alt-ergo-free-2.0.0/0000775000175000017500000000000013430774474011755 5ustar mimialt-ergo-free-2.0.0/README.md0000644000175000017500000000132213430774474013230 0ustar miminext | master ------------ | ------------- [![Travis-CI Build Status](https://travis-ci.org/OCamlPro/alt-ergo.svg?branch=next)](https://travis-ci.org/OCamlPro/alt-ergo) | [![Travis-CI Build Status](https://travis-ci.org/OCamlPro/alt-ergo.svg?branch=master)](https://travis-ci.org/OCamlPro/alt-ergo) # Alt-Ergo Alt-Ergo is an automatic theorem prover of mathematical formulas. It was developed at LRI, and is now maintained at OCamlPro: See more details on http://alt-ergo.ocamlpro.com/ ## Copyright See enclosed LICENSE.md file ## Build, Installation and Usage See enclosed sources/INSTALL.md file ## Support See http://alt-ergo.ocamlpro.com/support.php or contact us at contact@ocamlpro.com for more details alt-ergo-free-2.0.0/configure0000775000175000017500000031761613430774474013702 0ustar mimi#! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.69. # # # Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. # # # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH # Use a proper internal environment variable to ensure we don't fall # into an infinite loop, continuously re-executing ourselves. if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then _as_can_reexec=no; export _as_can_reexec; # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. $as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 as_fn_exit 255 fi # We don't want this to propagate to other subprocesses. { _as_can_reexec=; unset _as_can_reexec;} if test "x$CONFIG_SHELL" = x; then as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which # is contrary to our usage. Disable this feature. alias -g '\${1+\"\$@\"}'='\"\$@\"' setopt NO_GLOB_SUBST else case \`(set -o) 2>/dev/null\` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi " as_required="as_fn_return () { (exit \$1); } as_fn_success () { as_fn_return 0; } as_fn_failure () { as_fn_return 1; } as_fn_ret_success () { return 0; } as_fn_ret_failure () { return 1; } exitcode=0 as_fn_success || { exitcode=1; echo as_fn_success failed.; } as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : else exitcode=1; echo positional parameters were not saved. fi test x\$exitcode = x0 || exit 1 test -x / || exit 1" as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1" if (eval "$as_required") 2>/dev/null; then : as_have_required=yes else as_have_required=no fi if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR as_found=false for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. as_found=: case $as_dir in #( /*) for as_base in sh bash ksh sh5; do # Try only shells that exist, to save several forks. as_shell=$as_dir/$as_base if { test -f "$as_shell" || test -f "$as_shell.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : CONFIG_SHELL=$as_shell as_have_required=yes if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : break 2 fi fi done;; esac as_found=false done $as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : CONFIG_SHELL=$SHELL as_have_required=yes fi; } IFS=$as_save_IFS if test "x$CONFIG_SHELL" != x; then : export CONFIG_SHELL # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. $as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 exit 255 fi if test x$as_have_required = xno; then : $as_echo "$0: This script requires a shell more modern than all" $as_echo "$0: the shells that I found on your system." if test x${ZSH_VERSION+set} = xset ; then $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" $as_echo "$0: be upgraded to zsh 4.3.4 or later." else $as_echo "$0: Please tell bug-autoconf@gnu.org about your system, $0: including any error possibly output before this $0: message. Then install a modern shell, or manually run $0: the script under such a shell if you do have one." fi exit 1 fi fi fi SHELL=${CONFIG_SHELL-/bin/sh} export SHELL # Unset more variables known to interfere with behavior of common tools. CLICOLOR_FORCE= GREP_OPTIONS= unset CLICOLOR_FORCE GREP_OPTIONS ## --------------------- ## ## M4sh Shell Functions. ## ## --------------------- ## # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi $as_echo "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits as_lineno_1=$LINENO as_lineno_1a=$LINENO as_lineno_2=$LINENO as_lineno_2a=$LINENO eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) sed -n ' p /[$]LINENO/= ' <$as_myself | sed ' s/[$]LINENO.*/&-/ t lineno b :lineno N :loop s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ t loop s/-\n.*// ' >$as_me.lineno && chmod +x "$as_me.lineno" || { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } # If we had to re-execute with $CONFIG_SHELL, we're ensured to have # already done that, so ensure we don't try to do so again and fall # in an infinite loop. This has already happened in practice. _as_can_reexec=no; export _as_can_reexec # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensitive to this). . "./$as_me.lineno" # Exit status is that of the last command. exit } ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" test -n "$DJDIR" || exec 7<&0 &1 # Name of the host. # hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, # so uname gets run too. ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` # # Initializations. # ac_default_prefix=/usr/local ac_clean_files= ac_config_libobj_dir=. LIBOBJS= cross_compiling=no subdirs= MFLAGS= MAKEFLAGS= # Identity of this package. PACKAGE_NAME= PACKAGE_TARNAME= PACKAGE_VERSION= PACKAGE_STRING= PACKAGE_BUGREPORT= PACKAGE_URL= ac_unique_file="lib/util/options.ml" ac_subst_vars='LTLIBOBJS LIBOBJS EXE OCAMLWIN32 INCLUDEGTK2 ENABLEGUI OCPLIBSIMPLEXLIB LABLGTK2LIB CAMLZIPLIB ZARITHLIB OCAMLLIB OCAMLVERSION OCAMLBEST OCAMLWEB MENHIR OCAMLLEXDOTOPT OCAMLLEX OCAMLDEP OCAMLOPTDOTOPT OCAMLCDOTOPT OCAMLOPT USEOCAMLFIND OCAMLC target_alias host_alias build_alias LIBS ECHO_T ECHO_N ECHO_C DEFS mandir localedir libdir psdir pdfdir dvidir htmldir infodir docdir oldincludedir includedir runstatedir localstatedir sharedstatedir sysconfdir datadir datarootdir libexecdir sbindir bindir program_transform_name prefix exec_prefix PACKAGE_URL PACKAGE_BUGREPORT PACKAGE_STRING PACKAGE_VERSION PACKAGE_TARNAME PACKAGE_NAME PATH_SEPARATOR SHELL' ac_subst_files='' ac_user_opts=' enable_option_checking ' ac_precious_vars='build_alias host_alias target_alias' # Initialize some variables set by options. ac_init_help= ac_init_version=false ac_unrecognized_opts= ac_unrecognized_sep= # The variables have the same names as the options, with # dashes changed to underlines. cache_file=/dev/null exec_prefix=NONE no_create= no_recursion= prefix=NONE program_prefix=NONE program_suffix=NONE program_transform_name=s,x,x, silent= site= srcdir= verbose= x_includes=NONE x_libraries=NONE # Installation directory options. # These are left unexpanded so users can "make install exec_prefix=/foo" # and all the variables that are supposed to be based on exec_prefix # by default will actually change. # Use braces instead of parens because sh, perl, etc. also accept them. # (The list follows the same order as the GNU Coding Standards.) bindir='${exec_prefix}/bin' sbindir='${exec_prefix}/sbin' libexecdir='${exec_prefix}/libexec' datarootdir='${prefix}/share' datadir='${datarootdir}' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' runstatedir='${localstatedir}/run' includedir='${prefix}/include' oldincludedir='/usr/include' docdir='${datarootdir}/doc/${PACKAGE}' infodir='${datarootdir}/info' htmldir='${docdir}' dvidir='${docdir}' pdfdir='${docdir}' psdir='${docdir}' libdir='${exec_prefix}/lib' localedir='${datarootdir}/locale' mandir='${datarootdir}/man' ac_prev= ac_dashdash= for ac_option do # If the previous option needs an argument, assign it. if test -n "$ac_prev"; then eval $ac_prev=\$ac_option ac_prev= continue fi case $ac_option in *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; *=) ac_optarg= ;; *) ac_optarg=yes ;; esac # Accept the important Cygnus configure options, so we can diagnose typos. case $ac_dashdash$ac_option in --) ac_dashdash=yes ;; -bindir | --bindir | --bindi | --bind | --bin | --bi) ac_prev=bindir ;; -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) bindir=$ac_optarg ;; -build | --build | --buil | --bui | --bu) ac_prev=build_alias ;; -build=* | --build=* | --buil=* | --bui=* | --bu=*) build_alias=$ac_optarg ;; -cache-file | --cache-file | --cache-fil | --cache-fi \ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) ac_prev=cache_file ;; -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) cache_file=$ac_optarg ;; --config-cache | -C) cache_file=config.cache ;; -datadir | --datadir | --datadi | --datad) ac_prev=datadir ;; -datadir=* | --datadir=* | --datadi=* | --datad=*) datadir=$ac_optarg ;; -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ | --dataroo | --dataro | --datar) ac_prev=datarootdir ;; -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) datarootdir=$ac_optarg ;; -disable-* | --disable-*) ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=no ;; -docdir | --docdir | --docdi | --doc | --do) ac_prev=docdir ;; -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) docdir=$ac_optarg ;; -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) ac_prev=dvidir ;; -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) dvidir=$ac_optarg ;; -enable-* | --enable-*) ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=\$ac_optarg ;; -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ | --exec | --exe | --ex) ac_prev=exec_prefix ;; -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ | --exec=* | --exe=* | --ex=*) exec_prefix=$ac_optarg ;; -gas | --gas | --ga | --g) # Obsolete; use --with-gas. with_gas=yes ;; -help | --help | --hel | --he | -h) ac_init_help=long ;; -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) ac_init_help=recursive ;; -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) ac_init_help=short ;; -host | --host | --hos | --ho) ac_prev=host_alias ;; -host=* | --host=* | --hos=* | --ho=*) host_alias=$ac_optarg ;; -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) ac_prev=htmldir ;; -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ | --ht=*) htmldir=$ac_optarg ;; -includedir | --includedir | --includedi | --included | --include \ | --includ | --inclu | --incl | --inc) ac_prev=includedir ;; -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ | --includ=* | --inclu=* | --incl=* | --inc=*) includedir=$ac_optarg ;; -infodir | --infodir | --infodi | --infod | --info | --inf) ac_prev=infodir ;; -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) infodir=$ac_optarg ;; -libdir | --libdir | --libdi | --libd) ac_prev=libdir ;; -libdir=* | --libdir=* | --libdi=* | --libd=*) libdir=$ac_optarg ;; -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ | --libexe | --libex | --libe) ac_prev=libexecdir ;; -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ | --libexe=* | --libex=* | --libe=*) libexecdir=$ac_optarg ;; -localedir | --localedir | --localedi | --localed | --locale) ac_prev=localedir ;; -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) localedir=$ac_optarg ;; -localstatedir | --localstatedir | --localstatedi | --localstated \ | --localstate | --localstat | --localsta | --localst | --locals) ac_prev=localstatedir ;; -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) localstatedir=$ac_optarg ;; -mandir | --mandir | --mandi | --mand | --man | --ma | --m) ac_prev=mandir ;; -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) mandir=$ac_optarg ;; -nfp | --nfp | --nf) # Obsolete; use --without-fp. with_fp=no ;; -no-create | --no-create | --no-creat | --no-crea | --no-cre \ | --no-cr | --no-c | -n) no_create=yes ;; -no-recursion | --no-recursion | --no-recursio | --no-recursi \ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) no_recursion=yes ;; -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ | --oldin | --oldi | --old | --ol | --o) ac_prev=oldincludedir ;; -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) oldincludedir=$ac_optarg ;; -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) ac_prev=prefix ;; -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) prefix=$ac_optarg ;; -program-prefix | --program-prefix | --program-prefi | --program-pref \ | --program-pre | --program-pr | --program-p) ac_prev=program_prefix ;; -program-prefix=* | --program-prefix=* | --program-prefi=* \ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) program_prefix=$ac_optarg ;; -program-suffix | --program-suffix | --program-suffi | --program-suff \ | --program-suf | --program-su | --program-s) ac_prev=program_suffix ;; -program-suffix=* | --program-suffix=* | --program-suffi=* \ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) program_suffix=$ac_optarg ;; -program-transform-name | --program-transform-name \ | --program-transform-nam | --program-transform-na \ | --program-transform-n | --program-transform- \ | --program-transform | --program-transfor \ | --program-transfo | --program-transf \ | --program-trans | --program-tran \ | --progr-tra | --program-tr | --program-t) ac_prev=program_transform_name ;; -program-transform-name=* | --program-transform-name=* \ | --program-transform-nam=* | --program-transform-na=* \ | --program-transform-n=* | --program-transform-=* \ | --program-transform=* | --program-transfor=* \ | --program-transfo=* | --program-transf=* \ | --program-trans=* | --program-tran=* \ | --progr-tra=* | --program-tr=* | --program-t=*) program_transform_name=$ac_optarg ;; -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) ac_prev=pdfdir ;; -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) pdfdir=$ac_optarg ;; -psdir | --psdir | --psdi | --psd | --ps) ac_prev=psdir ;; -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) psdir=$ac_optarg ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; -runstatedir | --runstatedir | --runstatedi | --runstated \ | --runstate | --runstat | --runsta | --runst | --runs \ | --run | --ru | --r) ac_prev=runstatedir ;; -runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \ | --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \ | --run=* | --ru=* | --r=*) runstatedir=$ac_optarg ;; -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ | --sbi=* | --sb=*) sbindir=$ac_optarg ;; -sharedstatedir | --sharedstatedir | --sharedstatedi \ | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ | --sharedst | --shareds | --shared | --share | --shar \ | --sha | --sh) ac_prev=sharedstatedir ;; -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ | --sha=* | --sh=*) sharedstatedir=$ac_optarg ;; -site | --site | --sit) ac_prev=site ;; -site=* | --site=* | --sit=*) site=$ac_optarg ;; -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) ac_prev=srcdir ;; -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) srcdir=$ac_optarg ;; -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ | --syscon | --sysco | --sysc | --sys | --sy) ac_prev=sysconfdir ;; -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) sysconfdir=$ac_optarg ;; -target | --target | --targe | --targ | --tar | --ta | --t) ac_prev=target_alias ;; -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) target_alias=$ac_optarg ;; -v | -verbose | --verbose | --verbos | --verbo | --verb) verbose=yes ;; -version | --version | --versio | --versi | --vers | -V) ac_init_version=: ;; -with-* | --with-*) ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=\$ac_optarg ;; -without-* | --without-*) ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=no ;; --x) # Obsolete; use --with-x. with_x=yes ;; -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ | --x-incl | --x-inc | --x-in | --x-i) ac_prev=x_includes ;; -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) x_includes=$ac_optarg ;; -x-libraries | --x-libraries | --x-librarie | --x-librari \ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) ac_prev=x_libraries ;; -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; -*) as_fn_error $? "unrecognized option: \`$ac_option' Try \`$0 --help' for more information" ;; *=*) ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` # Reject names that are not valid shell variable names. case $ac_envvar in #( '' | [0-9]* | *[!_$as_cr_alnum]* ) as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; esac eval $ac_envvar=\$ac_optarg export $ac_envvar ;; *) # FIXME: should be removed in autoconf 3.0. $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" ;; esac done if test -n "$ac_prev"; then ac_option=--`echo $ac_prev | sed 's/_/-/g'` as_fn_error $? "missing argument to $ac_option" fi if test -n "$ac_unrecognized_opts"; then case $enable_option_checking in no) ;; fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; esac fi # Check all directory arguments for consistency. for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ libdir localedir mandir runstatedir do eval ac_val=\$$ac_var # Remove trailing slashes. case $ac_val in */ ) ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` eval $ac_var=\$ac_val;; esac # Be sure to have absolute directory names. case $ac_val in [\\/$]* | ?:[\\/]* ) continue;; NONE | '' ) case $ac_var in *prefix ) continue;; esac;; esac as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" done # There might be people who depend on the old broken behavior: `$host' # used to hold the argument of --host etc. # FIXME: To remove some day. build=$build_alias host=$host_alias target=$target_alias # FIXME: To remove some day. if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi fi ac_tool_prefix= test -n "$host_alias" && ac_tool_prefix=$host_alias- test "$silent" = yes && exec 6>/dev/null ac_pwd=`pwd` && test -n "$ac_pwd" && ac_ls_di=`ls -di .` && ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || as_fn_error $? "working directory cannot be determined" test "X$ac_ls_di" = "X$ac_pwd_ls_di" || as_fn_error $? "pwd does not report name of working directory" # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then the parent directory. ac_confdir=`$as_dirname -- "$as_myself" || $as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_myself" : 'X\(//\)[^/]' \| \ X"$as_myself" : 'X\(//\)$' \| \ X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_myself" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` srcdir=$ac_confdir if test ! -r "$srcdir/$ac_unique_file"; then srcdir=.. fi else ac_srcdir_defaulted=no fi if test ! -r "$srcdir/$ac_unique_file"; then test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" fi ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" ac_abs_confdir=`( cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" pwd)` # When building in place, set srcdir=. if test "$ac_abs_confdir" = "$ac_pwd"; then srcdir=. fi # Remove unnecessary trailing slashes from srcdir. # Double slashes in file names in object file debugging info # mess up M-x gdb in Emacs. case $srcdir in */) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; esac for ac_var in $ac_precious_vars; do eval ac_env_${ac_var}_set=\${${ac_var}+set} eval ac_env_${ac_var}_value=\$${ac_var} eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} eval ac_cv_env_${ac_var}_value=\$${ac_var} done # # Report the --help message. # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF \`configure' configures this package to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... To assign environment variables (e.g., CC, CFLAGS...), specify them as VAR=VALUE. See below for descriptions of some of the useful variables. Defaults for the options are specified in brackets. Configuration: -h, --help display this help and exit --help=short display options specific to this package --help=recursive display the short help of all the included packages -V, --version display version information and exit -q, --quiet, --silent do not print \`checking ...' messages --cache-file=FILE cache test results in FILE [disabled] -C, --config-cache alias for \`--cache-file=config.cache' -n, --no-create do not create output files --srcdir=DIR find the sources in DIR [configure dir or \`..'] Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX [$ac_default_prefix] --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX [PREFIX] By default, \`make install' will install all the files in \`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify an installation prefix other than \`$ac_default_prefix' using \`--prefix', for instance \`--prefix=\$HOME'. For better control, use the options below. Fine tuning of the installation directories: --bindir=DIR user executables [EPREFIX/bin] --sbindir=DIR system admin executables [EPREFIX/sbin] --libexecdir=DIR program executables [EPREFIX/libexec] --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] --runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] --datadir=DIR read-only architecture-independent data [DATAROOTDIR] --infodir=DIR info documentation [DATAROOTDIR/info] --localedir=DIR locale-dependent data [DATAROOTDIR/locale] --mandir=DIR man documentation [DATAROOTDIR/man] --docdir=DIR documentation root [DATAROOTDIR/doc/PACKAGE] --htmldir=DIR html documentation [DOCDIR] --dvidir=DIR dvi documentation [DOCDIR] --pdfdir=DIR pdf documentation [DOCDIR] --psdir=DIR ps documentation [DOCDIR] _ACEOF cat <<\_ACEOF _ACEOF fi if test -n "$ac_init_help"; then cat <<\_ACEOF Report bugs to the package provider. _ACEOF ac_status=$? fi if test "$ac_init_help" = "recursive"; then # If there are subdirs, report their specific --help. for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue test -d "$ac_dir" || { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || continue ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix cd "$ac_dir" || { ac_status=$?; continue; } # Check for guested configure. if test -f "$ac_srcdir/configure.gnu"; then echo && $SHELL "$ac_srcdir/configure.gnu" --help=recursive elif test -f "$ac_srcdir/configure"; then echo && $SHELL "$ac_srcdir/configure" --help=recursive else $as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 fi || ac_status=$? cd "$ac_pwd" || { ac_status=$?; break; } done fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF configure generated by GNU Autoconf 2.69 Copyright (C) 2012 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF exit fi ## ------------------------ ## ## Autoconf initialization. ## ## ------------------------ ## cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by $as_me, which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@ _ACEOF exec 5>>config.log { cat <<_ASUNAME ## --------- ## ## Platform. ## ## --------- ## hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` /bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` /bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` /usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` /bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` /bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` _ASUNAME as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. $as_echo "PATH: $as_dir" done IFS=$as_save_IFS } >&5 cat >&5 <<_ACEOF ## ----------- ## ## Core tests. ## ## ----------- ## _ACEOF # Keep a trace of the command line. # Strip out --no-create and --no-recursion so they do not pile up. # Strip out --silent because we don't want to record it for future runs. # Also quote any args containing shell meta-characters. # Make two passes to allow for proper duplicate-argument suppression. ac_configure_args= ac_configure_args0= ac_configure_args1= ac_must_keep_next=false for ac_pass in 1 2 do for ac_arg do case $ac_arg in -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) continue ;; *\'*) ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; 2) as_fn_append ac_configure_args1 " '$ac_arg'" if test $ac_must_keep_next = true; then ac_must_keep_next=false # Got value, back to normal. else case $ac_arg in *=* | --config-cache | -C | -disable-* | --disable-* \ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ | -with-* | --with-* | -without-* | --without-* | --x) case "$ac_configure_args0 " in "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; esac ;; -* ) ac_must_keep_next=true ;; esac fi as_fn_append ac_configure_args " '$ac_arg'" ;; esac done done { ac_configure_args0=; unset ac_configure_args0;} { ac_configure_args1=; unset ac_configure_args1;} # When interrupted or exit'd, cleanup temporary files, and complete # config.log. We remove comments because anyway the quotes in there # would cause problems or look ugly. # WARNING: Use '\'' to represent an apostrophe within the trap. # WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. trap 'exit_status=$? # Save into config.log some information that might help in debugging. { echo $as_echo "## ---------------- ## ## Cache variables. ## ## ---------------- ##" echo # The following way of writing the cache mishandles newlines in values, ( for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( *${as_nl}ac_space=\ *) sed -n \ "s/'\''/'\''\\\\'\'''\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" ;; #( *) sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) echo $as_echo "## ----------------- ## ## Output variables. ## ## ----------------- ##" echo for ac_var in $ac_subst_vars do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo if test -n "$ac_subst_files"; then $as_echo "## ------------------- ## ## File substitutions. ## ## ------------------- ##" echo for ac_var in $ac_subst_files do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo fi if test -s confdefs.h; then $as_echo "## ----------- ## ## confdefs.h. ## ## ----------- ##" echo cat confdefs.h echo fi test "$ac_signal" != 0 && $as_echo "$as_me: caught signal $ac_signal" $as_echo "$as_me: exit $exit_status" } >&5 rm -f core *.core core.conftest.* && rm -f -r conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status ' 0 for ac_signal in 1 2 13 15; do trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal done ac_signal=0 # confdefs.h avoids OS command line length limits that DEFS can exceed. rm -f -r conftest* confdefs.h $as_echo "/* confdefs.h */" > confdefs.h # Predefined preprocessor variables. cat >>confdefs.h <<_ACEOF #define PACKAGE_NAME "$PACKAGE_NAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_TARNAME "$PACKAGE_TARNAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_VERSION "$PACKAGE_VERSION" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_STRING "$PACKAGE_STRING" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_URL "$PACKAGE_URL" _ACEOF # Let the site file select an alternate cache file if it wants to. # Prefer an explicitly selected file to automatically selected ones. ac_site_file1=NONE ac_site_file2=NONE if test -n "$CONFIG_SITE"; then # We do not want a PATH search for config.site. case $CONFIG_SITE in #(( -*) ac_site_file1=./$CONFIG_SITE;; */*) ac_site_file1=$CONFIG_SITE;; *) ac_site_file1=./$CONFIG_SITE;; esac elif test "x$prefix" != xNONE; then ac_site_file1=$prefix/share/config.site ac_site_file2=$prefix/etc/config.site else ac_site_file1=$ac_default_prefix/share/config.site ac_site_file2=$ac_default_prefix/etc/config.site fi for ac_site_file in "$ac_site_file1" "$ac_site_file2" do test "x$ac_site_file" = xNONE && continue if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 $as_echo "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 . "$ac_site_file" \ || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "failed to load site script $ac_site_file See \`config.log' for more details" "$LINENO" 5; } fi done if test -r "$cache_file"; then # Some versions of bash will fail to source /dev/null (special files # actually), so we avoid doing that. DJGPP emulates it as a regular file. if test /dev/null != "$cache_file" && test -f "$cache_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 $as_echo "$as_me: loading cache $cache_file" >&6;} case $cache_file in [\\/]* | ?:[\\/]* ) . "$cache_file";; *) . "./$cache_file";; esac fi else { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 $as_echo "$as_me: creating cache $cache_file" >&6;} >$cache_file fi # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false for ac_var in $ac_precious_vars; do eval ac_old_set=\$ac_cv_env_${ac_var}_set eval ac_new_set=\$ac_env_${ac_var}_set eval ac_old_val=\$ac_cv_env_${ac_var}_value eval ac_new_val=\$ac_env_${ac_var}_value case $ac_old_set,$ac_new_set in set,) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then # differences in whitespace do not lead to failure. ac_old_val_w=`echo x $ac_old_val` ac_new_val_w=`echo x $ac_new_val` if test "$ac_old_val_w" != "$ac_new_val_w"; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 $as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} ac_cache_corrupted=: else { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 $as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} eval $ac_var=\$ac_old_val fi { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 $as_echo "$as_me: former value: \`$ac_old_val'" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 $as_echo "$as_me: current value: \`$ac_new_val'" >&2;} fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; *) ac_arg=$ac_var=$ac_new_val ;; esac case " $ac_configure_args " in *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. *) as_fn_append ac_configure_args " '$ac_arg'" ;; esac fi done if $ac_cache_corrupted; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 $as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 fi ## -------------------- ## ## Main body of script. ## ## -------------------- ## ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu # Check for Ocaml compilers # we first look for ocamlc in the path; if not present, we fail for ac_prog in ocp-ocamlc ocamlc do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OCAMLC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OCAMLC"; then ac_cv_prog_OCAMLC="$OCAMLC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLC="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi OCAMLC=$ac_cv_prog_OCAMLC if test -n "$OCAMLC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLC" >&5 $as_echo "$OCAMLC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$OCAMLC" && break done test -n "$OCAMLC" || OCAMLC="no" if test "$OCAMLC" = no ; then as_fn_error $? "Cannot find ocamlc." "$LINENO" 5 fi # we extract Ocaml version number and library path OCAMLVERSION=`$OCAMLC -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` echo "ocaml version is $OCAMLVERSION" OCAMLLIB=`$OCAMLC -v | tail -1 | cut -f 4 -d " " | tr -d '\\r'` echo "ocaml library path is $OCAMLLIB" SMTPRELUDE="/usr/local/lib/ergo/smt_prelude.mlw" case $OCAMLVERSION in 3.10.1+rc1) as_fn_error $? "Alt-Ergo does not compile with this version of Ocaml" "$LINENO" 5;; esac # we look for ocamlfind; if not present, we just don't use it to find # libraries # Extract the first word of "ocamlfind", so it can be a program name with args. set dummy ocamlfind; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_USEOCAMLFIND+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$USEOCAMLFIND"; then ac_cv_prog_USEOCAMLFIND="$USEOCAMLFIND" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_USEOCAMLFIND="yes" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_prog_USEOCAMLFIND" && ac_cv_prog_USEOCAMLFIND="no" fi fi USEOCAMLFIND=$ac_cv_prog_USEOCAMLFIND if test -n "$USEOCAMLFIND"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $USEOCAMLFIND" >&5 $as_echo "$USEOCAMLFIND" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$USEOCAMLFIND" = yes; then OCAMLFINDLIB=$(ocamlfind printconf stdlib) OCAMLFIND=$(which ocamlfind) if test "$OCAMLFINDLIB" != "$OCAMLLIB"; then USEOCAMLFIND=no; echo "but your ocamlfind is not compatible with your ocamlc:" echo "ocamlfind : $OCAMLFINDLIB, ocamlc : $OCAMLLIB" fi fi #looking for ocamlgraph library #if test "$USEOCAMLFIND" = yes; then # OCAMLGRAPHLIB=$(ocamlfind query -i-format ocamlgraph) #fi # #if test -n "$OCAMLGRAPHLIB";then # echo "ocamlfind found ocamlgraph in $OCAMLGRAPHLIB" # OCAMLGRAPH=yes #else # AC_CHECK_FILE($OCAMLLIB/ocamlgraph/graph.cmi,OCAMLGRAPH=yes,OCAMLGRAPH=no) # if test "$OCAMLGRAPH" = no ; then # AC_CHECK_FILE($OCAMLLIB/graph.cmi,OCAMLGRAPH=yes,OCAMLGRAPH=no) # if test "$OCAMLGRAPH" = no ; then # AC_MSG_ERROR(Cannot find ocamlgraph library. Please install the *libocamlgraph-ocaml-dev* Debian package - or use the GODI caml package system *http://godi.ocaml-programming.de/* - or compile from sources *http://ocamlgraph.lri.fr/*) # else # OCAMLGRAPHLIB="" # fi # else # OCAMLGRAPHLIB="-I +ocamlgraph" # fi #fi #looking for zarith library if test "$USEOCAMLFIND" = yes; then ZARITHLIB=$(ocamlfind query -i-format zarith) fi if test -n "$ZARITHLIB";then echo "ocamlfind found zarith in $ZARITHLIB" ZARITH=yes else as_ac_File=`$as_echo "ac_cv_file_$OCAMLLIB/zarith/zarith.cma" | $as_tr_sh` { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $OCAMLLIB/zarith/zarith.cma" >&5 $as_echo_n "checking for $OCAMLLIB/zarith/zarith.cma... " >&6; } if eval \${$as_ac_File+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "$OCAMLLIB/zarith/zarith.cma"; then eval "$as_ac_File=yes" else eval "$as_ac_File=no" fi fi eval ac_res=\$$as_ac_File { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } if eval test \"x\$"$as_ac_File"\" = x"yes"; then : ZARITH=yes else ZARITH=no fi if test "$ZARITH" = no ; then as_ac_File=`$as_echo "ac_cv_file_$OCAMLLIB/zarith.cma" | $as_tr_sh` { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $OCAMLLIB/zarith.cma" >&5 $as_echo_n "checking for $OCAMLLIB/zarith.cma... " >&6; } if eval \${$as_ac_File+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "$OCAMLLIB/zarith.cma"; then eval "$as_ac_File=yes" else eval "$as_ac_File=no" fi fi eval ac_res=\$$as_ac_File { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } if eval test \"x\$"$as_ac_File"\" = x"yes"; then : ZARITH=yes else ZARITH=no fi if test "$ZARITH" = no ; then as_fn_error $? "Cannot find zarith library." "$LINENO" 5 else ZARITHLIB="" fi else ZARITHLIB="-I +zarith" fi fi #looking for camlzip library if test "$USEOCAMLFIND" = yes; then CAMLZIPLIB=$(ocamlfind query -i-format camlzip) fi if test -n "$CAMLZIPLIB";then echo "ocamlfind found camlzip in $CAMLZIPLIB" CAMLZIP=yes else as_ac_File=`$as_echo "ac_cv_file_$OCAMLLIB/zip/zip.cma" | $as_tr_sh` { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $OCAMLLIB/zip/zip.cma" >&5 $as_echo_n "checking for $OCAMLLIB/zip/zip.cma... " >&6; } if eval \${$as_ac_File+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "$OCAMLLIB/zip/zip.cma"; then eval "$as_ac_File=yes" else eval "$as_ac_File=no" fi fi eval ac_res=\$$as_ac_File { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } if eval test \"x\$"$as_ac_File"\" = x"yes"; then : CAMLZIP=yes else CAMLZIP=no fi if test "$CAMLZIP" = no ; then as_ac_File=`$as_echo "ac_cv_file_$OCAMLLIB/zip.cma" | $as_tr_sh` { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $OCAMLLIB/zip.cma" >&5 $as_echo_n "checking for $OCAMLLIB/zip.cma... " >&6; } if eval \${$as_ac_File+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "$OCAMLLIB/zip.cma"; then eval "$as_ac_File=yes" else eval "$as_ac_File=no" fi fi eval ac_res=\$$as_ac_File { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } if eval test \"x\$"$as_ac_File"\" = x"yes"; then : CAMLZIP=yes else CAMLZIP=no fi if test "$CAMLZIP" = no ; then as_fn_error $? "Cannot find camlzip library." "$LINENO" 5 else CAMLZIPLIB="" fi else CAMLZIPLIB="-I +zip" fi fi #looking for ocplib-simplex library if test "$USEOCAMLFIND" = yes; then OCPLIBSIMPLEXLIB=$(ocamlfind query -i-format ocplib-simplex) fi if test -n "$OCPLIBSIMPLEXLIB";then echo "ocamlfind found ocplib-simplex in $OCPLIBSIMPLEXLIB" else as_fn_error $? "Cannot find ocplib-simplex library." "$LINENO" 5 fi # then we look for ocamlopt; if not present, we issue a warning # if the version is not the same, we also discard it # we set OCAMLBEST to "opt" or "byte", whether ocamlopt is available or not for ac_prog in ocp-ocamlopt ocamlopt do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OCAMLOPT+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OCAMLOPT"; then ac_cv_prog_OCAMLOPT="$OCAMLOPT" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLOPT="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi OCAMLOPT=$ac_cv_prog_OCAMLOPT if test -n "$OCAMLOPT"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLOPT" >&5 $as_echo "$OCAMLOPT" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$OCAMLOPT" && break done test -n "$OCAMLOPT" || OCAMLOPT="no" OCAMLBEST=byte if test "$OCAMLOPT" = no ; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Cannot find ocamlopt; bytecode compilation only." >&5 $as_echo "$as_me: WARNING: Cannot find ocamlopt; bytecode compilation only." >&2;} else { $as_echo "$as_me:${as_lineno-$LINENO}: checking ocamlopt version" >&5 $as_echo_n "checking ocamlopt version... " >&6; } TMPVERSION=`$OCAMLOPT -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` if test "$TMPVERSION" != "$OCAMLVERSION" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: differs from ocamlc; ocamlopt discarded." >&5 $as_echo "differs from ocamlc; ocamlopt discarded." >&6; } OCAMLOPT=no else { $as_echo "$as_me:${as_lineno-$LINENO}: result: ok" >&5 $as_echo "ok" >&6; } OCAMLBEST=opt fi fi # checking for ocamlc.opt for ac_prog in ocp-ocamlc.opt ocamlc.opt do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OCAMLCDOTOPT+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OCAMLCDOTOPT"; then ac_cv_prog_OCAMLCDOTOPT="$OCAMLCDOTOPT" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLCDOTOPT="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi OCAMLCDOTOPT=$ac_cv_prog_OCAMLCDOTOPT if test -n "$OCAMLCDOTOPT"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLCDOTOPT" >&5 $as_echo "$OCAMLCDOTOPT" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$OCAMLCDOTOPT" && break done test -n "$OCAMLCDOTOPT" || OCAMLCDOTOPT="no" if test "$OCAMLCDOTOPT" != no ; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking ocamlc.opt version" >&5 $as_echo_n "checking ocamlc.opt version... " >&6; } TMPVERSION=`$OCAMLCDOTOPT -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` if test "$TMPVERSION" != "$OCAMLVERSION" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: differs from ocamlc; ocamlc.opt discarded." >&5 $as_echo "differs from ocamlc; ocamlc.opt discarded." >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: ok" >&5 $as_echo "ok" >&6; } OCAMLC=$OCAMLCDOTOPT fi fi # checking for ocamlopt.opt if test "$OCAMLOPT" != no ; then for ac_prog in ocp-ocamlopt.opt ocamlopt.opt do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OCAMLOPTDOTOPT+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OCAMLOPTDOTOPT"; then ac_cv_prog_OCAMLOPTDOTOPT="$OCAMLOPTDOTOPT" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLOPTDOTOPT="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi OCAMLOPTDOTOPT=$ac_cv_prog_OCAMLOPTDOTOPT if test -n "$OCAMLOPTDOTOPT"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLOPTDOTOPT" >&5 $as_echo "$OCAMLOPTDOTOPT" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$OCAMLOPTDOTOPT" && break done test -n "$OCAMLOPTDOTOPT" || OCAMLOPTDOTOPT="no" if test "$OCAMLOPTDOTOPT" != no ; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking ocamlc.opt version" >&5 $as_echo_n "checking ocamlc.opt version... " >&6; } TMPVER=`$OCAMLOPTDOTOPT -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` if test "$TMPVER" != "$OCAMLVERSION" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: differs from ocamlc; ocamlopt.opt discarded." >&5 $as_echo "differs from ocamlc; ocamlopt.opt discarded." >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: ok" >&5 $as_echo "ok" >&6; } OCAMLOPT=$OCAMLOPTDOTOPT fi fi fi # ocamldep, ocamllex and ocamlyacc should also be present in the path # Extract the first word of "ocamldep", so it can be a program name with args. set dummy ocamldep; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OCAMLDEP+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OCAMLDEP"; then ac_cv_prog_OCAMLDEP="$OCAMLDEP" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLDEP="ocamldep" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_prog_OCAMLDEP" && ac_cv_prog_OCAMLDEP="no" fi fi OCAMLDEP=$ac_cv_prog_OCAMLDEP if test -n "$OCAMLDEP"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLDEP" >&5 $as_echo "$OCAMLDEP" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$OCAMLDEP" = no ; then as_fn_error $? "Cannot find ocamldep." "$LINENO" 5 fi # Extract the first word of "ocamllex", so it can be a program name with args. set dummy ocamllex; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OCAMLLEX+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OCAMLLEX"; then ac_cv_prog_OCAMLLEX="$OCAMLLEX" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLLEX="ocamllex" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_prog_OCAMLLEX" && ac_cv_prog_OCAMLLEX="no" fi fi OCAMLLEX=$ac_cv_prog_OCAMLLEX if test -n "$OCAMLLEX"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLLEX" >&5 $as_echo "$OCAMLLEX" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$OCAMLLEX" = no ; then as_fn_error $? "Cannot find ocamllex." "$LINENO" 5 else # Extract the first word of "ocamllex.opt", so it can be a program name with args. set dummy ocamllex.opt; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OCAMLLEXDOTOPT+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OCAMLLEXDOTOPT"; then ac_cv_prog_OCAMLLEXDOTOPT="$OCAMLLEXDOTOPT" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLLEXDOTOPT="ocamllex.opt" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_prog_OCAMLLEXDOTOPT" && ac_cv_prog_OCAMLLEXDOTOPT="no" fi fi OCAMLLEXDOTOPT=$ac_cv_prog_OCAMLLEXDOTOPT if test -n "$OCAMLLEXDOTOPT"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLLEXDOTOPT" >&5 $as_echo "$OCAMLLEXDOTOPT" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$OCAMLLEXDOTOPT" != no ; then OCAMLLEX=$OCAMLLEXDOTOPT fi fi #AC_CHECK_PROG(OCAMLYACC,ocamlyacc,ocamlyacc,no) #if test "$OCAMLYACC" = no ; then # AC_MSG_ERROR(Cannot find ocamlyacc.) #fi # Extract the first word of "menhir", so it can be a program name with args. set dummy menhir; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_MENHIR+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$MENHIR"; then ac_cv_prog_MENHIR="$MENHIR" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_MENHIR="menhir" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_prog_MENHIR" && ac_cv_prog_MENHIR="no" fi fi MENHIR=$ac_cv_prog_MENHIR if test -n "$MENHIR"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $MENHIR" >&5 $as_echo "$MENHIR" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "$MENHIR" = no ; then as_fn_error $? "Cannot find menhir." "$LINENO" 5 fi # checking for lablgtk2 if test "$USEOCAMLFIND" = yes; then LABLGTK2LIB=$(ocamlfind query -i-format lablgtk2.sourceview2) fi if test -n "$LABLGTK2LIB";then echo "ocamlfind found lablgtk2.sourceview2 in $LABLGTK2LIB" LABLGTK2=yes ENABLEGUI="yes" else as_ac_File=`$as_echo "ac_cv_file_$OCAMLLIB/lablgtk2/lablgtksourceview2.cma" | $as_tr_sh` { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $OCAMLLIB/lablgtk2/lablgtksourceview2.cma" >&5 $as_echo_n "checking for $OCAMLLIB/lablgtk2/lablgtksourceview2.cma... " >&6; } if eval \${$as_ac_File+:} false; then : $as_echo_n "(cached) " >&6 else test "$cross_compiling" = yes && as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 if test -r "$OCAMLLIB/lablgtk2/lablgtksourceview2.cma"; then eval "$as_ac_File=yes" else eval "$as_ac_File=no" fi fi eval ac_res=\$$as_ac_File { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } if eval test \"x\$"$as_ac_File"\" = x"yes"; then : LABLGTK2=yes else LABLGTK2=no fi if test "$LABLGTK2" = no ; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: Will not be able to compile GUI. Please install the *liblablgtksourceview2-ocaml-dev* Debian package - or use the GODI caml package system *http://godi.ocaml-programming.de/* - or compile from sources *http://wwwfun.kurims.kyoto-u.ac.jp/soft/lsl/lablgtk.html*" >&5 $as_echo "Will not be able to compile GUI. Please install the *liblablgtksourceview2-ocaml-dev* Debian package - or use the GODI caml package system *http://godi.ocaml-programming.de/* - or compile from sources *http://wwwfun.kurims.kyoto-u.ac.jp/soft/lsl/lablgtk.html*" >&6; } else LABLGTK2LIB="-I +lablgtk2" ENABLEGUI="yes" fi fi #When LABLGTK2 is used threads is needed if test -n "$LABLGTK2LIB";then LABLGTK2LIB="$LABLGTK2LIB -I +threads" fi # Extract the first word of "ocamlweb", so it can be a program name with args. set dummy ocamlweb; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_OCAMLWEB+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$OCAMLWEB"; then ac_cv_prog_OCAMLWEB="$OCAMLWEB" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_OCAMLWEB="ocamlweb" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_prog_OCAMLWEB" && ac_cv_prog_OCAMLWEB="true" fi fi OCAMLWEB=$ac_cv_prog_OCAMLWEB if test -n "$OCAMLWEB"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLWEB" >&5 $as_echo "$OCAMLWEB" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi # platform { $as_echo "$as_me:${as_lineno-$LINENO}: checking platform" >&5 $as_echo_n "checking platform... " >&6; } if echo "let _ = Sys.os_type;;" | ocaml | grep -q Win32; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: Win32" >&5 $as_echo "Win32" >&6; } OCAMLWIN32=yes EXE=.exe else OCAMLWIN32=no EXE= fi # substitutions to perform #AC_SUBST(OCAMLYACC) #AC_SUBST(OCAMLGRAPHLIB) # Finally create the Makefile.configurable from Makefile.configurable.in ac_config_files="$ac_config_files Makefile.configurable" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure # scripts and configure runs, see configure's option --config-cache. # It is not useful on other systems. If it contains results you don't # want to keep, you may remove or edit it. # # config.status only pays attention to the cache file if you give it # the --recheck option to rerun configure. # # `ac_cv_env_foo' variables (set or unset) will be overridden when # loading this file, other *unset* `ac_cv_foo' will be assigned the # following values. _ACEOF # The following way of writing the cache mishandles newlines in values, # but we know of no workaround that is simple, portable, and efficient. # So, we kill variables containing newlines. # Ultrix sh set writes to stderr and can't be redirected directly, # and sets the high bit in the cache file unless we assign to the vars. ( for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space=' '; set) 2>&1` in #( *${as_nl}ac_space=\ *) # `set' does not quote correctly, so add quotes: double-quote # substitution turns \\\\ into \\, and sed turns \\ into \. sed -n \ "s/'/'\\\\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" ;; #( *) # `set' quotes correctly as required by POSIX, so do not add quotes. sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) | sed ' /^ac_cv_env_/b end t clear :clear s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ t end s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ :end' >>confcache if diff "$cache_file" confcache >/dev/null 2>&1; then :; else if test -w "$cache_file"; then if test "x$cache_file" != "x/dev/null"; then { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 $as_echo "$as_me: updating cache $cache_file" >&6;} if test ! -f "$cache_file" || test -h "$cache_file"; then cat confcache >"$cache_file" else case $cache_file in #( */* | ?:*) mv -f confcache "$cache_file"$$ && mv -f "$cache_file"$$ "$cache_file" ;; #( *) mv -f confcache "$cache_file" ;; esac fi fi else { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 $as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} fi fi rm -f confcache test "x$prefix" = xNONE && prefix=$ac_default_prefix # Let make expand exec_prefix. test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' # Transform confdefs.h into DEFS. # Protect against shell expansion while executing Makefile rules. # Protect against Makefile macro expansion. # # If the first sed substitution is executed (which looks for macros that # take arguments), then branch to the quote section. Otherwise, # look for a macro that doesn't take arguments. ac_script=' :mline /\\$/{ N s,\\\n,, b mline } t clear :clear s/^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\)/-D\1=\2/g t quote s/^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\)/-D\1=\2/g t quote b any :quote s/[ `~#$^&*(){}\\|;'\''"<>?]/\\&/g s/\[/\\&/g s/\]/\\&/g s/\$/$$/g H :any ${ g s/^\n// s/\n/ /g p } ' DEFS=`sed -n "$ac_script" confdefs.h` ac_libobjs= ac_ltlibobjs= U= for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue # 1. Remove the extension, and $U if already installed. ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' ac_i=`$as_echo "$ac_i" | sed "$ac_script"` # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR # will be set to the directory where LIBOBJS objects are built. as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' done LIBOBJS=$ac_libobjs LTLIBOBJS=$ac_ltlibobjs : "${CONFIG_STATUS=./config.status}" ac_write_fail=0 ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 $as_echo "$as_me: creating $CONFIG_STATUS" >&6;} as_write_fail=0 cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 #! $SHELL # Generated by $as_me. # Run this file to recreate the current configuration. # Compiler output produced by configure, useful for debugging # configure, is in config.log if it exists. debug=false ac_cs_recheck=false ac_cs_silent=false SHELL=\${CONFIG_SHELL-$SHELL} export SHELL _ASEOF cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi $as_echo "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" exec 6>&1 ## ----------------------------------- ## ## Main body of $CONFIG_STATUS script. ## ## ----------------------------------- ## _ASEOF test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Save the log message, to keep $0 and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" This file was extended by $as_me, which was generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ on `(hostname || uname -n) 2>/dev/null | sed 1q` " _ACEOF case $ac_config_files in *" "*) set x $ac_config_files; shift; ac_config_files=$*;; esac cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 # Files that config.status was made for. config_files="$ac_config_files" _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 ac_cs_usage="\ \`$as_me' instantiates files and other configuration actions from templates according to the current configuration. Unless the files and actions are specified as TAGs, all are instantiated by default. Usage: $0 [OPTION]... [TAG]... -h, --help print this help, then exit -V, --version print version number and configuration settings, then exit --config print configuration, then exit -q, --quiet, --silent do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions --file=FILE[:TEMPLATE] instantiate the configuration file FILE Configuration files: $config_files Report bugs to the package provider." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ config.status configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" Copyright (C) 2012 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." ac_pwd='$ac_pwd' srcdir='$srcdir' test -n "\$AWK" || AWK=awk _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # The default lists apply if the user does not specify any file. ac_need_defaults=: while test $# != 0 do case $1 in --*=?*) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` ac_shift=: ;; --*=) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg= ac_shift=: ;; *) ac_option=$1 ac_optarg=$2 ac_shift=shift ;; esac case $ac_option in # Handling of the options. -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) ac_cs_recheck=: ;; --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) $as_echo "$ac_cs_version"; exit ;; --config | --confi | --conf | --con | --co | --c ) $as_echo "$ac_cs_config"; exit ;; --debug | --debu | --deb | --de | --d | -d ) debug=: ;; --file | --fil | --fi | --f ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; '') as_fn_error $? "missing file argument" ;; esac as_fn_append CONFIG_FILES " '$ac_optarg'" ac_need_defaults=false;; --he | --h | --help | --hel | -h ) $as_echo "$ac_cs_usage"; exit ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil | --si | --s) ac_cs_silent=: ;; # This is an error. -*) as_fn_error $? "unrecognized option: \`$1' Try \`$0 --help' for more information." ;; *) as_fn_append ac_config_targets " $1" ac_need_defaults=false ;; esac shift done ac_configure_extra_args= if $ac_cs_silent; then exec 6>/dev/null ac_configure_extra_args="$ac_configure_extra_args --silent" fi _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 if \$ac_cs_recheck; then set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion shift \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 CONFIG_SHELL='$SHELL' export CONFIG_SHELL exec "\$@" fi _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 exec 5>>config.log { echo sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX ## Running $as_me. ## _ASBOX $as_echo "$ac_log" } >&5 _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Handling of arguments. for ac_config_target in $ac_config_targets do case $ac_config_target in "Makefile.configurable") CONFIG_FILES="$CONFIG_FILES Makefile.configurable" ;; *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; esac done # If the user did not use the arguments to specify the items to instantiate, # then the envvar interface is used. Set only those that are not. # We use the long form for the default assignment because of an extremely # bizarre bug on SunOS 4.1.3. if $ac_need_defaults; then test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files fi # Have a temporary directory for convenience. Make it in the build tree # simply because there is no reason against having it here, and in addition, # creating and moving files from /tmp can sometimes cause problems. # Hook for its removal unless debugging. # Note that there is a small window in which the directory will not be cleaned: # after its creation but before its name has been assigned to `$tmp'. $debug || { tmp= ac_tmp= trap 'exit_status=$? : "${ac_tmp:=$tmp}" { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status ' 0 trap 'as_fn_exit 1' 1 2 13 15 } # Create a (secure) tmp directory for tmp files. { tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && test -d "$tmp" } || { tmp=./conf$$-$RANDOM (umask 077 && mkdir "$tmp") } || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 ac_tmp=$tmp # Set up the scripts for CONFIG_FILES section. # No need to generate them if there are no CONFIG_FILES. # This happens for instance with `./config.status config.h'. if test -n "$CONFIG_FILES"; then ac_cr=`echo X | tr X '\015'` # On cygwin, bash can eat \r inside `` if the user requested igncr. # But we know of no other shell where ac_cr would be empty at this # point, so we can use a bashism as a fallback. if test "x$ac_cr" = x; then eval ac_cr=\$\'\\r\' fi ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then ac_cs_awk_cr='\\r' else ac_cs_awk_cr=$ac_cr fi echo 'BEGIN {' >"$ac_tmp/subs1.awk" && _ACEOF { echo "cat >conf$$subs.awk <<_ACEOF" && echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && echo "_ACEOF" } >conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` ac_delim='%!_!# ' for ac_last_try in false false false false false :; do . ./conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` if test $ac_delim_n = $ac_delim_num; then break elif $ac_last_try; then as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi done rm -f conf$$subs.sh cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && _ACEOF sed -n ' h s/^/S["/; s/!.*/"]=/ p g s/^[^!]*!// :repl t repl s/'"$ac_delim"'$// t delim :nl h s/\(.\{148\}\)..*/\1/ t more1 s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ p n b repl :more1 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t nl :delim h s/\(.\{148\}\)..*/\1/ t more2 s/["\\]/\\&/g; s/^/"/; s/$/"/ p b :more2 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t delim ' >$CONFIG_STATUS || ac_write_fail=1 rm -f conf$$subs.awk cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACAWK cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && for (key in S) S_is_set[key] = 1 FS = "" } { line = $ 0 nfields = split(line, field, "@") substed = 0 len = length(field[1]) for (i = 2; i < nfields; i++) { key = field[i] keylen = length(key) if (S_is_set[key]) { value = S[key] line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) len += length(value) + length(field[++i]) substed = 1 } else len += 1 + keylen } print line } _ACAWK _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" else cat fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 _ACEOF # VPATH may cause trouble with some makes, so we remove sole $(srcdir), # ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and # trailing colons and then remove the whole line if VPATH becomes empty # (actually we leave an empty line to preserve line numbers). if test "x$srcdir" = x.; then ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ h s/// s/^/:/ s/[ ]*$/:/ s/:\$(srcdir):/:/g s/:\${srcdir}:/:/g s/:@srcdir@:/:/g s/^:*// s/:*$// x s/\(=[ ]*\).*/\1/ G s/\n// s/^[^=]*=[ ]*$// }' fi cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 fi # test -n "$CONFIG_FILES" eval set X " :F $CONFIG_FILES " shift for ac_tag do case $ac_tag in :[FHLC]) ac_mode=$ac_tag; continue;; esac case $ac_mode$ac_tag in :[FHL]*:*);; :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; :[FH]-) ac_tag=-:-;; :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; esac ac_save_IFS=$IFS IFS=: set x $ac_tag IFS=$ac_save_IFS shift ac_file=$1 shift case $ac_mode in :L) ac_source=$1;; :[FH]) ac_file_inputs= for ac_f do case $ac_f in -) ac_f="$ac_tmp/stdin";; *) # Look for the file first in the build tree, then in the source tree # (if the path is not absolute). The absolute path cannot be DOS-style, # because $ac_f cannot contain `:'. test -f "$ac_f" || case $ac_f in [\\/$]*) false;; *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; esac || as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; esac case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac as_fn_append ac_file_inputs " '$ac_f'" done # Let's still pretend it is `configure' which instantiates (i.e., don't # use $as_me), people would be surprised to read: # /* config.h. Generated by config.status. */ configure_input='Generated from '` $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' `' by configure.' if test x"$ac_file" != x-; then configure_input="$ac_file. $configure_input" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 $as_echo "$as_me: creating $ac_file" >&6;} fi # Neutralize special characters interpreted by sed in replacement strings. case $configure_input in #( *\&* | *\|* | *\\* ) ac_sed_conf_input=`$as_echo "$configure_input" | sed 's/[\\\\&|]/\\\\&/g'`;; #( *) ac_sed_conf_input=$configure_input;; esac case $ac_tag in *:-:* | *:-) cat >"$ac_tmp/stdin" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac ;; esac ac_dir=`$as_dirname -- "$ac_file" || $as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$ac_file" : 'X\(//\)[^/]' \| \ X"$ac_file" : 'X\(//\)$' \| \ X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$ac_file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` as_dir="$ac_dir"; as_fn_mkdir_p ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix case $ac_mode in :F) # # CONFIG_FILE # _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # If the template does not know about datarootdir, expand it. # FIXME: This hack should be removed a few years after 2.60. ac_datarootdir_hack=; ac_datarootdir_seen= ac_sed_dataroot=' /datarootdir/ { p q } /@datadir@/p /@docdir@/p /@infodir@/p /@localedir@/p /@mandir@/p' case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in *datarootdir*) ac_datarootdir_seen=yes;; *@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 $as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_datarootdir_hack=' s&@datadir@&$datadir&g s&@docdir@&$docdir&g s&@infodir@&$infodir&g s&@localedir@&$localedir&g s&@mandir@&$mandir&g s&\\\${datarootdir}&$datarootdir&g' ;; esac _ACEOF # Neutralize VPATH when `$srcdir' = `.'. # Shell code in configure.ac might set extrasub. # FIXME: do we really want to maintain this feature? cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_sed_extra="$ac_vpsub $extrasub _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 :t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b s|@configure_input@|$ac_sed_conf_input|;t t s&@top_builddir@&$ac_top_builddir_sub&;t t s&@top_build_prefix@&$ac_top_build_prefix&;t t s&@srcdir@&$ac_srcdir&;t t s&@abs_srcdir@&$ac_abs_srcdir&;t t s&@top_srcdir@&$ac_top_srcdir&;t t s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t s&@builddir@&$ac_builddir&;t t s&@abs_builddir@&$ac_abs_builddir&;t t s&@abs_top_builddir@&$ac_abs_top_builddir&;t t $ac_datarootdir_hack " eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ "$ac_tmp/out"`; test -z "$ac_out"; } && { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&5 $as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&2;} rm -f "$ac_tmp/stdin" case $ac_file in -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; esac \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac done # for ac_tag as_fn_exit 0 _ACEOF ac_clean_files=$ac_clean_files_save test $ac_write_fail = 0 || as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 # configure is writing to config.log, and then calls config.status. # config.status does its own redirection, appending to config.log. # Unfortunately, on DOS this fails, as config.log is still kept open # by configure, so config.status won't be able to write to it; its # output is simply discarded. So we exec the FD to /dev/null, # effectively closing config.log, so it can be properly (re)opened and # appended to by config.status. When coming back to configure, we # need to make the FD available again. if test "$no_create" != yes; then ac_cs_success=: ac_config_status_args= test "$silent" = yes && ac_config_status_args="$ac_config_status_args --quiet" exec 5>/dev/null $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false exec 5>>config.log # Use ||, not &&, to avoid exiting from the if with $? = 1, which # would make configure fail if this is the last instruction. $ac_cs_success || as_fn_exit 1 fi if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} fi chmod a-w Makefile.configurable alt-ergo-free-2.0.0/Makefile.configurable.in0000664000175000017500000000242113430774474016460 0ustar mimi # sample Makefile for Objective Caml # Copyright (C) 2001 Jean-Christophe FILLIATRE # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License version 2, as published by the Free Software Foundation. # # This library 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 Library General Public License version 2 for more details # (enclosed in the file LGPL). # where to install the binaries DESTDIR= prefix=@prefix@ exec_prefix=@exec_prefix@ BINDIR=$(DESTDIR)@bindir@ LIBDIR=$(DESTDIR)@libdir@/alt-ergo PLUGINSDIR=$(LIBDIR)/plugins PRELUDESDIR=$(LIBDIR)/preludes DATADIR=$(DESTDIR)@datadir@/alt-ergo # where to install the man page MANDIR=$(DESTDIR)@mandir@ # other variables set by ./configure OCAMLC = @OCAMLC@ OCAMLOPT = @OCAMLOPT@ OCAMLDEP = @OCAMLDEP@ OCAMLLEX = @OCAMLLEX@ #OCAMLYACC= @OCAMLYACC@ MENHIR= @MENHIR@ OCAMLBEST = @OCAMLBEST@ OCAMLVERSION = @OCAMLVERSION@ OCAMLWIN32 = @OCAMLWIN32@ EXE = @EXE@ ENABLEGUI = @ENABLEGUI@ ZARITHLIB=@ZARITHLIB@ CAMLZIPLIB=@CAMLZIPLIB@ #OCAMLGRAPHLIB=@OCAMLGRAPHLIB@ LABLGTK2LIB=@LABLGTK2LIB@ OCPLIBSIMPLEXLIB=@OCPLIBSIMPLEXLIB@ alt-ergo-free-2.0.0/Makefile0000664000175000017500000000012213430774474013410 0ustar mimiinclude Makefile.configurable include Makefile.users -include Makefile.developers alt-ergo-free-2.0.0/Makefile.developers0000664000175000017500000001473313430774474015574 0ustar mimiCOMMIT_ID = $(shell git log -1 | grep commit | cut -d " " -f 2) edit: emacs lib/*/*ml* tools/text/*.ml* tools/gui/*.ml* parsers/*/*.ml* plugins/*/*.ml* & # Modules Architecture ############################################################################### poor-archi: .depend cat .depend | ocamldot | dot -Tpdf > poor-archi.pdf rich-archi:opt gui ocamldoc.opt $(INCLUDES) -dot -dot-reduce -dot-include-all lib/util/*.ml lib/structures/*.ml lib/reasoners/*.ml lib/frontend/*.ml tools/text/*.ml tools/gui/*.ml \ parsers/why/*.ml lib/util/*.mli lib/structures/*.mli lib/reasoners/*.mli lib/frontend/*.mli tools/text/*.mli tools/gui/*.mli parsers/why/*.mli -verbose grep -v "}" ocamldoc.out > archi.dot rm ocamldoc.out cat ../extra/subgraphs.dot >> archi.dot echo "}" >> archi.dot dot -Tpdf archi.dot > archi.pdf archi:$(NAME).byte $(GUINAME).byte ocamldoc.opt $(INCLUDES) -dot -dot-reduce lib/util/*.ml lib/structures/*.ml lib/reasoners/*.ml lib/frontend/*.ml tools/text/*.ml tools/gui/*.ml \ parsers/why/*.ml lib/util/*.mli lib/structures/*.mli lib/reasoners/*.mli lib/frontend/*.mli tools/text/*.mli tools/gui/*.mli parsers/why/*.mli -verbose grep -v "}" ocamldoc.out > archi.dot rm ocamldoc.out cat ../extra/subgraphs.dot >> archi.dot echo "}" >> archi.dot dot -Tpdf archi.dot > archi.pdf evince archi.pdf 2> /dev/null > /dev/null & # try-alt-ergo ########################################################################################## try-alt-ergo: make clean cp -rf ../alt-ergo ../try-alt-ergo/ cp -rf ../try-alt-ergo/extra/Makefile ../try-alt-ergo/alt-ergo/ cp -rf ../try-alt-ergo/extra/Makefile.js ../try-alt-ergo/alt-ergo/ cp -rf ../try-alt-ergo/lib-num ../try-alt-ergo/alt-ergo/ cp -rf ../try-alt-ergo/js ../try-alt-ergo/alt-ergo/ cp -rf ../try-alt-ergo/extra/src__main__main_js.ml ../try-alt-ergo/alt-ergo/tools/javascript/main_js.ml cp -rf ../try-alt-ergo/extra/src__util__myUnix.ml ../try-alt-ergo/alt-ergo/lib/util/myUnix.ml cp -rf ../try-alt-ergo/extra/src__util__numbers.ml ../try-alt-ergo/alt-ergo/lib/util/numbers.ml cp -rf ../try-alt-ergo/extra/src__util__myZip.ml ../try-alt-ergo/alt-ergo/lib/util/myZip.ml make depend -C ../try-alt-ergo/alt-ergo make byte -C ../try-alt-ergo/alt-ergo make try -C ../try-alt-ergo/alt-ergo cp ../try-alt-ergo/alt-ergo/try-alt-ergo.js ../try-alt-ergo/html-interface/try-alt-ergo/alt-ergo.js firefox ../try-alt-ergo/html-interface/try.html try-alt-ergo-mini: make clean cp -rf ../alt-ergo ../try-alt-ergo/ cp -rf ../try-alt-ergo/extra/Makefile ../try-alt-ergo/alt-ergo/ cp -rf ../try-alt-ergo/extra/Makefile.js ../try-alt-ergo/alt-ergo/ cp -rf ../try-alt-ergo/lib-num ../try-alt-ergo/alt-ergo/ cp -rf ../try-alt-ergo/js ../try-alt-ergo/alt-ergo/ cp -rf ../try-alt-ergo/extra/src__main__main_js_mini.ml ../try-alt-ergo/alt-ergo/tools/javascript/main_js.ml cp -rf ../try-alt-ergo/extra/src__util__myUnix.ml ../try-alt-ergo/alt-ergo/lib/util/myUnix.ml cp -rf ../try-alt-ergo/extra/src__util__numbers.ml ../try-alt-ergo/alt-ergo/lib/util/numbers.ml cp -rf ../try-alt-ergo/extra/src__util__myZip.ml ../try-alt-ergo/alt-ergo/lib/util/myZip.ml make depend -C ../try-alt-ergo/alt-ergo make byte -C ../try-alt-ergo/alt-ergo make try -C ../try-alt-ergo/alt-ergo cp ../try-alt-ergo/alt-ergo/try-alt-ergo.js ../try-alt-ergo/html-interface/try-alt-ergo/alt-ergo-mini.js firefox ../try-alt-ergo/html-interface/try-mini.html # TESTS ########################################################################################## non-regression:$(OPT) satML fm-simplex cp alt-ergo.opt ../non-regression/alt-ergo.opt cd ../non-regression && ./non-regression.sh rm ../non-regression/alt-ergo.opt # try to make all the targets ########################################################################################## test-everything: make configure ./configure --prefix=`pwd`/test-make-everything rm -rf `pwd`/test-make-everything mkdir `pwd`/test-make-everything make show-dest-dirs make depend make all make gui make alt-ergo.byte make opt make alt-ergo.opt make altgr-ergo.opt make byte make altgr-ergo.byte make satML make fm-simplex make satML-plugin.cma make fm-simplex-plugin.cma make satML-plugin.cmxs make fm-simplex-plugin.cmxs make non-regression make archi make META make install-opt make install make install-byte make install-satML make install-fm-simplex make install-gui make install-man make stripped-arch-binary # make try-alt-ergo # make public-release # also performs opam-public, which needs public-export # headers ############## headers: cd ../extra/headers && ./headers.sh # STATIC ########################################################################################## BIBBYTE_STATIC = zarith.cma nums.cma unix.cma str.cma zip.cma # = BIBBYTE minus dynlink.cma BIBOPT_STATIC = $(BIBBYTE_STATIC:.cma=.cmxa) hide-dynlink-in-wrapper-MyDynlink: sed -i 's/include Dynlink/include DummyDL/g' lib/util/myDynlink.ml static: hide-dynlink-in-wrapper-MyDynlink depend $(MAINCMX) $(OCAMLOPT) -ccopt -static $(OFLAGS) -o $@ $(BIBOPT_STATIC) $(MAINCMX) sed -i 's/include DummyDL/include Dynlink/g' lib/util/myDynlink.ml strip $@ mv static alt-ergo-static-$(VERSION)-$(ARCH) # PUBLIC RELEASES ########################################################################################## PUBLIC_VERSION=$(VERSION) PUBLIC_RELEASE=alt-ergo-free-$(PUBLIC_VERSION) PUBLIC_TARGZ=$(PUBLIC_RELEASE).tar.gz FILES_DEST=../public-release/$(PUBLIC_RELEASE)/$(PUBLIC_RELEASE) public-release: # test-everything rm -rf ../public-release mkdir -p $(FILES_DEST) cp configure $(FILES_DEST) git clean -dfx cp ../License.OCamlPro ../LGPL-License.txt ../Apache-License-2.0.txt $(FILES_DEST)/ cp ../README.md ../LICENSE.md ../COPYING.md $(FILES_DEST)/ cp configure.in Makefile.configurable.in Makefile.users Makefile Makefile.developers $(FILES_DEST)/ cp INSTALL.md opam CHANGES $(FILES_DEST)/ cp -rf lib tools parsers plugins preludes examples doc $(FILES_DEST)/ #echo "let version=\"$(PUBLIC_VERSION)\"" >> $(FILES_DEST)/lib/util/version.ml echo "let release_commit = \"$(COMMIT_ID)\"" >> $(FILES_DEST)/lib/util/version.ml echo "let release_date = \""`LANG=en_US; date`"\"" >> $(FILES_DEST)/lib/util/version.ml cd $(FILES_DEST)/.. && tar cfz $(PUBLIC_TARGZ) $(PUBLIC_RELEASE) rm -rf $(FILES_DEST) autoconf && ./configure # Targets that work only after the modification in Makefile.XX and/or Alt-Ergo ############################################################################### bisect-report: bisect-report -dump - -html report bisect*.out alt-ergo-free-2.0.0/plugins/0000775000175000017500000000000013430774474013436 5ustar mimialt-ergo-free-2.0.0/plugins/fm-simplex/0000775000175000017500000000000013430774474015517 5ustar mimialt-ergo-free-2.0.0/plugins/fm-simplex/fmSimplexIneqs.mli0000664000175000017500000000150613430774474021170 0ustar mimi(******************************************************************************) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the license indicated *) (* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) (* present, please contact us to clarify licensing. *) (* *) (******************************************************************************) (* empty interface file *) alt-ergo-free-2.0.0/plugins/fm-simplex/simplex.ml0000664000175000017500000010424013430774474017533 0ustar mimi(******************************************************************************) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the license indicated *) (* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) (* present, please contact us to clarify licensing. *) (* *) (******************************************************************************) open Options open Format open Numbers module H = Hashtbl type pred = Eq | Ge | Le | Gt let dsimplex = ref false (******************************************************************************) module type Coef_Type = sig type t = Q.t val zero : t val one : t val m_one : t val is_zero : t -> bool val is_one : t -> bool val compare : t -> t -> int val equal : t -> t -> bool val to_string : t -> string val add : t -> t -> t val sub : t -> t -> t val mult : t -> t -> t val div : t -> t -> t val minus : t -> t end type t_c2 = Q.t * Q.t type t1 = { mutable a : (int * Q.t) array; mutable c : Q.t * Q.t} type t2 = { mutable a2 : Q.t array; mutable c2 : Q.t * Q.t} type rich_result = { vof : t_c2; vals : (int * t_c2) list; ctx : (int * t2) list; distr : int array; order : int Queue.t} type result = | Unsat of rich_result | Unbound of rich_result | Max of rich_result | Eq_unsat module Simplex (C : Coef_Type) = struct exception Out of int module C2 = struct type t = C.t * C.t let zero = C.zero, C.zero let concrete c = c, C.zero let abstract c = c, C.m_one (* -1, car on a p + (-eps) > 0 *) let to_string (c,k) = "(" ^ (C.to_string c) ^ " + " ^ (C.to_string k) ^ "*e)" let add (c1,k1) (c2,k2) = C.add c1 c2, C.add k1 k2 let mult c1 (c2,k2) = C.mult c1 c2, C.mult c1 k2 let is_zero (c, k) = C.is_zero c && C.is_zero k let is_one (c, k) = C.is_one c && C.is_one k let compare (c1,k1) (c2,k2) = let r = C.compare c1 c2 in if r <> 0 then r else C.compare k1 k2 let div (c1,k1) c = C.div c1 c, C.div k1 c let minus (c,k) = C.minus c, C.minus k end type sbt = {old_lhs:int; lhs:int; rhs:t2} let boung_ghost = -1 module D = struct let matrix_stats matrix co = if !dsimplex then begin fprintf fmt "taille: %d x %d@." (Array.length co.a2) (List.length matrix); let z = ref 0 in let nz = ref 0 in List.iter (fun (_,{a2=a2}) -> Array.iter (fun v -> incr (if Q.is_zero v then z else nz)) a2 )matrix; fprintf fmt "zero-cells: %d@." !z; fprintf fmt "non-zero-cells: %d@." !nz end let expand s n = let rec exrec s n = if n <= -1 then s else exrec (" "^s) (n-1) in exrec s (n-(String.length s)) let poly0 fmt l = List.iter (fun (si,c) -> fprintf fmt "%sL%d + " (C.to_string c) si) l; fprintf fmt "0" let poly fmt {a=a;c=c} = Array.iter (fun (si,c) -> fprintf fmt "%sL%d + " (C.to_string c) si) a; fprintf fmt "%s" (C2.to_string c) let poly01 fmt {a=a; c=c} = for i = 1 to Array.length a - 2 do fprintf fmt "%s" (expand (C.to_string (snd a.(i))) 2) done let pred = function | Eq -> "=" | Ge -> ">=" | Gt -> ">" | Le -> "<=" let sep = "----------------------------------------------------------------" let given_problem co eqs s_neq nb_vars = if !dsimplex then begin fprintf fmt "%s@." sep; fprintf fmt "I am given a problem of size %d:@." nb_vars; fprintf fmt "max: %a;@." poly0 co; List.iter (fun (x,(pp, pn, ctt)) -> fprintf fmt " (%a) + (%a) + %s = 0;@." poly0 pp poly0 pn (Q.to_string ctt) ) eqs; fprintf fmt " %a > 0;@." poly0 s_neq; fprintf fmt "%s@." sep; end let max_poly {a2=a2} = Array.fold_left (fun n v -> max n (String.length (C.to_string v))) 0 a2 let max_sys ctx = List.fold_left (fun n (_,p) -> max n (max_poly p)) 0 ctx let expand s n = let rec exrec s n = if n <= -1 then s else exrec (" "^s) (n-1) in exrec s (n-(String.length s)) let ppoly sp fmt {a2=a2; c2=c2} = Array.iter (fun c -> fprintf fmt "%s" (expand (C.to_string c) sp)) a2; fprintf fmt " %s@." (C2.to_string c2) let auxiliary_problem sbt s_neq co h_i_s = if !dsimplex then begin fprintf fmt "%s@.Associations:@." sep; H.iter(fun i j -> fprintf fmt "L(%d) -> %d@." j i)h_i_s; fprintf fmt "subst:@."; List.iter (fun ((s,i),p) ->fprintf fmt "(L%d,%d) |-> %a@." s i poly p) sbt; fprintf fmt "s_neq:@."; let (s, i), pneq = s_neq in fprintf fmt "(L%d,%d) |-> %a@." s i poly pneq; fprintf fmt "cost:@."; fprintf fmt "%a@." poly co; fprintf fmt "%s@." sep end let compacted_problem basic non_basic matrix co = if !dsimplex then begin let sp = max (max_sys matrix) (max_poly co) in fprintf fmt "%s@." sep; fprintf fmt "compacted_problem:@."; fprintf fmt "> non_basic vars:@."; H.iter (fun i s -> fprintf fmt "L%i |-> %d@." s i) non_basic; fprintf fmt "@.> basic vars:@."; H.iter (fun i s -> fprintf fmt "L%i |-> %d@." s i) basic; fprintf fmt "@.> matrix:@."; List.iter (fun (i,p) -> fprintf fmt "%d |-> %a" i (ppoly sp) p) matrix; fprintf fmt "@.> cost: %a@.@." (ppoly sp) co; fprintf fmt "%s@." sep end let psystem fmt (ctx, co, distr) = fprintf fmt "@.tbl: "; Array.iteri (fun i s -> fprintf fmt "%d -> L%d | " i s) distr; fprintf fmt "@.@."; let sp = max (max_sys ctx) (max_poly co) in List.iter (fun (i,p) -> fprintf fmt "%d = %a" i (ppoly sp) p) ctx; fprintf fmt "cost = %a@." (ppoly sp) co let report_unsat ctx co distr = if !dsimplex then begin fprintf fmt "%s@." sep; fprintf fmt "pb aux's result:(E_unsat)@.%a@." psystem (ctx,co,distr); fprintf fmt "%s@." sep; end let report_max ctx co distr = if !dsimplex then begin fprintf fmt "%s@." sep; fprintf fmt "pb aux's result:(E_max)@.%a@." psystem (ctx,co,distr); fprintf fmt "%s@." sep; end let given_problem2 ctx co distr = if !dsimplex then begin fprintf fmt "%s@." sep; fprintf fmt "[solve] given pb:@.%a@." psystem (ctx,co, distr); fprintf fmt "%s@." sep end let in_simplex ctx co distr = if !dsimplex then begin fprintf fmt "%s@." sep; fprintf fmt "@.[simplex]@. I start with:@.%a@." psystem (ctx,co, distr); fprintf fmt "%s@." sep end let result_extraction status ctx co distr = if !dsimplex then begin fprintf fmt "::RESULT EXTRACTION FROM:::::::::::::::::::::::::::::::::::::::@."; fprintf fmt "The problem is %s@." status; fprintf fmt "%a@." psystem (ctx,co, distr); fprintf fmt ":::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::@."; end let retrieved_cost co = if !dsimplex then fprintf fmt "retrieved_const: %a@." (ppoly 4) co let pline fmt (i,p) = let sp = max_poly p in fprintf fmt "x%d = %a" i (ppoly sp) p let psbt fmt sbt = let sp = max_poly sbt.rhs in fprintf fmt "%d |-> %a / (old %d)@." sbt.lhs (ppoly sp)sbt.rhs sbt.old_lhs let choosed_var ch_vr = if !dsimplex then fprintf fmt "choosed var's index: %d@." ch_vr let choosed_eq ch_eq = if !dsimplex then fprintf fmt "choosed eq: %a@." pline ch_eq let pivot_result sbt = if !dsimplex then fprintf fmt "pivot's result: %a@." psbt sbt let change_pivot ch_vr old_vr = if !dsimplex then fprintf fmt "ch_vr: %d et old_vr: %d@." ch_vr old_vr let init_simplex_pb ctx co distr ghost line = if !dsimplex then begin fprintf fmt "%s@." sep; fprintf fmt "init_simplex: pb_aux@.%a@." psystem (ctx,co,distr); fprintf fmt "choosed var's index: %d@." ghost; fprintf fmt "choosed eq: %a@." pline line; fprintf fmt "%s@." sep end end module Normalizer = struct exception Trivial exception Inconsistent exception Pivot of int * int * C.t let array_is_null ar = let len = Array.length ar in let is_null = ref true in let i = ref 0 in while !i < len && !is_null do is_null := C.is_zero ar.(!i); incr i; done; !is_null let coefs_have_mem_sign ar = let len = Array.length ar in let nb_pos = ref 0 in let nb_neg = ref 0 in let i = ref 0 in while !i < len && (!nb_pos = 0 || !nb_neg = 0) do let c = C.compare (snd ar.(!i)) C.zero in if c > 0 then incr nb_pos; if c < 0 then decr nb_neg; incr i; done; match !nb_pos, !nb_neg with | 0, 0 -> Some 0 | 0, ng -> Some ng | ps, 0 -> Some ps | _ -> None let create len (lpos, lneg, ctt) tbl_i_s = let a = Array.init len (fun i -> i, Q.zero) in (* BUG CORRIGE*) let f1 (i,c)= a.(i) <- i,c in List.iter f1 lpos; List.iter f1 lneg; a.(0) <- -1, C.zero; a.(len-1) <- 1-len, C.zero; { a = a; c = C2.concrete ctt } let create_strict len s_neq tbl_i_s = { (create len (s_neq,[],Q.zero) tbl_i_s) with c = C2.abstract C.zero } let mult_const a c v = let f2 i (s,cs) = a.(i) <- s, C.zero in let g2 i (s,cs) = () in let h2 i (s,cs) = a.(i) <- s, C.mult v cs in let k = if C.is_zero v then f2 else if C.is_one v then g2 else h2 in Array.iteri k a; {a=a ; c = C2.mult v c} let pivot_in_p len {a=a; c=c} = try for i = 0 to len - 1 do let s, v = a.(i) in if not (C.is_zero v) then raise (Pivot (s,i,v)) done; if C2.is_zero c then raise Trivial else raise Inconsistent with Pivot (s,ind,v) -> a.(ind) <- s, C.zero; (s, ind), mult_const a c (C.div C.m_one v) let subst_in_p ({a=a ; c=c} as pp) ((s,lhs), {a=rhs_a; c=rhs_c}) = let s', v = a.(lhs) in (*assert (String.compare s s' = 0);*) if not (C.is_zero v) then begin a.(lhs) <- s, C.zero; let f6a j (sw,w) = let sj, vj = rhs_a.(j) in if not (C.is_zero vj) then a.(j) <- sj, C.add vj w in let f6b j (sw,w) = let sj, vj = rhs_a.(j) in if not (C.is_zero vj) then a.(j) <- sj, C.add (C.mult v vj) w in let f6 = if C.is_one v then f6a else f6b in Array.iteri f6 a; pp.c <- C2.add c (C2.mult v rhs_c) end let z_subst_in_p p s = p.a.(s) <- s, C.zero let normalize_poly p sbt zsbt = for i = 0 to Vec.size sbt - 1 do subst_in_p p (Vec.get sbt i) done; for i = 0 to Vec.size zsbt - 1 do z_subst_in_p p (Vec.get zsbt i) done let normalize_sbt sbt zsbt = for i = 0 to Vec.size sbt - 1 do for j = 0 to Vec.size zsbt - 1 do z_subst_in_p (snd (Vec.get sbt i)) (Vec.get zsbt j) done; done; for i = Vec.size sbt - 1 downto 1 do for j = i - 1 downto 0 do subst_in_p (snd (Vec.get sbt j)) (Vec.get sbt i) done; done; let l1 = ref [] in let l2 = ref [] in for i = 0 to Vec.size sbt - 1 do l1 := (Vec.get sbt i) :: !l1 done; for i = 0 to Vec.size zsbt - 1 do l2 := (Vec.get zsbt i) :: !l2 done; !l2, !l1 let sbt = Vec.make 107 ((0,0),{a=[||]; c=Q.zero, Q.zero}) let zsbt = Vec.make 107 (-2) let solve_zero_arr zsbt zsbt_inv a = Array.iter (fun (s,coef) -> if not (C.is_zero coef) then begin Vec.push zsbt s; zsbt_inv.(s) <- true end )a let solve_zero_list zsbt zsbt_inv l = if !dsimplex then fprintf fmt "[eq_solve] 0 = 0 (modulo Li >= 0)@."; List.iter (fun (s,coef) -> if not zsbt_inv.(s) then begin Vec.push zsbt s; zsbt_inv.(s) <- true end )l let substs_from_equalities eqs h_i_s len = if !dsimplex then fprintf fmt "subst from eqs:@."; Vec.clear sbt; Vec.clear zsbt; let zsbt_inv = Array.make len false in let eqs = List.fold_left (fun acc (x,((lp,ln, ctt) as lp_ln)) -> (* lp + ln + ctt = 0 *) let sg = Q.sign ctt in let p = (create len lp_ln h_i_s) in if !dsimplex then fprintf fmt " >> poly %a@." D.poly p; match lp, ln with | [], [] -> assert false | _::_, [] when sg = 0 -> solve_zero_list zsbt zsbt_inv lp; acc | [], _::_ when sg = 0 -> solve_zero_list zsbt zsbt_inv ln; acc | _::_, [] when sg > 0 -> raise Inconsistent | [], _::_ when sg < 0 -> raise Inconsistent | _ -> (create len lp_ln h_i_s)::acc )[] eqs in (*let mm = ref [] in*) List.iter (fun p -> (*mm := {c=p.c ; a = Array.copy p.a} :: !mm;*) if !dsimplex then fprintf fmt "[eq_solve] solve 0 = %a@." D.poly p; normalize_poly p sbt zsbt; if !dsimplex then fprintf fmt "i.e. [eq_solve] solve 0 = %a@." D.poly p; try match coefs_have_mem_sign p.a with | Some n -> let c = C2.compare p.c C2.zero in if n = 0 && c <> 0 then raise Inconsistent; if n > 0 && c > 0 then raise Inconsistent; if n < 0 && c < 0 then raise Inconsistent; if n <> 0 && c = 0 then solve_zero_arr zsbt zsbt_inv p.a; if n <> 0 && c <> 0 then let ((s, pivot), p) as ln = pivot_in_p len p in if !dsimplex then fprintf fmt "new pivot (L%d,%d) |-> %a@.@." s pivot D.poly p; Vec.push sbt ln | _ -> let ((s, pivot), p) as ln = pivot_in_p len p in if !dsimplex then fprintf fmt "new pivot (L%d,%d) |-> %a@.@." s pivot D.poly p; Vec.push sbt ln with Trivial -> () )eqs; normalize_sbt sbt zsbt (* let mm = !mm in let mmT = List.fast_sort (fun {a=a1} {a=a2} -> try for i = 0 to Array.length a1 -1 do let _, c1 = a1.(i) in let _, c2 = a2.(i) in if C.is_zero c1 then raise (Out 1); if C.is_zero c2 then raise (Out (-1)); let c = C.compare c1 c2 in if c <> 0 then raise (Out c) done; 0 with Out c -> c ) mm in fprintf fmt "MM@."; List.iter (fun p -> fprintf fmt "%a@." D.poly01 p; )mm; fprintf fmt "MMT@."; List.iter (fun p -> fprintf fmt "%a@." D.poly01 p; )mmT; *) let make_problem co eqs s_neq len = let h_i_s = H.create len in for i = 1 to len - 2 do H.add h_i_s i i done; H.add h_i_s 0 (-1); H.add h_i_s (len-1) (1-len); if !dsimplex then fprintf fmt "make_problem: len = %d (incluant les neqs et ghost)@." len; let zsbt, sbt = substs_from_equalities eqs h_i_s len in if !dsimplex then begin fprintf fmt "ZERO substs:@."; List.iter (fun i -> fprintf fmt "L%i -> 0 ; " i) zsbt; fprintf fmt "@." end; let p_sneq = create_strict len s_neq h_i_s in List.iter (subst_in_p p_sneq) sbt; List.iter (z_subst_in_p p_sneq) zsbt; let s_neq = (1 - len, len - 1) , p_sneq in let co = create len (co, [], Q.zero) h_i_s in List.iter (subst_in_p co) sbt; List.iter (z_subst_in_p co) zsbt; D.auxiliary_problem sbt s_neq co h_i_s; co, s_neq :: sbt, zsbt let compact_poly_2 {a=a ; c=c} base new_len h_zsbt = let non_basic = H.create 101 in let old_i = ref 0 in let f3 i = while H.mem base !old_i || H.mem h_zsbt !old_i do incr old_i done; let s, c = a.(!old_i) in H.add non_basic i s; incr old_i; c in {a2=Array.init new_len f3 ; c2=c}, non_basic let compact_poly {a=a ; c=c} base new_len h_zsbt = let old_i = ref 0 in let f4 i = while H.mem base !old_i || H.mem h_zsbt !old_i do incr old_i done; let s, coef = a.(!old_i) in incr old_i; coef in { a2 = Array.init new_len f4; c2=c } (* XXX : Faire des simplifications pour eliminer les lignes triviales de la matrice de la forme s_i |-> ctt ??? XXX : Faire des simplifications pour eliminer les colonnes nulles ??? *) let compact_problem co matrix len new_len zsbt = let base = H.create 101 in let basic = H.create 101 in List.iter (fun ((s,i),p) -> H.add base i 0) matrix; let h_zsbt = H.create (List.length zsbt) in List.iter (fun i -> H.add h_zsbt i ()) zsbt; let matrix, _ = List.fold_left (fun (matrix,cptL) ((s,i),p) -> let p = compact_poly p base new_len h_zsbt in H.add basic cptL s; (cptL, p)::matrix, cptL + 1 )([],new_len) matrix in let matrix = List.fold_left (fun acc ((i, p) as line) -> if !dsimplex then fprintf fmt "compact_problem: LINE %a@." D.pline line; if array_is_null p.a2 then let c = C2.compare p.c2 C2.zero in if c = 0 then acc else if c < 0 then raise Inconsistent else line :: acc (* CONSTANT SOLUTION: SHOULD EXTRACT IT*) else line :: acc )[] matrix in let co, non_basic = compact_poly_2 co base new_len h_zsbt in D.compacted_problem basic non_basic matrix co; let distr = Array.init len (fun i -> try H.find basic i with Not_found -> try H.find non_basic i with Not_found -> if !dsimplex then fprintf fmt "Colonne vide ! donc supprimee@."; -20000) in co, matrix, distr let norm_main co eqs s_neq nb_vars = let len = nb_vars + 2 in (* ghost + one slack var *) let co, matrix, zsbt = make_problem co eqs s_neq len in let new_len = len - (List.length matrix) - (List.length zsbt) in if !dsimplex then fprintf fmt "new_len = %d (excluant les pivots)@." new_len; compact_problem co matrix len new_len zsbt end (************************************************************************) module Core_Simplex = struct type system = (int * t2) list * t2 type i_result = | I_unsat of system | I_unbound of system | I_max of system exception E_max of system exception E_unbound of system exception E_unsat of system let len = ref (-1) let co_opt: t2 option ref = ref None let v_ghost = "!ghost" let main_simplex = ref true (*debut utile *) let reset_refs length = len := length; co_opt := None; main_simplex := true let index_of_ghost distr = try Array.iteri (fun i s -> if s = boung_ghost then raise (Out i)) distr; assert false with Out i -> i let line_with_min_const ctx = match ctx with | [] -> assert false | line :: ctx -> List.fold_left (fun ((_,p') as line') ((_,p) as line) -> if C2.compare p.c2 p'.c2 < 0 then line else line') line ctx let subst ({a2=a2; c2=c2} as pp) lhs {a2=rhs_a2; c2=rhs_c2} = let v = a2.(lhs) in if not (C.is_zero v) then begin a2.(lhs) <- C.zero; let f7a j w = let rhs_j = rhs_a2.(j) in if not (C.is_zero rhs_j) then a2.(j) <- C.add rhs_j w in let f7b j w = let rhs_j = rhs_a2.(j) in if not (C.is_zero rhs_j) then a2.(j) <- C.add (C.mult v rhs_j) w in let f7 = if C.is_one v then f7a else f7b in Array.iteri f7 a2; pp.c2 <- C2.add c2 (C2.mult v rhs_c2) end let subst_line {old_lhs=old_lhs; lhs=lhs; rhs=rhs} (i, p) = if i = old_lhs then begin p.a2 <- rhs.a2; p.c2 <- rhs.c2 end else subst p lhs rhs let subst_ctx ctx sbt = List.iter (subst_line sbt) ctx (*fin utile *) (*** coeur du simplex ********************************************************) exception Choose_index of int let choose_var ctx co (q,lines) = try for j = 0 to !len - 1 do let i = Queue.pop q in Queue.push i q; if C.compare co.a2.(i) C.zero > 0 then raise (Choose_index i) done; raise (E_max (ctx,co)) with Choose_index ind -> ind let choose_eq ctx co ch_vr = let acc = ref None in List.iter (fun ((j,p) as line) -> let v_ch_vr = p.a2.(ch_vr) in if C.compare v_ch_vr C.zero < 0 then let rap = C2.minus (C2.div p.c2 v_ch_vr) in match !acc with | None -> acc := Some (v_ch_vr, rap, line) | Some (v_r,r,(jj,_)) -> let delta = C2.compare rap r in let change = delta < 0 || (delta = 0 && j < jj) in if change then acc := Some (v_ch_vr, rap, line) )ctx; match !acc with | None -> raise (E_unbound (ctx,co)) | Some (_, _, eq) -> eq let mult_const a2 c2 v = let f5 i cs = a2.(i) <- C.zero in let g5 i cs = () in let h5 i cs = a2.(i) <- C.mult v cs in let k = if C.is_zero v then f5 else if C.is_one v then g5 else h5 in Array.iteri k a2; {a2=a2 ; c2 = C2.mult v c2} let change_pivot ch_vr (old_vr, {a2=old_a; c2=c2}) distr order = D.change_pivot ch_vr old_vr; (* update_distr *) let tmp = distr.(ch_vr) in distr.(ch_vr) <- distr.(old_vr); distr.(old_vr) <- tmp; let v = old_a.(ch_vr) in old_a.(ch_vr) <- C.m_one; {old_lhs=old_vr; lhs=ch_vr; rhs= mult_const old_a c2 (C.div C.m_one v)} let cpt = ref 0 let last_cost = ref (Q.zero, Q.zero) let loops distr order co_cst = if C2.compare co_cst ! last_cost = 0 then begin incr cpt; let limit = max (Queue.length (fst order)) (Array.length distr) in !cpt >= limit end else begin last_cost := co_cst; cpt := 0; false end let nbloops = ref 0 let rec simplex ctx co distr order = (* let ppoly fmt {a2=a2; c2=c2} = Array.iter (fun c -> fprintf fmt "%s " (C.to_string c)) a2; fprintf fmt " %s@." (C2.to_string c2) in let psystem fmt (ctx, co, distr) = fprintf fmt "@.tbl: "; Array.iteri (fun i s -> fprintf fmt "%d -> %s | " i s) distr; fprintf fmt "@.@."; List.iter (fun (i,p) -> fprintf fmt "%d = %a" i ppoly p) ctx; fprintf fmt "cost = %a@." ppoly co in fprintf fmt "@.#########################################################@."; fprintf fmt "%a" psystem (ctx, co, distr); fprintf fmt "@.#########################################################@."; *) if !main_simplex && loops distr order co.c2 then raise (E_max(ctx,co)); incr nbloops; (* fprintf fmt "nb_loops = %d @." !nbloops; fprintf fmt "ici: main = %b : %s @." !main_simplex (C2.to_string co.c2); (*D.matrix_stats ctx co;*) *) if !main_simplex && C.compare (fst co.c2) C.zero >= 0 && C.compare (snd co.c2) C.zero >= 0 then raise (E_max(ctx,co)); D.in_simplex ctx co distr; let ch_vr = choose_var ctx co order in D.choosed_var ch_vr; let ch_eq = choose_eq ctx co ch_vr in D.choosed_eq ch_eq; let sbt = change_pivot ch_vr ch_eq distr order in D.pivot_result sbt; begin match !co_opt with None -> () | Some coo -> subst coo sbt.lhs sbt.rhs; co_opt := Some coo end; subst_ctx ctx sbt; subst co sbt.lhs sbt.rhs; simplex ctx co distr order (*** / coeur du simplex ******************************************************) (*** coeur du simplex_init *************************************************) let delete_ghost ghost ghost_p ctx distr order = let ch_vr = ref 0 in try for i = 0 to !len - 1 do if C.compare ghost_p.a2.(i) C.zero <> 0 then (ch_vr := i; raise Exit) done; failwith "Pas possible" with Exit -> let sbt = change_pivot !ch_vr (ghost, ghost_p) distr order in D.choosed_var !ch_vr; D.pivot_result sbt; subst_ctx ctx sbt; ctx let report_unsat distr order ctx co = D.report_unsat ctx co distr; let ghost = try index_of_ghost distr with Not_found -> assert false in if ghost < !len then begin List.iter (fun (_,p) -> p.a2.(ghost) <- C.zero) ctx; ctx, true end else try let p_ghost = List.assoc ghost ctx in let ctx = delete_ghost ghost p_ghost ctx distr order in let ghost = index_of_ghost distr in assert (ghost < !len); List.iter (fun (_,p) -> p.a2.(ghost) <- C.zero) ctx; ctx, true with Not_found -> assert false let report_max distr order ctx co = D.report_max ctx co distr; let ghost = try index_of_ghost distr with Not_found -> assert false in if ghost < !len then begin List.iter (fun (_,p) -> if not ((Array.length p.a2) == !len) then failwith (sprintf "len = %d but plen = %d" !len (Array.length p.a2)); p.a2.(ghost) <- C.zero) ctx; ctx, false end else try let p_ghost = List.assoc ghost ctx in let ctx = delete_ghost ghost p_ghost ctx distr order in let ghost = index_of_ghost distr in assert (ghost < !len); List.iter (fun (_,p) -> p.a2.(ghost) <- C.zero) ctx; ctx, C2.compare p_ghost.c2 C2.zero <> 0 with Not_found -> assert false (* chercher une solution initiale *) let init_simplex ctx ((_,p) as line) distr order = let ghost = index_of_ghost distr in List.iter (fun (_,p) -> p.a2.(ghost) <- C.one) ctx; let co_a2 = Array.make (Array.length p.a2) C.zero in co_a2.(ghost) <- C.m_one; let co = {a2=co_a2; c2= C2.zero} in D.init_simplex_pb ctx co distr ghost line; (* choix du premier pivot sur la variable fantome *) let sbt = change_pivot ghost line distr order in D.pivot_result sbt; subst_ctx ctx sbt; subst co sbt.lhs sbt.rhs; try simplex ctx co distr order with | E_unbound (ctx,co) -> raise (E_unbound (ctx,co)) (*XXX*) | E_unsat (ctx,co) -> report_unsat distr order ctx co | E_max (ctx,co) -> report_max distr order ctx co let retrieve_cost distr = match !co_opt with | None -> assert false | Some co -> co_opt := None; let i = index_of_ghost distr in if i < !len then co.a2.(i) <- C.zero; co (*** / coeur du simplex_init *************************************************) let solve co ctx distr order = D.given_problem2 ctx co distr; try let (_,p) as line = line_with_min_const ctx in if C2.compare p.c2 C2.zero >= 0 then simplex ctx co distr order else begin co_opt := Some co; main_simplex := false; let ctx, unsat = init_simplex ctx line distr order in main_simplex := true; let co = retrieve_cost distr in D.retrieved_cost co; if unsat then I_unsat (ctx, co) else simplex ctx co distr order end with | E_max (ctx, co) -> I_max (ctx, co) | E_unbound (ctx,co) -> I_unbound (ctx, co) | E_unsat(ctx,co) -> I_unsat(ctx,co) let infos_of distr q {c2=c2} ctx = let acc0 = List.fold_left (fun acc (i,p) -> if C2.is_zero p.c2 then acc else (i, p.c2):: acc )[] ctx in let acc = ref [] in let inf i s = if s > 0 then try acc := (s, List.assoc i acc0) :: !acc with Not_found -> () in Array.iteri inf distr; {vof = c2; vals = !acc; ctx = ctx; distr = distr; order =q } let result_extraction distr q = function | I_max (ctx_ex,co_ex) -> D.result_extraction "max" ctx_ex co_ex distr; let res = infos_of distr q co_ex ctx_ex in if !dsimplex then fprintf fmt ">result size %d@." (List.length res.vals); Max res | I_unbound (ctx_ex,co_ex) -> D.result_extraction "unbound" ctx_ex co_ex distr; let res = infos_of distr q co_ex ctx_ex in if !dsimplex then fprintf fmt ">result size %d@." (List.length res.vals); Unbound res | I_unsat (ctx_ex,co_ex) -> D.result_extraction "unsat" ctx_ex co_ex distr; let res = infos_of distr q co_ex ctx_ex in if !dsimplex then fprintf fmt ">result size %d@." (List.length res.vals); Unsat res let core_main co matrix distr = let len = Array.length co.a2 in reset_refs len; let q = Queue.create () in for i = len - 1 downto 0 do Queue.push i q done; let res = solve co matrix distr (q, []) in result_extraction distr q res end let cpt = ref 0 let main co eqs s_neq nb_vars = (*XXXTimer.Simplex_main.start();*) (*incr cpt; fprintf fmt "%d@." !cpt; *) let res = D.given_problem co eqs s_neq nb_vars; try (*fprintf fmt "avant norm@."; fprintf fmt " nb_eqs = %d@." (List.length eqs); fprintf fmt " nb_vars = %d@." nb_vars;*) let co, matrix, distr = Normalizer.norm_main co eqs s_neq nb_vars in (*fprintf fmt "apres norm@."; fprintf fmt " nb_sbts = %d@." (List.length matrix); fprintf fmt " nb_vars = %d@." (Array.length distr);*) D.matrix_stats matrix co; Core_Simplex.core_main co matrix distr with Normalizer.Inconsistent -> Eq_unsat in (*XXXTimer.Simplex_main.stop();*) res let subst_spec ({a2=a2; c2=c2} as pp) v {a2=rhs_a2; c2=rhs_c2} = if not (C.is_zero v) then begin let f7a j w = let rhs_j = rhs_a2.(j) in if not (C.is_zero rhs_j) then a2.(j) <- C.add rhs_j w in let f7b j w = let rhs_j = rhs_a2.(j) in if not (C.is_zero rhs_j) then a2.(j) <- C.add (C.mult v rhs_j) w in let f7 = if C.is_one v then f7a else f7b in Array.iteri f7 a2; pp.c2 <- C2.add c2 (C2.mult v rhs_c2) end let partial_restart res (max_ctt: (int*Q.t) list) = (**XXXTimer.Simplex_main.start();**) if !dsimplex then fprintf fmt "new: "; if !dsimplex then List.iter (fun (i,q) -> fprintf fmt "%s*L%d + " (Q.to_string q) i )(List.rev max_ctt); if !dsimplex then fprintf fmt "@."; (*let max_ctt = ancien_ in*) match res with | Eq_unsat -> Eq_unsat | Unsat rr | Unbound rr | Max rr -> match rr.ctx with | [] -> assert false | (_,a)::_ -> if !dsimplex then fprintf fmt "@.tbl: "; if !dsimplex then Array.iteri (fun i s -> fprintf fmt "%d -> L%d | " i s) rr.distr; if !dsimplex then fprintf fmt "@.@."; let len = Array.length a.a2 in let cost = {a2=Array.make len Q.zero; c2=Q.zero,Q.zero} in Array.iteri (fun i ld -> if !dsimplex then fprintf fmt "> AVANT: cost: %a@." (D.ppoly (D.max_poly cost)) cost; if !dsimplex then fprintf fmt "traitement de l'index %d@." i; begin try let q = List.assoc ld max_ctt in if !dsimplex then fprintf fmt "L%d associe a %s@." ld (Q.to_string q); try cost.a2.(i) <- Q.add cost.a2.(i) q with Invalid_argument s -> assert (String.compare s "index out of bounds" = 0); if !dsimplex then fprintf fmt "L%d out of bounds@." ld; try let rhs = List.assoc i rr.ctx in subst_spec cost q rhs with Not_found -> () (*vaut zero ? assert false*) with Not_found -> if !dsimplex then fprintf fmt "L%d associe a RIEN@." ld end; )rr.distr; if !dsimplex then fprintf fmt "@.> RES cost: %a@.@." (D.ppoly (D.max_poly cost)) cost; (* XXX *) let leng = Array.length cost.a2 in Core_Simplex.reset_refs leng; (* XXX *) let res = Core_Simplex.solve cost rr.ctx rr.distr (rr.order, []) in let res = Core_Simplex.result_extraction rr.distr rr.order res in (*XXX*Timer.Simplex_main.stop();*) res (* let main co eqs s_neq nb_vars = let res = main co eqs s_neq nb_vars in let res' = partial_restart res co in (match res, res' with | Eq_unsat, Eq_unsat -> () | Unsat rr, Unsat r -> (*let r1, i1 = rr.vof in let r2, i2 = r.vof in assert (Q.equal r1 r2 && Q.equal i1 i2) *) () | Unbound rr,Unbound r -> let r1, i1 = rr.vof in let r2, i2 = r.vof in assert (Q.equal r1 r2 && Q.equal i1 i2) | Max rr, Max r -> let r1, i1 = rr.vof in let r2, i2 = r.vof in assert (Q.equal r1 r2 && Q.equal i1 i2) | _ -> assert false); res *) end module Simplex_Q = Simplex(Numbers.Q) alt-ergo-free-2.0.0/plugins/fm-simplex/simplex_cache.ml0000664000175000017500000000730413430774474020661 0ustar mimi(******************************************************************************) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the license indicated *) (* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) (* present, please contact us to clarify licensing. *) (* *) (******************************************************************************) open Format open Numbers open Options open Simplex module MAKE (C : sig type t val compare : t -> t -> int val print : formatter -> t -> unit end) = struct module MI = Map.Make (struct type t = int let compare a b = a - b end) module MD = Map.Make(C) let ppprint fmt p = MI.iter (fun i q -> fprintf fmt "%s*L%d + " (Q.to_string q) i) p; fprintf fmt "0" let print_sum id sum = fprintf fmt "@.sum %d@." id; MD.iter (fun x (lp,ln,q) -> fprintf fmt "%a -> (%a) + (%a) + %s = 0@." C.print x ppprint lp ppprint ln (Q.to_string q)) sum module SM = Map.Make (struct type t1 = (Q.t MI.t * Q.t MI.t * Q.t) MD.t type t2 = Q.t MI.t type t3 = Q.t MI.t type t = t1 * t2 * t3 let cmp (m1,n1,q1) (m2,n2,q2) = let c = Q.compare q1 q2 in if c <> 0 then c else let c = MI.compare Q.compare m1 m2 in if c <> 0 then c else MI.compare Q.compare n1 n2 let compare (sum1, ctt1, lambdas1) (sum2, ctt2, lambdas2) = let c = MD.compare cmp sum1 sum2 in if c <> 0 then c else let c = MI.compare Q.compare lambdas1 lambdas2 in if c <> 0 then( print_sum 1 sum1; print_sum 2 sum2; fprintf fmt "l1 = %a@." ppprint lambdas1; fprintf fmt "l2 = %a@." ppprint lambdas2); assert (c = 0); c end) let (m : (int * result * Q.t MI.t) SM.t ref) = ref SM.empty let (mm : (int * result * Q.t MI.t) SM.t MD.t ref) = ref MD.empty let mi_of_l l = List.fold_left (fun m (i,q) -> MI.add i q m) MI.empty l let make_repr max_ctt equas s_neq = let max_ctt = mi_of_l max_ctt in let s_neq = mi_of_l s_neq in let equas = List.fold_left (fun mp (x, (lp, ln, q)) -> let lp = mi_of_l lp in let ln = mi_of_l ln in MD.add x (lp, ln, q) mp )MD.empty equas in max_ctt, equas, s_neq let already_registered max_ctt equas s_neq = let repr = equas, max_ctt, s_neq in try let counter, res_sim, ctt = SM.find repr !m in Some (counter, res_sim, ctt) with Not_found -> None let register max_ctt equas s_neq cpt sim_res = if already_registered max_ctt equas s_neq == None then begin let repr = equas, max_ctt, s_neq in m := SM.add repr (cpt, sim_res, max_ctt) !m end let already_registered_mon x max_ctt equas s_neq = let repr = equas, max_ctt, s_neq in try let m = MD.find x !mm in let counter, res_sim, ctt = SM.find repr m in Some (counter, res_sim, ctt) with Not_found -> None let register_mon x max_ctt equas s_neq cpt sim_res = if already_registered_mon x max_ctt equas s_neq == None then begin let m = try MD.find x !mm with Not_found -> SM.empty in let repr = equas, max_ctt, s_neq in mm := MD.add x (SM.add repr (cpt, sim_res, max_ctt) m) !mm end end alt-ergo-free-2.0.0/plugins/fm-simplex/fmSimplexIneqs.ml0000664000175000017500000002750113430774474021022 0ustar mimi(******************************************************************************) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the license indicated *) (* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) (* present, please contact us to clarify licensing. *) (* *) (******************************************************************************) open Format open Options module Z = Numbers.Z module Q = Numbers.Q module Container : Inequalities.Container_SIG = struct module Make (X : Sig.X) (Uf : Uf.S with type r = X.r) (P : Polynome.EXTENDED_Polynome with type r = X.r) : Inequalities.S with module P = P = struct module FM = Inequalities.FM(X)(Uf)(P) include FM (* Only redefine functions "available" and "fmSimplex" functions *) open Simplex let dsimplex = ref false module SCache = Simplex_cache.MAKE( struct type t = X.r let compare = X.hash_cmp include X end) module MX = Map.Make(struct type t = X.r let compare = X.hash_cmp end) module Ex = Exception let print_couple fmt (re, eps) = fprintf fmt "(%s , %s)" (Q.to_string re) (Q.to_string eps) let print_answer (vof,vals) = fprintf fmt "vof = %a@." print_couple vof; fprintf fmt "@.assignement returned by the Simplex@."; List.iter (fun (l,v) -> fprintf fmt " L(%d) -> %a@." l print_couple v )vals let print_parsed_answer answer = if debug_fm() then match answer with | Unsat {vof=vof;vals=vals} -> fprintf fmt "I read: the simplex problem is not feasible (<=)@."; print_answer (vof,vals) | Eq_unsat -> fprintf fmt "I read: the simplex problem is not feasible (=)@." | Unbound {vof=vof;vals=vals} -> fprintf fmt "I read: the simplex problem is not bounnded@."; print_answer (vof,vals) | Max {vof=vof;vals=vals} -> fprintf fmt "I read: the simplex problem has a solution@."; print_answer (vof,vals) let add_to_sum ld sum l_m = List.fold_left (fun sum (c, x) -> let lp, ln = try MX.find x sum with Not_found -> [], [] in if Q.sign c > 0 then MX.add x ((ld, c) :: lp, ln) sum else MX.add x (lp, (ld, c) :: ln) sum ) sum l_m let generalized_fm_projection (constrs : (int * t) list) = List.fold_left (fun (sum, ctt, lds) (ld, ineq) -> let l_m, c = P.to_list ineq.ple0 in assert (Q.is_int c); if l_m == [] then begin fprintf fmt "%a <= 0@." P.print ineq.ple0; assert false end else let sum = add_to_sum ld sum l_m in let ctt = (ld, c) :: ctt in let lds = (ld, Q.one) :: lds in sum, ctt, lds )(MX.empty,[],[]) constrs let polynomials_bounding_pb sum ctt lambdas = let vars_elim_eqs = MX.fold (fun x (l1,l2) acc -> (x,(l1,l2, Q.zero)) :: acc) sum [] in let lds_gt_z = lambdas in ctt, vars_elim_eqs, lds_gt_z let monomial_bounding_pb sum ctt lambdas x sum_x is_pos = let max_ctt, vars_elim, s_neq = polynomials_bounding_pb sum ctt lambdas in let lp, ln = sum_x in let coef_x =(x, (lp, ln, if is_pos then Q.m_one else Q.one)) in max_ctt, coef_x :: vars_elim, s_neq let explain vals constrs = List.fold_left (fun expl (ld, (re,eps)) -> if Q.compare re Q.zero = 0 && Q.compare eps Q.zero = 0 then expl (* XXX eps ? re ? *) else let {expl=ex} = List.assoc ld constrs in Explanation.union expl ex )Explanation.empty vals let cpt = ref 0 let tighten_polynomials add_ineqs are_eq acc sum ctt lambdas nb_constrs constrs = let max_ctt, equas, s_neq = polynomials_bounding_pb sum ctt lambdas in let r_max_ctt,r_equas,r_s_neq = SCache.make_repr max_ctt equas s_neq in let sim_res = match SCache.already_registered r_max_ctt r_equas r_s_neq with | None -> if !dsimplex then fprintf fmt "Simplex poly in@."; incr cpt; if !dsimplex then fprintf fmt "new simplex %d@." !cpt; let res = Simplex_Q.main max_ctt equas s_neq nb_constrs in if !dsimplex then fprintf fmt "Simplex poly out@."; SCache.register r_max_ctt r_equas r_s_neq !cpt res ; res | Some (n, res, ctt') -> if SCache.MI.compare Q.compare r_max_ctt ctt' = 0 then begin if !dsimplex then fprintf fmt "reuse RESULTS of simplex %d@." n; res end else begin if !dsimplex then fprintf fmt "reuse simplex %d@." n; let res = Simplex_Q.partial_restart res max_ctt in res end in print_parsed_answer sim_res; match sim_res with | Unsat _ | Eq_unsat -> acc | Unbound {vof=vof;vals=vals} -> raise (Ex.Inconsistent (explain vals constrs, [])) | Max {vof=(re, eps);vals=vals} -> (* XXX: parties reelles nulles *) assert (Q.is_zero re); let expl = explain vals constrs in let cmp = Q.compare eps Q.zero in if cmp > 0 then raise(Ex.Inconsistent (expl, [])); let dep = List.fold_left (fun dep (ld,(re_ld, eps_ld)) -> assert (Q.is_zero re_ld); if Q.is_zero eps_ld then dep else let ineq = List.assoc ld constrs in match Util.MI.bindings ineq.dep with [a, (n,p, is_le)] -> assert (Q.is_one n && is_le); assert (not (Util.MI.mem a dep)); Util.MI.add a (eps_ld, p, is_le) dep | _ -> assert false )Util.MI.empty vals in let ineq = { ple0 = P.create [] eps Ty.Tint; is_le = true; (* add an assert *) age = current_age(); expl = expl; dep = dep; } in add_ineqs are_eq acc None [ineq] let tighten_monomial add_ineqs are_eq acc x sum_x is_pos sum ctt lambdas nb_constrs constrs = if false || debug_fm() then fprintf fmt "tighten_monomial %s%a@." (if is_pos then "+" else "-") X.print x; let max_ctt, equas, s_neq = monomial_bounding_pb sum ctt lambdas x sum_x is_pos in let r_max_ctt,r_equas,r_s_neq = SCache.make_repr max_ctt equas s_neq in let sim_res = match SCache.already_registered_mon x r_max_ctt r_equas r_s_neq with | None -> if !dsimplex then fprintf fmt "Simplex monomes in@."; incr cpt; if !dsimplex then fprintf fmt "new simplex %d@." !cpt; let res = Simplex_Q.main max_ctt equas s_neq nb_constrs in if !dsimplex then fprintf fmt "Simplex monomes out@."; SCache.register_mon x r_max_ctt r_equas r_s_neq !cpt res ; res | Some (n, res, ctt') -> if SCache.MI.compare Q.compare r_max_ctt ctt' = 0 then begin if !dsimplex then fprintf fmt "reuse RESULTS of simplex %d@." n; res end else begin if !dsimplex then fprintf fmt "reuse simplex %d@." n; let res = Simplex_Q.partial_restart res max_ctt in res end in print_parsed_answer sim_res; match sim_res with | Unsat _ | Eq_unsat -> acc | Unbound {vof=vof;vals=vals} -> raise (Ex.Inconsistent (explain vals constrs, [])) | Max {vof=vof,eps; vals=vals} -> (* XXX: parties avec eps nulles *) assert (Q.is_zero eps); let expl = explain vals constrs in let dep = List.fold_left (fun dep (ld,(re_ld, eps_ld)) -> assert (Q.is_zero eps_ld); if Q.is_zero re_ld then dep else let ineq = List.assoc ld constrs in match Util.MI.bindings ineq.dep with [a, (n,p, is_le)] -> assert (Q.is_one n && is_le); assert (not (Util.MI.mem a dep)); Util.MI.add a (re_ld, p, is_le) dep | _ -> assert false )Util.MI.empty vals in let mon_coef = if is_pos then Q.one else Q.m_one in let ineq = { ple0 = P.create [mon_coef, x] vof Ty.Tint; is_le = true; (* add an assert *) age = current_age(); expl = expl; dep = dep; } in add_ineqs are_eq acc None [ineq] let tighten_monomials add_ineqs are_eq acc sum ctt lds nb_ctrs ctrs = MX.fold (fun x sum_x acc -> let sum = MX.remove x sum in let acc = tighten_monomial add_ineqs are_eq acc x sum_x true sum ctt lds nb_ctrs ctrs in let acc = tighten_monomial add_ineqs are_eq acc x sum_x false sum ctt lds nb_ctrs ctrs in acc )sum acc let fm_simplex add_ineqs are_eq acc constrs nb_constrs = if debug_fm() then begin fprintf fmt "begin fm-simplex: nb_constrs = %d@." nb_constrs; List.iter (fun (id, {ple0}) -> fprintf fmt "%d) %a <= 0@." id P.print ple0) constrs; end; let sum, ctt, lambdas = generalized_fm_projection constrs in let acc = if MX.is_empty sum then acc else let acc = tighten_polynomials add_ineqs are_eq acc sum ctt lambdas nb_constrs constrs in if Options.tighten_vars() then tighten_monomials add_ineqs are_eq acc sum ctt lambdas nb_constrs constrs else acc in if debug_fm() then fprintf fmt "end fm-simplex@.@."; acc let list_of_mineqs mp = let nb_ineqs = MP.cardinal mp in let cpt = ref (nb_ineqs + 1) in let ctrs = MINEQS.fold (fun p (ineq, _) ctrs -> decr cpt; (!cpt, ineq) :: ctrs )mp [] in ctrs, nb_ineqs (*------------------------------------------------------------------------*) let is_rat_poly p = match P.type_info p with | Ty.Tint -> false | Ty.Treal -> true | _ -> assert false let check_is_rat mp = let is_rat = ref true in begin try MINEQS.iter (fun p i -> is_rat := is_rat_poly p; raise Exit) mp with Exit -> () end; let is_rat = !is_rat in assert (MINEQS.fold (fun p _ z -> z && is_rat == is_rat_poly p) mp true); is_rat let fmSimplex add_ineqs are_eq acc mp = if check_is_rat mp then fourierMotzkin add_ineqs are_eq acc mp else let constrs, nb_constrs = list_of_mineqs mp in fm_simplex add_ineqs are_eq acc constrs nb_constrs let available = fmSimplex end end let () = Inequalities.set_current (module Container : Inequalities.Container_SIG) alt-ergo-free-2.0.0/plugins/satML/0000775000175000017500000000000013430774474014456 5ustar mimialt-ergo-free-2.0.0/plugins/satML/satml_frontend.mli0000664000175000017500000000154613430774474020206 0ustar mimi(******************************************************************************) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the license indicated *) (* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) (* present, please contact us to clarify licensing. *) (* *) (******************************************************************************) (* empty interface file *) module Main : Sat_solver_sig.S alt-ergo-free-2.0.0/plugins/satML/satml.mli0000664000175000017500000000735613430774474016314 0ustar mimi(******************************************************************************) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the license indicated *) (* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) (* present, please contact us to clarify licensing. *) (* *) (******************************************************************************) module Types : sig type atom type clause val pr_atom : Format.formatter -> atom -> unit val pr_clause : Format.formatter -> clause -> unit val literal : atom -> Literal.LT.t val weight : atom -> float val is_true : atom -> bool val level : atom -> int val index : atom -> int val cmp_atom : atom -> atom -> int (* type var type reason type premise (*module Make (Dummy : sig end) : sig*) val neg : atom -> atom val cpt_mk_var : int ref val ma : var Literal.LT.Map.t ref val dummy_var : var val dummy_atom : atom val dummy_clause : clause val make_var : Literal.LT.t -> var * bool val add_atom : Literal.LT.t -> atom val vrai_atom : atom val faux_atom : atom val make_clause : string -> atom list -> Formula.t -> int -> bool -> premise-> clause val fresh_name : unit -> string val fresh_lname : unit -> string val fresh_dname : unit -> string val to_float : int -> float val to_int : float -> int val made_vars_info : unit -> int * var list val clear : unit -> unit (****) val eq_atom : atom -> atom -> bool val hash_atom : atom -> int val tag_atom : atom -> int val cmp_var : var -> var -> int val eq_var : var -> var -> bool val h_var : var -> int val tag_var : var -> int (*end*) *) end (******************************************************************************) module Flat_Formula : sig type t type view = private UNIT of Types.atom | AND of t list | OR of t list val print : Format.formatter -> t -> unit val view : t -> view val vrai : t val faux : t val mk_lit : Literal.LT.t -> t val mk_not : t -> t val mk_and : t list -> t val mk_or : t list -> t val compare : t -> t -> int val equal : t -> t -> bool val simplify : Formula.t -> (Formula.t -> t * 'a) -> t * (Formula.t * (t * Types.atom)) list val cnf_abstr : t -> (Types.atom * Types.atom list * bool) Util.MI.t -> Types.atom * (Types.atom * Types.atom list * bool) list * (Types.atom * Types.atom list * bool) Util.MI.t val expand_proxy_defn : Types.atom list list -> Types.atom * Types.atom list * bool -> Types.atom list list module Set : Set.S with type elt = t module Map : Map.S with type key = t end exception Sat exception Unsat of Types.clause list module type SAT_ML = sig (*module Make (Dummy : sig end) : sig*) type state type th val solve : unit -> unit val assume : Types.atom list list -> Formula.t -> cnumber : int -> unit val boolean_model : unit -> Types.atom list val current_tbox : unit -> th val set_current_tbox : th -> unit val empty : unit -> unit val clear : unit -> unit val save : unit -> state val restore : state -> unit val reset_steps : unit -> unit val get_steps : unit -> int64 val assume_th_elt : Commands.th_elt -> unit val decision_level : unit -> int val cancel_until : int -> unit (*end*) end module Make (Th : Theory.S) : SAT_ML with type th = Th.t alt-ergo-free-2.0.0/plugins/satML/satml_frontend.ml0000664000175000017500000005415713430774474020043 0ustar mimi(******************************************************************************) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the license indicated *) (* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) (* present, please contact us to clarify licensing. *) (* *) (******************************************************************************) module Main : Sat_solver_sig.S = struct open Options open Format module Th = Theory.Main module SAT = Satml.Make(Th) module Inst = Instances.Make(Th) module Ex = Explanation module F = Formula module MF = F.Map module SF = F.Set module A = Literal.LT module T = Term module Types = Satml.Types module Hs = Hstring module FF = Satml.Flat_Formula module MFF = FF.Map module SFF = FF.Set let reset_refs () = SAT.reset_steps () let get_steps () = SAT.get_steps () type t = { nb_mrounds : int; gamma : int MF.t; conj : int MFF.t; abstr1 : (FF.t * Types.atom) MF.t; abstr2 : F.t MFF.t; proxies : (Types.atom * Types.atom list * bool) Util.MI.t; inst : Inst.t; ground_preds : (F.gformula * string * Loc.t) Term.Map.t; add_inst: Formula.t -> bool; } let empty () = SAT.empty (); (*(* Soundness issue due to bad hash-consing *) *) { gamma = MF.empty; nb_mrounds = 0; conj = MFF.empty; abstr1 = MF.empty; abstr2 = MFF.empty; proxies = Util.MI.empty; inst = Inst.empty; ground_preds = Term.Map.empty; add_inst = fun _ -> true; } let empty_with_inst add_inst = { (empty ()) with add_inst = add_inst } exception Sat of t exception Unsat of Explanation.t exception I_dont_know of t exception IUnsat of t * Explanation.t let mk_gf f = { F.f = f; trigger_depth = max_int; nb_reductions = 0; origin_name = ""; age = 0; lem = None; mf = false; gf = false; gdist = -1; hdist = -1; from_terms = []; theory_elim = true; } module Replay = struct let print_gamma env = fprintf fmt "(* ground problem *)@."; MF.iter (fun f _ -> fprintf fmt "%a -> @." F.print f) env.gamma; fprintf fmt "false@." let replay_with_dfs env = try let env_dfs = try let env_dfs = MF.fold (fun f _ env_dfs -> Fun_sat.assume env_dfs (mk_gf f)) env.gamma (Fun_sat.empty ()) in MF.fold (fun f (_,at) env_dfs -> let f = F.mk_iff f (F.mk_lit (Types.literal at) 0) 0 in Fun_sat.assume env_dfs (mk_gf f) ) env.abstr1 env_dfs with Fun_sat.Unsat dep -> raise (Unsat dep) in ignore (Fun_sat.unsat env_dfs (mk_gf F.vrai)); fprintf fmt "replay (by Fun_sat.unsat)@." with | Unsat _ -> fprintf fmt "replay (by Fun_sat.assume)@."; | Fun_sat.Unsat _ -> assert false | Fun_sat.Sat _ -> fprintf fmt "satML said UNSAT but Fun_sat said SAT@."; print_gamma env; exit 12 | e -> fprintf fmt "satML said UNSAT but Fun_sat said:@."; (*fprintf fmt "%s@." (Printexc.to_string e);*) exit 13 end (*BISECT-IGNORE-BEGIN*) module Debug = struct let pred_def f = if debug_sat () then eprintf "[sat] I assume a predicate: %a@.@." F.print f let unsat gf = if debug_sat () then printf "[sat] unsat of %a ?@." F.print gf.F.f let assume gf = let {F.f=f;age=age;lem=lem;mf=mf;from_terms=terms} = gf in if debug_sat () then begin match F.view f with | F.Unit _ -> () | F.Clause _ -> fprintf fmt "[sat] I assume a clause %a@." F.print f | F.Lemma _ -> fprintf fmt "[sat] I assume a [%d-atom] lemma: %a@." (F.size f) F.print f | F.Literal a -> Term.print_list str_formatter terms; let s = flush_str_formatter () in let n = match lem with | None -> "" | Some ff -> (match F.view ff with F.Lemma xx -> xx.F.name | _ -> "") in fprintf fmt "\n[sat]I assume a literal (%s : %s) %a@]@." n s Literal.LT.print a; fprintf fmt "================================================@.@." | F.Skolem _ -> fprintf fmt "[sat] I assume a skolem %a@." F.print f | F.Let {F.let_var=lvar; let_term=lterm; let_f=lf} -> fprintf fmt "[sat] I assume a let %a = %a in %a@." Symbols.print lvar Term.print lterm F.print lf; end let simplified_form f f' = if debug_sat () && verbose () then begin fprintf fmt "[sat] Simplified form of: %a@." F.print f; fprintf fmt " is: %a@." FF.print f'; end let cnf_form f unit non_unit = if debug_sat () && verbose () then begin fprintf fmt "[sat] CFF form of: %a@." FF.print f; fprintf fmt " is:@."; List.iter (List.iter (fun a -> fprintf fmt "UNIT: %a@." Types.pr_atom a)) unit; List.iter (fun c -> fprintf fmt "CLAUSE: "; List.iter (fun a -> fprintf fmt "%a or " Types.pr_atom a) c; fprintf fmt "@." )non_unit end let model ()= if debug_sat () then let model = SAT.boolean_model () in eprintf "@.(2) satML's model:@."; List.iter (fun a -> eprintf " %f | %a @." (Types.weight a) Types.pr_atom a; ) (List.rev model); eprintf " --------------@." let mround () = if debug_sat () then fprintf fmt "matching round@." let new_instances env = if debug_sat () then begin eprintf "@.# [sat] I GENERATE NEW INSTANCES ########################@.@."; eprintf "(1) ground problem: @."; MFF.iter (fun f md -> eprintf "-> %d : %a@." md FF.print f) env.conj; fprintf fmt "@.Gamma:@."; model (); end let generated_instances l = if verbose () && debug_sat () then begin eprintf "[new_instances] %d generated@." (List.length l); List.iter (fun ({F.f=f}, _) -> eprintf " instance: %a@." F.print f) l end let trivial_fact p inst = if verbose () && debug_sat () then begin if inst then eprintf "already known instance: %a@." F.print p else eprintf "already known skolem: %a@." F.print p end let generated_skolems l = if verbose () && debug_sat () then begin eprintf "[new_skolems] %d generated@." (List.length l); List.iter (fun {F.f=f} -> eprintf " skolem: %a@." F.print f) l end let terms_from_sat_branch f = if verbose () && debug_sat () then begin fprintf fmt "[extract_and_add_terms from] %a@." FF.print f; end let add_terms_of src terms = if verbose () && debug_sat () then begin fprintf fmt "[%s] add_terms_of:@." src; Term.Set.iter (fprintf fmt ">> %a@." Term.print) terms; fprintf fmt "@."; end let axiom_def f = if debug_sat () then eprintf "[sat] I assume an axiom: %a@.@." F.print f let internal_axiom_def f fa = if debug_sat () then eprintf "[sat] I assume an internal axiom: %a <-> %a@.@." FF.print fa F.print f end (*BISECT-IGNORE-END*) let selector env f orig = not (MF.mem f env.gamma) && begin match F.view orig with | F.Lemma _ -> env.add_inst orig | _ -> true end (* copied from sat_solvers.ml *) let in_mk_theories_instances () = if Options.debug_fpa() > 0 || debug_sat() then fprintf fmt "@.[sat] entering mk_theories_instances:@." let out_mk_theories_instances normal_exit = if Options.debug_fpa() > 0 || debug_sat() then if normal_exit then fprintf fmt "@.[sat] normal exit of mk_theories_instances.@.@." else fprintf fmt "@.exit mk_theories_instances with Inconsistency.@.@." let print_f_conj fmt hyp = match hyp with | [] -> fprintf fmt "True"; | e::l -> fprintf fmt "%a" F.print e; List.iter (fun f -> fprintf fmt " /\\ %a" F.print f) l let print_theory_instance hyp gf = if Options.debug_fpa() > 1 || Options.debug_sat() then begin fprintf fmt "@.%s >@." (F.name_of_lemma_opt gf.F.lem); fprintf fmt " hypotheses: %a@." print_f_conj hyp; fprintf fmt " conclusion: %a@." F.print gf.F.f; end let reduce_filters acc (hyp, gf, dep) = print_theory_instance hyp gf; let clause = List.fold_left (fun tmp f -> (* we cannot reduce like in Fun_sat *) F.mk_or (F.mk_not f) tmp false 0 )gf.F.f hyp in ({gf with F.f=clause}, dep) :: acc let mk_theories_instances do_synt_ma remove_clauses env acc = let t_match = Inst.matching_terms_info env.inst in let tbox = SAT.current_tbox () in let tbox, l = Th.theories_instances do_synt_ma t_match tbox (selector env) env.nb_mrounds 0 [@ocaml.ppwarning "TODO: modifications made in tbox are lost! improve?"] in List.fold_left reduce_filters acc l, (match l with [] -> false | _ -> true) let syntactic_th_inst remove_clauses env acc = mk_theories_instances true remove_clauses env acc let semantic_th_inst_rec = let rec aux_rec remove_clauses env rnd acc = let acc, inst_made = mk_theories_instances false remove_clauses env acc in if not inst_made || rnd <= 1 then acc else aux_rec remove_clauses env (rnd - 1) acc in fun remove_clauses env rnd acc -> aux_rec remove_clauses env rnd acc let mk_theories_inst_rec env rnd = let acc, _ = syntactic_th_inst false env [] in semantic_th_inst_rec false env rnd acc (* copied from sat_solvers.ml *) let mround env = let tbox = SAT.current_tbox () in let gd2, ngd2 = Inst.m_predicates ~backward:Util.Normal env.inst tbox (selector env) env.nb_mrounds in let l2 = List.rev_append (List.rev gd2) ngd2 in if Options.profiling() then Profiling.instances l2; (*let env = assume env l2 in*) let gd1, ngd1 = Inst.m_lemmas ~backward:Util.Normal env.inst tbox (selector env) env.nb_mrounds in let l1 = List.rev_append (List.rev gd1) ngd1 in if Options.profiling() then Profiling.instances l1; let l = ((List.rev_append l2 l1) : (F.gformula * Explanation.t) list) in let th_insts = mk_theories_inst_rec env 10 in let l = List.rev_append th_insts l in List.rev_map (fun (gf,dep) -> let orig = match gf.F.lem with None -> assert false | Some lem -> lem in try let _, at = MF.find orig env.abstr1 in (*not true for greedy assert (Types.is_true at && Types.level at >= 0);*) (*if at.ST.var.ST.level = 0 then (p, dep, w) :: acc else*) let fat = F.mk_lit (Types.literal at) 0 in let f' = F.mk_or (F.mk_not fat) gf.F.f false 0 in ({gf with F.f = f' }, dep) with | Not_found -> (gf, dep) )l let print_propositional_model () = let model = SAT.boolean_model () in fprintf fmt "Propositional:"; List.iter (fun at -> (fprintf fmt "\n %a" Literal.LT.print) (Types.literal at) ) model; fprintf fmt "\n@." let print_model ~header fmt env = Format.print_flush (); if header then fprintf fmt "\nModel\n@."; print_propositional_model (); Th.print_model fmt (SAT.current_tbox ()) let make_explanation lc = Ex.empty (* if debug_sat () then fprintf fmt "make_explanation of %d clauses@." (List.length lc); List.fold_left (fun ex ({ST.form = f} as c) -> if debug_sat () then fprintf fmt "unsat_core: %a@." Types.pr_clause c; Ex.union (Ex.singleton (Ex.Dep f)) ex )Ex.empty lc*) let pred_def env f name loc = Debug.pred_def f; let gf = mk_gf f in let t = Term.make (Symbols.name name) [] Ty.Tbool in if Term.Set.mem t (F.ground_terms_rec f) then begin assert (not (Term.Map.mem t env.ground_preds)); {env with ground_preds = Term.Map.add t (gf, name, loc) env.ground_preds} end else {env with inst = Inst.add_predicate env.inst gf} let axiom_def env gf ex = let inst, deds = Inst.add_lemma env.inst gf ex in {env with inst}, deds let register_abstraction env (f, (af, at)) = if debug_sat () && verbose () then fprintf fmt "abstraction: %a --> %a@." F.print f FF.print af; if MF.mem f env.abstr1 then begin let _, bt = MF.find f env.abstr1 in if Types.cmp_atom at bt <> 0 then begin fprintf fmt "%a -----> %a@.ET@.%a -----> %a@." F.print f Types.pr_atom at F.print f Types.pr_atom bt; assert false end; end; let gf = mk_gf f in let inst, deds = if not (Types.is_true at) then env.inst, [] else Inst.add_lemma env.inst gf Ex.empty in { env with inst; abstr1 = MF.add f (af, at) env.abstr1; abstr2 = MFF.add af f env.abstr2 } let internal_axiom_def ax fa inst = Debug.internal_axiom_def ax fa; let gax = mk_gf ax in let inst, deds = Inst.add_lemma inst gax Ex.empty in (* !!! eventual particular instances in deds are ignored !!! *) inst let terms_from_atom f env (inst, acc, sa) a = let gf = mk_gf F.vrai in if A.Set.mem a sa then inst, acc, sa else let sa = A.Set.add a sa in if verbose () then fprintf fmt "terms_of_atom %a @.@." Literal.LT.print a; let inst = Inst.add_terms inst (A.terms_nonrec a) gf in let fa = FF.mk_lit a in (* ax <-> fa, if ax exists in abstr2 *) try let ax = MFF.find fa env.abstr2 in internal_axiom_def ax fa inst, acc, sa with Not_found -> try (* ax <-> fa donc ax -> fa i.e (not ax) or fa *) let ax = MFF.find (FF.mk_not fa) env.abstr2 in match F.view (F.mk_not ax) with | F.Skolem quantif -> let neg_ax = F.skolemize quantif in let f = F.mk_or (F.mk_not (F.mk_lit a 0)) neg_ax false 0 in if MF.mem f env.gamma (*|| is_satisfied env p*) then begin Debug.trivial_fact f false; inst, acc, sa end else inst, f :: acc, sa | _ -> assert false with Not_found -> inst, acc, sa let measure at = Types.level at, Types.weight at, Types.index at (* smaller is more important *) let cmp_tuples (l1, w1, i1) (l2,w2, i2) = (* lower decision level is better *) let res = compare l1 l2 in if res <> 0 then res else (* higher weight is better hence compare w2 w1 *) let res = Pervasives.compare w2 w1 in if res <> 0 then res else (* lower index is better *) compare i1 i2 let max a b = if cmp_tuples a b > 0 then a else b let take_max aux l = let ((lvl, _, ind) ,_) as acc = List.fold_left (fun ((mz,lz) as acc) f -> match aux f with | None -> acc | Some (m, l) -> if cmp_tuples m mz > 0 then (m, l) else acc )((-1, -.1., -1), []) l in if lvl = -1 && ind = -1 then None else Some acc let take_min aux l = let ((lvl, _, ind) ,_) as acc = List.fold_left (fun ((mz,lz) as acc) f -> match aux f with | None -> acc | Some (m, l) -> if cmp_tuples m mz < 0 then (m, l) else acc )((max_int, -.1., max_int), []) l in if lvl = max_int && ind = max_int then None else Some acc let rec take_normal aux l = match l with [] -> None | a::l -> match aux a with | None -> take_normal aux l | (Some _) as v -> v let terms_from_sat_branches = let rec terms_from_sat_branch f = match FF.view f with | FF.UNIT at -> if not (Types.is_true at) then None else Some (measure at, [Types.literal at]) | FF.AND l -> begin try let acc = List.fold_left (fun (mz,lz) f -> match terms_from_sat_branch f with | None -> raise Exit | Some (m, l) -> max m mz, List.rev_append l lz )((-1, -.1., -1), []) l in Some acc with Exit -> None end | FF.OR l -> take_normal terms_from_sat_branch l in fun env -> let inst, acc, sa = MFF.fold (fun f _ (inst, acc, sa) -> Debug.terms_from_sat_branch f; match terms_from_sat_branch f with | None -> assert false | Some (_,l) -> List.fold_left (fun (inst, acc, sa) a -> terms_from_atom f env (inst, acc, sa) a) (inst, acc, sa) l ) env.conj (env.inst, [], A.Set.empty) in inst, acc let terms_from_bmodel env = MF.fold (fun f _ (inst, acc) -> Inst.add_terms inst (F.ground_terms_rec f) (mk_gf f), f::acc) env.gamma (env.inst, []) let terms_from_sat_branches env greedy_round = if greedy_round || greedy () then terms_from_bmodel env else terms_from_sat_branches env let terms_from_dec_proc env = let terms = Th.extract_ground_terms (SAT.current_tbox ()) in Debug.add_terms_of "terms_from_dec_proc" terms; let gf = mk_gf F.vrai in Inst.add_terms env.inst terms gf let instantiate_ground_preds env acc = let bmodel = SAT.boolean_model () in List.fold_left (fun acc at -> let a = Types.literal at in match Literal.LT.view a with | Literal.Pred(t, _) -> (try let ff, pred_name, loc = Term.Map.find t env.ground_preds in if Options.profiling() then Profiling.new_instance_of pred_name ff.F.f loc true; ff::acc with Not_found -> acc) | _ -> acc ) acc bmodel let new_instances env greedy_round = Debug.new_instances env; let inst, acc = terms_from_sat_branches env greedy_round in let acc = List.map mk_gf acc in let inst = terms_from_dec_proc {env with inst=inst} in let l = mround {env with inst = inst} in Debug.generated_instances l; Debug.generated_skolems acc; let l = List.map (fun (gf, dep) -> gf) l in let acc = List.rev_append acc l in instantiate_ground_preds env acc let rec assume_aux (env, updated) gf = let {F.f=f} = gf in if MF.mem f env.gamma then env, updated else let env = {env with gamma = MF.add f env.nb_mrounds env.gamma} in Debug.assume gf; match F.view f with | F.Lemma _ -> let env, deds = axiom_def env gf Ex.empty in List.fold_left (fun acc (gf, _) -> assume_aux acc gf) (env, true) deds | _ -> let f', axs = FF.simplify f (fun f -> MF.find f env.abstr1) in Debug.simplified_form f f'; let env = { env with conj = MFF.add f' env.nb_mrounds env.conj } in let env = List.fold_left register_abstraction env axs in let f'_abstr, new_proxies, proxies_mp = FF.cnf_abstr f' env.proxies in let env = {env with proxies = proxies_mp} in let unit = [[f'_abstr]] in let nunit = List.fold_left FF.expand_proxy_defn [] new_proxies in Debug.cnf_form f' unit nunit; try SAT.assume unit f ~cnumber:0; SAT.assume nunit f ~cnumber:0; (*SAT.assume2 f ~cnumber:0 f'_abstr new_proxies;*) env, true with | Satml.Unsat (lc) -> raise (IUnsat (env, make_explanation lc)) | Satml.Sat -> assert false let rec unsat_rec env : unit = try SAT.solve (); assert false with | Satml.Unsat lc -> raise (IUnsat (env, make_explanation lc)) | Satml.Sat -> let env = {env with nb_mrounds = env.nb_mrounds + 1} in if Options.profiling() then Profiling.instantiation env.nb_mrounds; let l = new_instances env false in let env, updated = List.fold_left assume_aux (env, false) l in let env = if updated then env else begin if greedy () then raise (I_dont_know env); let l = new_instances env true in let env, updated = List.fold_left assume_aux (env, false) l in if not updated then raise (I_dont_know env); env end in unsat_rec env let unsat env gf = Debug.unsat gf; (* In dfs_sat goals' terms are added to env.inst *) let env = {env with inst = Inst.add_terms env.inst (F.ground_terms_rec gf.F.f) gf} in try let env, updated = List.fold_left assume_aux (env, false) [gf] in unsat_rec env; assert false with IUnsat (env, dep) -> if replay_satml_dfs () then Replay.replay_with_dfs env; dep let assume env gf = try fst (assume_aux (env, false) gf) with IUnsat (env, dep) -> raise (Unsat dep) let retrieve_used_context {inst=inst} = Inst.retrieve_used_context inst (* instrumentation of relevant exported functions for profiling *) let assume t ff = if not (Options.timers ()) then assume t ff else try Timers.exec_timer_start Timers.M_Sat Timers.F_assume; let t = assume t ff in Timers.exec_timer_pause Timers.M_Sat Timers.F_assume; t with exn -> Timers.exec_timer_pause Timers.M_Sat Timers.F_assume; raise exn let unsat t ff = if not (Options.timers()) then unsat t ff else try Timers.exec_timer_start Timers.M_Sat Timers.F_unsat; let t = unsat t ff in Timers.exec_timer_pause Timers.M_Sat Timers.F_unsat; t with exn -> Timers.exec_timer_pause Timers.M_Sat Timers.F_unsat; raise exn let assume_th_elt env th_elt = SAT.assume_th_elt th_elt; env end let () = Sat_solver.set_current (module Main : Sat_solver_sig.S) alt-ergo-free-2.0.0/plugins/satML/satml.ml0000664000175000017500000017511613430774474016143 0ustar mimi(******************************************************************************) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the license indicated *) (* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) (* present, please contact us to clarify licensing. *) (* *) (******************************************************************************) open Format open Options module F = Formula module MF = F.Map module SF = F.Set module A = Literal.LT module T = Term module Hs = Hstring module Iheap : sig type t val init : int -> t val in_heap : t -> int -> bool val decrease : (int -> int -> bool) -> t -> int -> unit (*val increase : (int -> int -> bool) -> t -> int -> unit*) val size : t -> int val is_empty : t -> bool val insert : (int -> int -> bool) -> t -> int -> unit val grow_to_by_double: t -> int -> unit (*val update : (int -> int -> bool) -> t -> int -> unit*) val remove_min : (int -> int -> bool) -> t -> int val filter : t -> (int -> bool) -> (int -> int -> bool) -> unit end = struct type t = {heap : int Vec.t; indices : int Vec.t } let dummy = -100 let init sz = { heap = Vec.init sz (fun i -> i) dummy; indices = Vec.init sz (fun i -> i) dummy} let left i = (i lsl 1) + 1 (* i*2 + 1 *) let right i = (i + 1) lsl 1 (* (i+1)*2 *) let parent i = (i - 1) asr 1 (* (i-1) / 2 *) (* let rec heap_property cmp ({heap=heap} as s) i = i >= (Vec.size heap) || ((i = 0 || not(cmp (Vec. get heap i) (Vec.get heap (parent i)))) && heap_property cmp s (left i) && heap_property cmp s (right i)) let heap_property cmp s = heap_property cmp s 1 *) let percolate_up cmp {heap=heap;indices=indices} i = let x = Vec.get heap i in let pi = ref (parent i) in let i = ref i in while !i <> 0 && cmp x (Vec.get heap !pi) do Vec.set heap !i (Vec.get heap !pi); Vec.set indices (Vec.get heap !i) !i; i := !pi; pi := parent !i done; Vec.set heap !i x; Vec.set indices x !i let percolate_down cmp {heap=heap;indices=indices} i = let x = Vec.get heap i in let sz = Vec.size heap in let li = ref (left i) in let ri = ref (right i) in let i = ref i in (try while !li < sz do let child = if !ri < sz && cmp (Vec.get heap !ri) (Vec.get heap !li) then !ri else !li in if not (cmp (Vec.get heap child) x) then raise Exit; Vec.set heap !i (Vec.get heap child); Vec.set indices (Vec.get heap !i) !i; i := child; li := left !i; ri := right !i done; with Exit -> ()); Vec.set heap !i x; Vec.set indices x !i let in_heap s n = try n < Vec.size s.indices && Vec.get s.indices n >= 0 with Not_found -> false let decrease cmp s n = assert (in_heap s n); percolate_up cmp s (Vec.get s.indices n) let increase cmp s n = assert (in_heap s n); percolate_down cmp s (Vec.get s.indices n) let filter s filt cmp = let j = ref 0 in let lim = Vec.size s.heap in for i = 0 to lim - 1 do if filt (Vec.get s.heap i) then begin Vec.set s.heap !j (Vec.get s.heap i); Vec.set s.indices (Vec.get s.heap i) !j; incr j; end else Vec.set s.indices (Vec.get s.heap i) (-1); done; Vec.shrink s.heap (lim - !j) true; for i = (lim / 2) - 1 downto 0 do percolate_down cmp s i done let size s = Vec.size s.heap let is_empty s = Vec.is_empty s.heap let insert cmp s n = if not (in_heap s n) then begin Vec.set s.indices n (Vec.size s.heap); Vec.push s.heap n; percolate_up cmp s (Vec.get s.indices n) end let grow_to_by_double s sz = Vec.grow_to_by_double s.indices sz; Vec.grow_to_by_double s.heap sz (* let update cmp s n = assert (heap_property cmp s); begin if in_heap s n then begin percolate_up cmp s (Vec.get s.indices n); percolate_down cmp s (Vec.get s.indices n) end else insert cmp s n end; assert (heap_property cmp s) *) let remove_min cmp ({heap=heap; indices=indices} as s) = let x = Vec.get heap 0 in Vec.set heap 0 (Vec.last heap); (*heap.last()*) Vec.set indices (Vec.get heap 0) 0; Vec.set indices x (-1); Vec.pop s.heap; if Vec.size s.heap > 1 then percolate_down cmp s 0; x end module type STT = sig type var = { vid : int; pa : atom; na : atom; mutable weight : float; mutable sweight : int; mutable seen : bool; mutable level : int; mutable index : int; mutable reason : reason; mutable vpremise : premise } and atom = { var : var; lit : Literal.LT.t; neg : atom; mutable watched : clause Vec.t; mutable is_true : bool; aid : int } and clause = { name : string; mutable atoms : atom Vec.t; mutable activity : float; mutable removed : bool; learnt : bool; cpremise : premise; form : Formula.t} and reason = clause option and premise = clause list (*module Make (Dummy : sig end) : sig*) val literal : atom -> Literal.LT.t val weight : atom -> float val is_true : atom -> bool val level : atom -> int val index : atom -> int val neg : atom -> atom val cpt_mk_var : int ref val ma : var Literal.LT.Map.t ref val dummy_var : var val dummy_atom : atom val dummy_clause : clause val make_var : Literal.LT.t -> var * bool val add_atom : Literal.LT.t -> atom val vrai_atom : atom val faux_atom : atom val make_clause : string -> atom list -> Formula.t -> int -> bool -> premise-> clause val fresh_name : unit -> string val fresh_lname : unit -> string val fresh_dname : unit -> string val to_float : int -> float val to_int : float -> int val made_vars_info : unit -> int * var list val clear : unit -> unit (****) val cmp_atom : atom -> atom -> int val eq_atom : atom -> atom -> bool val hash_atom : atom -> int val tag_atom : atom -> int val cmp_var : var -> var -> int val eq_var : var -> var -> bool val h_var : var -> int val tag_var : var -> int (*end*) val pr_atom : Format.formatter -> atom -> unit val pr_clause : Format.formatter -> clause -> unit val iter_atoms_of_clauses : clause Vec.t -> (atom -> unit) -> unit end module Types (*: STT*) = struct let ale = Hstring.make "<=" let alt = Hstring.make "<" let agt = Hstring.make ">" let is_le n = Hstring.compare n ale = 0 let is_lt n = Hstring.compare n alt = 0 let is_gt n = Hstring.compare n agt = 0 type var = { vid : int; pa : atom; na : atom; mutable weight : float; mutable sweight : int; mutable seen : bool; mutable level : int; mutable index : int; mutable reason: reason; mutable vpremise : premise} and atom = { var : var; lit : Literal.LT.t; neg : atom; mutable watched : clause Vec.t; mutable is_true : bool; aid : int } and clause = { name : string; mutable atoms : atom Vec.t ; mutable activity : float; mutable removed : bool; learnt : bool; cpremise : premise; form : Formula.t} and reason = clause option and premise = clause list (*module Make (Dummy : sig end) = struct*) let dummy_lit = Literal.LT.vrai let vraie_form = Formula.mk_lit dummy_lit 0 let rec dummy_var = { vid = -101; pa = dummy_atom; na = dummy_atom; level = -1; index = -1; reason = None; weight = -1.; sweight = 0; seen = false; vpremise = [] } and dummy_atom = { var = dummy_var; lit = dummy_lit; watched = {Vec.dummy=dummy_clause; data=[||]; sz=0}; neg = dummy_atom; is_true = false; aid = -102 } and dummy_clause = { name = ""; atoms = {Vec.dummy=dummy_atom; data=[||]; sz=0}; activity = -1.; removed = false; learnt = false; cpremise = []; form = vraie_form } module Debug = struct let sign a = if a==a.var.pa then "" else "-" let level a = match a.var.level, a.var.reason with | n, _ when n < 0 -> assert false | 0, Some c -> sprintf "->0/%s" c.name | 0, None -> "@0" | n, Some c -> sprintf "->%d/%s" n c.name | n, None -> sprintf "@@%d" n let value a = if a.is_true then sprintf "[T%s]" (level a) else if a.neg.is_true then sprintf "[F%s]" (level a) else "" let value_ms_like a = if a.is_true then sprintf ":1%s" (level a) else if a.neg.is_true then sprintf ":0%s" (level a) else ":X" let premise fmt v = List.iter (fun {name=name} -> fprintf fmt "%s," name) v let atom fmt a = fprintf fmt "%s%d%s [index=%d | lit:%a] vpremise={{%a}}" (sign a) (a.var.vid+1) (value a) a.var.index Literal.LT.print a.lit premise a.var.vpremise let atoms_list fmt l = List.iter (fprintf fmt "%a ; " atom) l let atoms_array fmt arr = Array.iter (fprintf fmt "%a ; " atom) arr let atoms_vec fmt vec = for i = 0 to Vec.size vec - 1 do fprintf fmt "%a ; " atom (Vec.get vec i) done let clause fmt {name=name; atoms=arr; cpremise=cp} = fprintf fmt "%s:{ %a} cpremise={{%a}}" name atoms_vec arr premise cp end let pr_atom = Debug.atom let pr_clause = Debug.clause module MA = Literal.LT.Map let ale = Hstring.make "<=" let alt = Hstring.make "<" let agt = Hstring.make ">" let is_le n = Hstring.compare n ale = 0 let is_lt n = Hstring.compare n alt = 0 let is_gt n = Hstring.compare n agt = 0 let normal_form lit = (* XXX do better *) let av, is_neg = Literal.LT.atom_view lit in (if is_neg then Literal.LT.neg lit else lit), is_neg let max_depth a = let l = match Literal.LT.view a with | Literal.Eq (s,t) -> [s;t] | Literal.Distinct(_,l) -> l | Literal.Builtin (_,_,l) -> l | Literal.Pred (p,_) -> [p] in List.fold_left (fun z t -> max z (Term.view t).Term.depth) 0 l let literal a = a.lit let weight a = a.var.weight let is_true a = a.is_true let level a = a.var.level let index a = a.var.index let neg a = a.neg let cpt_mk_var = ref 0 let ma = ref MA.empty let make_var = fun lit -> let lit, negated = normal_form lit in try MA.find lit !ma, negated with Not_found -> let cpt_fois_2 = !cpt_mk_var lsl 1 in let rec var = { vid = !cpt_mk_var; pa = pa; na = na; level = -1; index = -1; reason = None; weight = 0.; sweight = max_depth lit; seen = false; vpremise = []; } and pa = { var = var; lit = lit; watched = Vec.make 10 dummy_clause; neg = na; is_true = false; aid = cpt_fois_2 (* aid = vid*2 *) } and na = { var = var; lit = Literal.LT.neg lit; watched = Vec.make 10 dummy_clause; neg = pa; is_true = false; aid = cpt_fois_2 + 1 (* aid = vid*2+1 *) } in ma := MA.add lit var !ma; incr cpt_mk_var; var, negated let made_vars_info () = !cpt_mk_var, MA.fold (fun lit var acc -> var::acc)!ma [] let add_atom lit = let var, negated = make_var lit in if negated then var.na else var.pa let get_var lit = let lit, negated = normal_form lit in try MA.find lit !ma, negated with Not_found -> assert false let vrai_atom = let a = add_atom Literal.LT.vrai in a.is_true <- true; a.var.level <- 0; a.var.reason <- None; a let faux_atom = vrai_atom.neg let make_clause name ali f sz_ali is_learnt premise = let atoms = Vec.from_list ali sz_ali dummy_atom in { name = name; atoms = atoms; removed = false; learnt = is_learnt; activity = 0.; cpremise = premise; form = f} let fresh_lname = let cpt = ref 0 in fun () -> incr cpt; "L" ^ (string_of_int !cpt) let fresh_dname = let cpt = ref 0 in fun () -> incr cpt; "D" ^ (string_of_int !cpt) let fresh_name = let cpt = ref 0 in fun () -> incr cpt; "C" ^ (string_of_int !cpt) module Clause = struct let size c = Vec.size c.atoms let pop c = Vec.pop c.atoms let shrink c i = Vec.shrink c.atoms i true let last c = Vec.last c.atoms let get c i = Vec.get c.atoms i let set c i v = Vec.set c.atoms i v end let to_float i = float_of_int i let to_int f = int_of_float f let clear () = cpt_mk_var := 0; ma := MA.empty (*end*) let cmp_var v1 v2 = v1.vid - v2.vid let eq_var v1 v2 = v1.vid - v2.vid = 0 let tag_var v = v.vid let h_var v = v.vid let cmp_atom a1 a2 = a1.aid - a2.aid let eq_atom a1 a2 = a1.aid - a2.aid = 0 let hash_atom a1 = a1.aid let tag_atom a1 = a1.aid let iter_atoms_of_clauses cls f = Vec.iter cls (fun c -> Vec.iter c.atoms f) end (******************************************************************************) module type FF_SIG = sig type t type view = private UNIT of Types.atom | AND of t list | OR of t list val equal : t -> t -> bool val compare : t -> t -> int val print : Format.formatter -> t -> unit val print_stats : Format.formatter -> unit val vrai : t val faux : t val view : t -> view val mk_lit : Literal.LT.t -> t val mk_and : t list -> t val mk_or : t list -> t val mk_not : t -> t val simplify : Formula.t -> (Formula.t -> t * 'a) -> t * (Formula.t * (t * Types.atom)) list val cnf_abstr : t -> (Types.atom * Types.atom list * bool) Util.MI.t -> Types.atom * (Types.atom * Types.atom list * bool) list * (Types.atom * Types.atom list * bool) Util.MI.t val expand_proxy_defn : Types.atom list list -> Types.atom * Types.atom list * bool -> Types.atom list list module Set : Set.S with type elt = t module Map : Map.S with type key = t end module Flat_Formula : FF_SIG = struct type view = UNIT of Types.atom | AND of t list | OR of t list and t = { pos : view ; neg : view; tpos : int; tneg : int } let mk_not {pos=pos; neg=neg;tpos=tpos; tneg=tneg} = {pos=neg; neg=pos;tpos=tneg; tneg=tpos} module HC = Hconsing.Make (struct type elt = t let set_id tag f = { f with tpos = 2*tag; tneg = 2*tag+1 } let eq f1 f2 = let eq_aux c1 c2 = match c1, c2 with | UNIT x , UNIT y -> Types.eq_atom x y | AND u , AND v | OR u , OR v -> (try List.iter2 (fun x y -> if x.tpos <> y.tpos then raise Exit) u v; true with | Exit -> false | Invalid_argument s -> assert (String.compare s "List.iter2" = 0); false) | _, _ -> false in eq_aux f1.pos f2.pos let hash f = let h_aux f = match f with | UNIT a -> Types.hash_atom a | AND l -> List.fold_left (fun acc f -> acc * 19 + f.tpos) 1 l | OR l -> List.fold_left (fun acc f -> acc * 23 + f.tpos) 1 l in let h = h_aux f.pos in match f.pos with | UNIT _ -> abs (3 * h) | AND _ -> abs (3 * h + 1) | OR _ -> abs (3 * h + 2) let neg f = mk_not f let initial_size = 4096 let disable_weaks () = Options.disable_weaks () end) let cpt = ref 0 let sp() = let s = ref "" in for i = 1 to !cpt do s := " " ^ !s done; !s ^ !s let rec print fmt fa = match fa.pos with | UNIT a -> fprintf fmt "%a" Types.pr_atom a | AND s -> incr cpt; fprintf fmt "(and%a" print_list s; decr cpt; fprintf fmt "@.%s)" (sp()) | OR s -> incr cpt; fprintf fmt "(or%a" print_list s; decr cpt; fprintf fmt "@.%s)" (sp()) and print_list fmt l = match l with | [] -> assert false | e::l -> fprintf fmt "@.%s%a" (sp()) print e; List.iter(fprintf fmt "@.%s%a" (sp()) print) l let print fmt f = cpt := 0; print fmt f let print_stats fmt = () let compare f1 f2 = f1.tpos - f2.tpos let equal f1 f2 = f1.tpos - f2.tpos = 0 let hash f = f.tpos let tag f = f.tpos let view f = f.pos let is_positive pos = match pos with | AND _ -> true | OR _ -> false | UNIT at -> at == at.Types.var.Types.pa let make pos neg = let is_pos = is_positive pos in if is_pos then HC.make {pos=pos ; neg=neg; tpos= -1; tneg= -1 (*dump*)} else mk_not (HC.make {pos=neg ; neg=pos; tpos= -1; tneg= -1 (*dump*)}) let aaz a = assert (a.Types.var.Types.level = 0) let complements f1 f2 = f1.tpos - f2.tneg = 0 let mk_lit a = let at = Types.add_atom a in make (UNIT at) (UNIT at.Types.neg) let vrai = mk_lit Literal.LT.vrai let faux = mk_not vrai let merge_and_check l1 l2 = let rec merge_rec l1 l2 hd = match l1, l2 with | [], l2 -> l2 | l1, [] -> l1 | h1 :: t1, h2 :: t2 -> let c = compare h1 h2 in if c = 0 then merge_rec l1 t2 hd else if compare h1 h2 < 0 then begin if complements hd h1 then raise Exit; h1 :: merge_rec t1 l2 h1 end else begin if complements hd h2 then raise Exit; h2 :: merge_rec l1 t2 h2 end in match l1, l2 with | [], l2 -> l2 | l1, [] -> l1 | h1 :: t1, h2 :: t2 -> let c = compare h1 h2 in if c = 0 then merge_rec t1 l2 h1 else if compare h1 h2 < 0 then merge_rec l1 l2 h1 else merge_rec l1 l2 h2 let mk_and l = try let so, nso = List.fold_left (fun ((so,nso) as acc) e -> match e.pos with | AND l -> merge_and_check so l, nso | UNIT a when a.Types.var.Types.level = 0 -> if a.Types.neg.Types.is_true then (aaz a; raise Exit); (* XXX*) if a.Types.is_true then (aaz a; acc) else so, e::nso | _ -> so, e::nso )([],[]) l in let delta_inv = List.fast_sort (fun a b -> compare b a) nso in let delta_u = match delta_inv with | [] -> delta_inv | e::l -> let _, delta_u = List.fold_left (fun ((c,l) as acc) e -> if complements c e then raise Exit; if equal c e then acc else (e, e::l) )(e,[e]) l in delta_u in match merge_and_check so delta_u with | [] -> vrai | [e]-> e | l -> make (AND l) (OR (List.rev (List.rev_map mk_not l))) with Exit -> faux (* res = l1 inter l2 *) let intersect_list l1 l2 = let rec inter l1 l2 acc = match l1, l2 with | [], _ | _ , [] -> List.rev acc | f1::r1, f2::r2 -> let c = compare f1 f2 in if c = 0 then inter r1 r2 (f1::acc) else if c > 0 then inter l1 r2 acc else inter r1 l2 acc in inter l1 l2 [] exception Not_included let remove_elt e l = let rec relt l acc = match l with | [] -> raise Not_included | f::r -> let c = compare f e in if c = 0 then List.rev_append acc r else if c < 0 then relt r (f::acc) else raise Not_included in relt l [] let diff_list to_exclude l = let rec diff l1 l2 acc = match l1, l2 with | [], [] -> List.rev acc | [], r -> List.rev_append acc r | _ , [] -> raise Not_included | f1::r1, f2::r2 -> let c = compare f1 f2 in if c = 0 then diff r1 r2 acc else if c > 0 then diff l1 r2 (f2::acc) else raise Not_included in diff to_exclude l [] let extract_common l = let atoms, ands = List.fold_left (fun (atoms, ands) f -> match view f with | OR _ -> assert false | UNIT a -> f::atoms, ands | AND l -> atoms, l::ands )([],[]) l in match atoms, ands with | [], [] -> assert false | _::_::_, _ -> if debug () then fprintf fmt "Failure: many distinct atoms@."; None | [_] as common, _ -> if debug () then fprintf fmt "TODO: Should have one toplevel common atom@."; begin try (* a + (a . B_1) + ... (a . B_n) = a *) ignore (List.rev_map (diff_list common) ands); Some (common, [[]]) with Not_included -> None end | [], ad::ands' -> if debug () then fprintf fmt "Should look for internal common parts@."; let common = List.fold_left intersect_list ad ands' in match common with [] -> None | _ -> try Some (common, List.rev_map (diff_list common) ands) with Not_included -> assert false let rec mk_or l = try let so, nso = List.fold_left (fun ((so,nso) as acc) e -> match e.pos with | OR l -> merge_and_check so l, nso | UNIT a when a.Types.var.Types.level = 0 -> if a.Types.is_true then (aaz a; raise Exit); (* XXX *) if a.Types.neg.Types.is_true then (aaz a; acc) else so, e::nso | _ -> so, e::nso )([],[]) l in let delta_inv = List.fast_sort (fun a b -> compare b a) nso in let delta_u = match delta_inv with | [] -> delta_inv | e::l -> let _, delta_u = List.fold_left (fun ((c,l) as acc) e -> if complements c e then raise Exit; if equal c e then acc else (e, e::l) )(e,[e]) l in delta_u in match merge_and_check so delta_u with | [] -> faux | [e]-> e | l -> match extract_common l with | None -> begin match l with | [{pos=UNIT _} as fa;{pos=AND ands}] -> begin try mk_or [fa ; (mk_and (remove_elt (mk_not fa) ands))] with Not_included -> make (OR l) (AND (List.rev (List.rev_map mk_not l))) end | _ -> make (OR l) (AND (List.rev (List.rev_map mk_not l))) end | Some (com,ands) -> let ands = List.rev_map mk_and ands in mk_and ((mk_or ands) :: com) with Exit -> vrai (* translation from Formula.t *) let abstract_lemma abstr f tl lem = try fst (abstr f) with Not_found -> try fst (List.assoc f !lem) with Not_found -> if tl then begin lem := (f, (vrai, Types.vrai_atom)) :: !lem; vrai end else let lit = A.mk_pred (T.fresh_name Ty.Tbool) false in let xlit = mk_lit lit in lem := (f, (xlit, Types.add_atom lit)) :: !lem; xlit let simplify f abstr = let lem = ref [] in let rec simp topl f = match F.view f with | F.Literal a -> mk_lit a | F.Lemma _ -> abstract_lemma abstr f topl lem | F.Skolem _ -> mk_not (simp false (F.mk_not f)) | F.Unit(f1, f2) -> let x1 = simp topl f1 in let x2 = simp topl f2 in begin match x1.pos , x2.pos with | AND l1, AND l2 -> mk_and (List.rev_append l1 l2) | AND l1, _ -> mk_and (x2 :: l1) | _ , AND l2 -> mk_and (x1 :: l2) | _ -> mk_and [x1; x2] end | F.Clause(f1, f2, _) -> let x1 = simp false f1 in let x2 = simp false f2 in begin match x1.pos, x2.pos with | OR l1, OR l2 -> mk_or (List.rev_append l1 l2) | OR l1, _ -> mk_or (x2 :: l1) | _ , OR l2 -> mk_or (x1 :: l2) | _ -> mk_or [x1; x2] end | F.Let {F.let_var=lvar; let_term=lterm; let_subst=s; let_f=lf} -> let f' = F.apply_subst s lf in let v = Symbols.Map.find lvar (fst s) in let at = mk_lit (A.mk_eq v lterm) in let res = simp topl f' in begin match res.pos with | AND l -> mk_and (at :: l) | _ -> mk_and [at; res] end in simp true f, !lem (* CNF_ABSTR a la Tseitin *) let atom_of_lit lit is_neg = let a = Types.add_atom lit in if is_neg then a.Types.neg else a let mk_new_proxy n = let hs = Hs.make ("PROXY__" ^ (string_of_int n)) in let sy = Symbols.Name(hs, Symbols.Other) in A.mk_pred (Term.make sy [] Ty.Tbool) false let get_proxy_of f proxies_mp = try let p, _, _ = Util.MI.find f.tpos !proxies_mp in Some p with Not_found -> try let p, _, _ = Util.MI.find f.tneg !proxies_mp in Some p.Types.neg with Not_found -> None let expand_proxy_defn acc (p, l, is_and) = if is_and then (* p <=> (l1 and ... and l_n) *) let np = p.Types.neg in let cl, acc = List.fold_left (fun (cl,acc) a -> (a.Types.neg :: cl), [np; a] :: acc)([p],acc) l in cl :: acc else (* p <=> (l1 or ... or l_n) *) let acc = List.fold_left (fun acc a -> [p;a.Types.neg]::acc) acc l in ((p.Types.neg) :: l) :: acc let cnf_abstr f proxies_mp = let proxies_mp = ref proxies_mp in let new_proxies = ref [] in let rec abstr f = match f.pos with | UNIT a -> a | AND l | OR l -> match get_proxy_of f proxies_mp with | Some p -> p | None -> let l = List.rev (List.rev_map abstr l) in let p = atom_of_lit (mk_new_proxy f.tpos) false in let is_and = match f.pos with | AND _ -> true | OR _ -> false | UNIT _ -> assert false in new_proxies := (p, l, is_and) :: !new_proxies; proxies_mp := Util.MI.add f.tpos (p, l, is_and) !proxies_mp; p in let abstr_f = abstr f in abstr_f, !new_proxies, !proxies_mp module Set = Set.Make(struct type t'=t type t=t' let compare=compare end) module Map = Map.Make(struct type t'=t type t=t' let compare=compare end) end (******************************************************************************) open Types module Ex = Explanation exception Sat exception Unsat of clause list exception Restart let vraie_form = Formula.vrai module type SAT_ML = sig (*module Make (Dummy : sig end) : sig*) type state type th val solve : unit -> unit val assume : Types.atom list list -> Formula.t -> cnumber : int -> unit val boolean_model : unit -> Types.atom list val current_tbox : unit -> th val set_current_tbox : th -> unit val empty : unit -> unit val clear : unit -> unit val save : unit -> state val restore : state -> unit val reset_steps : unit -> unit val get_steps : unit -> int64 val assume_th_elt : Commands.th_elt -> unit val decision_level : unit -> int val cancel_until : int -> unit (*end*) end module Make (Th : Theory.S) : SAT_ML with type th = Th.t = struct type th = Th.t type env = { (* si vrai, les contraintes sont deja fausses *) mutable is_unsat : bool; mutable unsat_core : clause list; (* clauses du probleme *) mutable clauses : clause Vec.t; (* clauses apprises *) mutable learnts : clause Vec.t; (* valeur de l'increment pour l'activite des clauses *) mutable clause_inc : float; (* valeur de l'increment pour l'activite des variables *) mutable var_inc : float; (* un vecteur des variables du probleme *) mutable vars : var Vec.t; (* la pile de decisions avec les faits impliques *) mutable trail : atom Vec.t; (* une pile qui pointe vers les niveaux de decision dans trail *) mutable trail_lim : int Vec.t; (* Tete de la File des faits unitaires a propager. C'est un index vers le trail *) mutable qhead : int; (* Nombre des assignements top-level depuis la derniere execution de 'simplify()' *) mutable simpDB_assigns : int; (* Nombre restant de propagations a faire avant la prochaine execution de 'simplify()' *) mutable simpDB_props : int; (* Un tas ordone en fonction de l'activite des variables *) mutable order : Iheap.t; (* estimation de progressions, mis a jour par 'search()' *) mutable progress_estimate : float; (* *) remove_satisfied : bool; (* inverse du facteur d'acitivte des variables, vaut 1/0.999 par defaut *) var_decay : float; (* inverse du facteur d'activite des clauses, vaut 1/0.95 par defaut *) clause_decay : float; (* la limite de restart initiale, vaut 100 par defaut *) mutable restart_first : int; (* facteur de multiplication de restart limite, vaut 1.5 par defaut*) restart_inc : float; (* limite initiale du nombre de clause apprises, vaut 1/3 des clauses originales par defaut *) mutable learntsize_factor : float; (* multiplier learntsize_factor par cette valeur a chaque restart, vaut 1.1 par defaut *) learntsize_inc : float; (* controler la minimisation des clauses conflit, vaut true par defaut *) expensive_ccmin : bool; (* controle la polarite a choisir lors de la decision *) polarity_mode : bool; mutable starts : int; mutable decisions : int; mutable propagations : int; mutable conflicts : int; mutable clauses_literals : int; mutable learnts_literals : int; mutable max_literals : int; mutable tot_literals : int; mutable nb_init_vars : int; mutable nb_init_clauses : int; mutable model : var Vec.t; mutable tenv : Th.t; mutable tenv_queue : Th.t Vec.t; mutable tatoms_queue : atom Queue.t; mutable cpt_current_propagations : int; } exception Conflict of clause (*module Make (Dummy : sig end) = struct*) module Solver_types = Types(*.Make(struct end)*) let steps = ref 0L let reset_steps () = steps := 0L let get_steps () = !steps open Solver_types type state = { env : env; st_cpt_mk_var: int; st_ma : var Literal.LT.Map.t; } let env = { is_unsat = false; unsat_core = [] ; clauses = Vec.make 0 dummy_clause; (*sera mis a jour lors du parsing*) learnts = Vec.make 0 dummy_clause; (*sera mis a jour lors du parsing*) clause_inc = 1.; var_inc = 1.; vars = Vec.make 0 dummy_var; (*sera mis a jour lors du parsing*) trail = Vec.make 601 dummy_atom; trail_lim = Vec.make 601 (-105); qhead = 0; simpDB_assigns = -1; simpDB_props = 0; order = Iheap.init 0; (* sera mis a jour dans solve *) progress_estimate = 0.; remove_satisfied = true; var_decay = 1. /. 0.95; clause_decay = 1. /. 0.999; restart_first = 100; restart_inc = 1.5; learntsize_factor = 1. /. 3. ; learntsize_inc = 1.1; expensive_ccmin = true; polarity_mode = false; starts = 0; decisions = 0; propagations = 0; conflicts = 0; clauses_literals = 0; learnts_literals = 0; max_literals = 0; tot_literals = 0; nb_init_vars = 0; nb_init_clauses = 0; model = Vec.make 0 dummy_var; tenv = Th.empty(); tenv_queue = Vec.make 100 (Th.empty()); tatoms_queue = Queue.create (); cpt_current_propagations = 0; } (* module SA = Set.Make (struct type t = Types.atom let compare a b = a.Types.aid - b.Types.aid end) module SSA = Set.Make(SA) let ssa = ref SSA.empty let clause_exists atoms = try (*List.iter (fun a -> if a.is_true then raise Exit) atoms;*) let sa = List.fold_left (fun s e -> SA.add e s) SA.empty atoms in if SSA.mem sa !ssa then true else begin ssa := SSA.add sa !ssa; false end with Exit -> true let f_weight i j = let vj = Vec.get env.vars j in let vi = Vec.get env.vars i in (*if vi.sweight <> vj.sweight then vi.sweight < vj.sweight else*) vj.weight < vi.weight *) let f_weight i j = Pervasives.(<) (Vec.get env.vars j).weight (Vec.get env.vars i).weight let f_filter i = (Vec.get env.vars i).level < 0 let insert_var_order v = Iheap.insert f_weight env.order v.vid let var_decay_activity () = env.var_inc <- env.var_inc *. env.var_decay let clause_decay_activity () = env.clause_inc <- env.clause_inc *. env.clause_decay let var_bump_activity v = v.weight <- v.weight +. env.var_inc; if Pervasives.(>) v.weight 1e100 then begin for i = 0 to env.vars.Vec.sz - 1 do (Vec.get env.vars i).weight <- (Vec.get env.vars i).weight *. 1e-100 done; env.var_inc <- env.var_inc *. 1e-100; end; if Iheap.in_heap env.order v.vid then Iheap.decrease f_weight env.order v.vid let clause_bump_activity c = c.activity <- c.activity +. env.clause_inc; if Pervasives.(>) c.activity 1e20 then begin for i = 0 to env.learnts.Vec.sz - 1 do (Vec.get env.learnts i).activity <- (Vec.get env.learnts i).activity *. 1e-20; done; env.clause_inc <- env.clause_inc *. 1e-20 end let decision_level () = Vec.size env.trail_lim let nb_assigns () = Vec.size env.trail let nb_clauses () = Vec.size env.clauses let nb_learnts () = Vec.size env.learnts let nb_vars () = Vec.size env.vars let new_decision_level () = env.decisions <- env.decisions + 1; Vec.push env.trail_lim (Vec.size env.trail); if Options.profiling() then Profiling.decision (decision_level()) ""; Vec.push env.tenv_queue env.tenv (* save the current tenv *) let attach_clause c = Vec.push (Vec.get c.atoms 0).neg.watched c; Vec.push (Vec.get c.atoms 1).neg.watched c; if c.learnt then env.learnts_literals <- env.learnts_literals + Vec.size c.atoms else env.clauses_literals <- env.clauses_literals + Vec.size c.atoms let detach_clause c = c.removed <- true; (* Vec.remove (Vec.get c.atoms 0).neg.watched c; Vec.remove (Vec.get c.atoms 1).neg.watched c; *) if c.learnt then env.learnts_literals <- env.learnts_literals - Vec.size c.atoms else env.clauses_literals <- env.clauses_literals - Vec.size c.atoms let remove_clause c = detach_clause c let satisfied c = try for i = 0 to Vec.size c.atoms - 1 do if (Vec.get c.atoms i).is_true then raise Exit done; false with Exit -> true (* annule tout jusqu'a lvl *exclu* *) let cancel_until lvl = if decision_level () > lvl then begin env.qhead <- Vec.get env.trail_lim lvl; for c = Vec.size env.trail - 1 downto env.qhead do let a = Vec.get env.trail c in a.is_true <- false; a.neg.is_true <- false; a.var.level <- -1; a.var.index <- -1; a.var.reason <- None; a.var.vpremise <- []; insert_var_order a.var done; Queue.clear env.tatoms_queue; env.tenv <- Vec.get env.tenv_queue lvl; (* recover the right tenv *) Vec.shrink env.trail ((Vec.size env.trail) - env.qhead) true; Vec.shrink env.trail_lim ((Vec.size env.trail_lim) - lvl) true; Vec.shrink env.tenv_queue ((Vec.size env.tenv_queue) - lvl) true; (try let last_dec = if Vec.size env.trail_lim = 0 then 0 else Vec.last env.trail_lim in env.cpt_current_propagations <- (Vec.size env.trail) - last_dec with e -> assert false ); end; if Options.profiling() then Profiling.reset_dlevel (decision_level()); assert (Vec.size env.trail_lim = Vec.size env.tenv_queue) let rec pick_branch_var () = if Iheap.size env.order = 0 then raise Sat; let max = Iheap.remove_min f_weight env.order in let v = Vec.get env.vars max in if v.level>= 0 then begin assert (v.pa.is_true || v.na.is_true); pick_branch_var () end else v let pick_branch_lit () = let v = pick_branch_var () in v.na let enqueue a lvl reason = assert (not a.is_true && not a.neg.is_true && a.var.level < 0 && a.var.reason == None && lvl >= 0); (* Garder la reason car elle est utile pour les unsat-core *) (*let reason = if lvl = 0 then None else reason in*) a.is_true <- true; a.var.level <- lvl; a.var.reason <- reason; (*eprintf "enqueue: %a@." Debug.atom a; *) Vec.push env.trail a; a.var.index <- Vec.size env.trail let progress_estimate () = let prg = ref 0. in let nbv = to_float (nb_vars()) in let lvl = decision_level () in let _F = 1. /. nbv in for i = 0 to lvl do let _beg = if i = 0 then 0 else Vec.get env.trail_lim (i-1) in let _end = if i=lvl then Vec.size env.trail else Vec.get env.trail_lim i in prg := !prg +. _F**(to_float i) *. (to_float (_end - _beg)) done; !prg /. nbv let propagate_in_clause a c i watched new_sz = let atoms = c.atoms in let first = Vec.get atoms 0 in if first == a.neg then begin (* le litiral faux doit etre dans .(1) *) Vec.set atoms 0 (Vec.get atoms 1); Vec.set atoms 1 first end; let first = Vec.get atoms 0 in if first.is_true then begin (* clause vraie, la garder dans les watched *) Vec.set watched !new_sz c; incr new_sz; if Options.profiling() then Profiling.elim true; end else try (* chercher un nouveau watcher *) for k = 2 to Vec.size atoms - 1 do let ak = Vec.get atoms k in if not (ak.neg.is_true) then begin (* Watcher Trouve: mettre a jour et sortir *) Vec.set atoms 1 ak; Vec.set atoms k a.neg; Vec.push ak.neg.watched c; raise Exit end done; (* Watcher NON Trouve *) if first.neg.is_true then begin (* la clause est fausse *) env.qhead <- Vec.size env.trail; for k = i to Vec.size watched - 1 do Vec.set watched !new_sz (Vec.get watched k); incr new_sz; done; if Options.profiling() then Profiling.bcp_conflict true true; raise (Conflict c) end else begin (* la clause est unitaire *) Vec.set watched !new_sz c; incr new_sz; enqueue first (decision_level ()) (Some c); if Options.profiling() then Profiling.red true; end with Exit -> () let propagate_atom a res = let watched = a.watched in let new_sz_w = ref 0 in begin try for i = 0 to Vec.size watched - 1 do let c = Vec.get watched i in if not c.removed then propagate_in_clause a c i watched new_sz_w done; with Conflict c -> assert (!res == None); res := Some c end; let dead_part = Vec.size watched - !new_sz_w in Vec.shrink watched dead_part true let do_case_split origin = if Options.case_split_policy () != Util.AfterTheoryAssume then failwith "Only AfterTheoryAssume case-split policy is supported by satML"; if Options.case_split_policy () == origin then try let tenv, _ = Th.do_case_split env.tenv in env.tenv <- tenv; None with Exception.Inconsistent (expl, classes) -> Some expl else None let expensive_theory_propagate () = None (* try *) (* if D1.d then eprintf "expensive_theory_propagate@."; *) (* ignore(Th.expensive_processing env.tenv); *) (* if D1.d then eprintf "expensive_theory_propagate => None@."; *) (* None *) (* with Exception.Inconsistent dep -> *) (* if D1.d then eprintf "expensive_theory_propagate => Inconsistent@."; *) (* Some dep *) let theory_propagate () = let facts = ref [] in let dlvl = decision_level () in while not (Queue.is_empty env.tatoms_queue) do let a = Queue.pop env.tatoms_queue in let ta = if a.is_true then a else if a.neg.is_true then a.neg (* TODO: useful ?? *) else assert false in let ex = if proof () || ta.var.level > 0 then Ex.singleton (Ex.Literal ta.lit) else Ex.empty in assert (Literal.LT.is_ground ta.lit); facts := (ta.lit, ex, dlvl,env.cpt_current_propagations) :: !facts; env.cpt_current_propagations <- env.cpt_current_propagations + 1 done; try (*let full_model = nb_assigns() = env.nb_init_vars in*) (* XXX what to do with the other results of Th.assume ? *) let t,_,cpt = Th.assume (List.rev !facts) env.tenv in steps := Int64.add (Int64.of_int cpt) !steps; if steps_bound () <> -1 && Int64.compare !steps (Int64.of_int (steps_bound ())) > 0 then begin printf "Steps limit reached: %Ld@." !steps; exit 1 end; env.tenv <- t; do_case_split Util.AfterTheoryAssume (*if full_model then expensive_theory_propagate () else None*) with Exception.Inconsistent (dep, terms) -> (* XXX what to do with terms ? *) (* eprintf "th inconsistent : %a @." Ex.print dep; *) if Options.profiling() then Profiling.theory_conflict(); Some dep let propagate () = let num_props = ref 0 in let res = ref None in (*assert (Queue.is_empty env.tqueue);*) while env.qhead < Vec.size env.trail do let a = Vec.get env.trail env.qhead in env.qhead <- env.qhead + 1; incr num_props; propagate_atom a res; Queue.push a env.tatoms_queue; done; env.propagations <- env.propagations + !num_props; env.simpDB_props <- env.simpDB_props - !num_props; !res let analyze c_clause = let pathC = ref 0 in let learnt = ref [] in let cond = ref true in let blevel = ref 0 in let seen = ref [] in let c = ref c_clause in let tr_ind = ref (Vec.size env.trail - 1) in let size = ref 1 in let history = ref [] in while !cond do if !c.learnt then clause_bump_activity !c; history := !c :: !history; (* visit the current predecessors *) for j = 0 to Vec.size !c.atoms - 1 do let q = Vec.get !c.atoms j in (*printf "I visit %a@." D1.atom q;*) assert (q.is_true || q.neg.is_true && q.var.level >= 0); (* Pas sur *) if not q.var.seen && q.var.level > 0 then begin var_bump_activity q.var; q.var.seen <- true; seen := q :: !seen; if q.var.level >= decision_level () then incr pathC else begin learnt := q :: !learnt; incr size; blevel := max !blevel q.var.level end end done; (* look for the next node to expand *) while not (Vec.get env.trail !tr_ind).var.seen do decr tr_ind done; decr pathC; let p = Vec.get env.trail !tr_ind in decr tr_ind; match !pathC, p.var.reason with | 0, _ -> cond := false; learnt := p.neg :: (List.rev !learnt) | n, None -> assert false | n, Some cl -> c := cl done; List.iter (fun q -> q.var.seen <- false) !seen; !blevel, !learnt, !history, !size let f_sort_db c1 c2 = let sz1 = Vec.size c1.atoms in let sz2 = Vec.size c2.atoms in let c = Pervasives.compare c1.activity c2.activity in if sz1 = sz2 && c = 0 then 0 else if sz1 > 2 && (sz2 = 2 || c < 0) then -1 else 1 let locked c = false(* try for i = 0 to Vec.size env.vars - 1 do match (Vec.get env.vars i).reason with | Some c' when c ==c' -> raise Exit | _ -> () done; false with Exit -> true*) let reduce_db () = () (* let extra_lim = env.clause_inc /. (to_float (Vec.size env.learnts)) in Vec.sort env.learnts f_sort_db; let lim2 = Vec.size env.learnts in let lim1 = lim2 / 2 in let j = ref 0 in for i = 0 to lim1 - 1 do let c = Vec.get env.learnts i in if Vec.size c.atoms > 2 && not (locked c) then remove_clause c else begin Vec.set env.learnts !j c; incr j end done; for i = lim1 to lim2 - 1 do let c = Vec.get env.learnts i in if Vec.size c.atoms > 2 && not (locked c) && c.activity < extra_lim then remove_clause c else begin Vec.set env.learnts !j c; incr j end done; Vec.shrink env.learnts (lim2 - !j) true *) let remove_satisfied vec = let j = ref 0 in let k = Vec.size vec - 1 in for i = 0 to k do let c = Vec.get vec i in if satisfied c then remove_clause c else begin Vec.set vec !j (Vec.get vec i); incr j end done; Vec.shrink vec (k + 1 - !j) true module HUC = Hashtbl.Make (struct type t = clause let equal = (==) let hash = Hashtbl.hash end) let report_b_unsat ({atoms=atoms} as confl) = let l = ref [confl] in for i = 0 to Vec.size atoms - 1 do let v = (Vec.get atoms i).var in l := List.rev_append v.vpremise !l; match v.reason with None -> () | Some c -> l := c :: !l done; if false then begin eprintf "@.>>UNSAT Deduction made from:@."; List.iter (fun hc -> eprintf " %a@." Types.pr_clause hc )!l; end; let uc = HUC.create 17 in let rec roots todo = match todo with | [] -> () | c::r -> for i = 0 to Vec.size c.atoms - 1 do let v = (Vec.get c.atoms i).var in if not v.seen then begin v.seen <- true; roots v.vpremise; match v.reason with None -> () | Some r -> roots [r]; end done; match c.cpremise with | [] -> if not (HUC.mem uc c) then HUC.add uc c (); roots r | prems -> roots prems; roots r in roots !l; let unsat_core = HUC.fold (fun c _ l -> c :: l) uc [] in if false then begin eprintf "@.>>UNSAT_CORE:@."; List.iter (fun hc -> eprintf " %a@." Types.pr_clause hc )unsat_core; end; env.is_unsat <- true; env.unsat_core <- unsat_core; raise (Unsat unsat_core) let report_t_unsat dep = let l = Ex.fold_atoms (fun ex l -> match ex with | Ex.Literal lit -> let {var=v} = Types.add_atom lit in let l = List.rev_append v.vpremise l in begin match v.reason with | None -> l | Some c -> c :: l end | _ -> assert false (* TODO *) ) dep [] in if false then begin eprintf "@.>>T-UNSAT Deduction made from:@."; List.iter (fun hc -> eprintf " %a@." Types.pr_clause hc )l; end; let uc = HUC.create 17 in let rec roots todo = match todo with | [] -> () | c::r -> for i = 0 to Vec.size c.atoms - 1 do let v = (Vec.get c.atoms i).var in if not v.seen then begin v.seen <- true; roots v.vpremise; match v.reason with None -> () | Some r -> roots [r]; end done; match c.cpremise with | [] -> if not (HUC.mem uc c) then HUC.add uc c (); roots r | prems -> roots prems; roots r in roots l; let unsat_core = HUC.fold (fun c _ l -> c :: l) uc [] in if false then begin eprintf "@.>>T-UNSAT_CORE:@."; List.iter (fun hc -> eprintf " %a@." Types.pr_clause hc ) unsat_core; end; env.is_unsat <- true; env.unsat_core <- unsat_core; raise (Unsat unsat_core) (*** experimental: taken from ctrl-ergo-2 ******************** let rec theory_simplify () = let theory_simplification = 2 in let assume a = assert (Literal.LT.is_ground ta.lit); ignore (Th.assume a.lit Ex.empty env.tenv) in if theory_simplification >= 2 then begin for i = 0 to Vec.size env.vars - 1 do try let a = (Vec.get env.vars i).pa in if not (a.is_true || a.neg.is_true) then try assume a; try assume a.neg with Exception.Inconsistent _ -> if debug () then eprintf "%a propagated m/theory at level 0@.@." Types.pr_atom a; enqueue a 0 None (* Mettre Some dep pour les unsat-core*) with Exception.Inconsistent _ -> if debug () then eprintf "%a propagated m/theory at level 0@.@." Types.pr_atom a.neg; enqueue a.neg 0 None (* Mettre Some dep pour les unsat-core*) with Not_found -> () done; let head = env.qhead in if propagate () <> None || theory_propagate () <> None then raise (Unsat []); let head' = env.qhead in if head' > head then theory_simplify () end *) let simplify () = assert (decision_level () = 0); if env.is_unsat then raise (Unsat env.unsat_core); begin match propagate () with | Some confl -> report_b_unsat confl | None -> match theory_propagate () with Some dep -> report_t_unsat dep | None -> () end; if nb_assigns() <> env.simpDB_assigns && env.simpDB_props <= 0 then begin if debug () then fprintf fmt "simplify@."; (*theory_simplify ();*) if Vec.size env.learnts > 0 then remove_satisfied env.learnts; if env.remove_satisfied then remove_satisfied env.clauses; (*Iheap.filter env.order f_filter f_weight;*) env.simpDB_assigns <- nb_assigns (); env.simpDB_props <- env.clauses_literals + env.learnts_literals; end let record_learnt_clause blevel learnt history size = begin match learnt with | [] -> assert false | [fuip] -> assert (blevel = 0); fuip.var.vpremise <- history; enqueue fuip 0 None | fuip :: _ -> let name = fresh_lname () in let lclause = make_clause name learnt vraie_form size true history in Vec.push env.learnts lclause; attach_clause lclause; clause_bump_activity lclause; enqueue fuip blevel (Some lclause) end; var_decay_activity (); clause_decay_activity() let check_inconsistence_of dep = () (* try let env = ref (Th.empty()) in (); Ex.iter_atoms (fun atom -> let t,_,_ = Th.assume ~cs:true atom.lit (Ex.singleton atom) !env in env := t) dep; (* ignore (Th.expensive_processing !env); *) assert false with Exception.Inconsistent _ -> () *) let theory_analyze dep = let atoms, sz, max_lvl, c_hist = Ex.fold_atoms (fun ex (acc, sz, max_lvl, c_hist) -> match ex with Ex.Literal lit -> let a = Types.add_atom lit in let c_hist = List.rev_append a.var.vpremise c_hist in let c_hist = match a.var.reason with | None -> c_hist | Some r -> r:: c_hist in if a.var.level = 0 then acc, sz, max_lvl, c_hist else a.neg :: acc, sz + 1, max max_lvl a.var.level, c_hist | _ -> assert false (* TODO *) ) dep ([], 0, 0, []) in if atoms == [] then begin (* check_inconsistence_of dep; *) report_t_unsat dep (* une conjonction de faits unitaires etaient deja unsat *) end; let name = fresh_dname() in let c_clause = make_clause name atoms vraie_form sz false c_hist in (* eprintf "c_clause: %a@." Types.pr_clause c_clause; *) c_clause.removed <- true; let pathC = ref 0 in let learnt = ref [] in let cond = ref true in let blevel = ref 0 in let seen = ref [] in let c = ref c_clause in let tr_ind = ref (Vec.size env.trail - 1) in let size = ref 1 in let history = ref [] in while !cond do if !c.learnt then clause_bump_activity !c; history := !c :: !history; (* visit the current predecessors *) for j = 0 to Vec.size !c.atoms - 1 do let q = Vec.get !c.atoms j in (*printf "I visit %a@." D1.atom q;*) assert (q.is_true || q.neg.is_true && q.var.level >= 0); (* Pas sur *) if not q.var.seen && q.var.level > 0 then begin (*(try fprintf fmt "%a -> %f@." Types.pr_atom q q.var.weight; var_bump_activity q.var; with Not_found -> fprintf fmt "%a -> %f NOT found@." Types.pr_atom q q.var.weight; assert false );*) q.var.seen <- true; seen := q :: !seen; if q.var.level >= max_lvl then incr pathC else begin learnt := q :: !learnt; incr size; blevel := max !blevel q.var.level end end done; (* look for the next node to expand *) while not (Vec.get env.trail !tr_ind).var.seen do decr tr_ind done; decr pathC; let p = Vec.get env.trail !tr_ind in decr tr_ind; match !pathC, p.var.reason with | 0, _ -> cond := false; learnt := p.neg :: (List.rev !learnt) | n, None -> assert false | n, Some cl -> c := cl done; List.iter (fun q -> q.var.seen <- false) !seen; !blevel, !learnt, !history, !size let add_boolean_conflict confl = env.conflicts <- env.conflicts + 1; if decision_level() = 0 then report_b_unsat confl; (* Top-level conflict *) let blevel, learnt, history, size = analyze confl in cancel_until blevel; record_learnt_clause blevel learnt history size exception TopClause exception BotClause let partial_model () = Options.partial_bmodel () && try for i = 0 to Vec.size env.clauses - 1 do let c = Vec.get env.clauses i in try for j = 0 to Vec.size c.atoms - 1 do if (Vec.get c.atoms j).is_true then raise TopClause done; raise BotClause with TopClause -> () done; true with BotClause -> false let search n_of_conflicts n_of_learnts = let conflictC = ref 0 in env.starts <- env.starts + 1; while (true) do match propagate () with | Some confl -> (* Conflict *) incr conflictC; add_boolean_conflict confl | None -> (* No Conflict *) match theory_propagate () with | Some dep -> incr conflictC; env.conflicts <- env.conflicts + 1; if decision_level() = 0 then report_t_unsat dep; (* T-L conflict *) let blevel, learnt, history, size = theory_analyze dep in cancel_until blevel; record_learnt_clause blevel learnt history size | None -> if nb_assigns () = env.nb_init_vars || partial_model () then raise Sat; if n_of_conflicts >= 0 && !conflictC >= n_of_conflicts then begin env.progress_estimate <- progress_estimate(); cancel_until 0; raise Restart end; if decision_level() = 0 then simplify (); if n_of_learnts >= 0 && Vec.size env.learnts - nb_assigns() >= n_of_learnts then reduce_db(); new_decision_level(); let next = pick_branch_lit () in let current_level = decision_level () in env.cpt_current_propagations <- 0; assert (next.var.level < 0); (* eprintf "decide: %a@." Types.pr_atom next; *) enqueue next current_level None done let check_clause c = let b = ref false in let atoms = c.atoms in for i = 0 to Vec.size atoms - 1 do let a = Vec.get atoms i in b := !b || a.is_true done; assert (!b) let check_vec vec = for i = 0 to Vec.size vec - 1 do check_clause (Vec.get vec i) done let check_model () = check_vec env.clauses; check_vec env.learnts let solve () = if env.is_unsat then raise (Unsat env.unsat_core); let n_of_conflicts = ref (to_float env.restart_first) in let n_of_learnts = ref ((to_float (nb_clauses())) *. env.learntsize_factor) in try while true do (try search (to_int !n_of_conflicts) (to_int !n_of_learnts); with Restart -> ()); n_of_conflicts := !n_of_conflicts *. env.restart_inc; n_of_learnts := !n_of_learnts *. env.learntsize_inc; done; with | Sat -> (*check_model ();*) raise Sat | (Unsat cl) as e -> (* check_unsat_core cl; *) raise e exception Trivial let partition atoms init = let rec partition_aux trues unassigned falses init = function | [] -> trues @ unassigned @ falses, init | a::r -> if a.is_true then if a.var.level = 0 then raise Trivial else (a::trues) @ unassigned @ falses @ r, init else if a.neg.is_true then if a.var.level = 0 then partition_aux trues unassigned falses (List.rev_append (a.var.vpremise) init) r else partition_aux trues unassigned (a::falses) init r else partition_aux trues (a::unassigned) falses init r in partition_aux [] [] [] init atoms let add_clause f ~cnumber atoms = if env.is_unsat then raise (Unsat env.unsat_core); (*if not (clause_exists atoms) then XXX TODO *) let init_name = string_of_int cnumber in let init0 = make_clause init_name atoms f (List.length atoms) false [] in try let atoms, init = if decision_level () = 0 then let atoms, init = List.fold_left (fun (atoms, init) a -> if a.is_true then raise Trivial; if a.neg.is_true then begin if Options.profiling() then Profiling.red true; atoms, (List.rev_append (a.var.vpremise) init) end else a::atoms, init ) ([], [init0]) atoms in List.fast_sort (fun a b -> a.var.vid - b.var.vid) atoms, init else partition atoms [init0] in let size = List.length atoms in match atoms with | [] -> report_b_unsat init0; | a::_::_ -> let name = fresh_name () in let clause = make_clause name atoms vraie_form size false init in attach_clause clause; Vec.push env.clauses clause; if debug_sat () && verbose () then fprintf fmt "[satML] add_clause: %a@." Types.pr_clause clause; if a.neg.is_true then begin let lvl = List.fold_left (fun m a -> max m a.var.level) 0 atoms in cancel_until lvl; add_boolean_conflict clause end | [a] -> if debug_sat () && verbose () then fprintf fmt "[satML] add_atom: %a@." Types.pr_atom a; cancel_until 0; a.var.vpremise <- init; enqueue a 0 None; match propagate () with None -> () | Some confl -> report_b_unsat confl with Trivial -> if Options.profiling() then Profiling.elim true let add_clauses cnf f ~cnumber = List.iter (add_clause f ~cnumber) cnf; match theory_propagate () with None -> () | Some dep -> report_t_unsat dep let init_solver cnf f ~cnumber = let nbv, _ = made_vars_info () in let nbc = env.nb_init_clauses + List.length cnf in Vec.grow_to_by_double env.vars nbv; Iheap.grow_to_by_double env.order nbv; List.iter (List.iter (fun a -> Vec.set env.vars a.var.vid a.var; insert_var_order a.var ) ) cnf; env.nb_init_vars <- nbv; Vec.grow_to_by_double env.model nbv; Vec.grow_to_by_double env.clauses nbc; Vec.grow_to_by_double env.learnts nbc; env.nb_init_clauses <- nbc; add_clauses cnf f ~cnumber let assume cnf f ~cnumber = match cnf with | [] -> () | _ -> (*let cnf = List.map (List.map Solver_types.add_atom) cnf in*) init_solver cnf f ~cnumber; if verbose () then begin fprintf fmt "%d clauses@." (Vec.size env.clauses); fprintf fmt "%d learnts@." (Vec.size env.learnts); end let boolean_model () = let l = ref [] in for i = Vec.size env.trail - 1 downto 0 do l := (Vec.get env.trail i) :: !l done; !l let current_tbox () = env.tenv let set_current_tbox tb = env.tenv <- tb let assume_th_elt th_elt = assert (decision_level () == 0); env.tenv <- Th.assume_th_elt (current_tbox ()) th_elt let empty () = for i = 0 to Vec.size env.vars - 1 do try let var = Vec.get env.vars i in var.pa.is_true <- false; var.na.is_true <- false; var.level <- -1; var.index <- -1; var.reason <- None; var.vpremise <- []; with Not_found -> () done; env.is_unsat <- false; env.unsat_core <- []; env.clauses <- Vec.make 0 dummy_clause; env.learnts <- Vec.make 0 dummy_clause; env.clause_inc <- 1.; env.var_inc <- 1.; env.vars <- Vec.make 0 dummy_var; env.qhead <- 0; env.simpDB_assigns <- -1; env.simpDB_props <- 0; env.order <- Iheap.init 0; (* sera mis a jour dans solve *) env.progress_estimate <- 0.; env.restart_first <- 100; env.starts <- 0; env.decisions <- 0; env.propagations <- 0; env.conflicts <- 0; env.clauses_literals <- 0; env.learnts_literals <- 0; env.max_literals <- 0; env.tot_literals <- 0; env.nb_init_vars <- 0; env.nb_init_clauses <- 0; env.tenv <- (Th.empty ()); env.model <- Vec.make 0 dummy_var; env.trail <- Vec.make 601 dummy_atom; env.trail_lim <- Vec.make 601 (-105); env.tenv_queue <- Vec.make 100 (Th.empty ()); env.tatoms_queue <- Queue.create () let clear () = empty (); Solver_types.clear () let copy (v : 'a) : 'a = Marshal.from_string (Marshal.to_string v []) 0 let save () = let sv = { env = env; st_cpt_mk_var = !Solver_types.cpt_mk_var; st_ma = !Solver_types.ma } in copy sv let restore { env = s_env; st_cpt_mk_var = st_cpt_mk_var; st_ma = st_ma } = env.is_unsat <- s_env.is_unsat; env.unsat_core <- s_env.unsat_core; env.clauses <- s_env.clauses; env.learnts <- s_env.learnts; env.clause_inc <- s_env.clause_inc; env.var_inc <- s_env.var_inc; env.vars <- s_env.vars; env.qhead <- s_env.qhead; env.simpDB_assigns <- s_env.simpDB_assigns; env.simpDB_props <- s_env.simpDB_props; env.order <- s_env.order; env.progress_estimate <- s_env.progress_estimate; env.restart_first <- s_env.restart_first; env.starts <- s_env.starts; env.decisions <- s_env.decisions; env.propagations <- s_env.propagations; env.conflicts <- s_env.conflicts; env.clauses_literals <- s_env.clauses_literals; env.learnts_literals <- s_env.learnts_literals; env.max_literals <- s_env.max_literals; env.tot_literals <- s_env.tot_literals; env.nb_init_vars <- s_env.nb_init_vars; env.nb_init_clauses <- s_env.nb_init_clauses; env.tenv <- s_env.tenv; env.model <- s_env.model; env.trail <- s_env.trail; env.trail_lim <- s_env.trail_lim; env.tenv_queue <- s_env.tenv_queue; env.tatoms_queue <- s_env.tatoms_queue; env.learntsize_factor <- s_env.learntsize_factor; Solver_types.cpt_mk_var := st_cpt_mk_var; Solver_types.ma := st_ma (*end*) end alt-ergo-free-2.0.0/plugins/common/0000775000175000017500000000000013430774474014726 5ustar mimialt-ergo-free-2.0.0/plugins/common/vec.mli0000664000175000017500000000340013430774474016203 0ustar mimi(******************************************************************************) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the license indicated *) (* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) (* present, please contact us to clarify licensing. *) (* *) (******************************************************************************) type 'a t = { mutable dummy: 'a; mutable data : 'a array; mutable sz : int } val make : int -> 'a -> 'a t val init : int -> (int -> 'a) -> 'a -> 'a t val from_array : 'a array -> int -> 'a -> 'a t val from_list : 'a list -> int -> 'a -> 'a t val clear : 'a t -> unit (* if bool is true, then put "dummy" is unreachable cells *) val shrink : 'a t -> int -> bool -> unit val pop : 'a t -> unit val size : 'a t -> int val is_empty : 'a t -> bool val grow_to : 'a t -> int -> unit val grow_to_double_size : 'a t -> unit val grow_to_by_double : 'a t -> int -> unit val is_full : 'a t -> bool val push : 'a t -> 'a -> unit val push_none : 'a t -> unit val last : 'a t -> 'a val get : 'a t -> int -> 'a val set : 'a t -> int -> 'a -> unit val set_size : 'a t -> int -> unit val copy : 'a t -> 'a t val move_to : 'a t -> 'a t -> unit val remove : 'a t -> 'a -> unit val fast_remove : 'a t -> 'a -> unit val sort : 'a t -> ('a -> 'a -> int) -> unit val iter : 'a t -> ('a -> unit) -> unit alt-ergo-free-2.0.0/plugins/common/vec.ml0000664000175000017500000000751613430774474016046 0ustar mimi(******************************************************************************) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the license indicated *) (* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) (* present, please contact us to clarify licensing. *) (* *) (******************************************************************************) open Options type 'a t = { mutable dummy: 'a; mutable data : 'a array; mutable sz : int } let make capa d = {data = Array.make capa d; sz = 0; dummy = d} let init capa f d = {data = Array.init capa (fun i -> f i); sz = capa; dummy = d} let from_array data sz d = {data = data; sz = sz; dummy = d} let from_list l sz d = let l = ref l in let f_init i = match !l with [] -> assert false | e::r -> l := r; e in {data = Array.init sz f_init; sz = sz; dummy = d} let clear s = s.sz <- 0 let shrink t i fill_with_dummy = assert (i >= 0 && i<=t.sz); if fill_with_dummy then for i = t.sz - i to t.sz - 1 do t.data.(i) <- t.dummy done; t.sz <- t.sz - i let pop t = assert (t.sz >=1); t.sz <- t.sz - 1 let size t = t.sz let is_empty t = t.sz = 0 let grow_to t new_capa = let data = t.data in let capa = Array.length data in t.data <- Array.init new_capa (fun i -> if i < capa then data.(i) else t.dummy) let grow_to_double_size t = let n = max 1 (Array.length t.data) in grow_to t (2 * n) let rec grow_to_by_double t new_capa = let new_capa = max 1 new_capa in let data = t.data in let capa = ref (Array.length data + 1) in while !capa < new_capa do capa := 2 * !capa done; grow_to t !capa let is_full t = Array.length t.data = t.sz let push t e = (*Format.eprintf "push; sz = %d et capa=%d@." t.sz (Array.length t.data);*) if is_full t then grow_to_double_size t; t.data.(t.sz) <- e; t.sz <- t.sz + 1 let push_none t = if is_full t then grow_to_double_size t; t.data.(t.sz) <- t.dummy; t.sz <- t.sz + 1 let last t = let e = t.data.(t.sz - 1) in assert (not (e == t.dummy)); e let get t i = assert (i < t.sz); let e = t.data.(i) in if e == t.dummy then raise Not_found else e let set t i v = t.data.(i) <- v; t.sz <- max t.sz (i + 1) let set_size t sz = t.sz <- sz let copy t = let data = t.data in let len = Array.length data in let data = Array.init len (fun i -> data.(i)) in { data=data; sz=t.sz; dummy = t.dummy } let move_to t t' = let data = t.data in let len = Array.length data in let data = Array.init len (fun i -> data.(i)) in t'.data <- data; t'.sz <- t.sz let remove t e = let j = ref 0 in while (!j < t.sz && not (t.data.(!j) == e)) do incr j done; assert (!j < t.sz); for i = !j to t.sz - 2 do t.data.(i) <- t.data.(i+1) done; pop t let fast_remove t e = let j = ref 0 in while (!j < t.sz && not (t.data.(!j) == e)) do incr j done; assert (!j < t.sz); t.data.(!j) <- last t; pop t let sort t f = let sub_arr = Array.sub t.data 0 t.sz in Array.fast_sort f sub_arr; t.data <- sub_arr let iter vec f = for i = 0 to size vec - 1 do f (get vec i) done (* template static inline void remove(V& ts, const T& t) { int j = 0; for (; j < ts.size() && ts[j] != t; j++); assert(j < ts.size()); ts[j] = ts.last(); ts.pop(); } #endif template static inline bool find(V& ts, const T& t) { int j = 0; for (; j < ts.size() && ts[j] != t; j++); return j < ts.size(); } #endif *) alt-ergo-free-2.0.0/opam0000664000175000017500000000172013430774474012634 0ustar mimiopam-version: "1.2" name: "alt-ergo" version: "2.0.0" maintainer: "alt-ergo@ocamlpro.com" authors: "Alt-Ergo developers" license: "OCamlPro Non-Commercial License + Apache" homepage: "http://alt-ergo.ocamlpro.com/" bug-reports: "https://github.com/OCamlPro/alt-ergo/issues" dev-repo: "https://github.com/OCamlPro/alt-ergo.git" build: [ ["autoconf"] ["./configure" "-prefix" "%{prefix}%"] [make] ] install: [ [make "install" "MANDIR=%{man}%"] ] remove: [ ["autoconf"] ["./configure" "-prefix" "%{prefix}%"] [make "uninstall" "MANDIR=%{man}%"] ] depends: [ "num" "zarith" "camlzip" "ocplib-simplex" {>= "0.4" } "menhir" "conf-autoconf" {build} ] depopts: [ "lablgtk" "conf-gtksourceview" ] available: [ ocaml-version >= "4.04.0" ] conflicts: [ "alt-ergo" {< "2.0.0" } "altgr-ergo" {< "2.0.0" } "satML-plugin" {< "2.0.0" } "profiler-plugin" {< "2.0.0" } "fm-simplex-plugin" {< "2.0.0" } ]alt-ergo-free-2.0.0/examples/0000755000175000017500000000000013430774474013571 5ustar mimialt-ergo-free-2.0.0/examples/invalid/0000755000175000017500000000000013430774474015217 5ustar mimialt-ergo-free-2.0.0/examples/invalid/bitv.why0000644000175000017500000000021513430774474016712 0ustar mimi logic f : 'a -> bitv[2] goal g11: forall x:bitv[3]. forall y:bitv[2]. forall z:'a. x=y@[|1|] -> f(z)=y -> f(z)^{0,0} = x^{0,0} alt-ergo-free-2.0.0/examples/invalid/arrays.why0000644000175000017500000000022313430774474017246 0ustar mimi goal g5: forall a,b : ('a,'b) farray. forall i,j : 'a. forall v,w : 'b. v = a[j] -> w = b[i] -> a[j<-w] = b[i<-v] -> a[j] = b[j] alt-ergo-free-2.0.0/examples/invalid/arith2.why0000644000175000017500000000007513430774474017143 0ustar mimilogic x,y:int goal g12 : x = 5 -> y - (x / 10) = y - 1 alt-ergo-free-2.0.0/examples/invalid/arith1.why0000644000175000017500000000007113430774474017136 0ustar mimi logic x,y,z : int goal g16 : x>=0 -> y >=0 -> x/y>=0 alt-ergo-free-2.0.0/examples/valid/0000755000175000017500000000000013430774474014670 5ustar mimialt-ergo-free-2.0.0/examples/valid/ac_arith.why0000644000175000017500000000015213430774474017171 0ustar mimi logic ac f : int,int -> int goal g1 : forall a,b,c,x:int. c = a + x -> a = f(c,b) -> x=1 -> f(c,b)=c-1 alt-ergo-free-2.0.0/examples/valid/bitv.why0000644000175000017500000000021313430774474016361 0ustar mimi logic f : 'a -> bitv[2] goal g11: forall x:bitv[3]. forall y:bitv[2]. forall z:'a. x=y@[|1|] -> f(z)=y -> f(z)^{0,0} = x^{1,1} alt-ergo-free-2.0.0/examples/valid/congruence.why0000644000175000017500000000027513430774474017555 0ustar mimi logic h,g,f: int,int -> int logic a, b:int goal g8: h(g(a,a),g(b,b)) = g(b,b) -> a = b -> g(f(h(g(a,a),g(b,b)),b) - f(g(b,b),a), f(h(g(a,a),g(b,b)),a) - f(g(b,b),b)) = g(0,0) alt-ergo-free-2.0.0/examples/valid/arrays.why0000644000175000017500000000022713430774474016723 0ustar mimi goal g17 : forall i,j,k:int. forall v,w : 'a. forall b : 'a farray. b = b[j<-b[i],k<-w] -> i = 1 -> j = 2 -> k = 1 -> b[i] = b[j] alt-ergo-free-2.0.0/examples/valid/arith3.why0000644000175000017500000000015213430774474016611 0ustar mimi goal g1 : (*goal sqrt_po_10*) forall x,y:int. x > 3 -> y = (x + 1) / 2 -> x < (y + 1) * (y + 1) alt-ergo-free-2.0.0/examples/valid/arith2.why0000644000175000017500000000017513430774474016615 0ustar mimi goal g41: forall x,y,z:int. x > 3 -> y > 0 -> z > 0 -> y > z -> z = ((x / y) + y) / 2 -> z > 1 and y > 2 alt-ergo-free-2.0.0/examples/valid/arith4.why0000644000175000017500000000012713430774474016614 0ustar mimi goal mult_po_4: forall a,b:int. a > 0 -> a % 2 = 1 -> b + (a / 2) * (2 * b) = a * b alt-ergo-free-2.0.0/examples/valid/quantifiers.why0000644000175000017500000000026613430774474017757 0ustar mimi type 'a pointer type 'a pset logic P : int -> prop logic Q : int , int -> prop axiom a: (forall x:int. (P(x) <-> (exists i:int, r: int. Q(r,i)))) goal g8: Q(1,2) -> P(4) alt-ergo-free-2.0.0/examples/valid/arith1.why0000644000175000017500000000017013430774474016607 0ustar mimi goal g2 : forall x,y,z,t:int. 0 <= y + z <= 1 -> x + t + y + z = 1 -> y + z <> 0 -> x + t = 0 alt-ergo-free-2.0.0/examples/valid/enum_arrays.why0000644000175000017500000000026713430774474017753 0ustar mimi type t = A | B | C | D type t2 = E | F | G | H goal g2 : forall a : (t,t2) farray. a[B <- E][A] <> E -> a[C <- F][A] <> F -> a[D <- G][A] <> G -> a[A] = H alt-ergo-free-2.0.0/LICENSE.md0000664000175000017500000000235713430774474013370 0ustar mimi## Copyright These software are distributed in the hope that they will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. Please, do not use enclosed software until you have read and accepted the terms of the licensing below. The use of these software implies that you automatically agree with our terms and conditions. In case of doubt, please contact us to clarify licensing. The resources are licensed as follows: ### OCaml source files and Alt-Ergo preludes Some of these files are Copyright (C) 2006-2013 --- CNRS - INRIA - Universite Paris Sud, and Copyright (C) 2013-2017 --- OCamlPro SAS. They are distributed under the terms of the Apache Software License version 2.0. The other files are Copyright (C) --- OCamlPro SAS. They are distributed under the terms of the license indicated in the file 'License.OCamlPro'. You may want to refer to the header of each file to know under which license it is distributed. ### Binaries generated from the source files The binaries (tools, plugins, ...) that are generated from the OCaml source files are Copyright (C) --- OCamlPro SAS. They are distributed under the terms of the license indicated in the file 'License.OCamlPro'. alt-ergo-free-2.0.0/lib/0000755000175000017500000000000013430774474012521 5ustar mimialt-ergo-free-2.0.0/lib/util/0000755000175000017500000000000013430774474013476 5ustar mimialt-ergo-free-2.0.0/lib/util/numbersInterface.mli0000664000175000017500000001174513430774474017507 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) (** Interface of Integers **) module type ZSig = sig type t val zero : t val one : t val m_one : t (* minus one *) val compare : t -> t -> int val compare_to_0 : t -> int val equal : t -> t -> bool val sign : t -> int val hash : t -> int val is_zero : t -> bool val is_one : t -> bool val is_m_one : t -> bool val add : t -> t -> t val sub : t -> t -> t val mult : t -> t -> t val div : t -> t -> t val rem : t -> t -> t val div_rem : t -> t -> t * t val minus : t -> t val abs : t -> t val my_gcd : t -> t -> t val my_lcm : t -> t -> t val max : t -> t -> t val from_int : int -> t val from_string : string -> t val to_string : t -> string (** convert to machine integer. returns None in case of overflow *) val to_machine_int : t -> int option val to_float : t -> float val fdiv : t -> t -> t val cdiv : t -> t -> t val power : t -> int -> t val print : Format.formatter -> t -> unit val shift_left: t -> int -> t (** Shifts left by (n:int >= 0) bits. This is the same as t * pow(2,n) *) val sqrt_rem: t -> (t * t) (** returns sqrt truncated with the remainder. It assumes that the argument is positive, otherwise, [Invalid_argument] is raised. *) (** [testbit z n] returns true iff the nth bit of z is set to 1. n is supposed to be positive *) val testbit: t -> int -> bool (** return the number of bits set to one in the given integer *) val numbits : t -> int end (** Interface of Rationals **) module type QSig = sig module Z : ZSig type t exception Not_a_float val num : t -> Z.t val den : t -> Z.t val zero : t val one : t val m_one : t (* minus one *) val compare : t -> t -> int val compare_to_0 : t -> int val equal : t -> t -> bool val sign : t -> int val hash : t -> int val is_zero : t -> bool val is_one : t -> bool val is_m_one : t -> bool val is_int : t -> bool val add : t -> t -> t val sub : t -> t -> t val mult : t -> t -> t val div : t -> t -> t val minus : t -> t val abs : t -> t val min : t -> t -> t val max : t -> t -> t val inv : t -> t (* Euclidean division's remainder. Assumes that the arguments are in Z *) val modulo : t -> t -> t val from_float : float -> t val from_int : int -> t val from_z : Z.t -> t val from_zz: Z.t -> Z.t -> t val from_string : string -> t val to_float : t -> float val to_z : t -> Z.t (* Assumes that the argument is in Z *) val to_string : t -> string val print : Format.formatter -> t -> unit val power : t -> int -> t val floor : t -> t val ceiling : t -> t val truncate : t -> Z.t (** converts the argument to an integer by truncation. **) val mult_2exp: t -> int -> t (** multiplies the first argument by 2^(the second argument) *) val div_2exp: t -> int -> t (** divides the first argument by 2^(the second argument) *) end alt-ergo-free-2.0.0/lib/util/timers.mli0000664000175000017500000001014113430774474015503 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) type ty_module = | M_None | M_Typing | M_Sat | M_Match | M_CC | M_UF | M_Arith | M_Arrays | M_Sum | M_Records | M_AC | M_Formula | M_Literal | M_Term | M_Triggers | M_Simplex type ty_function = | F_add | F_add_lemma | F_add_predicate | F_add_terms | F_are_equal | F_assume | F_class_of | F_leaves | F_make | F_m_lemmas | F_m_predicates | F_query | F_solve | F_subst | F_union | F_unsat | F_none | F_new_facts | F_apply_subst | F_instantiate (** environment of internal timers **) type t (** return a new empty env **) val empty : unit -> t (** reset the given env to empty *) val reset : t -> unit (** save the current timer and start the timer "ty_module x ty_function" **) val start : t -> ty_module -> ty_function -> unit (** pause the timer "ty_module x ty_function" and restore the former timer **) val pause : t -> ty_module -> ty_function -> unit (** update the value of the current timer **) val update : t -> unit (** get the value of the timer "ty_module x ty_function" **) val get_value : t -> ty_module -> ty_function -> float (** get the sum of the "ty_function" timers for the given "ty_module" **) val get_sum : t -> ty_module -> float val current_timer : t -> ty_module * ty_function * int val string_of_ty_module : ty_module -> string val string_of_ty_function : ty_function -> string val get_stack : t -> (ty_module * ty_function * int) list val get_timers_array : t -> (float array) array val mtag : ty_module -> int val ftag : ty_function -> int val all_modules : ty_module list val all_functions : ty_function list (** This functions assumes (asserts) that timers() yields true **) val set_timer_start : (ty_module -> ty_function -> unit) -> unit (** This functions assumes (asserts) that timers() yields true **) val set_timer_pause : (ty_module -> ty_function -> unit) -> unit val exec_timer_start : ty_module -> ty_function -> unit val exec_timer_pause : ty_module -> ty_function -> unit alt-ergo-free-2.0.0/lib/util/myUnix.ml0000664000175000017500000000335313430774474015327 0ustar mimi(******************************************************************************) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the license indicated *) (* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) (* present, please contact us to clarify licensing. *) (* *) (******************************************************************************) module Default_Unix = struct open Unix let cur_time () = (times()).tms_utime let set_timeout ~is_gui timelimit = if Pervasives.(<>) timelimit 0. then let itimer = if is_gui then Unix.ITIMER_REAL (* troubles with VIRTUAL *) else Unix.ITIMER_VIRTUAL in ignore (Unix.setitimer itimer { Unix.it_value = timelimit; Unix.it_interval = 0. }) let unset_timeout ~is_gui = let itimer = if is_gui then Unix.ITIMER_REAL (* troubles with VIRTUAL *) else Unix.ITIMER_VIRTUAL in ignore (Unix.setitimer itimer { Unix.it_value = 0.; Unix.it_interval = 0. }) end include Default_Unix (* !! This commented code is used when compiling to javascript !! module JavaScript_Unix = struct let cur_time () = let today = jsnew Js.date_now () in let t = Js.to_float (today##getTime()) in t /. 1000. let set_timeout _ = () let unset_timeout () = () end include JavaScript_Unix *) alt-ergo-free-2.0.0/lib/util/util.ml0000664000175000017500000000277613430774474015023 0ustar mimi(******************************************************************************) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the license indicated *) (* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) (* present, please contact us to clarify licensing. *) (* *) (******************************************************************************) exception Timeout module MI = Map.Make(struct type t = int let compare a b = a - b end) module SS = Set.Make(String) (** Different values for -case-split-policy option: -after-theory-assume (default value): after assuming facts in theory by the SAT -before-matching: just before performing a matching round -after-matching: just after performing a matching round **) type case_split_policy = | AfterTheoryAssume (* default *) | BeforeMatching | AfterMatching type inst_kind = Normal | Forward | Backward (* let map_merge_is_union eq k a b = match a, b with | None, None -> None | None, Some _ -> b | Some _, None -> a | Some (x, c1), Some (y, c2) -> assert (eq x y); Some (x, c1 + c2) *) alt-ergo-free-2.0.0/lib/util/numbers.ml0000664000175000017500000001045313430774474015510 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) module MyZarith = ZarithNumbers module MyNums = NumsNumbers module Z = MyZarith.Z module Q = struct include MyZarith.Q let two = from_int 2 let root_num q n = assert (n >= 0); let sgn = sign q in assert (sgn >= 0); if n = 1 then Some q else if sgn = 0 then Some zero else let v = to_float q in let w = if Pervasives.(<) v min_float then min_float else if Pervasives.(>) v max_float then max_float else v in let flt = if n = 2 then sqrt w else w ** (1. /. float n) in match classify_float flt with | FP_normal | FP_subnormal | FP_zero -> Some (from_float flt) | FP_infinite | FP_nan -> None let unaccurate_root_default q n = match root_num q n with | None -> None | (Some s) as res -> let d = sub q (power s n) in if sign d >= 0 then res else Some (div q (power s (n - 1))) let unaccurate_root_excess q n = match root_num q n with | None -> None | Some s as res -> let d = sub q (power s n) in if sign d <= 0 then res else Some (div q (power s (n - 1))) let accurate_root_default q n = let dd = unaccurate_root_default q n in let ee = unaccurate_root_excess q n in match dd, ee with | None, _ | _ , None -> dd | Some d, Some e -> let cand = div (add d e) two in if MyZarith.Q.compare (power cand n) q <= 0 then Some cand else dd let accurate_root_excess q n = let dd = unaccurate_root_default q n in let ee = unaccurate_root_excess q n in match dd, ee with | None, _ | _ , None -> ee | Some d, Some e -> let cand = div (add d e) two in if MyZarith.Q.compare (power cand n) q >= 0 then Some cand else ee let sqrt_excess q = match root_num q 2 with | None -> None | Some s -> if not (is_zero s) then Some (div (add s (div q s)) two) else accurate_root_default q 2 let sqrt_default q = match sqrt_excess q with | None -> None | Some s -> if not (is_zero s) then Some (div q s) else accurate_root_excess q 2 let root_default = accurate_root_default let root_excess = accurate_root_excess end alt-ergo-free-2.0.0/lib/util/myZip.mli0000664000175000017500000000222113430774474015310 0ustar mimi(******************************************************************************) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the license indicated *) (* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) (* present, please contact us to clarify licensing. *) (* *) (******************************************************************************) (** A wrapper of the Zip module of CamlZip: we use Zip except when we want to generate the.js file for try-Alt-Ergo **) type in_file type entry val open_in : string -> in_file val close_in : in_file -> unit val entries : in_file -> entry list val read_entry : in_file -> entry -> string val filename : entry -> string val is_directory : entry -> bool alt-ergo-free-2.0.0/lib/util/version.mli0000664000175000017500000000432713430774474015676 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) val version : string val release_commit : string val release_date : string alt-ergo-free-2.0.0/lib/util/version.ml0000664000175000017500000000471213430774474015523 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) (* WARNING: a "cut" is performed on the following file in the Makefile. DO NOT CHANGE its format *) let version="2.0.0" let release_commit = "(not released)" let release_date = "(not released)" let release_commit = "cb1456939abe99c93f7244462954cd1170508ea9" let release_date = "Wed Feb 13 12:02:20 CET 2019" alt-ergo-free-2.0.0/lib/util/hstring.ml0000664000175000017500000000652713430774474015522 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Hconsing open Options type t = { content : string ; id : int} module S = Hconsing.Make(struct type elt = t let hash s = Hashtbl.hash s.content let eq s1 s2 = String.equal s1.content s2.content let set_id n v = {v with id = n} let initial_size = 5003 let disable_weaks () = Options.disable_weaks () end) let make s = S.make {content = s; id = - 1} let view s = s.content let equal s1 s2 = s1.id == s2.id let compare s1 s2 = compare s1.id s2.id let hash s = s.id let empty = make "" let rec list_assoc x = function | [] -> raise Not_found | (y, v) :: l -> if equal x y then v else list_assoc x l let fresh_string = let cpt = ref 0 in fun () -> incr cpt; "!k" ^ (string_of_int !cpt) let is_fresh_string s = try s.[0] == '!' && s.[1] == 'k' with Invalid_argument s -> assert (String.compare s "index out of bounds" = 0); false let is_fresh_skolem s = try s.[0] == '!' && s.[1] == '?' with Invalid_argument s -> assert (String.compare s "index out of bounds" = 0); false module Arg = struct type t'= t type t = t' let compare = compare end module Set : Set.S with type elt = t = Set.Make(Arg) module Map : Map.S with type key = t = Map.Make(Arg) alt-ergo-free-2.0.0/lib/util/zarithNumbers.mli0000664000175000017500000000455513430774474017051 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) (** Integers implementation. Based on Zarith's integers **) module Z : NumbersInterface.ZSig with type t = Z.t (** Rationals implementation. Based on Zarith's rationals **) module Q : NumbersInterface.QSig with module Z = Z alt-ergo-free-2.0.0/lib/util/myDynlink.mli0000664000175000017500000000200613430774474016157 0ustar mimi(******************************************************************************) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the license indicated *) (* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) (* present, please contact us to clarify licensing. *) (* *) (******************************************************************************) (** A wrapper of the Dynlink module: we use Dynlink except when we want to generate a static (native) binary **) type error exception Error of error val error_message : error -> string val loadfile : string -> unit alt-ergo-free-2.0.0/lib/util/hconsing.ml0000664000175000017500000000627613430774474015655 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Options module type HASHED = sig type elt val eq : elt -> elt -> bool val hash : elt -> int val set_id : int -> elt -> elt val initial_size : int val disable_weaks : unit -> bool end module type S = sig type t val make : t -> t val elements : unit -> t list end module Make(Hashed : HASHED) : (S with type t = Hashed.elt) = struct type t = Hashed.elt module HWeak = Weak.Make (struct type t = Hashed.elt let equal = Hashed.eq let hash = Hashed.hash end) let storage = HWeak.create Hashed.initial_size let retain_list = ref [] let next_id = ref 0 let make d = let d = Hashed.set_id !next_id d in let o = HWeak.merge storage d in if o == d then begin incr next_id; if Hashed.disable_weaks() then (* retain a pointer to 'd' to prevent the GC from collecting the object if H.disable_weaks is set *) retain_list := d :: !retain_list end; o let elements () = let acc = ref [] in HWeak.iter (fun e -> acc := e :: !acc) storage; !acc end alt-ergo-free-2.0.0/lib/util/lists.ml0000664000175000017500000000237713430774474015201 0ustar mimi(******************************************************************************) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the license indicated *) (* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) (* present, please contact us to clarify licensing. *) (* *) (******************************************************************************) let apply f l = let res, same = List.fold_left (fun (acc, same) a -> let b = f a in b :: acc, same && a == b )([], true) l in (if same then l else List.rev res), same let apply_right f l = let res, same = List.fold_left (fun (acc, same) (v, a) -> let b = f a in (v, b) :: acc, same && a == b )([], true) l in (if same then l else List.rev res), same let rrmap f l = List.rev (List.map f l) alt-ergo-free-2.0.0/lib/util/myZip.ml0000664000175000017500000000275013430774474015146 0ustar mimi(******************************************************************************) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the license indicated *) (* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) (* present, please contact us to clarify licensing. *) (* *) (******************************************************************************) (** A wrapper of the Zip module of CamlZip: we use Zip except when we want to generate the.js file for try-Alt-Ergo **) module ZipWrapper = struct include Zip let filename e = e.Zip.filename let is_directory e = e.Zip.is_directory end include ZipWrapper (* !! This commented code is used when compiling to javascript !! module DummyZip = struct type entry = unit type in_file = unit let s = "Zip module not available for your setting or has been disabled !" let open_in _ = failwith s let close_in _ = failwith s let entries _ = failwith s let read_entry _ _ = failwith s let filename _ = failwith s let is_directory _ = failwith s end include DummyZip *) alt-ergo-free-2.0.0/lib/util/options.ml0000664000175000017500000006113413430774474015532 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) let fmt = Format.err_formatter [@ocaml.ppwarning "Options: should not parse args here in 'lib mod'"] module M = struct let file = ref "" let session_file = ref "" let used_context_file = ref "" let rewriting = ref false let type_only = ref false let parse_only = ref false let steps_bound = ref (-1) let age_bound = ref 50 let debug = ref false let debug_warnings = ref false let notriggers = ref false let debug_cc = ref false let debug_gc = ref false let debug_use = ref false let debug_arrays = ref false let debug_uf = ref false let debug_sat = ref false let debug_sat_simple = ref false let debug_typing = ref false let debug_constr = ref false let verbose = ref false let debug_fm = ref false let debug_fpa = ref 0 let debug_sum = ref false let debug_arith = ref false let debug_combine = ref false let debug_bitv = ref false let debug_ac = ref false let debug_split = ref false let options = ref false let greedy = ref false let triggers_var = ref false let nb_triggers = ref 2 let enable_assertions = ref false let no_Ematching = ref false let no_backjumping = ref false let nocontracongru = ref false let term_like_pp = ref true let debug_types = ref false let all_models = ref false let model = ref false let complete_model = ref false let interpretation = ref 0 let debug_interpretation = ref false let proof = ref false let debug_proof = ref false let rules = ref (-1) let max_split = ref (Numbers.Q.from_int 1000000) let fm_cross_limit = ref (Numbers.Q.from_int 10_000) let case_split_policy = ref Util.AfterTheoryAssume let restricted = ref false let bottom_classes = ref false let timelimit = ref 0. let interpretation_timelimit = ref (if Sys.win32 then 0. else 1.) let debug_matching = ref 0 let debug_explanations = ref false let sat_plugin = ref "" let inequalities_plugin = ref "" let profiling_plugin = ref "" let cumulative_time_profiling = ref false let normalize_instances = ref false let partial_bmodel = ref true let tighten_vars = ref false let no_tcp = ref false let no_decisions = ref false let no_decisions_on = ref Util.SS.empty let no_fm = ref false let no_theory = ref false let js_mode = ref false let use_fpa = ref false let reversed_preludes : string list ref = ref [] let no_NLA = ref false let no_ac = ref false let no_backward = ref false let no_sat_learning = ref false let instantiate_after_backjump = ref false let disable_weaks = ref false let default_input_lang = ref ".why" let show_where s= match s with | "" -> () | s -> let path = match s with | "bin" -> Config.bindir | "lib" -> Config.libdir | "plugins" -> Config.pluginsdir | "preludes" -> Config.preludesdir | "data" -> Config.datadir | "man" -> Config.mandir | s -> raise (Arg.Bad ("Option -where has no argument " ^ s)) in Format.printf "%s@." path; exit 0 let show_version () = Format.printf "%s@." Version.version; exit 0 let show_version_info () = Format.printf "Version = %s@." Version.version; Format.printf "Release date = %s@." Version.release_date; Format.printf "Release commit = %s@." Version.release_commit; exit 0 let set_max_split s = max_split := try Numbers.Q.from_string s with Failure _ -> Numbers.Q.m_one let set_fm_cross_limit s = fm_cross_limit := try Numbers.Q.from_string s with Failure _ -> Numbers.Q.m_one let update_no_decisions_on s = no_decisions_on := List.fold_left (fun set s -> match s with | "" -> set | s -> Util.SS.add s set ) !no_decisions_on (Str.split (Str.regexp ",") s) let set_sat_plugin s = sat_plugin := s let set_inequalities_plugin s = inequalities_plugin := s let set_profiling_plugin s = profiling_plugin := s let set_proof b = proof := b let set_rules = function | "parsing" -> rules := 0 | "typing" -> rules := 1 | "sat" -> rules := 2 | "cc" -> rules := 3 | "arith" -> rules := 4 | _ -> rules := -1 let set_limit timelimit_target t = if Sys.win32 then Format.eprintf "timelimit not supported on Win32 (ignored)@." else timelimit_target := t let replay = ref false let replay_used_context = ref false let replay_all_used_context = ref false let save_used_context = ref false let replay_satml_dfs = ref false let profiling_period = ref 0. let profiling = ref false let parse_profiling s = profiling := true; try profiling_period := float_of_string s with _ -> () let set_case_split_policy_option s = case_split_policy := match s with | "after-theory-assume" -> Util.AfterTheoryAssume | "before-matching" -> Util.BeforeMatching | "after-matching" -> Util.AfterMatching | _ -> raise (Arg.Bad ("Bad value '"^s^"' for option -case-split-policy")) let check_file_extension s = if not (Filename.check_suffix s ".mlw" || Filename.check_suffix s ".why" || Filename.check_suffix s ".zip") then begin Format.fprintf fmt "Bad extension for file %S@." s; raise (Arg.Bad "no .mlw, .why or .zip extension") end let add_prelude p = check_file_extension p; reversed_preludes := p :: !reversed_preludes let set_default_input_lang lang = default_input_lang := "." ^ lang let timers = ref false let usage = "usage: alt-ergo [options] file." let spec = [ (* "-stats", Arg.Set stats, " activate statistics recording and printing (use Ctrl-C to print them in the terminal)"; *) "-parse-only", Arg.Set parse_only, " stop after parsing"; "-type-only", Arg.Set type_only , " stop after typing"; "-notriggers", Arg.Set notriggers, " disable triggers inference"; "-debug", Arg.Set debug, " sets the debugging flag"; "-dwarnings", Arg.Set debug_warnings, " sets the debugging flag of warnings"; "-dcc", Arg.Set debug_cc, " sets the debugging flag of cc"; "-dgc", Arg.Set debug_gc, " prints some debug info about the GC's activity"; "-duse", Arg.Set debug_use, " sets the debugging flag of use"; "-duf", Arg.Set debug_uf, " sets the debugging flag of uf"; "-dfm", Arg.Set debug_fm, " sets the debugging flag of inequalities"; "-dfpa", Arg.Set_int debug_fpa, " sets the debugging flag of floating-point"; "-dsum", Arg.Set debug_sum, " sets the debugging flag of Sum"; "-darith", Arg.Set debug_arith, " sets the debugging flag of Arith (without fm)"; "-dbitv", Arg.Set debug_bitv, " sets the debugging flag of bitv"; "-dac", Arg.Set debug_ac, " sets the debugging flag of ac"; "-dsat", Arg.Set debug_sat, " sets the debugging flag of sat"; "-dsats", Arg.Set debug_sat_simple, " sets the debugging flag of sat (simple output)"; "-dtyping", Arg.Set debug_typing, " sets the debugging flag of typing"; "-types", Arg.Set debug_types, " sets the debugging flag of types"; "-dconstr", Arg.Set debug_constr, " sets the debugging flag of constructors"; "-darrays", Arg.Set debug_arrays, " sets the debugging flag of arrays"; "-dcombine", Arg.Set debug_combine, " sets the debugging flag of combine"; "-dsplit", Arg.Set debug_split, " sets the debugging flag of case-split analysis"; "-dmatching", Arg.Set_int debug_matching, " sets the debugging flag of E-matching (0 = disabled, 1 = light, 2 = full)"; "-dexplanations", Arg.Set debug_explanations, " sets the debugging flag of explanations"; "-verbose", Arg.Set verbose, " sets the verbose mode"; "-version", Arg.Unit show_version, " prints the version number"; "-version-info", Arg.Unit show_version_info, " prints some info about this version"; "-where", Arg.String show_where, " prints the directory of its argument. Possible arguments are: \"bin\", \"lib\", \"plugins\", \"data\" and \"man\""; "-steps-bound", Arg.Set_int steps_bound, " set the maximum number of steps"; "-enable-assertions", Arg.Set enable_assertions, " Enable verification of some heavy invariants"; "-no-tcp", Arg.Set no_tcp, " Deactivate BCP modulo theories"; "-no-decisions", Arg.Set no_decisions, " Disable decisions at the SAT level"; "-no-decisions-on", Arg.String update_no_decisions_on, " Disable decisions at the SAT level for the instances generated from the given axioms. Arguments should be separated with a comma"; "-no-fm", Arg.Set no_fm, " Disable Fourier-Motzkin algorithm"; "-tighten-vars", Arg.Set tighten_vars, " Compute the best bounds for arithmetic variables"; "-no-theory", Arg.Set no_theory, " Completely deactivate theory reasoning"; "-age-bound", Arg.Set_int age_bound, " set the age limite bound"; "-greedy" , Arg.Set greedy, " use all available ground terms in instantiation"; "-nb-triggers" , Arg.Set_int nb_triggers, " number of redondant (multi)triggers (default: 2)"; "-triggers-var" , Arg.Set triggers_var , " allows variables as triggers"; "-no-Ematching", Arg.Set no_Ematching, " disable matching modulo ground equalities"; "-no-backjumping", Arg.Set no_backjumping, " disable backjumping mechanism in the functional SAT solver"; "-no-NLA", Arg.Set no_NLA, " disable non-linear arithmetic reasoning (i.e. non-linear multplication, division and modulo on integers and rationals). Non-linear multiplication remains AC"; "-no-ac", Arg.Set no_ac, " Disable the AC theory of Associative and Commutative function symbols"; "-nocontracongru", Arg.Set nocontracongru, ""; "-term-like-pp", Arg.Set term_like_pp, " output semantic values as terms"; "-all-models", Arg.Set all_models, " experimental support for all models"; "-model", Arg.Set model, " experimental support for models on labeled terms"; "-complete-model", Arg.Set complete_model, " experimental support for complete model"; "-dinterpretation", Arg.Set debug_interpretation, " set debug flag for interpretation generatation"; "-interpretation", Arg.Set_int interpretation, " experimental support for counter-example generation. Possible values are 1, 2, or 3 to compute an interpretation before returning Unknown, before instantiation, or before every decision or instantiation. A negative value (-1, -2, or -3) will disable interpretation display. Note that -max-split limitation will be ignored in model generation phase"; "-proof", Arg.Set proof, " experimental support for succinct proof"; "-debug-proof", Arg.Set debug_proof, " replay unsatisfiable core produced by -proof. This options implies -proof"; "-rules", Arg.String set_rules, "tr (tr in ) output rules used on stderr"; "-max-split", Arg.String set_max_split, (Format.sprintf " maximum size of case-split (default value : %s)" (Numbers.Q.to_string !max_split)); "-fm-cross-limit", Arg.String set_fm_cross_limit, (Format.sprintf " skip Fourier-Motzkin variables elimination steps that may produce a number of inequalities that is greater than the given limit (default value : %s). However, unit eliminations are always done" (Numbers.Q.to_string !fm_cross_limit)); "-case-split-policy", Arg.String set_case_split_policy_option, " case-split policy. Set the case-split policy to use. Possible values are: after-theory-assume (default), before-matching, after-matching" ; "-restricted", Arg.Set restricted, " restrict set of decision procedures (equality, arithmetic and AC)"; "-bottom-classes", Arg.Set bottom_classes, " show equivalence classes at each bottom of the sat"; "-replay", Arg.Set replay, " replay session saved in .agr"; "-replay-used-context", Arg.Set replay_used_context, " replay with axioms and predicates saved in .used file"; "-replay-all-used-context", Arg.Set replay_all_used_context, " replay with all axioms and predicates saved in .used files of the current directory"; "-save-used-context", Arg.Set save_used_context, " save used axioms and predicates in a .used file. This options implies -proof"; "-replay-satml-dfs", Arg.Set replay_satml_dfs, " debug option for the satML plugin. Replays proven (valid) goals (with generated ground instances) using the functional SAT solver"; "-timelimit", Arg.Float (set_limit timelimit), "n set the time limit to n seconds (not supported on Windows)"; "-interpretation-timelimit", Arg.Float (set_limit interpretation_timelimit), "n set the time limit to n seconds for model generation (not supported on Windows). Default value is 1. sec"; "-sat-plugin" , Arg.String set_sat_plugin, " use the given SAT-solver instead of the default DFS-based SAT solver"; "-inequalities-plugin" , Arg.String set_inequalities_plugin, " use the given module to handle inequalities of linear arithmetic"; "-profiling", Arg.String parse_profiling, " activate the profiling module with the given frequency. Use Ctrl-C to switch between different views and \"Ctrl + AltGr + \\\" to exit."; "-profiling-plugin" , Arg.String set_profiling_plugin, " use the given profiling plugin"; "-cumulative-time-profiling", Arg.Set cumulative_time_profiling, " the time spent in called functions is also recorded in callers"; "-rwt", Arg.Set rewriting, " use rewriting instead of axiomatic approach"; "-normalize-instances" , Arg.Set normalize_instances, " normalize generated substitutions by matching w.r.t. the state of the theory. Default value is false. This means that only terms that are greater (w.r.t. depth) than the initial terms of the problem are normalized."; "-use-fpa", Arg.Set use_fpa, " enable support for floating-point arithmetic"; "-prelude", Arg.String add_prelude, " add a file that will be loaded as a prelude. The command is cumulative, and the order of successive preludes is presrved."; "-inst-after-bj", Arg.Set instantiate_after_backjump, " make a (normal) instantiation round after every backjump/backtrack" ; "-no-backward", Arg.Set no_backward, " Disable backward reasoning step (starting from the goal) done in the default SAT solver before deciding" ; "-no-sat-learning", Arg.Set no_sat_learning, " Disable learning/caching of unit facts in the Default SAT. These facts are used to improve bcp" ; "-disable-weaks", Arg.Set disable_weaks, " Prevent the GC from collecting hashconsed data structrures that are not reachable (useful for more determinism)" ; "-default-lang", Arg.String set_default_input_lang, " Set the default input language to 'lang'. Useful when the extension does not allow to automatically select a parser (eg. JS mode, GUI mode, ...)" ; ] let spec = Arg.align spec let thread_yield = ref (fun () -> ()) let (timeout : (unit -> unit) ref) = ref (fun () -> raise Util.Timeout) end let parse_cmdline_arguments () = let ofile = ref None in let set_file s = M.check_file_extension s; ofile := Some s in Arg.parse M.spec set_file M.usage; match !ofile with | Some f -> M.file := f; M.session_file := (Filename.chop_extension f)^".agr"; M.used_context_file := (Filename.chop_extension f)^".used" | None -> () let set_file_for_js filename = M.file := filename; M.js_mode := true (** setter functions **********************************************************) (** setters for debug flags *) let set_debug b = M.debug := b let set_debug_cc b = M.debug_cc := b let set_debug_gc b = M.debug_gc := b let set_debug_use b = M.debug_use := b let set_debug_uf b = M.debug_uf := b let set_debug_fm b = M.debug_fm := b let set_debug_sum b = M.debug_sum := b let set_debug_arith b = M.debug_arith := b let set_debug_bitv b = M.debug_bitv := b let set_debug_ac b = M.debug_ac := b let set_debug_sat b = M.debug_sat := b let set_debug_sat_simple b = M.debug_sat_simple := b let set_debug_typing b = M.debug_typing := b let set_debug_constr b = M.debug_constr := b let set_debug_arrays b = M.debug_arrays := b let set_debug_types b = M.debug_types := b let set_debug_combine b = M.debug_combine := b let set_debug_proof b = M.debug_proof := b let set_debug_split b = M.debug_split := b let set_debug_matching i = M.debug_matching := i let set_debug_explanations b = M.debug_explanations := b (** additional setters *) let set_type_only b = M.type_only := b let set_parse_only b = M.parse_only := b let set_steps_bound b = M.steps_bound := b let set_age_bound b = M.age_bound := b let set_notriggers b = M.notriggers := b let set_verbose b = M.verbose := b let set_greedy b = M.greedy := b let set_triggers_var b = M.triggers_var := b let set_nb_triggers b = M.nb_triggers := b let set_no_Ematching b = M.no_Ematching := b let set_no_NLA b = M.no_NLA := b let set_no_ac b = M.no_ac := b let set_normalize_instances b = M.normalize_instances := b let set_nocontracongru b = M.nocontracongru := b let set_term_like_pp b = M.term_like_pp := b let set_all_models b = M.all_models := b let set_model b = M.model := b let set_complete_model b = M.complete_model := b let set_interpretation b = M.interpretation := b let set_max_split b = M.max_split := b let set_fm_cross_limit b = M.fm_cross_limit := b let set_rewriting b = M.rewriting := b let set_proof b = M.proof := b let set_rules b = M.rules := b let set_restricted b = M.restricted := b let set_bottom_classes b = M.bottom_classes := b let set_timelimit b = M.timelimit := b let set_model_timelimit b = M.timelimit := b let set_timers b = M.timers := b let set_profiling f b = M.profiling := b; M.profiling_period := if b then f else 0. let set_thread_yield f = M.thread_yield := f let set_timeout f = M.timeout := f let set_partial_bmodel b = M.partial_bmodel := b let set_save_used_context b = M.save_used_context := b let set_default_input_lang lang = M.set_default_input_lang lang (** getter functions **********************************************************) (** getters for debug flags *) let debug () = !M.debug let debug_warnings () = !M.debug_warnings let debug_cc () = !M.debug_cc let debug_gc () = !M.debug_gc let debug_use () = !M.debug_use let debug_uf () = !M.debug_uf let debug_fm () = !M.debug_fm let debug_fpa () = !M.debug_fpa let debug_sum () = !M.debug_sum let debug_arith () = !M.debug_arith let debug_bitv () = !M.debug_bitv let debug_ac () = !M.debug_ac let debug_sat () = !M.debug_sat let debug_sat_simple () = !M.debug_sat_simple let debug_typing () = !M.debug_typing let debug_constr () = !M.debug_constr let debug_arrays () = !M.debug_arrays let debug_types () = !M.debug_types let debug_combine () = !M.debug_combine let debug_proof () = !M.debug_proof let debug_split () = !M.debug_split let debug_matching () = !M.debug_matching let debug_explanations () = !M.debug_explanations (** additional getters *) let js_mode () = !M.js_mode let type_only () = !M.type_only let parse_only () = !M.parse_only let steps_bound () = !M.steps_bound let no_tcp () = !M.no_tcp let no_decisions () = !M.no_decisions let no_fm () = !M.no_fm let no_theory () = !M.no_theory let tighten_vars () = !M.tighten_vars let age_bound () = !M.age_bound let notriggers () = !M.notriggers let verbose () = !M.verbose let greedy () = !M.greedy let triggers_var () = !M.triggers_var let nb_triggers () = !M.nb_triggers let no_Ematching () = !M.no_Ematching let no_backjumping () = !M.no_backjumping let no_NLA () = !M.no_NLA let no_ac () = !M.no_ac let no_backward () = !M.no_backward let no_sat_learning () = !M.no_sat_learning let sat_learning () = not !M.no_sat_learning let nocontracongru () = !M.nocontracongru let term_like_pp () = !M.term_like_pp let cumulative_time_profiling () = !M.cumulative_time_profiling let all_models () = !M.all_models let model () = !M.model || !M.complete_model let interpretation () = !M.interpretation let debug_interpretation () = !M.debug_interpretation let complete_model () = !M.complete_model let max_split () = !M.max_split let fm_cross_limit () = !M.fm_cross_limit let rewriting () = !M.rewriting let proof () = !M.proof || !M.save_used_context || !M.debug_proof let rules () = !M.rules let restricted () = !M.restricted let bottom_classes () = !M.bottom_classes let timelimit () = !M.timelimit let interpretation_timelimit () = !M.interpretation_timelimit let enable_assertions () = !M.enable_assertions let profiling () = !M.profiling let profiling_period () = !M.profiling_period let timers () = !M.timers || !M.profiling let case_split_policy () = !M.case_split_policy let instantiate_after_backjump () = !M.instantiate_after_backjump let disable_weaks () = !M.disable_weaks let replay () = !M.replay let replay_used_context () = !M.replay_used_context let replay_all_used_context () = !M.replay_all_used_context let save_used_context () = !M.save_used_context let replay_satml_dfs () = !M.replay_satml_dfs let get_file () = !M.file let get_session_file () = !M.session_file let get_used_context_file () = !M.used_context_file let sat_plugin () = !M.sat_plugin let inequalities_plugin () = !M.inequalities_plugin let profiling_plugin () = !M.profiling_plugin let normalize_instances () = !M.normalize_instances let partial_bmodel () = !M.partial_bmodel let use_fpa () = !M.use_fpa let preludes () = List.rev !M.reversed_preludes let can_decide_on s = !M.no_decisions_on == Util.SS.empty || not (Util.SS.mem s !M.no_decisions_on) let no_decisions_on__is_empty () = !M.no_decisions_on == Util.SS.empty let default_input_lang () = !M.default_input_lang (** particular getters : functions that are immediately executed **************) let exec_thread_yield () = !M.thread_yield () let exec_timeout () = !M.timeout () let tool_req n msg = if rules () = n then Format.fprintf fmt "[rule] %s@." msg (** Simple Timer module **) module Time = struct let u = ref 0.0 let start () = u := MyUnix.cur_time() let value () = MyUnix.cur_time() -. !u let set_timeout ~is_gui tm = MyUnix.set_timeout ~is_gui tm let unset_timeout ~is_gui = if timelimit() <> 0. then MyUnix.unset_timeout ~is_gui end (** globals **) let cs_steps_cpt = ref 0 let cs_steps () = !cs_steps_cpt let incr_cs_steps () = incr cs_steps_cpt (** open Options in every module to hide polymorphic versions of Pervasives **) let (<>) (a: int) (b: int) = a <> b let (=) (a: int) (b: int) = a = b let (<) (a: int) (b: int) = a < b let (>) (a: int) (b: int) = a > b let (<=) (a: int) (b: int) = a <= b let (>=) (a: int) (b: int) = a >= b let compare (a: int) (b: int) = Pervasives.compare a b (* extra **) let is_gui = ref None let set_is_gui b = match !is_gui with | None -> is_gui := Some b | Some _ -> Format.eprintf "Error in Options.set_is_gui: is_gui is already set!@."; assert false let get_is_gui () = match !is_gui with | Some b -> b | None -> Format.eprintf "Error in Options.get_is_gui: is_gui is not set!@."; assert false alt-ergo-free-2.0.0/lib/util/hstring.mli0000664000175000017500000000502413430774474015662 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Hconsing type t val make : string -> t val view : t -> string val equal : t -> t -> bool val compare : t -> t -> int val hash : t -> int val empty : t val list_assoc : t -> (t * 'a) list -> 'a val fresh_string : unit -> string val is_fresh_string : string -> bool val is_fresh_skolem : string -> bool module Set : Set.S with type elt = t module Map : Map.S with type key = t alt-ergo-free-2.0.0/lib/util/numsNumbers.ml0000664000175000017500000001702513430774474016355 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) (** Integers implementation. Based on Zarith's integers **) module Z : NumbersInterface.ZSig with type t = Big_int.big_int = struct open Big_int type t = big_int let zero = zero_big_int let one = unit_big_int let m_one = minus_big_int one let compare a b = compare_big_int a b let compare_to_0 a = sign_big_int a let equal a b = eq_big_int a b let is_zero t = compare_to_0 t = 0 let is_one t = equal t one let is_m_one t = equal t m_one let sign t = sign_big_int t let hash t = Hashtbl.hash t let add a b = add_big_int a b let mult a b = mult_big_int a b let abs t = abs_big_int t let sub a b = sub_big_int a b let minus t = minus_big_int t let div a b = assert (not (is_zero b)); div_big_int a b let max a b = max_big_int a b let to_string t = string_of_big_int t let from_string s = big_int_of_string s let from_int n = big_int_of_int n let rem a b = assert (not (is_zero b)); mod_big_int a b let div_rem a b = assert (not (is_zero b)); quomod_big_int a b let print fmt t = Format.fprintf fmt "%s" (to_string t) let my_gcd a b = if is_zero a then b else if is_zero b then a else gcd_big_int a b let my_lcm a b = try div (mult a b) (my_gcd a b) with e -> Format.printf "my_lcm %a %a failed with:@.%s@." print a print b (Printexc.to_string e); assert false let to_float t = float_of_big_int t let to_machine_int t = try Some (Big_int.int_of_big_int t) with _ -> None let fdiv a b = assert (not (is_zero b)); let open Num in try let n1 = num_of_big_int a in let n2 = num_of_big_int b in let nm = div_num n1 n2 in big_int_of_num (floor_num nm) with e -> Format.printf "fdiv %a %a failed with:@.%s@." print a print b (Printexc.to_string e); assert false let cdiv a b = assert (not (is_zero b)); let open Num in try let n1 = num_of_big_int a in let n2 = num_of_big_int b in let nm = div_num n1 n2 in big_int_of_num (ceiling_num nm) with e -> Format.printf "cdiv %a %a failed with:@.%s@." print a print b (Printexc.to_string e); assert false let power a n = assert (n>=0); power_big_int_positive_int a n (* Shifts left by (n:int >= 0) bits. This is the same as t * pow(2,n) *) let shift_left = shift_left_big_int (* returns sqrt truncated with the remainder. It assumes that the argument is positive, otherwise, [Invalid_argument] is raised. *) let sqrt_rem t = let sq = sqrt_big_int t in sq, sub t (mult sq sq) let testbit z n = assert (n >= 0); is_one (extract_big_int z n 1) let numbits = Big_int.num_bits_big_int end (** Rationals implementation. Based on Zarith's rationals **) module Q : NumbersInterface.QSig with module Z = Z = struct module Z = Z exception Not_a_float open Num type t = num let zero = Int 0 let one = Int 1 let m_one = Int (-1) let of_int n = Int n let compare_to_0 n = sign_num n let is_zero n = compare_to_0 n = 0 let equal a b = a =/ b let is_one n = equal one n let is_m_one n = equal m_one n let ceiling = ceiling_num let floor = floor_num let is_int = is_integer_num let abs = abs_num let power a n = if n = 0 then one (* 0 ^ 0 = 1, undefined in mathematics*) else match a with | Int 1 -> one | Int 0 -> zero | Int (-1) -> if n mod 2 = 0 then one else m_one | _ -> power_num a (Int n) let modulo = mod_num let div a b = assert (not (is_zero b)); div_num a b let mult = mult_num let sub = sub_num let add = add_num let minus = minus_num let sign = sign_num let compare = compare_num let equal a b = a =/ b let to_string = string_of_num let from_string = num_of_string let to_float = float_of_num let to_z = big_int_of_num let from_z = num_of_big_int let from_int i = num_of_int i let den = function | Int _ | Big_int _ -> Big_int.unit_big_int | Ratio rat -> Ratio.denominator_ratio rat let num = function | Int i -> Big_int.big_int_of_int i | Big_int b -> b | Ratio rat -> Ratio.numerator_ratio rat let from_float x = if x = infinity || x = neg_infinity then raise Not_a_float; let (f, n) = frexp x in let z = Big_int.big_int_of_string (Int64.to_string (Int64.of_float (f *. 2. ** 52.))) in let factor = power (of_int 2) (n - 52) in mult (from_z z) factor let hash v = match v with | Int i -> i | Big_int b -> Hashtbl.hash b | Ratio rat -> Hashtbl.hash (Ratio.normalize_ratio rat) let print fmt q = Format.fprintf fmt "%s" (to_string q) let min t1 t2 = min_num t1 t2 let max t1 t2 = max_num t1 t2 let inv t = if Z.is_zero (num t) then raise Division_by_zero; one // t let from_zz z1 z2 = Big_int z1 // Big_int z2 (******** comparer avec l'implem de Alain de of_float let ratio_of_float f = Ratio.ratio_of_string (string_of_float f) let num_of_float f = num_of_ratio (ratio_of_float f) let of_float x = let res = of_float x in let z = num_of_float x in assert (res =/ z); res ********) let truncate t = let res = integer_num t in assert (compare (abs res) (abs t) <= 0); match res with | Int i -> Big_int.big_int_of_int i | Big_int b -> b | Ratio rat -> assert false let mult_2exp t n = mult t (power (Int 2) n) let div_2exp t n = div t (power (Int 2) n) end alt-ergo-free-2.0.0/lib/util/gc_debug.ml0000664000175000017500000000424313430774474015574 0ustar mimi(******************************************************************************) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the license indicated *) (* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) (* present, please contact us to clarify licensing. *) (* *) (******************************************************************************) open Options open Format open Gc (* major_collections; (* num of completed major collection cycles *) minor_collections; (* num of minor collections *) stack_size; (* current size of the stack, in word *) heap_words; (* tot size of the major heap *) top_heap_words; (* Max size reached by major heap *) minor_words; (* num of alloc words in minor heap since beginning *) major_words; (* num of alloc words in major heap, since beginning *) *) let () = if debug_gc() then begin let tmp = ref (quick_stat ()) in ignore (create_alarm (fun () -> let e = quick_stat () in let d = !tmp in fprintf fmt "[GC infos]==========================================@."; fprintf fmt "[major collections] %d th@." e.major_collections; fprintf fmt "[minor collections] %d th@." e.minor_collections; fprintf fmt "[stack used] %d words@." e.stack_size; fprintf fmt "[size of major heap] %d words@." e.heap_words; fprintf fmt "[max size major heap] %d words@." e.top_heap_words; fprintf fmt "[major words diff] %0.f Kwords@." ((e.major_words -. d.major_words) /. 1000.); fprintf fmt "[minor words diff] %0.f Kwords@." ((e.minor_words -. d.minor_words) /. 1000.); tmp := e ) ) end alt-ergo-free-2.0.0/lib/util/lists.mli0000664000175000017500000000251113430774474015340 0ustar mimi(******************************************************************************) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the license indicated *) (* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) (* present, please contact us to clarify licensing. *) (* *) (******************************************************************************) (** [apply f [a_1; ...; a_n]] returns a couple [f a_1; ...; f a_n], same such that: (1) "same" is true if and only if a_i == a_i for each i; and (2) if same is true, then the resulting list is physically equal to the argument **) val apply : ('a -> 'a) -> 'a list -> 'a list * bool (** similar to function apply, but the elements of the list are couples **) val apply_right : ('a -> 'a) -> ('b * 'a) list -> ('b * 'a) list * bool (** An abbreviation of List.rev List.rev_map **) val rrmap : ('a -> 'b) -> 'a list -> 'b list alt-ergo-free-2.0.0/lib/util/myUnix.mli0000664000175000017500000000203213430774474015471 0ustar mimi(******************************************************************************) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the license indicated *) (* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) (* present, please contact us to clarify licensing. *) (* *) (******************************************************************************) (** cur_time, provided by Unix or by Javascript depending on the compilation mode: for byte/opt or for javascript **) val cur_time : unit -> float val set_timeout : is_gui:bool -> float -> unit val unset_timeout : is_gui:bool -> unit alt-ergo-free-2.0.0/lib/util/numbers.mli0000664000175000017500000000547113430774474015665 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) (** Integers implementation. **) module Z : NumbersInterface.ZSig (** Rationals implementation. **) module Q : sig include NumbersInterface.QSig with module Z = Z (* computing root and sqrt by default and "by excess". The given rational is supposed to be positive. The integer provided for root_xxx is also supposed to be positive. Computations use floats. None is returned in case of failure. sqrt_xxx versions are more accurate and faster than their equivalent root_xxx when the integer is 2*) val root_default : t -> int -> t option val root_excess : t -> int -> t option val sqrt_default : t -> t option val sqrt_excess : t -> t option end alt-ergo-free-2.0.0/lib/util/myDynlink.ml0000664000175000017500000000206013430774474016006 0ustar mimi(******************************************************************************) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the license indicated *) (* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) (* present, please contact us to clarify licensing. *) (* *) (******************************************************************************) (** A wrapper of the Dynlink module: we use Dynlink except when we want to generate a static (native) binary **) module DummyDL = struct type error = string exception Error of error let error_message s = s let loadfile s = () end include Dynlink alt-ergo-free-2.0.0/lib/util/zarithNumbers.ml0000664000175000017500000001412513430774474016672 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) (** Integers implementation. Based on Zarith's integers **) module Z : NumbersInterface.ZSig with type t = Z.t = struct type t = Z.t let zero = Z.zero let one = Z.one let m_one = Z.minus_one let compare a b = Z.compare a b let compare_to_0 t = Z.sign t let equal a b = Z.equal a b let sign t = Z.sign t let hash t = Z.hash t let is_zero t = compare_to_0 t = 0 let is_one t = equal t one let is_m_one t = equal t m_one let add a b = Z.add a b let sub a b = Z.sub a b let mult a b = Z.mul a b let div a b = assert (not (is_zero b)); Z.div a b let rem a b = assert (not (is_zero b)); Z.rem a b let div_rem a b = assert (not (is_zero b)); Z.div_rem a b let minus t = Z.neg t let abs t = Z.abs t let max t1 t2 = Z.max t1 t2 let from_int n = Z.of_int n let from_string s = Z.of_string s let to_string t = Z.to_string t let print fmt z = Format.fprintf fmt "%s" (to_string z) let my_gcd a b = if is_zero a then b else if is_zero b then a else Z.gcd a b let my_lcm a b = try let res1 = Z.lcm a b in assert (equal res1 (div (mult a b) (my_gcd a b))); res1 with Division_by_zero -> assert false let to_machine_int t = try Some (Z.to_int t) with Z.Overflow -> None (* These functuons are not exported, but they are used by module Q below *) let to_float z = Z.to_float z let fdiv z1 z2 = assert (not (is_zero z2)); Z.fdiv z1 z2 let cdiv z1 z2 = assert (not (is_zero z2)); Z.cdiv z1 z2 let power z n = assert (n >= 0); Z.pow z n (* Shifts left by (n:int >= 0) bits. This is the same as t * pow(2,n) *) let shift_left = Z.shift_left (* returns sqrt truncated with the remainder. It assumes that the argument is positive, otherwise, [Invalid_argument] is raised. *) let sqrt_rem = Z.sqrt_rem let testbit z n = assert (n >= 0); Z.testbit z n let numbits = Z.numbits end (** Rationals implementation. Based on Zarith's rationals **) module Q : NumbersInterface.QSig with module Z = Z = struct module Z = Z exception Not_a_float type t = Q.t let num t = Q.num t let den t = Q.den t let zero = Q.zero let one = Q.one let m_one = Q.minus_one let compare t1 t2 = Q.compare t1 t2 let compare_to_0 t = Q.sign t let equal t1 t2 = Q.equal t1 t2 let sign t = Q.sign t let hash t = 13 * Z.hash (num t) + 23 * Z.hash (den t) let is_zero t = compare_to_0 t = 0 let is_one t = equal t one let is_m_one t = equal t m_one let is_int t = Z.is_one (den t) let add t1 t2 = Q.add t1 t2 let sub t1 t2 = Q.sub t1 t2 let mult t1 t2 = Q.mul t1 t2 let div t1 t2 = assert (not (is_zero t2)); Q.div t1 t2 let minus t = Q.neg t let abs t = Q.abs t let min t1 t2 = Q.min t1 t2 let max t1 t2 = Q.max t1 t2 let inv t = if Z.is_zero (num t) then raise Division_by_zero; Q.inv t let from_int n = Q.of_int n let from_z z = Q.make z Z.one let from_zz z1 z2 = Q.make z1 z2 let from_string s = Q.of_string s let from_float f = if f = infinity || f = neg_infinity then raise Not_a_float; Q.of_float f let to_string t = Q.to_string t let to_z q = assert (is_int q); num q let to_float t = (Z.to_float (num t)) /. (Z.to_float (den t)) let print fmt q = Format.fprintf fmt "%s" (to_string q) let floor t = from_z (Z.fdiv (num t) (den t)) let ceiling t = from_z (Z.cdiv (num t) (den t)) let power t n = let abs_n = Pervasives.abs n in let num_pow = Z.power (num t) abs_n in let den_pow = Z.power (den t) abs_n in if n >= 0 then from_zz num_pow den_pow else from_zz den_pow num_pow let modulo t1 t2 = assert (is_int t1 && is_int t2); from_zz (Z.rem (num t1) (num t2)) Z.one (* converts the argument to an integer by truncation. *) let truncate = Q.to_bigint let mult_2exp = Q.mul_2exp let div_2exp = Q.div_2exp end alt-ergo-free-2.0.0/lib/util/loc.ml0000664000175000017500000000473313430774474014616 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Format open Lexing type t = Lexing.position * Lexing.position let dummy = Lexing.dummy_pos, Lexing.dummy_pos let report fmt (b,e) = let l = b.pos_lnum in let fc = b.pos_cnum - b.pos_bol + 1 in let lc = e.pos_cnum - b.pos_bol + 1 in fprintf fmt "File \"%s\", line %d, characters %d-%d:" (Options.get_file()) l fc lc alt-ergo-free-2.0.0/lib/util/timers.ml0000664000175000017500000002111113430774474015331 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Format type ty_module = | M_None | M_Typing | M_Sat | M_Match | M_CC | M_UF | M_Arith | M_Arrays | M_Sum | M_Records | M_AC | M_Formula | M_Literal | M_Term | M_Triggers | M_Simplex let mtag k = match k with | M_None -> 0 | M_Typing -> 1 | M_Sat -> 2 | M_Match -> 3 | M_CC -> 4 | M_UF -> 5 | M_Arith -> 6 | M_Arrays -> 7 | M_Sum -> 8 | M_Records-> 9 | M_AC -> 10 | M_Formula-> 11 | M_Literal-> 12 | M_Term -> 13 | M_Triggers->14 | M_Simplex->15 let nb_mtag = 16 type ty_function = | F_add | F_add_lemma | F_add_predicate | F_add_terms | F_are_equal | F_assume | F_class_of | F_leaves | F_make | F_m_lemmas | F_m_predicates | F_query | F_solve | F_subst | F_union | F_unsat | F_none | F_new_facts | F_apply_subst | F_instantiate let ftag f = match f with | F_add -> 0 | F_add_lemma -> 1 | F_assume -> 2 | F_class_of -> 3 | F_leaves -> 4 | F_make -> 5 | F_m_lemmas -> 6 | F_m_predicates -> 7 | F_query -> 8 | F_solve -> 9 | F_subst -> 10 | F_union -> 11 | F_unsat -> 12 | F_add_predicate -> 13 | F_add_terms -> 14 | F_are_equal -> 15 | F_none -> 16 | F_new_facts -> 17 | F_apply_subst -> 18 | F_instantiate -> 19 let nb_ftag = 20 let string_of_ty_module k = match k with | M_None -> "None" | M_Typing -> "Typing" | M_Sat -> "Sat" | M_Match -> "Match" | M_CC -> "CC" | M_UF -> "UF" | M_Arith -> "Arith" | M_Arrays -> "Arrays" | M_Sum -> "Sum" | M_Records-> "Records" | M_AC -> "AC" | M_Formula-> "Formula" | M_Literal-> "Literal" | M_Term -> "Term" | M_Triggers->"Triggers" | M_Simplex->"Simplex" let string_of_ty_function f = match f with | F_add -> "add" | F_add_lemma -> "add_lemma" | F_assume -> "assume" | F_class_of -> "class_of" | F_leaves -> "leaves" | F_make -> "make" | F_m_lemmas -> "m_lemmas" | F_m_predicates -> "m_predicates" | F_query -> "query" | F_solve -> "solve" | F_subst -> "subst" | F_union -> "union" | F_unsat -> "unsat" | F_add_predicate -> "add_predicate" | F_add_terms -> "add_terms" | F_are_equal -> "are_equal" | F_none -> "none" | F_new_facts -> "new_facts" | F_apply_subst -> "apply_subst" | F_instantiate -> "instantiate" type t = { (* current time *) mutable cur_u : float; (* current activated (module x function) for time profiling *) mutable cur_t : (ty_module * ty_function * int); (* stack of suspended (module x function)s callers *) mutable stack : (ty_module * ty_function * int) list; (* table of timers for each combination "" *) z : (float array) array; (*h:(ty_module, float ref) Hashtbl.t;*) } let cpt_id = ref 0 let fresh_id () = incr cpt_id; !cpt_id (** return a new empty env **) let empty () = { cur_t = (M_None, F_none, 0); cur_u = 0.0; stack = []; z = Array.init nb_mtag (fun _ -> Array.make nb_ftag 0.); } (** reset the references of the given env to empty **) let reset env = for i = 0 to nb_mtag - 1 do let a = env.z.(i) in for j = 0 to nb_ftag - 1 do a.(j) <- 0. done done; env.cur_t <- (M_None, F_none, 0); env.cur_u <- 0.0; env.stack <- []; cpt_id := 0 let accumulate env cur m f = let mt = mtag m in let ft = ftag f in env.z.(mt).(ft) <- env.z.(mt).(ft) +. (cur -. env.cur_u) let accumulate_cumulative_mode name env m f cur = if Options.cumulative_time_profiling() then begin if Options.debug() then eprintf "@.%s time of %s , %s@." name (string_of_ty_module m) (string_of_ty_function f); List.iter (fun (m, f, id) -> if Options.debug() then eprintf " also update time of %s , %s@." (string_of_ty_module m) (string_of_ty_function f); accumulate env cur m f )env.stack end (** save the current timer and start the timer m x f **) let start env m f = let cur = MyUnix.cur_time() in accumulate_cumulative_mode "start" env m f cur; begin match env.cur_t with | (M_None, _, _) -> () | kd -> accumulate env cur m f; env.stack <- kd :: env.stack end; env.cur_t <- (m, f, fresh_id()); env.cur_u <- cur (** pause the timer "m x f" and restore the former timer **) let pause env m f = let cur = MyUnix.cur_time() in accumulate_cumulative_mode "pause" env m f cur; accumulate env cur m f; env.cur_u <- cur; match env.stack with | [] -> env.cur_t <- (M_None, F_none, 0) | kd::st -> env.cur_t <- kd; env.stack <- st (** update the value of the current timer **) let update env = let cur = MyUnix.cur_time() in let m, f, id = env.cur_t in accumulate_cumulative_mode "update" env m f cur; accumulate env cur m f; env.cur_u <- cur (** get the value of the timer "m x f" **) let get_value env m f = env.z.(mtag m).(ftag f) (** get the sum of the "ty_function" timers for the given "ty_module" **) let get_sum env m = let cpt = ref 0. in Array.iter (fun v -> cpt := !cpt +. v) env.z.(mtag m); !cpt let current_timer env = env.cur_t let get_stack env = env.stack let get_timers_array env = env.z let all_functions = let l = [ F_add; F_add_lemma; F_add_predicate; F_add_terms; F_are_equal; F_assume; F_class_of; F_leaves; F_make; F_m_lemmas; F_m_predicates; F_query; F_solve; F_subst; F_union; F_unsat; F_none; F_new_facts; F_apply_subst; F_instantiate; ] in assert (List.length l = nb_ftag); l let all_modules = let l = [ M_None; M_Typing; M_Sat; M_Match; M_CC; M_UF; M_Arith; M_Arrays; M_Sum; M_Records; M_AC; M_Formula; M_Literal; M_Term; M_Triggers; M_Simplex; ] in assert (List.length l = nb_mtag); l let (timer_start : (ty_module -> ty_function -> unit) ref) = ref (fun _ _ -> ()) let (timer_pause : (ty_module -> ty_function -> unit) ref) = ref (fun _ _ -> ()) let set_timer_start f = assert (Options.timers ()); timer_start := f let set_timer_pause f = assert (Options.timers ()); timer_pause := f let exec_timer_start kd msg = !timer_start kd msg let exec_timer_pause kd = !timer_pause kd alt-ergo-free-2.0.0/lib/util/emap.mli0000664000175000017500000003140413430774474015127 0ustar mimi(******************************************************************************) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the license indicated *) (* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) (* present, please contact us to clarify licensing. *) (* *) (******************************************************************************) (*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*) (*+ +*) (*+ OCaml +*) (*+ +*) (*+ Xavier Leroy, projet Cristal, INRIA Rocquencourt +*) (*+ +*) (*+ Copyright 1996 Institut National de Recherche en Informatique et +*) (*+ en Automatique. +*) (*+ +*) (*+ All rights reserved. This file is distributed under the terms of +*) (*+ the GNU Lesser General Public License version 2.1, with the +*) (*+ special exception on linking described in the file LICENSE. +*) (*+ +*) (*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*) (** Association tables over ordered types. This module implements applicative association tables, also known as finite maps or dictionaries, given a total ordering function over the keys. All operations over maps are purely applicative (no side-effects). The implementation uses balanced binary trees, and therefore searching and insertion take time logarithmic in the size of the map. For instance: {[ module IntPairs = struct type t = int * int let compare (x0,y0) (x1,y1) = match Pervasives.compare x0 x1 with 0 -> Pervasives.compare y0 y1 | c -> c end module PairsMap = Map.Make(IntPairs) let m = PairsMap.(empty |> add (0,1) "hello" |> add (1,0) "world") ]} This creates a new module [PairsMap], with a new type ['a PairsMap.t] of maps from [int * int] to ['a]. In this example, [m] contains [string] values so its type is [string PairsMap.t]. *) module type OrderedType = sig type t (** The type of the map keys. *) val compare : t -> t -> int (** A total ordering function over the keys. This is a two-argument function [f] such that [f e1 e2] is zero if the keys [e1] and [e2] are equal, [f e1 e2] is strictly negative if [e1] is smaller than [e2], and [f e1 e2] is strictly positive if [e1] is greater than [e2]. Example: a suitable ordering function is the generic structural comparison function {!Pervasives.compare}. *) end (** Input signature of the functor {!Map.Make}. *) module type S = sig type key (** The type of the map keys. *) type (+'a) t (** The type of maps from type [key] to type ['a]. *) val empty: 'a t (** The empty map. *) val is_empty: 'a t -> bool (** Test whether a map is empty or not. *) val mem: key -> 'a t -> bool (** [mem x m] returns [true] if [m] contains a binding for [x], and [false] otherwise. *) val add: key -> 'a -> 'a t -> 'a t (** [add x y m] returns a map containing the same bindings as [m], plus a binding of [x] to [y]. If [x] was already bound in [m] to a value that is physically equal to [y], [m] is returned unchanged (the result of the function is then physically equal to [m]). Otherwise, the previous binding of [x] in [m] disappears. @before 4.03 Physical equality was not ensured. *) val singleton: key -> 'a -> 'a t (** [singleton x y] returns the one-element map that contains a binding [y] for [x]. @since 3.12.0 *) val remove: key -> 'a t -> 'a t (** [remove x m] returns a map containing the same bindings as [m], except for [x] which is unbound in the returned map. If [x] was not in [m], [m] is returned unchanged (the result of the function is then physically equal to [m]). @before 4.03 Physical equality was not ensured. *) val merge: (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t (** [merge f m1 m2] computes a map whose keys is a subset of keys of [m1] and of [m2]. The presence of each such binding, and the corresponding value, is determined with the function [f]. In terms of the [find_opt] operation, we have [find_opt x (merge f m1 m2) = f (find_opt x m1) (find_opt x m2)] for any key [x], provided that [f None None = None]. @since 3.12.0 *) val union: (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t (** [union f m1 m2] computes a map whose keys is the union of keys of [m1] and of [m2]. When the same binding is defined in both arguments, the function [f] is used to combine them. This is a special case of [merge]: [union f m1 m2] is equivalent to [merge f' m1 m2], where - [f' None None = None] - [f' (Some v) None = Some v] - [f' None (Some v) = Some v] - [f' (Some v1) (Some v2) = f v1 v2] @since 4.03.0 *) val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int (** Total ordering between maps. The first argument is a total ordering used to compare data associated with equal keys in the two maps. *) val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal, that is, contain equal keys and associate them with equal data. [cmp] is the equality predicate used to compare the data associated with the keys. *) val iter: (key -> 'a -> unit) -> 'a t -> unit (** [iter f m] applies [f] to all bindings in map [m]. [f] receives the key as first argument, and the associated value as second argument. The bindings are passed to [f] in increasing order with respect to the ordering over the type of the keys. *) val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], where [k1 ... kN] are the keys of all bindings in [m] (in increasing order), and [d1 ... dN] are the associated data. *) val for_all: (key -> 'a -> bool) -> 'a t -> bool (** [for_all p m] checks if all the bindings of the map satisfy the predicate [p]. @since 3.12.0 *) val exists: (key -> 'a -> bool) -> 'a t -> bool (** [exists p m] checks if at least one binding of the map satisfies the predicate [p]. @since 3.12.0 *) val filter: (key -> 'a -> bool) -> 'a t -> 'a t (** [filter p m] returns the map with all the bindings in [m] that satisfy predicate [p]. If [p] satisfies every binding in [m], [m] is returned unchanged (the result of the function is then physically equal to [m]) @since 3.12.0 @before 4.03 Physical equality was not ensured. *) val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t (** [partition p m] returns a pair of maps [(m1, m2)], where [m1] contains all the bindings of [s] that satisfy the predicate [p], and [m2] is the map with all the bindings of [s] that do not satisfy [p]. @since 3.12.0 *) val cardinal: 'a t -> int (** Return the number of bindings of a map. @since 3.12.0 *) val height: 'a t -> int (** Return the height of the tree encodin the map. NOTE THAT: two maps that are equal may have a different height. @since now *) val bindings: 'a t -> (key * 'a) list (** Return the list of all bindings of the given map. The returned list is sorted in increasing order with respect to the ordering [Ord.compare], where [Ord] is the argument given to {!Map.Make}. @since 3.12.0 *) val min_binding: 'a t -> (key * 'a) (** Return the smallest binding of the given map (with respect to the [Ord.compare] ordering), or raise [Not_found] if the map is empty. @since 3.12.0 *) val min_binding_opt: 'a t -> (key * 'a) option (** Return the smallest binding of the given map (with respect to the [Ord.compare] ordering), or [None] if the map is empty. @since 4.05 *) val max_binding: 'a t -> (key * 'a) (** Same as {!Map.S.min_binding}, but returns the largest binding of the given map. @since 3.12.0 *) val max_binding_opt: 'a t -> (key * 'a) option (** Same as {!Map.S.min_binding_opt}, but returns the largest binding of the given map. @since 4.05 *) val choose: 'a t -> (key * 'a) (** Return one binding of the given map, or raise [Not_found] if the map is empty. Which binding is chosen is unspecified, but equal bindings will be chosen for equal maps. @since 3.12.0 *) val choose_opt: 'a t -> (key * 'a) option (** Return one binding of the given map, or [None] if the map is empty. Which binding is chosen is unspecified, but equal bindings will be chosen for equal maps. @since 4.05 *) val split: key -> 'a t -> 'a t * 'a option * 'a t (** [split x m] returns a triple [(l, data, r)], where [l] is the map with all the bindings of [m] whose key is strictly less than [x]; [r] is the map with all the bindings of [m] whose key is strictly greater than [x]; [data] is [None] if [m] contains no binding for [x], or [Some v] if [m] binds [v] to [x]. @since 3.12.0 *) val find: key -> 'a t -> 'a (** [find x m] returns the current binding of [x] in [m], or raises [Not_found] if no such binding exists. *) val find_opt: key -> 'a t -> 'a option (** [find_opt x m] returns [Some v] if the current binding of [x] in [m] is [v], or [None] if no such binding exists. @since 4.05 *) val find_first: (key -> bool) -> 'a t -> key * 'a (** [find_first f m], where [f] is a monotonically increasing function, returns the binding of [m] with the lowest key [k] such that [f k], or raises [Not_found] if no such key exists. For example, [find_first (fun k -> Ord.compare k x >= 0) m] will return the first binding [k, v] of [m] where [Ord.compare k x >= 0] (intuitively: [k >= x]), or raise [Not_found] if [x] is greater than any element of [m]. @since 4.05 *) val find_first_opt: (key -> bool) -> 'a t -> (key * 'a) option (** [find_first_opt f m], where [f] is a monotonically increasing function, returns an option containing the binding of [m] with the lowest key [k] such that [f k], or [None] if no such key exists. @since 4.05 *) val find_last: (key -> bool) -> 'a t -> key * 'a (** [find_last f m], where [f] is a monotonically decreasing function, returns the binding of [m] with the highest key [k] such that [f k], or raises [Not_found] if no such key exists. @since 4.05 *) val find_last_opt: (key -> bool) -> 'a t -> (key * 'a) option (** [find_last_opt f m], where [f] is a monotonically decreasing function, returns an option containing the binding of [m] with the highest key [k] such that [f k], or [None] if no such key exists. @since 4.05 *) val map: ('a -> 'b) -> 'a t -> 'b t (** [map f m] returns a map with same domain as [m], where the associated value [a] of all bindings of [m] has been replaced by the result of the application of [f] to [a]. The bindings are passed to [f] in increasing order with respect to the ordering over the type of the keys. *) val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t (** Same as {!Map.S.map}, but the function receives as arguments both the key and the associated value for each binding of the map. *) end (** Output signature of the functor {!Map.Make}. *) module Make (Ord : OrderedType) : S with type key = Ord.t (** Functor building an implementation of the map structure given a totally ordered type. *) alt-ergo-free-2.0.0/lib/util/emap.ml0000664000175000017500000003650313430774474014763 0ustar mimi(******************************************************************************) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the license indicated *) (* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) (* present, please contact us to clarify licensing. *) (* *) (******************************************************************************) (*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*) (*+ +*) (*+ OCaml +*) (*+ +*) (*+ Xavier Leroy, projet Cristal, INRIA Rocquencourt +*) (*+ +*) (*+ Copyright 1996 Institut National de Recherche en Informatique et +*) (*+ en Automatique. +*) (*+ +*) (*+ All rights reserved. This file is distributed under the terms of +*) (*+ the GNU Lesser General Public License version 2.1, with the +*) (*+ special exception on linking described in the file LICENSE. +*) (*+ +*) (*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*) module type OrderedType = sig type t val compare: t -> t -> int end module type S = sig type key type +'a t val empty: 'a t val is_empty: 'a t -> bool val mem: key -> 'a t -> bool val add: key -> 'a -> 'a t -> 'a t val singleton: key -> 'a -> 'a t val remove: key -> 'a t -> 'a t val merge: (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t val union: (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val iter: (key -> 'a -> unit) -> 'a t -> unit val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val for_all: (key -> 'a -> bool) -> 'a t -> bool val exists: (key -> 'a -> bool) -> 'a t -> bool val filter: (key -> 'a -> bool) -> 'a t -> 'a t val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t val cardinal: 'a t -> int val height: 'a t -> int val bindings: 'a t -> (key * 'a) list val min_binding: 'a t -> (key * 'a) val min_binding_opt: 'a t -> (key * 'a) option val max_binding: 'a t -> (key * 'a) val max_binding_opt: 'a t -> (key * 'a) option val choose: 'a t -> (key * 'a) val choose_opt: 'a t -> (key * 'a) option val split: key -> 'a t -> 'a t * 'a option * 'a t val find: key -> 'a t -> 'a val find_opt: key -> 'a t -> 'a option val find_first: (key -> bool) -> 'a t -> key * 'a val find_first_opt: (key -> bool) -> 'a t -> (key * 'a) option val find_last: (key -> bool) -> 'a t -> key * 'a val find_last_opt: (key -> bool) -> 'a t -> (key * 'a) option val map: ('a -> 'b) -> 'a t -> 'b t val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t end module Make(Ord: OrderedType) = struct type key = Ord.t type 'a t = Empty | Node of 'a t * key * 'a * 'a t * int let height = function Empty -> 0 | Node(_,_,_,_,h) -> h let create l x d r = let hl = height l and hr = height r in Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) let singleton x d = Node(Empty, x, d, Empty, 1) let bal l x d r = let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in if hl > hr + 2 then begin match l with Empty -> invalid_arg "Map.bal" | Node(ll, lv, ld, lr, _) -> if height ll >= height lr then create ll lv ld (create lr x d r) else begin match lr with Empty -> invalid_arg "Map.bal" | Node(lrl, lrv, lrd, lrr, _)-> create (create ll lv ld lrl) lrv lrd (create lrr x d r) end end else if hr > hl + 2 then begin match r with Empty -> invalid_arg "Map.bal" | Node(rl, rv, rd, rr, _) -> if height rr >= height rl then create (create l x d rl) rv rd rr else begin match rl with Empty -> invalid_arg "Map.bal" | Node(rll, rlv, rld, rlr, _) -> create (create l x d rll) rlv rld (create rlr rv rd rr) end end else Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) let empty = Empty let is_empty = function Empty -> true | _ -> false let rec add x data = function Empty -> Node(Empty, x, data, Empty, 1) | Node(l, v, d, r, h) as m -> let c = Ord.compare x v in if c = 0 then if d == data then m else Node(l, x, data, r, h) else if c < 0 then let ll = add x data l in if l == ll then m else bal ll v d r else let rr = add x data r in if r == rr then m else bal l v d rr let rec find x = function Empty -> raise Not_found | Node(l, v, d, r, _) -> let c = Ord.compare x v in if c = 0 then d else find x (if c < 0 then l else r) let rec find_first_aux v0 d0 f = function Empty -> (v0, d0) | Node(l, v, d, r, _) -> if f v then find_first_aux v d f l else find_first_aux v0 d0 f r let rec find_first f = function Empty -> raise Not_found | Node(l, v, d, r, _) -> if f v then find_first_aux v d f l else find_first f r let rec find_first_opt_aux v0 d0 f = function Empty -> Some (v0, d0) | Node(l, v, d, r, _) -> if f v then find_first_opt_aux v d f l else find_first_opt_aux v0 d0 f r let rec find_first_opt f = function Empty -> None | Node(l, v, d, r, _) -> if f v then find_first_opt_aux v d f l else find_first_opt f r let rec find_last_aux v0 d0 f = function Empty -> (v0, d0) | Node(l, v, d, r, _) -> if f v then find_last_aux v d f r else find_last_aux v0 d0 f l let rec find_last f = function Empty -> raise Not_found | Node(l, v, d, r, _) -> if f v then find_last_aux v d f r else find_last f l let rec find_last_opt_aux v0 d0 f = function Empty -> Some (v0, d0) | Node(l, v, d, r, _) -> if f v then find_last_opt_aux v d f r else find_last_opt_aux v0 d0 f l let rec find_last_opt f = function Empty -> None | Node(l, v, d, r, _) -> if f v then find_last_opt_aux v d f r else find_last_opt f l let rec find_opt x = function Empty -> None | Node(l, v, d, r, _) -> let c = Ord.compare x v in if c = 0 then Some d else find_opt x (if c < 0 then l else r) let rec mem x = function Empty -> false | Node(l, v, _, r, _) -> let c = Ord.compare x v in c = 0 || mem x (if c < 0 then l else r) let rec min_binding = function Empty -> raise Not_found | Node(Empty, x, d, _, _) -> (x, d) | Node(l, _, _, _, _) -> min_binding l let rec min_binding_opt = function Empty -> None | Node(Empty, x, d, _, _) -> Some (x, d) | Node(l, _, _, _, _) -> min_binding_opt l let rec max_binding = function Empty -> raise Not_found | Node(_, x, d, Empty, _) -> (x, d) | Node(_, _, _, r, _) -> max_binding r let rec max_binding_opt = function Empty -> None | Node(_, x, d, Empty, _) -> Some (x, d) | Node(_, _, _, r, _) -> max_binding_opt r let rec remove_min_binding = function Empty -> invalid_arg "Map.remove_min_elt" | Node(Empty, _, _, r, _) -> r | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r let merge t1 t2 = match (t1, t2) with (Empty, t) -> t | (t, Empty) -> t | (_, _) -> let (x, d) = min_binding t2 in bal t1 x d (remove_min_binding t2) let rec remove x = function Empty -> Empty | (Node(l, v, d, r, _) as t) -> let c = Ord.compare x v in if c = 0 then merge l r else if c < 0 then let ll = remove x l in if l == ll then t else bal ll v d r else let rr = remove x r in if r == rr then t else bal l v d rr let rec iter f = function Empty -> () | Node(l, v, d, r, _) -> iter f l; f v d; iter f r let rec map f = function Empty -> Empty | Node(l, v, d, r, h) -> let l' = map f l in let d' = f d in let r' = map f r in Node(l', v, d', r', h) let rec mapi f = function Empty -> Empty | Node(l, v, d, r, h) -> let l' = mapi f l in let d' = f v d in let r' = mapi f r in Node(l', v, d', r', h) let rec fold f m accu = match m with Empty -> accu | Node(l, v, d, r, _) -> fold f r (f v d (fold f l accu)) let rec for_all p = function Empty -> true | Node(l, v, d, r, _) -> p v d && for_all p l && for_all p r let rec exists p = function Empty -> false | Node(l, v, d, r, _) -> p v d || exists p l || exists p r (* Beware: those two functions assume that the added k is *strictly* smaller (or bigger) than all the present keys in the tree; it does not test for equality with the current min (or max) key. Indeed, they are only used during the "join" operation which respects this precondition. *) let rec add_min_binding k v = function | Empty -> singleton k v | Node (l, x, d, r, _) -> bal (add_min_binding k v l) x d r let rec add_max_binding k v = function | Empty -> singleton k v | Node (l, x, d, r, _) -> bal l x d (add_max_binding k v r) (* Same as create and bal, but no assumptions are made on the relative heights of l and r. *) let rec join l v d r = match (l, r) with (Empty, _) -> add_min_binding v d r | (_, Empty) -> add_max_binding v d l | (Node(ll, lv, ld, lr, lh), Node(rl, rv, rd, rr, rh)) -> if lh > rh + 2 then bal ll lv ld (join lr v d r) else if rh > lh + 2 then bal (join l v d rl) rv rd rr else create l v d r (* Merge two trees l and r into one. All elements of l must precede the elements of r. No assumption on the heights of l and r. *) let concat t1 t2 = match (t1, t2) with (Empty, t) -> t | (t, Empty) -> t | (_, _) -> let (x, d) = min_binding t2 in join t1 x d (remove_min_binding t2) let concat_or_join t1 v d t2 = match d with | Some d -> join t1 v d t2 | None -> concat t1 t2 let rec split x = function Empty -> (Empty, None, Empty) | Node(l, v, d, r, _) -> let c = Ord.compare x v in if c = 0 then (l, Some d, r) else if c < 0 then let (ll, pres, rl) = split x l in (ll, pres, join rl v d r) else let (lr, pres, rr) = split x r in (join l v d lr, pres, rr) let rec merge f s1 s2 = match (s1, s2) with (Empty, Empty) -> Empty | (Node (l1, v1, d1, r1, h1), _) when h1 >= height s2 -> let (l2, d2, r2) = split v1 s2 in concat_or_join (merge f l1 l2) v1 (f v1 (Some d1) d2) (merge f r1 r2) | (_, Node (l2, v2, d2, r2, _)) -> let (l1, d1, r1) = split v2 s1 in concat_or_join (merge f l1 l2) v2 (f v2 d1 (Some d2)) (merge f r1 r2) | _ -> assert false let rec union f s1 s2 = match (s1, s2) with | (Empty, s) | (s, Empty) -> s | (Node (l1, v1, d1, r1, h1), Node (l2, v2, d2, r2, h2)) -> if h1 >= h2 then let (l2, d2, r2) = split v1 s2 in let l = union f l1 l2 and r = union f r1 r2 in match d2 with | None -> join l v1 d1 r | Some d2 -> concat_or_join l v1 (f v1 d1 d2) r else let (l1, d1, r1) = split v2 s1 in let l = union f l1 l2 and r = union f r1 r2 in match d1 with | None -> join l v2 d2 r | Some d1 -> concat_or_join l v2 (f v2 d1 d2) r let rec filter p = function Empty -> Empty | Node(l, v, d, r, _) as t -> (* call [p] in the expected left-to-right order *) let l' = filter p l in let pvd = p v d in let r' = filter p r in if pvd then if l==l' && r==r' then t else join l' v d r' else concat l' r' let rec partition p = function Empty -> (Empty, Empty) | Node(l, v, d, r, _) -> (* call [p] in the expected left-to-right order *) let (lt, lf) = partition p l in let pvd = p v d in let (rt, rf) = partition p r in if pvd then (join lt v d rt, concat lf rf) else (concat lt rt, join lf v d rf) type 'a enumeration = End | More of key * 'a * 'a t * 'a enumeration let rec cons_enum m e = match m with Empty -> e | Node(l, v, d, r, _) -> cons_enum l (More(v, d, r, e)) let compare cmp m1 m2 = let rec compare_aux e1 e2 = match (e1, e2) with (End, End) -> 0 | (End, _) -> -1 | (_, End) -> 1 | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) -> let c = Ord.compare v1 v2 in if c <> 0 then c else let c = cmp d1 d2 in if c <> 0 then c else compare_aux (cons_enum r1 e1) (cons_enum r2 e2) in compare_aux (cons_enum m1 End) (cons_enum m2 End) let equal cmp m1 m2 = let rec equal_aux e1 e2 = match (e1, e2) with (End, End) -> true | (End, _) -> false | (_, End) -> false | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) -> Ord.compare v1 v2 = 0 && cmp d1 d2 && equal_aux (cons_enum r1 e1) (cons_enum r2 e2) in equal_aux (cons_enum m1 End) (cons_enum m2 End) let rec cardinal = function Empty -> 0 | Node(l, _, _, r, _) -> cardinal l + 1 + cardinal r let rec bindings_aux accu = function Empty -> accu | Node(l, v, d, r, _) -> bindings_aux ((v, d) :: bindings_aux accu r) l let bindings s = bindings_aux [] s let choose = min_binding let choose_opt = min_binding_opt end alt-ergo-free-2.0.0/lib/util/options.mli0000664000175000017500000002020313430774474015673 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) val fmt : Format.formatter (** setter functions **********************************************************) (** setters for debug flags *) val set_debug : bool -> unit val set_debug_cc : bool -> unit val set_debug_gc : bool -> unit val set_debug_use : bool -> unit val set_debug_uf : bool -> unit val set_debug_fm : bool -> unit val set_debug_sum : bool -> unit val set_debug_arith : bool -> unit val set_debug_bitv : bool -> unit val set_debug_ac : bool -> unit val set_debug_sat : bool -> unit val set_debug_sat_simple : bool -> unit val set_debug_typing : bool -> unit val set_debug_constr : bool -> unit val set_debug_arrays : bool -> unit val set_debug_types : bool -> unit val set_debug_combine : bool -> unit val set_debug_proof : bool -> unit val set_debug_split : bool -> unit val set_debug_matching : int -> unit val set_debug_explanations : bool -> unit val set_timers : bool -> unit val set_profiling : float -> bool -> unit (** additional setters *) val set_type_only : bool -> unit val set_parse_only : bool -> unit val set_verbose : bool -> unit val set_steps_bound : int -> unit val set_age_bound : int -> unit val set_notriggers : bool -> unit val set_triggers_var : bool -> unit val set_nb_triggers : int -> unit val set_greedy : bool -> unit val set_no_Ematching : bool -> unit val set_no_NLA : bool -> unit val set_no_ac : bool -> unit val set_normalize_instances : bool -> unit val set_nocontracongru : bool -> unit val set_term_like_pp : bool -> unit val set_all_models : bool -> unit val set_model : bool -> unit val set_complete_model : bool -> unit val set_interpretation : int -> unit val set_max_split : Numbers.Q.t -> unit val set_fm_cross_limit : Numbers.Q.t -> unit val set_rewriting : bool -> unit val set_proof : bool -> unit val set_rules : int -> unit val set_restricted : bool -> unit val set_bottom_classes : bool -> unit val set_timelimit : float -> unit val set_thread_yield : (unit -> unit) -> unit val set_timeout : (unit -> unit) -> unit val set_partial_bmodel : bool -> unit val set_save_used_context : bool -> unit val set_default_input_lang : string -> unit (* updates the filename to be parsed and sets a js_mode flag *) val set_file_for_js : string -> unit (** getter functions **********************************************************) (** getters for debug flags *) val debug : unit -> bool val debug_warnings : unit -> bool val debug_cc : unit -> bool val debug_gc : unit -> bool val debug_use : unit -> bool val debug_uf : unit -> bool val debug_fm : unit -> bool val debug_fpa : unit -> int val debug_sum : unit -> bool val debug_arith : unit -> bool val debug_bitv : unit -> bool val debug_ac : unit -> bool val debug_sat : unit -> bool val debug_sat_simple : unit -> bool val debug_typing : unit -> bool val debug_constr : unit -> bool val debug_arrays : unit -> bool val debug_types : unit -> bool val debug_combine : unit -> bool val debug_proof : unit -> bool val debug_split : unit -> bool val debug_matching : unit -> int val debug_explanations : unit -> bool (** additional getters *) val enable_assertions : unit -> bool val type_only : unit -> bool val parse_only : unit -> bool val steps_bound : unit -> int val no_tcp : unit -> bool val no_decisions : unit -> bool val no_fm : unit -> bool val no_theory : unit -> bool val tighten_vars : unit -> bool val age_bound : unit -> int val notriggers : unit -> bool val triggers_var : unit -> bool val nb_triggers : unit -> int val verbose : unit -> bool val greedy : unit -> bool val no_Ematching : unit -> bool val no_backjumping : unit -> bool val no_NLA : unit -> bool val no_ac : unit -> bool val no_backward : unit -> bool val no_sat_learning : unit -> bool val sat_learning : unit -> bool val nocontracongru : unit -> bool val term_like_pp : unit -> bool val all_models : unit -> bool val model : unit -> bool val interpretation : unit -> int val debug_interpretation : unit -> bool val complete_model : unit -> bool val max_split : unit -> Numbers.Q.t val fm_cross_limit : unit -> Numbers.Q.t val rewriting : unit -> bool val proof : unit -> bool val rules : unit -> int val restricted : unit -> bool val bottom_classes : unit -> bool val timelimit : unit -> float val interpretation_timelimit : unit -> float val profiling : unit -> bool val cumulative_time_profiling : unit -> bool val profiling_period : unit -> float val js_mode : unit -> bool val case_split_policy : unit -> Util.case_split_policy val preludes : unit -> string list val instantiate_after_backjump : unit -> bool val disable_weaks : unit -> bool val default_input_lang : unit -> string (** this option also yields true if profiling is set to true **) val timers : unit -> bool val replay : unit -> bool val replay_used_context : unit -> bool val replay_all_used_context : unit -> bool val save_used_context : unit -> bool val replay_satml_dfs : unit -> bool val get_file : unit -> string val get_session_file : unit -> string val get_used_context_file : unit -> string val sat_plugin : unit -> string val inequalities_plugin : unit -> string val profiling_plugin : unit -> string val normalize_instances : unit -> bool val partial_bmodel : unit -> bool val use_fpa : unit -> bool (** particular getters : functions that are immediately executed **************) val exec_thread_yield : unit -> unit val exec_timeout : unit -> unit val tool_req : int -> string -> unit (** Simple Timer module **) module Time : sig val start : unit -> unit val value : unit -> float val set_timeout : is_gui:bool -> float -> unit val unset_timeout : is_gui:bool -> unit end (** globals **) val cs_steps : unit -> int val incr_cs_steps : unit -> unit (** open Options in every module to hide polymorphic versions of Pervasives **) val (<>) : int -> int -> bool val (=) : int -> int -> bool val (<) : int -> int -> bool val (>) : int -> int -> bool val (<=) : int -> int -> bool val (>=) : int -> int -> bool val compare : int -> int -> int val can_decide_on : string -> bool val no_decisions_on__is_empty : unit -> bool (** extra **) val set_is_gui : bool -> unit val get_is_gui : unit -> bool val parse_cmdline_arguments : unit -> unit alt-ergo-free-2.0.0/lib/util/numsNumbers.mli0000664000175000017500000000454113430774474016525 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) (** Integers implementation. Based on big_int **) module Z : NumbersInterface.ZSig with type t = Big_int.big_int (** Rationals implementation. Based on nums **) module Q : NumbersInterface.QSig with module Z = Z alt-ergo-free-2.0.0/lib/util/hconsing.mli0000664000175000017500000000472013430774474016016 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) module type HASHED = sig type elt val eq : elt -> elt -> bool val hash : elt -> int val set_id : int -> elt -> elt val initial_size : int val disable_weaks : unit -> bool end module type S = sig type t val make : t -> t val elements : unit -> t list end module Make(H : HASHED) : (S with type t = H.elt) alt-ergo-free-2.0.0/lib/util/util.mli0000664000175000017500000000317013430774474015161 0ustar mimi(******************************************************************************) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the license indicated *) (* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) (* present, please contact us to clarify licensing. *) (* *) (******************************************************************************) exception Timeout module MI : Map.S with type key = int module SS : Set.S with type elt = string (** Different values for -case-split-policy option: -after-theory-assume (default value): after assuming facts in theory by the SAT -before-matching: just before performing a matching round -after-matching: just after performing a matching round **) type case_split_policy = | AfterTheoryAssume (* default *) | BeforeMatching | AfterMatching type inst_kind = Normal | Forward | Backward (* (** This function is intended to be used with Map.merge in order to perform a union of two maps. The first argument is an equality function used to assert that bindings present in boths maps have the same value **) val map_merge_is_union : ('a -> 'a -> bool) -> 'b -> ('a * int) option -> ('a * int) option -> ('a * int) option *) alt-ergo-free-2.0.0/lib/util/.merlin0000664000175000017500000000000413430774474014761 0ustar mimiREC alt-ergo-free-2.0.0/lib/util/gc_debug.mli0000664000175000017500000000150113430774474015737 0ustar mimi(******************************************************************************) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the license indicated *) (* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) (* present, please contact us to clarify licensing. *) (* *) (******************************************************************************) (* empty interface *) alt-ergo-free-2.0.0/lib/util/loc.mli0000664000175000017500000000436213430774474014765 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) type t = Lexing.position * Lexing.position val dummy : t val report : Format.formatter -> t -> unit alt-ergo-free-2.0.0/lib/frontend/0000755000175000017500000000000013430774474014340 5ustar mimialt-ergo-free-2.0.0/lib/frontend/typechecker.mli0000664000175000017500000000476113430774474017363 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Parsed open Typed type env val empty_env : env val file : bool -> env -> file -> ((int tdecl, int) annoted * env) list * env val split_goals : ((int tdecl, int) annoted * env) list -> ((int tdecl, int) annoted * env) list list val term : env -> (Symbols.t * Ty.t) list -> Parsed.lexpr -> (int tterm, int) annoted val new_id : unit -> int alt-ergo-free-2.0.0/lib/frontend/parsed_interface.ml0000664000175000017500000001467613430774474020210 0ustar mimi(******************************************************************************) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the license indicated *) (* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) (* present, please contact us to clarify licensing. *) (* *) (******************************************************************************) open Format open Options open Parsed (* helper functions *) let mk_localized pp_loc pp_desc = { pp_loc ; pp_desc } let mk_infix e1 op e2 = PPinfix (e1, op, e2) let mk_prefix op e = PPprefix (op, e) (** Declaration of types **) let mk_type_decl loc ty_vars ty ty_kind = TypeDecl (loc, ty_vars, ty, ty_kind) let mk_abstract_type_decl loc ty_vars ty = mk_type_decl loc ty_vars ty Abstract let mk_enum_type_decl loc ty_vars ty enums = mk_type_decl loc ty_vars ty (Enum enums) let mk_record_type_decl loc ty_vars ty fields = mk_type_decl loc ty_vars ty (Record fields) (** Declaration of symbols, functions, predicates, and goals *) let mk_logic loc is_ac named_idents ty = Logic (loc , is_ac, named_idents, ty) let mk_function_def loc named_ident args ty expr = Function_def (loc, named_ident, args, ty, expr) let mk_ground_predicate_def loc named_ident expr = Predicate_def (loc, named_ident, [], expr) let mk_non_ground_predicate_def loc named_ident args expr = Predicate_def (loc, named_ident, args, expr) let mk_goal loc name expr = Goal (loc, name, expr) (** Declaration of theories, generic axioms and rewriting rules **) let mk_theory loc name ext expr = Theory (loc, name, ext, expr) let mk_generic_axiom loc name expr = Axiom (loc, name, Default, expr) let mk_rewriting loc name expr = Rewriting (loc, name, expr) (** Declaration of theory axioms and case-splits **) let mk_theory_axiom loc name expr = Axiom (loc, name, Propagator, expr) let mk_theory_case_split loc name expr = Axiom (loc, name, Default, expr) (** Making pure and logic types *) let int_type = PPTint let bool_type = PPTbool let real_type = PPTreal let unit_type = PPTunit let mk_bitv_type size = PPTbitv(int_of_string size) let mk_external_type loc args ty = PPTexternal (args, ty, loc) let mk_logic_type args_ty res_ty = match res_ty with | None -> PPredicate args_ty | Some res -> PFunction (args_ty, res) let mk_var_type loc alpha = PPTvarid (alpha, loc) (** Making arithmetic expressions and predicates **) let mk_int_const loc n = mk_localized loc (PPconst (ConstInt n)) let mk_real_const loc r = mk_localized loc (PPconst (ConstReal r)) let mk_add loc e1 e2 = mk_localized loc (mk_infix e1 PPadd e2) let mk_sub loc e1 e2 = mk_localized loc (mk_infix e1 PPsub e2) let mk_mul loc e1 e2 = mk_localized loc (mk_infix e1 PPmul e2) let mk_div loc e1 e2 = mk_localized loc (mk_infix e1 PPdiv e2) let mk_mod loc e1 e2 = mk_localized loc (mk_infix e1 PPmod e2) let mk_minus loc e = mk_localized loc (mk_prefix PPneg e) let mk_pred_lt loc e1 e2 = mk_localized loc (mk_infix e1 PPlt e2) let mk_pred_le loc e1 e2 = mk_localized loc (mk_infix e1 PPle e2) let mk_pred_gt loc e1 e2 = mk_localized loc (mk_infix e1 PPgt e2) let mk_pred_ge loc e1 e2 = mk_localized loc (mk_infix e1 PPge e2) (** Making Record expressions **) let mk_record loc fields = mk_localized loc (PPrecord fields) let mk_with_record loc e fields = mk_localized loc (PPwith(e, fields)) let mk_dot_record loc e label = mk_localized loc (PPdot(e, label)) (** Making Array expressions **) let mk_array_get loc e1 e2 = mk_localized loc (PPget(e1, e2)) let mk_array_set loc e1 e2 e3 = mk_localized loc (PPset(e1, e2, e3)) (** Making Bit-vector expressions **) let mk_bitv_const = let check_binary_mode s = String.iter (fun x -> match x with | '0' | '1' -> () | _ -> raise Parsing.Parse_error) s; s in fun loc const -> mk_localized loc (PPconst (ConstBitv (check_binary_mode const))) let mk_bitv_extract loc e i j = let i = mk_int_const loc i in let j = mk_int_const loc j in mk_localized loc (PPextract (e, i, j)) let mk_bitv_concat loc e1 e2 = mk_localized loc (PPconcat(e1, e2)) (** Making Boolean / Propositional expressions **) let mk_true_const loc = mk_localized loc (PPconst ConstTrue) let mk_false_const loc = mk_localized loc (PPconst ConstFalse) let mk_and loc e1 e2 = mk_localized loc (mk_infix e1 PPand e2) let mk_or loc e1 e2 = mk_localized loc (mk_infix e1 PPor e2) let mk_iff loc e1 e2 = mk_localized loc (mk_infix e1 PPiff e2) let mk_implies loc e1 e2 = mk_localized loc (mk_infix e1 PPimplies e2) let mk_not loc e = mk_localized loc (mk_prefix PPnot e) let mk_distinct loc e2 = mk_localized loc (PPdistinct e2) let mk_pred_eq loc e1 e2 = mk_localized loc (mk_infix e1 PPeq e2) let mk_pred_not_eq loc e1 e2 = mk_localized loc (mk_infix e1 PPneq e2) (** Making quantified formulas **) let mk_forall loc vs_ty triggers filters expr = mk_localized loc (PPforall_named (vs_ty, triggers, filters, expr)) let mk_exists loc vs_ty triggers filters expr = mk_localized loc (PPexists_named (vs_ty, triggers, filters, expr)) (** Naming and casting types of expressions **) let mk_named loc name e = mk_localized loc (PPnamed (name, e)) let mk_type_cast loc e ty = mk_localized loc (PPcast(e,ty)) (** Making vars, applications, if-then-else, and let expressions **) let mk_var loc var = mk_localized loc (PPvar var) let mk_application loc app args = mk_localized loc (PPapp (app, args)) let mk_ite loc cond th el = mk_localized loc (PPif (cond, th, el)) let mk_let loc var e1 e2 = mk_localized loc (PPlet (var, e1, e2)) let mk_void loc = mk_localized loc (PPconst ConstVoid) (** Making particular expression used in semantic triggers **) let mk_in_interval loc expr low_br ei ej up_br = mk_localized loc (PPinInterval (expr, not low_br, ei ,ej, up_br)) let mk_maps_to loc v expr = mk_localized loc (PPmapsTo (v, expr)) (** Making cuts and checks **) let mk_check loc expr = mk_localized loc (PPcheck expr) let mk_cut loc expr = mk_localized loc (PPcut expr) alt-ergo-free-2.0.0/lib/frontend/parsers.mli0000664000175000017500000000665213430774474016535 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) module type PARSER_INTERFACE = sig val file : Lexing.lexbuf -> Parsed.file val expr : Lexing.lexbuf -> Parsed.lexpr val trigger : Lexing.lexbuf -> Parsed.lexpr list * bool end (** The interface that should be provided by every lexer/parser of an input language *) val register_parser : lang:string -> (module PARSER_INTERFACE) -> unit (** Registers a new 'parser' for the given extension/language *) val parse_file : ?lang:string -> Lexing.lexbuf -> Parsed.file (** Parses the given file (lexbuf) using the appropriate 'parser' depending on the given language. If no language is given, the default one is used. *) val parse_expr : ?lang:string -> Lexing.lexbuf -> Parsed.lexpr (** Parses the given expression (lexbuf) using the appropriate 'parser' depending on the given language. If no language is given, the default one is used. *) val parse_trigger : ?lang:string -> Lexing.lexbuf -> Parsed.lexpr list * bool (** Parses the given trigger (lexbuf) using the appropriate 'parser' depending on the given language. If no language is given, the default one is used. *) val parse_problem : filename:string -> preludes:string list -> Parsed.file (** Parses the given input file and eventual preludes. Parsers are chosen depending on the extension of different files. *) alt-ergo-free-2.0.0/lib/frontend/triggers.ml0000664000175000017500000006600613430774474016532 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Options open Format open Typed module Sy = Symbols type polarity = Pos | Neg module Vterm = Sy.Set module Vtype = Set.Make(struct type t=int let compare=Pervasives.compare end) module STRS = Set.Make( struct type t = (int tterm, int) annoted * Vterm.t * Vtype.t let rec compare_term t1 t2 = match t1.c.tt_desc, t2.c.tt_desc with | TTvar s1 , TTvar s2 -> Sy.compare s1 s2 | TTapp (s1,l1) , TTapp(s2,l2) -> let c = Sy.compare s1 s2 in if c=0 then compare_list l1 l2 else c | TTinfix(a1,s1,b1) , TTinfix(a2,s2,b2) -> let c = Sy.compare s1 s2 in if c=0 then let c=compare_term a1 a2 in if c=0 then compare_term b1 b2 else c else c | TTconst (Treal r1) , TTconst (Treal r2) -> Num.compare_num r1 r2 | x , y -> Pervasives.compare x y and compare_list l1 l2 = match l1,l2 with [] , _ -> -1 | _ , [] -> 1 | x::l1 , y::l2 -> let c = Pervasives.compare x y in if c=0 then compare_list l1 l2 else c let compare (t1,_,_) (t2,_,_) = compare_term t1 t2 end) let sort = List.sort (fun l1 l2 -> compare (List.length l1) (List.length l2)) let neg_pol x = x (*function Pos -> Neg | Neg -> Pos*) let compare_tconstant c1 c2 = match c1, c2 with | Tint s1, Tint s2 -> String.compare s1 s2 | Tint s1, _ -> 1 | _, Tint s1 -> -1 | Treal s1, Treal s2 -> Num.compare_num s1 s2 | Treal s1, _ -> 1 | _, Treal s2 -> -1 | Tbitv s1, Tbitv s2 -> String.compare s1 s2 | Tbitv s1, _ -> 1 | _, Tbitv s2 -> -1 | _ -> Pervasives.compare c1 c2 let rec depth_tterm t = match t.c.tt_desc with | TTconst _ | TTvar _-> 0 | TTapp (_, tl) -> 1 + (List.fold_left (fun acc t -> max (depth_tterm t) acc) 0 tl) | TTinfix _ | TTprefix _ -> 0 (* arithmetic triggers are not suitable *) | TTget (t1, t2) | TTconcat (t1, t2) -> max (depth_tterm t1) (depth_tterm t2) | TTdot(t, _) -> 1 + depth_tterm t | TTrecord lbs -> 1 + (List.fold_left (fun acc (lb, t) -> max (depth_tterm t) acc) 0 lbs) | TTset (t1, t2, t3) | TTextract (t1, t2, t3) -> max (depth_tterm t1) (max (depth_tterm t2) (depth_tterm t3)) | TTlet (s, t1, t2) -> max (depth_tterm t1 + 1) (depth_tterm t2) | TTnamed (_, t) | TTinInterval (t,_,_,_,_) | TTmapsTo(_,t) -> depth_tterm t exception Out of int (* pourquoi cette fonction de comparaison est-elle si compliquee? *) let rec compare_tterm t1 t2 = match t1.c.tt_desc, t2.c.tt_desc with | TTconst c1, TTconst c2 -> compare_tconstant c1 c2 | TTconst _, _ -> -1 | _, TTconst _ -> 1 | TTvar v1, TTvar v2 -> Sy.compare v1 v2 | TTvar _, _ -> -1 | _, TTvar _ -> 1 | TTinfix (tu1, s, tu2), TTinfix (tu1', s', tu2') -> let c = (depth_tterm t1) - (depth_tterm t2) in if c <> 0 then c else let c = Sy.compare s s' in if c <> 0 then c else let c = compare_tterm tu1 tu1' in if c <> 0 then c else compare_tterm tu2 tu2' | TTinfix _, _ -> -1 | _, TTinfix _ -> 1 | TTprefix (s1, t1), TTprefix (s2, t2) -> let c = Sy.compare s1 s2 in if c<>0 then c else compare_tterm t1 t2 | TTprefix _, _ -> -1 | _, TTprefix _ -> 1 | TTapp (s1, tl1), TTapp (s2, tl2) -> let l1 = List.map depth_tterm tl1 in let l2 = List.map depth_tterm tl2 in let l1 = List.fast_sort compare l1 in let l2 = List.fast_sort compare l2 in let c = try List.iter2 (fun n m -> if n <> m then raise (Out (n-m)) ) l1 l2; 0 with | Out c -> c | _ -> (List.length l1) - (List.length l2) in if c <> 0 then c else let c = Sy.compare s1 s2 in if c <> 0 then c else begin try List.iter2 (fun t1 t2 -> let c = compare_tterm t1 t2 in if c <> 0 then raise (Out c) ) tl1 tl2; 0 with Out c -> c end | TTapp _, _ -> -1 | _, TTapp _ -> 1 | TTinInterval (e1, a1, b1, c1, d1), TTinInterval (e2, a2, b2, c2, d2) -> let c = compare_tterm e1 e2 in if c <> 0 then c else Pervasives.compare (a1, b1, c1, d1) (a2, b2, c2, d2) | TTinInterval _, _ -> -1 | _, TTinInterval _ -> 1 | TTmapsTo (x1, e1), TTmapsTo (x2, e2) -> let c = Hstring.compare x1 x2 in if c <> 0 then c else compare_tterm e1 e2 | TTmapsTo _, _ -> -1 | _, TTmapsTo _ -> 1 | TTget (t1, t2), TTget (u1, u2) -> let c = compare_tterm t1 u1 in if c<>0 then c else compare_tterm t2 u2 | TTget _, _ -> -1 | _, TTget _ -> 1 | TTset(t1, t2, t3) , TTset(u1, u2, u3) -> let c = compare_tterm t1 u1 in if c<>0 then c else let c = compare_tterm t2 u2 in if c<>0 then c else compare_tterm t3 u3 | TTset _, _ -> -1 | _, TTset _ -> 1 | TTextract(t1, t2, t3) , TTextract(u1, u2, u3) -> let c = compare_tterm t1 u1 in if c<>0 then c else let c = compare_tterm t2 u2 in if c<>0 then c else compare_tterm t3 u3 | TTextract _, _ -> -1 | _, TTextract _ -> 1 | TTconcat (t1, t2), TTconcat (u1, u2) -> let c = compare_tterm t1 u1 in if c<>0 then c else compare_tterm t2 u2 | TTconcat _, _ -> -1 | _, TTconcat _ -> 1 | TTdot(t1, a1), TTdot(t2,a2) -> let c = Pervasives.compare a1 a2 in if c<>0 then c else compare_tterm t1 t2 | TTdot _, _ -> -1 | _, TTdot _ -> 1 | TTrecord lbs1, TTrecord lbs2 -> let s1 = List.length lbs1 in let s2 = List.length lbs2 in let c = compare s1 s2 in if c <> 0 then c else begin try List.iter2 (fun (lb1, t1) (lb2, t2) -> let c = Hstring.compare lb1 lb2 in if c<>0 then raise (Out c); let c = compare_tterm t1 t2 in if c<>0 then raise (Out c)) lbs1 lbs2; 0 with Out n -> n end | TTrecord _, _ -> -1 | _, TTrecord _ -> 1 | TTlet (s1, t1, u1) , TTlet (s2, t2, u2) -> let c = Sy.compare s1 s2 in if c<>0 then c else let c = compare_tterm t1 u1 in if c<>0 then c else compare_tterm u1 u2 | TTnamed (_, t), _ -> compare_tterm t t2 | _, TTnamed (_, t) -> compare_tterm t1 t let compare_tterm_list tl2 tl1 = let l1 = List.map depth_tterm tl1 in let l2 = List.map depth_tterm tl2 in let l1 = List.rev (List.fast_sort compare l1) in let l2 = List.rev (List.fast_sort compare l2) in let c = try List.iter2 (fun n m -> if n <> m then raise (Out (n-m)) ) l1 l2; 0 with | Out c -> c | _ -> (List.length l2) - (List.length l1) in if c <> 0 then c else begin try List.iter2 (fun t1 t2 -> let c = compare_tterm t1 t2 in if c <> 0 then raise (Out c) ) tl1 tl2; 0 with Out c -> c end module Uniq_sort = struct let rec merge cmp l1 l2 = match l1, l2 with | [], l2 -> l2 | l1, [] -> l1 | h1 :: t1, h2 :: t2 -> let c = cmp h1 h2 in if c = 0 then h1 :: merge cmp t1 t2 else if c < 0 then h1 :: merge cmp t1 l2 else h2 :: merge cmp l1 t2 let rec chop k l = if k = 0 then l else begin match l with | x::t -> chop (k-1) t | _ -> assert false end ;; let stable_sort cmp l = let rec rev_merge l1 l2 accu = match l1, l2 with | [], l2 -> List.rev_append l2 accu | l1, [] -> List.rev_append l1 accu | h1::t1, h2::t2 -> let c = cmp h1 h2 in if c = 0 then rev_merge t1 t2 (h1::accu) else if c < 0 then rev_merge t1 l2 (h1::accu) else rev_merge l1 t2 (h2::accu) in let rec rev_merge_rev l1 l2 accu = match l1, l2 with | [], l2 -> List.rev_append l2 accu | l1, [] -> List.rev_append l1 accu | h1::t1, h2::t2 -> let c = cmp h1 h2 in if c = 0 then rev_merge_rev t1 t2 (h1::accu) else if c > 0 then rev_merge_rev t1 l2 (h1::accu) else rev_merge_rev l1 t2 (h2::accu) in let rec sort n l = match n, l with | 2, x1 :: x2 :: _ -> let c = cmp x1 x2 in if c = 0 then [x1] else if c < 0 then [x1; x2] else [x2; x1] | 3, x1 :: x2 :: x3 :: _ -> let c = cmp x1 x2 in if c = 0 then begin let c = cmp x2 x3 in if c = 0 then [x1] else if c <= 0 then [x1; x3] else [x3; x1] end else if c < 0 then begin let c = cmp x2 x3 in if c = 0 then [x1; x2] else if c < 0 then [x1; x2; x3] else let c = cmp x1 x3 in if c = 0 then [x1; x2] else if c < 0 then [x1; x3; x2] else [x3; x1; x2] end else begin let c = cmp x1 x3 in if c = 0 then [x2; x1] else if c < 0 then [x2; x1; x3] else let c = cmp x2 x3 in if c = 0 then [x2; x1] else if c < 0 then [x2; x3; x1] else [x3; x2; x1] end | n, l -> let n1 = n asr 1 in let n2 = n - n1 in let l2 = chop n1 l in let s1 = rev_sort n1 l in let s2 = rev_sort n2 l2 in rev_merge_rev s1 s2 [] and rev_sort n l = match n, l with | 2, x1 :: x2 :: _ -> let c = cmp x1 x2 in if c = 0 then [x1] else if c > 0 then [x1; x2] else [x2; x1] | 3, x1 :: x2 :: x3 :: _ -> let c = cmp x1 x2 in if c = 0 then begin let c = cmp x2 x3 in if c = 0 then [x1] else if c > 0 then [x1; x3] else [x3; x1] end else if c > 0 then begin let c = cmp x2 x3 in if c = 0 then [x1; x2] else if c > 0 then [x1; x2; x3] else let c = cmp x1 x3 in if c = 0 then [x1; x2] else if c > 0 then [x1; x3; x2] else [x3; x1; x2] end else begin let c = cmp x1 x3 in if c = 0 then [x2; x1] else if c > 0 then [x2; x1; x3] else let c = cmp x2 x3 in if c = 0 then [x2; x1] else if c > 0 then [x2; x3; x1] else [x3; x2; x1] end | n, l -> let n1 = n asr 1 in let n2 = n - n1 in let l2 = chop n1 l in let s1 = sort n1 l in let s2 = sort n2 l2 in rev_merge s1 s2 [] in let len = List.length l in if len < 2 then l else sort len l end let at_most n l = let l = Uniq_sort.stable_sort compare_tterm_list l in let rec atmost acc n l = match n, l with | n, _ when n <= 0 -> acc | _ , [] -> acc | n, x::l -> if List.mem x acc then atmost acc n l else atmost (x::acc) (n-1) l in List.rev (atmost [] n l) let is_var t = match t.c.tt_desc with | TTvar (Sy.Var _) -> true | _ -> false (* constant terms such as "logic nil : 'a list" are allowed in triggers *) module SLLT = Set.Make( struct type t = (int tterm, int) annoted list * Vterm.t * Vtype.t let compare (_, y1, _) (_, y2, _) = Vterm.compare y1 y2 end) let parties bv vty l = let l = if triggers_var () then l else List.filter (fun (t,_,_) -> not (is_var t)) l in let rec parties_rec (llt, llt_ok) l = match l with | [] -> llt_ok | (t, bv1, vty1)::l -> let llt, llt_ok = SLLT.fold (fun (l, bv2, vty2) (llt, llt_ok) -> let bv3 = Vterm.union bv2 bv1 in let vty3 = Vtype.union vty2 vty1 in let e = t::l, bv3, vty3 in if Vterm.subset bv bv3 && Vtype.subset vty vty3 then llt, SLLT.add e llt_ok else SLLT.add e llt, llt_ok) llt (llt, llt_ok) in parties_rec (SLLT.add ([t], bv1, vty1) llt, llt_ok) l in SLLT.elements (parties_rec (SLLT.empty, SLLT.empty) l) let strict_subset bv vty = List.exists (fun (_, bv',vty') -> (Vterm.subset bv bv' && not(Vterm.equal bv bv') && Vtype.subset vty vty') || (Vtype.subset vty vty' && not(Vtype.equal vty vty') && Vterm.subset bv bv') ) let simplification bv_a vty_a = let rec simpl_rec acc = function | [] -> acc | ((t, bv, vty) as e)::l -> if strict_subset bv vty l || strict_subset bv vty acc || (Vterm.subset bv_a bv && Vtype.subset vty_a vty) || (Vterm.equal (Vterm.inter bv_a bv) Vterm.empty && Vtype.equal (Vtype.inter vty_a vty) Vtype.empty) then simpl_rec acc l else simpl_rec (e::acc) l in simpl_rec [] let rec vars_of_term bv acc t = match t.c.tt_desc with | TTvar x -> if Vterm.mem x bv then Vterm.add x acc else acc | TTapp (_,lt) -> List.fold_left (vars_of_term bv) acc lt | TTinfix (t1,_,t2) -> List.fold_left (vars_of_term bv) acc [t1;t2] | TTset (t1, t2, t3) -> List.fold_left (vars_of_term bv) acc [t1;t2;t3] | TTget (t1, t2) -> List.fold_left (vars_of_term bv) acc [t1;t2] | TTlet (_, t1, t2) -> List.fold_left (vars_of_term bv) acc [t1;t2] | TTdot (t1, _) -> vars_of_term bv acc t1 | TTrecord lbs -> List.fold_left (fun acc (_, t) -> vars_of_term bv acc t) acc lbs | TTprefix (_, t) -> vars_of_term bv acc t | TTnamed (_, t) -> vars_of_term bv acc t | TTextract (t1, t2, t3) -> List.fold_left (vars_of_term bv) acc [t1;t2;t3] | TTconcat (t1, t2) -> List.fold_left (vars_of_term bv) acc [t1;t2] | TTconst _ -> acc | TTinInterval (x,_,lb,ub,_) -> (* !! here x should be covered by a syntactic trigger *) List.fold_left (vars_of_term bv) acc [lb;ub] | TTmapsTo (x,e) -> (* !! correct ? *) let acc = if Vterm.mem (Sy.Var x) bv then Vterm.add (Sy.Var x) acc else acc in vars_of_term bv acc e let underscoring_term mvars underscores t = let rec under_rec t = { t with c={ t.c with tt_desc = under_rec_desc t.c.tt_desc}} and under_rec_desc t = match t with | TTvar x when Vterm.mem x mvars -> if not (Vterm.mem x !underscores) then ( underscores := Vterm.add x !underscores; t) else TTvar (Sy.underscoring x) | TTvar _ -> t | TTapp (s,lt) -> TTapp(s,List.map under_rec lt) | TTinfix (t1,op,t2) -> TTinfix(under_rec t1,op,under_rec t2) (* XXX TTlet ? *) | _ -> t in under_rec t let underscoring_mt bv mt = let vars , mvars = List.fold_left (fun (vars, mvars) t -> let vs = vars_of_term bv Vterm.empty t in let mvars = Vterm.union mvars (Vterm.inter vars vs) in Vterm.union vars vs , mvars) (Vterm.empty,Vterm.empty) mt in let underscores = ref Vterm.empty in List.map (underscoring_term mvars underscores) mt let multi_triggers gopt bv vty trs = let terms = simplification bv vty trs in let l_parties = parties bv vty terms in let lm = List.map (fun (lt, _, _) -> lt) l_parties in let mv , mt = List.partition (List.exists is_var) lm in let mv , mt = sort mv , sort mt in let lm = if gopt || triggers_var () then mt@mv else mt in let m = at_most (nb_triggers ()) lm in at_most (nb_triggers ()) m let rec vty_ty acc t = let t = Ty.shorten t in match t with | Ty.Tvar { Ty.v = i; value = None } -> Vtype.add i acc | Ty.Text(l,_) -> List.fold_left vty_ty acc l | Ty.Tfarray (t1,t2) -> vty_ty (vty_ty acc t1) t2 | Ty.Trecord {Ty.args = args; lbs = lbs} -> let acc = List.fold_left vty_ty acc args in List.fold_left (fun acc (_, t) -> vty_ty acc t) acc lbs | _ -> acc let rec vty_term acc t = let acc = vty_ty acc t.c.tt_ty in match t.c.tt_desc with | TTapp (_,l) -> List.fold_left vty_term acc l | TTinfix (t1,_,t2) -> vty_term (vty_term acc t1) t2 | TTset (t1, t2, t3) -> List.fold_left vty_term acc [t1;t2;t3] | TTget (t1, t2) -> List.fold_left vty_term acc [t1;t2] | TTdot (t1, _) -> vty_term acc t1 | TTrecord lbs -> List.fold_left (fun acc (_, t) -> vty_term acc t) acc lbs | TTlet (_, t1, t2) -> List.fold_left vty_term acc [t1;t2] | _ -> acc let rec vty_form acc f = match f.c with | TFatom {c=(TAeq l | TAneq l | TAdistinct l | TAle l | TAlt l | TAbuilt(_,l))}-> List.fold_left vty_term acc l | TFatom {c=TApred t} -> vty_term acc t | TFop(_,l) -> List.fold_left vty_form acc l | TFforall qf | TFexists qf -> let acc = List.fold_left (fun acc (_, ty) -> vty_ty acc ty) acc qf.qf_bvars in vty_form acc qf.qf_form | TFnamed (_, f) -> vty_form acc f | TFlet (ls, s, e, f') -> vty_form (vty_term acc e) f' | _ -> acc let csort = Sy.name "c_sort" let filter_mono vterm vtype (t, bv_t, vty_t) = Vterm.subset vterm bv_t && Vtype.subset vtype vty_t && match t.c.tt_desc with | TTapp(s, _) -> not (Sy.equal s csort) | _ -> true let as_bv bv s = not (Vterm.is_empty (Vterm.inter bv s)) let as_tyv vty s = not (Vtype.is_empty (Vtype.inter vty s)) let potential_triggers = let rec potential_rec ( (bv, vty) as vars) acc t = let vty_t = vty_term Vtype.empty t in match t.c.tt_desc with | TTvar x -> if Vterm.mem x bv || as_tyv vty vty_t then STRS.add (t, Vterm.singleton x, vty_t) acc else acc | TTapp(s, lf) when Sy.equal s Sy.fake_eq || Sy.equal s Sy.fake_neq || Sy.equal s Sy.fake_lt || Sy.equal s Sy.fake_le -> let vty_lf = List.fold_left vty_term vty_t lf in let bv_lf = List.fold_left (vars_of_term bv) Vterm.empty lf in if as_bv bv bv_lf || as_tyv vty vty_lf then let csts = List.filter (fun f -> not (as_bv bv (vars_of_term bv Vterm.empty f)) && not (as_tyv vty (vty_term vty f))) lf in let lf' = lf@csts in let t = { t with c = {t.c with tt_desc = TTapp(s, lf')}} in List.fold_left (potential_rec vars) (STRS.add (t, bv_lf, vty_lf) acc) lf else acc | TTapp(s,lf)-> let vty_lf = List.fold_left vty_term vty_t lf in let bv_lf = List.fold_left (vars_of_term bv) Vterm.empty lf in if as_bv bv bv_lf || as_tyv vty vty_lf then List.fold_left (potential_rec vars) (STRS.add (t, bv_lf, vty_lf) acc) lf else acc | TTinfix(t1,_,t2) | TTlet (_, t1, t2) -> (* XXX TTlet ? *) let vty_lf = List.fold_left vty_term vty_t [t1;t2] in let bv_lf = List.fold_left (vars_of_term bv) Vterm.empty [t1;t2] in if as_bv bv bv_lf || as_tyv vty vty_lf then List.fold_left (potential_rec vars) (STRS.add (t, bv_lf, vty_lf) acc) [t1;t2] else acc | TTset (t1, t2, t3) -> let vty_lf = List.fold_left vty_term vty_t [t1;t2;t3] in let bv_lf = List.fold_left (vars_of_term bv) Vterm.empty [t1;t2;t3] in if as_bv bv bv_lf || as_tyv vty vty_lf then List.fold_left (potential_rec vars) (STRS.add (t, bv_lf, vty_lf) acc) [t1;t2;t3] else acc | TTget (t1, t2) -> let vty_lf = List.fold_left vty_term vty_t [t1;t2] in let bv_lf = List.fold_left (vars_of_term bv) Vterm.empty [t1;t2] in if as_bv bv bv_lf || as_tyv vty vty_lf then List.fold_left (potential_rec vars) (STRS.add (t, bv_lf, vty_lf) acc) [t1;t2] else acc | TTdot (t1 , a) -> let vty_lf = vty_term vty_t t1 in let bv_lf = vars_of_term bv Vterm.empty t1 in if as_bv bv bv_lf || as_tyv vty vty_lf then potential_rec vars (STRS.add (t, bv_lf, vty_lf) acc) t1 else acc | TTrecord lbs -> let lt = List.map snd lbs in let vty_lf = List.fold_left vty_term vty_t lt in let bv_lf = List.fold_left (vars_of_term bv) Vterm.empty lt in if as_bv bv bv_lf || as_tyv vty vty_lf then List.fold_left (potential_rec vars) (STRS.add (t, bv_lf, vty_lf) acc) lt else acc | _ -> acc in fun vars -> List.fold_left (potential_rec vars) STRS.empty let filter_good_triggers (bv, vty) = List.filter (fun (l, _) -> let s1 = List.fold_left (vars_of_term bv) Vterm.empty l in let s2 = List.fold_left vty_term Vtype.empty l in Vterm.subset bv s1 && Vtype.subset vty s2 ) let make_triggers gopt vterm vtype trs = let l = match List.filter (filter_mono vterm vtype) trs with | [] -> multi_triggers gopt vterm vtype trs | trs' -> let f l = at_most (nb_triggers ()) (List.map (fun (t, _, _) -> [t]) l) in let trs_v, trs_nv = List.partition (fun (t, _, _) -> is_var t) trs' in let ll = if trs_nv == [] then if triggers_var () || gopt then f trs_v else [] (*multi_triggers vars trs*) else f trs_nv in if greedy () || gopt then ll@(multi_triggers gopt vterm vtype trs) else ll in Lists.rrmap (fun e -> e, false) l let check_triggers trs (bv, vty) = if trs == [] then failwith "There should be a trigger for every quantified formula in a theory."; List.iter (fun (l, _) -> let s1 = List.fold_left (vars_of_term bv) Vterm.empty l in let s2 = List.fold_left vty_term Vtype.empty l in if not (Vtype.subset vty s2) || not (Vterm.subset bv s1) then failwith "Triggers of a theory should contain every quantified types and variables.") trs; trs let rec make_rec keep_triggers pol gopt vterm vtype f = let c, trs = match f.c with | TFatom {c = (TAfalse | TAtrue)} -> f.c, STRS.empty | TFatom a -> if Vterm.is_empty vterm && Vtype.is_empty vtype then f.c, STRS.empty else begin let l = match a.c with | TAeq l when pol == Neg -> let v = {tt_desc = TTapp(Sy.fake_eq, l); tt_ty = Ty.Tbool} in [ { c = v; annot = a.annot } ] | TAneq ([t1; t2] as l) when pol == Neg -> let v = { tt_desc = TTapp(Sy.fake_neq, l); tt_ty = Ty.Tbool} in [ { c = v; annot = a.annot } ] | TAle l when pol == Neg -> let v = { tt_desc = TTapp(Sy.fake_le, l); tt_ty = Ty.Tbool} in [ { c = v; annot = a.annot } ] | TAlt l when pol == Neg -> let v = { tt_desc = TTapp(Sy.fake_lt, l); tt_ty = Ty.Tbool} in [ { c = v; annot = a.annot } ] | TAle l | TAlt l | TAeq l | TAneq l | TAbuilt(_,l) -> l | TApred t -> [t] | _ -> assert false in f.c, potential_triggers (vterm, vtype) l end | TFop (OPimp, [f1; f2]) -> let f1, trs1 = make_rec keep_triggers (neg_pol pol) gopt vterm vtype f1 in let f2, trs2 = make_rec keep_triggers pol gopt vterm vtype f2 in let trs = STRS.union trs1 trs2 in TFop(OPimp, [f1; f2]), trs | TFop (OPnot, [f1]) -> let f1, trs1 = make_rec keep_triggers (neg_pol pol) gopt vterm vtype f1 in TFop(OPnot, [f1]), trs1 (* | OPiff | OPif of ('a tterm, 'a) annoted *) | TFop (op, lf) -> let lf, trs = List.fold_left (fun (lf, trs1) f -> let f, trs2 = make_rec keep_triggers pol gopt vterm vtype f in f::lf, STRS.union trs1 trs2) ([], STRS.empty) lf in TFop(op,List.rev lf), trs | TFforall ({ qf_form= {c = TFop(OPiff,[{c=TFatom _} as f1;f2]); annot = ido}} as qf) -> let vtype' = vty_form Vtype.empty qf.qf_form in let vterm' = List.fold_left (fun b (s,_) -> Vterm.add s b) Vterm.empty qf.qf_bvars in let vterm'' = Vterm.union vterm vterm' in let vtype'' = Vtype.union vtype vtype' in let f1', trs1 = make_rec keep_triggers pol gopt vterm'' vtype'' f1 in let f2', trs2 = make_rec keep_triggers pol gopt vterm'' vtype'' f2 in let trs12 = if keep_triggers then check_triggers qf.qf_triggers (vterm', vtype') else if Options.notriggers () || qf.qf_triggers == [] then begin (make_triggers false vterm' vtype' (STRS.elements trs1))@ (make_triggers false vterm' vtype' (STRS.elements trs2)) end else begin let lf = filter_good_triggers (vterm', vtype') qf.qf_triggers in if lf != [] then lf else (make_triggers false vterm' vtype' (STRS.elements trs1))@ (make_triggers false vterm' vtype' (STRS.elements trs2)) end in let trs = STRS.filter (fun (_, bvt, _) -> Vterm.is_empty (Vterm.inter bvt vterm')) (STRS.union trs1 trs2) in let r = { qf with qf_triggers = trs12 ; qf_form = {c=TFop(OPiff,[f1'; f2']); annot = ido} } in begin match f.c with | TFforall _ -> TFforall r, trs | _ -> TFexists r , trs end | TFforall qf | TFexists qf -> let vtype' = vty_form Vtype.empty qf.qf_form in let vterm' = List.fold_left (fun b (s,_) -> Vterm.add s b) Vterm.empty qf.qf_bvars in let f', trs = make_rec keep_triggers pol gopt (Vterm.union vterm vterm') (Vtype.union vtype vtype') qf.qf_form in let trs' = if keep_triggers then check_triggers qf.qf_triggers (vterm', vtype') else if Options.notriggers () || qf.qf_triggers == [] then make_triggers gopt vterm' vtype' (STRS.elements trs) else let lf = filter_good_triggers (vterm',vtype') qf.qf_triggers in if lf != [] then lf else make_triggers gopt vterm' vtype' (STRS.elements trs) in let trs = STRS.filter (fun (_, bvt, _) -> Vterm.is_empty (Vterm.inter bvt vterm')) trs in let r = {qf with qf_triggers = trs' ; qf_form = f'} in (match f.c with | TFforall _ -> TFforall r , trs | _ -> TFexists r , trs) | TFlet (up, v, t, f) -> let f, trs = make_rec keep_triggers pol gopt vterm vtype f in let trs = STRS.union trs (potential_triggers (vterm, vtype) [t]) in (* XXX correct for terms *) TFlet (up, v, t, f), trs | TFnamed(lbl, f) -> let f, trs = make_rec keep_triggers pol gopt vterm vtype f in TFnamed(lbl, f), trs in { f with c = c }, trs let make keep_triggers gopt f = match f.c with | TFforall _ | TFexists _ -> let f, _ = make_rec keep_triggers Pos gopt Vterm.empty Vtype.empty f in f | _ -> let vty = vty_form Vtype.empty f in let f, trs = make_rec keep_triggers Pos gopt Vterm.empty vty f in if Vtype.is_empty vty then f else let trs = STRS.elements trs in if keep_triggers then failwith "No polymorphism in use-defined theories."; let trs = make_triggers gopt Vterm.empty vty trs in { f with c = TFforall {qf_bvars=[]; qf_upvars=[]; qf_triggers=trs; qf_form=f; qf_hyp=[] }} alt-ergo-free-2.0.0/lib/frontend/frontend.mli0000664000175000017500000000527613430774474016676 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Typed module type S = sig type sat_env type output = Unsat of Explanation.t | Inconsistent | Sat of sat_env | Unknown of sat_env val process_decl: (Commands.sat_tdecl -> output -> int64 -> unit) -> sat_env * bool * Explanation.t -> Commands.sat_tdecl -> sat_env * bool * Explanation.t val typecheck_file : Parsed.file -> ((int tdecl, int) annoted * Typechecker.env) list list val print_status : Commands.sat_tdecl -> output -> int64 -> unit end module Make (SAT: Sat_solver_sig.S) : S with type sat_env = SAT.t alt-ergo-free-2.0.0/lib/frontend/parsed_interface.mli0000664000175000017500000001237013430774474020346 0ustar mimi(******************************************************************************) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the license indicated *) (* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) (* present, please contact us to clarify licensing. *) (* *) (******************************************************************************) open Parsed (** Declaration of types **) val mk_abstract_type_decl : Loc.t -> string list -> string -> decl [@ocaml.ppwarning "TODO: add documentation for every function in this file"] val mk_enum_type_decl : Loc.t -> string list -> string -> string list -> decl val mk_record_type_decl : Loc.t -> string list -> string -> (string * ppure_type) list -> decl (** Declaration of symbols, functions, predicates, and goals *) val mk_logic : Loc.t -> name_kind -> (string * string) list -> plogic_type -> decl val mk_function_def : Loc.t -> string * string -> (Loc.t * string * ppure_type) list -> ppure_type -> lexpr -> decl val mk_ground_predicate_def : Loc.t -> string * string -> lexpr -> decl val mk_non_ground_predicate_def : Loc.t -> string * string -> (Loc.t * string * ppure_type) list -> lexpr -> decl val mk_goal : Loc.t -> string -> lexpr -> decl (** Declaration of theories, generic axioms and rewriting rules **) val mk_theory : Loc.t -> string -> string -> decl list -> decl val mk_generic_axiom : Loc.t -> string -> lexpr -> decl val mk_rewriting : Loc.t -> string -> lexpr list -> decl (** Declaration of theory axioms and case-splits **) val mk_theory_axiom : Loc.t -> string -> lexpr -> decl val mk_theory_case_split : Loc.t -> string -> lexpr -> decl (** Making pure and logic types *) val int_type : ppure_type val bool_type : ppure_type val real_type : ppure_type val unit_type : ppure_type val mk_bitv_type : string -> ppure_type val mk_external_type : Loc.t -> ppure_type list -> string -> ppure_type val mk_logic_type : ppure_type list -> ppure_type option -> plogic_type val mk_var_type : Loc.t -> string -> ppure_type val mk_logic_type : ppure_type list -> ppure_type option -> plogic_type (** Making arithmetic expressions and predicates **) val mk_int_const : Loc.t -> string -> lexpr val mk_real_const : Loc.t -> Num.num -> lexpr val mk_add : Loc.t -> lexpr -> lexpr -> lexpr val mk_sub : Loc.t -> lexpr -> lexpr -> lexpr val mk_mul : Loc.t -> lexpr -> lexpr -> lexpr val mk_div : Loc.t -> lexpr -> lexpr -> lexpr val mk_mod : Loc.t -> lexpr -> lexpr -> lexpr val mk_minus : Loc.t -> lexpr -> lexpr val mk_pred_lt : Loc.t -> lexpr -> lexpr -> lexpr val mk_pred_le : Loc.t -> lexpr -> lexpr -> lexpr val mk_pred_gt : Loc.t -> lexpr -> lexpr -> lexpr val mk_pred_ge : Loc.t -> lexpr -> lexpr -> lexpr (** Making Record expressions **) val mk_record : Loc.t -> (string * lexpr) list -> lexpr val mk_with_record : Loc.t -> lexpr -> (string * lexpr) list -> lexpr val mk_dot_record : Loc.t -> lexpr -> string -> lexpr (** Making Array expressions **) val mk_array_get : Loc.t -> lexpr -> lexpr -> lexpr val mk_array_set : Loc.t -> lexpr -> lexpr -> lexpr -> lexpr (** Making Bit-vector expressions **) val mk_bitv_const : Loc.t -> string -> lexpr val mk_bitv_extract : Loc.t -> lexpr -> string -> string -> lexpr val mk_bitv_concat : Loc.t -> lexpr -> lexpr -> lexpr (** Making Boolean / Propositional expressions **) val mk_true_const : Loc.t -> lexpr val mk_false_const : Loc.t -> lexpr val mk_and : Loc.t -> lexpr -> lexpr -> lexpr val mk_or : Loc.t -> lexpr -> lexpr -> lexpr val mk_iff : Loc.t -> lexpr -> lexpr -> lexpr val mk_implies : Loc.t -> lexpr -> lexpr -> lexpr val mk_not : Loc.t -> lexpr -> lexpr val mk_distinct : Loc.t -> lexpr list -> lexpr val mk_pred_eq : Loc.t -> lexpr -> lexpr -> lexpr val mk_pred_not_eq : Loc.t -> lexpr -> lexpr -> lexpr (** Making quantified formulas **) val mk_forall : Loc.t -> (string * string * ppure_type) list -> (lexpr list * bool) list -> lexpr list -> lexpr -> lexpr val mk_exists : Loc.t -> (string * string * ppure_type) list -> (lexpr list * bool) list -> lexpr list -> lexpr -> lexpr (** Naming and casting types of expressions **) val mk_type_cast : Loc.t -> lexpr -> ppure_type -> lexpr val mk_named : Loc.t -> string -> lexpr -> lexpr (** Making vars, applications, if-then-else, and let expressions **) val mk_var : Loc.t -> string -> lexpr val mk_application : Loc.t -> string -> lexpr list -> lexpr val mk_ite : Loc.t -> lexpr -> lexpr -> lexpr -> lexpr val mk_let : Loc.t -> string -> lexpr -> lexpr -> lexpr val mk_void : Loc.t -> lexpr (** Making particular expression used in semantic triggers **) val mk_in_interval : Loc.t -> lexpr -> bool -> lexpr -> lexpr -> bool -> lexpr val mk_maps_to : Loc.t -> string -> lexpr -> lexpr (** Making cuts and checks **) val mk_check : Loc.t -> lexpr -> lexpr val mk_cut : Loc.t -> lexpr -> lexpr alt-ergo-free-2.0.0/lib/frontend/parsers.ml0000664000175000017500000001260113430774474016353 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Options open Format module type PARSER_INTERFACE = sig val file : Lexing.lexbuf -> Parsed.file val expr : Lexing.lexbuf -> Parsed.lexpr val trigger : Lexing.lexbuf -> Parsed.lexpr list * bool end let parsers = ref ([] : (string * (module PARSER_INTERFACE)) list) [@ocaml.ppwarning "TODO: add the ability to add parsers dynamically"] let register_parser ~lang new_parser = if List.mem_assoc lang !parsers then begin eprintf "error: A parser is already registered for extension %S@." lang; exit 1 end; parsers := (lang, new_parser) :: !parsers let get_parser lang_opt = let lang = match lang_opt with | Some lang -> lang | None -> Options.default_input_lang () in try List.assoc lang !parsers with Not_found -> eprintf "error: no parser registered for extension %S@." lang; exit 1 let parse_file ?lang lexbuf = let module Parser = (val get_parser lang : PARSER_INTERFACE) in Parser.file lexbuf let parse_expr ?lang lexbuf = let module Parser = (val get_parser lang : PARSER_INTERFACE) in Parser.expr lexbuf let parse_trigger ?lang lexbuf = let module Parser = (val get_parser lang : PARSER_INTERFACE) in Parser.trigger lexbuf (* pre-condition: f is of the form f'.zip *) let extract_zip_file f = let cin = MyZip.open_in f in try match MyZip.entries cin with | [e] when not (MyZip.is_directory e) -> if verbose () then eprintf "I'll read the content of '%s' in the given zip@." (MyZip.filename e); let content = MyZip.read_entry cin e in MyZip.close_in cin; content | _ -> MyZip.close_in cin; raise (Arg.Bad (sprintf "%s '%s' %s@?" "The zipped file" f "should contain exactly one file.")) with e -> MyZip.close_in cin; raise e let parse_input_file file = if verbose() then fprintf fmt "[input_lang] parsing file %s@." file; let cin, lb, opened_cin, ext = if Filename.check_suffix file ".zip" then let ext = Filename.extension (Filename.chop_extension file) in let file_content = extract_zip_file file in stdin, Lexing.from_string file_content, false, ext else let ext = Filename.extension file in if Pervasives.(<>) file "" then let cin = open_in file in cin, Lexing.from_channel cin, true, ext else stdin, Lexing.from_channel stdin, false, ext in try let ext = if String.equal ext "" then None else Some ext in let a = parse_file ?lang:ext lb in if opened_cin then close_in cin; if parse_only () then exit 0; a with | Errors.Lexical_error (loc, s) -> Loc.report err_formatter loc; eprintf "lexical error: %s\n@." s; if opened_cin then close_in cin; exit 1 | Errors.Syntax_error (loc, s) -> Loc.report err_formatter loc; eprintf "syntax error when reading token %S\n@." s; if opened_cin then close_in cin; exit 1 let parse_problem ~filename ~preludes = let acc = parse_input_file filename in List.fold_left (fun acc prelude -> let prelude = if Sys.file_exists prelude then prelude else Config.preludesdir ^ "/" ^ prelude in List.rev_append (List.rev (parse_input_file prelude)) acc) acc (List.rev preludes) alt-ergo-free-2.0.0/lib/frontend/triggers.mli0000664000175000017500000000461513430774474016701 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Typed (* make k b f computes the triggers for a formula f if k is true existing triggers are checked if b is true then variables are authorized in multi-triggers *) val make : bool -> bool -> (int tform, int) annoted -> (int tform, int) annoted alt-ergo-free-2.0.0/lib/frontend/typechecker.ml0000664000175000017500000015721713430774474017217 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Options open Format open Parsed open Typed open Errors module S = Set.Make(String) module Sy = Symbols.Set module MString = Map.Make(struct type t = string let compare = Pervasives.compare end) module Types = struct (* environment for user-defined types *) type t = { to_ty : Ty.t MString.t; from_labels : string MString.t; } let to_tyvars = ref MString.empty let empty = { to_ty = MString.empty; from_labels = MString.empty } let fresh_vars env vars loc = List.map (fun x -> if MString.mem x !to_tyvars then error (TypeDuplicateVar x) loc; let nv = Ty.Tvar (Ty.fresh_var ()) in to_tyvars := MString.add x nv !to_tyvars; nv ) vars let check_number_args loc lty ty = match ty with | Ty.Text (lty', s) | Ty.Trecord {Ty.args=lty'; name=s} -> if List.length lty <> List.length lty' then error (WrongNumberofArgs (Hstring.view s)) loc; lty' | Ty.Tsum (s, _) -> if List.length lty <> 0 then error (WrongNumberofArgs (Hstring.view s)) loc; [] | _ -> assert false let equal_pp_vars lpp lvars = try List.for_all2 (fun pp x -> match pp with | PPTvarid (y, _) -> Pervasives.(=) x y | _ -> false ) lpp lvars with Invalid_argument _ -> false let rec ty_of_pp loc env rectype = function | PPTint -> Ty.Tint | PPTbool -> Ty.Tbool | PPTunit -> Ty.Tunit | PPTreal -> Ty.Treal | PPTbitv n -> Ty.Tbitv n | PPTvarid (s, _) -> begin try MString.find s !to_tyvars with Not_found -> let nty = Ty.Tvar (Ty.fresh_var ()) in to_tyvars := MString.add s nty !to_tyvars; nty end | PPTexternal (l, s, loc) when Pervasives.(=) s "farray" -> let t1,t2 = match l with | [t2] -> PPTint,t2 | [t1;t2] -> t1,t2 | _ -> error (WrongArity(s,2)) loc in let ty1 = ty_of_pp loc env rectype t1 in let ty2 = ty_of_pp loc env rectype t2 in Ty.Tfarray (ty1, ty2) | PPTexternal (l, s, loc) -> begin match rectype with | Some (id, vars, ty) when Pervasives.(=) s id && equal_pp_vars l vars -> ty | _ -> try let lty = List.map (ty_of_pp loc env rectype) l in let ty = MString.find s env.to_ty in let vars = check_number_args loc lty ty in Ty.instantiate vars lty ty with Not_found -> error (UnknownType s) loc end let add env vars id body loc = if MString.mem id env.to_ty then error (ClashType id) loc; let ty_vars = fresh_vars env vars loc in match body with | Abstract -> { env with to_ty = MString.add id (Ty.text ty_vars id) env.to_ty } | Enum lc -> { env with to_ty = MString.add id (Ty.tsum id lc) env.to_ty } | Record lbs -> let lbs = List.map (fun (x, pp) -> x, ty_of_pp loc env None pp) lbs in { to_ty = MString.add id (Ty.trecord ty_vars id lbs) env.to_ty; from_labels = List.fold_left (fun fl (l,_) -> MString.add l id fl) env.from_labels lbs } module SH = Set.Make(Hstring) let check_labels lbs ty loc = let rec check_duplicates s = function | [] -> () | (lb, _) :: l -> if SH.mem lb s then error (DuplicateLabel lb) loc; check_duplicates (SH.add lb s) l in check_duplicates SH.empty lbs; match ty with | Ty.Trecord {Ty.lbs=l} -> if List.length lbs <> List.length l then error WrongNumberOfLabels loc; List.iter (fun (lb, _) -> try ignore (Hstring.list_assoc lb l) with Not_found -> error (WrongLabel(lb, ty)) loc) lbs; ty | _ -> assert false let from_labels env lbs loc = match lbs with | [] -> assert false | (l, _) :: _ -> try let l = Hstring.view l in let ty = MString.find (MString.find l env.from_labels) env.to_ty in check_labels lbs ty loc with Not_found -> error (NoRecordType l) loc let rec monomorphized = function | PPTvarid (x, _) when not (MString.mem x !to_tyvars) -> to_tyvars := MString.add x (Ty.fresh_empty_text ()) !to_tyvars; | PPTexternal (args, _, _) -> List.iter monomorphized args | pp_ty -> () let init_labels fl id loc = function | Record lbs -> List.fold_left (fun fl (s, _) -> if MString.mem s fl then error (ClashLabel (s, (MString.find s fl))) loc; MString.add s id fl) fl lbs | _ -> fl end module Env = struct type profile = { args : Ty.t list; result : Ty.t } type t = { var_map : (Symbols.t * Ty.t) MString.t ; (* variables' map*) types : Types.t ; logics : (Symbols.t * profile) MString.t (* logic symbols' map *) } let empty = { var_map = MString.empty; types = Types.empty; logics = MString.empty } let add env lv fvar ty = let vmap = List.fold_left (fun vmap x -> MString.add x (fvar x, ty) vmap) env.var_map lv in { env with var_map = vmap } let add_var env lv pp_ty loc = let ty = Types.ty_of_pp loc env.types None pp_ty in add env lv Symbols.var ty let add_names env lv pp_ty loc = Types.monomorphized pp_ty; let ty = Types.ty_of_pp loc env.types None pp_ty in add env lv Symbols.name ty let add_names_lbl env lv pp_ty loc = Types.monomorphized pp_ty; let ty = Types.ty_of_pp loc env.types None pp_ty in let rlv = List.fold_left (fun acc (x, lbl) -> let lbl = Hstring.make lbl in if not (Hstring.equal lbl Hstring.empty) then Symbols.add_label lbl (Symbols.name x); x::acc ) [] lv in let lv = List.rev rlv in add env lv Symbols.name ty let add_logics env ac names pp_profile loc = let profile = match pp_profile with | PPredicate args -> { args = List.map (Types.ty_of_pp loc env.types None) args; result = Ty.Tbool } (*| PFunction ([], PPTvarid (_, loc)) -> error CannotGeneralize loc*) | PFunction(args, res) -> let args = List.map (Types.ty_of_pp loc env.types None) args in let res = Types.ty_of_pp loc env.types None res in { args = args; result = res } in let logics = List.fold_left (fun logics (n, lbl) -> let sy = Symbols.name n ~kind:ac in if MString.mem n logics then error (SymbAlreadyDefined n) loc; let lbl = Hstring.make lbl in if not (Hstring.equal lbl Hstring.empty) then Symbols.add_label lbl sy; MString.add n (sy, profile) logics) env.logics names in { env with logics = logics } let find {var_map=m} n = MString.find n m let mem n {var_map=m} = MString.mem n m let list_of {var_map=m} = MString.fold (fun _ c acc -> c::acc) m [] let add_type_decl env vars id body loc = { env with types = Types.add env.types vars id body loc } (* returns a type with fresh variables *) let fresh_type env n loc = try let s, { args = args; result = r} = MString.find n env.logics in let args, subst = Ty.fresh_list args Ty.esubst in let res, _ = Ty.fresh r subst in s, { args = args; result = res } with Not_found -> error (SymbUndefined n) loc end let new_id = let r = ref 0 in fun () -> r := !r+1; !r let rec freevars_term acc t = match t.c.tt_desc with | TTvar x -> Sy.add x acc | TTapp (_,lt) -> List.fold_left freevars_term acc lt | TTinInterval (e,_,_,_,_) -> freevars_term acc e | TTmapsTo (_, e) -> freevars_term acc e | TTinfix (t1,_,t2) | TTget(t1, t2) -> List.fold_left freevars_term acc [t1; t2] | TTset (t1, t2, t3) -> List.fold_left freevars_term acc [t1; t2; t3] | TTdot (t1, _) -> freevars_term acc t1 | TTrecord lbs -> List.fold_left (fun acc (_, t) -> freevars_term acc t) acc lbs | TTconst _ -> acc | TTprefix (_, t) -> freevars_term acc t | TTconcat (t1, t2) -> freevars_term (freevars_term acc t1) t2 | TTnamed (_, t) -> freevars_term acc t | TTextract (t1, t2, t3) -> freevars_term (freevars_term (freevars_term acc t1) t2) t3 | TTlet (sy, t1, t2) -> let acc_t1 = freevars_term acc t1 in let acc_t2 = freevars_term acc_t1 t2 in if Sy.mem sy acc_t1 then acc_t2 (* the symbol sy is already a free var in acc or t1 -> keep it *) else Sy.remove sy acc_t2 (* the symbol sy is not a free var *) let freevars_atom a = match a.c with | TAeq lt | TAneq lt | TAle lt | TAlt lt | TAbuilt(_,lt) | TAdistinct lt -> List.fold_left freevars_term Sy.empty lt | TApred t -> freevars_term Sy.empty t | _ -> Sy.empty let rec freevars_form f = match f with | TFatom a -> freevars_atom a | TFop (_,lf) -> List.fold_left Sy.union Sy.empty (List.map (fun f -> freevars_form f.c) lf) | TFforall qf | TFexists qf -> let s = freevars_form qf.qf_form.c in List.fold_left (fun acc (s,_) -> Sy.remove s acc) s qf.qf_bvars | TFlet(up,v,t,f) -> freevars_term (Sy.remove v (freevars_form f.c)) t | TFnamed(_, f) -> freevars_form f.c let symbol_of = function PPadd -> Symbols.Op Symbols.Plus | PPsub -> Symbols.Op Symbols.Minus | PPmul -> Symbols.Op Symbols.Mult | PPdiv -> Symbols.Op Symbols.Div | PPmod -> Symbols.Op Symbols.Modulo | _ -> assert false let append_type msg ty = fprintf str_formatter "%s %a" msg Ty.print ty; flush_str_formatter () let type_var_desc env p loc = try let s,t = Env.find env p in Options.tool_req 1 (append_type "TR-Typing-Var$_\\Gamma$ type" t); TTvar s , t with Not_found -> match Env.fresh_type env p loc with | s, { Env.args = []; result = ty} -> Options.tool_req 1 (append_type "TR-Typing-Var$_\\Delta$ type" ty); TTvar s , ty | _ -> error (ShouldBeApply p) loc let rec type_term env f = let e,t = type_term_desc env f.pp_loc f.pp_desc in {c = { tt_desc = e ; tt_ty = t }; annot = new_id ()} and type_term_desc env loc = function | PPconst ConstTrue -> Options.tool_req 1 (append_type "TR-Typing-Const type" Ty.Tbool); TTconst Ttrue, Ty.Tbool | PPconst ConstFalse -> Options.tool_req 1 (append_type "TR-Typing-Const type" Ty.Tbool); TTconst Tfalse, Ty.Tbool | PPconst ConstVoid -> Options.tool_req 1 (append_type "TR-Typing-Const type" Ty.Tunit); TTconst Tvoid, Ty.Tunit | PPconst (ConstInt n) -> Options.tool_req 1 (append_type "TR-Typing-Const type" Ty.Tint); TTconst(Tint n), Ty.Tint | PPconst (ConstReal n) -> Options.tool_req 1 (append_type "TR-Typing-Const type" Ty.Treal); TTconst(Treal n), Ty.Treal | PPconst (ConstBitv n) -> Options.tool_req 1 (append_type "TR-Typing-Const type" (Ty.Tbitv (String.length n))); TTconst(Tbitv n), Ty.Tbitv (String.length n) | PPvar p -> type_var_desc env p loc | PPapp(p,args) -> begin let te_args = List.map (type_term env) args in let lt_args = List.map (fun {c={tt_ty=t}} -> t) te_args in let s, {Env.args = lt; result = t} = Env.fresh_type env p loc in try List.iter2 Ty.unify lt lt_args; Options.tool_req 1 (append_type "TR-Typing-App type" t); TTapp(s,te_args), t with | Ty.TypeClash(t1,t2) -> error (Unification(t1,t2)) loc | Invalid_argument _ -> error (WrongNumberofArgs p) loc end | PPinfix(t1,(PPadd | PPsub | PPmul | PPdiv as op),t2) -> begin let s = symbol_of op in let te1 = type_term env t1 in let te2 = type_term env t2 in let ty1 = Ty.shorten te1.c.tt_ty in let ty2 = Ty.shorten te2.c.tt_ty in match ty1, ty2 with | Ty.Tint, Ty.Tint -> Options.tool_req 1 (append_type "TR-Typing-OpBin type" ty1); TTinfix(te1,s,te2) , ty1 | Ty.Treal, Ty.Treal -> Options.tool_req 1 (append_type "TR-Typing-OpBin type" ty2); TTinfix(te1,s,te2), ty2 | Ty.Tint, _ -> error (ShouldHaveType(ty2,Ty.Tint)) t2.pp_loc | Ty.Treal, _ -> error (ShouldHaveType(ty2,Ty.Treal)) t2.pp_loc | _ -> error (ShouldHaveTypeIntorReal ty1) t1.pp_loc end | PPinfix(t1, PPmod, t2) -> begin let s = symbol_of PPmod in let te1 = type_term env t1 in let te2 = type_term env t2 in let ty1 = Ty.shorten te1.c.tt_ty in let ty2 = Ty.shorten te2.c.tt_ty in match ty1, ty2 with | Ty.Tint, Ty.Tint -> Options.tool_req 1 (append_type "TR-Typing-OpMod type" ty1); TTinfix(te1,s,te2) , ty1 | _ -> error (ShouldHaveTypeInt ty1) t1.pp_loc end | PPprefix(PPneg, {pp_desc=PPconst (ConstInt n)}) -> Options.tool_req 1 (append_type "TR-Typing-OpUnarith type" Ty.Tint); TTconst(Tint ("-"^n)), Ty.Tint | PPprefix(PPneg, {pp_desc=PPconst (ConstReal n)}) -> Options.tool_req 1 (append_type "TR-Typing-OpUnarith type" Ty.Treal); TTconst(Treal (Num.minus_num n)), Ty.Treal | PPprefix(PPneg, e) -> let te = type_term env e in let ty = Ty.shorten te.c.tt_ty in if ty!=Ty.Tint && ty!=Ty.Treal then error (ShouldHaveTypeIntorReal ty) e.pp_loc; Options.tool_req 1 (append_type "TR-Typing-OpUnarith type" ty); TTprefix(Symbols.Op Symbols.Minus, te), ty | PPconcat(t1, t2) -> begin let te1 = type_term env t1 in let te2 = type_term env t2 in let ty1 = Ty.shorten te1.c.tt_ty in let ty2 = Ty.shorten te2.c.tt_ty in match ty1, ty2 with | Ty.Tbitv n , Ty.Tbitv m -> Options.tool_req 1 (append_type "TR-Typing-OpConcat type" (Ty.Tbitv (n+m))); TTconcat(te1, te2), Ty.Tbitv (n+m) | Ty.Tbitv _ , _ -> error (ShouldHaveTypeBitv ty2) t2.pp_loc | _ , Ty.Tbitv _ -> error (ShouldHaveTypeBitv ty1) t1.pp_loc | _ -> error (ShouldHaveTypeBitv ty1) t1.pp_loc end | PPextract(e, ({pp_desc=PPconst(ConstInt i)} as ei), ({pp_desc=PPconst(ConstInt j)} as ej)) -> begin let te = type_term env e in let tye = Ty.shorten te.c.tt_ty in let i = int_of_string i in let j = int_of_string j in match tye with | Ty.Tbitv n -> if i>j then error (BitvExtract(i,j)) loc; if j>=n then error (BitvExtractRange(n,j) ) loc; let tei = type_term env ei in let tej = type_term env ej in Options.tool_req 1 (append_type "TR-Typing-OpExtract type" (Ty.Tbitv (j-i+1))); TTextract(te, tei, tej), Ty.Tbitv (j-i+1) | _ -> error (ShouldHaveType(tye,Ty.Tbitv (j+1))) loc end | PPget (t1, t2) -> begin let te1 = type_term env t1 in let te2 = type_term env t2 in let tyarray = Ty.shorten te1.c.tt_ty in let tykey2 = Ty.shorten te2.c.tt_ty in match tyarray with | Ty.Tfarray (tykey,tyval) -> begin try Ty.unify tykey tykey2; Options.tool_req 1 (append_type "TR-Typing-OpGet type" tyval); TTget(te1, te2), tyval with | Ty.TypeClash(t1,t2) -> error (Unification(t1,t2)) loc end | _ -> error ShouldHaveTypeArray t1.pp_loc end | PPset (t1, t2, t3) -> begin let te1 = type_term env t1 in let te2 = type_term env t2 in let te3 = type_term env t3 in let ty1 = Ty.shorten te1.c.tt_ty in let tykey2 = Ty.shorten te2.c.tt_ty in let tyval2 = Ty.shorten te3.c.tt_ty in try match ty1 with | Ty.Tfarray (tykey,tyval) -> Ty.unify tykey tykey2;Ty.unify tyval tyval2; Options.tool_req 1 (append_type "TR-Typing-OpSet type" ty1); TTset(te1, te2, te3), ty1 | _ -> error ShouldHaveTypeArray t1.pp_loc with | Ty.TypeClash(t, t') -> error (Unification(t, t')) loc end | PPif(t1,t2,t3) -> begin let te1 = type_term env t1 in let ty1 = Ty.shorten te1.c.tt_ty in if not (Ty.equal ty1 Ty.Tbool) then error (ShouldHaveType(ty1,Ty.Tbool)) t1.pp_loc; let te2 = type_term env t2 in let te3 = type_term env t3 in let ty2 = Ty.shorten te2.c.tt_ty in let ty3 = Ty.shorten te3.c.tt_ty in if not (Ty.equal ty2 ty3) then error (ShouldHaveType(ty3,ty2)) t3.pp_loc; Options.tool_req 1 (append_type "TR-Typing-Ite type" ty2); TTapp(Symbols.name "ite",[te1;te2;te3]) , ty2 end | PPdot(t, a) -> begin let te = type_term env t in let ty = Ty.shorten te.c.tt_ty in match ty with | Ty.Trecord {Ty.name=g; lbs=lbs} -> begin try let a = Hstring.make a in TTdot(te, a), Hstring.list_assoc a lbs with Not_found -> let g = Hstring.view g in error (ShouldHaveLabel(g,a)) t.pp_loc end | _ -> error (ShouldHaveTypeRecord ty) t.pp_loc end | PPrecord lbs -> begin let lbs = List.map (fun (lb, t) -> Hstring.make lb, type_term env t) lbs in let lbs = List.sort (fun (l1, _) (l2, _) -> Hstring.compare l1 l2) lbs in let ty = Types.from_labels env.Env.types lbs loc in let ty, _ = Ty.fresh (Ty.shorten ty) Ty.esubst in match ty with | Ty.Trecord {Ty.lbs=ty_lbs} -> begin try let lbs = List.map2 (fun (s, te) (lb,ty_lb)-> Ty.unify te.c.tt_ty ty_lb; lb, te) lbs ty_lbs in TTrecord(lbs), ty with Ty.TypeClash(t1,t2) -> error (Unification(t1,t2)) loc end | _ -> error ShouldBeARecord loc end | PPwith(e, lbs) -> begin let te = type_term env e in let lbs = List.map (fun (lb, t) -> Hstring.make lb, (type_term env t, t.pp_loc)) lbs in let ty = Ty.shorten te.c.tt_ty in match ty with | Ty.Trecord {Ty.lbs=ty_lbs} -> let nlbs = List.map (fun (lb, ty_lb) -> try let v, _ = Hstring.list_assoc lb lbs in Ty.unify ty_lb v.c.tt_ty; lb, v with | Not_found -> lb, {c = { tt_desc = TTdot(te, lb); tt_ty = ty_lb}; annot = te.annot } | Ty.TypeClash(t1,t2) -> error (Unification(t1,t2)) loc ) ty_lbs in List.iter (fun (lb, _) -> try ignore (Hstring.list_assoc lb ty_lbs) with Not_found -> error (NoLabelInType(lb, ty)) loc) lbs; TTrecord(nlbs), ty | _ -> error ShouldBeARecord loc end | PPlet(x, t1, t2) -> let te1 = type_term env t1 in let ty1 = Ty.shorten te1.c.tt_ty in let env = Env.add env [x] Symbols.var ty1 in let te2 = type_term env t2 in let ty2 = Ty.shorten te2.c.tt_ty in let s, _ = Env.find env x in Options.tool_req 1 (append_type "TR-Typing-Let type" ty2); TTlet(s, te1, te2), ty2 (* | PPnamed(lbl, t) -> *) (* let te = type_term env t in *) (* te.c.tt_desc, te.c.tt_ty *) | PPnamed (lbl, t) -> let te = type_term env t in let ty = Ty.shorten te.c.tt_ty in let lbl = Hstring.make lbl in TTnamed (lbl, te), ty | PPcast (t,ty) -> let ty = Types.ty_of_pp loc env.Env.types None ty in let te = type_term env t in begin try Ty.unify te.c.tt_ty ty; te.c.tt_desc, Ty.shorten te.c.tt_ty with | Ty.TypeClash(t1,t2) -> error (Unification(t1,t2)) loc end | _ -> error SyntaxError loc let rec join_forall f = match f.pp_desc with | PPforall(vs_ty, trs1, hyp1, f) -> let tyvars,trs2,hyp2, f = join_forall f in vs_ty @ tyvars , trs1@trs2 , hyp1@hyp2, f | PPforall_named (named_vs_ty, trs1, hyp1, f) -> let vs_ty = List.map (fun (v, _, ty) -> v, ty) named_vs_ty in join_forall {f with pp_desc = PPforall (vs_ty, trs1, hyp1, f)} | PPnamed(lbl, f) -> join_forall f | _ -> [] , [] , [], f let rec join_exists f = match f.pp_desc with | PPexists (vs_ty, trs1, hyp1, f) -> let tyvars,trs2, hyp2,f = join_exists f in vs_ty @ tyvars , trs1@trs2, hyp1@hyp2, f | PPexists_named (named_vs_ty, trs1, hyp1, f) -> let vs_ty = List.map (fun (v, _, ty) -> v, ty) named_vs_ty in join_exists {f with pp_desc = PPexists (vs_ty, trs1, hyp1, f)} | PPnamed (_, f) -> join_exists f | _ -> [] , [] , [], f let type_bound env bnd ty = try match bnd.pp_desc with | PPvar s -> begin match s.[0] with | '?' -> let res = TTvar (Symbols.Var (Hstring.make s)) in {c = { tt_desc = res ; tt_ty = ty }; annot = new_id ()} | _ -> type_term env bnd end | PPconst num -> begin match num with | ConstInt _ | ConstReal _-> type_term env bnd | _ -> assert false end | _ -> assert false with Invalid_argument s when String.equal s "index out of bounds" -> assert false let type_trigger in_theory env l = List.map (fun t -> match in_theory, t.pp_desc with | false, PPinInterval _ -> error ThSemTriggerError t.pp_loc | false, PPmapsTo _ -> error ThSemTriggerError t.pp_loc | true, PPinInterval (e, a,b, c, d) -> let te = type_term env e in let tt_ty = te.c.tt_ty in let tb = type_bound env b tt_ty in if not (Ty.equal tt_ty tb.c.tt_ty) then error (ShouldHaveType(tb.c.tt_ty,tt_ty)) b.pp_loc; let tc = type_bound env c tt_ty in if not (Ty.equal tt_ty tc.c.tt_ty) then error (ShouldHaveType(tc.c.tt_ty, tt_ty)) c.pp_loc; { c = { tt_desc = TTinInterval(te, a, tb , tc, d) ; tt_ty = Ty.Tbool}; annot = new_id ()} | true, PPmapsTo (x, e) -> let vx, ty_x = type_var_desc env x t.pp_loc in let hs_x = match vx with TTvar Symbols.Var hs -> hs | _ -> assert false in let te = type_term env e in let tt_ty = te.c.tt_ty in if not (Ty.equal tt_ty ty_x) then error (ShouldHaveType(ty_x,tt_ty)) t.pp_loc; { c = { tt_desc = TTmapsTo(hs_x, te) ; tt_ty = Ty.Tbool}; annot = new_id ()} | _ -> type_term env t )l let rec type_form ?(in_theory=false) env f = let rec type_pp_desc pp_desc = match pp_desc with | PPconst ConstTrue -> Options.tool_req 1 "TR-Typing-True$_F$"; TFatom {c=TAtrue; annot=new_id ()}, Sy.empty | PPconst ConstFalse -> Options.tool_req 1 "TR-Typing-False$_F$"; TFatom {c=TAfalse; annot=new_id ()}, Sy.empty | PPvar p -> Options.tool_req 1 "TR-Typing-Var$_F$"; let r = begin match Env.fresh_type env p f.pp_loc with | s, { Env.args = []; result = Ty.Tbool} -> let t2 = {c = {tt_desc=TTconst Ttrue;tt_ty=Ty.Tbool}; annot = new_id ()} in let t1 = {c = {tt_desc=TTvar s; tt_ty=Ty.Tbool}; annot = new_id ()} in TFatom {c = TAeq [t1;t2]; annot=new_id ()} | _ -> error (NotAPropVar p) f.pp_loc end in r, freevars_form r | PPapp(p,args ) -> Options.tool_req 1 "TR-Typing-App$_F$"; let r = begin let te_args = List.map (type_term env) args in let lt_args = List.map (fun {c={tt_ty=t}} -> t) te_args in match Env.fresh_type env p f.pp_loc with | s , { Env.args = lt; result = Ty.Tbool} -> begin try List.iter2 Ty.unify lt lt_args; if Pervasives.(=) p "<=" || Pervasives.(=) p "<" then TFatom { c = TAbuilt(Hstring.make p,te_args); annot=new_id ()} else let t1 = { c = {tt_desc=TTapp(s,te_args); tt_ty=Ty.Tbool}; annot=new_id (); } in TFatom { c = TApred t1; annot=new_id () } with | Ty.TypeClash(t1,t2) -> error (Unification(t1,t2)) f.pp_loc | Invalid_argument _ -> error (WrongNumberofArgs p) f.pp_loc end | _ -> error (NotAPredicate p) f.pp_loc end in r, freevars_form r | PPdistinct (args) -> Options.tool_req 1 "TR-Typing-Distinct$_F$"; let r = begin let te_args = List.map (type_term env) args in let lt_args = List.map (fun {c={tt_ty=t}} -> t) te_args in try let t = match lt_args with | t::_ -> t | [] -> error (WrongNumberofArgs "distinct") f.pp_loc in List.iter (Ty.unify t) lt_args; TFatom { c = TAdistinct te_args; annot=new_id () } with | Ty.TypeClash(t1,t2) -> error (Unification(t1,t2)) f.pp_loc end in r, freevars_form r | PPinfix ({pp_desc = PPinfix (_, (PPlt|PPle|PPgt|PPge|PPeq|PPneq), a)} as p, (PPlt | PPle | PPgt | PPge | PPeq | PPneq as r), b) -> Options.tool_req 1 "TR-Typing-OpComp$_F$"; let r = let q = { pp_desc = PPinfix (a, r, b); pp_loc = f.pp_loc } in let f1,_ = type_form env p in let f2,_ = type_form env q in TFop(OPand, [f1;f2]) in r, freevars_form r | PPinfix(t1, (PPeq | PPneq as op), t2) -> Options.tool_req 1 "TR-Typing-OpBin$_F$"; let r = let tt1 = type_term env t1 in let tt2 = type_term env t2 in try Ty.unify tt1.c.tt_ty tt2.c.tt_ty; match op with | PPeq -> TFatom {c = TAeq [tt1; tt2]; annot = new_id()} | PPneq -> TFatom {c = TAneq [tt1; tt2]; annot = new_id()} | _ -> assert false with Ty.TypeClash(t1,t2) -> error (Unification(t1,t2)) f.pp_loc in r, freevars_form r | PPinfix(t1, (PPlt | PPgt | PPge | PPle as op), t2) -> Options.tool_req 1 "TR-Typing-OpComp$_F$"; let r = let tt1 = type_term env t1 in let tt2 = type_term env t2 in try Ty.unify tt1.c.tt_ty tt2.c.tt_ty; let ty = Ty.shorten tt1.c.tt_ty in match ty with | Ty.Tint | Ty.Treal -> let top = match op with | PPlt -> TAlt [tt1; tt2] | PPgt -> TAlt [tt2; tt1] | PPle -> TAle [tt1; tt2] | PPge -> TAle [tt2; tt1] | PPeq -> TAeq [tt1; tt2] | PPneq -> TAneq [tt1; tt2] | _ -> assert false in TFatom {c = top; annot=new_id ()} | _ -> error (ShouldHaveTypeIntorReal ty) t1.pp_loc with Ty.TypeClash(t1,t2) -> error (Unification(t1,t2)) f.pp_loc in r, freevars_form r | PPinfix(f1,op ,f2) -> Options.tool_req 1 "TR-Typing-OpConnectors$_F$"; begin let f1,fv1 = type_form env f1 in let f2,fv2 = type_form env f2 in ((match op with | PPand -> TFop(OPand,[f1;f2]) | PPor -> TFop(OPor,[f1;f2]) | PPimplies -> TFop(OPimp,[f1;f2]) | PPiff -> TFop(OPiff,[f1;f2]) | _ -> assert false), Sy.union fv1 fv2) end | PPprefix(PPnot,f) -> Options.tool_req 1 "TR-Typing-OpNot$_F$"; let f, fv = type_form env f in TFop(OPnot,[f]),fv | PPif(f1,f2,f3) -> Options.tool_req 1 "TR-Typing-Ite$_F$"; let f1 = type_term env f1 in let f2,fv2 = type_form env f2 in let f3,fv3 = type_form env f3 in TFop(OPif f1,[f2;f3]), Sy.union fv2 fv3 | PPnamed(lbl,f) -> let f, fv = type_form env f in let lbl = Hstring.make lbl in TFnamed(lbl, f), fv | PPforall _ | PPexists _ -> let ty_vars, triggers, hyp, f' = match pp_desc with | PPforall(vs_ty,triggers,hyp,f') -> let ty_vars, triggers', hyp', f' = join_forall f' in vs_ty @ ty_vars, triggers@triggers', hyp @ hyp', f' | PPexists(vs_ty,triggers,hyp,f') -> let ty_vars, triggers', hyp', f' = join_exists f' in vs_ty @ ty_vars, triggers@triggers', hyp @ hyp', f' | _ -> assert false in let env' = List.fold_left (fun env (v, pp_ty) -> Env.add_var env [v] pp_ty f.pp_loc) env ty_vars in let f', fv = type_form env' f' in let ty_triggers = List.map (fun (tr, b) -> type_trigger in_theory env' tr, b) triggers in let qf_hyp = List.map (fun h -> fst (type_form env' h)) hyp in let upbvars = Env.list_of env in let bvars = List.fold_left (fun acc (v,_) -> let ty = Env.find env' v in if Sy.mem (fst ty) fv then ty :: acc else acc) [] ty_vars in let qf_form = { qf_upvars = upbvars ; qf_bvars = bvars ; qf_triggers = ty_triggers ; qf_hyp = qf_hyp; qf_form = f'} in (match pp_desc with | PPforall _ -> Options.tool_req 1 "TR-Typing-Forall$_F$"; TFforall qf_form | PPexists _ -> Options.tool_req 1 "TR-Typing-Exists$_F$"; TFexists qf_form | _ -> assert false), (List.fold_left (fun acc (l,_) -> Sy.remove l acc) fv bvars) | PPlet (var,t,f) -> Options.tool_req 1 "TR-Typing-Let$_F$"; let {c= { tt_ty = ttype }} as tt = type_term env t in let svar = Symbols.var var in let up = Env.list_of env in let env = {env with Env.var_map = MString.add var (svar, ttype) env.Env.var_map} in let f,fv = type_form env f in TFlet (up ,svar , tt, f), freevars_term (Sy.remove svar fv) tt (* Remove labels : *) | PPforall_named (vs_tys, trs, hyp, f) -> let vs_tys = List.map (fun (v, _, ty) -> v, ty) vs_tys in type_pp_desc (PPforall (vs_tys, trs, hyp, f)) | PPexists_named (vs_tys, trs, hyp, f) -> let vs_tys = List.map (fun (v, _, ty) -> v, ty) vs_tys in type_pp_desc (PPexists (vs_tys, trs, hyp, f)) | PPcheck _ | PPcut _ -> assert false | _ -> let te1 = type_term env f in let ty = te1.c.tt_ty in match ty with | Ty.Tbool -> let te2 = {c = {tt_desc=TTconst Ttrue;tt_ty=Ty.Tbool}; annot = new_id ()} in let r = TFatom {c = TAeq [te1;te2]; annot=new_id ()} in r, freevars_form r | _ -> error ShouldHaveTypeProp f.pp_loc in let form, vars = type_pp_desc f.pp_desc in {c = form; annot = new_id ()}, vars let make_rules loc f = match f.c with | TFforall {qf_bvars = vars; qf_form = {c = TFatom {c = TAeq [t1; t2]}}} -> {rwt_vars = vars; rwt_left = t1; rwt_right = t2} | TFatom {c = TAeq [t1; t2]} -> {rwt_vars = []; rwt_left = t1; rwt_right = t2} | _ -> error SyntaxError loc let fresh_var = let cpt = ref 0 in fun x -> incr cpt; ("_"^x^(string_of_int !cpt)) let rec no_alpha_renaming_b ((up, m) as s) f = match f.pp_desc with | PPvar x -> (try let y = MString.find x m in assert (String.compare x y <> 0); raise Exit with Not_found -> ()) | PPmapsTo(x, e) -> (try let y = MString.find x m in assert (String.compare x y <> 0); raise Exit with Not_found -> ()); no_alpha_renaming_b s e | PPapp(k, l) -> List.iter (no_alpha_renaming_b s) l | PPinInterval(e, _,_,_,_) -> no_alpha_renaming_b s e | PPdistinct l -> List.iter (no_alpha_renaming_b s) l | PPconst _ -> () | PPinfix(f1, op, f2) -> no_alpha_renaming_b s f1; no_alpha_renaming_b s f2 | PPprefix(op, f1) -> no_alpha_renaming_b s f1 | PPget(f1,f2) -> no_alpha_renaming_b s f1; no_alpha_renaming_b s f2 | PPset(f1, f2, f3) -> no_alpha_renaming_b s f1; no_alpha_renaming_b s f2; no_alpha_renaming_b s f3 | PPextract(f1, f2, f3) -> no_alpha_renaming_b s f1; no_alpha_renaming_b s f2; no_alpha_renaming_b s f3 | PPconcat(f1, f2) -> no_alpha_renaming_b s f1; no_alpha_renaming_b s f2 | PPif(f1, f2, f3) -> no_alpha_renaming_b s f1; no_alpha_renaming_b s f2; no_alpha_renaming_b s f3 | PPnamed(n, f1) -> no_alpha_renaming_b s f1 | PPdot(f1, a) -> no_alpha_renaming_b s f1 | PPrecord l -> List.iter (fun (_,e) -> no_alpha_renaming_b s e) l | PPwith(e, l) -> List.iter (fun (_,e) -> no_alpha_renaming_b s e) l; no_alpha_renaming_b s e | PPlet(x, f1, f2) -> no_alpha_renaming_b s f1; let s, x = if S.mem x up then let nx = fresh_var x in let m = MString.add x nx m in let up = S.add nx up in (up, m), nx else (S.add x up, m), x in no_alpha_renaming_b s f2 | PPcheck f' -> no_alpha_renaming_b s f' | PPcut f' -> no_alpha_renaming_b s f' | PPcast (f',ty) -> no_alpha_renaming_b s f' | PPforall(xs, trs, hyp, f1) -> let xs1, xs2 = List.partition (fun (x, _) -> S.mem x up) xs in let nv = List.map (fun (x, ty) -> fresh_var x, ty) xs1 in let m = List.fold_left2 (fun m (x, _) (nx, _) -> MString.add x nx m) m xs1 nv in let xs = nv @ xs2 in let up = List.fold_left (fun up (x, _) -> S.add x up) up xs in let s = (up, m) in List.iter (no_alpha_renaming_b s) hyp; no_alpha_renaming_b s f1; List.iter (fun (l, _) -> List.iter (no_alpha_renaming_b s) l) trs | PPforall_named (xs, trs, hyp, f1) -> let xs1, xs2 = List.partition (fun (x, _, _) -> S.mem x up) xs in let nv = List.map (fun (x, lbl, ty) -> fresh_var x, lbl, ty) xs1 in let m = List.fold_left2 (fun m (x, _, _) (nx, _, _) -> MString.add x nx m) m xs1 nv in let xs = nv @ xs2 in let up = List.fold_left (fun up (x, _, _) -> S.add x up) up xs in let s = (up, m) in List.iter (no_alpha_renaming_b s) hyp; no_alpha_renaming_b s f1; List.iter (fun (l, _) -> List.iter (no_alpha_renaming_b s) l) trs | PPexists(lx, trs, hyp, f1) -> let s, lx = List.fold_left (fun (s, lx) (x, _) -> if S.mem x up then let nx = fresh_var x in let m = MString.add x nx m in let up = S.add nx up in (up, m), nx :: lx else (S.add x up, m), x :: lx) (s, []) lx in no_alpha_renaming_b s f1; List.iter (no_alpha_renaming_b s) hyp; List.iter (fun (l, _) -> List.iter (no_alpha_renaming_b s) l) trs | PPexists_named (lx, trs, hyp, f1) -> let s, lx = List.fold_left (fun (s, lx) (x, _, _) -> if S.mem x up then let nx = fresh_var x in let m = MString.add x nx m in let up = S.add nx up in (up, m), nx :: lx else (S.add x up, m), x :: lx) (s, []) lx in no_alpha_renaming_b s f1; List.iter (no_alpha_renaming_b s) hyp; List.iter (fun (l, _) -> List.iter (no_alpha_renaming_b s) l) trs let rec alpha_renaming_b ((up, m) as s) f = match f.pp_desc with | PPvar x -> (try let y = MString.find x m in assert (String.compare x y <> 0); {f with pp_desc = PPvar y} with Not_found -> f) | PPmapsTo (x, e) -> let x' = try let y = MString.find x m in assert (String.compare x y <> 0); y with Not_found -> x in let e' = alpha_renaming_b s e in if x == x' && e == e' then f else {f with pp_desc = PPmapsTo(x', e')} | PPapp(k, l) -> let l2 = List.rev (List.rev_map (alpha_renaming_b s) l) in if List.for_all2 (fun a b -> a == b) l l2 then f else {f with pp_desc = PPapp(k, l2)} | PPinInterval (e,a,b,c,d) -> let e' = alpha_renaming_b s e in if e == e' then e else {f with pp_desc = PPinInterval(e', a,b,c,d)} | PPdistinct l -> let l2 = List.rev (List.rev_map (alpha_renaming_b s) l) in if List.for_all2 (fun a b -> a == b) l l2 then f else {f with pp_desc = PPdistinct l2} | PPconst _ -> f | PPinfix(f1, op, f2) -> let ff1 = alpha_renaming_b s f1 in let ff2 = alpha_renaming_b s f2 in if f1 == ff1 && f2 == ff2 then f else {f with pp_desc = PPinfix(ff1, op, ff2)} | PPprefix(op, f1) -> let ff1 = alpha_renaming_b s f1 in if f1 == ff1 then f else {f with pp_desc = PPprefix(op, ff1)} | PPget(f1,f2) -> let ff1 = alpha_renaming_b s f1 in let ff2 = alpha_renaming_b s f2 in if f1 == ff1 && f2 == ff2 then f else {f with pp_desc = PPget(ff1, ff2)} | PPset(f1, f2, f3) -> let ff1 = alpha_renaming_b s f1 in let ff2 = alpha_renaming_b s f2 in let ff3 = alpha_renaming_b s f3 in if f1 == ff1 && f2 == ff2 && f3 == ff3 then f else {f with pp_desc = PPset(ff1, ff2, ff3)} | PPextract(f1, f2, f3) -> let ff1 = alpha_renaming_b s f1 in let ff2 = alpha_renaming_b s f2 in let ff3 = alpha_renaming_b s f3 in if f1 == ff1 && f2 == ff2 && f3 == ff3 then f else {f with pp_desc = PPextract(ff1, ff2, ff3)} | PPconcat(f1, f2) -> let ff1 = alpha_renaming_b s f1 in let ff2 = alpha_renaming_b s f2 in if ff1 == f1 && ff2 == f2 then f else {f with pp_desc = PPconcat(ff1, ff2)} | PPif(f1, f2, f3) -> let ff1 = alpha_renaming_b s f1 in let ff2 = alpha_renaming_b s f2 in let ff3 = alpha_renaming_b s f3 in if f1 == ff1 && f2 == ff2 && f3 == ff3 then f else {f with pp_desc = PPif(ff1, ff2, ff3)} | PPnamed(n, f1) -> let ff1 = alpha_renaming_b s f1 in if f1 == ff1 then f else {f with pp_desc = PPnamed(n, ff1)} | PPdot(f1, a) -> let ff1 = alpha_renaming_b s f1 in if f1 == ff1 then f else {f with pp_desc = PPdot(ff1, a)} | PPrecord l -> let l2 = List.rev (List.rev_map (fun (a,e) -> a, alpha_renaming_b s e) l) in if List.for_all2 (fun a b -> a == b) l l2 then f else {f with pp_desc = PPrecord l2} | PPwith(e, l) -> let l2 = List.rev (List.rev_map (fun (a,e) -> a, alpha_renaming_b s e) l) in let ee = alpha_renaming_b s e in if List.for_all2 (fun a b -> a == b) l l2 && e == ee then f else {f with pp_desc = PPwith(ee, l2)} | PPlet(x, f1, f2) -> let ff1 = alpha_renaming_b s f1 in let s, x = if S.mem x up then let nx = fresh_var x in let m = MString.add x nx m in let up = S.add nx up in (up, m), nx else (S.add x up, m), x in let ff2 = alpha_renaming_b s f2 in if f1 == ff1 && f2 == ff2 then f else {f with pp_desc = PPlet(x, ff1, ff2)} | PPcheck f' -> let ff = alpha_renaming_b s f' in if f' == ff then f else {f with pp_desc = PPcheck ff} | PPcut f' -> let ff = alpha_renaming_b s f' in if f' == ff then f else {f with pp_desc = PPcut ff} | PPcast (f',ty) -> let ff = alpha_renaming_b s f' in if f' == ff then f else {f with pp_desc = PPcast (ff,ty)} | PPforall(xs, trs, hyp, f1) -> let xs1, xs2 = List.partition (fun (x, _) -> S.mem x up) xs in let nv = List.map (fun (x, ty) -> fresh_var x, ty) xs1 in let m = List.fold_left2 (fun m (x, _) (nx, _) -> MString.add x nx m) m xs1 nv in let xs = nv @ xs2 in let up = List.fold_left (fun up (x, _) -> S.add x up) up xs in let s = (up, m) in let ff1 = alpha_renaming_b s f1 in let trs2 = List.map (fun (l, tuser) -> List.map (alpha_renaming_b s) l, tuser) trs in let hyp2 = List.map (alpha_renaming_b s) hyp in if f1==ff1 && List.for_all2 (fun a b -> a==b) trs trs2 && List.for_all2 (fun a b -> a==b) hyp hyp2 then f else {f with pp_desc = PPforall(xs, trs2, hyp2, ff1)} | PPforall_named (xs, trs, hyp, f1) -> let xs1, xs2 = List.partition (fun (x, _, _) -> S.mem x up) xs in let nv = List.map (fun (x, lbl, ty) -> fresh_var x, lbl, ty) xs1 in let m = List.fold_left2 (fun m (x, _, _) (nx, _, _) -> MString.add x nx m) m xs1 nv in let xs = nv @ xs2 in let up = List.fold_left (fun up (x, _, _) -> S.add x up) up xs in let s = (up, m) in let ff1 = alpha_renaming_b s f1 in let trs2 = List.map (fun (l, tuser) -> List.map (alpha_renaming_b s) l, tuser) trs in let hyp2 = List.map (alpha_renaming_b s) hyp in if f1==ff1 && List.for_all2 (fun a b -> a==b) trs trs2 && List.for_all2 (fun a b -> a==b) hyp hyp2 then f else {f with pp_desc = PPforall_named (xs, trs2, hyp2, ff1)} | PPexists(lx, trs, hyp, f1) -> let s, lx = List.fold_left (fun (s, lx) (x, ty) -> if S.mem x up then let nx = fresh_var x in let m = MString.add x nx m in let up = S.add nx up in (up, m), (nx, ty) :: lx else (S.add x up, m), (x, ty) :: lx) (s, []) lx in let trs2 = List.map (fun (l, tuser) -> List.map (alpha_renaming_b s) l, tuser) trs in let ff1 = alpha_renaming_b s f1 in let hyp2 = List.map (alpha_renaming_b s) hyp in if f1==ff1 && List.for_all2 (fun a b -> a==b) trs trs2 && List.for_all2 (fun a b -> a==b) hyp hyp2 then f else {f with pp_desc = PPexists(lx, trs2, hyp2, ff1)} | PPexists_named (lx, trs, hyp, f1) -> let s, lx = List.fold_left (fun (s, lx) (x, lbl, ty) -> if S.mem x up then let nx = fresh_var x in let m = MString.add x nx m in let up = S.add nx up in (up, m), (nx, lbl, ty) :: lx else (S.add x up, m), (x, lbl, ty) :: lx) (s, []) lx in let ff1 = alpha_renaming_b s f1 in let trs2 = List.map (fun (l, tuser) -> List.map (alpha_renaming_b s) l, tuser) trs in let hyp2 = List.map (alpha_renaming_b s) hyp in if f1==ff1 && List.for_all2 (fun a b -> a==b) trs trs2 && List.for_all2 (fun a b -> a==b) hyp hyp2 then f else {f with pp_desc = PPexists_named (lx, trs2, hyp2, ff1)} let alpha_renaming_b s f = try no_alpha_renaming_b s f; f with Exit -> alpha_renaming_b s f let alpha_renaming = alpha_renaming_b (S.empty, MString.empty) let alpha_renaming_env env = let up = MString.fold (fun s _ up -> S.add s up) env.Env.logics S.empty in let up = MString.fold (fun s _ up -> S.add s up) env.Env.var_map up in alpha_renaming_b (up, MString.empty) let inv_infix = function | PPand -> PPor | PPor -> PPand | _ -> assert false let rec elim_toplevel_forall env bnot f = (* bnot = true : nombre impaire de not *) match f.pp_desc with | PPforall (lv, _, _, f) when bnot -> let env = List.fold_left (fun env (v, ty) -> Env.add_names env [v] ty f.pp_loc ) env lv in elim_toplevel_forall env bnot f | PPforall_named (lvb, _, _, f) when bnot-> let env = List.fold_left (fun env (v, lbl, ty) -> Env.add_names_lbl env [v, lbl] ty f.pp_loc ) env lvb in elim_toplevel_forall env bnot f | PPinfix (f1, PPand, f2) when not bnot -> let f1 , env = elim_toplevel_forall env false f1 in let f2 , env = elim_toplevel_forall env false (alpha_renaming_env env f2) in { f with pp_desc = PPinfix(f1, PPand , f2)}, env | PPinfix (f1, PPor, f2) when bnot -> let f1 , env = elim_toplevel_forall env true f1 in let f2 , env = elim_toplevel_forall env true (alpha_renaming_env env f2) in { f with pp_desc = PPinfix(f1, PPand , f2)}, env | PPinfix (f1, PPimplies, f2) when bnot -> let f1 , env = elim_toplevel_forall env false f1 in let f2 , env = elim_toplevel_forall env true (alpha_renaming_env env f2) in { f with pp_desc = PPinfix(f1,PPand,f2)}, env | PPprefix (PPnot, f) -> elim_toplevel_forall env (not bnot) f | _ when bnot -> { f with pp_desc = PPprefix (PPnot, f) }, env | _ -> f , env let rec intro_hypothesis env valid_mode f = match f.pp_desc with | PPinfix(f1,PPimplies,f2) when valid_mode -> let ((f1, env) as f1_env) = elim_toplevel_forall env (not valid_mode) f1 in let axioms, goal = intro_hypothesis env valid_mode (alpha_renaming_env env f2) in f1_env::axioms, goal | PPlet(var,{pp_desc=PPcast(t1,ty); pp_loc = ty_loc},f2) -> let env = Env.add_names env [var] ty ty_loc in let var = {pp_desc = PPvar var; pp_loc = f.pp_loc} in let feq = {pp_desc = PPinfix(var,PPeq,t1); pp_loc = f.pp_loc} in let axioms, goal = intro_hypothesis env valid_mode (alpha_renaming_env env f2) in (feq,env)::axioms, goal | PPforall (lv, _, _, f) when valid_mode -> let env = List.fold_left (fun env (v, ty) -> Env.add_names env [v] ty f.pp_loc ) env lv in intro_hypothesis env valid_mode f | PPexists (lv, _, _, f) when not valid_mode-> let env = List.fold_left (fun env (v, ty) -> Env.add_names env [v] ty f.pp_loc ) env lv in intro_hypothesis env valid_mode f | PPforall_named (lvb, _, _, f) when valid_mode -> let env = List.fold_left (fun env (v, lbl, ty) -> Env.add_names_lbl env [v, lbl] ty f.pp_loc ) env lvb in intro_hypothesis env valid_mode f | PPexists_named (lvb, _, _, f) when not valid_mode-> let env = List.fold_left (fun env (v, lbl, ty) -> Env.add_names_lbl env [v, lbl] ty f.pp_loc ) env lvb in intro_hypothesis env valid_mode f | _ -> let f_env = elim_toplevel_forall env valid_mode f in [] , f_env let fresh_hypothesis_name = let cpt = ref 0 in fun sort -> incr cpt; match sort with | Thm -> "@H"^(string_of_int !cpt) | _ -> "@L"^(string_of_int !cpt) let fresh_check_name = let cpt = ref 0 in fun () -> incr cpt; "check_"^(string_of_int !cpt) let fresh_cut_name = let cpt = ref 0 in fun () -> incr cpt; "cut_"^(string_of_int !cpt) let check_duplicate_params l = let rec loop l acc = match l with | [] -> () | (loc,x,_)::rem -> if List.mem x acc then error (ClashParam x) loc else loop rem (x::acc) in loop l [] let rec make_pred loc trs f = function [] -> f | [x,t] -> { pp_desc = PPforall([x,t],trs,[],f) ; pp_loc = loc } | (x,t)::l -> { pp_desc = PPforall([x,t],[],[],(make_pred loc trs f l)) ; pp_loc = loc } let rec max_terms acc f = match f.pp_desc with | PPinfix(f1, ( PPand | PPor | PPimplies | PPiff ), f2) | PPconcat(f1, f2) -> let acc = max_terms acc f1 in max_terms acc f2 | PPforall(_, _, _, _) | PPexists(_, _, _, _) | PPforall_named(_, _, _, _) | PPexists_named(_, _, _, _) | PPvar _ | PPlet(_, _, _) | PPinfix(_, _, _) -> raise Exit | PPif(f1, f2, f3) -> let acc = max_terms acc f1 in let acc = max_terms acc f2 in max_terms acc f3 | PPextract(f1, _, _) | PPprefix(_, f1) | PPnamed(_, f1) -> max_terms acc f1 | _ -> f::acc let max_terms f = try max_terms [] f with Exit -> [] let rec mono_term {c = {tt_ty=tt_ty; tt_desc=tt_desc}; annot = id} = let tt_desc = match tt_desc with | TTconst _ | TTvar _ -> tt_desc | TTinfix (t1, sy, t2) -> TTinfix(mono_term t1, sy, mono_term t2) | TTprefix (sy,t) -> TTprefix(sy, mono_term t) | TTapp (sy,tl) -> TTapp (sy, List.map mono_term tl) | TTinInterval (e, a,b,c,d) -> TTinInterval(mono_term e, a,b,c,d) | TTmapsTo (x, e) -> TTmapsTo(x, mono_term e) | TTget (t1,t2) -> TTget (mono_term t1, mono_term t2) | TTset (t1,t2,t3) -> TTset(mono_term t1, mono_term t2, mono_term t3) | TTextract (t1,t2,t3) -> TTextract(mono_term t1, mono_term t2, mono_term t3) | TTconcat (t1,t2)-> TTconcat (mono_term t1, mono_term t2) | TTdot (t1, a) -> TTdot (mono_term t1, a) | TTrecord lbs -> TTrecord (List.map (fun (x, t) -> x, mono_term t) lbs) | TTlet (sy,t1,t2)-> TTlet (sy, mono_term t1, mono_term t2) | TTnamed (lbl, t)-> TTnamed (lbl, mono_term t) in { c = {tt_ty = Ty.monomorphize tt_ty; tt_desc=tt_desc}; annot = id} let monomorphize_atom tat = let c = match tat.c with | TAtrue | TAfalse -> tat.c | TAeq tl -> TAeq (List.map mono_term tl) | TAneq tl -> TAneq (List.map mono_term tl) | TAle tl -> TAle (List.map mono_term tl) | TAlt tl -> TAlt (List.map mono_term tl) | TAdistinct tl -> TAdistinct (List.map mono_term tl) | TApred t -> TApred (mono_term t) | TAbuilt (hs, tl) -> TAbuilt(hs, List.map mono_term tl) in { tat with c = c } let monomorphize_var (s,ty) = s, Ty.monomorphize ty let rec monomorphize_form tf = let c = match tf.c with | TFatom tat -> TFatom (monomorphize_atom tat) | TFop (oplogic , tfl) -> TFop(oplogic, List.map monomorphize_form tfl) | TFforall qf -> TFforall { qf_bvars = List.map monomorphize_var qf.qf_bvars; qf_upvars = List.map monomorphize_var qf.qf_upvars; qf_hyp = List.map monomorphize_form qf.qf_hyp; qf_form = monomorphize_form qf.qf_form; qf_triggers = List.map (fun (l, b) -> List.map mono_term l, b) qf.qf_triggers} | TFexists qf -> TFexists { qf_bvars = List.map monomorphize_var qf.qf_bvars; qf_upvars = List.map monomorphize_var qf.qf_upvars; qf_hyp = List.map monomorphize_form qf.qf_hyp; qf_form = monomorphize_form qf.qf_form; qf_triggers = List.map (fun (l, b) -> List.map mono_term l, b) qf.qf_triggers} | TFlet (l, sy, tt, tf) -> let l = List.map monomorphize_var l in TFlet(l,sy, mono_term tt, monomorphize_form tf) | TFnamed (hs,tf) -> TFnamed(hs, monomorphize_form tf) in { tf with c = c } let axioms_of_rules keep_triggers loc name lf acc env = let acc = List.fold_left (fun acc (f, _) -> let f = Triggers.make keep_triggers false f in let name = (Hstring.fresh_string ()) ^ "_" ^ name in let td = {c = TAxiom(loc,name,Default, f); annot = new_id () } in (td, env)::acc ) acc lf in acc, env let type_hypothesis keep_triggers acc env_f loc sort f = let f,_ = type_form env_f f in let f = monomorphize_form f in let f = Triggers.make keep_triggers false f in let td = {c = TAxiom(loc, fresh_hypothesis_name sort,Default, f); annot = new_id () } in (td, env_f)::acc let type_goal keep_triggers acc env_g loc sort n goal = let goal, _ = type_form env_g goal in let goal = monomorphize_form goal in let goal = Triggers.make keep_triggers true goal in let td = {c = TGoal(loc, sort, n, goal); annot = new_id () } in (td, env_g)::acc let rec type_and_intro_goal keep_triggers acc env loc sort n f = let b = (* smtfile() || smt2file() || satmode()*) false in let axioms, (goal, env_g) = intro_hypothesis env (not b) f in let loc = f.pp_loc in let acc = List.fold_left (fun acc (f, env_f) -> match f.pp_desc with | PPcut f -> let acc = type_and_intro_goal keep_triggers acc env_f loc Cut (fresh_cut_name ()) f in type_hypothesis keep_triggers acc env_f loc sort f | PPcheck f -> type_and_intro_goal keep_triggers acc env_f loc Check (fresh_check_name ()) f | _ -> type_hypothesis keep_triggers acc env_f loc sort f ) acc axioms in type_goal keep_triggers acc env_g loc sort n goal let type_one_th_decl keep_triggers env e = (* NB: we always keep triggers for axioms of theories *) match e with | Axiom(loc,name,ax_kd,f) -> let f,_ = type_form ~in_theory:true env f in let f = Triggers.make (*keep_triggers=*) true false f in {c = TAxiom (loc,name,ax_kd,f); annot = new_id ()} | Theory (loc, _, _, _) | Logic (loc, _, _, _) | Rewriting(loc, _, _) | Goal(loc, _, _) | Predicate_def(loc,_,_,_) | Function_def(loc,_,_,_,_) | TypeDecl(loc, _, _, _) -> error WrongDeclInTheory loc let type_decl keep_triggers (acc, env) d = Types.to_tyvars := MString.empty; try match d with | Theory (loc, name, ext, l) -> Options.tool_req 1 "TR-Typing-TheoryDecl$_F$"; let tl = List.map (type_one_th_decl keep_triggers env) l in let ext = Typed.th_ext_of_string ext loc in let td = {c = TTheory(loc, name, ext, tl); annot = new_id () } in (td, env)::acc, env | Logic (loc, ac, lp, pp_ty) -> Options.tool_req 1 "TR-Typing-LogicFun$_F$"; let env' = Env.add_logics env ac lp pp_ty loc in let lp = List.map fst lp in let td = {c = TLogic(loc,lp,pp_ty); annot = new_id () } in (td, env)::acc, env' | Axiom(loc,name,ax_kd,f) -> Options.tool_req 1 "TR-Typing-AxiomDecl$_F$"; let f, _ = type_form env f in let f = Triggers.make keep_triggers false f in let td = {c = TAxiom(loc,name,ax_kd,f); annot = new_id () } in (td, env)::acc, env | Rewriting(loc, name, lr) -> let lf = List.map (type_form env) lr in if Options.rewriting () then let rules = List.map (fun (f,_) -> make_rules loc f) lf in let td = {c = TRewriting(loc, name, rules); annot = new_id () } in (td, env)::acc, env else axioms_of_rules keep_triggers loc name lf acc env | Goal(loc, n, f) -> Options.tool_req 1 "TR-Typing-GoalDecl$_F$"; (*let f = move_up f in*) let f = alpha_renaming_env env f in type_and_intro_goal keep_triggers acc env loc Thm n f, env | Predicate_def(loc,n,l,e) | Function_def(loc,n,l,_,e) -> check_duplicate_params l; let ty = let l = List.map (fun (_,_,x) -> x) l in match d with Function_def(_,_,_,t,_) -> PFunction(l,t) | _ -> PPredicate l in let l = List.map (fun (_,x,t) -> (x,t)) l in let env = Env.add_logics env Symbols.Other [n] ty loc in (* TODO *) let n = fst n in let lvar = List.map (fun (x,_) -> {pp_desc=PPvar x;pp_loc=loc}) l in let p = {pp_desc=PPapp(n,lvar) ; pp_loc=loc } in let infix = match d with Function_def _ -> PPeq | _ -> PPiff in let f = { pp_desc = PPinfix(p,infix,e) ; pp_loc = loc } in (* le trigger [[p]] ne permet pas de replier la definition, donc on calcule les termes maximaux de la definition pour laisser une possibilite de replier *) let trs = max_terms e in let f = make_pred loc [[p], false ; trs, false] f l in let f,_ = type_form env f in let f = Triggers.make keep_triggers false f in let td = match d with | Function_def(_,_,_,t,_) -> Options.tool_req 1 "TR-Typing-LogicFun$_F$"; TFunction_def(loc,n,l,t,f) | _ -> Options.tool_req 1 "TR-Typing-LogicPred$_F$"; TPredicate_def(loc,n,l,f) in let td_a = { c = td; annot=new_id () } in (td_a, env)::acc, env | TypeDecl(loc, ls, s, body) -> Options.tool_req 1 "TR-Typing-TypeDecl$_F$"; let env1 = Env.add_type_decl env ls s body loc in let td1 = TTypeDecl(loc, ls, s, body) in let td1_a = { c = td1; annot=new_id () } in let tls = List.map (fun s -> PPTvarid (s,loc)) ls in let ty = PFunction([], PPTexternal(tls, s, loc)) in match body with | Enum lc -> let lcl = List.map (fun c -> c, "") lc in (* TODO change this *) let env2 = Env.add_logics env1 Symbols.Constructor lcl ty loc in let td2 = TLogic(loc, lc, ty) in let td2_a = { c = td2; annot=new_id () } in (td1_a, env1)::(td2_a,env2)::acc, env2 | _ -> (td1_a, env1)::acc, env1 with Warning(e,loc) -> Loc.report std_formatter loc; acc, env let file keep_triggers env ld = let ltd, env = List.fold_left (fun acc d -> type_decl keep_triggers acc d) ([], env) ld in List.rev ltd, env let is_local_hyp s = try Pervasives.(=) (String.sub s 0 2) "@L" with Invalid_argument _ -> false let is_global_hyp s = try Pervasives.(=) (String.sub s 0 2) "@H" with Invalid_argument _ -> false let split_goals l = let _, _, _, ret = List.fold_left (fun (ctx, global_hyp, local_hyp, ret) ( (td, env) as x) -> match td.c with | TGoal (_, (Check | Cut), _, _) -> ctx, global_hyp, [], (x::(local_hyp@global_hyp@ctx))::ret | TGoal (_, _, _, _) -> ctx, [], [], (x::(local_hyp@global_hyp@ctx))::ret | TAxiom (_, s, _, _) when is_global_hyp s -> ctx, x::global_hyp, local_hyp, ret | TAxiom (_, s, _, _) when is_local_hyp s -> ctx, global_hyp, x::local_hyp, ret | _ -> x::ctx, global_hyp, local_hyp, ret ) ([],[],[],[]) l in List.rev_map List.rev ret let term env vars t = let vmap = List.fold_left (fun m (s,ty)-> let str = Symbols.to_string_clean s in MString.add str (s,ty) m ) env.Env.var_map vars in let env = { env with Env.var_map = vmap } in type_term env t type env = Env.t let empty_env = Env.empty alt-ergo-free-2.0.0/lib/frontend/cnf.ml0000664000175000017500000003417513430774474015454 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Options open Format open Typed open Commands module T = Term module F = Formula module A = Literal module Sy = Symbols let ale = Hstring.make "<=" let alt = Hstring.make "<" [@ocaml.ppwarning "TODO: Change Symbols.Float to store FP numeral \ constants (eg, <24, -149> for single) instead of having terms"] let make_adequate_app s l ty = let open Fpa_rounding in match s with | Sy.Name (hs, Sy.Other) when Options.use_fpa() -> let s, l = match Hstring.view hs, l with | "float", [_;_;_;_] -> Sy.Op Sy.Float, l | "float32", [_;_;] -> Sy.Op Sy.Float,(T.int "24")::(T.int "149")::l | "float32d", [_] -> Sy.Op Sy.Float, (T.int "24"):: (T.int "149"):: _NearestTiesToEven__rounding_mode :: l | "float64", [_;_;] -> Sy.Op Sy.Float,(T.int "53")::(T.int "1074")::l | "float64d", [_] -> Sy.Op Sy.Float, (T.int "53"):: (T.int "1074"):: _NearestTiesToEven__rounding_mode :: l | "integer_round", [_;_] -> Sy.Op Sy.Integer_round, l | "fixed", [_;_;_;_] -> Sy.Op Sy.Fixed, l | "sqrt_real", [_] -> Sy.Op Sy.Sqrt_real, l | "sqrt_real_default", [_] -> Sy.Op Sy.Sqrt_real_default, l | "sqrt_real_excess", [_] -> Sy.Op Sy.Sqrt_real_excess, l | "abs_int", [_] -> Sy.Op Sy.Abs_int, l | "abs_real", [_] -> Sy.Op Sy.Abs_real, l | "real_of_int", [_] -> Sy.Op Sy.Real_of_int, l | "int_floor", [_] -> Sy.Op Sy.Int_floor, l | "int_ceil", [_] -> Sy.Op Sy.Int_ceil, l | "max_real", [_;_] -> Sy.Op Sy.Max_real, l | "max_int", [_;_] -> Sy.Op Sy.Max_int, l | "min_real", [_;_] -> Sy.Op Sy.Min_real, l | "min_int", [_;_] -> Sy.Op Sy.Min_int, l | "integer_log2", [_] -> Sy.Op Sy.Integer_log2, l | "pow_real_int", [_;_] -> Sy.Op Sy.Pow_real_int, l | "pow_real_real", [_;_] -> Sy.Op Sy.Pow_real_real, l (* should not happend thanks to well typedness *) | ("float" | "float32" | "float32d" | "float64" | "float64d" | "integer_round" | "fixed" | "sqrt_real" | "abs_int" | "abs_real" | "real_of_int" | "int_floor" | "int_ceil" | "max_real" | "max_int" | "min_real" | "min_int" | "integer_log2" | "power_of"), _ -> assert false | _ -> s, l in T.make s l ty | _ -> T.make s l ty let varset_of_list = List.fold_left (fun acc (s,ty) -> Term.Set.add (Term.make s [] (Ty.shorten ty)) acc) Term.Set.empty let bound_of_term (t: T.t) = let open Symbols in let {T.f=f; ty=ty; xs=xs} = T.view t in assert (xs == []); match f with | Var hs | Int hs | Real hs -> hs, ty | Name _ | True | False | Void | Bitv _ | Op _ | In _ | MapsTo _ -> assert false let rec make_term {c = { tt_ty = ty; tt_desc = tt }} = let ty = Ty.shorten ty in match tt with | TTconst Ttrue -> T.vrai | TTconst Tfalse -> T.faux | TTconst Tvoid -> T.void | TTconst (Tint i) -> T.int i | TTconst (Treal n) -> T.real (Num.string_of_num n) | TTconst (Tbitv bt) -> T.bitv bt ty | TTvar s -> T.make s [] ty | TTapp (s, l) -> make_adequate_app s (List.map make_term l) ty | TTinInterval (e, a, b, c, d) -> assert (ty == Ty.Tbool); let b, ty_b = bound_of_term (make_term b) in let c, ty_c = bound_of_term (make_term c) in let lb = Symbols.mk_bound b ty_b ~is_open:a ~is_lower:true in let ub = Symbols.mk_bound c ty_c ~is_open:d ~is_lower:false in T.make (Symbols.mk_in lb ub) [make_term e] ty | TTmapsTo (x, e) -> assert (ty == Ty.Tbool); T.make (Symbols.mk_maps_to x) [make_term e] ty | TTinfix (t1, s, t2) -> T.make s [make_term t1;make_term t2] ty | TTprefix ((Sy.Op Sy.Minus) as s, n) -> let t1 = if ty == Ty.Tint then T.int "0" else T.real "0" in T.make s [t1; make_term n] ty | TTprefix _ -> assert false | TTget (t1, t2) -> T.make (Sy.Op Sy.Get) [make_term t1; make_term t2] ty | TTset (t1, t2, t3) -> let t1 = make_term t1 in let t2 = make_term t2 in let t3 = make_term t3 in T.make (Sy.Op Sy.Set) [t1; t2; t3] ty | TTextract (t1, t2, t3) -> let t1 = make_term t1 in let t2 = make_term t2 in let t3 = make_term t3 in T.make (Sy.Op Sy.Extract) [t1; t2; t3] ty | TTconcat (t1, t2) -> T.make (Sy.Op Sy.Concat) [make_term t1; make_term t2] ty | TTdot (t, s) -> T.make (Sy.Op (Sy.Access s)) [make_term t] ty | TTrecord lbs -> let lbs = List.map (fun (_, t) -> make_term t) lbs in T.make (Sy.Op Sy.Record) lbs ty | TTlet (s, t1, t2) -> let t1 = make_term t1 in let subst = Sy.Map.add s t1 Sy.Map.empty, Ty.esubst in let t2 = make_term t2 in T.apply_subst subst t2 | TTnamed(lbl, t) -> let t = make_term t in T.add_label lbl t; t let make_trigger hyp (e, from_user) = let content, guard = match e with | [{c={ tt_desc = TTapp(s, t1::t2::l)}}] when Sy.equal s Sy.fake_eq -> let trs = List.filter (fun t -> not (List.mem t l)) [t1; t2] in let trs = List.map make_term trs in let lit = A.LT.mk_eq (make_term t1) (make_term t2) in trs, Some lit | [{c={ tt_desc = TTapp(s, t1::t2::l) } }] when Sy.equal s Sy.fake_neq -> let trs = List.filter (fun t -> not (List.mem t l)) [t1; t2] in let trs = List.map make_term trs in let lit = A.LT.mk_distinct false [make_term t1; make_term t2] in trs, Some lit | [{c={ tt_desc = TTapp(s, t1::t2::l) } }] when Sy.equal s Sy.fake_le -> let trs = List.filter (fun t -> not (List.mem t l)) [t1; t2] in let trs = List.map make_term trs in let lit = A.LT.mk_builtin true ale [make_term t1; make_term t2] in trs, Some lit | [{c={ tt_desc = TTapp(s, t1::t2::l) } }] when Sy.equal s Sy.fake_lt -> let trs = List.filter (fun t -> not (List.mem t l)) [t1; t2] in let trs = List.map make_term trs in let lit = A.LT.mk_builtin true alt [make_term t1; make_term t2] in trs, Some lit | lt -> List.map make_term lt, None in let depth = List.fold_left (fun z t -> max z (T.view t).T.depth) 0 content in { F.content ; guard ; depth; semantic = []; (* will be set by theories *) hyp; from_user; } let make_form name_base f loc = let name_tag = ref 0 in let rec make_form toplevel acc c id = match c with | TFatom a -> let a , lit = match a.c with | TAtrue -> A.LT.vrai , A.LT.vrai::acc | TAfalse -> A.LT.faux , A.LT.faux::acc | TAeq [t1;t2] -> let lit = A.LT.mk_eq (make_term t1) (make_term t2) in lit , lit::acc | TApred t -> let lit = A.LT.mk_pred (make_term t) false in lit , lit::acc | TAneq lt | TAdistinct lt -> let lt = List.map make_term lt in let lit = A.LT.mk_distinct false lt in lit , lit::acc | TAle [t1;t2] -> let lit = A.LT.mk_builtin true ale [make_term t1;make_term t2] in lit , lit::acc | TAlt [t1;t2] -> begin match t1.c.tt_ty with | Ty.Tint -> let one = {c = {tt_ty = Ty.Tint; tt_desc = TTconst(Tint "1")}; annot = t1.annot} in let tt2 = T.make (Sy.Op Sy.Minus) [make_term t2; make_term one] Ty.Tint in let lit = A.LT.mk_builtin true ale [make_term t1; tt2] in lit , lit::acc | _ -> let lit = A.LT.mk_builtin true alt [make_term t1; make_term t2] in lit, lit::acc end | TAbuilt(n,lt) -> let lit = A.LT.mk_builtin true n (List.map make_term lt) in lit , lit::acc | _ -> assert false in F.mk_lit a id, lit | TFop(((OPand | OPor) as op),[f1;f2]) -> let ff1 , lit1 = make_form false acc f1.c f1.annot in let ff2 , lit2 = make_form false lit1 f2.c f2.annot in let mkop = match op with | OPand -> F.mk_and ff1 ff2 false id | _ -> F.mk_or ff1 ff2 false id in mkop , lit2 | TFop(OPimp,[f1;f2]) -> let ff1 , _ = make_form false acc f1.c f1.annot in let ff2 , lit = make_form false acc f2.c f2.annot in F.mk_imp ff1 ff2 id, lit | TFop(OPnot,[f]) -> let ff , lit = make_form false acc f.c f.annot in F.mk_not ff , lit | TFop(OPif t,[f2;f3]) -> let tt = make_term t in let ff2 , lit2 = make_form false acc f2.c f2.annot in let ff3 , lit3 = make_form false lit2 f3.c f3.annot in F.mk_if tt ff2 ff3 id, lit3 | TFop(OPiff,[f1;f2]) -> let ff1 , lit1 = make_form false acc f1.c f1.annot in let ff2 , lit2 = make_form false lit1 f2.c f2.annot in F.mk_iff ff1 ff2 id, lit2 | (TFforall qf | TFexists qf) as f -> let name = if !name_tag = 0 then name_base else sprintf "#%s#sub-%d" name_base !name_tag in incr name_tag; let qvars = varset_of_list qf.qf_bvars in let binders = F.mk_binders qvars in (*let upvars = varset_of_list qf.qf_upvars in*) let hyp = List.map (fun f -> fst (make_form false [] f.c f.annot)) qf.qf_hyp in let trs = List.map (make_trigger hyp) qf.qf_triggers in let ff , lit = make_form false acc qf.qf_form.c qf.qf_form.annot in begin match f with | TFforall _ -> F.mk_forall name loc binders trs ff id None, lit | TFexists _ -> if toplevel && not (Ty.Set.is_empty (F.type_variables ff)) then (* If there is type variables in a toplevel exists: 1 - we add a forall quantification without term variables (ie. only with type variables) 2 - we keep the triggers of 'exists' to try to instantiate type variables with these triggers as guards *) let nm = sprintf "#%s#sub-%d" name_base 0 in let gg = F.mk_exists nm loc binders trs ff id None in F.mk_forall name loc Symbols.Map.empty trs gg id None, lit else F.mk_exists name loc binders trs ff id None, lit | _ -> assert false end | TFlet(up,lvar,lterm,lf) -> let ff, lit = make_form false acc lf.c lf.annot in F.mk_let (varset_of_list up) lvar (make_term lterm) ff id, lit | TFnamed(lbl, f) -> let ff, lit = make_form false acc f.c f.annot in F.add_label lbl ff; ff, lit | _ -> assert false in make_form true [] f.c f.annot let push_assume queue f name loc match_flag = let ff , _ = make_form name f loc in Queue.push {st_decl=Assume(name, ff, match_flag) ; st_loc=loc} queue let push_preddef queue f name loc match_flag = let ff , _ = make_form name f loc in Queue.push {st_decl=PredDef (ff, name) ; st_loc=loc} queue let push_query queue n f loc sort = let ff, lits = make_form "" f loc in Queue.push {st_decl=Query(n, ff, lits, sort) ; st_loc=loc} queue let make_rule ({rwt_left = t1; rwt_right = t2} as r) = { r with rwt_left = make_term t1; rwt_right = make_term t2 } let push_theory queue l th_name extends loc b = List.iter (fun e -> let loc, name, f, axiom_kind = match e.c with | TAxiom (loc, name, ax_kd, f) -> loc, name, f, ax_kd | _ -> assert false in let th_form, _ = make_form name f loc in let th_elt = {th_name; axiom_kind; extends; th_form} in Queue.push {st_decl=ThAssume th_elt ; st_loc=loc} queue )l let make l = let queue = Queue.create () in List.iter (fun (d,b) -> match d.c with | TTheory(loc, name, ext, l) -> push_theory queue l name ext loc b | TAxiom(loc, name, Parsed.Default, f) -> push_assume queue f name loc b | TAxiom(loc, name, Parsed.Propagator, f) -> assert false | TRewriting(loc, name, lr) -> Queue.push {st_decl=RwtDef(List.map make_rule lr); st_loc=loc} queue | TGoal(loc, sort, n, f) -> push_query queue n f loc sort (*| TPredicate_def(loc, n, [], f) -> push_preddef queue f n loc b*) | TPredicate_def(loc, n, _, f) -> push_preddef queue f n loc b | TFunction_def(loc, n, _, _, f) -> push_assume queue f n loc b | TTypeDecl _ | TLogic _ -> ()) l; queue alt-ergo-free-2.0.0/lib/frontend/frontend.ml0000664000175000017500000002017513430774474016520 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Typed open Commands open Lexing open Format open Options module type S = sig type sat_env type output = Unsat of Explanation.t | Inconsistent | Sat of sat_env | Unknown of sat_env val process_decl: (Commands.sat_tdecl -> output -> int64 -> unit) -> sat_env * bool * Explanation.t -> Commands.sat_tdecl -> sat_env * bool * Explanation.t val typecheck_file : Parsed.file -> ((int tdecl, int) annoted * Typechecker.env) list list val print_status : Commands.sat_tdecl -> output -> int64 -> unit end module Make(SAT : Sat_solver_sig.S) : S with type sat_env = SAT.t = struct type sat_env = SAT.t type output = Unsat of Explanation.t | Inconsistent | Sat of sat_env | Unknown of sat_env let check_produced_proof dep = if verbose () then fprintf fmt "checking the proof:\n-------------------\n%a@." Explanation.print_proof dep; try let pb = Formula.Set.elements (Explanation.formulas_of dep) in let env = List.fold_left (fun env f -> SAT.assume env {Formula.f=f; origin_name = ""; gdist = -1; hdist = -1; trigger_depth = max_int; nb_reductions = 0; age=0; lem=None; mf=false; gf=false; from_terms = []; theory_elim = true; } ) (SAT.empty ()) pb in ignore (SAT.unsat env {Formula.f=Formula.vrai; origin_name = ""; gdist = -1; hdist = -1; trigger_depth = max_int; nb_reductions = 0; age=0; lem=None; mf=false; gf=false; from_terms = []; theory_elim = true; }); fprintf fmt "Checking produced proof failed!@."; fprintf fmt "this may be due to a bug.@."; exit 1 with | SAT.Unsat _ -> () | (SAT.Sat _ | SAT.I_dont_know _) as e -> raise e let do_save_used_context env dep = if not (Options.js_mode ()) then let used, unused = SAT.retrieve_used_context env dep in let f = Options.get_used_context_file () in let cout = open_out f in List.iter (fun f -> match Formula.view f with | Formula.Lemma {Formula.name=name} -> output_string cout (sprintf "%s\n" name) | _ -> assert false ) used; close_out cout let process_decl print_status (env, consistent, dep) d = try match d.st_decl with | Assume(n, f, mf) -> let hdist = try if Char.equal '@' n.[0] then 0 else -1 with _ -> -1 in if consistent then SAT.assume env {Formula.f=f; origin_name = n; gdist = -1; hdist = hdist; trigger_depth = max_int; nb_reductions = 0; age=0; lem=None; mf=mf; gf=false; from_terms = []; theory_elim = true; }, consistent, dep else env, consistent, dep | PredDef (f, name) -> SAT.pred_def env f name d.st_loc, consistent, dep | RwtDef r -> assert false | Query(n, f, lits, sort) -> let dep = if consistent then let dep' = SAT.unsat env {Formula.f=f; origin_name = n; hdist = -1; gdist = 0; trigger_depth = max_int; nb_reductions = 0; age=0; lem=None; mf=(sort != Check); gf=true; from_terms = []; theory_elim = true; } in Explanation.union dep' dep else dep in if debug_proof () then check_produced_proof dep; if save_used_context () then do_save_used_context env dep; print_status d (Unsat dep) (SAT.get_steps ()); env, consistent, dep | ThAssume th_elt -> if consistent then let env = SAT.assume_th_elt env th_elt in env, consistent, dep else env, consistent, dep with | SAT.Sat t -> print_status d (Sat t) (SAT.get_steps ()); if model () then SAT.print_model ~header:true std_formatter t; env , consistent, dep | SAT.Unsat dep' -> let dep = Explanation.union dep dep' in if debug_proof () then check_produced_proof dep; print_status d Inconsistent (SAT.get_steps ()); env , false, dep | SAT.I_dont_know t -> print_status d (Unknown t) (SAT.get_steps ()); if model () then SAT.print_model ~header:true std_formatter t; env , consistent, dep let typecheck_file (pfile : Parsed.file) = try let ltd, typ_env = Typechecker.file false Typechecker.empty_env pfile in let d = Typechecker.split_goals ltd in if type_only () then exit 0; d with | Errors.Error(e,l) -> Loc.report err_formatter l; eprintf "typing error: %a\n@." Errors.report e; exit 1 let print_status d status steps = let time = Time.value() in let loc = d.st_loc in match status with | Unsat dep -> if js_mode () then printf "# [answer] Valid (%2.4f seconds) (%Ld steps)@." time steps else begin printf "%aValid (%2.4f) (%Ld steps)@." Loc.report loc time steps; if proof () && not (debug_proof ()) && not (save_used_context ()) then printf "Proof:\n%a@." Explanation.print_proof dep end | Inconsistent -> if js_mode () then printf "# [message] Inconsistent assumption \n@." else eprintf "%aInconsistent assumption@." Loc.report loc; | Unknown t | Sat t -> if js_mode () then printf "# [answer] unknown (%2.4f seconds) (%Ld steps)@." time steps else printf "%aI don't know (%2.4f) (%Ld steps)@." Loc.report loc time steps end alt-ergo-free-2.0.0/lib/frontend/cnf.mli0000664000175000017500000000435413430774474015621 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) val make : ((int Typed.tdecl, int) Typed.annoted * bool) list -> Commands.sat_tdecl Queue.t alt-ergo-free-2.0.0/lib/frontend/.merlin0000664000175000017500000000000413430774474015623 0ustar mimiREC alt-ergo-free-2.0.0/lib/parsing/0000775000175000017500000000000013430774474014166 5ustar mimialt-ergo-free-2.0.0/lib/parsing/.merlin0000664000175000017500000000000413430774474015447 0ustar mimiREC alt-ergo-free-2.0.0/lib/structures/0000755000175000017500000000000013430774474014744 5ustar mimialt-ergo-free-2.0.0/lib/structures/commands.ml0000664000175000017500000000520413430774474017102 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Format open Parsed open Typed type th_elt = { th_name : string; th_form : Formula.t; extends : Typed.theories_extensions; axiom_kind : axiom_kind; } (* Sat entry *) type sat_decl_aux = | Assume of string * Formula.t * bool | PredDef of Formula.t * string (*name of the predicate*) | RwtDef of (Term.t rwt_rule) list | Query of string * Formula.t * Literal.LT.t list * goal_sort | ThAssume of th_elt type sat_tdecl = { st_loc : Loc.t; st_decl : sat_decl_aux } alt-ergo-free-2.0.0/lib/structures/fpa_rounding.mli0000664000175000017500000000473613430774474020136 0ustar mimi(******************************************************************************) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the license indicated *) (* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) (* present, please contact us to clarify licensing. *) (* *) (******************************************************************************) val is_rounding_mode : Term.t -> bool val fpa_rounding_mode : Ty.t (* why3/standard rounding modes*) val _NearestTiesToEven__rounding_mode : Term.t (** ne in Gappa: to nearest, tie breaking to even mantissas*) val _ToZero__rounding_mode : Term.t (** zr in Gappa: toward zero *) val _Up__rounding_mode : Term.t (** up in Gappa: toward plus infinity *) val _Down__rounding_mode : Term.t (** dn in Gappa: toward minus infinity *) val _NearestTiesToAway__rounding_mode : Term.t (** na : to nearest, tie breaking away from zero *) (* additional Gappa rounding modes *) val _Aw__rounding_mode : Term.t (** aw in Gappa: away from zero **) val _Od__rounding_mode : Term.t (** od in Gappa: to odd mantissas *) val _No__rounding_mode : Term.t (** no in Gappa: to nearest, tie breaking to odd mantissas *) val _Nz__rounding_mode : Term.t (** nz in Gappa: to nearest, tie breaking toward zero *) val _Nd__rounding_mode : Term.t (** nd in Gappa: to nearest, tie breaking toward minus infinity *) val _Nu__rounding_mode : Term.t (** nu in Gappa: to nearest, tie breaking toward plus infinity *) (** Integer part of binary logarithm for NON-ZERO POSITIVE number **) val integer_log_2 : Numbers.Q.t -> int (** [float_of_rational prec exp mode x] float approx of a rational constant. The function also returns the mantissa and the exponent. i.e. if [res, m, e = float_of_rational prec exp mode x], then [res = m * 2^e] **) val float_of_rational : Term.t -> Term.t -> Term.t -> Numbers.Q.t -> Numbers.Q.t * Numbers.Z.t * int (** [round_to_integer mode x] rounds the rational [x] to an integer depending on the rounding mode [mode] *) val round_to_integer: Term.t -> Numbers.Q.t -> Numbers.Q.t alt-ergo-free-2.0.0/lib/structures/literal.mli0000664000175000017500000000765213430774474017117 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) type 'a view = private | Eq of 'a * 'a | Distinct of bool * 'a list | Builtin of bool * Hstring.t * 'a list | Pred of 'a * bool type 'a atom_view (* We do not need to export internal representation of literals ! = | EQ of 'a * 'a | BT of Hstring.t * 'a list | PR of 'a | EQ_LIST of 'a list*) module type OrderedType = sig type t val compare : t -> t -> int val hash : t -> int val print : Format.formatter -> t -> unit val top : unit -> t val bot : unit -> t val type_info : t -> Ty.t end module type S = sig type elt type t val make : elt view -> t val view : t -> elt view val atom_view : t -> elt atom_view * bool (* is_negated ? *) val mk_eq : elt -> elt -> t val mk_distinct : bool -> elt list -> t val mk_builtin : bool -> Hstring.t -> elt list -> t val mk_pred : elt -> bool -> t val mkv_eq : elt -> elt -> elt view val mkv_distinct : bool -> elt list -> elt view val mkv_builtin : bool -> Hstring.t -> elt list -> elt view val mkv_pred : elt -> bool -> elt view val neg : t -> t val add_label : Hstring.t -> t -> unit val label : t -> Hstring.t val print : Format.formatter -> t -> unit val compare : t -> t -> int val equal : t -> t -> bool val hash : t -> int val uid : t -> int module Map : Map.S with type key = t module Set : Set.S with type elt = t end module Make ( X : OrderedType ) : S with type elt = X.t module type S_Term = sig include S with type elt = Term.t val vrai : t val faux : t val apply_subst : Term.subst -> t -> t val terms_nonrec : t -> Term.Set.t val terms_rec : t -> Term.Set.t val vars_of : t -> Ty.t Symbols.Map.t -> Ty.t Symbols.Map.t val is_ground : t -> bool val is_in_model : t -> bool end module LT : S_Term alt-ergo-free-2.0.0/lib/structures/exception.mli0000664000175000017500000000451613430774474017455 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) exception Unsolvable exception Inconsistent of Explanation.t * Term.Set.t list exception Progress exception NotCongruent exception Trivial exception Interpreted_Symbol exception Compared of int alt-ergo-free-2.0.0/lib/structures/typed.mli0000664000175000017500000001342113430774474016577 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Parsed type ('a, 'b) annoted = { c : 'a; annot : 'b } type tconstant = | Tint of string | Treal of Num.num | Tbitv of string | Ttrue | Tfalse | Tvoid type 'a tterm = { tt_ty : Ty.t; tt_desc : 'a tt_desc } and 'a tt_desc = | TTconst of tconstant | TTvar of Symbols.t | TTinfix of ('a tterm, 'a) annoted * Symbols.t * ('a tterm, 'a) annoted | TTprefix of Symbols.t * ('a tterm, 'a) annoted | TTapp of Symbols.t * ('a tterm, 'a) annoted list | TTmapsTo of Hstring.t * ('a tterm, 'a) annoted | TTinInterval of ('a tterm, 'a) annoted * bool * ('a tterm, 'a) annoted * ('a tterm, 'a) annoted * bool (* bool = true <-> interval is_open *) | TTget of ('a tterm, 'a) annoted * ('a tterm, 'a) annoted | TTset of ('a tterm, 'a) annoted * ('a tterm, 'a) annoted * ('a tterm, 'a) annoted | TTextract of ('a tterm, 'a) annoted * ('a tterm, 'a) annoted * ('a tterm, 'a) annoted | TTconcat of ('a tterm, 'a) annoted * ('a tterm, 'a) annoted | TTdot of ('a tterm, 'a) annoted * Hstring.t | TTrecord of (Hstring.t * ('a tterm, 'a) annoted) list | TTlet of Symbols.t * ('a tterm, 'a) annoted * ('a tterm, 'a) annoted | TTnamed of Hstring.t * ('a tterm, 'a) annoted type 'a tatom = | TAtrue | TAfalse | TAeq of ('a tterm, 'a) annoted list | TAdistinct of ('a tterm, 'a) annoted list | TAneq of ('a tterm, 'a) annoted list | TAle of ('a tterm, 'a) annoted list | TAlt of ('a tterm, 'a) annoted list | TApred of ('a tterm, 'a) annoted | TAbuilt of Hstring.t * ('a tterm, 'a) annoted list type 'a oplogic = OPand |OPor | OPimp | OPnot | OPiff | OPif of ('a tterm, 'a) annoted type 'a quant_form = { (* quantified variables that appear in the formula *) qf_bvars : (Symbols.t * Ty.t) list ; qf_upvars : (Symbols.t * Ty.t) list ; qf_triggers : (('a tterm, 'a) annoted list * bool) list; qf_hyp : ('a tform, 'a) annoted list; qf_form : ('a tform, 'a) annoted } and 'a tform = | TFatom of ('a tatom, 'a) annoted | TFop of 'a oplogic * (('a tform, 'a) annoted) list | TFforall of 'a quant_form | TFexists of 'a quant_form | TFlet of (Symbols.t * Ty.t) list * Symbols.t * ('a tterm, 'a) annoted * ('a tform, 'a) annoted | TFnamed of Hstring.t * ('a tform, 'a) annoted type 'a rwt_rule = { rwt_vars : (Symbols.t * Ty.t) list; rwt_left : 'a; rwt_right : 'a } type goal_sort = Cut | Check | Thm type theories_extensions = | Sum | Arrays | Records | Bitv | LIA | LRA | NRA | NIA | FPA type 'a tdecl = (* to simplify impl and extension of GUI, a TTtheory is seen a list of tdecl, although we only allow axioms in theories declarations *) | TTheory of Loc.t * string * theories_extensions * ('a tdecl, 'a) annoted list | TAxiom of Loc.t * string * axiom_kind * ('a tform, 'a) annoted | TRewriting of Loc.t * string * (('a tterm, 'a) annoted rwt_rule) list | TGoal of Loc.t * goal_sort * string * ('a tform, 'a) annoted | TLogic of Loc.t * string list * plogic_type | TPredicate_def of Loc.t * string * (string * ppure_type) list * ('a tform, 'a) annoted | TFunction_def of Loc.t * string * (string * ppure_type) list * ppure_type * ('a tform, 'a) annoted | TTypeDecl of Loc.t * string list * string * body_type_decl val print_term : Format.formatter -> ('a tterm, 'a) annoted -> unit val print_formula : Format.formatter -> ('a tform, 'a) annoted -> unit val print_binders : Format.formatter -> (Symbols.t * Ty.t) list -> unit val print_triggers : Format.formatter -> (('a tterm, 'a) annoted list * bool) list -> unit val th_ext_of_string : string -> Loc.t -> theories_extensions val string_of_th_ext : theories_extensions -> string alt-ergo-free-2.0.0/lib/structures/parsed.mli0000664000175000017500000001123213430774474016726 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) type constant = | ConstBitv of string | ConstInt of string | ConstReal of Num.num | ConstTrue | ConstFalse | ConstVoid type pp_infix = | PPand | PPor | PPimplies | PPiff | PPlt | PPle | PPgt | PPge | PPeq | PPneq | PPadd | PPsub | PPmul | PPdiv | PPmod type pp_prefix = | PPneg | PPnot type ppure_type = | PPTint | PPTbool | PPTreal | PPTunit | PPTbitv of int | PPTvarid of string * Loc.t | PPTexternal of ppure_type list * string * Loc.t type axiom_kind = Default | Propagator type lexpr = { pp_loc : Loc.t; pp_desc : pp_desc } and pp_desc = | PPvar of string | PPapp of string * lexpr list | PPmapsTo of string * lexpr | PPinInterval of lexpr * bool * lexpr * lexpr * bool (* bool = true <-> interval is_open *) | PPdistinct of lexpr list | PPconst of constant | PPinfix of lexpr * pp_infix * lexpr | PPprefix of pp_prefix * lexpr | PPget of lexpr * lexpr | PPset of lexpr * lexpr * lexpr | PPdot of lexpr * string | PPrecord of (string * lexpr) list | PPwith of lexpr * (string * lexpr) list | PPextract of lexpr * lexpr * lexpr | PPconcat of lexpr * lexpr | PPif of lexpr * lexpr * lexpr | PPforall of (string * ppure_type) list * (lexpr list * bool) list * lexpr list * lexpr | PPexists of (string * ppure_type) list * (lexpr list * bool) list * lexpr list * lexpr | PPforall_named of (string * string * ppure_type) list * (lexpr list * bool) list * lexpr list * lexpr | PPexists_named of (string * string * ppure_type) list * (lexpr list * bool) list * lexpr list * lexpr | PPnamed of string * lexpr | PPlet of string * lexpr * lexpr | PPcheck of lexpr | PPcut of lexpr | PPcast of lexpr * ppure_type (* Declarations. *) type plogic_type = | PPredicate of ppure_type list | PFunction of ppure_type list * ppure_type type name_kind = Symbols.name_kind type body_type_decl = | Record of (string * ppure_type) list (* lbl : t *) | Enum of string list | Abstract type decl = | Theory of Loc.t * string * string * decl list | Axiom of Loc.t * string * axiom_kind * lexpr | Rewriting of Loc.t * string * lexpr list | Goal of Loc.t * string * lexpr | Logic of Loc.t * name_kind * (string * string) list * plogic_type | Predicate_def of Loc.t * (string * string) * (Loc.t * string * ppure_type) list * lexpr | Function_def of Loc.t * (string * string) * (Loc.t * string * ppure_type) list * ppure_type * lexpr | TypeDecl of Loc.t * string list * string * body_type_decl type file = decl list alt-ergo-free-2.0.0/lib/structures/symbols.mli0000664000175000017500000000741513430774474017150 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) type operator = | Plus | Minus | Mult | Div | Modulo | Concat | Extract | Get | Set | Fixed | Float | Reach | Access of Hstring.t | Record | Sqrt_real | Abs_int | Abs_real | Real_of_int | Int_floor | Int_ceil | Sqrt_real_default | Sqrt_real_excess | Min_real | Min_int | Max_real | Max_int | Integer_log2 | Pow_real_int | Pow_real_real | Integer_round type name_kind = Ac | Constructor | Other type bound_kind = VarBnd of Hstring.t | ValBnd of Numbers.Q.t type bound = private { kind : bound_kind; sort : Ty.t; is_open : bool; is_lower : bool } type t = | True | False | Void | Name of Hstring.t * name_kind | Int of Hstring.t | Real of Hstring.t | Bitv of string | Op of operator | Var of Hstring.t | In of bound * bound | MapsTo of Hstring.t val name : ?kind:name_kind -> string -> t val var : string -> t val underscoring : t -> t val int : string -> t val real : string -> t val mk_bound : Hstring.t -> Ty.t -> is_open:bool -> is_lower:bool -> bound val mk_in : bound -> bound -> t val mk_maps_to : Hstring.t -> t val is_ac : t -> bool val equal : t -> t -> bool val compare : t -> t -> int val hash : t -> int val to_string : t -> string val print : Format.formatter -> t -> unit val to_string_clean : t -> string val print_clean : Format.formatter -> t -> unit val dummy : t val fresh : string -> t val is_get : t -> bool val is_set : t -> bool val fake_eq : t val fake_neq : t val fake_lt : t val fake_le : t module Map : Map.S with type key = t module Set : Set.S with type elt = t val add_label : Hstring.t -> t -> unit val label : t -> Hstring.t val print_bound : Format.formatter -> bound -> unit alt-ergo-free-2.0.0/lib/structures/term.ml0000664000175000017500000002600713430774474016254 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Format open Hconsing open Options module Sy = Symbols type view = { f: Sy.t; xs: t list; ty: Ty.t; tag: int; vars : Ty.t Sy.Map.t Lazy.t; vty : Ty.Svty.t Lazy.t; depth: int; nb_nodes : int; } and t = view module Subst = struct include Symbols.Map let print pr_elt fmt sbt = iter (fun k v -> fprintf fmt "%a -> %a " Sy.print k pr_elt v) sbt end type subst = t Subst.t * Ty.subst module H = struct type elt = view type t = elt let eq t1 t2 = try Sy.equal t1.f t2.f && List.for_all2 (==) t1.xs t2.xs && Ty.equal t1.ty t2.ty with Invalid_argument _ -> false let equal = eq let hash t = abs (List.fold_left (fun acc x-> acc*19 +x.tag) (Sy.hash t.f + Ty.hash t.ty) t.xs) let set_id tag x = {x with tag = tag} let initial_size = 4096 let disable_weaks () = Options.disable_weaks () end module T = Make(H) let view t = t let rec print_silent fmt t = let {f=x;xs=l;ty=ty} = view t in match x, l with | Sy.Op Sy.Get, [e1; e2] -> fprintf fmt "%a[%a]" print e1 print e2 | Sy.Op Sy.Set, [e1; e2; e3] -> fprintf fmt "%a[%a<-%a]" print e1 print e2 print e3 | Sy.Op Sy.Concat, [e1; e2] -> fprintf fmt "%a@@%a" print e1 print e2 | Sy.Op Sy.Extract, [e1; e2; e3] -> fprintf fmt "%a^{%a,%a}" print e1 print e2 print e3 | Sy.Op (Sy.Access field), [e] -> fprintf fmt "%a.%s" print e (Hstring.view field) | Sy.Op (Sy.Record), _ -> begin match ty with | Ty.Trecord {Ty.lbs=lbs} -> assert (List.length l = List.length lbs); fprintf fmt "{"; ignore (List.fold_left2 (fun first (field,_) e -> fprintf fmt "%s%s = %a" (if first then "" else "; ") (Hstring.view field) print e; false ) true lbs l); fprintf fmt "}"; | _ -> assert false end (* TODO: introduce PrefixOp in the future to simplify this ? *) | Sy.Op op, [e1; e2] when op == Sy.Pow_real_int || op == Sy.Max_real || op == Sy.Max_int || op == Sy.Min_real || op == Sy.Min_int || op == Sy.Pow_real_real || op == Sy.Integer_round -> fprintf fmt "%a(%a,%a)" Sy.print x print e1 print e2 | Sy.Op op, [e1; e2] -> fprintf fmt "(%a %a %a)" print e1 Sy.print x print e2 | Sy.In(lb, rb), [t] -> fprintf fmt "(%a in %a, %a)" print t Sy.print_bound lb Sy.print_bound rb | _, [] -> fprintf fmt "%a" Sy.print x | _, _ -> fprintf fmt "%a(%a)" Sy.print x print_list l and print_verbose fmt t = fprintf fmt "(%a : %a)" print_silent t Ty.print (view t).ty and print fmt t = if Options.debug () then print_verbose fmt t else print_silent fmt t and print_list_sep sep fmt = function | [] -> () | [t] -> print fmt t | t::l -> Format.fprintf fmt "%a%s%a" print t sep (print_list_sep sep) l and print_list fmt = print_list_sep "," fmt (* * We keep true and false as repr * ordering is influenced by depth * otherwise, we compare tag2 - tag1 so that fresh vars will be smaller *) let compare t1 t2 = if t1 == t2 then 0 else let c = t1.depth - t2.depth in if c <> 0 then c else match (view t1).f, (view t2).f with | (Sy.True | Sy.False ), (Sy.True | Sy.False) -> t2.tag - t1.tag | (Sy.True | Sy.False ), _ -> -1 | _, (Sy.True | Sy.False ) -> 1 | _ -> t2.tag - t1.tag let sort = List.sort compare let merge_maps acc b = Sy.Map.merge (fun sy a b -> match a, b with | None, None -> assert false | Some _, None -> a | _ -> b ) acc b let vars_of_make s l ty = lazy ( match s, l with | Sy.Var _, [] -> Sy.Map.singleton s ty | Sy.Var _, _ -> assert false | _, [] -> Sy.Map.empty | _, e::r -> List.fold_left (fun s t -> merge_maps s (Lazy.force t.vars)) (Lazy.force e.vars) r ) let vty_of_make l ty = lazy ( List.fold_left (fun acc t -> Ty.Svty.union acc (Lazy.force t.vty)) (Ty.vty_of ty) l ) let make s l ty = let d = 1 + List.fold_left (fun z t -> max z t.depth) 0 l in let nb_nodes = List.fold_left (fun z t -> z + t.nb_nodes) 1 l in let vars = vars_of_make s l ty in let vty = vty_of_make l ty in T.make {f=s; xs=l; ty=ty; depth=d; tag= -42; vars; vty; nb_nodes} let fresh_name ty = make (Sy.name (Hstring.fresh_string())) [] ty let is_fresh t = match view t with | {f=Sy.Name(hs,_);xs=[]} -> Hstring.is_fresh_string (Hstring.view hs) | _ -> false let is_fresh_skolem t = match view t with | {f=Sy.Name(hs,_)} -> Hstring.is_fresh_skolem (Hstring.view hs) | _ -> false let shorten t = let {f=f;xs=xs;ty=ty} = view t in make f xs (Ty.shorten ty) let vrai = make (Sy.True) [] Ty.Tbool let faux = make (Sy.False) [] Ty.Tbool let void = make (Sy.Void) [] Ty.Tunit let positive_int i = make (Sy.int i) [] Ty.Tint let int i = let len = String.length i in assert (len >= 1); match i.[0] with | '-' -> assert (len >= 2); let pi = String.sub i 1 (len - 1) in make (Sy.Op Sy.Minus) [ positive_int "0"; positive_int pi ] Ty.Tint | _ -> positive_int i let positive_real i = make (Sy.real i) [] Ty.Treal let real r = let len = String.length r in assert (len >= 1); match r.[0] with | '-' -> assert (len >= 2); let pi = String.sub r 1 (len - 1) in make (Sy.Op Sy.Minus) [ positive_real "0"; positive_real pi ] Ty.Treal | _ -> positive_real r let bitv bt ty = make (Sy.Bitv bt) [] ty let is_int t = (view t).ty == Ty.Tint let is_real t = (view t).ty == Ty.Treal let equal t1 t2 = t1 == t2 let hash t = t.tag let pred t = make (Sy.Op Sy.Minus) [t;int "1"] Ty.Tint module Set = Set.Make(struct type t' = t type t=t' let compare=compare end) module Map = Map.Make(struct type t' = t type t=t' let compare=compare end) let vars_of t acc = merge_maps acc (Lazy.force t.vars) let vty_of t = Lazy.force t.vty module Hsko = Hashtbl.Make(H) let gen_sko ty = make (Sy.fresh "@sko") [] ty let is_skolem_cst v = try Pervasives.(=) (String.sub (Sy.to_string v.f) 0 4) "_sko" with Invalid_argument _ -> false let find_skolem = let hsko = Hsko.create 17 in fun v ty -> if is_skolem_cst v then try Hsko.find hsko v with Not_found -> let c = gen_sko ty in Hsko.add hsko v c; c else v let is_ground t = Symbols.Map.is_empty (vars_of t Sy.Map.empty) && Ty.Svty.is_empty (vty_of t) let rec apply_subst (s_t,s_ty) t = let {f=f;xs=xs;ty=ty; vars; vty} = view t in if is_ground t then t else let vars = Lazy.force vars in let vty = Lazy.force vty in let s_t = Sy.Map.filter (fun sy _ -> Sy.Map.mem sy vars) s_t in let s_ty = Ty.M.filter (fun id _ -> Ty.Svty.mem id vty) s_ty in if s_t == Sy.Map.empty && s_ty == Ty.M.empty then t else try let v = Sy.Map.find f s_t in find_skolem v ty with Not_found -> let s = s_t, s_ty in let xs', same = Lists.apply (apply_subst s) xs in let ty' = Ty.apply_subst s_ty ty in if same && ty == ty' then t else make f xs' ty' let compare_subst (s_t1, s_ty1) (s_t2, s_ty2) = let c = Ty.compare_subst s_ty1 s_ty2 in if c<>0 then c else Sy.Map.compare compare s_t1 s_t2 let equal_subst (s_t1, s_ty1) (s_t2, s_ty2) = Ty.equal_subst s_ty1 s_ty2 || Sy.Map.equal equal s_t1 s_t2 let fold_subst_term f (s,_) acc = Sy.Map.fold f s acc let union_subst (s_t1, s_ty1) ((s_t2, s_ty2) as subst) = let s_t = Sy.Map.fold (fun k x s2 -> Sy.Map.add k x s2) (Sy.Map.map (apply_subst subst) s_t1) s_t2 in let s_ty = Ty.union_subst s_ty1 s_ty2 in s_t, s_ty let rec subterms acc t = let {xs=xs} = view t in List.fold_left subterms (Set.add t acc) xs module Labels = Hashtbl.Make(H) let labels = Labels.create 100007 let add_label lbl t = Labels.replace labels t lbl let label t = try Labels.find labels t with Not_found -> Hstring.empty let label_model h = try Pervasives.(=) (String.sub (Hstring.view h) 0 6) "model:" with Invalid_argument _ -> false let rec is_in_model_rec depth { f = f; xs = xs } = let lb = Symbols.label f in (label_model lb && (try let md = Scanf.sscanf (Hstring.view lb) "model:%d" (fun x -> x) in depth <= md with Scanf.Scan_failure _ | End_of_file-> true)) || List.exists (is_in_model_rec (depth +1)) xs let is_in_model t = label_model (label t) || is_in_model_rec 0 t let is_labeled t = not (Hstring.equal (label t) Hstring.empty) let print_tagged_classes fmt = List.iter (fun cl -> let cl = List.filter is_labeled (Set.elements cl) in if cl != [] then fprintf fmt "\n{ %a }" (print_list_sep " , ") cl) let type_info t = t.ty let top () = vrai let bot () = faux let apply_subst s t = if Options.timers() then try Timers.exec_timer_start Timers.M_Term Timers.F_apply_subst; let res = apply_subst s t in Timers.exec_timer_pause Timers.M_Term Timers.F_apply_subst; res with e -> Timers.exec_timer_pause Timers.M_Term Timers.F_apply_subst; raise e else apply_subst s t alt-ergo-free-2.0.0/lib/structures/errors.mli0000664000175000017500000000702613430774474016772 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) type error = | BitvExtract of int*int | BitvExtractRange of int*int | ClashType of string | ClashLabel of string * string | ClashParam of string | TypeDuplicateVar of string | UnboundedVar of string | UnknownType of string | WrongArity of string * int | SymbAlreadyDefined of string | SymbUndefined of string | NotAPropVar of string | NotAPredicate of string | Unification of Ty.t * Ty.t | ShouldBeApply of string | WrongNumberofArgs of string | ShouldHaveType of Ty.t * Ty.t | ShouldHaveTypeIntorReal of Ty.t | ShouldHaveTypeInt of Ty.t | ShouldHaveTypeBitv of Ty.t | ArrayIndexShouldHaveTypeInt | ShouldHaveTypeArray | ShouldHaveTypeRecord of Ty.t | ShouldBeARecord | ShouldHaveLabel of string * string | NoLabelInType of Hstring.t * Ty.t | ShouldHaveTypeProp | NoRecordType of Hstring.t | DuplicateLabel of Hstring.t | WrongLabel of Hstring.t * Ty.t | WrongNumberOfLabels | Notrigger | CannotGeneralize | SyntaxError | ThExtError of string | ThSemTriggerError | WrongDeclInTheory (* this is a typing error *) exception Error of error * Loc.t exception Warning of error * Loc.t (* these two exception are used by the lexer and the parser *) exception Lexical_error of Loc.t * string exception Syntax_error of Loc.t * string val report : Format.formatter -> error -> unit val error : error -> Loc.t -> 'a val warning : error -> Loc.t -> 'a alt-ergo-free-2.0.0/lib/structures/formula.mli0000664000175000017500000001327313430774474017124 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) type t type binders = (Ty.t * int) Symbols.Map.t (*int tag in globally unique *) type semantic_trigger = | Interval of Term.t * Symbols.bound * Symbols.bound | MapsTo of Hstring.t * Term.t | NotTheoryConst of Term.t | IsTheoryConst of Term.t | LinearDependency of Term.t * Term.t type trigger = { content : Term.t list; (* this field is filled (with a part of 'content' field) by theories when assume_th_elt is called *) semantic : semantic_trigger list; hyp : t list; depth : int; from_user : bool; guard : Literal.LT.t option } type quantified = { name : string; main : t; (*simplified quantified formula, or immediate inst*) simple_inst : (Term.t Symbols.Map.t * Ty.subst) option; triggers : trigger list; backward_triggers : trigger list Lazy.t; forward_triggers : trigger list Lazy.t; binders : binders; (* quantified variable *) (* These fields should be (ordered) lists ! important for skolemization *) free_v : Term.t list; (* free variables in main *) free_vty : Ty.t list; (* free type variables in main *) loc : Loc.t; (* location of the "GLOBAL" axiom containing this quantified formula. It forms with name a unique id *) } and llet = { let_var: Symbols.t; let_subst : Term.subst; let_term : Term.t; let_f : t; } and view = Unit of t*t (* unit clauses *) | Clause of t*t*bool (* a clause (t1 or t2) bool <-> is implication *) | Literal of Literal.LT.t (* an atom *) | Lemma of quantified (* a lemma *) | Skolem of quantified (* lazy skolemization *) | Let of llet (* a binding of a term *) type gformula = { f: t; nb_reductions : int; trigger_depth : int; age: int; lem: t option; origin_name : string; from_terms : Term.t list; mf: bool; gf: bool; gdist : int; (* dist to goal *) hdist : int; (* dist to hypotheses *) theory_elim : bool; } val mk_binders : Term.Set.t -> binders val mk_not : t -> t val mk_and : t -> t -> bool -> int -> t (* bool <-> is implication (neg) *) val mk_or : t -> t -> bool -> int -> t (* bool <-> is implication *) val mk_imp : t -> t -> int -> t val mk_if : Term.t -> t -> t -> int -> t val mk_iff : t -> t -> int -> t val mk_lit : Literal.LT.t -> int -> t val mk_forall : string -> (* name *) Loc.t -> (* location in the original file *) binders -> (* quantified variables *) trigger list -> (* triggers *) t -> (* quantified formula *) int -> (* id, for the GUI *) (Term.t list * Ty.t list) option -> (* free_vars and free_vty: they are computed if None is given *) t val mk_exists : string -> (* name *) Loc.t -> (* location in the original file *) binders -> (* quantified variables *) trigger list -> (* triggers *) t -> (* quantified formula *) int -> (* id, for the GUI *) (Term.t list * Ty.t list) option -> (* free_vars and free_vty: they are computed if None is given *) t val mk_let : Term.Set.t -> Symbols.t -> Term.t -> t -> int -> t val add_label : Hstring.t -> t -> unit val label : t -> Hstring.t val is_in_model : t -> bool val view : t -> view val size : t -> int val id : t -> int val print : Format.formatter -> t -> unit val ground_terms_rec : t -> Term.Set.t val free_vars : t -> Ty.t Symbols.Map.t val apply_subst : Term.subst -> t -> t val compare : t -> t -> int val equal : t -> t -> bool val hash : t -> int val vrai : t val faux : t val skolemize : quantified -> t val type_variables: t -> Ty.Set.t val max_term_depth : t -> int module Set : Set.S with type elt = t module Map : Map.S with type key = t val name_of_lemma : t -> string val name_of_lemma_opt : t option -> string alt-ergo-free-2.0.0/lib/structures/typed.ml0000664000175000017500000002220413430774474016425 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Format open Parsed open Options type ('a, 'b) annoted = { c : 'a; annot : 'b } type tconstant = | Tint of string | Treal of Num.num | Tbitv of string | Ttrue | Tfalse | Tvoid type 'a tterm = { tt_ty : Ty.t; tt_desc : 'a tt_desc } and 'a tt_desc = | TTconst of tconstant | TTvar of Symbols.t | TTinfix of ('a tterm, 'a) annoted * Symbols.t * ('a tterm, 'a) annoted | TTprefix of Symbols.t * ('a tterm, 'a) annoted | TTapp of Symbols.t * ('a tterm, 'a) annoted list | TTmapsTo of Hstring.t * ('a tterm, 'a) annoted | TTinInterval of ('a tterm, 'a) annoted * bool * ('a tterm, 'a) annoted * ('a tterm, 'a) annoted * bool (* bool = true <-> interval is_open *) | TTget of ('a tterm, 'a) annoted * ('a tterm, 'a) annoted | TTset of ('a tterm, 'a) annoted * ('a tterm, 'a) annoted * ('a tterm, 'a) annoted | TTextract of ('a tterm, 'a) annoted * ('a tterm, 'a) annoted * ('a tterm, 'a) annoted | TTconcat of ('a tterm, 'a) annoted * ('a tterm, 'a) annoted | TTdot of ('a tterm, 'a) annoted * Hstring.t | TTrecord of (Hstring.t * ('a tterm, 'a) annoted) list | TTlet of Symbols.t * ('a tterm, 'a) annoted * ('a tterm, 'a) annoted | TTnamed of Hstring.t * ('a tterm, 'a) annoted type 'a tatom = | TAtrue | TAfalse | TAeq of ('a tterm, 'a) annoted list | TAdistinct of ('a tterm, 'a) annoted list | TAneq of ('a tterm, 'a) annoted list | TAle of ('a tterm, 'a) annoted list | TAlt of ('a tterm, 'a) annoted list | TApred of ('a tterm, 'a) annoted | TAbuilt of Hstring.t * ('a tterm, 'a) annoted list type 'a oplogic = OPand |OPor | OPimp | OPnot | OPiff | OPif of ('a tterm, 'a) annoted type 'a quant_form = { (* quantified variables that appear in the formula *) qf_bvars : (Symbols.t * Ty.t) list ; qf_upvars : (Symbols.t * Ty.t) list ; qf_triggers : (('a tterm, 'a) annoted list * bool) list ; qf_hyp : ('a tform, 'a) annoted list; qf_form : ('a tform, 'a) annoted } and 'a tform = | TFatom of ('a tatom, 'a) annoted | TFop of 'a oplogic * (('a tform, 'a) annoted) list | TFforall of 'a quant_form | TFexists of 'a quant_form | TFlet of (Symbols.t * Ty.t) list * Symbols.t * ('a tterm, 'a) annoted * ('a tform, 'a) annoted | TFnamed of Hstring.t * ('a tform, 'a) annoted type 'a rwt_rule = { rwt_vars : (Symbols.t * Ty.t) list; rwt_left : 'a; rwt_right : 'a } type goal_sort = Cut | Check | Thm type theories_extensions = | Sum | Arrays | Records | Bitv | LIA | LRA | NRA | NIA | FPA type 'a tdecl = (* to simplify impl and extension of GUI, a TTtheory is seen a list of tdecl, although we only allow axioms in theories declarations *) | TTheory of Loc.t * string * theories_extensions * ('a tdecl, 'a) annoted list | TAxiom of Loc.t * string * axiom_kind * ('a tform, 'a) annoted | TRewriting of Loc.t * string * (('a tterm, 'a) annoted rwt_rule) list | TGoal of Loc.t * goal_sort * string * ('a tform, 'a) annoted | TLogic of Loc.t * string list * plogic_type | TPredicate_def of Loc.t * string * (string * ppure_type) list * ('a tform, 'a) annoted | TFunction_def of Loc.t * string * (string * ppure_type) list * ppure_type * ('a tform, 'a) annoted | TTypeDecl of Loc.t * string list * string * body_type_decl (*****) let rec print_term fmt t = match t.c.tt_desc with | TTconst Ttrue -> fprintf fmt "true" | TTconst Tfalse -> fprintf fmt "false" | TTconst Tvoid -> fprintf fmt "void" | TTconst (Tint n) -> fprintf fmt "%s" n | TTconst (Treal n) -> fprintf fmt "%s" (Num.string_of_num n) | TTconst Tbitv s -> fprintf fmt "%s" s | TTvar s -> fprintf fmt "%a" Symbols.print s | TTapp(s,l) -> fprintf fmt "%a(%a)" Symbols.print s print_term_list l | TTinfix(t1,s,t2) -> fprintf fmt "%a %a %a" print_term t1 Symbols.print s print_term t2 | TTprefix (s, t') -> fprintf fmt "%a %a" Symbols.print s print_term t' | TTget (t1, t2) -> fprintf fmt "%a[%a]" print_term t1 print_term t2 | TTset (t1, t2, t3) -> fprintf fmt "%a[%a<-%a]" print_term t1 print_term t2 print_term t3 | TTextract (t1, t2, t3) -> fprintf fmt "%a^{%a,%a}" print_term t1 print_term t2 print_term t3 | TTconcat (t1, t2) -> fprintf fmt "%a @ %a" print_term t1 print_term t2 | TTdot (t1, s) -> fprintf fmt "%a.%s" print_term t1 (Hstring.view s) | TTrecord l -> fprintf fmt "{ "; List.iter (fun (s, t) -> fprintf fmt "%s = %a" (Hstring.view s) print_term t) l; fprintf fmt " }" | TTlet (s, t1, t2) -> fprintf fmt "let %a=%a in %a" Symbols.print s print_term t1 print_term t2 | TTnamed (lbl, t) -> fprintf fmt "%a" print_term t | TTinInterval(e, lb, i, j, ub) -> fprintf fmt "%a in %s%a, %a%s" print_term e (if lb then "]" else "[") print_term i print_term j (if ub then "[" else "]") | TTmapsTo(x,e) -> fprintf fmt "%s |-> %a" (Hstring.view x) print_term e and print_term_list fmt = List.iter (fprintf fmt "%a," print_term) let print_atom fmt a = match a.c with | TAtrue -> fprintf fmt "True" | TAfalse -> fprintf fmt "True" | TAeq [t1; t2] -> fprintf fmt "%a = %a" print_term t1 print_term t2 | TAneq [t1; t2] -> fprintf fmt "%a <> %a" print_term t1 print_term t2 | TAle [t1; t2] -> fprintf fmt "%a <= %a" print_term t1 print_term t2 | TAlt [t1; t2] -> fprintf fmt "%a < %a" print_term t1 print_term t2 | TApred t -> print_term fmt t | TAbuilt(s, l) -> fprintf fmt "%s(%a)" (Hstring.view s) print_term_list l | _ -> assert false let string_of_op = function | OPand -> "and" | OPor -> "or" | OPimp -> "->" | OPiff -> "<->" | _ -> assert false let print_binder fmt (s, t) = fprintf fmt "%a :%a" Symbols.print s Ty.print t let print_binders fmt l = List.iter (fun c -> fprintf fmt "%a, " print_binder c) l let print_triggers fmt l = List.iter (fun (tr, _) -> fprintf fmt "%a | " print_term_list tr) l let rec print_formula fmt f = match f.c with | TFatom a -> print_atom fmt a | TFop(OPnot, [f]) -> fprintf fmt "not %a" print_formula f | TFop(OPif(t), [f1;f2]) -> fprintf fmt "if %a then %a else %a" print_term t print_formula f1 print_formula f2 | TFop(op, [f1; f2]) -> fprintf fmt "%a %s %a" print_formula f1 (string_of_op op) print_formula f2 | TFforall {qf_bvars = l; qf_triggers = t; qf_form = f} -> fprintf fmt "forall %a [%a]. %a" print_binders l print_triggers t print_formula f | _ -> assert false and print_form_list fmt = List.iter (fprintf fmt "%a" print_formula) let th_ext_of_string ext loc = match ext with | "Sum" -> Sum | "Arrays" -> Arrays | "Records" -> Records | "Bitv" -> Bitv | "LIA" -> LIA | "LRA" -> LRA | "NRA" -> NRA | "NIA" -> NIA | "FPA" -> FPA | _ -> Errors.error (Errors.ThExtError ext) loc let string_of_th_ext ext = match ext with | Sum -> "Sum" | Arrays -> "Arrays" | Records -> "Records" | Bitv -> "Bitv" | LIA -> "LIA" | LRA -> "LRA" | NRA -> "NRA" | NIA -> "NIA" | FPA -> "FPA" alt-ergo-free-2.0.0/lib/structures/term.mli0000664000175000017500000000746013430774474016427 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) type t type view = private { f: Symbols.t; xs: t list; ty: Ty.t; tag: int; vars : Ty.t Symbols.Map.t Lazy.t; vty : Ty.Svty.t Lazy.t; depth: int; nb_nodes : int; } module Subst : sig include Map.S with type key = Symbols.t and type 'a t = 'a Symbols.Map.t val print : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit end type subst = t Subst.t * Ty.subst module Map : Map.S with type key = t module Set : Set.S with type elt = t val view : t -> view val make : Symbols.t -> t list -> Ty.t -> t val shorten : t -> t val vrai : t val faux : t val void : t val int : string -> t val real : string -> t val bitv : string -> Ty.t -> t val fresh_name : Ty.t -> t val is_fresh : t -> bool val is_fresh_skolem : t -> bool val is_int : t -> bool val is_real : t -> bool val compare : t -> t -> int val equal : t -> t -> bool val hash : t -> int val vars_of : t -> Ty.t Symbols.Map.t -> Ty.t Symbols.Map.t val vty_of : t -> Ty.Svty.t val pred : t -> t val apply_subst : subst -> t -> t val compare_subst : subst -> subst -> int val equal_subst : subst -> subst -> bool val fold_subst_term : (Symbols.t -> t -> 'b -> 'b) -> subst -> 'b -> 'b val union_subst : subst -> subst -> subst val add_label : Hstring.t -> t -> unit val label : t -> Hstring.t val is_in_model : t -> bool val print : Format.formatter -> t -> unit val print_list : Format.formatter -> t list -> unit val print_list_sep : string -> Format.formatter -> t list -> unit val print_tagged_classes : Format.formatter -> Set.t list -> unit val subterms : Set.t -> t -> Set.t val type_info : t -> Ty.t val top : unit -> t val bot : unit -> t val is_ground : t -> bool alt-ergo-free-2.0.0/lib/structures/formula.ml0000664000175000017500000006531713430774474016761 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Format open Hconsing open Options module T = Term module Sy = Symbols type binders = (Ty.t * int) Sy.Map.t (*int tag in globally unique *) type semantic_trigger = | Interval of Term.t * Symbols.bound * Symbols.bound | MapsTo of Hstring.t * Term.t | NotTheoryConst of Term.t | IsTheoryConst of Term.t | LinearDependency of Term.t * Term.t type trigger = { content : T.t list; semantic : semantic_trigger list; hyp : t list; depth : int; from_user : bool; guard : Literal.LT.t option } and quantified = { name : string; main : t; (*simplified quantified formula, or immediate inst*) simple_inst : (Term.t Symbols.Map.t * Ty.subst) option; triggers : trigger list; backward_triggers : trigger list Lazy.t; forward_triggers : trigger list Lazy.t; binders : binders; (* These fields should be (ordered) lists ! important for skolemization *) free_v : T.t list; free_vty : Ty.t list; loc : Loc.t; (* location of the "GLOBAL" axiom containing this quantified formula. It forms with name a unique id *) } and llet = { let_var: Symbols.t; let_subst : Term.subst; let_term : Term.t; let_f : t; } and view = Unit of t*t | Clause of t*t*bool | Literal of Literal.LT.t | Lemma of quantified | Skolem of quantified | Let of llet and iview = { pos : view ; neg : view ; size : int; tag : int ; negation : iview} and t = iview * int type gformula = { f: t; nb_reductions : int; trigger_depth : int; age: int; lem: t option; origin_name : string; from_terms : Term.t list; mf: bool; gf: bool; gdist : int; (* dist to goal *) hdist : int; (* dist to hypotheses *) theory_elim : bool; } let size (t,_) = t.size let compare ((v1,_) as f1) ((v2,_) as f2) = let c = Pervasives.compare (size f1) (size f2) in if c=0 then Pervasives.compare v1.tag v2.tag else c let equal (f1,_) (f2,_) = assert ((f1 == f2) == (f1.tag == f2.tag)); f1 == f2 let equal_binders b1 b2 = Sy.Map.equal (fun (_,i) (_,j) -> i = j) b1 b2 let equal_free_vars = let set_of l = List.fold_left (fun z t -> T.Set.add t z) T.Set.empty l in fun l1 l2 -> let st2 = set_of l2 in List.for_all (fun ty -> T.Set.mem ty st2) l1 let equal_free_vty = let set_of l = List.fold_left (fun z t -> Ty.Set.add t z) Ty.Set.empty l in fun l1 l2 -> let st2 = set_of l2 in List.for_all (fun ty -> Ty.Set.mem ty st2) l1 module MST = Map.Make(T.Set) let equal_triggers = let map_of l = List.fold_left (fun mp {content=mtr; guard = opt} -> let st = List.fold_left (fun z t -> T.Set.add t z) T.Set.empty mtr in MST.add st opt mp )MST.empty l in let equal_opt o1 o2 = match o1, o2 with | None, None -> true | Some a, Some b -> Literal.LT.equal a b | _ -> false in fun trs1 trs2 -> MST.equal equal_opt (map_of trs1) (map_of trs2) let equal_quant {main=f1; binders=b1; free_v=free_v1; free_vty=free_vty1; triggers=trs1} {main=f2; binders=b2; free_v=free_v2; free_vty=free_vty2; triggers=trs2} = equal f1 f2 && equal_binders b1 b2 && equal_free_vars free_v1 free_v2 && equal_free_vty free_vty1 free_vty2 && equal_triggers trs1 trs2 let hash (f, _) = f.tag let view (t,_) = t.pos let hash_quant acc q = let { name = name; main = main; triggers = triggers; binders = binders; free_v = free_v; free_vty = free_vty; } = q in let acc = (fst main).tag + 13*acc in let acc = Sy.Map.fold (fun sy (ty, i) acc -> i * (Ty.hash ty) + 13*acc) binders acc in let acc = List.fold_left (fun acc t -> (T.hash t) + 13*acc) acc free_v in let acc = List.fold_left (fun acc ty -> (Ty.hash ty) + 13*acc) acc free_vty in acc let rec is_positive v = match v with | Unit _ | Lemma _ -> true | Clause _ | Skolem _ -> false | Literal a -> snd (Literal.LT.atom_view a) | Let llet -> is_positive (view llet.let_f) module View = struct type elt = iview let eqc c1 c2 = match c1,c2 with | Literal x , Literal y -> Literal.LT.equal x y | Unit(f1,f2), Unit(g1,g2) | Clause(f1,f2,_), Clause(g1,g2,_) -> equal f1 g1 && equal f2 g2 || equal f1 g2 && equal f2 g1 | Lemma q1, Lemma q2 | Skolem q1, Skolem q2 -> equal_quant q1 q2 | Let l1, Let l2 -> fst l1.let_f == fst l2.let_f && Sy.equal l1.let_var l2.let_var && Term.equal l1.let_term l2.let_term && Term.compare_subst l1.let_subst l2.let_subst = 0 | _, _ -> false let hashlt = List.fold_left (fun acc x->acc*19 + T.hash x) let hashllt = List.fold_left (fun acc (x, _) ->acc*19 + hashlt 0 x) let hashc acc = function | Literal x -> Literal.LT.hash x | Unit((f1,_),(f2,_)) -> (* XXX : Same as Clause ? *) let min = min f1.tag f2.tag in let max = max f1.tag f2.tag in (acc*19 + min)*19 + max | Clause((f1,_),(f2,_),_) -> let min = min f1.tag f2.tag in let max = max f1.tag f2.tag in (acc*19 + min)*19 + max | Lemma q -> 2*hash_quant acc q | Skolem q -> 1 + 2*hash_quant acc q | Let ({let_var=lvar; let_term=lterm; let_subst=s; let_f=(lf,_)}) -> T.fold_subst_term (fun s t acc ->acc * 19 + Sy.hash s) s (lf.tag * 19 * 19 + Sy.hash lvar * 19 + acc) let eq f1 f2 = eqc f1.pos f2.pos && eqc f1.neg f2.neg let hash f = abs (hashc (hashc 1 f.pos) f.neg) let set_id tag {pos=pos; neg=neg; size=size} = (*assert (is_positive (pos));*) let rec p = {pos = pos; neg = neg; size = size; tag = 2*tag; negation = n} and n = {pos = neg; neg = pos; size = size; tag = 2*tag+1; negation = p} in p let initial_size = 4096 let disable_weaks () = Options.disable_weaks () end module H = Make(View) let iview f = f let id (_,id) = id let print_binders = let print_one fmt (sy, (ty, _)) = fprintf fmt "%a:%a" Sy.print sy Ty.print ty in fun fmt b -> match Sy.Map.bindings b with | [] -> (* can happen when quantifying only on type variables *) fprintf fmt "(no term variables)" | e::l -> print_one fmt e; List.iter (fun e -> fprintf fmt ", %a" print_one e) l let rec print fmt f = match view f with | Literal a -> Literal.LT.print fmt a | Lemma {triggers = trs; main = f; name = n; binders} -> if verbose () then let first = ref true in fprintf fmt "(lemma: %s forall %a.)[%a]@ %a" n print_binders binders (fun fmt -> List.iter (fun {content=l} -> fprintf fmt "%s%a" (if !first then "" else " | ") T.print_list l; first := false; )) trs print f else fprintf fmt "lem %s" n | Unit(f1, f2) -> fprintf fmt "@[(%a /\\@ %a)@]" print f1 print f2 | Clause(f1, f2,_) -> fprintf fmt "@[(%a \\/@ %a)@]" print f1 print f2 | Skolem{main=f; binders} -> fprintf fmt " (%a)" print_binders binders print f | Let l -> fprintf fmt "let %a =@ %a in@ %a" Sy.print l.let_var Term.print l.let_term print l.let_f (* let print fmt ((_,id) as f) = *) (* fprintf fmt "(%d)%a" id print f *) let union_subst s1 ((s2,s2_ty) as subst) = Sy.Map.fold (fun k x s2 -> Sy.Map.add k x s2) (Sy.Map.map (T.apply_subst subst) s1) s2 let mk_not (f,id) = f.negation, id (* smart constructors *) let make pos neg size id = let rec p = {pos = pos; neg = neg; size = size; tag = -1; negation = n} and n = {pos = neg; neg = pos; size = size; tag = -1; negation = p} in if is_positive pos then H.make p, id else mk_not (H.make n, id) let vrai = make (Literal Literal.LT.vrai) (Literal Literal.LT.faux) 1 0 let faux = mk_not vrai let mk_binders = let cpt = ref 0 in fun st -> T.Set.fold (fun t sym -> incr cpt; match T.view t with | {T.f=(Sy.Var _) as v; ty=ty} -> Sy.Map.add v (ty, !cpt) sym | _ -> assert false )st Sy.Map.empty module F_Htbl = Hashtbl.Make(struct type t'=t type t=t' let hash = hash let equal = equal end) let merge_maps acc b = Sy.Map.merge (fun sy a b -> match a, b with | None, None -> assert false | Some _, None -> a | _ -> b ) acc b let free_vars = let rec free_rec acc f = match view f with | Literal a -> Literal.LT.vars_of a acc | Unit(f1,f2) -> free_rec (free_rec acc f1) f2 | Clause(f1,f2,_) -> free_rec (free_rec acc f1) f2 | Lemma {binders = binders; main = f} | Skolem {binders = binders; main = f} -> let mp = free_rec Sy.Map.empty f in let mp = Sy.Map.filter (fun sy _ -> not (Sy.Map.mem sy binders)) mp in merge_maps mp acc | Let {let_subst = (subst, _); let_term = t; let_f = lf} -> let mp = free_rec Sy.Map.empty lf in let mp = Term.vars_of t mp in let mp = Sy.Map.fold (fun sy t mp -> if Sy.Map.mem sy mp then (* 'let' bindings are removed since they are mapped to fresh terms 'vars' that are not nrmalized are replaced with the vars of their normal form w.r.t. subst *) Term.vars_of t (Sy.Map.remove sy mp) else mp ) subst mp in merge_maps mp acc in fun f -> free_rec Sy.Map.empty f let type_variables f = let rec aux acc f = match view f with | Unit(f1,f2) | Clause(f1,f2,_) -> aux (aux acc f1) f2 | Lemma lem | Skolem lem -> aux acc lem.main | Let llet -> aux acc llet.let_f | Literal a -> Term.Set.fold (fun t z -> Ty.Svty.union z (T.vty_of t)) (Literal.LT.terms_nonrec a) acc in Ty.Svty.fold (fun i z -> Ty.Set.add (Ty.Tvar {Ty.v=i; value = None}) z) (aux Ty.Svty.empty f) Ty.Set.empty exception Particuar_instance of Sy.t * Term.t let eventual_particular_inst = let rec aux v tv f = match view f with | Unit _ | Lemma _ | Skolem _ | Let _ -> () | Clause(f1, f2,_) -> aux v tv f1; aux v tv f2 | Literal a -> begin match Literal.LT.view a with | Literal.Distinct (false, [a;b]) when Term.equal tv a -> if not (Sy.Map.mem v (T.vars_of b Sy.Map.empty)) then raise (Particuar_instance (v, b)) | Literal.Distinct (false, [a;b]) when Term.equal tv b -> if not (Sy.Map.mem v (T.vars_of a Sy.Map.empty)) then raise (Particuar_instance (v, a)) | Literal.Pred (t, is_neg) when Term.equal tv t -> raise (Particuar_instance (v, if is_neg then T.vrai else T.faux)) | _ -> () end in fun binders free_vty f -> match free_vty with | _::_ -> None | [] -> match Sy.Map.bindings binders with | [] -> assert false | _::_::_ -> None | [v, (ty,_)] -> try aux v (Term.make v [] ty) f; None with Particuar_instance (x, t) -> Some (Sy.Map.singleton x t, Ty.esubst) let resolution_of_literal a binders free_vty acc = match Literal.LT.view a with | Literal.Pred(t, _) -> let cond = Ty.Svty.subset free_vty (Term.vty_of t) && let vars = Term.vars_of t Symbols.Map.empty in Symbols.Map.for_all (fun sy ty -> Sy.Map.mem sy vars) binders in if cond then Term.Set.add t acc else acc | _ -> acc let rec resolution_of_disj is_back f binders free_vty acc = match view f with | Literal a -> resolution_of_literal a binders free_vty acc | Clause(g,f, true) -> if is_back then resolution_of_disj is_back f binders free_vty acc else resolution_of_disj is_back g binders free_vty acc | _ -> acc let rec resolution_of_toplevel_conj is_back f binders free_vty acc = match view f with | Unit(f1, f2) -> resolution_of_toplevel_conj is_back f2 binders free_vty (resolution_of_toplevel_conj is_back f1 binders free_vty acc) | _ -> resolution_of_disj is_back f binders free_vty acc let sub_terms_of_formula f = let rec aux f acc = match view f with | Literal a -> Term.Set.union acc (Literal.LT.terms_rec a) | Unit(f1, f2) -> aux f2 (aux f1 acc) | Clause(f1, f2, _) -> aux f2 (aux f1 acc) | Skolem q | Lemma q -> aux q.main acc | Let llet -> Term.subterms (aux llet.let_f acc) llet.let_term in aux f Term.Set.empty (* unification/matching like function, to detect when a backward triggers is too permessive (general) *) let cand_is_more_general cand other = let rec matches cand other = match Term.view cand, Term.view other with | {T.f=Sy.Var _}, _ -> () | {T.f=f1; xs=xs1}, {T.f=f2; xs=xs2} when Sy.equal f1 f2 -> List.iter2 matches xs1 xs2 | _ -> raise Exit in try matches cand other; true with Exit -> false let resolution_triggers is_back f name binders free_vty = let free_vty = Ty.Set.fold (fun ty svty -> match ty with | Ty.Tvar {Ty.v; value = None} -> Ty.Svty.add v svty | _ -> assert false )free_vty Ty.Svty.empty in let cand = resolution_of_toplevel_conj is_back f binders free_vty Term.Set.empty in let others = Term.Set.filter (fun t -> not (Term.Set.mem t cand)) (sub_terms_of_formula f) in Term.Set.fold (fun t acc -> if Term.Set.exists (cand_is_more_general t) others then acc else { content = [t]; hyp = []; semantic = []; depth = (Term.view t).Term.depth; from_user = false; guard = None } :: acc )cand [] let mk_forall = let env = F_Htbl.create 101 in (*fun up bv trs f name id ->*) fun name loc binders triggers f id ext_free -> let free_vty = type_variables f in (* type variables of f*) let free_v_f = free_vars f in (* free variables of f *) let binders = (* ignore binders that are not used in f *) Sy.Map.filter (fun sy _ -> Sy.Map.mem sy free_v_f) binders in if Sy.Map.is_empty binders && Ty.Set.is_empty free_vty then (* not quantified ==> should fix save-used-context to be able to save "non-quantified axioms", or use a cache to save the name of axioms as labels, but they should be unique in this case *) f else let bkw_trs = lazy (resolution_triggers true f name binders free_vty) in let frw_trs = lazy (resolution_triggers false f name binders free_vty) in let free_v, free_vty = match ext_free with | Some (fv, fv_ty) -> fv, fv_ty | None -> let free_v = (* compute free vars (as terms) of f *) Sy.Map.fold (fun sy ty fv -> if Sy.Map.mem sy binders then fv else (Term.make sy [] ty) ::fv) free_v_f [] in free_v, Ty.Set.elements free_vty in let simple_inst = eventual_particular_inst binders free_vty f in let new_q = { name = name; backward_triggers = bkw_trs; forward_triggers = frw_trs; simple_inst = simple_inst; main = f; triggers = triggers; binders = binders; free_v = free_v; free_vty = free_vty; loc = loc } in try let lem = F_Htbl.find env f in let q = match view lem with Lemma q -> q | _ -> assert false in assert (equal q.main f (* should be true *)); if not (equal_quant q new_q) then raise Exit; if debug_warnings () then eprintf "[warning] (sub) axiom %s replaced with %s@." name q.name; lem with Not_found | Exit -> let sko = {new_q with main = mk_not f} in let res = make (Lemma new_q) (Skolem sko) (size f) id in F_Htbl.add env f res; res let mk_exists name loc binders triggers f id ext_free = mk_not (mk_forall name loc binders triggers (mk_not f) id ext_free) (* forall up. let bv = t in f *) let mk_let _up bv t f id = let {Term.ty=ty} = Term.view t in let up = Term.vars_of t Sy.Map.empty in let up = Sy.Map.fold (fun sy ty acc -> (Term.make sy [] ty)::acc) up [] in let subst = Sy.Map.add bv (T.make (Sy.fresh "_let") up ty) Sy.Map.empty in make (Let{let_var=bv; let_subst=(subst, Ty.esubst); let_term=t; let_f=f}) (Let{let_var=bv; let_subst=(subst, Ty.esubst); let_term=t; let_f=mk_not f}) (size f) id let mk_and f1 f2 is_impl id = if equal f1 (mk_not f2) then faux else if equal f1 f2 then f1 else if equal f1 vrai then f2 else if equal f2 vrai then f1 else if (equal f1 faux) || (equal f2 faux) then faux else let f1, f2 = if is_impl || compare f1 f2 < 0 then f1, f2 else f2, f1 in let size = size f1 + size f2 in make (Unit(f1,f2)) (Clause(mk_not f1,mk_not f2,is_impl)) size id let mk_or f1 f2 is_impl id = if equal f1 (mk_not f2) then vrai else if equal f1 f2 then f1 else if equal f1 faux then f2 else if equal f2 faux then f1 else if equal f1 vrai || equal f2 vrai then vrai else let f1, f2 = if is_impl || compare f1 f2 < 0 then f1, f2 else f2, f1 in let size = size f1 + size f2 in make (Clause(f1,f2,is_impl)) (Unit(mk_not f1,mk_not f2)) size id let mk_imp f1 f2 id = mk_or (mk_not f1) f2 true id (* using simplifications of mk_or and mk_and is not always efficient !! *) let mk_iff f1 f2 id = (* try to interpret iff as a double implication *) let a = mk_or (mk_not f1) f2 true id in let b = mk_or (mk_not f2) f1 true id in mk_and a b false id let translate_eq_to_iff s t = (T.view s).T.ty == Ty.Tbool && not (T.equal s T.vrai || T.equal s T.faux || T.equal t T.vrai ||T.equal t T.faux) let mk_lit a id = match Literal.LT.view a with | Literal.Eq(s,t) when translate_eq_to_iff s t -> let a1 = Literal.LT.mk_pred s false in let a2 = Literal.LT.mk_pred t false in let f1 = make (Literal a1) (Literal (Literal.LT.neg a1)) 1 id in let f2 = make (Literal a2) (Literal (Literal.LT.neg a2)) 1 id in mk_iff f1 f2 id | Literal.Distinct(false,[s;t]) when translate_eq_to_iff s t -> let a1 = Literal.LT.mk_pred s false in let a2 = Literal.LT.mk_pred t false in let f1 = make (Literal a1) (Literal (Literal.LT.neg a1)) 1 id in let f2 = make (Literal a2) (Literal (Literal.LT.neg a2)) 1 id in mk_not (mk_iff f1 f2 id) | _ -> make (Literal a) (Literal (Literal.LT.neg a)) 1 id let mk_if t f2 f3 id = let lit = mk_lit (Literal.LT.mk_pred t false) id in mk_or (mk_and lit f2 true id) (mk_and (mk_not lit) f3 true id) false id let no_capture_issue s_t binders = true (* TODO *) module Set = Set.Make(struct type t'=t type t=t' let compare=compare end) module Map = Map.Make(struct type t'=t type t=t' let compare=compare end) let apply_subst_trigger subst ({content; guard} as tr) = {tr with content = List.map (T.apply_subst subst) content; guard = match guard with | None -> guard | Some g -> Some (Literal.LT.apply_subst subst g) } (* this function should only be applied with ground substitutions *) let rec apply_subst = fun subst ((f, id) as ff) -> let {pos=p;neg=n;size=s} = iview f in let sp, sn, same = iapply_subst subst p n in if same then ff else match sp with | Literal a -> mk_lit a id (* this may simplifies the res *) | Unit (f1, f2) -> let is_impl = match sn with Clause(_,_,b) -> b | _ -> assert false in mk_and f1 f2 is_impl id (* this may simplifies the res *) | Clause (f1,f2,is_impl) -> mk_or f1 f2 is_impl id (* this may simplifies the res *) | Lemma q -> mk_forall q.name q.loc q.binders q.triggers q.main id (Some (q.free_v, q.free_vty)) | Skolem q -> mk_exists q.name q.loc q.binders q.triggers q.main id (Some (q.free_v, q.free_vty)) | _ -> make sp sn s id and iapply_subst ((s_t,s_ty) as subst) p n = match p, n with | Literal a, Literal _ -> let sa = Literal.LT.apply_subst subst a in let nsa = Literal.LT.neg sa in if a == sa then p, n, true else Literal sa, Literal nsa , false | Lemma lem, Skolem sko | Skolem sko, Lemma lem -> let { main = f; triggers = trs; binders = binders; free_v = fr_v; free_vty = fr_vty } = lem in assert (no_capture_issue s_t binders); let s_t = Sy.Map.fold (fun sy _ s_t -> Sy.Map.remove sy s_t) binders s_t in let s_t = (* discard the variables of s_t that are not in free_v *) List.fold_left (fun s_t' tv -> match T.view tv with | {T.f=(Sy.Var _) as x; xs = []} when Sy.Map.mem x s_t -> Sy.Map.add x (Sy.Map.find x s_t) s_t' | _ -> s_t' )Sy.Map.empty fr_v in (* should do the same filtering for fr_vty *) if (Sy.Map.is_empty s_t) && (Ty.M.is_empty s_ty) then p, n, true (* (s_t, s_ty) does not apply *) else let subst = s_t , s_ty in let f = apply_subst subst f in let trs = List.map (apply_subst_trigger subst) trs in let binders = Sy.Map.fold (fun sy (ty,i) bders -> let ty' = Ty.apply_subst s_ty ty in if Ty.compare ty ty' = 0 then bders else Sy.Map.add sy (ty', i) bders )binders binders in let fr_v = List.rev (List.rev_map (T.apply_subst subst) fr_v) in let fr_vty = List.rev (List.rev_map (Ty.apply_subst s_ty) fr_vty) in let lem = {lem with main = f; triggers = trs; binders = binders; free_v = fr_v; free_vty = fr_vty } in let slem = Lemma lem in let ssko = Skolem {lem with main = mk_not f} in (match p, n with | Lemma _, Skolem _ -> slem, ssko, false (* a lot of cmp needed to hcons*) | Skolem _, Lemma _ -> ssko, slem, false | _ -> assert false) | Unit(f1, f2), Clause(_,_, is_impl) -> let sf1 = apply_subst subst f1 in let sf2 = apply_subst subst f2 in if sf1 == f1 && sf2 == f2 then p, n, true else Unit(sf1, sf2), Clause(mk_not sf1, mk_not sf2, is_impl), false | Clause(f1, f2, is_impl), _ -> let sf1 = apply_subst subst f1 in let sf2 = apply_subst subst f2 in if sf1 == f1 && sf2 == f2 then p, n, true else Clause(sf1, sf2, is_impl), Unit(mk_not sf1, mk_not sf2), false | Let ({let_subst = s; let_term = lterm; let_f = lf} as e), Let _ -> let lterm = T.apply_subst subst lterm in let se = { e with let_subst = T.union_subst s subst; let_term = lterm } in let sne = { se with let_f = mk_not lf } in Let se, Let sne, false | _ -> assert false let add_label lbl f = match view f with | Literal a -> Literal.LT.add_label lbl a; Literal.LT.add_label lbl (Literal.LT.neg a) | _ -> () let label f = match view f with | Literal l -> Literal.LT.label l | _ -> Hstring.empty let label_model h = try Pervasives.(=) (String.sub (Hstring.view h) 0 6) "model:" with Invalid_argument _ -> false let is_in_model f = match view f with | Literal l -> label_model (Literal.LT.label l) || Literal.LT.is_in_model l | _ -> false let ground_terms_rec = let rec terms acc f = match view f with | Literal a -> let s = T.Set.filter (fun t-> Sy.Map.is_empty (T.vars_of t Sy.Map.empty) && Ty.Svty.is_empty (T.vty_of t) ) (Literal.LT.terms_rec a) in T.Set.union s acc | Lemma {main = f} | Skolem {main = f} -> terms acc f | Unit(f1,f2) -> terms (terms acc f1) f2 | Clause(f1,f2,_) -> terms (terms acc f1) f2 | Let {let_term=t; let_f=lf} -> let st = T.Set.filter (fun t-> Sy.Map.is_empty (T.vars_of t Sy.Map.empty) && Ty.Svty.is_empty (T.vty_of t)) (Term.subterms Term.Set.empty t) in terms (T.Set.union st acc) lf in terms T.Set.empty let skolemize {main=f; binders=binders; free_v=free_v; free_vty=free_vty} = let tyvars = ignore (flush_str_formatter ()); List.iter (fun ty -> assert (Ty.Svty.is_empty (Ty.vty_of ty)); fprintf str_formatter "<%a>" Ty.print ty ) free_vty; flush_str_formatter () in let mk_sym cpt s = (* garder le suffixe "__" car cela influence l'ordre *) Sy.name (Format.sprintf "!?__%s%s!%d" s tyvars cpt) in let sbt = Symbols.Map.fold (fun x (ty,i) m -> Sy.Map.add x (T.make (mk_sym i "_sko") free_v ty) m) binders Sy.Map.empty in apply_subst (sbt, Ty.esubst) f let apply_subst s f = if Options.timers() then try Timers.exec_timer_start Timers.M_Formula Timers.F_apply_subst; let res = apply_subst s f in Timers.exec_timer_pause Timers.M_Formula Timers.F_apply_subst; res with e -> Timers.exec_timer_pause Timers.M_Formula Timers.F_apply_subst; raise e else apply_subst s f let max_term_depth f = let rec aux f mx = match view f with | Literal a -> T.Set.fold (fun t mx -> max mx (T.view t).T.depth) (Literal.LT.terms_nonrec a) mx | Clause(f1, f2,_) | Unit(f1, f2) -> aux f2 (aux f1 mx) | Lemma q | Skolem q -> aux q.main mx | Let q -> max (aux q.let_f mx) (T.view q.let_term).T.depth in aux f 0 let name_of_lemma f = match view f with | Lemma {name} -> name | _ -> assert false let name_of_lemma_opt opt = match opt with | None -> "(Lemma=None)" | Some f -> name_of_lemma f alt-ergo-free-2.0.0/lib/structures/explanation.ml0000664000175000017500000001241313430774474017623 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Format open Options module F = Formula type exp = | Literal of Literal.LT.t | Fresh of int | Bj of F.t | Dep of F.t module S = Set.Make (struct type t = exp let compare a b = match a,b with | Fresh i1, Fresh i2 -> i1 - i2 | Literal a , Literal b -> Literal.LT.compare a b | Dep e1 , Dep e2 -> Formula.compare e1 e2 | Bj e1 , Bj e2 -> Formula.compare e1 e2 | Literal _, _ -> -1 | _, Literal _ -> 1 | Fresh _, _ -> -1 | _, Fresh _ -> 1 | Dep _, _ -> 1 | _, Dep _ -> -1 end) let is_empty t = S.is_empty t type t = S.t let empty = S.empty let union s1 s2 = if s1 == s2 then s1 else S.union s1 s2 let singleton e = S.singleton e let mem e s = S.mem e s let remove e s = if S.mem e s then S.remove e s else raise Not_found let iter_atoms f s = S.iter f s let fold_atoms f s acc = S.fold f s acc (* TODO : XXX : We have to choose the smallest ??? *) let merge s1 s2 = s1 let fresh_exp = let r = ref (-1) in fun () -> incr r; Fresh !r let remove_fresh fe s = if S.mem fe s then Some (S.remove fe s) else None let add_fresh fe s = S.add fe s let print fmt ex = if Options.debug_explanations () then begin fprintf fmt "{"; S.iter (function | Literal a -> fprintf fmt "{Literal:%a}, " Literal.LT.print a | Fresh i -> Format.fprintf fmt "{Fresh:%i}" i; | Dep f -> Format.fprintf fmt "{Dep:%a}" Formula.print f | Bj f -> Format.fprintf fmt "{BJ:%a}" Formula.print f ) ex; fprintf fmt "}" end let print_proof fmt s = S.iter (fun e -> match e with | Dep f -> Format.fprintf fmt " %a@." F.print f | Bj f -> assert false (* XXX or same as Dep ? *) | Fresh i -> assert false | Literal a -> assert false ) s let formulas_of s = S.fold (fun e acc -> match e with | Dep f | Bj f -> F.Set.add f acc | Fresh _ -> acc | Literal a -> assert false (*TODO*) ) s F.Set.empty let bj_formulas_of s = S.fold (fun e acc -> match e with | Bj f -> F.Set.add f acc | Dep _ | Fresh _ -> acc | Literal a -> assert false (*TODO*) ) s F.Set.empty let rec literals_of_acc lit fs f acc = match F.view f with | F.Literal _ -> if lit then f :: acc else acc | F.Unit (f1,f2) -> let acc = literals_of_acc false fs f1 acc in literals_of_acc false fs f2 acc | F.Clause (f1, f2, _) -> let acc = literals_of_acc true fs f1 acc in literals_of_acc true fs f2 acc | F.Lemma _ -> acc | F.Skolem {F.main = f1} | F.Let {F.let_f = f1} -> literals_of_acc true fs f1 acc let literals_of ex = let fs = formulas_of ex in F.Set.fold (literals_of_acc true fs) fs [] module MI = Map.Make (struct type t = int let compare = compare end) let literals_ids_of ex = List.fold_left (fun acc f -> let i = F.id f in let m = try MI.find i acc with Not_found -> 0 in MI.add i (m + 1) acc ) MI.empty (literals_of ex) let make_deps sf = Formula.Set.fold (fun l acc -> S.add (Bj l) acc) sf S.empty let has_no_bj s = try S.iter (function Bj _ -> raise Exit | _ -> ())s; true with Exit -> false let compare = S.compare let subset = S.subset alt-ergo-free-2.0.0/lib/structures/explanation.mli0000664000175000017500000000573413430774474020004 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) type t type exp = | Literal of Literal.LT.t | Fresh of int | Bj of Formula.t | Dep of Formula.t val empty : t val is_empty : t -> bool val mem : exp -> t -> bool val singleton : exp -> t val union : t -> t -> t val merge : t -> t -> t val iter_atoms : (exp -> unit) -> t -> unit val fold_atoms : (exp -> 'a -> 'a ) -> t -> 'a -> 'a val fresh_exp : unit -> exp val remove_fresh : exp -> t -> t option val remove : exp -> t -> t val add_fresh : exp -> t -> t val print : Format.formatter -> t -> unit val print_proof : Format.formatter -> t -> unit val formulas_of : t -> Formula.Set.t val bj_formulas_of : t -> Formula.Set.t module MI : Map.S with type key = int val literals_ids_of : t -> int MI.t val make_deps : Formula.Set.t -> t val has_no_bj : t -> bool val compare : t -> t -> int val subset : t -> t -> bool alt-ergo-free-2.0.0/lib/structures/profiling.mli0000664000175000017500000000374113430774474017447 0ustar mimi(******************************************************************************) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the license indicated *) (* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) (* present, please contact us to clarify licensing. *) (* *) (******************************************************************************) type t val init : unit -> unit val decision : int -> string -> unit val assume : int -> unit val query : unit -> unit val instantiation : int -> unit val instances : 'a list -> unit val bool_conflict : unit -> unit val theory_conflict : unit -> unit (* each boolean is true for Boolean conflict and false for Theory conflict *) val bcp_conflict : bool -> bool -> unit (* the boolean is true for Boolean red/elim and false for Theory red/elim *) val red : bool -> unit val elim : bool -> unit (* reset decision and matching levels *) val reset_dlevel : int -> unit val reset_ilevel : int -> unit (* record when the axioms are instantiated. Bool tells whether the instance is kept or removed by the selector function. The formula is the instance that has been generated *) val new_instance_of : string -> Formula.t -> Loc.t -> bool -> unit val conflicting_instance : string -> Loc.t -> unit val register_produced_terms : string -> Loc.t -> Term.Set.t -> (* consumed *) Term.Set.t -> (* all terms of the instance *) Term.Set.t -> (* produced *) Term.Set.t -> (* produced that are new *) unit val print : bool -> int64 -> Timers.t -> Format.formatter -> unit val switch : unit -> unit alt-ergo-free-2.0.0/lib/structures/fpa_rounding.ml0000664000175000017500000002044413430774474017757 0ustar mimi(******************************************************************************) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the license indicated *) (* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) (* present, please contact us to clarify licensing. *) (* *) (******************************************************************************) module Sy = Symbols module Hs = Hstring module T = Term open Format open Options module Q = Numbers.Q module Z = Numbers.Z let is_rounding_mode t = Options.use_fpa() && match (T.view t).T.ty with | Ty.Tsum (hs, _) -> String.compare (Hs.view hs) "fpa_rounding_mode" = 0 | _ -> false let fpa_rounding_mode = let mode_ty = Hs.make "fpa_rounding_mode" in let mode_constrs = [ (* standards *) Hs.make "NearestTiesToEven"; Hs.make "NearestTiesToAway"; Hs.make "ToZero"; Hs.make "Up"; Hs.make "Down"; (* non standards *) Hs.make "Aw"; Hs.make "Od"; Hs.make "Nodd"; Hs.make "Nz"; Hs.make "Nd"; Hs.make "Nu" ] in Ty.Tsum(mode_ty, mode_constrs) (* why3/standard rounding modes*) let _NearestTiesToEven__rounding_mode = T.make (Sy.Name(Hs.make "NearestTiesToEven", Sy.Constructor)) [] fpa_rounding_mode (** ne in Gappa: to nearest, tie breaking to even mantissas*) let _ToZero__rounding_mode = T.make (Sy.Name(Hs.make "ToZero", Sy.Constructor)) [] fpa_rounding_mode (** zr in Gappa: toward zero *) let _Up__rounding_mode = T.make (Sy.Name(Hs.make "Up", Sy.Constructor)) [] fpa_rounding_mode (** up in Gappa: toward plus infinity *) let _Down__rounding_mode = T.make (Sy.Name(Hs.make "Down", Sy.Constructor)) [] fpa_rounding_mode (** dn in Gappa: toward minus infinity *) let _NearestTiesToAway__rounding_mode = T.make (Sy.Name(Hs.make "NearestTiesToAway", Sy.Constructor)) [] fpa_rounding_mode (** na : to nearest, tie breaking away from zero *) (* additional Gappa rounding modes *) let _Aw__rounding_mode = T.make (Sy.Name(Hs.make "Aw", Sy.Constructor)) [] fpa_rounding_mode (** aw in Gappa: away from zero **) let _Od__rounding_mode = T.make (Sy.Name(Hs.make "Od", Sy.Constructor)) [] fpa_rounding_mode (** od in Gappa: to odd mantissas *) let _No__rounding_mode = T.make (Sy.Name(Hs.make "No", Sy.Constructor)) [] fpa_rounding_mode (** no in Gappa: to nearest, tie breaking to odd mantissas *) let _Nz__rounding_mode = T.make (Sy.Name(Hs.make "Nz", Sy.Constructor)) [] fpa_rounding_mode (** nz in Gappa: to nearest, tie breaking toward zero *) let _Nd__rounding_mode = T.make (Sy.Name(Hs.make "Nd", Sy.Constructor)) [] fpa_rounding_mode (** nd in Gappa: to nearest, tie breaking toward minus infinity *) let _Nu__rounding_mode = T.make (Sy.Name(Hs.make "Nu", Sy.Constructor)) [] fpa_rounding_mode (** nu in Gappa: to nearest, tie breaking toward plus infinity *) (** Hepler functions **) let mult_x_by_2_pow_n x n = (* Q.mul_2exp does not support negative i according to Cody ? *) let res1 = if n >= 0 then Q.mult_2exp x n else Q.div_2exp x (-n) in let res2 = Q.mult res1 Q.one in (* Bug in Zarith according to Cody ? *) assert (Q.equal res1 res2); res2 let div_x_by_2_pow_n x n = mult_x_by_2_pow_n x (-n) let two = Q.from_int 2 let two_z = Z.from_int 2 let half = Q.div Q.one two type rounding_mode = (* five standard/why3 fpa rounding modes *) | NearestTiesToEven (*ne in Gappa: to nearest, tie breaking to even mantissas*) | ToZero (* zr in Gappa: toward zero *) | Up (* up in Gappa: toward plus infinity *) | Down (* dn in Gappa: toward minus infinity *) | NearestTiesToAway (* na : to nearest, tie breaking away from zero *) (* additional Gappa rounding modes *) | Aw (* aw in Gappa: away from zero **) | Od (* od in Gappa: to odd mantissas *) | No (* no in Gappa: to nearest, tie breaking to odd mantissas *) | Nz (* nz in Gappa: to nearest, tie breaking toward zero *) | Nd (* nd in Gappa: to nearest, tie breaking toward minus infinity *) | Nu (* nu in Gappa: to nearest, tie breaking toward plus infinity *) (* Integer part of binary logarithm for NON-ZERO POSITIVE number *) let integer_log_2 = let rec aux m e = if Q.compare m two >= 0 then aux (div_x_by_2_pow_n m 1) (e+1) else if Q.compare m Q.one >= 0 then e else let () = assert (Q.compare_to_0 m > 0) in aux (mult_x_by_2_pow_n m 1) (e - 1) in fun m -> if Q.compare_to_0 m <= 0 then begin eprintf "integer_log_2 not defined for input (%a)@." Q.print m; assert false end; let res = aux m 0 in (*eprintf "found that integer_log_2 of %a is %d@." Q.print m res;*) assert (Q.compare (mult_x_by_2_pow_n Q.one res) m <= 0); assert (Q.compare (mult_x_by_2_pow_n Q.one (res+1)) m > 0); res let signed_one y = let tmp = Q.sign y in assert (tmp <> 0); if tmp > 0 then Z.one else Z.m_one let round_big_int mode y = match mode with | Up -> Q.num (Q.ceiling y) | Down -> Q.num (Q.floor y) | ToZero -> Q.truncate y | NearestTiesToEven -> let z = Q.truncate y in let diff = Q.abs (Q.sub y (Q.from_z z)) in if Q.sign diff = 0 then z else let tmp = Q.compare diff half in if tmp < 0 then z else if tmp > 0 then Z.add z (signed_one y) else if Z.testbit z 0 then Z.add z (signed_one y) else z | NearestTiesToAway -> let z = Q.truncate y in let diff = Q.abs (Q.sub y (Q.from_z z)) in if Q.sign diff = 0 then z else if Q.compare diff half < 0 then z else Z.add z (signed_one y) | Aw | Od | No | Nz | Nd | Nu -> assert false let to_mantissa_exp prec exp mode x = let sign_x = Q.sign x in assert ((sign_x = 0) == Q.equal x Q.zero); if sign_x = 0 then Z.zero, 1 else let abs_x = Q.abs x in let e = integer_log_2 abs_x in let e' = max (e + 1 - prec) (- exp) in let y = mult_x_by_2_pow_n x (-e') in let r_y = round_big_int mode y in r_y, e' let mode_of_term t = let eq_t s = Term.equal s t in if eq_t _NearestTiesToEven__rounding_mode then NearestTiesToEven else if eq_t _ToZero__rounding_mode then ToZero else if eq_t _Up__rounding_mode then Up else if eq_t _Down__rounding_mode then Down else if eq_t _NearestTiesToAway__rounding_mode then NearestTiesToAway else if eq_t _Aw__rounding_mode then Aw else if eq_t _Od__rounding_mode then Od else if eq_t _No__rounding_mode then No else if eq_t _Nz__rounding_mode then Nz else if eq_t _Nd__rounding_mode then Nd else if eq_t _Nu__rounding_mode then Nu else begin eprintf "bad rounding mode %a@." Term.print t; assert false end let int_of_term t = match Term.view t with {Term.f = Symbols.Int n} -> let n = Hstring.view n in let n = try int_of_string n with e -> eprintf "error when trying to convert %s to an int@." n; assert false in n (* ! may be negative or null *) | _ -> eprintf "error: the given term %a is not an integer@." Term.print t; assert false module MQ = Map.Make (struct type t = Term.t * Term.t * Term.t * Q.t let compare (prec1, exp1, mode1, x1) (prec2, exp2, mode2, x2) = let c = Q.compare x1 x2 in if c <> 0 then c else let c = Term.compare prec1 prec2 in if c <> 0 then c else let c = Term.compare exp1 exp2 in if c <> 0 then c else Term.compare mode1 mode2 end) let cache = ref MQ.empty (* Compute the floating-point approximation of a rational number *) let float_of_rational prec exp mode x = (* prec = 24 and exp = 149 for 32 bits (or exp = -149 ???) *) let input = (prec, exp, mode, x) in try MQ.find input !cache with Not_found -> let mode = mode_of_term mode in let prec = int_of_term prec in let exp = int_of_term exp in let m, e = to_mantissa_exp prec exp mode x in let res = mult_x_by_2_pow_n (Q.from_z m) e in cache := MQ.add input (res, m, e) !cache; res, m, e let round_to_integer mode q = Q.from_z (round_big_int (mode_of_term mode) q) alt-ergo-free-2.0.0/lib/structures/parsed.ml0000664000175000017500000001126413430774474016562 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Format open Options type constant = | ConstBitv of string | ConstInt of string | ConstReal of Num.num | ConstTrue | ConstFalse | ConstVoid type pp_infix = | PPand | PPor | PPimplies | PPiff | PPlt | PPle | PPgt | PPge | PPeq | PPneq | PPadd | PPsub | PPmul | PPdiv | PPmod type pp_prefix = | PPneg | PPnot type ppure_type = | PPTint | PPTbool | PPTreal | PPTunit | PPTbitv of int | PPTvarid of string * Loc.t | PPTexternal of ppure_type list * string * Loc.t type axiom_kind = Default | Propagator type lexpr = { pp_loc : Loc.t; pp_desc : pp_desc } and pp_desc = | PPvar of string | PPapp of string * lexpr list | PPmapsTo of string * lexpr | PPinInterval of lexpr * bool * lexpr * lexpr * bool (* bool = true <-> interval is_open *) | PPdistinct of lexpr list | PPconst of constant | PPinfix of lexpr * pp_infix * lexpr | PPprefix of pp_prefix * lexpr | PPget of lexpr * lexpr | PPset of lexpr * lexpr * lexpr | PPdot of lexpr * string | PPrecord of (string * lexpr) list | PPwith of lexpr * (string * lexpr) list | PPextract of lexpr * lexpr * lexpr | PPconcat of lexpr * lexpr | PPif of lexpr * lexpr * lexpr | PPforall of (string * ppure_type) list * (lexpr list * bool) list * lexpr list * lexpr | PPexists of (string * ppure_type) list * (lexpr list * bool) list * lexpr list * lexpr | PPforall_named of (string * string * ppure_type) list * (lexpr list * bool) list * lexpr list * lexpr | PPexists_named of (string * string * ppure_type) list * (lexpr list * bool) list * lexpr list * lexpr | PPnamed of string * lexpr | PPlet of string * lexpr * lexpr | PPcheck of lexpr | PPcut of lexpr | PPcast of lexpr * ppure_type (* Declarations. *) type plogic_type = | PPredicate of ppure_type list | PFunction of ppure_type list * ppure_type type name_kind = Symbols.name_kind type body_type_decl = | Record of (string * ppure_type) list (* lbl : t *) | Enum of string list | Abstract type decl = | Theory of Loc.t * string * string * decl list | Axiom of Loc.t * string * axiom_kind * lexpr | Rewriting of Loc.t * string * lexpr list | Goal of Loc.t * string * lexpr | Logic of Loc.t * name_kind * (string * string) list * plogic_type | Predicate_def of Loc.t * (string * string) * (Loc.t * string * ppure_type) list * lexpr | Function_def of Loc.t * (string * string) * (Loc.t * string * ppure_type) list * ppure_type * lexpr | TypeDecl of Loc.t * string list * string * body_type_decl type file = decl list alt-ergo-free-2.0.0/lib/structures/commands.mli0000664000175000017500000000520413430774474017253 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Format open Parsed open Typed type th_elt = { th_name : string; th_form : Formula.t; extends : Typed.theories_extensions; axiom_kind : axiom_kind; } (* Sat entry *) type sat_decl_aux = | Assume of string * Formula.t * bool | PredDef of Formula.t * string (*name of the predicate*) | RwtDef of (Term.t rwt_rule) list | Query of string * Formula.t * Literal.LT.t list * goal_sort | ThAssume of th_elt type sat_tdecl = { st_loc : Loc.t; st_decl : sat_decl_aux } alt-ergo-free-2.0.0/lib/structures/errors.ml0000664000175000017500000001527513430774474016626 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Format type error = | BitvExtract of int*int | BitvExtractRange of int*int | ClashType of string | ClashLabel of string * string | ClashParam of string | TypeDuplicateVar of string | UnboundedVar of string | UnknownType of string | WrongArity of string * int | SymbAlreadyDefined of string | SymbUndefined of string | NotAPropVar of string | NotAPredicate of string | Unification of Ty.t * Ty.t | ShouldBeApply of string | WrongNumberofArgs of string | ShouldHaveType of Ty.t * Ty.t | ShouldHaveTypeIntorReal of Ty.t | ShouldHaveTypeInt of Ty.t | ShouldHaveTypeBitv of Ty.t | ArrayIndexShouldHaveTypeInt | ShouldHaveTypeArray | ShouldHaveTypeRecord of Ty.t | ShouldBeARecord | ShouldHaveLabel of string * string | NoLabelInType of Hstring.t * Ty.t | ShouldHaveTypeProp | NoRecordType of Hstring.t | DuplicateLabel of Hstring.t | WrongLabel of Hstring.t * Ty.t | WrongNumberOfLabels | Notrigger | CannotGeneralize | SyntaxError | ThExtError of string | ThSemTriggerError | WrongDeclInTheory (* this is a typing error *) exception Error of error * Loc.t exception Warning of error * Loc.t (* these two exception are used by the lexer and the parser *) exception Lexical_error of Loc.t * string exception Syntax_error of Loc.t * string let report fmt = function | BitvExtract(i,j) -> fprintf fmt "bitvector extraction malformed (%d>%d)" i j | BitvExtractRange(n,j) -> fprintf fmt "extraction out of range (%d>%d)" j n | ClashType s -> fprintf fmt "the type %s is already defined" s | ClashParam s -> fprintf fmt "parameter %s is bound twice" s | ClashLabel (s,t) -> fprintf fmt "the label %s already appears in type %s" s t | CannotGeneralize -> fprintf fmt "cannot generalize the type of this expression" | TypeDuplicateVar s -> fprintf fmt "duplicate type variable %s" s | UnboundedVar s -> fprintf fmt "unbounded variable %s" s | UnknownType s -> fprintf fmt "unknown type %s" s | WrongArity(s,n) -> fprintf fmt "the type %s has %d arguments" s n | SymbAlreadyDefined s -> fprintf fmt "the symbol %s is already defined" s | SymbUndefined s -> fprintf fmt "undefined symbol %s" s | NotAPropVar s -> fprintf fmt "%s is not a propositional variable" s | NotAPredicate s -> fprintf fmt "%s is not a predicate" s | Unification(t1,t2) -> fprintf fmt "%a and %a cannot be unified" Ty.print t1 Ty.print t2 | ShouldBeApply s -> fprintf fmt "%s is a function symbol, it should be apply" s | WrongNumberofArgs s -> fprintf fmt "Wrong number of arguments when applying %s" s | ShouldHaveType(ty1,ty2) -> fprintf fmt "this expression has type %a but is here used with type %a" Ty.print ty1 Ty.print ty2 | ShouldHaveTypeBitv t -> fprintf fmt "this expression has type %a but it should be a bitvector" Ty.print t | ShouldHaveTypeIntorReal t -> fprintf fmt "this expression has type %a but it should have type int or real" Ty.print t | ShouldHaveTypeInt t -> fprintf fmt "this expression has type %a but it should have type int" Ty.print t | ShouldHaveTypeArray -> fprintf fmt "this expression should have type farray" | ShouldHaveTypeRecord t -> fprintf fmt "this expression has type %a but it should have a record type" Ty.print t | ShouldBeARecord -> fprintf fmt "this expression should have a record type" | ShouldHaveLabel (s, a) -> fprintf fmt "this expression has type %s which has no label %s" s a | NoLabelInType (lb, ty) -> fprintf fmt "no label %s in type %a" (Hstring.view lb) Ty.print ty | ShouldHaveTypeProp -> fprintf fmt "this expression should have type prop" | NoRecordType s -> fprintf fmt "no record type has label %s" (Hstring.view s) | DuplicateLabel s -> fprintf fmt "label %s is defined several times" (Hstring.view s) | WrongLabel (s, ty) -> fprintf fmt "wrong label %s in type %a" (Hstring.view s) Ty.print ty | WrongNumberOfLabels -> fprintf fmt "wrong number of labels" | ArrayIndexShouldHaveTypeInt -> fprintf fmt "index of arrays should hava type int" | Notrigger -> fprintf fmt "No trigger for this lemma" | SyntaxError -> fprintf fmt "syntax error" | ThExtError s -> fprintf fmt "Theory extension %S not recognized" s | ThSemTriggerError -> fprintf fmt "Semantic triggers are only allowed inside Theories" | WrongDeclInTheory -> fprintf fmt "Currently, this kind of declarations are not allowed inside theories" let error e l = raise (Error(e,l)) let warning e l = raise (Warning(e,l)) alt-ergo-free-2.0.0/lib/structures/ty.ml0000664000175000017500000003332513430774474015742 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Hconsing open Format open Options type t = | Tint | Treal | Tbool | Tunit | Tvar of tvar | Tbitv of int | Text of t list * Hstring.t | Tfarray of t * t | Tnext of t | Tsum of Hstring.t * Hstring.t list | Trecord of trecord and tvar = { v : int ; mutable value : t option } and trecord = { mutable args : t list; name : Hstring.t; mutable lbs : (Hstring.t * t) list } exception TypeClash of t*t exception Shorten of t (*** pretty print ***) let print full = let h = Hashtbl.create 17 in let rec print fmt = function | Tint -> fprintf fmt "int" | Treal -> fprintf fmt "real" | Tbool -> fprintf fmt "bool" | Tunit -> fprintf fmt "unit" | Tbitv n -> fprintf fmt "bitv[%d]" n | Tvar{v=v ; value = None} -> fprintf fmt "'a_%d" v | Tvar{v=v ; value = Some (Trecord {args=l; name=n} as t) } -> if Hashtbl.mem h v then fprintf fmt "%a %s" print_list l (Hstring.view n) else (Hashtbl.add h v (); (*fprintf fmt "('a_%d->%a)" v print t *) print fmt t) | Tvar{v=v ; value = Some t} -> (*fprintf fmt "('a_%d->%a)" v print t *) print fmt t | Text(l, s) -> fprintf fmt "%a %s" print_list l (Hstring.view s) | Tfarray (t1, t2) -> fprintf fmt "(%a,%a) farray" print t1 print t2 | Tnext t -> fprintf fmt "%a next" print t | Tsum(s, _) -> fprintf fmt "%s" (Hstring.view s) | Trecord {args=lv; name=n; lbs=lbls} -> fprintf fmt "%a %s" print_list lv (Hstring.view n); if full then begin fprintf fmt " = {"; let first = ref true in List.iter (fun (s, t) -> fprintf fmt "%s%s : %a" (if !first then "" else "; ") (Hstring.view s) print t; first := false ) lbls; fprintf fmt "}" end and print_list fmt = function | [] -> () | [t] -> fprintf fmt "%a " print t | t::l -> fprintf fmt "(%a" print t; List.iter (fprintf fmt ", %a" print) l; fprintf fmt ")" in print, print_list let print_list = snd (print false) let print_full = fst (print true) let print = fst (print false) (* smart constructors *) let tunit = Text ([],Hstring.make "unit") let text l s = Text (l,Hstring.make s) let tsum s lc = Tsum (Hstring.make s, List.map Hstring.make lc) let trecord lv n lbs = let lbs = List.map (fun (l,ty) -> Hstring.make l, ty) lbs in let lbs = List.sort (fun (l1, _) (l2, _) -> Hstring.compare l1 l2) lbs in Trecord { args = lv; name = Hstring.make n; lbs = lbs} let rec shorten ty = match ty with | Tvar {value=None} -> ty | Tvar {value=Some(Tvar{value=None} as t')} -> t' | Tvar ({value=Some(Tvar t2)} as t1) -> t1.value <- t2.value; shorten ty | Tvar {v = n; value = Some t'} -> shorten t' | Text (l,s) -> let l, same = Lists.apply shorten l in if same then ty else Text(l,s) | Tfarray (t1,t2) -> let t1' = shorten t1 in let t2' = shorten t2 in if t1 == t1' && t2 == t2' then ty else Tfarray(t1', t2') | Trecord r -> r.args <- List.map shorten r.args; r.lbs <- List.map (fun (lb, ty) -> lb, shorten ty) r.lbs; ty | Tnext t1 -> let t1' = shorten t1 in if t1 == t1' then ty else Tnext t1' | Tint | Treal | Tbool | Tunit | Tbitv _ | Tsum (_, _) -> ty let fresh_var = let cpt = ref (-1) in fun () -> incr cpt; {v= !cpt ; value = None } let fresh_tvar () = Tvar (fresh_var ()) let fresh_empty_text = let cpt = ref (-1) in fun () -> incr cpt; text [] ("'_c"^(string_of_int !cpt)) let rec hash t = match t with | Tvar{v=v} -> v | Text(l,s) -> abs (List.fold_left (fun acc x-> acc*19 + hash x) (Hstring.hash s) l) | Tfarray (t1,t2) -> 19 * (hash t1) + 23 * (hash t2) | Trecord { args = args; name = s; lbs = lbs} -> let h = List.fold_left (fun h ty -> 27 * h + hash ty) (Hstring.hash s) args in let h = List.fold_left (fun h (lb, ty) -> 23 * h + 19 * (Hstring.hash lb) + hash ty) (abs h) lbs in abs h | Tsum (s, l) -> abs (Hstring.hash s) (*we do not hash constructors*) | _ -> Hashtbl.hash t let rec equal t1 t2 = match shorten t1 , shorten t2 with | Tvar{v=v1}, Tvar{v=v2} -> v1 = v2 | Text(l1, s1), Text(l2, s2) -> (try Hstring.equal s1 s2 && List.for_all2 equal l1 l2 with Invalid_argument _ -> false) | Tfarray (ta1, ta2), Tfarray (tb1, tb2) -> equal ta1 tb1 && equal ta2 tb2 | Tsum (s1, _), Tsum (s2, _) -> Hstring.equal s1 s2 | Trecord {args=a1;name=s1;lbs=l1}, Trecord {args=a2;name=s2;lbs=l2} -> begin try Hstring.equal s1 s2 && List.for_all2 equal a1 a2 && List.for_all2 (fun (l1, ty1) (l2, ty2) -> Hstring.equal l1 l2 && equal ty1 ty2) l1 l2 with Invalid_argument _ -> false end | Tint, Tint | Treal, Treal | Tbool, Tbool | Tunit, Tunit -> true | Tbitv n1, Tbitv n2 -> n1 =n2 | Tnext t1, Tnext t2 -> equal t1 t2 | _ -> false let rec compare t1 t2 = match shorten t1 , shorten t2 with | Tvar{v=v1} , Tvar{v=v2} -> Pervasives.compare v1 v2 | Tvar _, _ -> -1 | _ , Tvar _ -> 1 | Text(l1, s1) , Text(l2, s2) -> let c = Hstring.compare s1 s2 in if c<>0 then c else compare_list l1 l2 | Text _, _ -> -1 | _ , Text _ -> 1 | Tfarray (ta1,ta2), Tfarray (tb1,tb2) -> let c = compare ta1 tb1 in if c<>0 then c else compare ta2 tb2 | Tfarray _, _ -> -1 | _ , Tfarray _ -> 1 | Tsum(s1, _), Tsum(s2, _) -> Hstring.compare s1 s2 | Tsum _, _ -> -1 | _ , Tsum _ -> 1 | Trecord {args=a1;name=s1;lbs=l1},Trecord {args=a2;name=s2;lbs=l2} -> let c = Hstring.compare s1 s2 in if c <> 0 then c else let c = compare_list a1 a2 in if c <> 0 then c else let l1, l2 = List.map snd l1, List.map snd l2 in compare_list l1 l2 | Trecord _, _ -> -1 | _ , Trecord _ -> 1 | t1 , t2 -> Pervasives.compare t1 t2 and compare_list l1 l2 = match l1, l2 with | [] , [] -> 0 | [] , _ -> -1 | _ , [] -> 1 | x::ll1 , y::ll2 -> let c = compare x y in if c<>0 then c else compare_list ll1 ll2 let occurs {v=n} t = let rec occursrec = function Tvar {v=m} -> n=m | Text(l,_) -> List.exists occursrec l | Tfarray (t1,t2) -> occursrec t1 || occursrec t2 | _ -> false in occursrec t (*** destructive unification ***) let rec unify t1 t2 = let t1 = shorten t1 in let t2 = shorten t2 in match t1 , t2 with Tvar ({v=n;value=None} as tv1), Tvar {v=m;value=None} -> if n<>m then tv1.value <- Some t2 | _ , Tvar ({value=None} as tv) -> if (occurs tv t1) then raise (TypeClash(t1,t2)); tv.value <- Some t1 | Tvar ({value=None} as tv) , _ -> if (occurs tv t2) then raise (TypeClash(t1,t2)); tv.value <- Some t2 | Text(l1,s1) , Text(l2,s2) when Hstring.equal s1 s2 -> List.iter2 unify l1 l2 | Tfarray (ta1,ta2), Tfarray (tb1,tb2) -> unify ta1 tb1;unify ta2 tb2 | Trecord r1, Trecord r2 when Hstring.equal r1.name r2.name -> List.iter2 unify r1.args r2.args | Tsum(s1, _) , Tsum(s2, _) when Hstring.equal s1 s2 -> () | Tint, Tint | Tbool, Tbool | Treal, Treal | Tunit, Tunit -> () | Tbitv n , Tbitv m when m=n -> () | _ , _ -> raise (TypeClash(t1,t2)) (*** matching with a substitution mechanism ***) module M = Map.Make(struct type t=int let compare = Pervasives.compare end) type subst = t M.t let esubst = M.empty let rec matching s pat t = match pat , t with | Tvar {v=n;value=None} , _ -> (try if not (equal (M.find n s) t) then raise (TypeClash(pat,t)); s with Not_found -> M.add n t s) | Tvar {value=_}, _ -> raise (Shorten pat) | Text (l1,s1) , Text (l2,s2) when Hstring.equal s1 s2 -> List.fold_left2 matching s l1 l2 | Tfarray (ta1,ta2), Tfarray (tb1,tb2) -> matching (matching s ta1 tb1) ta2 tb2 | Trecord r1, Trecord r2 when Hstring.equal r1.name r2.name -> let s = List.fold_left2 matching s r1.args r2.args in List.fold_left2 (fun s (_, p) (_, ty) -> matching s p ty) s r1.lbs r2.lbs | Tsum (s1, _), Tsum (s2, _) when Hstring.equal s1 s2 -> s | Tint , Tint | Tbool , Tbool | Treal , Treal | Tunit, Tunit -> s | Tbitv n , Tbitv m when n=m -> s | _ , _ -> raise (TypeClash(pat,t)) let rec apply_subst s ty = match ty with | Tvar {v=n} -> (try M.find n s with Not_found -> ty) | Text (l,e) -> let l, same = Lists.apply (apply_subst s) l in if same then ty else Text(l, e) | Tfarray (t1,t2) -> let t1' = apply_subst s t1 in let t2' = apply_subst s t2 in if t1 == t1' && t2 == t2' then ty else Tfarray (t1', t2') | Trecord r -> let lbs, same1 = Lists.apply_right (apply_subst s) r.lbs in let args, same2 = Lists.apply (apply_subst s) r.args in if same1 && same2 then ty else Trecord {args = args; name = r.name; lbs = lbs} | Tnext t -> let t' = apply_subst s t in if t == t' then ty else Tnext t' | Tint | Treal | Tbool | Tunit | Tbitv _ | Tsum (_, _) -> ty let instantiate lvar lty ty = let s = List.fold_left2 (fun s x t -> match x with | Tvar {v=n} -> M.add n t s | _ -> assert false) M.empty lvar lty in apply_subst s ty let union_subst s1 s2 = M.fold (fun k x s2 -> M.add k x s2) (M.map (apply_subst s2) s1) s2 let compare_subst = M.compare Pervasives.compare let equal_subst = M.equal Pervasives.(=) let rec fresh ty subst = match ty with | Tvar {v=x} -> begin try M.find x subst, subst with Not_found -> let nv = Tvar (fresh_var()) in nv, M.add x nv subst end | Text (args, n) -> let args, subst = fresh_list args subst in Text (args, n), subst | Tfarray (ty1, ty2) -> let ty1, subst = fresh ty1 subst in let ty2, subst = fresh ty2 subst in Tfarray (ty1, ty2), subst | Trecord {args = args; name = n; lbs = lbs} -> let args, subst = fresh_list args subst in let lbs, subst = List.fold_right (fun (x,ty) (lbs, subst) -> let ty, subst = fresh ty subst in (x, ty)::lbs, subst) lbs ([], subst) in Trecord { args = args; name = n; lbs = lbs}, subst | Tnext ty -> let ty, subst = fresh ty subst in Tnext ty, subst | t -> t, subst and fresh_list lty subst = List.fold_right (fun ty (lty, subst) -> let ty, subst = fresh ty subst in ty::lty, subst) lty ([], subst) module Svty = Set.Make(struct type t = int let compare = Pervasives.compare end) module Set = Set.Make(struct type t' = t type t = t' let compare = compare end) let vty_of t = let rec vty_of_rec acc t = let t = shorten t in match t with | Tvar { v = i ; value = None } -> Svty.add i acc | Text(l,_) -> List.fold_left vty_of_rec acc l | Tfarray (t1,t2) -> vty_of_rec (vty_of_rec acc t1) t2 | Trecord {args = args; name = s; lbs = lbs} -> let acc = List.fold_left vty_of_rec acc args in List.fold_left (fun acc (_, ty) -> vty_of_rec acc ty) acc lbs | _ -> acc in vty_of_rec Svty.empty t let rec monomorphize ty = match ty with | Tint | Treal | Tbool | Tunit | Tbitv _ | Tsum _ -> ty | Text (tyl,hs) -> Text (List.map monomorphize tyl, hs) | Trecord {args = tylv; name = n; lbs = tylb} -> let m_tylv = List.map monomorphize tylv in let m_tylb = List.map (fun (lb, ty_lb) -> lb, monomorphize ty_lb) tylb in Trecord {args = m_tylv; name = n; lbs = m_tylb} | Tfarray (ty1,ty2) -> Tfarray (monomorphize ty1,monomorphize ty2) | Tnext ty -> Tnext (monomorphize ty) | Tvar {v=v; value=None} -> text [] ("'_c"^(string_of_int v)) | Tvar ({value=Some ty1} as r) -> Tvar { r with value = Some (monomorphize ty1)} let print_subst fmt sbt = M.iter (fun n ty -> fprintf fmt "%d -> %a" n print ty) sbt; fprintf fmt "@?" alt-ergo-free-2.0.0/lib/structures/profiling.ml0000664000175000017500000005373513430774474017306 0ustar mimi(******************************************************************************) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the license indicated *) (* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) (* present, please contact us to clarify licensing. *) (* *) (******************************************************************************) open Format open Options module T = Term module SF = Formula.Set module MS = Map.Make(String) type inst_info = { loc : Loc.t; kept : int; ignored : int; all_insts : SF.t; confl : int; decided : int; consumed : T.Set.t; all : T.Set.t; produced : T.Set.t; _new : T.Set.t; } type t = { decisions : int ref; assumes : int ref; assumes_current_lvl : int ref; queries : int ref; instantiation_rounds : int ref; instances : int ref; decision_lvl : int ref; instantiation_lvl : int ref; (* 4 kinds of conflicts *) th_conflicts : int ref; b_conflicts : int ref; bcp_th_conflicts : int ref; bcp_b_conflicts : int ref; bcp_mix_conflicts : int ref; (* 4 kinds of red/elim *) t_red : int ref; b_red : int ref; t_elim : int ref; b_elim : int ref; (* first int: counter ok kept instances, second int: counter of removed instances*) instances_map : inst_info MS.t ref; instances_map_printed : bool ref } let state = { decisions = ref 0; assumes = ref 0; assumes_current_lvl = ref 0; queries = ref 0; instantiation_rounds = ref 0; instances = ref 0; decision_lvl = ref 0; instantiation_lvl = ref 0; th_conflicts = ref 0; b_conflicts = ref 0; bcp_th_conflicts = ref 0; bcp_b_conflicts = ref 0; bcp_mix_conflicts = ref 0; t_red = ref 0; b_red = ref 0; t_elim = ref 0; b_elim = ref 0; instances_map = ref MS.empty; instances_map_printed = ref false } let set_sigprof = let tm = let v = Options.profiling_period () in if Pervasives.(>) v 0. then v else -. v in fun () -> ignore (Unix.setitimer Unix.ITIMER_PROF { Unix.it_value = tm; Unix.it_interval = 0. }) let init () = state.decisions := 0; state.assumes := 0; state.queries := 0; state.instantiation_rounds := 0; state.instances := 0; state.decision_lvl := 0; state.instantiation_lvl := 0; state.assumes_current_lvl := 0; state.th_conflicts := 0; state.b_conflicts := 0; state.bcp_th_conflicts := 0; state.bcp_b_conflicts := 0; state.bcp_mix_conflicts := 0; state.t_red := 0; state.b_red := 0; state.t_elim := 0; state.b_elim := 0; state.instances_map := MS.empty; state.instances_map_printed := false; set_sigprof () (* update functions of the internal state *) let assume nb = state.assumes := nb + !(state.assumes); state.assumes_current_lvl := nb + !(state.assumes_current_lvl) let query () = incr state.queries let instances l = state.instances := !(state.instances) + List.length l let instantiation ilvl = incr state.instantiation_rounds; incr state.instantiation_lvl; if not (!(state.instantiation_lvl) = ilvl) then begin Format.eprintf "state.instantiation_lvl = %d et ilvl = %d@." !(state.instantiation_lvl) ilvl; assert false end let bool_conflict () = incr state.b_conflicts let theory_conflict () = incr state.th_conflicts let bcp_conflict b1 b2 = if b1 && b2 then incr state.bcp_b_conflicts else if (not b1) && (not b2) then incr state.bcp_th_conflicts else incr state.bcp_mix_conflicts let red b = if b then incr state.b_red else incr state.t_red let elim b = if b then incr state.b_elim else incr state.t_elim let reset_ilevel n = state.instantiation_lvl := n let reset_dlevel n = state.decision_lvl := n let empty_inst_info loc = { loc = loc; kept = 0; ignored = 0; confl = 0; decided = 0; all_insts = SF.empty; consumed = T.Set.empty; all = T.Set.empty; produced = T.Set.empty; _new = T.Set.empty; } let new_instance_of axiom inst loc kept = let () = state.instances_map_printed := false in let ii = try MS.find axiom !(state.instances_map) with Not_found -> empty_inst_info loc in assert (ii.loc == loc); let ii = if kept then {ii with kept = ii.kept + 1; all_insts = SF.add inst ii.all_insts} else {ii with ignored = ii.ignored + 1} in state.instances_map := MS.add axiom ii !(state.instances_map) let conflicting_instance axiom loc = let ii = try MS.find axiom !(state.instances_map) with Not_found -> empty_inst_info loc in let ii = {ii with confl = ii.confl + 1} in assert (ii.loc == loc); state.instances_map := MS.add axiom ii !(state.instances_map) let decision_on_instance axiom_name = try let ii = MS.find axiom_name !(state.instances_map) in let ii = {ii with decided = ii.decided + 1} in (*assert (ii.loc == loc);*) state.instances_map := MS.add axiom_name ii !(state.instances_map) with Not_found -> () let decision d origin = incr state.decisions; incr state.decision_lvl; if not (!(state.decision_lvl) = d) then begin Format.eprintf "state.decision_lvl = %d et d = %d@." !(state.decision_lvl) d; assert false end; state.assumes_current_lvl := 0; decision_on_instance origin let register_produced_terms axiom loc consumed all produced _new = let ii = try MS.find axiom !(state.instances_map) with Not_found -> empty_inst_info loc in assert (ii.loc == loc); let ii = {ii with consumed = T.Set.union ii.consumed consumed; all = T.Set.union ii.all all; produced = T.Set.union ii.produced produced; _new = T.Set.union ii._new _new } in state.instances_map := MS.add axiom ii !(state.instances_map) (******************************************************************************* printing the internal state *******************************************************************************) type mode = | Stats | Timers | CallTree | FunctionsTimers | Instances let mode = ref Stats let max_nb_prints = 30 let nb_prints = ref max_nb_prints let initial_info = ref true let string_resize s i = let tmp = ref s in for cpt = String.length s + 1 to i do tmp := sprintf "%s " !tmp done; if false && not (String.length !tmp = i) then begin fprintf fmt "i = %d@." i; fprintf fmt "s in = \"%s\"@." s; fprintf fmt "s out = \"%s\"@." !tmp; fprintf fmt "size out = %d@." (String.length !tmp); assert false end; !tmp let int_resize n i = string_resize (sprintf "%d" n) i let float_resize f i = string_resize (sprintf "%f" f) i let percent total a = (string_of_int (int_of_float (a *. 100. /. total))) ^ "%" let columns = [ "GTimer", "Global timer", 11, None, (fun steps gtime timers sz -> float_resize gtime sz); "Steps", "Number of Steps", 14, None, (fun steps gtime timers sz -> let avg = int_of_float (Int64.to_float steps /. gtime) in sprintf "%s~%s" (string_resize (sprintf "%Ld" steps) (sz-7)) (string_resize (sprintf "%d/s" avg) 6) ); "Case splits", "Number of Case Splits", 14, None, (fun steps gtime timers sz -> let avg = int_of_float (float_of_int (Options.cs_steps()) /. gtime) in sprintf "%s~%s" (string_resize (sprintf "%d" (Options.cs_steps())) (sz-7)) (string_resize (sprintf "%d/s" avg) 6) ); "Mod.", "Current active module", 7, None, (fun steps gtime timers sz -> let kd, msg, _ = Timers.current_timer timers in string_resize (Timers.string_of_ty_module kd) sz); "Module Id", "Each call to a module is tagged with a fresh Id", 10, None, (fun steps gtime timers sz -> let kd, msg, id = Timers.current_timer timers in int_resize id sz); (*-----------------------------------------------------------------*) "ilvl", "Current Instantiaton level", 6, Some true, (fun steps gtime timers sz -> int_resize !(state.instantiation_lvl) sz); "#i rnds", "Number of intantiation rounds", 8, Some true, (fun steps gtime timers sz -> int_resize !(state.instantiation_rounds) sz); "#insts", "Number of generated instances", 8, Some true, (fun steps gtime timers sz -> int_resize !(state.instances) sz); "i/r", "AVG number of generated instances per instantiation rounds", 8, Some true, (fun steps gtime timers sz -> int_resize (!(state.instances) / (max 1 !(state.instantiation_rounds))) sz); "dlvl", "Current Decision level", 6, Some true, (fun steps gtime timers sz -> int_resize !(state.decision_lvl) sz); "#decs", "Number of decisions", 6, Some true, (fun steps gtime timers sz -> int_resize !(state.decisions) sz); "T-asm", "Number of calls to Theory.assume", 6, Some true, (fun steps gtime timers sz -> int_resize !(state.assumes) sz); "T/d", "Number of Theory.assume after last decision", 6, Some true, (fun steps gtime timers sz -> int_resize !(state.assumes_current_lvl) sz); "T-qr", "Number of calls to Theory.query", 15, Some true, (fun steps gtime timers sz -> int_resize !(state.queries) sz); "B-R", "Number of reduced clauses by Boolean propagation", 6, Some true, (fun steps gtime timers sz -> int_resize !(state.b_red) sz); "B-E", "Number of eliminated clauses by Boolean propagation", 6, Some true, (fun steps gtime timers sz -> int_resize !(state.b_elim) sz); "T-R", "Number of reduced clauses by Theory propagation", 6, Some true, (fun steps gtime timers sz -> int_resize !(state.t_red) sz); "T-E", "Number of eliminated clauses by Theory propagation", 6, Some true, (fun steps gtime timers sz -> int_resize !(state.t_elim) sz); "B-!", "Number of direct Boolean conflicts", 5, Some true, (fun steps gtime timers sz -> int_resize !(state.b_conflicts) sz); "T-!", "Number of direct Theory conflicts" , 5, Some true, (fun steps gtime timers sz -> int_resize !(state.th_conflicts) sz); "B>!", "Number of Boolean conflicts deduced by BCP", 5, Some true, (fun steps gtime timers sz -> int_resize !(state.bcp_b_conflicts) sz); "T>!", "Number of Theory conflicts deduced by BCP", 5, Some true, (fun steps gtime timers sz -> int_resize !(state.bcp_th_conflicts) sz); "M>!", "Number of Mix conflicts deduced by BCP", 5, Some true, (fun steps gtime timers sz -> int_resize !(state.bcp_mix_conflicts) sz); (*-----------------------------------------------------------------*) "SAT", "Time spent in SAT module(s)", 16, Some false, (fun steps gtime timers sz -> let curr = Timers.get_sum timers Timers.M_Sat in sprintf "%s~%s" (float_resize curr (sz - 5)) (string_resize (percent gtime curr) 4)); "Matching", "Time spent in Matching module(s)", 16, Some false, (fun steps gtime timers sz -> let curr = Timers.get_sum timers Timers.M_Match in sprintf "%s~%s" (float_resize curr (sz - 5)) (string_resize (percent gtime curr) 4)); "CC", "Time spent in CC module(s)", 16, Some false, (fun steps gtime timers sz -> let curr = Timers.get_sum timers Timers.M_CC in sprintf "%s~%s" (float_resize curr (sz - 5)) (string_resize (percent gtime curr) 4) ); "Arith", "Time spent in Arith module(s)", 16, Some false, (fun steps gtime timers sz -> let curr = Timers.get_sum timers Timers.M_Arith in sprintf "%s~%s" (float_resize curr (sz - 5)) (string_resize (percent gtime curr) 4)); "Arrays", "Time spent in Arrays module(s)", 16, Some false, (fun steps gtime timers sz -> let curr = Timers.get_sum timers Timers.M_Arrays in sprintf "%s~%s" (float_resize curr (sz - 5)) (string_resize (percent gtime curr) 4)); "Sum", "Time spent in Sum module(s)", 16, Some false, (fun steps gtime timers sz -> let curr = Timers.get_sum timers Timers.M_Sum in sprintf "%s~%s" (float_resize curr (sz - 5)) (string_resize (percent gtime curr) 4)); "Records", "Time spent in Records module(s)", 16, Some false, (fun steps gtime timers sz -> let curr = Timers.get_sum timers Timers.M_Records in sprintf "%s~%s" (float_resize curr (sz - 5)) (string_resize (percent gtime curr) 4)); "AC", "Time spent in AC module(s)", 16, Some false, (fun steps gtime timers sz -> let curr = Timers.get_sum timers Timers.M_AC in sprintf "%s~%s" (float_resize curr (sz - 5)) (string_resize (percent gtime curr) 4)); "Total", "Time spent in 'supervised' module(s)", 11, Some false, (fun steps gtime timers sz -> let tsat = Timers.get_sum timers Timers.M_Sat in let tmatch = Timers.get_sum timers Timers.M_Match in let tcc = Timers.get_sum timers Timers.M_CC in let tarith = Timers.get_sum timers Timers.M_Arith in let tarrays = Timers.get_sum timers Timers.M_Arrays in let tsum = Timers.get_sum timers Timers.M_Sum in let trecs = Timers.get_sum timers Timers.M_Records in let tac = Timers.get_sum timers Timers.M_AC in let total = tsat+.tmatch+.tcc+.tarith+.tarrays+.tsum+.trecs+.tac in float_resize total sz); ] let print_initial_info () = if !initial_info then begin initial_info := false; let max = List.fold_left (fun z (id,_, _,_,_) -> max z (String.length id)) 0 columns in List.iter (fun (id, descr, sz, opt, func) -> fprintf fmt "%s : %s@." (string_resize id max) descr )columns end let stats_limit, timers_limit = let aux tmp sz = tmp := sprintf "%s|" !tmp; for i = 1 to sz do tmp := sprintf "%s-" !tmp done in let tmp_s = ref "" in let tmp_t = ref "" in List.iter (fun (_, _, sz, opt, _) -> match opt with | Some true -> aux tmp_s sz | Some false -> aux tmp_t sz | _ -> aux tmp_s sz; aux tmp_t sz )columns; !tmp_s ^ "|", !tmp_t ^ "|" let print_header header fmt = let pp_stats = match !mode with Stats -> true | Timers -> false | _ -> assert false in if header || !nb_prints >= max_nb_prints then begin nb_prints := 0; fprintf fmt "%s@." (if pp_stats then stats_limit else timers_limit); List.iter (fun (id, descr, sz, opt, func) -> match opt with | Some b when b != pp_stats -> () | _ -> fprintf fmt "|%s" (string_resize id sz) )columns; fprintf fmt "|@."; fprintf fmt "%s@." (if pp_stats then stats_limit else timers_limit) end; incr nb_prints let print_stats header steps fmt timers = print_header header fmt; let gtime = Options.Time.value() in List.iter (fun (id, descr, sz, opt, func) -> match opt with | Some false -> () | _ -> fprintf fmt "|%s" (func steps gtime timers sz) )columns; fprintf fmt "|@." let print_timers header steps fmt timers = Timers.update timers; print_header header fmt; let gtime = Options.Time.value() in List.iter (fun (id, descr, sz, opt, func) -> match opt with | Some true -> () | _ -> fprintf fmt "|%s" (func steps gtime timers sz) )columns; fprintf fmt "|@." let report2 axiom fmt (b,e) = let open Lexing in let l = b.pos_lnum in let fc = b.pos_cnum - b.pos_bol + 1 in let lc = e.pos_cnum - b.pos_bol + 1 in fprintf fmt "(Sub) Axiom \"%s\", line %d, characters %d-%d:" axiom l fc lc let report3 fmt (b,e) = let open Lexing in let l = b.pos_lnum in let fc = b.pos_cnum - b.pos_bol + 1 in let lc = e.pos_cnum - b.pos_bol + 1 in fprintf fmt "line %d, chars %d-%d." l fc lc let (@@) a b = if a <> 0 then a else b let print_instances_generation forced steps timers = if not forced && !(state.instances_map_printed) then fprintf fmt "[Instances profiling] No change since last print@." else let () = state.instances_map_printed := true in if not forced then ignore(Sys.command("clear")); fprintf fmt "[Instances profiling] ...@."; let insts = MS.fold (fun name ii acc -> let f1 = float_of_int ii.kept in let f2 = float_of_int ii.ignored in let ratio = f1 /. (f1 +. f2) in let all_card = SF.cardinal ii.all_insts in (name, ii, all_card, ratio) :: acc) !(state.instances_map) [] in let insts = List.fast_sort (fun (_,i1,c1, r1) (_,i2,c2, r2) -> (i1.decided - i2.decided) @@ (c1 - c2) @@ (i1.kept - i2.kept) @@ (i1.confl - i2.confl) @@ (i1.ignored - i2.ignored) @@ (T.Set.cardinal i1._new - T.Set.cardinal i2._new) ) insts in List.iter (fun (name, i, card, r) -> fprintf fmt "ratio kept/all: %s| " (float_resize r 8); fprintf fmt "<> insts: %s| " (int_resize card 5); fprintf fmt "kept: %s| " (int_resize i.kept 7); fprintf fmt "ignored: %s| " (int_resize i.ignored 7) ; fprintf fmt "decided: %s| " (int_resize i.decided 4); fprintf fmt "conflicted: %s| " (int_resize i.confl 4); fprintf fmt "consumed: %s| " (int_resize (T.Set.cardinal i.consumed) 5); fprintf fmt "produced: %s| " (int_resize (T.Set.cardinal i.produced) 5); fprintf fmt "new: %s|| " (int_resize (T.Set.cardinal i._new) 5); fprintf fmt "%s" (string_resize name 30); (*fprintf fmt "%s | " (string_resize name 30); fprintf fmt "%a@." report3 i.loc (* too long *) *) fprintf fmt "@." )insts; (*if forced then let () = fprintf fmt "digraph v{@." in fprintf fmt "size=\"10,7.5\"@."; fprintf fmt "ratio=\"fill\"@."; fprintf fmt "rotate=90@."; fprintf fmt "fontsize=\"12pt\"@."; fprintf fmt "rankdir = TB@." ; let terms = ref T.Set.empty in List.iter (fun (name, i, _) -> T.Set.iter (fun t -> fprintf fmt "\"%d\" -> \"%s\";@." (T.hash t) name )i.consumed; terms := T.Set.union !terms i.consumed; T.Set.iter (fun t -> fprintf fmt "\"%s\" -> \"%d\";@." name (T.hash t) )i._new; terms := T.Set.union !terms i._new; fprintf fmt "\"%s\" [fillcolor=yellow];@." name; )insts; T.Set.iter (fun t -> fprintf fmt "\"%d\" [fillcolor=green];@." (T.hash t); )!terms; fprintf fmt "}@."*) (* if forced then let () = fprintf fmt "digraph v{@." in fprintf fmt "size=\"10,7.5\"@."; fprintf fmt "ratio=\"fill\"@."; fprintf fmt "rotate=90@."; fprintf fmt "fontsize=\"12pt\"@."; fprintf fmt "rankdir = TB@." ; List.iter (fun (s1, i1, _) -> List.iter (fun (s2, i2, _) -> if T.Set.is_empty (T.Set.inter i1.produced i2.consumed) then () else fprintf fmt "\"%s\" -> \"%s\";@." s1 s2 )insts )insts; fprintf fmt "}@."*) () let print_call_tree forced steps timers = let stack = Timers.get_stack timers in List.iter (fun (k, f, id) -> fprintf fmt "(%s, %s, %s) --> " (string_resize (Timers.string_of_ty_module k) 5) (string_resize (Timers.string_of_ty_function f) 10) (int_resize id 7) )(List.rev stack); let m, f, id = Timers.current_timer timers in fprintf fmt "(%s, %s, %s)@." (string_resize (Timers.string_of_ty_module m) 5) (string_resize (Timers.string_of_ty_function f) 10) (int_resize id 7) let switch () = let next, next_msg = match !mode with | Stats -> Timers, "Time" | Timers -> CallTree, "CallTree" | CallTree -> FunctionsTimers, "Functions Timers" | FunctionsTimers -> Instances, "Instances generation" | Instances -> Stats, "Stats" in fprintf fmt "@.>>> Switch to %s profiling. Use \"Ctrl + AltGr + \\\" to exit\n" next_msg; nb_prints := max_nb_prints; mode := next let float_print fmt v = if Pervasives.(=) v 0. then fprintf fmt "-- " else if Pervasives.(<) v 10. then fprintf fmt "%0.5f" v else if Pervasives.(<) v 100. then fprintf fmt "%0.4f" v else fprintf fmt "%0.3f" v let line_of_module arr f = fprintf fmt "%s " (string_resize (Timers.string_of_ty_function f) 13); let cpt = ref 0. in List.iter (fun m -> let v = arr.(Timers.mtag m).(Timers.ftag f) in cpt := !cpt +. v; fprintf fmt "| %a " float_print v ) Timers.all_modules; fprintf fmt "| %a |@." float_print !cpt let line_of_sum_module timers = for i = 0 to 206 do fprintf fmt "-" done; fprintf fmt "|@."; fprintf fmt "%s " (string_resize "" 13); List.iter (fun m -> fprintf fmt "| %a " float_print (Timers.get_sum timers m)) Timers.all_modules; fprintf fmt "| GTimer %a |@." float_print (Options.Time.value()) let timers_table forced timers = if not forced then ignore(Sys.command("clear")); Timers.update timers; fprintf fmt "@."; fprintf fmt " "; List.iter (fun f -> fprintf fmt"| %s" (string_resize (Timers.string_of_ty_module f) 9)) Timers.all_modules; fprintf fmt "|@."; for i = 0 to 206 do fprintf fmt "-" done; fprintf fmt "|@."; let arr_timers = Timers.get_timers_array timers in List.iter (line_of_module arr_timers) Timers.all_functions; line_of_sum_module timers let print all steps timers fmt = print_initial_info (); set_sigprof(); if all then begin mode := Stats; fprintf fmt "@."; print_stats true steps fmt timers; fprintf fmt "@."; mode := Timers; print_timers true steps fmt timers; fprintf fmt "@."; timers_table true timers; fprintf fmt "@."; print_instances_generation true steps timers; fprintf fmt "@."; end else match !mode with | Stats -> print_stats false steps fmt timers | Timers -> print_timers false steps fmt timers | CallTree -> print_call_tree false steps timers | FunctionsTimers -> timers_table false timers; | Instances -> print_instances_generation false steps timers alt-ergo-free-2.0.0/lib/structures/symbols.ml0000664000175000017500000001644513430774474017002 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Hconsing open Options type operator = Plus | Minus | Mult | Div | Modulo | Concat | Extract | Get | Set | Fixed | Float | Reach | Access of Hstring.t | Record | Sqrt_real | Abs_int | Abs_real | Real_of_int | Int_floor | Int_ceil | Sqrt_real_default | Sqrt_real_excess | Min_real | Min_int | Max_real | Max_int | Integer_log2 | Pow_real_int | Pow_real_real | Integer_round type name_kind = Ac | Constructor | Other type bound_kind = VarBnd of Hstring.t | ValBnd of Numbers.Q.t type bound = { kind : bound_kind; sort : Ty.t; is_open : bool; is_lower : bool } type t = | True | False | Void | Name of Hstring.t * name_kind | Int of Hstring.t | Real of Hstring.t | Bitv of string | Op of operator | Var of Hstring.t | In of bound * bound | MapsTo of Hstring.t type s = t let name ?(kind=Other) s = Name (Hstring.make s, kind) let var s = Var (Hstring.make s) let int i = Int (Hstring.make i) let real r = Real (Hstring.make r) let mk_bound name sort ~is_open ~is_lower = let kind = try ValBnd (Numbers.Q.from_string (Hstring.view name)) with _ -> VarBnd name in {kind; sort; is_open; is_lower} let mk_in b1 b2 = assert (b1.is_lower); assert (not b2.is_lower); In (b1, b2) let mk_maps_to x = MapsTo x let is_ac = function | Name(_, Ac) -> true | _ -> false let underscoring = function Var s -> Var (Hstring.make ("$"^Hstring.view s)) | _ -> assert false let compare_kind k1 k2 = match k1, k2 with | Ac , Ac -> 0 | Ac , _ -> 1 | _ , Ac -> -1 | Other, Other -> 0 | Other, _ -> 1 | _ , Other -> -1 | Constructor, Constructor -> 0 let compare s1 s2 = match s1, s2 with | Name (n1,k1), Name (n2,k2) -> let c = compare_kind k1 k2 in if c = 0 then Hstring.compare n1 n2 else c | Name _, _ -> -1 | _, Name _ -> 1 | Var n1, Var n2 -> Hstring.compare n1 n2 | Var _, _ -> -1 | _ ,Var _ -> 1 | Int i1, Int i2 -> Hstring.compare i1 i2 | Int _, _ -> -1 | _ ,Int _ -> 1 | MapsTo i1, MapsTo i2 -> Hstring.compare i1 i2 | MapsTo _, _ -> -1 | _ ,MapsTo _ -> 1 | Op(Access s1), Op(Access s2) -> Hstring.compare s1 s2 | Op(Access _), _ -> -1 | _, Op(Access _) -> 1 | _ -> Pervasives.compare s1 s2 let equal s1 s2 = compare s1 s2 = 0 let hash = function | Name (n,Ac) -> Hstring.hash n * 19 + 1 | Name (n,_) -> Hstring.hash n * 19 | Var n (*| Int n*) -> Hstring.hash n * 19 + 1 | Op (Access s) -> Hstring.hash s + 19 | MapsTo hs -> Hstring.hash hs * 37 | s -> Hashtbl.hash s let string_of_bound_kind = function | VarBnd h -> Hstring.view h | ValBnd v -> Numbers.Q.to_string v let string_of_bound b = let kd = string_of_bound_kind b.kind in if b.is_lower then Format.sprintf "%s %s" (if b.is_open then "]" else "[") kd else Format.sprintf "%s %s" kd (if b.is_open then "[" else "]") let print_bound fmt b = Format.fprintf fmt "%s" (string_of_bound b) let to_string ?(show_vars=true) = function | Name (n,_) -> Hstring.view n | Var x when show_vars -> Format.sprintf "'%s'" (Hstring.view x) | Var x -> Hstring.view x | Int n -> Hstring.view n | Real n -> Hstring.view n | Bitv s -> "[|"^s^"|]" | Op Plus -> "+" | Op Minus -> "-" | Op Mult -> "*" | Op Div -> "/" | Op Modulo -> "%" | Op (Access s) -> "@Access_"^(Hstring.view s) | Op Record -> "@Record" | Op Get -> "get" | Op Set -> "set" | Op Float -> "float" | Op Fixed -> "fixed" | Op Abs_int -> "abs_int" | Op Abs_real -> "abs_real" | Op Sqrt_real -> "sqrt_real" | Op Sqrt_real_default -> "sqrt_real_default" | Op Sqrt_real_excess -> "sqrt_real_excess" | Op Real_of_int -> "real_of_int" | Op Int_floor -> "int_floor" | Op Int_ceil -> "int_ceil" | Op Max_real -> "max_real" | Op Max_int -> "max_int" | Op Min_real -> "min_real" | Op Min_int -> "min_int" | Op Integer_log2 -> "integer_log2" | Op Pow_real_int -> "pow_real_int" | Op Pow_real_real -> "pow_real_real" | Op Integer_round -> "integer_round" | True -> "true" | False -> "false" | Void -> "void" | In (lb, rb) -> Format.sprintf "%s , %s" (string_of_bound lb) (string_of_bound rb) | MapsTo x -> Format.sprintf "%s |->" (Hstring.view x) | _ -> "" (*assert false*) let to_string_clean s = to_string ~show_vars:false s let to_string s = to_string ~show_vars:true s let print_clean fmt s = Format.fprintf fmt "%s" (to_string_clean s) let print fmt s = Format.fprintf fmt "%s" (to_string s) let dummy = Name (Hstring.make "_one", Other) let fresh = let cpt = ref 0 in fun s -> incr cpt; (* garder le suffixe "__" car cela influence l'ordre *) name (Format.sprintf "!?__%s%i" s (!cpt)) let is_get f = equal f (Op Get) let is_set f = equal f (Op Set) let fake_eq = name "@eq" let fake_neq = name "@neq" let fake_lt = name "@lt" let fake_le = name "@le" module Map = Map.Make(struct type t' = t type t=t' let compare=compare end) module Set = Set.Make(struct type t' = t type t=t' let compare=compare end) module Labels = Hashtbl.Make(struct type t = s let equal = equal let hash = hash end) let labels = Labels.create 100007 let add_label lbl t = Labels.replace labels t lbl let label t = try Labels.find labels t with Not_found -> Hstring.empty alt-ergo-free-2.0.0/lib/structures/.merlin0000664000175000017500000000000413430774474016227 0ustar mimiREC alt-ergo-free-2.0.0/lib/structures/literal.ml0000664000175000017500000003034013430774474016734 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Hconsing open Options type 'a view = | Eq of 'a * 'a | Distinct of bool * 'a list | Builtin of bool * Hstring.t * 'a list | Pred of 'a * bool type 'a atom_view = | EQ of 'a * 'a | BT of Hstring.t * 'a list | PR of 'a | EQ_LIST of 'a list module type OrderedType = sig type t val compare : t -> t -> int val hash : t -> int val print : Format.formatter -> t -> unit val top : unit -> t val bot : unit -> t val type_info : t -> Ty.t end module type S = sig type elt type t val make : elt view -> t val view : t -> elt view val atom_view : t -> elt atom_view * bool (* is_negated ? *) val mk_eq : elt -> elt -> t val mk_distinct : bool -> elt list -> t val mk_builtin : bool -> Hstring.t -> elt list -> t val mk_pred : elt -> bool -> t val mkv_eq : elt -> elt -> elt view val mkv_distinct : bool -> elt list -> elt view val mkv_builtin : bool -> Hstring.t -> elt list -> elt view val mkv_pred : elt -> bool -> elt view val neg : t -> t val add_label : Hstring.t -> t -> unit val label : t -> Hstring.t val print : Format.formatter -> t -> unit val compare : t -> t -> int val equal : t -> t -> bool val hash : t -> int val uid : t -> int module Map : Map.S with type key = t module Set : Set.S with type elt = t end module Make (X : OrderedType) : S with type elt = X.t = struct type elt = X.t type atom = {value : elt atom_view; uid : int } type t = { at : atom; neg : bool; tpos : int; tneg : int } let compare a1 a2 = Pervasives.compare a1.tpos a2.tpos let equal a1 a2 = a1.tpos = a2.tpos (* XXX == *) let hash a1 = a1.tpos let uid a1 = a1.tpos let neg t = {t with neg = not t.neg; tpos = t.tneg; tneg = t.tpos} let atom_view t = t.at.value, t.neg let view t = match t.neg, t.at.value with | false, EQ(s,t) -> Eq(s,t) | true , EQ(s,t) -> Distinct(false, [s;t]) (* b false <-> not negated *) | false, EQ_LIST l -> Distinct (true,l) | true, EQ_LIST l -> Distinct (false,l) | b , PR p -> Pred(p,b) | b , BT(n,l) -> Builtin(not b, n, l) (* b true <-> not negated *) module T = struct type t' = t type t = t' let compare=compare let equal = equal let hash = hash end module Set = Set.Make(T) module Map = Map.Make(T) module Labels = Hashtbl.Make(T) let labels = Labels.create 100007 let add_label lbl t = Labels.replace labels t lbl let label t = try Labels.find labels t with Not_found -> Hstring.empty let print_list fmt = function | [] -> () | z :: l -> Format.fprintf fmt "%a" X.print z; List.iter (Format.fprintf fmt ", %a" X.print) l let ale = Hstring.make "<=" let alt = Hstring.make "<" let print fmt a = let lbl = Hstring.view (label a) in let lbl = if String.length lbl = 0 then lbl else lbl^":" in match view a with | Eq (z1, z2) -> Format.fprintf fmt "%s %a = %a" lbl X.print z1 X.print z2 | Distinct (b,(z::l)) -> let b = if b then "~ " else "" in Format.fprintf fmt "%s %s%a" lbl b X.print z; List.iter (fun x -> Format.fprintf fmt " <> %a" X.print x) l | Builtin (true, n, [v1;v2]) when Hstring.equal n ale -> Format.fprintf fmt "%s %a <= %a" lbl X.print v1 X.print v2 | Builtin (true, n, [v1;v2]) when Hstring.equal n alt -> Format.fprintf fmt "%s %a < %a" lbl X.print v1 X.print v2 | Builtin (false, n, [v1;v2]) when Hstring.equal n ale -> Format.fprintf fmt "%s %a > %a" lbl X.print v1 X.print v2 | Builtin (false, n, [v1;v2]) when Hstring.equal n alt -> Format.fprintf fmt "%s %a >= %a" lbl X.print v1 X.print v2 | Builtin (b, n, l) -> let b = if b then "" else "~" in Format.fprintf fmt "%s %s %s(%a)" lbl b (Hstring.view n) print_list l | Pred (p,b) -> Format.fprintf fmt "%s %a = %s" lbl X.print p (if b then "false" else "true") | Distinct (_, _) -> assert false module V = struct type elt = atom let eq a1 a2 = match a1.value, a2.value with | EQ(t1, t2), EQ(u1, u2) -> X.compare t1 u1 = 0 && X.compare t2 u2 = 0 | BT(n1, l1), BT(n2, l2) -> begin try Hstring.equal n1 n2 && List.for_all2 (fun x y -> X.compare x y = 0) l1 l2 with Invalid_argument _ -> false end | PR p1, PR p2 -> X.compare p1 p2 = 0 | EQ_LIST l1, EQ_LIST l2 -> begin try List.for_all2 (fun x y -> X.compare x y = 0) l1 l2 with Invalid_argument _ -> false end | _ -> false let hash a = match a.value with | EQ(t1, t2) -> abs (19 * (X.hash t1 + X.hash t2)) | BT(n, l) -> abs (List.fold_left (fun acc t-> acc*13 + X.hash t) (Hstring.hash n+7) l) | PR p -> abs (17 * X.hash p) (*XXX * 29 ?*) | EQ_LIST l -> abs (List.fold_left (fun acc t-> acc*31 + X.hash t) 1 l) let set_id n v = {v with uid = n} let initial_size = 4096 let disable_weaks () = Options.disable_weaks () end module H = Make(V) let normalize_eq_bool t1 t2 is_neg = if X.compare t1 (X.bot()) = 0 then Pred(t2, not is_neg) else if X.compare t2 (X.bot()) = 0 then Pred(t1, not is_neg) else if X.compare t1 (X.top()) = 0 then Pred(t2, is_neg) else if X.compare t2 (X.top()) = 0 then Pred(t1, is_neg) else if is_neg then Distinct (false, [t1;t2]) (* XXX assert ? *) else Eq(t1,t2) (* should be translated into iff *) let normalize_eq t1 t2 is_neg = let c = X.compare t1 t2 in if c = 0 then Pred(X.top(), is_neg) else let t1, t2 = if c < 0 then t1, t2 else t2, t1 in if X.type_info t1 == Ty.Tbool then normalize_eq_bool t1 t2 is_neg else if is_neg then Distinct (false, [t1;t2]) (* XXX assert ? *) else Eq(t1,t2) (* should be translated into iff *) let normalize_view t = match t with | Eq(t1,t2) -> normalize_eq t1 t2 false | Distinct (b, [t1;t2]) -> normalize_eq t1 t2 (not b) | Distinct (b, l) -> Distinct (b, List.fast_sort X.compare l) | Builtin (_, _, _) | Pred (_, _) -> t let make_aux av is_neg = let av = {value = av; uid = -1} in let at = H.make av in if is_neg then {at = at; neg = is_neg; tpos = 2*at.uid+1; tneg = 2*at.uid} else {at = at; neg = is_neg; tneg = 2*at.uid+1; tpos = 2*at.uid} let make t = match normalize_view t with | Eq(t1,t2) -> make_aux (EQ(t1,t2)) false | Builtin (b,n,l) -> make_aux (BT (n,l)) (not b) | Pred (x,y) -> make_aux (PR x) y | Distinct(false, [t1;t2]) -> make_aux (EQ(t1,t2)) true | Distinct (b,l) -> make_aux (EQ_LIST l) (not b) (************) (* let mk_eq_bool t1 t2 is_neg = if X.compare t1 (X.bot()) = 0 then make_aux (PR t2) (not is_neg) else if X.compare t2 (X.bot()) = 0 then make_aux (PR t1) (not is_neg) else if X.compare t1 (X.top()) = 0 then make_aux (PR t2) is_neg else if X.compare t2 (X.top()) = 0 then make_aux (PR t1) is_neg else make_aux (EQ(t1,t2)) is_neg let mk_equa t1 t2 is_neg = let c = X.compare t1 t2 in if c = 0 then make_aux (PR (X.top())) is_neg else let t1, t2 = if c < 0 then t1, t2 else t2, t1 in if X.type_info t1 = Ty.Tbool then mk_eq_bool t1 t2 is_neg else make_aux (EQ(t1, t2)) is_neg let make t = match t with | Eq(t1,t2) -> mk_equa t1 t2 false | Distinct (b, [t1;t2]) -> mk_equa t1 t2 (not b) | Builtin (b,n,l) -> make_aux (BT (n,l)) (not b) | Distinct (_,_) -> assert false (* TODO *) | Pred (x,y) -> make_aux (PR x) y *) let mk_eq t1 t2 = make (Eq(t1,t2)) let mk_distinct is_neg tl = make (Distinct(is_neg, tl)) let mk_builtin is_pos n l = make (Builtin(is_pos, n, l)) let mk_pred t is_neg = make (Pred(t, is_neg)) let mkv_eq t1 t2 = normalize_view (Eq(t1,t2)) let mkv_distinct is_neg tl = normalize_view (Distinct(is_neg, tl)) let mkv_builtin is_pos n l = normalize_view (Builtin(is_pos, n, l)) let mkv_pred t is_neg = normalize_view (Pred(t, is_neg)) end module type S_Term = sig include S with type elt = Term.t val vrai : t val faux : t val apply_subst : Term.subst -> t -> t val terms_nonrec : t -> Term.Set.t val terms_rec : t -> Term.Set.t val vars_of : t -> Ty.t Symbols.Map.t -> Ty.t Symbols.Map.t val is_ground : t -> bool val is_in_model : t -> bool (* module SetEq : Set.S with type elt = t * Term.t * Term.t*) end module LT : S_Term = struct module L = Make(Term) include L let vrai = mk_pred Term.vrai false let faux = neg vrai let apply_subst subst a = match view a with | Pred (t1, b) -> let t1' = Term.apply_subst subst t1 in if t1 == t1' then a else make (Pred(t1', b)) | Eq (t1, t2) -> let t1' = Term.apply_subst subst t1 in let t2' = Term.apply_subst subst t2 in if t1 == t1' && t2 == t2' then a else make (Eq(t1', t2')) | Distinct (b, lt) -> let lt, same = Lists.apply (Term.apply_subst subst) lt in if same then a else make (Distinct (b, lt)) | Builtin (b, n, l) -> let l, same = Lists.apply (Term.apply_subst subst) l in if same then a else make (Builtin(b, n, l)) let terms_nonrec a = match atom_view a with | EQ(a,b), _ -> Term.Set.add a (Term.Set.singleton b) | PR a, _ -> Term.Set.singleton a | BT (_,l), _ | EQ_LIST l, _ -> List.fold_left (fun z t -> Term.Set.add t z) Term.Set.empty l let terms_rec a = Term.Set.fold (fun t z -> Term.subterms z t)(terms_nonrec a) Term.Set.empty module SM = Symbols.Map let vars_of a acc = Term.Set.fold Term.vars_of (terms_nonrec a) acc let is_ground a = Term.Set.for_all Term.is_ground (terms_nonrec a) let is_in_model l = match view l with | Eq (t1, t2) -> Term.is_in_model t1 || Term.is_in_model t2 | Distinct (_, tl) | Builtin (_, _, tl) -> List.exists Term.is_in_model tl | Pred (t1, b) -> Term.is_in_model t1 let apply_subst s a = if Options.timers() then try Timers.exec_timer_start Timers.M_Literal Timers.F_apply_subst; let res = apply_subst s a in Timers.exec_timer_pause Timers.M_Literal Timers.F_apply_subst; res with e -> Timers.exec_timer_pause Timers.M_Literal Timers.F_apply_subst; raise e else apply_subst s a end alt-ergo-free-2.0.0/lib/structures/ty.mli0000664000175000017500000000740513430774474016113 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) type t = | Tint | Treal | Tbool | Tunit | Tvar of tvar | Tbitv of int | Text of t list * Hstring.t | Tfarray of t * t | Tnext of t | Tsum of Hstring.t * Hstring.t list | Trecord of trecord and tvar = { v : int ; mutable value : t option } and trecord = { mutable args : t list; name : Hstring.t; mutable lbs : (Hstring.t * t) list } module M : Map.S with type key = int type subst = t M.t val esubst : subst exception TypeClash of t*t val tunit : t val text : t list -> string -> t val tsum : string -> string list -> t val trecord : t list -> string -> (string * t) list -> t val shorten : t -> t val fresh_var : unit -> tvar val fresh_tvar : unit -> t val fresh_empty_text : unit -> t val fresh : t -> subst -> t * subst val fresh_list : t list -> subst -> t list * subst val equal : t -> t -> bool val hash : t -> int val compare : t -> t -> int val unify : t -> t -> unit val matching : subst -> t -> t -> subst val apply_subst : subst -> t -> t val instantiate : t list -> t list -> t -> t (* Applique la seconde substitution sur la premiere puis fais l'union des map avec prioritée à la première *) val union_subst : subst -> subst -> subst val compare_subst : subst -> subst -> int val equal_subst : subst -> subst -> bool val print : Format.formatter -> t -> unit val print_list : Format.formatter -> t list -> unit val print_full : Format.formatter -> t -> unit (*val printl : Format.formatter -> t list -> unit*) module Svty : Set.S with type elt = int module Set : Set.S with type elt = t val vty_of : t -> Svty.t val monomorphize: t -> t val print_subst: Format.formatter -> subst -> unit alt-ergo-free-2.0.0/lib/structures/exception.ml0000664000175000017500000000451613430774474017304 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) exception Unsolvable exception Inconsistent of Explanation.t * Term.Set.t list exception Progress exception NotCongruent exception Trivial exception Interpreted_Symbol exception Compared of int alt-ergo-free-2.0.0/lib/reasoners/0000755000175000017500000000000013430774474014522 5ustar mimialt-ergo-free-2.0.0/lib/reasoners/inequalities.mli0000664000175000017500000001013513430774474017723 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) module type S = sig module P : Polynome.EXTENDED_Polynome module MP : Map.S with type key = P.t type t = { ple0 : P.t; is_le : bool; dep : (Numbers.Q.t * P.t * bool) Util.MI.t; expl : Explanation.t; age : Numbers.Z.t; } module MINEQS : sig type mp = (t * Numbers.Q.t) MP.t val empty : mp val is_empty : mp -> bool val younger : t -> t -> bool val insert : t -> mp -> mp val ineqs_of : mp -> t list val add_to_map : mp -> t list -> mp val iter : (P.t -> (t * Numbers.Q.t) -> unit) -> mp -> unit val fold : (P.t -> (t * Numbers.Q.t) -> 'a -> 'a) -> mp -> 'a -> 'a end val current_age : unit -> Numbers.Z.t val incr_age : unit -> unit val create_ineq : P.t -> P.t -> bool -> Literal.LT.t option -> Explanation.t -> t val print_inequation : Format.formatter -> t -> unit val fourierMotzkin : ('are_eq -> 'acc -> P.r option -> t list -> 'acc) -> 'are_eq -> 'acc -> MINEQS.mp -> 'acc val fmSimplex : ('are_eq -> 'acc -> P.r option -> t list -> 'acc) -> 'are_eq -> 'acc -> MINEQS.mp -> 'acc val available : ('are_eq -> 'acc -> P.r option -> t list -> 'acc) -> 'are_eq -> 'acc -> MINEQS.mp -> 'acc end module FM (X : Sig.X) (Uf : Uf.S with type r = X.r) (P : Polynome.EXTENDED_Polynome with type r = X.r) : S with module P = P module type Container_SIG = sig module Make (X : Sig.X) (Uf : Uf.S with type r = X.r) (P : Polynome.EXTENDED_Polynome with type r = X.r) : S with module P = P end val get_current : unit -> (module Container_SIG) (** returns the current activated 'inequalities reasoner'. The default value is the Fourier-Motzkin module. When the selected reasoner is an external plugin, the first call of this function will attemp to dynamically load it **) val set_current : (module Container_SIG) -> unit (** sets a new 'inequalities reasoner'. This function is intended to be used by dynamically loaded plugins **) alt-ergo-free-2.0.0/lib/reasoners/instances.mli0000664000175000017500000000621013430774474017215 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) module type S = sig type t type tbox type instances = (Formula.gformula * Explanation.t) list val empty : t val add_terms : t -> Term.Set.t -> Formula.gformula -> t val add_lemma : t -> Formula.gformula -> Explanation.t -> t * instances val add_predicate : t -> Formula.gformula -> t val m_lemmas : backward:Util.inst_kind -> t -> tbox -> (Formula.t -> Formula.t -> bool) -> int -> instances * instances (* goal_directed, others *) val m_predicates : backward:Util.inst_kind -> t -> tbox -> (Formula.t -> Formula.t -> bool) -> int -> instances * instances (* goal_directed, others *) (* returns used axioms/predicates * unused axioms/predicates *) val retrieve_used_context : t -> Explanation.t -> Formula.t list * Formula.t list val register_max_term_depth : t -> int -> t val matching_terms_info : t -> Matching_types.info Term.Map.t * Term.t list Term.Map.t Term.Subst.t end module Make (X : Theory.S) : S with type tbox = X.t alt-ergo-free-2.0.0/lib/reasoners/fun_sat.ml0000664000175000017500000013627613430774474016534 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Options open Format module Th = Theory.Main open Sig module A = Literal module F = Formula module Inst = Instances.Make(Th) module SF = F.Set module MF = F.Map module MA = Literal.LT.Map module Ex = Explanation module H = Hashtbl.Make(Formula) exception No_suitable_decision module Heuristics = struct type t = { mp : float MF.t; (* valeur de l'increment pour l'activite des variables *) var_inc : float; (* inverse du facteur d'acitivte des vars, vaut 1/0.999 par defaut *) var_decay : float; } let empty () = { mp = MF.empty; var_inc = 1.; var_decay = 1. /. 0.95; } let bump_activity ({mp=mp;var_inc=var_inc} as env) expl = let stable = ref true in let mp = SF.fold (fun f mp -> let w = var_inc +. try MF.find f mp with Not_found -> 0. in stable := !stable && Pervasives.(<=) w 1e100; MF.add f w mp )(Ex.bj_formulas_of expl) mp in let mp = if !stable then mp else MF.fold (fun f w acc -> MF.add f (w *. 1e-100) acc) mp MF.empty in { env with mp = mp; var_inc = var_inc *. env.var_decay } let choose delta env = let dec, no_dec = if Options.no_decisions_on__is_empty () then delta, [] else List.partition (fun (a, _,_,_) -> Options.can_decide_on a.F.origin_name) delta in let dec = List.rev_map (fun ((a,b,d,is_impl) as e) -> e, (try (MF.find a.F.f env.mp) with Not_found -> 0.), a.F.gf ) dec in let dec = List.fast_sort (fun (_, x1, b1) (_, x2, b2) -> let c = Pervasives.compare b2 b1 in if c <> 0 then c else Pervasives.compare x2 x1 )dec in (* match l with | [] -> assert false *) match dec with | [] -> raise No_suitable_decision | (e, _, _) :: r -> let delta = List.fold_left (fun acc (e, _, _) -> e :: acc) no_dec (List.rev r) in e, delta end type t = { (* The field gamma contains the current Boolean model (true formulas) of the SAT. Each assumed formula is mapped to a tuple (gf, ex, dlvl, plvl), where: - gf is the rich form of the formula - ex is the explanation associated to the formula - dlvl is the decision level where the formula was assumed to true - plvl is the propagation level (w.r.t. dlvl) of the formula. It forms with dlvl a total ordering on the formulas in gamma. *) gamma : (F.gformula * Ex.t * int * int) MF.t; nb_related_to_goal : int; nb_related_to_hypo : int; nb_related_to_both : int; nb_unrelated : int; tcp_cache : Sig.answer MA.t; delta : (F.gformula * F.gformula * Ex.t * bool) list; dlevel : int; plevel : int; ilevel : int; tbox : Th.t; unit_tbox : Th.t; (* theory env of facts at level 0 *) inst : Inst.t; heuristics : Heuristics.t ref; model_gen_mode : bool ref; ground_preds : F.t A.LT.Map.t; (* key <-> f *) add_inst: Formula.t -> bool; unit_facts_cache : (F.gformula * Ex.t) MF.t ref; } let steps = ref 0L let all_models_sat_env = ref None let latest_saved_env = ref None let terminated_normally = ref false exception Sat of t exception Unsat of Ex.t exception I_dont_know of t exception IUnsat of Ex.t * Term.Set.t list (*BISECT-IGNORE-BEGIN*) module Debug = struct let print_nb_related env = if verbose () then begin fprintf fmt "----------------------------------------------------@."; fprintf fmt " nb_related_to_both = %d@." env.nb_related_to_both; fprintf fmt " nb_related_to_goal = %d@." env.nb_related_to_goal; fprintf fmt " nb_related_to_hypo = %d@." env.nb_related_to_hypo; fprintf fmt " nb_unrelated = %d@." env.nb_unrelated; fprintf fmt "----------------------------------------------------@.@."; end let propagations (env, bcp, tcp, ap_delta, lits) = if debug_sat() then begin fprintf fmt "[sat] propagations: |lits| = %d , B = %b , T = %b , " (List.length lits) bcp tcp ; fprintf fmt "|Delta| = %d, |ap_Delta| = %d@." (List.length env.delta) (List.length ap_delta) end let is_it_unsat gf = if verbose () && debug_sat () then let s = match F.view gf.F.f with | F.Lemma _ -> "lemma" | F.Clause _ -> "clause" | F.Unit _ -> "conjunction" | F.Skolem _ -> "skolem" | F.Literal _ -> "literal" | F.Let _ -> "let" in fprintf fmt "[sat] the following %s is unsat ? :@.%a@.@." s F.print gf.F.f let pred_def f = if debug_sat () then eprintf "[sat] I assume a predicate: %a@.@." F.print f let unsat_rec dep = if debug_sat () then fprintf fmt "unsat_rec : %a@." Ex.print dep let assume gf dep env = if debug_sat () then let {F.f=f;age=age;lem=lem;mf=mf;from_terms=terms} = gf in fprintf fmt "[sat] at level (%d, %d) I assume a " env.dlevel env.plevel; begin match F.view f with | F.Literal a -> Term.print_list str_formatter terms; let s = flush_str_formatter () in let n = match lem with | None -> "" | Some ff -> (match F.view ff with F.Lemma xx -> xx.F.name | _ -> "") in fprintf fmt "LITERAL (%s : %s) %a@." n s Literal.LT.print a; fprintf fmt "==========================================@.@." | F.Unit _ -> fprintf fmt "conjunction@." | F.Clause _ -> fprintf fmt "clause %a@." F.print f | F.Lemma _ -> fprintf fmt "%d-atom lemma \"%a\"@." (F.size f) F.print f | F.Skolem _ -> fprintf fmt "skolem %a@." F.print f | F.Let {F.let_var=lvar; let_term=lterm; let_f=lf} -> fprintf fmt "let %a = %a in %a@." Symbols.print lvar Term.print lterm F.print lf end; if verbose () then fprintf fmt "with explanations : %a@." Explanation.print dep let unsat () = if debug_sat () then fprintf fmt "[sat] unsat@." let decide f env = if debug_sat () then fprintf fmt "[sat] I decide: at level (%d, %d), on %a@." env.dlevel env.plevel F.print f let instantiate env = if debug_sat () then fprintf fmt "[sat] I instantiate at level (%d, %d). Inst level = %d@." env.dlevel env.plevel env.ilevel let backtracking f env = if debug_sat () then fprintf fmt "[sat] backtrack: at level (%d, %d), and assume not %a@." env.dlevel env.plevel F.print f let backjumping f env = if debug_sat () then fprintf fmt "[sat] backjump: at level (%d, %d), I ignore the case %a@." env.dlevel env.plevel F.print f let elim _ _ = if debug_sat () && verbose () then fprintf fmt "[sat] elim@." let red _ _ = if debug_sat () && verbose () then fprintf fmt "[sat] red@." let delta d = if debug_sat () && verbose () && false then begin fprintf fmt "[sat] - Delta ---------------------@."; List.iter (fun (f1, f2, ex) -> fprintf fmt "(%a or %a), %a@." F.print f1.F.f F.print f2.F.f Ex.print ex) d; fprintf fmt "[sat] --------------------- Delta -@." end let gamma g = if false && debug_sat () && verbose () then begin fprintf fmt "[sat] --- GAMMA ---------------------@."; MF.iter (fun f (_, ex, dlvl, plvl) -> fprintf fmt "(%d, %d) %a \t->\t%a@." dlvl plvl F.print f Ex.print ex) g; fprintf fmt "[sat] - / GAMMA ---------------------@."; end let bottom classes = if bottom_classes () then printf "bottom:%a\n@." Term.print_tagged_classes classes let inconsistent expl env = if debug_sat () then fprintf fmt "inconsistent at level (%d, %d), reason : %a@." env.dlevel env.plevel Ex.print expl let in_mk_theories_instances () = if Options.debug_fpa() > 0 || debug_sat() then fprintf fmt "@.[sat] entering mk_theories_instances:@." let out_mk_theories_instances normal_exit = if Options.debug_fpa() > 0 || debug_sat() then if normal_exit then fprintf fmt "@.[sat] normal exit of mk_theories_instances.@.@." else fprintf fmt "@.[sat] exit mk_theories_instances with Inconsist.@.@." let print_f_conj fmt hyp = match hyp with | [] -> fprintf fmt "True"; | e::l -> fprintf fmt "%a" F.print e; List.iter (fun f -> fprintf fmt " /\\ %a" F.print f) l let print_theory_instance hyp gf = if Options.debug_fpa() > 1 || Options.debug_sat() then begin fprintf fmt "@.%s >@." (F.name_of_lemma_opt gf.F.lem); fprintf fmt " hypotheses: %a@." print_f_conj hyp; fprintf fmt " conclusion: %a@." F.print gf.F.f; end end (*BISECT-IGNORE-END*) let selector env f orig = not (MF.mem f env.gamma) && begin match F.view orig with | F.Lemma _ -> env.add_inst orig | _ -> true end let inst_predicates backward env inst tbox selector ilvl = try Inst.m_predicates ~backward inst tbox selector ilvl with Exception.Inconsistent (expl, classes) -> Debug.inconsistent expl env; Options.tool_req 2 "TR-Sat-Conflict-2"; env.heuristics := Heuristics.bump_activity !(env.heuristics) expl; raise (IUnsat (expl, classes)) let inst_lemmas backward env inst tbox selector ilvl = try Inst.m_lemmas ~backward inst tbox selector ilvl with Exception.Inconsistent (expl, classes) -> Debug.inconsistent expl env; Options.tool_req 2 "TR-Sat-Conflict-2"; env.heuristics := Heuristics.bump_activity !(env.heuristics) expl; raise (IUnsat (expl, classes)) let is_literal f = match F.view f with F.Literal _ -> true | _ -> false let extract_prop_model t = let s = ref SF.empty in MF.iter (fun f _ -> if (complete_model () && is_literal f) || F.is_in_model f then s := SF.add f !s ) t.gamma; !s let print_prop_model fmt s = SF.iter (fprintf fmt "\n %a" F.print) s let print_model ~header fmt t = Format.print_flush (); if header then fprintf fmt "\nModel\n@."; let pm = extract_prop_model t in if not (SF.is_empty pm) then begin fprintf fmt "Propositional:"; print_prop_model fmt pm; fprintf fmt "\n@."; end; Th.print_model fmt t.tbox let refresh_model_handler = if model () then fun t -> try let alrm = if Options.get_is_gui() then Sys.sigalrm (* troubles with GUI+VTARLM *) else Sys.sigvtalrm in Sys.set_signal alrm (Sys.Signal_handle (fun _ -> printf "%a@." (print_model ~header:true) t; Options.exec_timeout ())) with Invalid_argument _ -> () else fun _ -> () (* sat-solver *) let mk_gf f name mf gf = { F.f = f; origin_name = name; gdist = -1; hdist = -1; nb_reductions = 0; trigger_depth = max_int; age= 0; lem= None; from_terms = []; mf= mf; gf= gf; theory_elim = true; } let profile_conflicting_instances exp = if Options.profiling() then SF.iter (fun f -> match F.view f with | F.Lemma {F.name; loc} -> Profiling.conflicting_instance name loc | _ -> () )(Ex.formulas_of exp) let do_case_split env origin = if Options.case_split_policy () == origin then try if debug_sat() then fprintf fmt "[sat] performing case-split@."; let tbox, new_terms = Th.do_case_split env.tbox in let inst = Inst.add_terms env.inst new_terms (mk_gf F.vrai "" false false) in {env with tbox = tbox; inst = inst} with Exception.Inconsistent (expl, classes) -> Debug.inconsistent expl env; Options.tool_req 2 "TR-Sat-Conflict-2"; env.heuristics := Heuristics.bump_activity !(env.heuristics) expl; raise (IUnsat (expl, classes)) else env let b_elim f env = try let _ = MF.find f env.gamma in Options.tool_req 2 "TR-Sat-Bcp-Elim-1"; if Options.profiling() then Profiling.elim true; true with Not_found -> false let update_unit_facts env ff dep = let f = ff.F.f in if sat_learning () && not (MF.mem f !(env.unit_facts_cache)) then begin assert (Ex.has_no_bj dep); env.unit_facts_cache := MF.add f (ff, dep) !(env.unit_facts_cache) end let learn_clause ({gamma} as env) ff0 dep = if sat_learning () then let fl, dep = Ex.fold_atoms (fun e (l, ex) -> match e with | Ex.Bj f -> let d = try let _,_,d,_ = MF.find f gamma in d with Not_found -> max_int in (F.mk_not f, d) :: l, ex | _ -> l, Ex.add_fresh e ex )dep ([], Ex.empty) in let fl = List.fast_sort (fun (_, d1) (_,d2) -> d1 - d2) fl in let f = List.fold_left (fun acc (f, _) -> F.mk_or f acc false (F.id f)) ff0.F.f fl in update_unit_facts env {ff0 with F.f} dep let query_of tcp_cache tmp_cache ff a env = try MA.find a !tcp_cache with Not_found -> try MA.find a !tmp_cache with Not_found -> assert (A.LT.is_ground a); match Th.query a env.tbox with | No -> tmp_cache := MA.add a No !tmp_cache; No | Yes (ex,_) as y -> learn_clause env ff ex; tcp_cache := MA.add a y !tcp_cache; y let th_elim tcp_cache tmp_cache ff env = match F.view ff.F.f with | F.Literal a -> let ans = query_of tcp_cache tmp_cache ff a env in if ans != No then begin Options.tool_req 2 "TR-Sat-Bcp-Elim-2"; if Options.profiling() then Profiling.elim false; end; ans | _ -> No let red tcp_cache tmp_cache ff env tcp = let nf = F.mk_not ff.F.f in let nff = {ff with F.f = nf} in try let _, ex = MF.find nf !(env.unit_facts_cache) in Yes(ex, []), true with Not_found -> try let _, ex, _, _ = MF.find nf env.gamma in let r = Yes (ex, Th.cl_extract env.tbox) in Options.tool_req 2 "TR-Sat-Bcp-Red-1"; r, true with Not_found -> if not tcp then No, false else match F.view nf with | F.Literal a -> let ans = query_of tcp_cache tmp_cache nff a env in if ans != No then Options.tool_req 2 "TR-Sat-Bcp-Red-2"; ans, false | _ -> No, false let factorize_iff a_t f = let not_at = F.mk_not (F.mk_lit a_t 0) in match F.view f with | F.Unit(f1, f2) -> begin match F.view f1, F.view f2 with | F.Clause(g11, g12, _), F.Clause(g21, g22, _) -> let ng21 = F.mk_not g21 in let ng22 = F.mk_not g22 in assert (F.equal g11 ng21 || F.equal g11 ng22); assert (F.equal g12 ng21 || F.equal g12 ng22); if F.equal g21 not_at then g22 else if F.equal ng21 not_at then F.mk_not g22 else if F.equal g22 not_at then g21 else if F.equal ng22 not_at then F.mk_not g21 else assert false | _ -> assert false end | F.Literal a -> begin match Literal.LT.view a with | Literal.Pred (t, b) -> if b then F.faux else F.vrai | _ -> assert false end | _ -> assert false let pred_def env f name loc = Debug.pred_def f; let t = Term.make (Symbols.name name) [] Ty.Tbool in if not (Term.Set.mem t (F.ground_terms_rec f)) then {env with inst = Inst.add_predicate env.inst (mk_gf f name true false)} else begin let a_t = A.LT.mk_pred t false in assert (not (A.LT.Map.mem a_t env.ground_preds)); let f_simpl = factorize_iff a_t f in let gp = A.LT.Map.add a_t f_simpl env.ground_preds in let gp = A.LT.Map.add (A.LT.neg a_t) (F.mk_not f_simpl) gp in {env with ground_preds = gp} end let add_dep f dep = match F.view f with | F.Literal _ when proof () -> if not (Ex.mem (Ex.Bj f) dep) then Ex.union (Ex.singleton (Ex.Dep f)) dep else dep | F.Clause _ when proof () -> Ex.union (Ex.singleton (Ex.Dep f)) dep | _ -> dep let rec add_dep_of_formula f dep = let dep = add_dep f dep in match F.view f with | F.Unit (f1, f2) when proof () -> add_dep_of_formula f2 (add_dep_of_formula f1 dep) | _ -> dep (* currently: => this is not done modulo theories => unit_facts_cache not taken into account *) let update_distances = let aux gf ff = let gdist = max ff.F.gdist gf.F.gdist in let hdist = max ff.F.hdist gf.F.hdist in let gdist = if gdist < 0 then gdist else gdist + 1 in let hdist = if hdist < 0 then hdist else hdist + 1 in {gf with F.gdist; hdist} in fun env gf red -> let nf = F.mk_not red in try let ff, _ = MF.find nf !(env.unit_facts_cache) in aux gf ff with Not_found -> try let ff, _, _, _ = MF.find nf env.gamma in aux gf ff with Not_found -> gf let do_bcp env tcp tcp_cache tmp_cache delta acc = let tcp = tcp && not (Options.no_tcp ()) in List.fold_left (fun (cl,u) ((({F.f=f1} as gf1), ({F.f=f2} as gf2), d, _) as fd) -> Debug.elim gf1 gf2; if b_elim f1 env || b_elim f2 env then (cl,u) else try if not tcp then raise Exit; assert (gf1.F.theory_elim == gf2.F.theory_elim); let u = match th_elim tcp_cache tmp_cache gf1 env, th_elim tcp_cache tmp_cache gf2 env with | No, No -> raise Exit | Yes _, _ | _, Yes _ when gf1.F.theory_elim -> u | Yes (d1, c1), Yes (d2, c2) -> u (* eliminate if both are true ? why ? *) (*(gf1, Ex.union d d1) :: (gf2, Ex.union d d2) :: u*) | Yes (d1, c1), _ -> (gf1, Ex.union d d1) :: u | _, Yes (d2, c2) -> (gf2, Ex.union d d2) :: u in cl, u with Exit -> begin Debug.red gf1 gf2; match red tcp_cache tmp_cache gf1 env tcp, red tcp_cache tmp_cache gf2 env tcp with | (Yes (d1, c1), b1) , (Yes (d2, c2), b2) -> if Options.profiling() then Profiling.bcp_conflict b1 b2; let expl = Ex.union (Ex.union d d1) d2 in let c = List.rev_append c1 c2 in raise (Exception.Inconsistent (expl, c)) | (Yes(d1, _), b) , (No, _) -> if Options.profiling() then Profiling.red b; let gf2 = {gf2 with F.nb_reductions = gf2.F.nb_reductions + 1} in let gf2 = update_distances env gf2 f1 in cl, (gf2,Ex.union d d1) :: u | (No, _) , (Yes(d2, _),b) -> if Options.profiling() then Profiling.red b; let gf1 = {gf1 with F.nb_reductions = gf1.F.nb_reductions + 1} in let gf1 = update_distances env gf1 f2 in cl, (gf1,Ex.union d d2) :: u | (No, _) , (No, _) -> fd::cl , u end ) acc delta let theory_assume env facts = Options.tool_req 2 "TR-Sat-Assume-Lit"; if facts == [] then env else let facts, ufacts, inst, mf, gf = List.fold_left (fun (facts, ufacts, inst, mf, gf) (a, ff, ex, dlvl, plvl) -> assert (A.LT.is_ground a); let facts = (a, ex, dlvl, plvl) :: facts in let ufacts = if Ex.has_no_bj ex then (a, ex, dlvl, plvl) :: ufacts else ufacts in if not ff.F.mf then begin fprintf fmt "%a@." F.print ff.F.f; assert false end; let inst = if ff.F.mf then Inst.add_terms inst (A.LT.terms_nonrec a) ff else inst in facts, ufacts, inst, mf || ff.F.mf, gf || ff.F.gf )([], [], env.inst, false, false) facts in let utbox, _, _ = (* assume unit facts in the theory *) if ufacts != [] && env.dlevel > 0 then try Th.assume ~ordered:false ufacts env.unit_tbox with Exception.Inconsistent (reason, _) as e -> assert (Ex.has_no_bj reason); if Options.profiling() then Profiling.theory_conflict(); if debug_sat() then fprintf fmt "[sat] solved by unit_tbox@."; raise e else env.unit_tbox, Term.Set.empty, 0 in let tbox, new_terms, cpt = try Th.assume facts env.tbox with Exception.Inconsistent _ as e -> if Options.profiling() then Profiling.theory_conflict(); raise e in let utbox = if env.dlevel = 0 then tbox else utbox in let inst = Inst.add_terms inst new_terms (mk_gf F.vrai "" mf gf) in steps := Int64.add (Int64.of_int cpt) !steps; if steps_bound () <> -1 && Int64.compare !steps (Int64.of_int (steps_bound ())) > 0 then begin printf "Steps limit reached: %Ld@." !steps; exit 1 end; { env with tbox = tbox; unit_tbox = utbox; inst = inst } let propagations ((env, bcp, tcp, ap_delta, lits) as result) = let env = theory_assume env lits in let env = do_case_split env Util.AfterTheoryAssume in Debug.propagations result; let tcp_cache = ref env.tcp_cache in let tmp_cache = ref MA.empty in let acc = if bcp then do_bcp env tcp tcp_cache tmp_cache env.delta ([], []) else env.delta, [] (* no even bcp for old clauses *) in (*both bcp and tcp set to true for new clauses*) let delta, unit = do_bcp env true tcp_cache tmp_cache ap_delta acc in {env with delta = delta; tcp_cache = !tcp_cache}, unit let update_nb_related t ff = let gdist = ff.F.gdist in let hdist = ff.F.hdist in match gdist >= 0, hdist >= 0 with | true , false -> {t with nb_related_to_goal = t.nb_related_to_goal + 1} | false, true -> {t with nb_related_to_hypo = t.nb_related_to_hypo + 1} | false, false -> {t with nb_unrelated = t.nb_unrelated + 1} | true , true -> (* update these three counter to simplify comparaisons in the rest of the module: both+1 imples goal+1 *) {t with nb_related_to_both = t.nb_related_to_both + 1; nb_related_to_goal = t.nb_related_to_goal + 1; nb_related_to_hypo = t.nb_related_to_hypo + 1} let rec asm_aux acc list = List.fold_left (fun ((env, bcp, tcp, ap_delta, lits) as acc) ({F.f=f} as ff ,dep) -> refresh_model_handler env; Options.exec_thread_yield (); let dep = add_dep f dep in let dep_gamma = add_dep_of_formula f dep in (* propagate all unit facts to cache *) if sat_learning () && Ex.has_no_bj dep_gamma then update_unit_facts env ff dep_gamma; Debug.gamma env.gamma; (try let _, ex_nf, _, _ = MF.find (F.mk_not f) env.gamma in Options.tool_req 2 "TR-Sat-Conflict-1"; if Options.profiling() then Profiling.bool_conflict (); let exx = Ex.union dep_gamma ex_nf in (* missing VSID, but we have regressions when it is activated env.heuristics := Heuristics.bump_activity !(env.heuristics) exx;*) raise (IUnsat (exx, Th.cl_extract env.tbox)) with Not_found -> ()); if MF.mem f env.gamma then begin Options.tool_req 2 "TR-Sat-Remove"; acc end else let env = if ff.F.mf && greedy () then { env with inst= Inst.add_terms env.inst (F.ground_terms_rec f) ff } else env in Debug.assume ff dep env; let env = { env with gamma = MF.add f (ff,dep_gamma,env.dlevel,env.plevel) env.gamma; plevel = env.plevel + 1; } in let env = update_nb_related env ff in match F.view f with | F.Unit (f1, f2) -> Options.tool_req 2 "TR-Sat-Assume-U"; let lst = [{ff with F.f=f1},dep ; {ff with F.f=f2},dep] in asm_aux (env, true, tcp, ap_delta, lits) lst | F.Clause(f1,f2,is_impl) -> Options.tool_req 2 "TR-Sat-Assume-C"; let p1 = {ff with F.f=f1} in let p2 = {ff with F.f=f2} in let p1, p2 = if is_impl || F.size f1 <= F.size f2 then p1, p2 else p2, p1 in env, true, tcp, (p1,p2,dep,is_impl)::ap_delta, lits | F.Lemma l -> Options.tool_req 2 "TR-Sat-Assume-Ax"; let inst_env, direct_insts = Inst.add_lemma env.inst ff dep in let env = {env with inst = inst_env} in asm_aux (env, true, tcp, ap_delta, lits) direct_insts | F.Literal a -> let lits = (a, ff, dep, env.dlevel, env.plevel)::lits in let acc = env, true, true, ap_delta, lits in begin try (* ground preds bahave like proxies of lazy CNF *) asm_aux acc [{ff with F.f = A.LT.Map.find a env.ground_preds}, dep] with Not_found -> acc end | F.Skolem quantif -> Options.tool_req 2 "TR-Sat-Assume-Sko"; let f' = F.skolemize quantif in asm_aux (env, true, tcp, ap_delta, lits) [{ff with F.f=f'},dep] | F.Let {F.let_var=lvar; let_term=lterm; let_subst=s; let_f=lf} -> Options.tool_req 2 "TR-Sat-Assume-Let"; let f' = F.apply_subst s lf in let id = F.id f' in let v = Symbols.Map.find lvar (fst s) in let lst = [{ff with F.f=F.mk_lit (A.LT.mk_eq v lterm) id}, dep; {ff with F.f=f'}, dep] in asm_aux (env, true, tcp, ap_delta, lits) lst ) acc list let rec assume env list = if list == [] then env else try let result = asm_aux (env, false, false, [], []) list in let env, list = propagations result in assume env list with Exception.Inconsistent (expl, classes) -> Debug.inconsistent expl env; Options.tool_req 2 "TR-Sat-Conflict-2"; env.heuristics := Heuristics.bump_activity !(env.heuristics) expl; raise (IUnsat (expl, classes)) let new_inst_level env = let new_ilevel = env.ilevel + 1 in let env = {env with ilevel = new_ilevel} in if Options.profiling() then Profiling.instantiation new_ilevel; Debug.instantiate env; env (* this function has an internal state used to store the latest generated instances. These instances are used to try to backjump as far as possible using simple "assume"s, ie without decision. The reason for this modification is that a set of instances may cause several conflict, and we don't always detect the one which makes us backjump better. *) let update_instances_cache = let last_cache = ref [] in fun l_opt -> match l_opt with | None -> Some !last_cache (* Get *) | Some l -> (* Set or reset if l = [] *) last_cache := List.filter (fun (_,e) -> Ex.has_no_bj e) l; None (* returns the (new) env and true if some new instances are made *) let inst_and_assume backward env inst_function inst_env = let gd, ngd = inst_function backward env inst_env env.tbox (selector env) env.ilevel in let l = List.rev_append (List.rev gd) ngd in (* do this to avoid loosing instances when a conflict is detected directly with some of these instances only, ie before assumign the others *) if sat_learning () then List.iter (fun (gf, dep) -> if Ex.has_no_bj dep then update_unit_facts env gf dep; )l; if Options.profiling() then Profiling.instances l; match l with | [] -> env, false | _ -> (* Put new generated instances in cache *) ignore (update_instances_cache (Some l)); let env = assume env l in (* No conflict by direct assume, empty cache *) ignore (update_instances_cache (Some [])); env, true let update_all_models_option env = if all_models () then begin (* should be used when all_models () is activated only *) if !all_models_sat_env == None then all_models_sat_env := Some env; let m = MF.fold (fun f _ s -> if is_literal f then SF.add f s else s) env.gamma SF.empty in Format.printf "--- SAT model found ---"; Format.printf "%a@." print_prop_model m; Format.printf "--- / SAT model ---@."; raise (IUnsat (Ex.make_deps m, [])) end let get_all_models_answer () = if all_models () then match !all_models_sat_env with | Some env -> raise (Sat env) | None -> fprintf fmt "[all-models] No SAT models found@." let compute_concrete_model env origin = if abs (interpretation ()) <> origin then env else try (* to push pending stuff *) let env = do_case_split env (Options.case_split_policy ()) in let env = {env with tbox = Th.compute_concrete_model env.tbox} in latest_saved_env := Some env; env with Exception.Inconsistent (expl, classes) -> Debug.inconsistent expl env; Options.tool_req 2 "TR-Sat-Conflict-2"; env.heuristics := Heuristics.bump_activity !(env.heuristics) expl; raise (IUnsat (expl, classes)) let return_cached_model return_function = let i = abs(interpretation ()) in assert (i = 1 || i = 2 || i = 3); assert (not !terminated_normally); terminated_normally := true; (* to avoid loops *) begin match !latest_saved_env with | None -> fprintf fmt "[FunSat] %s%s%s@." "It seems that no model has been computed so for." " You may need to change your model generation strategy" ", or to increase your timeout." | Some env -> let cs_tbox = Th.get_case_split_env env.tbox in let uf = Ccx.Main.get_union_find cs_tbox in Combine.Uf.output_concrete_model uf end; return_function () let () = at_exit (fun () -> let i = abs(interpretation ()) in if not !terminated_normally && (i = 1 || i = 2 || i = 3) then return_cached_model (fun () -> ()) ) let return_answer env orig return_function = update_all_models_option env; let env = compute_concrete_model env orig in let uf = Ccx.Main.get_union_find (Th.get_case_split_env env.tbox) in Options.Time.unset_timeout ~is_gui:(Options.get_is_gui()); Combine.Uf.output_concrete_model uf; terminated_normally := true; return_function env let switch_to_model_gen env = not !terminated_normally && not !(env.model_gen_mode) && let i = abs (interpretation ()) in (i = 1 || i = 2 || i = 3) let do_switch_to_model_gen env = let i = abs (interpretation ()) in assert (i = 1 || i = 2 || i = 3); if not !(env.model_gen_mode) && Pervasives.(<>) (Options.interpretation_timelimit ()) 0. then begin Options.Time.unset_timeout ~is_gui:(Options.get_is_gui()); Options.Time.set_timeout ~is_gui:(Options.get_is_gui()) (Options.interpretation_timelimit ()); env.model_gen_mode := true; return_answer env i (fun _ -> raise Util.Timeout) end else return_cached_model (fun () -> raise Util.Timeout) let reduce_hypotheses tcp_cache tmp_cache env acc (hyp, gf, dep) = Debug.print_theory_instance hyp gf; let dep, acc = List.fold_left (fun (dep, acc) f -> try let _, ex, _, _ = MF.find f env.gamma in Ex.union dep ex, acc with Not_found -> try (*if no_sat_learning() then raise Not_found;*) let _, ex = MF.find f !(env.unit_facts_cache) in Ex.union dep ex, ({gf with F.f}, ex) :: acc with Not_found -> match F.view f with | F.Literal a -> begin match query_of tcp_cache tmp_cache {gf with F.f=f} a env with | Sig.Yes (ex, _) -> Ex.union dep ex, ({gf with F.f}, ex) :: acc | No -> fprintf fmt "Bad inst ! Hyp %a is not true !@." F.print f; assert false end | _ -> Format.eprintf "Currently, arbitrary formulas in Hyps are not Th-reduced@."; assert false )(dep, acc) hyp in (gf, dep) :: acc let does_not_contain_a_disjunction = let rec aux f = match F.view f with | F.Literal _ -> true | F.Unit(f1, f2) -> aux f1 && aux f2 | F.Clause _ -> false | F.Lemma _ | F.Skolem _ | F.Let _ -> (*failwith "Not in current theory axioms"*) false in fun (gf, _) -> aux gf.F.f let mk_theories_instances ~do_syntactic_matching ~rm_clauses env inst = let {gamma; tbox} = env in Debug.in_mk_theories_instances (); let t_match = Inst.matching_terms_info inst in try let tbox, l = Th.theories_instances ~do_syntactic_matching t_match tbox (selector env) env.ilevel env.dlevel in let env = {env with tbox} in match l with | [] -> env, false | _ -> let tcp_cache = ref env.tcp_cache in let tmp_cache = ref MA.empty in let rl = List.fold_left (reduce_hypotheses tcp_cache tmp_cache env) [] l in let l = List.rev rl in let l = if not rm_clauses then l else List.filter does_not_contain_a_disjunction l in let env = {env with tcp_cache = !tcp_cache} in ignore (update_instances_cache (Some l)); let env = assume env l in ignore (update_instances_cache (Some [])); Debug.out_mk_theories_instances true; env, l != [] with Exception.Inconsistent (expl, classes) -> Debug.out_mk_theories_instances false; Debug.inconsistent expl env; Options.tool_req 2 "TR-Sat-Conflict-2"; env.heuristics := Heuristics.bump_activity !(env.heuristics) expl; raise (IUnsat (expl, classes)) let syntactic_th_inst ~rm_clauses env = mk_theories_instances ~do_syntactic_matching:true ~rm_clauses env let semantic_th_inst = let rec aux_rec ~rm_clauses env inst loop nb_ok = let env, inst_made = mk_theories_instances ~do_syntactic_matching:false ~rm_clauses env inst in if inst_made then incr nb_ok; if not inst_made || loop <= 1 then env else aux_rec ~rm_clauses env inst (loop - 1) nb_ok in fun ~rm_clauses env inst ~loop -> let nb_ok = ref 0 in aux_rec ~rm_clauses env inst loop nb_ok, !nb_ok > 0 let greedy_instantiation env = if greedy () then return_answer env 1 (fun e -> raise (Sat e)); let gre_inst = MF.fold (fun f (gf,_,_,_) inst -> Inst.add_terms inst (F.ground_terms_rec f) gf) env.gamma env.inst in let env = new_inst_level env in let env, ok1 = inst_and_assume Util.Normal env inst_predicates gre_inst in let env, ok2 = inst_and_assume Util.Normal env inst_lemmas gre_inst in let env, ok3 = syntactic_th_inst env gre_inst ~rm_clauses:false in let env, ok4 = semantic_th_inst env gre_inst ~rm_clauses:false ~loop:4 in let env = do_case_split env Util.AfterMatching in if ok1 || ok2 || ok3 || ok4 then env else return_answer env 1 (fun e -> raise (Sat e)) let normal_instantiation env try_greedy = Debug.print_nb_related env; let env = do_case_split env Util.BeforeMatching in let env = compute_concrete_model env 2 in let env = new_inst_level env in let env, ok1 = inst_and_assume Util.Normal env inst_predicates env.inst in let env, ok2 = inst_and_assume Util.Normal env inst_lemmas env.inst in let env, ok3 = syntactic_th_inst env env.inst ~rm_clauses:false in let env, ok4 = semantic_th_inst env env.inst ~rm_clauses:false ~loop:4 in let env = do_case_split env Util.AfterMatching in if ok1 || ok2 || ok3 || ok4 then env else if try_greedy then greedy_instantiation env else env (* should be merged with do_bcp/red/elim ? calls to debug hooks are missing *) let propagate_unit_facts_in_cache env = if no_sat_learning() then None else let cache = !(env.unit_facts_cache) in let in_cache f = try Some (snd (MF.find f cache)) with Not_found -> None in let prop, delt = List.fold_left (fun (prop, new_delta) ((gf1, gf2, d, _) as e) -> let {F.f=f1} = gf1 in let {F.f=f2} = gf2 in let nf1 = F.mk_not f1 in let nf2 = F.mk_not f2 in match in_cache nf1, in_cache nf2 with | Some d1, Some d2 -> if Options.profiling() then Profiling.bcp_conflict true true; let expl = Ex.union (Ex.union d d1) d2 in raise (IUnsat (expl, [])) | Some d1, _ -> (* a is false, so b should be true *) if Options.profiling() then Profiling.red true; let not_gf1 = {gf1 with F.f = nf1} in let gf2 = {gf2 with F.nb_reductions = gf2.F.nb_reductions + 1} in let gf2 = update_distances env gf2 f1 in (gf2, Ex.union d d1) :: (not_gf1, d1) :: prop, new_delta | _, Some d2 -> (* b is false, so a should be true *) let not_gf2 = {gf2 with F.f = nf2} in let gf1 = {gf1 with F.nb_reductions = gf1.F.nb_reductions + 1} in let gf1 = update_distances env gf1 f2 in (gf1, Ex.union d d2) :: (not_gf2, d2) :: prop, new_delta | None, None -> match in_cache f1, in_cache f2 with | None, None -> prop, e :: new_delta | Some d1, _ -> (gf1, d1) :: prop, new_delta | None, Some d2 -> (gf2, d2) :: prop, new_delta )([], []) env.delta in match prop with [] -> None | _ -> Some (prop, delt) let rec unsat_rec env fg is_decision = try let env = assume env [fg] in let env = if is_decision || not (Options.instantiate_after_backjump ()) then env else normal_instantiation env false in back_tracking env with | IUnsat (d, classes) -> profile_conflicting_instances d; Debug.bottom classes; Debug.unsat (); d and back_tracking env = try let env = compute_concrete_model env 3 in if env.delta == [] || Options.no_decisions() then back_tracking (normal_instantiation env true) else match propagate_unit_facts_in_cache env with | Some (propag, new_delta_rev) -> let env = {env with delta = List.rev new_delta_rev} in back_tracking (assume env propag) | None -> try make_one_decision env with No_suitable_decision -> back_tracking (normal_instantiation env true) with | Util.Timeout when switch_to_model_gen env -> do_switch_to_model_gen env and make_one_decision env = let ({F.f=f} as a,b,d,is_impl), l = Heuristics.choose env.delta !(env.heuristics) in let new_level = env.dlevel + 1 in if Options.profiling() then Profiling.decision new_level a.F.origin_name; let env_a = {env with delta=l; dlevel = new_level; plevel = 0} in Debug.decide f env_a; let dep = unsat_rec env_a (a,Ex.singleton (Ex.Bj f)) true in Debug.unsat_rec dep; try let dep' = try Ex.remove (Ex.Bj f) dep with Not_found when Options.no_backjumping() -> dep in Debug.backtracking f env; Options.tool_req 2 "TR-Sat-Decide"; if Options.profiling() then begin Profiling.reset_dlevel env.dlevel; Profiling.reset_ilevel env.ilevel; end; let not_a = {a with F.f = F.mk_not f} in if sat_learning () then learn_clause env not_a dep'; let env = {env with delta=l} in (* in the section below, we try to backjump further with latest generated instances if any *) begin match update_instances_cache None with | None -> assert false | Some [] -> () | Some l -> (* backtrack further if Unsat is raised by the assume below *) ignore (assume env l); (*No backtrack, reset cache*) ignore (update_instances_cache (Some [])); end; unsat_rec (assume env [b, Ex.union d dep']) (not_a,dep') false with Not_found -> Debug.backjumping (F.mk_not f) env; Options.tool_req 2 "TR-Sat-Backjumping"; dep let max_term_depth_in_sat env = let aux mx f = max mx (F.max_term_depth f) in let max_t = MF.fold (fun f _ mx -> aux mx f) env.gamma 0 in A.LT.Map.fold (fun _ f mx -> aux mx f) env.ground_preds max_t let rec backward_instantiation_rec env rnd max_rnd = Debug.print_nb_related env; if rnd > max_rnd then env else let nb1 = env.nb_related_to_goal in if verbose () || debug_sat () then fprintf fmt "[sat.backward] round %d / %d@." rnd max_rnd; let env, new_i1 = inst_and_assume Util.Backward env inst_predicates env.inst in let env, new_i2 = inst_and_assume Util.Backward env inst_lemmas env.inst in let nb2 = env.nb_related_to_goal in if verbose () || debug_sat () then fprintf fmt "[sat.backward] backward: %d goal-related hyps (+%d)@." nb2 (nb2-nb1); if (new_i1 || new_i2) && nb1 < nb2 then backward_instantiation_rec env (rnd+1) max_rnd else env let backward_instantiation env deepest_term = try let no_Ematching = Options.no_Ematching () in let no_NLA = Options.no_NLA () in let no_ac = Options.no_ac () in let greedy = Options.greedy () in (*let normalize_instances = Options.normalize_instances () in*) let max_split = Options.max_split () in Options.set_no_Ematching true; Options.set_no_NLA true; Options.set_no_ac true; Options.set_greedy true; (*Options.set_normalize_instances true;*) Options.set_max_split Numbers.Q.zero; let max_rnd = 2 * deepest_term in let modified_env = backward_instantiation_rec env 1 max_rnd in Options.set_no_Ematching no_Ematching; Options.set_no_NLA no_NLA; Options.set_no_ac no_ac; Options.set_greedy greedy; (*Options.set_normalize_instances normalize_instances;*) Options.set_max_split max_split; let l = MF.fold (fun f (ff, ex, dlvl, plvl) acc -> if ff.F.gdist >= 0 then (ff, ex, plvl) :: acc else acc )modified_env.gamma [] in let l = List.fast_sort (fun (ff1, _, plvl1) (ff2, _, plvl2) -> let c = ff2.F.gdist - ff1.F.gdist in if c <> 0 then c else plvl2 - plvl1 )l in let l = List.rev_map (fun (ff, ex, _) -> ff, ex) l in if verbose () || debug_sat () then List.iter (fun (ff, ex) -> fprintf fmt "%2d : %a@.@." ff.F.gdist F.print ff.F.f )l; let env = assume env l in Debug.print_nb_related env; if verbose () || debug_sat () then fprintf fmt "[sat.backward] done (after %2.4f seconds)\n@." (Options.Time.value ()); env with IUnsat _ as e -> if verbose () || debug_sat () then fprintf fmt "[sat.backward] solved with backward !@."; raise e let unsat env gf = Debug.is_it_unsat gf; try let env = assume env [gf, Ex.empty] in let env = {env with inst = (* add all the terms of the goal to matching env *) Inst.add_terms env.inst (F.ground_terms_rec gf.F.f) gf} in (* this includes axioms and ground preds but not general predicates *) let max_t = max_term_depth_in_sat env in let env = {env with inst = Inst.register_max_term_depth env.inst max_t} in let env = if Options.no_backward () then env else backward_instantiation env max_t in let env = new_inst_level env in let env, _ = syntactic_th_inst env env.inst ~rm_clauses:true in let env, _ = semantic_th_inst env env.inst ~rm_clauses:true ~loop:4 in let env, _ = inst_and_assume Util.Normal env inst_predicates env.inst in let env, _ = syntactic_th_inst env env.inst ~rm_clauses:true in let env, _ = semantic_th_inst env env.inst ~rm_clauses:true ~loop:4 in (* goal directed for lemmas *) let gd, _ = inst_lemmas Util.Normal env env.inst env.tbox (selector env) env.ilevel in if Options.profiling() then Profiling.instances gd; let env = assume env gd in let env, _ = syntactic_th_inst env env.inst ~rm_clauses:true in let env, _ = semantic_th_inst env env.inst ~rm_clauses:true ~loop:4 in let d = back_tracking env in get_all_models_answer (); terminated_normally := true; d with | IUnsat (dep, classes) -> Debug.bottom classes; Debug.unsat (); get_all_models_answer (); terminated_normally := true; dep | Util.Timeout when switch_to_model_gen env -> do_switch_to_model_gen env let assume env fg = try assume env [fg,Ex.empty] with | IUnsat (d, classes) -> terminated_normally := true; Debug.bottom classes; raise (Unsat d) | Util.Timeout when switch_to_model_gen env -> do_switch_to_model_gen env let unsat env fg = if Options.timers() then try Timers.exec_timer_start Timers.M_Sat Timers.F_unsat; let env = unsat env fg in Timers.exec_timer_pause Timers.M_Sat Timers.F_unsat; env with e -> Timers.exec_timer_pause Timers.M_Sat Timers.F_unsat; raise e else unsat env fg let assume env fg = if Options.timers() then try Timers.exec_timer_start Timers.M_Sat Timers.F_assume; let env = assume env fg in Timers.exec_timer_pause Timers.M_Sat Timers.F_assume; env with e -> Timers.exec_timer_pause Timers.M_Sat Timers.F_assume; raise e else assume env fg let reset_refs () = steps := 0L; all_models_sat_env := None; latest_saved_env := None; terminated_normally := false let empty () = (* initialize some structures in SAT.empty. Otherwise, T.faux is never added as it is replaced with (not T.vrai) *) reset_refs (); let gf_true = mk_gf F.vrai "" true true in let inst = Inst.empty in let tbox = Th.empty () in let inst = Inst.add_terms inst (Term.Set.singleton Term.vrai) gf_true in let inst = Inst.add_terms inst (Term.Set.singleton Term.faux) gf_true in let tbox = Th.add_term tbox Term.vrai true in let tbox = Th.add_term tbox Term.faux true in let env = { gamma = MF.empty; nb_related_to_goal = 0; nb_related_to_hypo = 0; nb_related_to_both = 0; nb_unrelated = 0; tcp_cache = MA.empty; delta = [] ; dlevel = 0; plevel = 0; ilevel = 0; tbox = tbox; unit_tbox = tbox; inst = inst; heuristics = ref (Heuristics.empty ()); model_gen_mode = ref false; ground_preds = A.LT.Map.empty; unit_facts_cache = ref MF.empty; add_inst = fun _ -> true; } in assume env gf_true (*maybe usefull when -no-theory is on*) let empty_with_inst add_inst = { (empty ()) with add_inst = add_inst } let get_steps () = !steps let retrieve_used_context env dep = (* TODO: remove redundancies because of theories axioms *) let l1, l2 = Inst.retrieve_used_context env.inst dep in let r1, r2 = Th.retrieve_used_context env.tbox dep in List.rev_append l1 r1, List.rev_append l2 r2 let assume_th_elt env th_elt = {env with tbox = Th.assume_th_elt env.tbox th_elt} alt-ergo-free-2.0.0/lib/reasoners/inequalities.ml0000664000175000017500000003540513430774474017561 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Format open Options module Z = Numbers.Z module Q = Numbers.Q module type S = sig module P : Polynome.EXTENDED_Polynome module MP : Map.S with type key = P.t type t = { ple0 : P.t; is_le : bool; (* int instead of Literal.LT.t as a key to prevent us from using it in deductions *) dep : (Q.t * P.t * bool) Util.MI.t; expl : Explanation.t; age : Z.t; } module MINEQS : sig type mp = (t * Q.t) MP.t val empty : mp val is_empty : mp -> bool val younger : t -> t -> bool val insert : t -> mp -> mp val ineqs_of : mp -> t list val add_to_map : mp -> t list -> mp val iter : (P.t -> (t * Q.t) -> unit) -> mp -> unit val fold : (P.t -> (t * Q.t) -> 'a -> 'a) -> mp -> 'a -> 'a end val current_age : unit -> Numbers.Z.t val incr_age : unit -> unit val create_ineq : P.t -> P.t -> bool -> Literal.LT.t option -> Explanation.t -> t val print_inequation : Format.formatter -> t -> unit val fourierMotzkin : ('are_eq -> 'acc -> P.r option -> t list -> 'acc) -> 'are_eq -> 'acc -> MINEQS.mp -> 'acc val fmSimplex : ('are_eq -> 'acc -> P.r option -> t list -> 'acc) -> 'are_eq -> 'acc -> MINEQS.mp -> 'acc val available : ('are_eq -> 'acc -> P.r option -> t list -> 'acc) -> 'are_eq -> 'acc -> MINEQS.mp -> 'acc end module type Container_SIG = sig module Make (X : Sig.X) (Uf : Uf.S with type r = X.r) (P : Polynome.EXTENDED_Polynome with type r = X.r) : S with module P = P end module Container : Container_SIG = struct module Make (X : Sig.X) (Uf : Uf.S with type r = X.r) (P : Polynome.EXTENDED_Polynome with type r = X.r) : S with module P = P = struct module P = P module MP = Map.Make(P) module SP = Set.Make(P) module SX = Set.Make(struct type t = X.r let compare = X.hash_cmp end) module MX = Map.Make(struct type t = X.r let compare = X.hash_cmp end) type r = P.r type uf = Uf.t let age_cpt = ref Z.zero let current_age () = !age_cpt let incr_age () = age_cpt := Z.add !age_cpt Z.one; type t = { ple0 : P.t; is_le : bool; dep : (Q.t * P.t * bool) Util.MI.t; expl : Explanation.t; age : Z.t; } let print_inequation fmt ineq = fprintf fmt "%a %s 0 %a" P.print ineq.ple0 (if ineq.is_le then "<=" else "<") Explanation.print ineq.expl let create_ineq p1 p2 is_le a expl = let ple0 = P.sub p1 p2 in match P.to_list ple0 with | ([], ctt) when is_le && Q.sign ctt > 0-> raise (Intervals.NotConsistent expl) | ([], ctt) when not is_le && Q.sign ctt >= 0 -> raise (Intervals.NotConsistent expl) | _ -> let p,c,d = P.normal_form ple0 in (* ple0 = (p + c) * d, and d > 0 *) assert (Q.compare d Q.zero > 0); let c = if P.type_info p == Ty.Treal then c else (Q.ceiling c) in let p = P.add_const c p in let dep = match a with | Some a -> Util.MI.singleton (Literal.LT.uid a) (Q.one, p, is_le) | None -> Util.MI.empty in { ple0 = p; is_le = is_le; dep = dep; expl = expl; age = !age_cpt } let find_coefficient x ineq = P.find x ineq.ple0 let split_pos_neg _ ({ple0 = p ; age = age},_) (mx, nb_max) = let mx = List.fold_left (fun m (c,x) -> let cmp = Q.sign c in (* equiv. to compare c Q.zero *) if cmp = 0 then m else let (pos, neg) = try MX.find x m with Not_found -> (0,0) in if cmp > 0 then MX.add x (pos+1, neg) m else MX.add x (pos, neg+1) m ) mx (fst (P.to_list p)) in mx, if Z.equal age !age_cpt then nb_max + 1 else nb_max module MINEQS = struct type mp = (t * Q.t) MP.t let empty = MP.empty let is_empty mp = MP.is_empty mp let younger ineq' ineq = (* requires more work in Explanation Explanation.younger ineq'.expl ineq.expl ||*) Z.compare ineq'.age ineq.age <= 0 let insert ineq mp = (* ineq.ple0 == is == p0 + ctt <(=) 0 i.e. p0 <(=) -ctt *) let p0, ctt = P.separate_constant ineq.ple0 in try let ineq', ctt' = MP.find p0 mp in (* ineq'.ple0 == is == p0 + ctt' <(=) 0 i.e. p0 <(=) -ctt' *) let cmp = Q.compare ctt' ctt in if cmp = 0 then if ineq.is_le == ineq'.is_le then (* equivalent *) (* if ineq in older, we should update the map to have the right (most recent) age *) if younger ineq ineq' then mp else MP.add p0 (ineq, ctt) mp else if ineq.is_le then mp (* ineq' more precise, because it has < *) else MP.add p0 (ineq, ctt) mp (*ineq has < -c and ineq' <= -c *) else if cmp > 0 then (* i.e. ctt' > ctt, i.e. p0 <(=) -ctt' < -ctt *) mp (* ineq' is more precise *) else (* cmp < 0 i.e. ctt' < ctt, i.e. - ctt' > - ctt >(=) p0 *) MP.add p0 (ineq, ctt) mp (* ineq is more precise *) with Not_found -> MP.add p0 (ineq, ctt) mp let ineqs_of mp = MP.fold (fun _ (ineq, _) acc -> ineq :: acc) mp [] let add_to_map mp l = List.fold_left (fun mp v -> insert v mp) mp l let iter = MP.iter let fold = MP.fold end module Debug = struct let list_of_ineqs fmt = List.iter (fprintf fmt "%a " print_inequation) let map_of_ineqs fmt = MINEQS.iter (fun _ (i , _) -> fprintf fmt "%a " print_inequation i) let cross x vars cpos cneg others = if Options.debug_fm () then begin fprintf Options.fmt "[fm] We cross on %a (%d vars remaining)@." X.print x (MX.cardinal vars); fprintf Options.fmt "with:@. cpos = %a@. cneg = %a@. others = %a@." list_of_ineqs cpos list_of_ineqs cneg map_of_ineqs others end let cross_result x ninqs = if Options.debug_fm () then fprintf Options.fmt "result of eliminating %a: at most %d new ineqs (not printed)@." X.print x ninqs end let mult_list c dep = if Q.equal c Q.one then dep else Util.MI.fold (fun a (coef,p,is_le) dep -> Util.MI.add a (Q.mult coef c, p, is_le) dep )dep Util.MI.empty let merge_deps d1 d2 = Util.MI.merge (fun k op1 op2 -> match op1, op2 with | None, None -> None | Some _, None -> op1 | None, Some _ -> op2 | Some(c1,p1, is_le1), Some(c2,p2, is_le2) -> assert (P.equal p1 p2 && is_le1 == is_le2); Some (Q.add c1 c2, p1, is_le1) )d1 d2 let cross x cpos cneg mp = let nb_inqs = ref 0 in let rec cross_rec acc l = Options.exec_thread_yield (); match l with | [] -> acc | { ple0=p1; is_le=k1; dep=d1; expl=ex1; age=a1 }::l -> let n1 = Q.abs (P.find x p1) in let acc = List.fold_left (fun acc {ple0=p2; is_le=k2; dep=d2; expl=ex2; age=a2} -> Options.exec_thread_yield (); let n2 = Q.abs (P.find x p2) in let n1, n2 = (* light normalization of n1 and n2 *) if Q.equal n1 n2 then Q.one, Q.one else n1, n2 in let p = P.add (P.mult_const n2 p1) (P.mult_const n1 p2) in let p, c, d = P.normal_form p in (* light norm of p *) let p = P.add_const c p in assert (Q.sign d > 0); let d1 = mult_list (Q.div n2 d) d1 in let d2 = mult_list (Q.div n1 d) d2 in let ni = { ple0 = p; is_le = k1&&k2; dep = merge_deps d1 d2; age = Z.max a1 a2; expl = Explanation.union ex1 ex2 } in incr nb_inqs; MINEQS.insert ni acc ) acc cpos in cross_rec acc l in cross_rec mp cneg, !nb_inqs let split x mp = let rec split_rec _ (ineq, _) (cp, cn, co, nb_pos, nb_neg) = try let a = find_coefficient x ineq in if Q.sign a > 0 then ineq::cp, cn, co, nb_pos+1, nb_neg else cp, ineq::cn, co, nb_pos, nb_neg+1 with Not_found -> cp, cn, MINEQS.insert ineq co, nb_pos, nb_neg in MINEQS.fold split_rec mp ([], [], MINEQS.empty, 0, 0) let choose_var mp = let pos_neg, nb_max = MINEQS.fold split_pos_neg mp (MX.empty, 0) in if nb_max = 0 then raise Not_found; let xopt = MX.fold (fun x (pos, neg) acc -> match acc with | None -> Some (x, pos * neg) | Some (y, c') -> let c = pos * neg in if c < c' then Some (x, c) else acc ) pos_neg None in match xopt with | Some (x, _) -> x, pos_neg | None -> raise Not_found let monome_ineq ineq = P.is_monomial ineq.ple0 != None let fourierMotzkin add_ineqs are_eq acc mp = let rec fourier acc mp = Options.exec_thread_yield (); if MINEQS.is_empty mp then acc else try let x, vars = choose_var mp in let cpos, cneg, others, nb_pos, nb_neg = split x mp in Debug.cross x vars cpos cneg others; let s_x = Some x in let acc = add_ineqs are_eq acc s_x cpos in let acc = add_ineqs are_eq acc s_x cneg in let size_res = Q.from_int (nb_pos * nb_neg) in let mp', nb_inqs = if Q.compare size_res (fm_cross_limit ()) >= 0 && Q.sign (fm_cross_limit()) >= 0 then let u_cpos = List.filter monome_ineq cpos in let u_cneg = List.filter monome_ineq cneg in let mp', nb_inq1 = match u_cpos with | [] -> others, 0 | [_] -> cross x cneg u_cpos others | _ -> assert false (* normalization invariant *) in let mp', nb_inq2 = match u_cneg with | [] -> mp', 0 | [_] -> cross x cpos u_cneg mp' | _ -> assert false (* normalization invariant *) in mp', nb_inq1 + nb_inq2 else cross x cpos cneg others in Debug.cross_result x nb_inqs; fourier acc mp' with Not_found -> add_ineqs are_eq acc None (MINEQS.ineqs_of mp) in fourier acc mp let fmSimplex add_ineqs are_eq acc mp = let msg = "Not implemented in the default version!"^ "Use the FmSimplex plugin instead" in failwith msg let available = fourierMotzkin end end module FM = Container.Make let current = ref (module Container : Container_SIG) let initialized = ref false let set_current mdl = current := mdl let load_current_inequalities_reasoner () = match Options.inequalities_plugin () with | "" -> if Options.debug_fm () then eprintf "[Dynlink] Using the 'FM module' for arithmetic inequalities@." | path -> if Options.debug_fm () then eprintf "[Dynlink] Loading the 'inequalities' reasoner in %s ...@." path; try MyDynlink.loadfile path; if Options.debug_fm () then eprintf "Success !@.@." with | MyDynlink.Error m1 -> if Options.debug_fm() then begin eprintf "[Dynlink] Loading the 'inequalities' reasoner in \"%s\" failed!@." path; Format.eprintf ">> Failure message: %s@.@." (MyDynlink.error_message m1); end; let prefixed_path = sprintf "%s/%s" Config.pluginsdir path in if Options.debug_fm () then eprintf "[Dynlink] Loading the 'inequalities' reasoner in %s with prefix %s@." path Config.pluginsdir; try MyDynlink.loadfile prefixed_path; if Options.debug_fm () then eprintf "Success !@.@." with | MyDynlink.Error m2 -> if not (Options.debug_fm()) then begin eprintf "[Dynlink] Loading the 'inequalities' reasoner in \"%s\" failed!@." path; Format.eprintf ">> Failure message: %s@.@." (MyDynlink.error_message m1); end; eprintf "[Dynlink] Trying to load the plugin from \"%s\" failed too!@." prefixed_path; Format.eprintf ">> Failure message: %s@.@." (MyDynlink.error_message m2); exit 1 let get_current () = if not !initialized then begin load_current_inequalities_reasoner (); initialized := true; end; !current alt-ergo-free-2.0.0/lib/reasoners/use.ml0000664000175000017500000001123213430774474015651 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Options open Format module T = Term module ST = T.Set module SA = Set.Make (struct type t = Literal.LT.t * Explanation.t let compare (s1,_) (s2,_) = Literal.LT.compare s1 s2 end) module type S = sig type t type r val empty : t val find : r -> t -> Term.Set.t * SA.t val add : r -> Term.Set.t * SA.t -> t -> t val mem : r -> t -> bool val print : t -> unit val up_add : t -> Term.t -> r -> r list -> t val congr_add : t -> r list -> Term.Set.t val up_close_up :t -> r -> r -> t val congr_close_up : t -> r -> r list -> Term.Set.t * SA.t end module Make (X : Sig.X) : S with type r = X.r = struct module MX = Map.Make(struct type t = X.r let compare = X.hash_cmp end) type t = (ST.t * SA.t) MX.t type r = X.r let inter_tpl (x1,y1) (x2,y2) = Options.exec_thread_yield (); ST.inter x1 x2, SA.inter y1 y2 let union_tpl (x1,y1) (x2,y2) = Options.exec_thread_yield (); ST.union x1 x2, SA.union y1 y2 let one, _ = X.make (Term.make (Symbols.name "@bottom") [] Ty.Tint) let leaves r = match X.leaves r with [] -> [one] | l -> l let find k m = try MX.find k m with Not_found -> (ST.empty,SA.empty) let add_term k t mp = let g_t,g_a = find k mp in MX.add k (ST.add t g_t,g_a) mp let up_add g t rt lvs = let g = if MX.mem rt g then g else MX.add rt (ST.empty, SA.empty) g in match (T.view t).T.xs with | [] -> g | _ -> List.fold_left (fun g x -> add_term x t g) g lvs let congr_add g lvs = match lvs with [] -> ST.empty | x::ls -> List.fold_left (fun acc y -> ST.inter (fst(find y g)) acc) (fst(find x g)) ls let up_close_up g p v = let lvs = leaves v in let g_p = find p g in List.fold_left (fun gg l -> MX.add l (union_tpl g_p (find l g)) gg) g lvs let congr_close_up g p touched = let inter = function [] -> (ST.empty, SA.empty) | rx::l -> List.fold_left (fun acc x ->inter_tpl acc (find x g))(find rx g) l in List.fold_left (fun (st,sa) tch -> union_tpl (st,sa)(inter (leaves tch))) (find p g) touched let print g = if debug_use () then begin let sterms fmt = ST.iter (fprintf fmt "%a " T.print) in let satoms fmt = SA.iter (fun (a,e) -> fprintf fmt "%a %a" Literal.LT.print a Explanation.print e) in fprintf fmt "@{[use]@} gamma :\n"; MX.iter (fun t (st,sa) -> fprintf fmt "%a is used by {%a} and {%a}\n" X.print t sterms st satoms sa ) g end let mem = MX.mem let add = MX.add let empty = MX.empty end alt-ergo-free-2.0.0/lib/reasoners/matching.ml0000664000175000017500000004201513430774474016652 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Format open Options open Sig open Matching_types module T = Term module F = Formula module MF = F.Map module Ex = Explanation module MT = T.Map module SubstT = Term.Subst module type S = sig type t type theory val empty : t val make: max_t_depth:int -> Matching_types.info Term.Map.t -> Term.t list Term.Map.t Term.Subst.t -> Matching_types.trigger_info list -> t val add_term : term_info -> Term.t -> t -> t val max_term_depth : t -> int -> t val add_triggers : backward:Util.inst_kind -> t -> (int * Explanation.t) Formula.Map.t -> t val terms_info : t -> info Term.Map.t * T.t list MT.t SubstT.t val query : t -> theory -> (trigger_info * gsubst list) list val unused_context : Formula.t -> bool end module type Arg = sig type t val term_repr : t -> Term.t -> Term.t val add_term : t -> Term.t -> t val are_equal : t -> Term.t -> Term.t -> add_terms:bool -> Sig.answer val class_of : t -> Term.t -> Term.t list end module Make (X : Arg) : S with type theory = X.t = struct type theory = X.t type t = { fils : T.t list MT.t SubstT.t ; info : info MT.t ; max_t_depth : int; pats : trigger_info list } exception Echec let empty = { fils = SubstT.empty ; info = MT.empty ; pats = [ ]; max_t_depth = 0; } let make ~max_t_depth info fils pats = { fils; info; pats; max_t_depth } let age_limite = Options.age_bound (* l'age limite des termes, au dela ils ne sont pas consideres par le matching *) (*BISECT-IGNORE-BEGIN*) module Debug = struct let add_term t = if debug_matching() >= 3 then fprintf fmt "[matching] add_term: %a@." T.print t let matching tr = if debug_matching() >= 3 then begin fprintf fmt "@.[matching] (multi-)trigger: %a@." T.print_list tr.F.content; fprintf fmt "========================================================@." end let match_pats_modulo pat lsubsts = if debug_matching() >= 3 then begin fprintf fmt "@.match_pat_modulo: %a with accumulated substs@." T.print pat; List.iter (fun {sbs=sbs; sty=sty} -> fprintf fmt ">>> sbs= %a | sty= %a@." (SubstT.print Term.print) sbs Ty.print_subst sty )lsubsts end let match_one_pat {sbs=sbs; sty=sty} pat0 = if debug_matching() >= 3 then fprintf fmt "@.match_pat: %a with subst: sbs= %a | sty= %a @." T.print pat0 (SubstT.print Term.print) sbs Ty.print_subst sty let match_one_pat_against {sbs=sbs; sty=sty} pat0 t = if debug_matching() >= 3 then fprintf fmt "@.match_pat: %a against term %a@.with subst: sbs= %a | sty= %a @." T.print pat0 T.print t (SubstT.print Term.print) sbs Ty.print_subst sty let match_term {sbs=sbs; sty=sty} t pat = if debug_matching() >= 3 then fprintf fmt "[match_term] I match %a against %a with subst: sbs=%a | sty= %a@." T.print pat T.print t (SubstT.print Term.print) sbs Ty.print_subst sty let match_list {sbs=sbs; sty=sty} pats xs = if debug_matching() >= 3 then fprintf fmt "@.[match_list] I match %a against %a with subst: sbs=%a | sty= %a@." T.print_list pats T.print_list xs (SubstT.print Term.print) sbs Ty.print_subst sty let match_class_of t cl = if debug_matching() >= 3 then fprintf fmt "class_of (%a) = { %a }@." T.print t (fun fmt -> List.iter (fprintf fmt "%a , " T.print)) cl let candidate_substitutions pat_info res = if debug_matching() >= 1 then begin fprintf fmt "[Matching.matching]@."; fprintf fmt "%3d candidate substitutions for Axiom %a with trigger %a@." (List.length res) F.print pat_info.trigger_orig T.print_list pat_info.trigger.F.content; if debug_matching() >= 2 then List.iter (fun gsbt -> fprintf fmt " >>> sbs = %a and sbty = %a@." (SubstT.print T.print) gsbt.sbs Ty.print_subst gsbt.sty )res end end (*BISECT-IGNORE-END*) let infos op_gen op_but t g b env = try let i = MT.find t env.info in op_gen i.age g , op_but i.but b with Not_found -> g , b let add_term info t env = Debug.add_term t; let rec add_rec env t = if MT.mem t env.info then env else let {T.f=f; xs=xs} = T.view t in let env = let map_f = try SubstT.find f env.fils with Not_found -> MT.empty in (* - l'age d'un terme est le min entre l'age passe en argument et l'age dans la map - un terme est en lien avec le but de la PO seulement s'il ne peut etre produit autrement (d'ou le &&) - le lemme de provenance est le dernier lemme *) let g, b = infos min (&&) t info.term_age info.term_from_goal env in let from_lems = List.fold_left (fun acc t -> try (MT.find t env.info).lem_orig @ acc with Not_found -> acc) (match info.term_from_formula with None -> [] | Some a -> [a]) info.term_from_terms in { env with fils = SubstT.add f (MT.add t xs map_f) env.fils; info = MT.add t { age=g; lem_orig = from_lems; but=b; t_orig = info.term_from_terms } env.info } in List.fold_left add_rec env xs in if info.term_age > age_limite () then env else add_rec env t let add_trigger p env = { env with pats = p :: env.pats } let all_terms f ty env tbox {sbs=s_t; sty=s_ty; gen=g; goal=b; s_term_orig=s_torig; s_lem_orig = s_lorig} lsbt_acc = SubstT.fold (fun k s l -> MT.fold (fun t _ l -> try let s_ty = Ty.matching s_ty ty (T.view t).T.ty in let ng , but = try let {age=ng;lem_orig=lem'; but=bt} = MT.find t env.info in max ng g , bt || b with Not_found -> g , b in (* with triggers that are variables, always normalize substs *) let t = X.term_repr (X.add_term tbox t) t in { sbs = SubstT.add f t s_t; sty = s_ty; gen = ng; goal = but; s_term_orig = t :: s_torig; s_lem_orig = s_lorig; }::l with Ty.TypeClash _ -> l ) s l ) env.fils lsbt_acc module T2 = struct type t = T.t * T.t let compare (a, b) (x, y) = let c = T.compare a x in if c <> 0 then c else T.compare b y end module MT2 = Map.Make(T2) let wrap_are_equal_generic tbox t s add_terms cache_are_eq_gen = try MT2.find (t, s) !cache_are_eq_gen with Not_found -> let res = X.are_equal tbox t s ~add_terms:add_terms in cache_are_eq_gen := MT2.add (t, s) res (MT2.add (s, t) res !cache_are_eq_gen); res (* These references are reset before and after each call to query. If some intermediate functions are exported in the future, the code should be adapted. *) let cache_are_equal_light = ref MT2.empty let cache_are_equal_full = ref MT2.empty let are_equal_light tbox t s = wrap_are_equal_generic tbox t s false cache_are_equal_light let are_equal_full tbox t s = wrap_are_equal_generic tbox t s true cache_are_equal_full let add_msymb tbox f t ({sbs=s_t} as sg) max_t_depth = if SubstT.mem f s_t then let s = SubstT.find f s_t in if are_equal_full tbox t s == Sig.No then raise Echec; sg else let t = if (T.view t).T.depth > max_t_depth || normalize_instances () then X.term_repr (X.add_term tbox t) t else t in {sg with sbs=SubstT.add f t s_t} let (-@) l1 l2 = match l1, l2 with | [], _ -> l2 | _ , [] -> l1 | _ -> List.fold_left (fun acc e -> e :: acc) l2 (List.rev l1) let xs_modulo_records t { Ty.lbs = lbs } = List.rev (List.rev_map (fun (hs, ty) -> T.make (Symbols.Op (Symbols.Access hs)) [t] ty) lbs) module SLT = (* sets of lists of terms *) Set.Make(struct type t = T.t list let compare l1 l2 = try List.iter2 (fun t1 t2 -> let c = T.compare t1 t2 in if c <> 0 then raise (Exception.Compared c) ) l1 l2; 0 with Invalid_argument _ -> List.length l1 - List.length l2 | Exception.Compared n -> n end) let filter_classes cl tbox = if no_Ematching () then cl else let mtl = List.fold_left (fun acc xs -> let xs = List.rev (List.rev_map (fun t -> X.term_repr tbox t) xs) in SLT.add xs acc ) SLT.empty cl in SLT.elements mtl let rec match_term env tbox ({sty=s_ty;gen=g;goal=b} as sg) pat t = Options.exec_thread_yield (); Debug.match_term sg t pat; let {T.f=f_pat;xs=pats;ty=ty_pat} = T.view pat in match f_pat with | Symbols.Var _ -> let sb = (try let s_ty = Ty.matching s_ty ty_pat (T.view t).T.ty in let g',b' = infos max (||) t g b env in add_msymb tbox f_pat t { sg with sty=s_ty; gen=g'; goal=b' } env.max_t_depth with Ty.TypeClash _ -> raise Echec) in [sb] | _ -> try let s_ty = Ty.matching s_ty ty_pat (T.view t).T.ty in let gsb = { sg with sty = s_ty } in if T.is_ground pat && are_equal_light tbox pat t != Sig.No then [gsb] else let cl = if no_Ematching () then [t] else X.class_of tbox t in Debug.match_class_of t cl; let cl = List.fold_left (fun l t -> let {T.f=f; xs=xs; ty=ty} = T.view t in if Symbols.compare f_pat f = 0 then xs::l else begin match f_pat, ty with | Symbols.Op (Symbols.Record), Ty.Trecord record -> (xs_modulo_records t record) :: l | _ -> l end )[] cl in let cl = filter_classes cl tbox in List.fold_left (fun acc xs -> try (match_list env tbox gsb pats xs) -@ acc with Echec -> acc ) [] cl with Ty.TypeClash _ -> raise Echec and match_list env tbox sg pats xs = Debug.match_list sg pats xs; try List.fold_left2 (fun sb_l pat arg -> List.fold_left (fun acc sg -> let aux = match_term env tbox sg pat arg in (*match aux with [] -> raise Echec | _ -> BUG !! *) List.rev_append aux acc ) [] sb_l ) [sg] pats xs with Invalid_argument _ -> raise Echec let match_one_pat env tbox pat0 lsbt_acc sg = Debug.match_one_pat sg pat0; let pat = T.apply_subst (sg.sbs, sg.sty) pat0 in let {T.f=f; xs=pats; ty=ty} = T.view pat in match f with | Symbols.Var _ -> all_terms f ty env tbox sg lsbt_acc | _ -> let {sty=sty; gen=g; goal=b} = sg in let f_aux t xs lsbt = Debug.match_one_pat_against sg pat0 t; try let s_ty = Ty.matching sty ty (T.view t).T.ty in let gen, but = infos max (||) t g b env in let sg = { sg with sty = s_ty; gen = gen; goal = but; s_term_orig = t::sg.s_term_orig } in let aux = match_list env tbox sg pats xs in List.rev_append aux lsbt with Echec | Ty.TypeClash _ -> lsbt in try MT.fold f_aux (SubstT.find f env.fils) lsbt_acc with Not_found -> lsbt_acc let match_pats_modulo env tbox lsubsts pat = Debug.match_pats_modulo pat lsubsts; List.fold_left (match_one_pat env tbox pat) [] lsubsts let matching env tbox pat_info = let pats = pat_info.trigger in let pats_list = List.stable_sort (fun s t -> (T.view t).T.depth - (T.view s).T.depth) pats.F.content in Debug.matching pats; let egs = { sbs = SubstT.empty; sty = Ty.esubst; gen = 0; goal = false; s_term_orig = []; s_lem_orig = pat_info.trigger_orig; } in let res = List.fold_left (match_pats_modulo env tbox) [egs] pats_list in Debug.candidate_substitutions pat_info res; pat_info, res let reset_cache_refs () = cache_are_equal_light := MT2.empty; cache_are_equal_full := MT2.empty let query env tbox = reset_cache_refs (); try let res = List.rev_map (matching env tbox) env.pats in reset_cache_refs (); res with e -> reset_cache_refs (); raise e let query env tbox = if Options.timers() then try Timers.exec_timer_start Timers.M_Match Timers.F_query; let res = query env tbox in Timers.exec_timer_pause Timers.M_Match Timers.F_query; res with e -> Timers.exec_timer_pause Timers.M_Match Timers.F_query; raise e else query env tbox let max_term_depth env mx = {env with max_t_depth = max env.max_t_depth mx} let add_triggers ~backward env formulas = MF.fold (fun lem (age, dep) env -> match F.view lem with | F.Lemma {F.triggers = tgs0; main = f; backward_triggers=tgs1; forward_triggers=tgs2} -> let tgs = match backward with | Util.Normal -> tgs0 | Util.Backward -> Lazy.force tgs1 | Util.Forward -> Lazy.force tgs2 in List.fold_left (fun env tr -> let info = { trigger = tr; trigger_age = age ; trigger_orig = lem ; trigger_formula = f ; trigger_dep = dep} in add_trigger info env ) env tgs | _ -> assert false ) formulas env let terms_info env = env.info, env.fils module SST = Set.Make(String) let init_with_replay_used acc f = if Sys.command (sprintf "[ -e %s ]" f) <> 0 then begin fprintf fmt "File %s not found! Option -replay-used will be ignored@." f; acc end else let cin = open_in f in let acc = ref (match acc with None -> SST.empty | Some ss -> ss) in begin try while true do acc := SST.add (input_line cin) !acc done; with End_of_file -> close_in cin end; Some !acc let used = if Options.replay_used_context () then init_with_replay_used None (Options.get_used_context_file ()) else if Options.replay_all_used_context () then let dir = Filename.dirname (Options.get_used_context_file ()) in Array.fold_left (fun acc f -> let f = sprintf "%s/%s" dir f in if (Filename.check_suffix f ".used") then begin init_with_replay_used acc f end else acc ) None (Sys.readdir dir) else None let parent s = if String.length s = 0 then s else match s.[0] with | '#' -> (match Str.split (Str.regexp "#") s with | [a;b] -> a | _ -> assert false) | _ -> s let unused_context f = match used, F.view f with | None , _ -> false | Some s_used, F.Lemma {F.name=s} -> not (String.length s = 0 || SST.mem (parent s) s_used) | _ -> assert false end alt-ergo-free-2.0.0/lib/reasoners/intervals.mli0000664000175000017500000001111113430774474017231 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) type t exception NotConsistent of Explanation.t exception No_finite_bound val undefined : Ty.t -> t val is_undefined : t -> bool val point : Numbers.Q.t -> Ty.t -> Explanation.t -> t val doesnt_contain_0 : t -> Sig.answer val is_positive : t -> Sig.answer val is_strict_smaller : t -> t -> bool val new_borne_sup : Explanation.t -> Numbers.Q.t -> is_le : bool -> t -> t val new_borne_inf : Explanation.t -> Numbers.Q.t -> is_le : bool -> t -> t val is_point : t -> (Numbers.Q.t * Explanation.t) option val intersect : t -> t -> t val exclude : t -> t -> t val mult : t -> t -> t val power : int -> t -> t val sqrt : t -> t val root : int -> t -> t val add : t -> t -> t val scale : Numbers.Q.t -> t -> t val sub : t -> t -> t val merge : t -> t -> t val abs : t -> t val pretty_print : Format.formatter -> t -> unit val print : Format.formatter -> t -> unit val finite_size : t -> Numbers.Q.t option val borne_inf : t -> Numbers.Q.t * Explanation.t * bool (** bool is true when bound is large. Raise: No_finite_bound if no finite lower bound *) val borne_sup : t -> Numbers.Q.t * Explanation.t * bool (** bool is true when bound is large. Raise: No_finite_bound if no finite upper bound*) val div : t -> t -> t val mk_closed : Numbers.Q.t -> Numbers.Q.t -> bool -> bool -> Explanation.t -> Explanation.t -> Ty.t -> t (** takes as argument in this order: - a lower bound - an upper bound - a bool that says if the lower bound it is large (true) or strict - a bool that says if the upper bound it is large (true) or strict - an explanation of the lower bound - an explanation of the upper bound - a type Ty.t (Tint or Treal *) type bnd = (Numbers.Q.t * Numbers.Q.t) option * Explanation.t (* - None <-> Infinity - the first number is the real bound - the second number if +1 (resp. -1) for strict lower (resp. upper) bound, and 0 for large bounds *) val bounds_of : t -> (bnd * bnd) list val contains : t -> Numbers.Q.t -> bool val add_explanation : t -> Explanation.t -> t val equal : t -> t -> bool type interval_matching = ((Numbers.Q.t * bool) option * (Numbers.Q.t * bool) option * Ty.t) Hstring.Map.t (** matchs the given lower and upper bounds against the given interval, and update the given accumulator with the constraints. Returns None if the matching problem is inconsistent *) val match_interval: Symbols.bound -> Symbols.bound -> t -> interval_matching -> interval_matching option alt-ergo-free-2.0.0/lib/reasoners/arith.mli0000664000175000017500000000476513430774474016352 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) module Type (X : Sig.X ): Polynome.T with type r = X.r module Shostak (X : Sig.X) (P : Polynome.EXTENDED_Polynome with type r = X.r) : Sig.SHOSTAK with type r = X.r and type t = P.t module Relation (X : Sig.X) (Uf : Uf.S with type r = X.r) (P : Polynome.EXTENDED_Polynome with type r = X.r) : Sig.RELATION with type r = X.r and type uf = Uf.t alt-ergo-free-2.0.0/lib/reasoners/sig.mli0000664000175000017500000001533413430774474016017 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) type answer = Yes of Explanation.t * Term.Set.t list | No type 'a ac = {h: Symbols.t ; t: Ty.t ; l: ('a * int) list; distribute: bool} type 'a literal = LTerm of Literal.LT.t | LSem of 'a Literal.view type instances = (Formula.t list * Formula.gformula * Explanation.t) list type theory = | Th_arith | Th_sum | Th_arrays | Th_UF type lit_origin = | Subst | CS of theory * Numbers.Q.t | NCS of theory * Numbers.Q.t | Other type 'a input = 'a Literal.view * Literal.LT.t option * Explanation.t * lit_origin type 'a fact = 'a literal * Explanation.t * lit_origin type 'a facts = { equas : 'a fact Queue.t; diseqs : 'a fact Queue.t; ineqs : 'a fact Queue.t; mutable touched : 'a Util.MI.t; } type 'a result = { assume : 'a fact list; remove: Literal.LT.t list; } type 'a solve_pb = { sbt : ('a * 'a) list; eqs : ('a * 'a) list } module type RELATION = sig type t type r type uf val empty : Term.Set.t list -> t val assume : t -> uf -> (r input) list -> t * r result val query : t -> uf -> r input -> answer val case_split : t -> uf -> for_model:bool -> (r Literal.view * bool * lit_origin) list (** case_split env returns a list of equalities *) val add : t -> uf -> r -> Term.t -> t (** add a representant to take into account *) val instantiate : do_syntactic_matching:bool -> Matching_types.info Term.Map.t * Term.t list Term.Map.t Term.Subst.t -> t -> uf -> (Formula.t -> Formula.t -> bool) -> t * instances val print_model : Format.formatter -> t -> (Term.t * r) list -> unit val new_terms : t -> Term.Set.t val assume_th_elt : t -> Commands.th_elt -> t val retrieve_used_context : t -> Explanation.t -> Formula.t list * Formula.t list end module type SHOSTAK = sig (**Type of terms of the theory*) type t (**Type of representants of terms of the theory*) type r (** Name of the theory*) val name : string (** return true if the symbol is owned by the theory*) val is_mine_symb : Symbols.t -> bool (** Give a representant of a term of the theory*) val make : Term.t -> r * Literal.LT.t list val term_extract : r -> Term.t option * bool (* original term ? *) val color : (r ac) -> r val type_info : t -> Ty.t val embed : r -> t val is_mine : t -> r (** Give the leaves of a term of the theory *) val leaves : t -> r list val subst : r -> r -> t -> r val compare : r -> r -> int (* tests if two values are equal (using tags) *) val equal : t -> t -> bool val hash : t -> int (** solve r1 r2, solve the equality r1=r2 and return the substitution *) val solve : r -> r -> r solve_pb -> r solve_pb val print : Format.formatter -> t -> unit val fully_interpreted : Symbols.t -> bool val abstract_selectors : t -> (r * r) list -> r * (r * r) list (* the returned bool is true when the returned term in a constant of the theory. Otherwise, the term contains aliens that should be assigned (eg. records). In this case, it's a unit fact, not a decision *) val assign_value : r -> r list -> (Term.t * r) list -> (Term.t * bool) option (* choose the value to print and how to print it for the given term. The second term is its representative. The list is its equivalence class *) val choose_adequate_model : Term.t -> r -> (Term.t * r) list -> r * string end module type X = sig type r val make : Term.t -> r * Literal.LT.t list val type_info : r -> Ty.t val str_cmp : r -> r -> int val hash_cmp : r -> r -> int val equal : r -> r -> bool val hash : r -> int val leaves : r -> r list val subst : r -> r -> r -> r val solve : r -> r -> (r * r) list val term_embed : Term.t -> r val term_extract : r -> Term.t option * bool (* original term ? *) val ac_embed : r ac -> r val ac_extract : r -> (r ac) option val color : (r ac) -> r val fully_interpreted : Symbols.t -> bool val is_a_leaf : r -> bool val print : Format.formatter -> r -> unit val abstract_selectors : r -> (r * r) list -> r * (r * r) list val top : unit -> r val bot : unit -> r val is_solvable_theory_symbol : Symbols.t -> bool (* the returned bool is true when the returned term in a constant of the theory. Otherwise, the term contains aliens that should be assigned (eg. records). In this case, it's a unit fact, not a decision *) val assign_value : r -> r list -> (Term.t * r) list -> (Term.t * bool) option (* choose the value to print and how to print it for the given term. The second term is its representative. The list is its equivalence class *) val choose_adequate_model : Term.t -> r -> (Term.t * r) list -> r * string end alt-ergo-free-2.0.0/lib/reasoners/sat_solver.mli0000664000175000017500000000231113430774474017405 0ustar mimi(******************************************************************************) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the license indicated *) (* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) (* present, please contact us to clarify licensing. *) (* *) (******************************************************************************) val get_current : unit -> (module Sat_solver_sig.S) (** returns the current activated SAT-solver. The default value is Fun_sat. When the selected SAT-solver is an external plugin, the first call of this function will attemp to dynamically load it **) val set_current : (module Sat_solver_sig.S) -> unit (** sets a new SAT-solver. This function is intended to be used by dynamically loaded plugins **) alt-ergo-free-2.0.0/lib/reasoners/bitv.mli0000664000175000017500000000471213430774474016177 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) type 'a abstract module type ALIEN = sig include Sig.X val embed : r abstract -> r val extract : r -> (r abstract) option end module Shostak (X : ALIEN) : Sig.SHOSTAK with type r = X.r and type t = X.r abstract module Relation (X : ALIEN) (Uf : Uf.S) : Sig.RELATION with type r = X.r and type uf = Uf.t alt-ergo-free-2.0.0/lib/reasoners/fun_sat.mli0000664000175000017500000000424513430774474016673 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) include Sat_solver_sig.S alt-ergo-free-2.0.0/lib/reasoners/arrays.mli0000664000175000017500000000471213430774474016534 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) type 'a abstract module type ALIEN = sig include Sig.X val embed : r abstract -> r val extract : r -> (r abstract) option end module Shostak (X : ALIEN) : Sig.SHOSTAK with type r = X.r and type t = X.r abstract module Relation (X : ALIEN) (Uf : Uf.S) : Sig.RELATION with type r = X.r and type uf = Uf.t alt-ergo-free-2.0.0/lib/reasoners/instances.ml0000664000175000017500000003425613430774474017057 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Format open Options open Sig module T = Term module F = Formula module MF = F.Map module SF = F.Set module Ex = Explanation module MT = T.Map module type S = sig type t type tbox type instances = (F.gformula * Ex.t) list val empty : t val add_terms : t -> T.Set.t -> F.gformula -> t val add_lemma : t -> F.gformula -> Ex.t -> t * instances val add_predicate : t -> F.gformula -> t val m_lemmas : backward:Util.inst_kind -> t -> tbox -> (F.t -> F.t -> bool) -> int -> instances * instances (* goal_directed, others *) val m_predicates : backward:Util.inst_kind -> t -> tbox -> (F.t -> F.t -> bool) -> int -> instances * instances (* goal_directed, others *) (* returns used axioms/predicates * unused axioms/predicates *) val retrieve_used_context : t -> Ex.t -> Formula.t list * Formula.t list val register_max_term_depth : t -> int -> t val matching_terms_info : t -> Matching_types.info Term.Map.t * Term.t list Term.Map.t Term.Subst.t end module Make(X : Theory.S) : S with type tbox = X.t = struct module EM = Matching.Make( struct include X let add_term env t = X.add_term env t ~add_in_cs:false end) type tbox = X.t type instances = (F.gformula * Ex.t) list type t = { lemmas : (int * Ex.t) MF.t; predicates : (int * Ex.t) MF.t; matching : EM.t; } let empty = { lemmas = MF.empty ; matching = EM.empty; predicates = MF.empty; } module Debug = struct let new_facts_of_axiom ax insts_ok = if debug_matching () >= 1 && insts_ok != MF.empty then let name = match F.view ax with F.Lemma {F.name=s} -> s | _ -> "!(no-name)" in fprintf fmt "[Instances.split_and_filter_insts] "; fprintf fmt "%3d different new instances generated for %s@." (MF.cardinal insts_ok) name let new_mround ilvl kind = if debug_matching () >= 1 then fprintf fmt "@.# [matching] new %s matching round: ilevel = %d...@." kind ilvl end let add_terms env s gf = let infos = { Matching_types.term_age = gf.F.age ; term_from_goal = gf.F.gf ; term_from_formula = gf.F.lem ; term_from_terms = gf.F.from_terms } in { env with matching = T.Set.fold (EM.add_term infos) s env.matching } let add_predicate env gf = let {F.f=f;age=age} = gf in if EM.unused_context f then env else { env with predicates = MF.add f (age,Ex.empty) env.predicates; (* this is not done in SAT*) matching = EM.max_term_depth env.matching (F.max_term_depth f) } let register_max_term_depth env mx = {env with matching = EM.max_term_depth env.matching mx} let record_this_instance f accepted lorig = match F.view lorig with | F.Lemma {F.name;loc} -> Profiling.new_instance_of name f loc accepted | _ -> assert false let profile_produced_terms env lorig nf s trs = let st0 = List.fold_left (fun st t -> T.subterms st (T.apply_subst s t)) T.Set.empty trs in let name, loc, f = match F.view lorig with | F.Lemma {F.name;main;loc} -> name, loc, main | _ -> assert false in let st1 = F.ground_terms_rec nf in let diff = Term.Set.diff st1 st0 in let info, _ = EM.terms_info env.matching in let _new = Term.Set.filter (fun t -> not (MT.mem t info)) diff in Profiling.register_produced_terms name loc st0 st1 diff _new let inst_is_seen_during_this_round orig f insts = try let mp_orig_ok, mp_orig_ko = MF.find orig insts in MF.mem f mp_orig_ok || SF.mem f mp_orig_ko with Not_found -> false let add_accepted_to_acc orig f item insts = let mp_orig_ok, mp_orig_ko = try MF.find orig insts with Not_found -> MF.empty, SF.empty in assert (not (MF.mem f mp_orig_ok)); assert (not (SF.mem f mp_orig_ko)); MF.add orig (MF.add f item mp_orig_ok, mp_orig_ko) insts let add_rejected_to_acc orig f insts = let mp_orig_ok, mp_orig_ko = try MF.find orig insts with Not_found -> MF.empty, SF.empty in assert (not (MF.mem f mp_orig_ok)); assert (not (SF.mem f mp_orig_ko)); MF.add orig (mp_orig_ok, SF.add f mp_orig_ko) insts let new_facts env tbox selector substs = List.fold_left (fun acc ({Matching_types.trigger_formula=f; trigger_age=age; trigger_dep=dep; trigger_orig=orig; trigger = tr}, subst_list) -> let cpt = ref 0 in let kept = ref 0 in List.fold_left (fun acc {Matching_types.sbs = sbs; sty = sty; gen = g; goal = b; s_term_orig = torig; s_lem_orig = lorig} -> incr cpt; let s = sbs, sty in match tr.F.guard with | Some a when X.query (Literal.LT.apply_subst s a) tbox==No -> acc | _ -> let nf = F.apply_subst s f in if inst_is_seen_during_this_round orig nf acc then acc else let accepted = selector nf orig in if not accepted then add_rejected_to_acc orig nf acc else let p = { F.f = nf; origin_name = F.name_of_lemma lorig; gdist = -1; hdist = -1; trigger_depth = tr.F.depth; nb_reductions = 0; age = 1+(max g age); mf = true; gf = b; lem = Some lorig; from_terms = torig; theory_elim = true } in let dep = if not (Options.proof() || Options.profiling()) then dep else (* Dep lorig used to track conflicted instances in profiling mode *) Ex.union dep (Ex.singleton (Ex.Dep lorig)) in incr kept; add_accepted_to_acc orig nf (p, dep, s, tr.F.content) acc ) acc subst_list ) MF.empty substs let split_and_filter_insts env insts = MF.fold (fun orig (mp_orig_ok, mp_orig_ko) acc -> Debug.new_facts_of_axiom orig mp_orig_ok; let acc = MF.fold (fun f (p, dep, _, _) (gd, ngd) -> if p.F.gf then (p, dep) :: gd, ngd else gd, (p, dep) :: ngd )mp_orig_ok acc in if Options.profiling() then begin (* update profiler data *) SF.iter (fun f -> record_this_instance f false orig) mp_orig_ko; MF.iter (fun f (_, _, name, tr_ctt) -> profile_produced_terms env orig f name tr_ctt; record_this_instance f true orig ) mp_orig_ok; end; acc )insts ([], []) let sort_facts = let rec size f = match F.view f with | F.Unit(f1,f2) -> max (size f1) (size f2) | _ -> F.size f in fun lf -> List.fast_sort (fun (p1,_) (p2,_) -> let c = size p1.F.f - size p2.F.f in if c <> 0 then c else F.compare p2.F.f p1.F.f ) lf let new_facts env tbox selector substs = if Options.timers() then try Timers.exec_timer_start Timers.M_Match Timers.F_new_facts; let res = new_facts env tbox selector substs in Timers.exec_timer_pause Timers.M_Match Timers.F_new_facts; res with e -> Timers.exec_timer_pause Timers.M_Match Timers.F_new_facts; raise e else new_facts env tbox selector substs let mround env axs tbox selector ilvl kind backward = Debug.new_mround ilvl kind; Options.tool_req 2 "TR-Sat-Mround"; let env = {env with matching = EM.add_triggers ~backward env.matching axs} in let substs = EM.query env.matching tbox in let insts = new_facts env tbox selector substs in let gd, ngd = split_and_filter_insts env insts in sort_facts gd, sort_facts ngd let m_lemmas env tbox selector ilvl backward = mround env env.lemmas tbox selector ilvl "axioms" backward let m_predicates env tbox selector ilvl backward = mround env env.predicates tbox selector ilvl "predicates" backward module MI = Map.Make (struct type t = int let compare = compare end) let retrieve_used_context env dep = let deps = Ex.formulas_of dep in let used, unlems, unpreds = SF.fold (fun f ((used, lems, preds) as acc) -> if MF.mem f lems then f :: used, MF.remove f lems, preds else if MF.mem f preds then f :: used, lems, MF.remove f preds else match F.view f with | F.Lemma _ -> (* An axiom that does not appear in lems because of inconsist. *) f :: used, lems, preds | _ -> acc ) deps ([], env.lemmas, env.predicates) in let unused = MF.fold (fun f _ acc -> f::acc) unlems [] in let unused = MF.fold (fun f _ acc -> f::acc) unpreds unused in used, unused let add_lemma env gf dep = let {F.f=orig;age=age;gf=b} = gf in if (*not (Ex.is_empty dep) ||*) EM.unused_context orig then env, [] else let age, dep = try let age' , dep' = MF.find orig env.lemmas in min age age' , Ex.union dep dep' with Not_found -> age, dep in let env = { env with lemmas = MF.add orig (age,dep) env.lemmas } in match F.view orig with | F.Lemma {F.simple_inst = Some sbs; main; name} -> let nf = F.apply_subst sbs main in let p = { F.f = nf; origin_name = name; gdist = -1; hdist = -1; trigger_depth = max_int; nb_reductions = 0; age = age+1; mf = true; gf = b; lem = Some orig; from_terms = []; theory_elim = true; } in let dep = if not (Options.proof() || Options.profiling()) then dep else (* Dep lorig used to track conflicted instances in profiling mode *) Ex.union dep (Ex.singleton (Ex.Dep orig)) in let insts = add_accepted_to_acc orig nf (p, dep, sbs, []) MF.empty in let gd, ngd = split_and_filter_insts env insts in env, List.rev_append gd ngd | _ -> env, [] (*** add wrappers to profile exported functions ***) let add_terms env s gf = if Options.timers() then try Timers.exec_timer_start Timers.M_Match Timers.F_add_terms; let res = add_terms env s gf in Timers.exec_timer_pause Timers.M_Match Timers.F_add_terms; res with e -> Timers.exec_timer_pause Timers.M_Match Timers.F_add_terms; raise e else add_terms env s gf let add_lemma env gf dep = if Options.timers() then try Timers.exec_timer_start Timers.M_Match Timers.F_add_lemma; let res = add_lemma env gf dep in Timers.exec_timer_pause Timers.M_Match Timers.F_add_lemma; res with e -> Timers.exec_timer_pause Timers.M_Match Timers.F_add_lemma; raise e else add_lemma env gf dep let add_predicate env gf = if Options.timers() then try Timers.exec_timer_start Timers.M_Match Timers.F_add_predicate; let res = add_predicate env gf in Timers.exec_timer_pause Timers.M_Match Timers.F_add_predicate; res with e -> Timers.exec_timer_pause Timers.M_Match Timers.F_add_predicate; raise e else add_predicate env gf let m_lemmas ~backward env tbox selector ilvl = if Options.timers() then try Timers.exec_timer_start Timers.M_Match Timers.F_m_lemmas; let res = m_lemmas env tbox selector ilvl backward in Timers.exec_timer_pause Timers.M_Match Timers.F_m_lemmas; res with e -> Timers.exec_timer_pause Timers.M_Match Timers.F_m_lemmas; raise e else m_lemmas env tbox selector ilvl backward let m_predicates ~backward env tbox selector ilvl = if Options.timers() then try Timers.exec_timer_start Timers.M_Match Timers.F_m_predicates; let res = m_predicates env tbox selector ilvl backward in Timers.exec_timer_pause Timers.M_Match Timers.F_m_predicates; res with e -> Timers.exec_timer_pause Timers.M_Match Timers.F_m_predicates; raise e else m_predicates env tbox selector ilvl backward let matching_terms_info env = EM.terms_info env.matching end alt-ergo-free-2.0.0/lib/reasoners/ccx.ml0000664000175000017500000005241713430774474015644 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Format open Options open Sig open Exception module X = Combine.Shostak module Ex = Explanation module SetF = Formula.Set module T = Term module A = Literal module LR = A.Make(struct type t = X.r let compare = X.str_cmp include X end) module SetT = Term.Set module Sy = Symbols module type S = sig type t type r = Combine.Shostak.r val empty : unit -> t val empty_facts : unit -> r Sig.facts val add_fact : r Sig.facts -> r fact -> unit val add_term : t -> r Sig.facts -> (* acc *) Term.t -> Explanation.t -> t * r Sig.facts val add : t -> r Sig.facts -> (* acc *) Literal.LT.t -> Explanation.t -> t * r Sig.facts val assume_literals : t -> (r Sig.literal * Explanation.t * Sig.lit_origin) list -> r Sig.facts -> t * (r Sig.literal * Explanation.t * Sig.lit_origin) list val case_split : t -> for_model:bool -> (r Literal.view * bool * Sig.lit_origin) list * t val query : t -> Literal.LT.t -> Sig.answer val new_terms : t -> Term.Set.t val class_of : t -> Term.t -> Term.t list val are_equal : t -> Term.t -> Term.t -> added_terms:bool -> Sig.answer val are_distinct : t -> Term.t -> Term.t -> Sig.answer val cl_extract : t -> Term.Set.t list val term_repr : t -> Term.t -> Term.t val print_model : Format.formatter -> t -> unit val get_union_find : t -> Combine.Uf.t val assume_th_elt : t -> Commands.th_elt -> t val theories_instances : do_syntactic_matching:bool -> Matching_types.info Term.Map.t * Term.t list Term.Map.t Term.Subst.t -> t -> (Formula.t -> Formula.t -> bool) -> t * Sig.instances val retrieve_used_context : t -> Explanation.t -> Formula.t list * Formula.t list end module Main : S = struct module SetA = Use.SA module Use = Combine.Use module Uf = Combine.Uf module Rel = Combine.Relation module Q = Queue module MX = Map.Make(struct type t = X.r let compare = X.hash_cmp end) type t = { use : Use.t; uf : Uf.t ; relation : Rel.t } type r = Combine.Shostak.r let empty () = { use = Use.empty ; uf = Uf.empty () ; relation = Rel.empty []; } let empty_facts () = { equas = Queue.create (); ineqs = Queue.create (); diseqs = Queue.create (); touched = Util.MI.empty } let add_fact facts ((lit, ex, orig) as e) = match lit with | LSem Literal.Pred _ | LSem Literal.Eq _ -> Queue.push e facts.equas | LSem Literal.Distinct _ -> Queue.push e facts.diseqs | LSem Literal.Builtin _ -> Queue.push e facts.ineqs | LTerm a -> match Literal.LT.view a with | Literal.Pred _ | Literal.Eq _ -> Queue.push e facts.equas | Literal.Distinct _ -> Queue.push e facts.diseqs | Literal.Builtin _ -> Queue.push e facts.ineqs (*BISECT-IGNORE-BEGIN*) module Debug = struct let facts (f : r Sig.facts) msg = let aux fmt q = Q.iter (fun (lit,_,_) -> match lit with | LSem sa -> fprintf fmt " > LSem %a@." LR.print (LR.make sa) | LTerm a -> fprintf fmt " > LTerm %a@."Literal.LT.print a )q in let aux2 fmt mp = Util.MI.iter (fun _ x -> fprintf fmt "%a |-> ... (See Uf)@." X.print x) mp in if debug_cc () then begin fprintf fmt "I am in %s with the following facts@." msg; fprintf fmt "---- Begin Facts -----------------------------------@."; fprintf fmt "Equalities:@.%a" aux f.equas; fprintf fmt "Disequalities:@.%a" aux f.diseqs; fprintf fmt "Inequalities:@.%a" aux f.ineqs; fprintf fmt "Touched:@.%a" aux2 f.touched; fprintf fmt "---- End Facts -----------------------------------@.@."; end let cc r1 r2 = if debug_cc () then fprintf fmt "[cc] congruence closure : %a = %a@." X.print r1 X.print r2 let make_cst t ctx = if debug_cc () then if ctx != [] then begin fprintf fmt "[cc] constraints of make(%a)@." Term.print t; let c = ref 0 in List.iter (fun a -> incr c; fprintf fmt " %d) %a@." !c A.LT.print a) ctx end let add_to_use t = if debug_cc () then fprintf fmt "[cc] add_to_use: %a@." T.print t let lrepr fmt = List.iter (fprintf fmt "%a " X.print) let leaves t lvs = fprintf fmt "[cc] leaves of %a@.@." T.print t; lrepr fmt lvs let contra_congruence a ex = if debug_cc () then fprintf fmt "[cc] find that %a %a by contra-congruence@." A.LT.print a Ex.print ex let assume_literal sa = if debug_cc () then fprintf fmt "[cc] assume literal : %a@." LR.print (LR.make sa) let congruent a ex = if debug_cc () then fprintf fmt "[cc] new fact by conrgruence : %a ex[%a]@." A.LT.print a Ex.print ex let cc_result p v touched = if debug_cc() then begin fprintf fmt "[cc] the binding %a -> %a touched:@." X.print p X.print v; List.iter (fun (x, y, _) -> fprintf fmt " > %a ~~ becomes ~> %a@." X.print x X.print y) touched end end (*BISECT-IGNORE-END*) let one, _ = X.make (Term.make (Sy.name "@bottom") [] Ty.Tint) let concat_leaves uf l = let rec concat_rec acc t = match X.leaves (fst (Uf.find uf t)) , acc with [] , _ -> one::acc | res, [] -> res | res , _ -> List.rev_append res acc in match List.fold_left concat_rec [] l with [] -> [one] | res -> res let are_equal env ex t1 t2 = if T.equal t1 t2 then ex else match Uf.are_equal env.uf t1 t2 ~added_terms:true with | Yes (dep, _) -> Ex.union ex dep | No -> raise Exit let equal_only_by_congruence env facts t1 t2 = if not (T.equal t1 t2) then let {T.f=f1; xs=xs1; ty=ty1} = T.view t1 in let {T.f=f2; xs=xs2; ty=ty2} = T.view t2 in if Symbols.equal f1 f2 && Ty.equal ty1 ty2 then try let ex = List.fold_left2 (are_equal env) Ex.empty xs1 xs2 in let a = A.LT.mk_eq t1 t2 in Debug.congruent a ex; Q.push (LTerm a, ex, Sig.Other) facts.equas with Exit -> () let congruents env facts t1 s = match T.view t1 with | {T.xs=[]} -> () | {T.f} when X.fully_interpreted f -> () | _ -> SetT.iter (equal_only_by_congruence env facts t1) s let fold_find_with_explanation find ex l = List.fold_left (fun (lr, ex) t -> let r, ex_r = find t in r::lr, Ex.union ex_r ex) ([], ex) l let view find va ex_a = match va with | A.Pred (t1, b) -> let r1, ex1 = find t1 in let ex = Ex.union ex1 ex_a in LR.mkv_pred r1 b, ex | A.Eq (t1, t2) -> let r1, ex1 = find t1 in let r2, ex2 = find t2 in let ex = Ex.union (Ex.union ex1 ex2) ex_a in LR.mkv_eq r1 r2, ex | A.Distinct (b, lt) -> let lr, ex = fold_find_with_explanation find ex_a lt in LR.mkv_distinct b (List.rev lr), ex | A.Builtin(b, s, l) -> let lr, ex = fold_find_with_explanation find ex_a l in LR.mkv_builtin b s (List.rev lr), ex let term_canonical_view env a ex_a = view (Uf.find env.uf) (A.LT.view a) ex_a let canonical_view env a ex_a = view (Uf.find_r env.uf) a ex_a (* Begin: new implementation of add, add_term, assume_literals and all that *) let new_facts_by_contra_congruence env facts r bol = match X.term_extract r with | None, _ -> () | Some _, false -> () (* not an original term *) | Some t1, true -> (* original term *) match T.view t1 with | {T.f=f1 ; xs=[x]} -> let ty_x = (Term.view x).Term.ty in List.iter (fun t2 -> match T.view t2 with | {T.f=f2 ; xs=[y]} when Sy.equal f1 f2 -> let ty_y = (Term.view y).Term.ty in if Ty.equal ty_x ty_y then begin match Uf.are_distinct env.uf t1 t2 with | Yes (ex_r, _) -> let a = A.LT.mk_distinct false [x; y] in Debug.contra_congruence a ex_r; Q.push (LTerm a, ex_r, Sig.Other) facts.diseqs | No -> assert false end | _ -> () ) (Uf.class_of env.uf bol) | _ -> () let clean_use = List.fold_left (fun env a -> match A.LT.view a with | A.Distinct (_, lt) | A.Builtin (_, _, lt) -> let lvs = concat_leaves env.uf lt in List.fold_left (fun env rx -> let st, sa = Use.find rx env.use in (* SetA does not use ex, so Ex.empty is OK for removing *) let sa = SetA.remove (a, Ex.empty) sa in { env with use = Use.add rx (st,sa) env.use } ) env lvs | _ -> assert false ) let contra_congruence env facts r = Options.exec_thread_yield (); if X.equal (fst (Uf.find_r env.uf r)) (X.top()) then new_facts_by_contra_congruence env facts r T.faux else if X.equal (fst (Uf.find_r env.uf r)) (X.bot()) then new_facts_by_contra_congruence env facts r T.vrai let congruence_closure env (facts:r Sig.facts) r1 r2 ex = Options.exec_thread_yield (); Debug.cc r1 r2; let uf, res = Uf.union env.uf r1 r2 ex in List.fold_left (fun env (p, touched, v) -> Options.exec_thread_yield (); Debug.cc_result p v touched; assert (X.is_a_leaf p); (* we look for use(p) *) let p_t, p_a = Use.find p env.use in (* we compute terms and atoms to consider for congruence *) let repr_touched = List.map (fun (x, y, ex) -> facts.touched <- Util.MI.add (X.hash x) x facts.touched; y ) touched in let st_others, sa_others = Use.congr_close_up env.use p repr_touched in (* we update use *) let nuse = Use.up_close_up env.use p v in let nuse = List.fold_left (fun nuse (r, rr, ex) -> match X.leaves rr with | _ :: _ -> nuse | [] -> Use.up_close_up nuse p one )nuse touched in Use.print nuse; (* we check the congruence of the terms. *) let env = {env with use=nuse} in SetT.iter (fun t -> congruents env facts t st_others) p_t; (*CC of preds ?*) SetA.iter (fun (a, ex) -> add_fact facts (LTerm a, ex, Sig.Other)) p_a; (*touched preds ?*) SetA.iter (fun (a, ex) -> add_fact facts (LTerm a, ex, Sig.Other)) sa_others; env ) {env with uf=uf} res module LRT = Map.Make (struct type t = LR.t * Literal.LT.t option let compare (x, y) (x', y') = let c = LR.compare x x' in if c <> 0 then c else match y, y' with | None, None -> 0 | Some _, None -> 1 | None, Some _ -> -1 | Some a, Some a' -> Literal.LT.compare a a' end) let make_unique sa = let mp = List.fold_left (fun mp ((ra, aopt ,_ ,_) as e) -> LRT.add (LR.make ra, aopt) e mp ) LRT.empty sa in LRT.fold (fun _ e acc -> e::acc)mp [] let replay_atom env sa = Options.exec_thread_yield (); let sa = make_unique sa in let relation, result = Rel.assume env.relation env.uf sa in let env = { env with relation = relation } in let env = clean_use env result.remove in env, result.assume let rec add_term env facts t ex = Options.exec_thread_yield (); (* nothing to do if the term already exists *) if Uf.mem env.uf t then env else begin Options.tool_req 3 "TR-CCX-AddTerm"; Debug.add_to_use t; (* we add t's arguments in env *) let {T.f = f; xs = xs} = T.view t in let env = List.fold_left (fun env t -> add_term env facts t ex) env xs in (* we update uf and use *) let nuf, ctx = Uf.add env.uf t in Debug.make_cst t ctx; List.iter (fun a -> add_fact facts (LTerm a, ex, Sig.Other)) ctx; (*or Ex.empty ?*) let rt, _ = Uf.find nuf t in let lvs = concat_leaves nuf xs in let nuse = Use.up_add env.use t rt lvs in (* If finitetest is used we add the term to the relation *) let rel = Rel.add env.relation nuf rt t in Use.print nuse; (* we compute terms to consider for congruence *) (* we do this only for non-atomic terms with uninterpreted head-symbol *) let st_uset = Use.congr_add nuse lvs in (* we check the congruence of each term *) let env = {uf = nuf; use = nuse; relation = rel} in congruents env facts t st_uset; env end let add env facts a ex = match A.LT.view a with | A.Pred (t1, _) -> add_term env facts t1 ex | A.Eq (t1, t2) -> let env = add_term env facts t1 ex in add_term env facts t2 ex | A.Distinct (_, lt) | A.Builtin (_, _, lt) -> let env = List.fold_left (fun env t-> add_term env facts t ex) env lt in let lvs = concat_leaves env.uf lt in (* A verifier *) List.fold_left (* add Distinct and Builtin to Use *) (fun env rx -> let st, sa = Use.find rx env.use in { env with use = Use.add rx (st,SetA.add (a, ex) sa) env.use } ) env lvs let semantic_view env (a, ex, orig) facts = match a with | LTerm a -> (* Over terms: add terms + term_canonical_view *) let env = add env facts a ex in let sa, ex = term_canonical_view env a ex in env, (sa, Some a, ex, orig) | LSem sa -> match sa with | A.Builtin _ -> (* we put it in canonical form for FM *) let sa, ex = canonical_view env sa ex in env, (sa, None, ex, orig) | _ -> (* XXX if we do canonical_view for A.Distinct, the theory of arrays will get lost *) env, (sa, None, ex, orig) let assume_eq env facts r1 r2 ex = Options.tool_req 3 "TR-CCX-Congruence"; let env = congruence_closure env facts r1 r2 ex in if Options.nocontracongru () || X.type_info r1 != Ty.Tbool then env else begin contra_congruence env facts r1; contra_congruence env facts r2; env end let assume_dist env facts lr ex = Options.tool_req 3 "TR-CCX-Distinct"; if Uf.already_distinct env.uf lr then env else {env with uf = Uf.distinct env.uf lr ex} let rec assume_equalities env choices facts = if Q.is_empty facts.equas then env, choices else begin Debug.facts facts "equalities"; let e = Q.pop facts.equas in Q.push e facts.ineqs; (*XXX also added in touched by congruence_closure*) let env, (sa, root, ex, orig) = semantic_view env e facts in Debug.assume_literal sa; let env = match sa with | A.Pred (r1,neg) -> let r2, r3 = if neg then X.bot(), X.top() else X.top(), X.bot() in if X.hash_cmp r1 r2 = 0 then env else let env = assume_eq env facts r1 r2 ex in assume_dist env facts [r1;r3] ex | A.Eq(r1, r2) -> if X.hash_cmp r1 r2 = 0 then env else assume_eq env facts r1 r2 ex | _ -> assert false in assume_equalities env choices facts end let rec assume_disequalities env choices facts = if Q.is_empty facts.diseqs then env, choices else begin Debug.facts facts "disequalities"; let e = Q.pop facts.diseqs in Q.push e facts.ineqs; let env, (sa, root, ex, orig) = semantic_view env e facts in Debug.assume_literal sa; let env = match sa with | A.Distinct (false, lr) -> assume_dist env facts lr ex | A.Distinct (true, _) -> assert false | A.Pred _ -> Q.push (LSem sa, ex, orig) facts.equas; env | _ -> assert false in if Q.is_empty facts.equas then assume_disequalities env choices facts else env, choices (* Return to give priority to equalities *) end let rec norm_queue env ineqs (facts:r Sig.facts) = if Q.is_empty facts.ineqs then env, List.rev ineqs else let e = Q.pop facts.ineqs in let env, e' = semantic_view env e facts in let ineqs = e'::ineqs in let ineqs = match e with (* for case-split, to be sure that CS is given back to relations *) | LSem ra, ex, ((Sig.CS _ | Sig.NCS _) as orig) -> (ra, None, ex, orig) :: ineqs | _ -> ineqs in norm_queue env ineqs facts let add_touched uf acc (facts:r Sig.facts) = let acc = Util.MI.fold (fun _ x acc -> let y, ex = Uf.find_r uf x in (*use terms ? *) (LR.mkv_eq x y, None, ex, Sig.Subst) :: acc) facts.touched acc in facts.touched <- Util.MI.empty; acc let rec assume_inequalities env choices facts = Options.tool_req 3 "TR-CCX-Builtin"; if Q.is_empty facts.ineqs then env, choices else begin Debug.facts facts "inequalities"; let env, ineqs = norm_queue env [] facts in let ineqs = add_touched env.uf ineqs facts in let env, l = replay_atom env ineqs in List.iter (add_fact facts) l; env, List.rev_append l choices end let rec assume_literals env choices facts = match Q.is_empty facts.equas with | false -> let env, choices = assume_equalities env choices facts in assume_literals env choices facts | true -> match Q.is_empty facts.diseqs with | false -> let env, choices = assume_disequalities env choices facts in assume_literals env choices facts | true -> match Q.is_empty facts.ineqs with | false -> let env, choices = assume_inequalities env choices facts in assume_literals env choices facts | true -> env, choices let theories_instances ~do_syntactic_matching t_match env selector = let rel, th_instances = Rel.instantiate ~do_syntactic_matching t_match env.relation env.uf selector in {env with relation=rel}, th_instances let add_term env facts t ex = let env = add_term env facts t ex in env, facts let add env facts a ex = let env = add env facts a ex in env, facts (* End: new implementation of add, add_term, assume_literals and all that *) let case_split env ~for_model = match Rel.case_split env.relation env.uf for_model with | [] when for_model -> let l, uf = Uf.assign_next env.uf in (* try to not to modify uf in the future. It's currently done only to add fresh terms in UF to avoid loops *) l, {env with uf} | l -> l, env let query env a = let ra, ex_ra = term_canonical_view env a Ex.empty in Rel.query env.relation env.uf (ra, Some a, ex_ra, Sig.Other) let new_terms env = Rel.new_terms env.relation let class_of env t = Uf.class_of env.uf t let are_equal env t1 t2 = Uf.are_equal env.uf t1 t2 let are_distinct env t1 t2 = Uf.are_distinct env.uf t1 t2 let cl_extract env = Uf.cl_extract env.uf let term_repr env t = Uf.term_repr env.uf t let get_union_find env = env.uf let print_model fmt env = let zero = ref true in let eqs, neqs = Uf.model env.uf in let rs = List.fold_left (fun acc (r, l, to_rel) -> if l != [] then begin if !zero then begin fprintf fmt "Theory:"; zero := false; end; fprintf fmt "\n %a = %a" (T.print_list_sep " = ") l X.print r; end; to_rel@acc ) [] eqs in List.iter (fun lt -> if !zero then begin fprintf fmt "Theory:"; zero := false; end; fprintf fmt "\n %a" (T.print_list_sep " <> ") lt; ) neqs; if not !zero then fprintf fmt "\n@."; Rel.print_model fmt env.relation rs let assume_th_elt env th_elt = {env with relation = Rel.assume_th_elt env.relation th_elt} let retrieve_used_context env dep = Rel.retrieve_used_context env.relation dep end alt-ergo-free-2.0.0/lib/reasoners/matching.mli0000664000175000017500000000601113430774474017017 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) module type S = sig type t type theory open Matching_types val empty : t val make: max_t_depth:int -> Matching_types.info Term.Map.t -> Term.t list Term.Map.t Term.Subst.t -> Matching_types.trigger_info list -> t val add_term : term_info -> Term.t -> t -> t val max_term_depth : t -> int -> t val add_triggers : backward:Util.inst_kind -> t -> (int * Explanation.t) Formula.Map.t -> t val terms_info : t -> info Term.Map.t * Term.t list Term.Map.t Term.Subst.t val query : t -> theory -> (trigger_info * gsubst list) list val unused_context : Formula.t -> bool end module type Arg = sig type t val term_repr : t -> Term.t -> Term.t val add_term : t -> Term.t -> t val are_equal : t -> Term.t -> Term.t -> add_terms:bool -> Sig.answer val class_of : t -> Term.t -> Term.t list end module Make (X : Arg) : S with type theory = X.t alt-ergo-free-2.0.0/lib/reasoners/intervalCalculus.ml0000664000175000017500000023342213430774474020404 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Format open Options open Sig open Matching_types module Z = Numbers.Z module Q = Numbers.Q let ale = Hstring.make "<=" let alt = Hstring.make "<" let is_le n = Hstring.compare n ale = 0 let is_lt n = Hstring.compare n alt = 0 let (-@) l1 l2 = List.rev_append l1 l2 module L = Literal module Sy = Symbols module I = Intervals exception NotConsistent of Literal.LT.Set.t module OracleContainer = (val (Inequalities.get_current ()) : Inequalities.Container_SIG) module Make (X : Sig.X) (Uf : Uf.S with type r = X.r) (P : Polynome.EXTENDED_Polynome with type r = X.r) = struct module MP0 = Map.Make(P) module SP = Set.Make(P) module SX = Set.Make(struct type t = X.r let compare = X.hash_cmp end) module MX0 = Map.Make(struct type t = X.r let compare = X.hash_cmp end) module MPL = Literal.LT.Map module Oracle = OracleContainer.Make(X)(Uf)(P) module MF = Formula.Map module ST = Term.Set module MT = Term.Map module F = Formula module Ex = Explanation module EM = Matching.Make (struct include Uf let add_term env t = fst (Uf.add env t) let are_equal env s t ~add_terms = Uf.are_equal env s t ~added_terms:false end) type r = P.r type uf = Uf.t module LR = Literal.Make(struct type t = X.r let compare = X.hash_cmp include X end) module MR = Map.Make( struct type t = r L.view let compare a b = LR.compare (LR.make a) (LR.make b) end) let alien_of p = match P.is_monomial p with | Some (a,x,b) when Q.equal a Q.one && Q.sign b = 0 -> x | _ -> P.embed p let poly_of r = match P.extract r with | Some p -> p | None -> P.create [Numbers.Q.one, r] Numbers.Q.zero (X.type_info r) module SimVar = struct type t = X.r let compare = X.hash_cmp let is_int r = X.type_info r == Ty.Tint let print fmt x = match P.extract x with | None -> fprintf fmt "%a" X.print x | Some p -> fprintf fmt "s!%d" (X.hash x) (* slake vars *) end module Sim = OcplibSimplex.Basic.Make(SimVar)(Numbers.Q)(Explanation) type t = { inequations : Oracle.t MPL.t; monomes: (I.t * SX.t) MX0.t; polynomes : I.t MP0.t; known_eqs : SX.t; improved_p : SP.t; improved_x : SX.t; classes : Term.Set.t list; size_splits : Q.t; int_sim : Sim.Core.t; rat_sim : Sim.Core.t; new_uf : uf; th_axioms : Commands.th_elt MF.t; linear_dep : ST.t MT.t; syntactic_matching : (Matching_types.trigger_info * Matching_types.gsubst list) list list; } module Sim_Wrap = struct let check_unsat_result simplex env = match Sim.Result.get None simplex with | Sim.Core.Unknown -> assert false | Sim.Core.Unbounded _ -> assert false | Sim.Core.Max _ -> assert false | Sim.Core.Sat _ -> () | Sim.Core.Unsat ex -> let ex = Lazy.force ex in if debug_fm() then fprintf fmt "[fm] simplex derived unsat: %a@." Explanation.print ex; raise (Exception.Inconsistent (ex, env.classes)) let solve env i = let int_sim = Sim.Solve.solve env.int_sim in check_unsat_result int_sim env; let rat_sim = Sim.Solve.solve env.rat_sim in check_unsat_result rat_sim env; {env with int_sim; rat_sim} let solve env i = if Options.timers() then try Timers.exec_timer_start Timers.M_Simplex Timers.F_solve; let res = solve env i in Timers.exec_timer_pause Timers.M_Simplex Timers.F_solve; res with e -> Timers.exec_timer_pause Timers.M_Simplex Timers.F_solve; raise e else solve env i let extract_bound i get_lb = let func, q = if get_lb then I.borne_inf, Q.one else I.borne_sup, Q.m_one in try let bnd, expl, large = func i in Some (bnd, if large then Q.zero else q), expl with I.No_finite_bound -> None, Explanation.empty let same_bnds _old _new = match _old, _new with | None, None -> true | None, Some _ | Some _, None -> false | Some(s,t), Some(u, v) -> Q.equal s u && Q.equal t v let add_if_better p _old _new simplex = (* p is in normal form pos *) let old_mn, old_mn_ex = extract_bound _old true in let old_mx, old_mx_ex = extract_bound _old false in let new_mn, new_mn_ex = extract_bound _new true in let new_mx, new_mx_ex = extract_bound _new false in if same_bnds old_mn new_mn && same_bnds old_mx new_mx then simplex else let l, z = P.to_list p in assert (Q.sign z = 0); let simplex, changed = match l with [] -> assert false | [c, x] -> assert (Q.is_one c); Sim.Assert.var simplex x new_mn new_mn_ex new_mx new_mx_ex | _ -> let l = List.rev_map (fun (c, x) -> x, c) l in Sim.Assert.poly simplex (Sim.Core.P.from_list l) (alien_of p) new_mn new_mn_ex new_mx new_mx_ex in (* we don't solve immediately. It may be expensive *) simplex let finite_non_point_dom info = match info.Sim.Core.mini, info.Sim.Core.maxi with | None, _ | _, None -> None | Some (a, b), Some(x,y) -> assert (Q.is_zero b); (*called on integers only *) assert (Q.is_zero y); let c = Q.compare a x in assert (c <= 0); (* because simplex says sat *) if c = 0 then None else Some (Q.sub x a) (* not used for the moment *) let case_split = let gen_cs x n s orig = if debug_fm () then fprintf fmt "[Sim_CS-%d] %a = %a of size %a@." orig X.print x Q.print n Q.print s; let ty = X.type_info x in let r1 = x in let r2 = alien_of (P.create [] n ty) in [LR.mkv_eq r1 r2, true, CS (Th_arith, s)] in let aux_1 uf x (info,_) acc = assert (X.type_info x == Ty.Tint); match finite_non_point_dom info with | Some s when (Sim.Core.equals_optimum info.Sim.Core.value info.Sim.Core.mini || Sim.Core.equals_optimum info.Sim.Core.value info.Sim.Core.maxi) && Uf.is_normalized uf x -> let v, _ = info.Sim.Core.value in assert (Q.is_int v); begin match acc with | Some (_,_,s') when Q.compare s' s <= 0 -> acc | _ -> Some (x,v, s) end | _ -> acc in let aux_2 env uf x (info,_) acc = let v, _ = info.Sim.Core.value in assert (X.type_info x == Ty.Tint); match finite_non_point_dom info with | Some s when Q.is_int v && Uf.is_normalized uf x -> let fnd1, cont1 = try true, I.contains (fst (MX0.find x env.monomes)) v with Not_found -> false, true in let fnd2, cont2 = try true, I.contains (MP0.find (poly_of x) env.polynomes) v with Not_found -> false, true in if (fnd1 || fnd2) && cont1 && cont2 then match acc with | Some (_,_,s') when Q.compare s' s <= 0 -> acc | _ -> Some (x,v, s) else acc | _ -> acc in fun env uf -> let int_sim = env.int_sim in assert (int_sim.Sim.Core.status == Sim.Core.SAT); let acc = Sim.Core.MX.fold (aux_1 uf) int_sim.Sim.Core.non_basic None in let acc = Sim.Core.MX.fold (aux_1 uf) int_sim.Sim.Core.basic acc in match acc with | Some (x, n, s) -> gen_cs x n s 1 (*!!!disable case-split that separates and interval into two parts*) | None -> let acc = Sim.Core.MX.fold (aux_2 env uf) int_sim.Sim.Core.non_basic None in let acc = Sim.Core.MX.fold (aux_2 env uf) int_sim.Sim.Core.basic acc in match acc with | Some (x, n, s) -> gen_cs x n s 2 | None -> [] let infer_best_bounds env p = let best_bnd lp ~upper sim i set_new_bound = let q = if upper then Q.one else Q.m_one in let lp = List.rev_map (fun (c, x) -> x, Q.mult q c) lp in let sim, mx_res = Sim.Solve.maximize sim (Sim.Core.P.from_list lp) in match Sim.Result.get mx_res sim with | Sim.Core.Unknown -> assert false | Sim.Core.Sat _ -> assert false (* because we maximized *) | Sim.Core.Unsat _ -> assert false (* we know sim is SAT *) | Sim.Core.Unbounded _ -> i | Sim.Core.Max(mx,sol) -> let {Sim.Core.max_v; is_le; reason} = Lazy.force mx in set_new_bound reason (Q.mult q max_v) ~is_le:is_le i in if debug_fpa()>=2 then fprintf fmt "#infer bounds for %a@." P.print p; let ty = P.type_info p in let sim = if ty == Ty.Tint then env.int_sim else env.rat_sim in let i = I.undefined ty in let lp, c = P.to_list p in assert (Q.is_zero c); assert (sim.Sim.Core.status == Sim.Core.SAT); let i = best_bnd lp ~upper:true sim i I.new_borne_sup in let i = best_bnd lp ~upper:false sim i I.new_borne_inf in if debug_fpa () >= 2 then fprintf fmt "## inferred bounds for %a: %a@." P.print p I.print i; i end module MP = struct include MP0 let assert_normalized_poly p = assert (let p0, c0, d0 = P.normal_form_pos p in let b = Q.is_zero c0 && Q.is_one d0 in begin if not b then fprintf fmt "[IC.assert_normalized_poly] %a is not normalized@." P.print p end; b) let n_add p i old ({polynomes} as env) = (*NB: adding a new entry into the map is considered as an improvement*) assert_normalized_poly p; if I.is_strict_smaller i old || not (MP0.mem p polynomes) then let ty = P.type_info p in let polynomes = MP0.add p i polynomes in let improved_p = SP.add p env.improved_p in if ty == Ty.Tint then {env with polynomes; improved_p; int_sim = Sim_Wrap.add_if_better p old i env.int_sim} else {env with polynomes; improved_p; rat_sim = Sim_Wrap.add_if_better p old i env.rat_sim} else let () = assert (I.equal i old) in env (* find with normalized polys *) let n_find p mp = assert_normalized_poly p; MP0.find p mp (* shadow the functions find and add of MP with the ones below to force the use of n_find and n_add for normalized polys *) let find (_ : unit) (_ : unit) = assert false let add (_ : unit) (_ : unit) (_ : unit) = assert false end module MX = struct include MX0 let assert_is_alien x = assert ( let b = P.extract x == None in begin if not b then fprintf fmt "[IC.assert_is_alien] %a is not an alien@." X.print x end; b ) let n_add x ((i,_) as e) old ({monomes} as env) = (*NB: adding a new entry into the map is considered as an improvement*) assert_is_alien x; if I.is_strict_smaller i old || not (MX0.mem x monomes) then let ty = X.type_info x in let monomes = MX0.add x e monomes in let improved_x = SX.add x env.improved_x in if ty == Ty.Tint then {env with monomes; improved_x; int_sim = Sim_Wrap.add_if_better (poly_of x) old i env.int_sim} else {env with monomes; improved_x; rat_sim = Sim_Wrap.add_if_better (poly_of x) old i env.rat_sim} else let () = assert (I.equal i old) in (* because use_x may be updated*) {env with monomes = MX0.add x e monomes} (* find with real aliens *) let n_find x mp = assert_is_alien x; MX0.find x mp (* shadow the functions find and add of MX with the ones below to force the use of n_find and n_add for true aliens *) let find (_ : unit) (_ : unit) = assert false let add (_ : unit) (_ : unit) (_ : unit) = assert false end (* generic find for values that may be non-alien or non normalized polys *) let generic_find xp env = let is_mon = P.extract xp == None in try if not is_mon then raise Not_found; let i, use = MX.n_find xp env.monomes in i, use, is_mon with Not_found -> (* according to this implem, it means that we can find aliens in polys but not in monomes. FIX THIS => an interval of x in monomes and in polys may be differents !!! *) let p0 = poly_of xp in let p, c = P.separate_constant p0 in let p, c0, d = P.normal_form_pos p in assert (Q.sign d <> 0 && Q.sign c0 = 0); let ty = P.type_info p0 in let ip = try MP.n_find p env.polynomes with Not_found -> I.undefined ty in let ip = if Q.is_one d then ip else I.scale d ip in let ip = if Q.is_zero c then ip else I.add ip (I.point c ty Explanation.empty) in ip, SX.empty, is_mon (* generic add for values that may be non-alien or non normalized polys *) let generic_add x j use is_mon env = (* NB: adding an entry into the map is considered as an improvement *) let ty = X.type_info x in if is_mon then try MX.n_add x (j,use) (fst (MX.n_find x env.monomes)) env with Not_found -> MX.n_add x (j, use) (I.undefined ty) env else let p0 = poly_of x in let p, c = P.separate_constant p0 in let p, c0, d = P.normal_form_pos p in assert (Q.sign d <> 0 && Q.sign c0 = 0); let j = I.add j (I.point (Q.minus c) ty Explanation.empty) in let j = I.scale (Q.inv d) j in try MP.n_add p j (MP.n_find p env.polynomes) env with Not_found -> MP.n_add p j (I.undefined ty) env (*BISECT-IGNORE-BEGIN*) module Debug = struct let assume a expl = if debug_fm () then begin fprintf fmt "[fm] We assume: %a@." LR.print (LR.make a); fprintf fmt "explanations: %a@." Explanation.print expl end let print_use fmt use = SX.iter (fprintf fmt "%a, " X.print) use let env env = if debug_fm () then begin fprintf fmt "------------ FM: inequations-------------------------@."; MPL.iter (fun a {Oracle.ple0=p; is_le=is_le} -> fprintf fmt "%a%s0 | %a@." P.print p (if is_le then "<=" else "<") L.LT.print a )env.inequations; fprintf fmt "------------ FM: monomes ----------------------------@."; MX.iter (fun x (i, use) -> fprintf fmt "%a : %a |-use-> {%a}@." X.print x I.print i print_use use) env.monomes; fprintf fmt "------------ FM: polynomes---------------------------@."; MP.iter (fun p i -> fprintf fmt "%a : %a@." P.print p I.print i) env.polynomes; fprintf fmt "-----------------------------------------------------@." end let implied_equalities l = if debug_fm () then begin fprintf fmt "[fm] %d implied equalities@." (List.length l); List.iter (fun (ra, _, ex, _) -> fprintf fmt " %a %a@." LR.print (LR.make ra) Explanation.print ex) l end let case_split r1 r2 = if debug_fm () then fprintf fmt "[case-split] %a = %a@." X.print r1 X.print r2 let no_case_split s = if debug_fm () then fprintf fmt "[case-split] %s : nothing@." s let inconsistent_interval expl = if debug_fm () then fprintf fmt "interval inconsistent %a@." Explanation.print expl let added_inequation kind ineq = if debug_fm () then begin fprintf fmt "[fm] I derived the (%s) inequality: %a %s 0@." kind P.print ineq.Oracle.ple0 (if ineq.Oracle.is_le then "<=" else "<"); fprintf fmt "from the following combination:@."; Util.MI.iter (fun a (coef, ple0, is_le) -> fprintf fmt "\t%a * (%a %s 0) + @." Q.print coef P.print ple0 (if is_le then "<=" else "<") )ineq.Oracle.dep; fprintf fmt "\t0@.@." end let tighten_interval_modulo_eq p1 p2 i1 i2 b1 b2 j = if debug_fm () then begin fprintf fmt "@.[fm] tighten intervals modulo eq: %a = %a@." P.print p1 P.print p2; fprintf fmt " %a has interval %a@." P.print p1 I.print i1; fprintf fmt " %a has interval %a@." P.print p2 I.print i2; fprintf fmt " intersection is %a@." I.print j; if b1 then fprintf fmt " > improve interval of %a@.@." P.print p1; if b2 then fprintf fmt " > improve interval of %a@.@." P.print p2; if not b1 && not b2 then fprintf fmt " > no improvement@.@." end end (*BISECT-IGNORE-END*) let empty classes = { inequations = MPL.empty; monomes = MX.empty ; polynomes = MP.empty ; known_eqs = SX.empty ; improved_p = SP.empty ; improved_x = SX.empty ; classes = classes; size_splits = Q.one; new_uf = Uf.empty (); rat_sim = Sim.Solve.solve (Sim.Core.empty ~is_int:false ~check_invs:false ~debug:0); int_sim = Sim.Solve.solve (Sim.Core.empty ~is_int:true ~check_invs:false ~debug:0); th_axioms = MF.empty; linear_dep = MT.empty; syntactic_matching = []; } (*let up_improved env p oldi newi = if I.is_strict_smaller newi oldi then { env with improved = SP.add p env.improved } else env*) (** computes an interval for vars = x_1^n_1 * ..... * x_i^n_i (1) if some var is not in monomes, then return undefined (2) check that all vars are in monomes before doing interval ops **) let mult_bornes_vars vars env ty = try let l = List.rev_map (fun (y,n) -> let i, _, _ = generic_find y env in i, n ) vars in List.fold_left (fun ui (yi,n) -> I.mult ui (I.power n yi)) (I.point Q.one ty Explanation.empty) l with Not_found -> I.undefined ty (** computes the interval of a polynome from those of its monomes. The monomes are supposed to be already added in env **) let intervals_from_monomes ?(monomes_inited=true) env p = let pl, v = P.to_list p in List.fold_left (fun i (a, x) -> let i_x, _ = try MX.n_find x env.monomes with Not_found -> if monomes_inited then assert false; I.undefined (X.type_info x), SX.empty in I.add (I.scale a i_x) i ) (I.point v (P.type_info p) Explanation.empty) pl (* because, it's not sufficient to look in the interval that corresponds to the normalized form of p ... *) let cannot_be_equal_to_zero env p ip = try let z = alien_of (P.create [] Q.zero (P.type_info p)) in match X.solve (alien_of p) z with | [] -> Sig.No (* p is equal to zero *) | _ -> I.doesnt_contain_0 ip with Exception.Unsolvable -> Sig.Yes (Explanation.empty, env.classes) let rec init_monomes_of_poly are_eq env p use_p expl = List.fold_left (fun env (_, x) -> try let u, old_use_x = MX.n_find x env.monomes in MX.n_add x (u, SX.union old_use_x use_p) u env with Not_found -> update_monome are_eq expl use_p env x ) env (fst (P.to_list p)) and init_alien are_eq expl p (normal_p, c, d) ty use_x env = let env = init_monomes_of_poly are_eq env p use_x expl in let i = intervals_from_monomes env p in let i = try let old_i = MP.n_find normal_p env.polynomes in let old_i = I.scale d (I.add old_i (I.point c ty Explanation.empty)) in I.intersect i old_i with Not_found -> i in env, i and update_monome are_eq expl use_x env x = let ty = X.type_info x in let ui, env = match X.ac_extract x with | Some {h=h; l=l } when Symbols.equal h (Symbols.Op Symbols.Mult) -> let use_x = SX.singleton x in let env = List.fold_left (fun env (r,_) -> let rp, _, _ = poly_of r |> P.normal_form_pos in match P.is_monomial rp with | Some (a,y,b) when Q.equal a Q.one && Q.sign b = 0 -> update_monome are_eq expl use_x env y | _ -> env (* should update polys ? *) ) env l in let m = mult_bornes_vars l env ty in m, env | _ -> match X.term_extract x with | Some t, _ -> let use_x = SX.singleton x in begin match Term.view t with | {Term.f = (Sy.Op Sy.Div); xs = [a; b]} -> let ra, ea = let (ra, _) as e = Uf.find env.new_uf a in if List.filter (X.equal x) (X.leaves ra) == [] then e else fst (X.make a), Explanation.empty (*otherwise, we loop*) in let rb, eb = let (rb, _) as e = Uf.find env.new_uf b in if List.filter (X.equal x) (X.leaves rb) == [] then e else fst (X.make b), Explanation.empty (*otherwise, we loop*) in let expl = Explanation.union expl (Explanation.union ea eb) in let pa = poly_of ra in let pb = poly_of rb in let (pa', ca, da) as npa = P.normal_form_pos pa in let (pb', cb, db) as npb = P.normal_form_pos pb in let env, ia = init_alien are_eq expl pa npa ty use_x env in let ia = I.add_explanation ia ea in (* take repr into account*) let env, ib = init_alien are_eq expl pb npb ty use_x env in let ib = I.add_explanation ib eb in (* take repr into account*) let ia, ib = match cannot_be_equal_to_zero env pb ib with | Yes (ex, _) when Q.equal ca cb && P.compare pa' pb' = 0 -> let expl = Explanation.union ex expl in I.point da ty expl, I.point db ty expl | Yes (ex, _) -> begin match are_eq a b with | Yes (ex_eq, _) -> let expl = Explanation.union ex expl in let expl = Explanation.union ex_eq expl in I.point Q.one ty expl, I.point Q.one ty expl | No -> ia, ib end | No -> ia, ib in I.div ia ib, env | _ -> I.undefined ty, env end | _ -> I.undefined ty, env in let u, use_x' = try MX.n_find x env.monomes with Not_found -> I.undefined (X.type_info x), use_x in let ui = I.intersect ui u in MX.n_add x (ui, (SX.union use_x use_x')) u env let rec tighten_ac are_eq x env expl = let ty = X.type_info x in let u, use_x = try MX.n_find x env.monomes with Not_found -> I.undefined ty, SX.empty in try match X.ac_extract x with | Some {h=h;t=t;l=[x,n]} when Symbols.equal h (Symbols.Op Symbols.Mult) && n mod 2 = 0 -> let env = match P.extract x with | None -> begin (* identity *) let u = I.root n u in let (pu, use_px) = try MX.n_find x env.monomes (* we know that x is a monome *) with Not_found -> I.undefined ty, SX.empty in let u = I.intersect u pu in let env = MX.n_add x (u, use_px) pu env in tighten_non_lin are_eq x use_px env expl end | Some _ -> (* Do something else for polys and non normalized-monomes ? *) env in env | Some {h=h;t=t;l=[x,n]} when Symbols.equal h (Symbols.Op Symbols.Mult) && n > 2 -> let env = match P.extract x with | None -> begin let u = I.root n u in let pu, use_px = try MX.n_find x env.monomes (* we know that x is a monome *) with Not_found -> I.undefined ty, SX.empty in let u = I.intersect u pu in let env = MX.n_add x (u, use_px) pu env in tighten_non_lin are_eq x use_px env expl end | Some _ -> (* Do something else for polys and non normalized-monomes ? *) env in env | _ -> env with Q.Not_a_float -> env and tighten_div x env expl = env and tighten_non_lin are_eq x use_x env expl = let env' = tighten_ac are_eq x env expl in let env' = tighten_div x env' expl in (*let use_x = SX.union use1_x use2_x in*) (* let i, _ = MX.find x env.monomes in *) (*let env' = update_monome are_eq expl use_x env' x in too expensive*) SX.fold (fun x acc -> let _, use = MX.n_find x acc.monomes in (* this is non-lin mult *) (*if I.is_strict_smaller new_i i then*) update_monome are_eq expl use acc x (*else acc*)) use_x env' let update_monomes_from_poly p i env = let lp, _ = P.to_list p in let ty = P.type_info p in List.fold_left (fun env (a,x) -> let np = P.remove x p in let (np,c,d) = P.normal_form_pos np in try let inp = MP.n_find np env.polynomes in let new_ix = I.scale (Q.div Q.one a) (I.add i (I.scale (Q.minus d) (I.add inp (I.point c ty Explanation.empty)))) in let old_ix, ux = MX.n_find x env.monomes in let ix = I.intersect old_ix new_ix in MX.n_add x (ix, ux) old_ix env with Not_found -> env ) env lp let update_polynomes_intervals env = MP.fold (fun p ip env -> let new_i = intervals_from_monomes env p in let i = I.intersect new_i ip in if I.is_strict_smaller i ip then update_monomes_from_poly p i (MP.n_add p i ip env) else env ) env.polynomes env let update_non_lin_monomes_intervals are_eq env = MX.fold (fun x (_, use_x) env -> tighten_non_lin are_eq x use_x env Explanation.empty ) env.monomes env let find_one_eq x u = match I.is_point u with | Some (v, ex) when X.type_info x != Ty.Tint || Q.is_int v -> let eq = LR.mkv_eq x (alien_of (P.create [] v (X.type_info x))) in Some (eq, None, ex, Sig.Other) | _ -> None let find_eq eqs x u env = match find_one_eq x u with | None -> eqs | Some eq1 -> begin match X.ac_extract x with | Some {h = h; l = [y,n]} when Symbols.equal h (Symbols.Op Symbols.Mult) -> let neweqs = try let u, _, _ = generic_find y env in match find_one_eq y u with | None -> eq1::eqs | Some eq2 -> eq1::eq2::eqs with Not_found -> eq1::eqs in neweqs | _ -> eq1::eqs end type ineq_status = | Trivial_eq | Trivial_ineq of Q.t | Bottom | Monome of Q.t * P.r * Q.t | Other let ineq_status {Oracle.ple0 = p ; is_le = is_le} = match P.is_monomial p with Some (a, x, v) -> Monome (a, x, v) | None -> if P.is_empty p then let _, v = P.separate_constant p in let c = Q.sign v (* equiv. to compare v Q.zero *) in if c > 0 || (c >=0 && not is_le) then Bottom else if c = 0 && is_le then Trivial_eq else Trivial_ineq v else Other (*let ineqs_from_dep dep borne_inf is_le = List.map (fun {poly_orig = p; coef = c} -> let (m,v,ty) = P.mult_const minusone p in (* quelle valeur pour le ?????? *) { ple0 = {poly = (m, v +/ (Q.div borne_inf c), ty); le = is_le} ; dep = []} )dep*) let mk_equality p = let r1 = alien_of p in let r2 = alien_of (P.create [] Q.zero (P.type_info p)) in LR.mkv_eq r1 r2 let fm_equalities eqs { Oracle.ple0 = p; dep = dep; expl = ex } = Util.MI.fold (fun _ (_, p, _) eqs -> (mk_equality p, None, ex, Sig.Other) :: eqs ) dep eqs let update_intervals are_eq env eqs expl (a, x, v) is_le = let (u0, use_x0) as ixx = MX.n_find x env.monomes in let uints, use_x = match X.ac_extract x with | Some {h=h; l=l} when Symbols.equal h (Symbols.Op Symbols.Mult) -> let m = mult_bornes_vars l env (X.type_info x) in I.intersect m u0, use_x0 | _ -> ixx in let b = Q.div (Q.mult Q.m_one v) a in let u = if Q.sign a > 0 then I.new_borne_sup expl b is_le uints else I.new_borne_inf expl b is_le uints in let env = MX.n_add x (u, use_x) u0 env in let env = tighten_non_lin are_eq x use_x env expl in env, (find_eq eqs x u env) let update_ple0 are_eq env p0 is_le expl = if P.is_empty p0 then env else let ty = P.type_info p0 in let a, _ = P.choose p0 in let p, change = if Q.sign a < 0 then P.mult_const Q.m_one p0, true else p0, false in let p, c, _ = P.normal_form p in let c = Q.minus c in let u = if change then I.new_borne_inf expl c is_le (I.undefined ty) else I.new_borne_sup expl c is_le (I.undefined ty) in let u, pu = try (* p is in normal_form_pos because of the ite above *) let pu = MP.n_find p env.polynomes in let i = I.intersect u pu in i, pu with Not_found -> u, I.undefined ty in let env = if I.is_strict_smaller u pu then update_monomes_from_poly p u (MP.n_add p u pu env) else env in match P.to_list p0 with | [a,x], v -> fst(update_intervals are_eq env [] expl (a, x, v) is_le) | _ -> env let register_relationship c x pi expl (x_rels, p_rels) = let x_rels = let a = Q.minus c, expl in let s = Q.sign c in assert (s <> 0); let low, up = try MX0.find x x_rels with Not_found -> MP0.empty, MP0.empty in let v = if s < 0 then MP0.add pi a low, up (* low_bnd(pi) / (-c) is a low_bnd of x *) else low, MP0.add pi a up (* low_bnd(pi) / (-c) is an up_bnd of x *) in MX0.add x v x_rels in let p_rels = let p0, c0, d0 = P.normal_form_pos pi in let b = c, Q.minus c0, Q.minus d0, expl in let s = Q.sign d0 in assert (s <> 0); let low,up = try MP0.find p0 p_rels with Not_found -> MX0.empty, MX0.empty in let w = if s < 0 then (*low_bnd(c*x)/(-d0) + (-c0) is a low_bnd of p0*) MX0.add x b low, up else (*low_bnd(c*x)/(-d0) + (-c0) is an up_bnd of p0*) low, MX0.add x b up in MP0.add p0 w p_rels in x_rels, p_rels let add_inequations are_eq acc x_opt lin = List.fold_left (fun ((env, eqs, rels) as acc) ineq -> let expl = ineq.Oracle.expl in match ineq_status ineq with | Bottom -> Debug.added_inequation "Bottom" ineq; raise (Exception.Inconsistent (expl, env.classes)) | Trivial_eq -> Debug.added_inequation "Trivial_eq" ineq; env, fm_equalities eqs ineq, rels | Trivial_ineq c -> Debug.added_inequation "Trivial_ineq" ineq; let n, pp = Util.MI.fold (fun _ (_, p, is_le) ((n, pp) as acc) -> if is_le then acc else match pp with | Some _ -> n+1, None | None when n=0 -> 1, Some p | _ -> n+1, None) ineq.Oracle.dep (0,None) in let env = Util.MI.fold (fun _ (coef, p, is_le) env -> let ty = P.type_info p in let is_le = match pp with Some x -> P.compare x p = 0 | _ -> is_le && n=0 in let p' = P.sub (P.create [] (Q.div c coef) ty) p in update_ple0 are_eq env p' is_le expl ) ineq.Oracle.dep env in env, eqs, rels | Monome (a, x, v) -> Debug.added_inequation "Monome" ineq; let env, eqs = update_intervals are_eq env eqs expl (a, x, v) ineq.Oracle.is_le in env, eqs, rels | Other -> match x_opt with | None -> acc | Some x -> let ple0 = ineq.Oracle.ple0 in let c = try P.find x ple0 with Not_found -> assert false in let ple0 = P.remove x ple0 in env, eqs, register_relationship c x ple0 ineq.Oracle.expl rels ) acc lin let split_problem env ineqs aliens = let current_age = Oracle.current_age () in let l, all_lvs = List.fold_left (fun (acc, all_lvs) ({Oracle.ple0=p} as ineq) -> match ineq_status ineq with | Trivial_eq | Trivial_ineq _ -> (acc, all_lvs) | Bottom -> raise (Exception.Inconsistent (ineq.Oracle.expl, env.classes)) | _ -> let lvs = List.fold_left (fun acc e -> SX.add e acc) SX.empty (aliens p) in ([ineq], lvs) :: acc , SX.union lvs all_lvs )([], SX.empty) ineqs in let ll = SX.fold (fun x l -> let lx, l_nx = List.partition (fun (_,s) -> SX.mem x s) l in match lx with | [] -> assert false | e:: lx -> let elx = List.fold_left (fun (l, lvs) (l', lvs') -> List.rev_append l l', SX.union lvs lvs') e lx in elx :: l_nx ) all_lvs l in let ll = List.filter (fun (ineqs, _) -> List.exists (fun ineq -> Z.equal current_age ineq.Oracle.age) ineqs )ll in List.fast_sort (fun (a,_) (b,_) -> List.length a - List.length b) ll let is_normalized_poly uf p = let p = alien_of p in let rp, _ = Uf.find_r uf p in if X.equal p rp then true else begin fprintf fmt "%a <= 0 NOT normalized@." X.print p; fprintf fmt "It is equal to %a@." X.print rp; false end let better_upper_bound_from_intervals env p = let p0, c0, d0 = P.normal_form_pos p in assert (Q.is_zero c0); try let i = MP.n_find p0 env.polynomes in if Q.is_one d0 then I.borne_sup i else if Q.is_m_one d0 then let bi, ex, is_large = I.borne_inf i in Q.minus bi, ex, is_large else assert false with I.No_finite_bound | Not_found -> assert false (*env.polynomes is up to date w.r.t. ineqs *) let better_bound_from_intervals env ({Oracle.ple0; is_le; dep} as v) = let p, c = P.separate_constant ple0 in assert (not (P.is_empty p)); let cur_up_bnd = Q.minus c in let i_up_bnd, expl, is_large = better_upper_bound_from_intervals env p in let new_p = P.add_const (Q.minus i_up_bnd) p in let a = match Util.MI.bindings dep with [a,_] -> a | _ -> assert false in let cmp = Q.compare i_up_bnd cur_up_bnd in assert (cmp <= 0); if cmp = 0 then match is_le, is_large with | false, true -> assert false (* intervals are normalized wrt ineqs *) | false, false | true, true -> v (* no change *) | true , false -> (* better bound, Large ineq becomes Strict *) {v with Oracle.ple0 = new_p; expl = expl; is_le = false; dep = Util.MI.singleton a (Q.one, new_p, false)} else (* new bound is better. i.e. i_up_bnd < cur_up_bnd *) {v with Oracle.ple0 = new_p; expl = expl; is_le = is_large; dep = Util.MI.singleton a (Q.one, new_p, is_large)} let args_of p = List.rev_map snd (fst (P.to_list p)) let update_linear_dep env rclass_of ineqs = let terms = List.fold_left (fun st {Oracle.ple0} -> List.fold_left (fun st (c, x) -> ST.union st (rclass_of x)) st (fst (P.to_list ple0)) )ST.empty ineqs in let linear_dep = ST.fold (fun t linear_dep -> MT.add t terms linear_dep) terms env.linear_dep in {env with linear_dep} let refine_x_bounds ix env rels is_low = MP.fold (fun p (m_cx, ineq_ex) ix -> try (* recall (construction of x_rels): -> is_low : low_bnd(pi) / (-c) is a low_bnd of x -> not is_low : low_bnd(pi) / (-c) is an up_bnd of x *) assert (is_low == (Q.sign m_cx > 0)); let ip, _, _ = generic_find (alien_of p) env in let b, ex_b, is_le = I.borne_inf ip in (* invariant, see above *) let b = Q.div b m_cx in let func = if is_low then I.new_borne_inf else I.new_borne_sup in func (Explanation.union ineq_ex ex_b) b is_le ix with I.No_finite_bound -> ix )rels ix let monomes_relational_deductions env x_rels = MX.fold (fun x (low, up) env -> let ix0, use_x = try MX.n_find x env.monomes with Not_found -> assert false in let ix = refine_x_bounds ix0 env low true in let ix = refine_x_bounds ix env up false in if I.is_strict_smaller ix ix0 then MX.n_add x (ix, use_x) ix0 env else env )x_rels env let refine_p_bounds ip p env rels is_low = MX.fold (fun x (cx, mc0, md0, ineq_ex) ip -> try (* recall (construction of p_rels): -> is_low : low_bnd(c*x) / (-d0) + (-c0) is a low_bnd of p0 -> not is_low : low_bnd(c*x) / (-d0) + (-c0) is an up_bnd of p0 where p = (p0 + c0) * d0 and c*x + p <= 0 *) assert (is_low == (Q.sign md0 > 0)); let ix,_ = try MX.n_find x env.monomes with Not_found -> raise Exit in let bx, ex_b, is_le = (if Q.sign cx > 0 then I.borne_inf else I.borne_sup) ix in (* this this the low_bnd of c*x, see above *) let b = Q.mult cx bx in let b = Q.add (Q.div b md0) mc0 in (* final bnd of p0 *) let func = if is_low then I.new_borne_inf else I.new_borne_sup in func (Explanation.union ineq_ex ex_b) b is_le ip with Exit | I.No_finite_bound -> ip )rels ip let polynomes_relational_deductions env p_rels = MP.fold (fun p0 (low, up) env -> (* p0 is in normal_form pos *) let xp = alien_of p0 in if not (MP.mem p0 env.polynomes || MX.mem xp env.monomes) then env else let ip0, use, is_mon = generic_find xp env in let ip = refine_p_bounds ip0 p0 env low true in let ip = refine_p_bounds ip p0 env up false in if I.is_strict_smaller ip ip0 then if is_mon then MX.n_add xp (ip, use) ip0 env else MP.n_add p0 ip ip0 env else env )p_rels env let fm uf are_eq rclass_of env eqs = if debug_fm () then fprintf fmt "[fm] in fm/fm-simplex@."; Options.tool_req 4 "TR-Arith-Fm"; let ineqs = MPL.fold (fun k v acc -> assert (is_normalized_poly uf v.Oracle.ple0); (better_bound_from_intervals env v) :: acc ) env.inequations [] in (*let pbs = split_problem env ineqs (fun p -> P.leaves p) in*) let pbs = split_problem env ineqs args_of in let res = List.fold_left (fun (env, eqs) (ineqs, _) -> let env = update_linear_dep env rclass_of ineqs in let mp = Oracle.MINEQS.add_to_map Oracle.MINEQS.empty ineqs in let env, eqs, (x_rels, p_rels) = Oracle.available add_inequations are_eq (env, eqs, (MX.empty, MP.empty)) mp in let env = monomes_relational_deductions env x_rels in let env = polynomes_relational_deductions env p_rels in env, eqs )(env, eqs) pbs in if debug_fm () then fprintf fmt "[fm] out fm/fm-simplex@."; res let is_num r = let ty = X.type_info r in ty == Ty.Tint || ty == Ty.Treal let add_disequality are_eq env eqs p expl = let ty = P.type_info p in match P.to_list p with | ([], v) -> if Q.sign v = 0 then raise (Exception.Inconsistent (expl, env.classes)); env, eqs | ([a, x], v) -> let b = Q.div (Q.minus v) a in let i1 = I.point b ty expl in let i2, use2 = try MX.n_find x env.monomes with Not_found -> I.undefined ty, SX.empty in let i = I.exclude i1 i2 in let env = MX.n_add x (i,use2) i2 env in let env = tighten_non_lin are_eq x use2 env expl in env, find_eq eqs x i env | _ -> let p, c, _ = P.normal_form_pos p in let i1 = I.point (Q.minus c) ty expl in let i2 = try MP.n_find p env.polynomes with Not_found -> I.undefined ty in let i = I.exclude i1 i2 in let env = if I.is_strict_smaller i i2 then update_monomes_from_poly p i (MP.n_add p i i2 env) else env in env, eqs let add_equality are_eq env eqs p expl = let ty = P.type_info p in match P.to_list p with | ([], v) -> if Q.sign v <> 0 then raise (Exception.Inconsistent (expl, env.classes)); env, eqs | ([a, x], v) -> let b = Q.div (Q.minus v) a in let i = I.point b ty expl in let i2, use = try MX.n_find x env.monomes with Not_found -> I.undefined ty, SX.empty in let i = I.intersect i i2 in let env = MX.n_add x (i, use) i2 env in let env = tighten_non_lin are_eq x use env expl in env, find_eq eqs x i env | _ -> let p, c, _ = P.normal_form_pos p in let i = I.point (Q.minus c) ty expl in let i, ip = try let ip = MP.n_find p env.polynomes in I.intersect i ip, ip with Not_found -> i, I.undefined ty in let env = if I.is_strict_smaller i ip then update_monomes_from_poly p i (MP.n_add p i ip env) else env in let env = { env with known_eqs = SX.add (alien_of p) env.known_eqs } in env, eqs let normal_form a = match a with | L.Builtin (false, n, [r1; r2]) when is_le n && X.type_info r1 == Ty.Tint -> let pred_r1 = P.sub (poly_of r1) (P.create [] Q.one Ty.Tint) in LR.mkv_builtin true n [r2; alien_of pred_r1] | L.Builtin (true, n, [r1; r2]) when not (is_le n) && X.type_info r1 == Ty.Tint -> let pred_r2 = P.sub (poly_of r2) (P.create [] Q.one Ty.Tint) in LR.mkv_builtin true ale [r1; alien_of pred_r2] | L.Builtin (false, n, [r1; r2]) when is_le n -> LR.mkv_builtin true alt [r2; r1] | L.Builtin (false, n, [r1; r2]) when is_lt n -> LR.mkv_builtin true ale [r2; r1] | _ -> a let remove_trivial_eqs eqs la = let la = List.fold_left (fun m ((a, _, _, _) as e) -> MR.add a e m) MR.empty la in let eqs, _ = List.fold_left (fun ((eqs, m) as acc) ((sa, root, ex, orig) as e) -> if MR.mem sa m then acc else e :: eqs, MR.add sa e m )([], la) eqs in eqs let equalities_from_polynomes env eqs = let known, eqs = MP.fold (fun p i (knw, eqs) -> let xp = alien_of p in if SX.mem xp knw then knw, eqs else match I.is_point i with | Some (num, ex) -> let r2 = alien_of (P.create [] num (P.type_info p)) in SX.add xp knw, (LR.mkv_eq xp r2, None, ex, Sig.Other) :: eqs | None -> knw, eqs ) env.polynomes (env.known_eqs, eqs) in {env with known_eqs= known}, eqs let equalities_from_monomes env eqs = let known, eqs = MX.fold (fun x (i,_) (knw, eqs) -> if SX.mem x knw then knw, eqs else match I.is_point i with | Some (num, ex) -> let r2 = alien_of (P.create [] num (X.type_info x)) in SX.add x knw, (LR.mkv_eq x r2, None, ex, Sig.Other) :: eqs | None -> knw, eqs ) env.monomes (env.known_eqs, eqs) in {env with known_eqs= known}, eqs let equalities_from_intervals env eqs = let env, eqs = equalities_from_polynomes env eqs in equalities_from_monomes env eqs let count_splits env la = let nb = List.fold_left (fun nb (_,_,_,i) -> match i with | CS (Th_arith, n) -> Numbers.Q.mult nb n | _ -> nb )env.size_splits la in {env with size_splits = nb} let remove_ineq a ineqs = match a with None -> ineqs | Some a -> MPL.remove a ineqs let add_ineq a v ineqs = match a with None -> ineqs | Some a -> MPL.add a v ineqs (*** functions to improve intervals modulo equality ***) let tighten_eq_bounds env r1 r2 p1 p2 origin_eq expl = if P.is_const p1 != None || P.is_const p2 != None then env else match origin_eq with | CS _ | NCS _ -> env | Subst | Other -> (* Subst is needed, but is Other needed ?? or is it subsumed ? *) let i1, us1, is_mon_1 = generic_find r1 env in let i2, us2, is_mon_2 = generic_find r2 env in let j = I.add_explanation (I.intersect i1 i2) expl in let impr_i1 = I.is_strict_smaller j i1 in let impr_i2 = I.is_strict_smaller j i2 in Debug.tighten_interval_modulo_eq p1 p2 i1 i2 impr_i1 impr_i2 j; let env = if impr_i1 then generic_add r1 j us1 is_mon_1 env else env in if impr_i2 then generic_add r2 j us2 is_mon_2 env else env let rec loop_update_intervals are_eq env cpt = let cpt = cpt + 1 in let env = {env with improved_p=SP.empty; improved_x=SX.empty} in let env = update_non_lin_monomes_intervals are_eq env in let env = Sim_Wrap.solve env 1 in let env = update_polynomes_intervals env in let env = Sim_Wrap.solve env 1 in if env.improved_p == SP.empty && env.improved_x == SX.empty || cpt > 10 then env else loop_update_intervals are_eq env cpt let assume ~query env uf la = Oracle.incr_age (); let env = count_splits env la in let are_eq = Uf.are_equal uf ~added_terms:true in let classes = Uf.cl_extract uf in let rclass_of = Uf.rclass_of uf in let env = {env with improved_p=SP.empty; improved_x=SX.empty; classes; new_uf = uf} in Debug.env env; let nb_num = ref 0 in let env, eqs, new_ineqs, to_remove = List.fold_left (fun ((env, eqs, new_ineqs, rm) as acc) (a, root, expl, orig) -> let a = normal_form a in Debug.assume a expl; try match a with | L.Builtin(_, n, [r1;r2]) when is_le n || is_lt n -> incr nb_num; let p1 = poly_of r1 in let p2 = poly_of r2 in let ineq = Oracle.create_ineq p1 p2 (is_le n) root expl in begin match ineq_status ineq with | Bottom -> raise (Exception.Inconsistent (expl, env.classes)) | Trivial_eq | Trivial_ineq _ -> {env with inequations=remove_ineq root env.inequations}, eqs, new_ineqs, (match root with None -> rm | Some a -> a:: rm) | Monome _ | Other -> let env = init_monomes_of_poly are_eq env ineq.Oracle.ple0 SX.empty Explanation.empty in let env = update_ple0 are_eq env ineq.Oracle.ple0 (is_le n) expl in {env with inequations=add_ineq root ineq env.inequations}, eqs, true, rm end | L.Distinct (false, [r1; r2]) when is_num r1 && is_num r2 -> incr nb_num; let p = P.sub (poly_of r1) (poly_of r2) in begin match P.is_const p with | Some c -> if Q.is_zero c then (* bottom *) raise (Exception.Inconsistent (expl, env.classes)) else (* trivial *) let rm = match root with Some a -> a::rm | None -> rm in env, eqs, new_ineqs, rm | None -> let env = init_monomes_of_poly are_eq env p SX.empty Explanation.empty in let env, eqs = add_disequality are_eq env eqs p expl in env, eqs, new_ineqs, rm end | L.Eq(r1, r2) when is_num r1 && is_num r2 -> incr nb_num; let p1 = poly_of r1 in let p2 = poly_of r2 in let p = P.sub p1 p2 in let env = init_monomes_of_poly are_eq env p SX.empty Explanation.empty in let env, eqs = add_equality are_eq env eqs p expl in let env = tighten_eq_bounds env r1 r2 p1 p2 orig expl in env, eqs, new_ineqs, rm | _ -> acc with I.NotConsistent expl -> Debug.inconsistent_interval expl ; raise (Exception.Inconsistent (expl, env.classes)) ) (env, [], false, []) la in try let env = if query then env else Sim_Wrap.solve env 1 in if !nb_num = 0 || query then env, {assume=[]; remove = to_remove} else (* we only call fm when new ineqs are assumed *) let env, eqs = if new_ineqs && not (Options.no_fm ()) then fm uf are_eq rclass_of env eqs else env, eqs in let env = Sim_Wrap.solve env 1 in let env = loop_update_intervals are_eq env 0 in let env, eqs = equalities_from_intervals env eqs in Debug.env env; let eqs = remove_trivial_eqs eqs la in Debug.implied_equalities eqs; let to_assume = List.rev_map (fun (sa, _, ex, orig) -> (LSem sa, ex, orig)) eqs in env, {assume = to_assume; remove = to_remove} with I.NotConsistent expl -> Debug.inconsistent_interval expl ; raise (Exception.Inconsistent (expl, env.classes)) let assume ~query env uf la = let env, res = assume ~query env uf la in let polys = MP.fold (fun p _ mp -> if Uf.is_normalized uf (alien_of p) then mp else MP.remove p mp) env.polynomes env.polynomes in {env with polynomes = polys}, res let query env uf a_ex = try ignore(assume ~query:true env uf [a_ex]); No with Exception.Inconsistent (expl, classes) -> Yes (expl, classes) let assume env uf la = if Options.timers() then try Timers.exec_timer_start Timers.M_Arith Timers.F_assume; let res =assume ~query:false env uf la in Timers.exec_timer_pause Timers.M_Arith Timers.F_assume; res with e -> Timers.exec_timer_pause Timers.M_Arith Timers.F_assume; raise e else assume ~query:false env uf la let query env uf la = if Options.timers() then try Timers.exec_timer_start Timers.M_Arith Timers.F_query; let res = query env uf la in Timers.exec_timer_pause Timers.M_Arith Timers.F_query; res with e -> Timers.exec_timer_pause Timers.M_Arith Timers.F_query; raise e else query env uf la let case_split_polynomes env = let o = MP.fold (fun p i o -> match I.finite_size i with | Some s when Q.compare s Q.one > 0 -> begin match o with | Some (s', p', _) when Q.compare s' s < 0 -> o | _ -> let n, ex, is_large = I.borne_inf i in assert (is_large); Some (s, p, n) end | _ -> o ) env.polynomes None in match o with | Some (s, p, n) -> let r1 = alien_of p in let r2 = alien_of (P.create [] n (P.type_info p)) in Debug.case_split r1 r2; [LR.mkv_eq r1 r2, true, CS (Th_arith, s)], s | None -> Debug.no_case_split "polynomes"; [], Q.zero let case_split_monomes env = let o = MX.fold (fun x (i,_) o -> match I.finite_size i with | Some s when Q.compare s Q.one > 0 -> begin match o with | Some (s', _, _) when Q.compare s' s < 0 -> o | _ -> let n, ex, is_large = I.borne_inf i in assert (is_large); Some (s, x, n) end | _ -> o ) env.monomes None in match o with | Some (s,x,n) -> let ty = X.type_info x in let r1 = x in let r2 = alien_of (P.create [] n ty) in Debug.case_split r1 r2; [LR.mkv_eq r1 r2, true, CS (Th_arith, s)], s | None -> Debug.no_case_split "monomes"; [], Q.zero let check_size for_model env res = if for_model then res else match res with | [] -> res | [_, _, CS (Th_arith, s)] -> if Numbers.Q.compare (Q.mult s env.size_splits) (max_split ()) <= 0 || Numbers.Q.sign (max_split ()) < 0 then res else [] | _ -> assert false let default_case_split env uf ~for_model = Options.tool_req 4 "TR-Arith-CaseSplit"; match check_size for_model env (Sim_Wrap.case_split env uf) with [] -> begin let cs1, sz1 = case_split_polynomes env in let cs2, sz2 = case_split_monomes env in match check_size for_model env cs1, check_size for_model env cs2 with | [], cs | cs, [] -> cs | cs1, cs2 -> if Q.compare sz1 sz2 < 0 then cs1 else cs2 end | res -> res let add = let are_eq t1 t2 = if Term.equal t1 t2 then Yes (Explanation.empty, []) else No in fun env new_uf r t -> try let env = {env with new_uf} in if is_num r then init_monomes_of_poly are_eq env (poly_of r) SX.empty Explanation.empty else env with I.NotConsistent expl -> Debug.inconsistent_interval expl ; raise (Exception.Inconsistent (expl, env.classes)) (* let extract_improved env = SP.fold (fun p acc -> MP.add p (MP.find p env.polynomes) acc) env.improved MP.empty *) let print_model fmt env rs = match rs with | [] -> () | _ -> fprintf fmt "Relation:"; List.iter (fun (t, r) -> let p = poly_of r in let ty = P.type_info p in if ty == Ty.Tint || ty == Ty.Treal then let p', c, d = P.normal_form_pos p in let pu' = try MP.n_find p' env.polynomes with Not_found -> I.undefined ty in let pm' = try intervals_from_monomes ~monomes_inited:false env p' with Not_found -> I.undefined ty in let u' = I.intersect pu' pm' in if I.is_point u' == None && I.is_undefined u' then let u = I.scale d (I.add u' (I.point c ty Explanation.empty)) in fprintf fmt "\n %a ∈ %a" Term.print t I.pretty_print u ) rs; fprintf fmt "\n@." let new_terms env = Term.Set.empty let case_split_union_of_intervals = let aux acc uf i z = if Uf.is_normalized uf z then match I.bounds_of i with | [] -> assert false | [_] -> () | (_,(v, ex))::_ -> acc := Some (z, v, ex); raise Exit in fun env uf -> let cs = ref None in try MP.iter (fun p i -> aux cs uf i (alien_of p)) env.polynomes; MX.iter (fun x (i,_) -> aux cs uf i x) env.monomes; [] with Exit -> match !cs with | None -> assert false | Some(_,None, _) -> assert false | Some(r1,Some (n, eps), ex) -> let ty = X.type_info r1 in let r2 = alien_of (P.create [] n ty) in let pred = if Q.is_zero eps then ale else (assert (Q.is_m_one eps); alt) in [LR.mkv_builtin true pred [r1; r2], true, CS (Th_arith, Q.one)] (*****) let int_constraints_from_map_intervals = let aux p xp i uf acc = if Uf.is_normalized uf xp && I.is_point i == None && P.type_info p == Ty.Tint then (p, I.bounds_of i) :: acc else acc in fun env uf -> let acc = MP.fold (fun p i acc -> aux p (alien_of p) i uf acc) env.polynomes [] in MX.fold (fun x (i,s) acc -> aux (poly_of x) x i uf acc) env.monomes acc let fm_simplex_unbounded_integers_encoding env uf = let simplex = Sim.Core.empty ~is_int:true ~check_invs:true ~debug:0 in let int_ctx = int_constraints_from_map_intervals env uf in List.fold_left (fun simplex (p, uints) -> match uints with | [] -> fprintf fmt "Intervals already empty !!!!@."; assert false | _::_::_ -> fprintf fmt "case-split over unions of intervals is needed !!!!@."; assert false | [(mn, ex_mn), (mx, ex_mx)] -> let l, c = P.to_list p in let l = List.rev_map (fun (c, x) -> x, c) (List.rev l) in assert (Q.sign c = 0); let cst0 = List.fold_left (fun z (x, c) -> Q.add z (Q.abs c))Q.zero l in let cst = Q.div cst0 (Q.from_int 2) in assert (mn == None || mx == None); let mn = match mn with | None -> None | Some (q, q') -> Some (Q.add q cst, q') in let mx = match mx with | None -> None | Some (q, q') -> Some (Q.sub q cst, q') in match l with | [] -> assert false | [x, c] -> assert (Q.is_one c); Sim.Assert.var simplex x mn ex_mn mx ex_mx |> fst | _ -> let xp = alien_of p in let sim_p = match Sim.Core.poly_of_slake simplex xp with | Some res -> res | None -> Sim.Core.P.from_list l in Sim.Assert.poly simplex sim_p xp mn ex_mn mx ex_mx |> fst ) simplex int_ctx let round_to_integers list = List.rev_map (fun (x, q1) -> let f = Q.floor q1 in let c = Q.ceiling q1 in x, if Q.compare (Q.sub q1 f) (Q.sub c q1) > 0 then f else c ) (List.rev list) (* cannot replace directly with env.int_sim because of encoding *) let model_from_simplex sim is_int env uf = match Sim.Result.get None sim with | Sim.Core.Unknown | Sim.Core.Unbounded _ | Sim.Core.Max _ -> assert false | Sim.Core.Unsat ex -> (* when splitting on union of intervals, FM does not include related ineqs when crossing. So, we may miss some bounds/deductions, and FM-Simplex may fail to find a model *) raise (Exception.Inconsistent(Lazy.force ex, env.classes)) | Sim.Core.Sat sol -> let {Sim.Core.main_vars; slake_vars; int_sol} = Lazy.force sol in let main_vars, slake_vars = if int_sol || not is_int then main_vars, slake_vars else round_to_integers main_vars, round_to_integers slake_vars in let fct = if is_int then Term.int else Term.real in List.fold_left (fun acc (v, q) -> assert (not is_int || Q.is_int q); if SX.mem v env.known_eqs || not (Uf.is_normalized uf v) then (* may happen because of incremental simplex on rationals *) acc else let t = fct (Q.to_string q) in let r, _ = X.make t in if debug_interpretation() then fprintf fmt "[%s simplex] %a = %a@." (if is_int then "integer" else "rational") X.print v X.print r; (v, r, Explanation.empty) :: acc )[] (List.rev main_vars) let model_from_unbounded_domains = let mk_cs acc (x, v, ex) = ((LR.view (LR.mk_eq x v)), true, CS (Th_arith, Q.from_int 2)) :: acc in fun env uf -> assert (env.int_sim.Sim.Core.status == Sim.Core.SAT); assert (env.rat_sim.Sim.Core.status == Sim.Core.SAT); let rat_sim = env.rat_sim in (* reuse existing rat_sim *) let int_sim = (* create a new int_sim with FM-Simplex encoding *) let sim = fm_simplex_unbounded_integers_encoding env uf in Sim.Solve.solve sim in let l1 = model_from_simplex rat_sim false env uf in let l2 = model_from_simplex int_sim true env uf in List.fold_left mk_cs (List.fold_left mk_cs [] l1) l2 let case_split env uf ~for_model = let res = default_case_split env uf for_model in match res with | [] -> if not for_model then [] else begin match case_split_union_of_intervals env uf with | [] -> model_from_unbounded_domains env uf | l -> l end | _ -> res (*** part dedicated to FPA reasoning ************************************) open Matching let best_interval_of optimized env p = (* p is supposed to be in normal_form_pos *) match P.is_const p with | Some c -> env, I.point c (P.type_info p) Explanation.empty | None -> let i = try let i, _, _ = generic_find (alien_of p) env in i with Not_found -> I.undefined (P.type_info p) in if SP.mem p !optimized then env, i else try let j = Sim_Wrap.infer_best_bounds env p in optimized := SP.add p !optimized; let k = I.intersect i j in if not (I.is_strict_smaller k i) then env, i else let env = MP.n_add p k i env in Sim_Wrap.solve env 1, k with I.NotConsistent expl -> if true (*debug_fpa() >= 2*) then begin [@ocaml.ppwarning "TODO: find an example triggering this case!"] fprintf fmt "TODO: should check that this is correct !!!!@." end; raise (Exception.Inconsistent (expl, env.classes)) let mk_const_term ty s = match ty with | Ty.Tint -> Term.int (Q.to_string s) | Ty.Treal -> Term.real (Q.to_string s) | _ -> assert false let integrate_mapsTo_bindings sbs maps_to = try let sbs = List.fold_left (fun ((sbt, sty) as sbs) (x, tx) -> let x = Sy.Var x in assert (not (Symbols.Map.mem x sbt)); let t = Term.apply_subst sbs tx in let mk, _ = X.make t in match P.is_const (poly_of mk) with | None -> if debug_fpa() >= 2 then begin fprintf fmt "bad semantic trigger %a |-> %a" Sy.print x Term.print tx; fprintf fmt " left-hand side is not a constant!@."; end; raise Exit | Some c -> let tc = mk_const_term (Term.type_info t) c in Symbols.Map.add x tc sbt, sty )sbs maps_to in Some sbs with Exit -> None let extend_with_domain_substitution = (* TODO : add the ability to modify the value of epsilon ? *) let eps = Q.div_2exp Q.one 1076 in let aux idoms sbt = Hstring.Map.fold (fun hs (lv, uv, ty) sbt -> let s = Hstring.view hs in match s.[0] with | '?' -> sbt | _ -> let lb_var = Sy.var s in let lb_val = match lv, uv with | None, None -> raise Exit | Some (q1, false), Some (q2, false) when Q.equal q1 q2 -> mk_const_term ty q1 | Some (q1,s1), Some (q2,s2) -> fprintf fmt "%a <= %a <= %a@." Q.print q1 Sy.print lb_var Q.print q2; Format.eprintf "Which value should we choose ?@."; assert (Q.compare q2 q1 >= 0); assert false | Some (q, is_strict), None -> (* hs > q or hs >= q *) mk_const_term ty (if is_strict then Q.add q eps else q) | None, Some (q, is_strict) -> (* hs < q or hs <= q *) mk_const_term ty (if is_strict then Q.sub q eps else q) in Sy.Map.add lb_var lb_val sbt ) idoms sbt in fun (sbt, sbty) idoms -> try Some (aux idoms sbt, sbty) with Exit -> if debug_fpa() >=2 then fprintf fmt "[IC] extend_with_domain_substitution failed !@."; None let terms_linear_dep {linear_dep} lt = match lt with | [] | [_] -> true | e::l -> try let st = MT.find e linear_dep in List.for_all (fun t -> ST.mem t st) l with Not_found -> false exception Sem_match_fails of t let domain_matching lem_name tr sbt env uf optimized = try let idoms, maps_to, env, uf = List.fold_left (fun (idoms, maps_to, env, uf) s -> match s with | F.MapsTo (x, t) -> (* this will be done in the latest phase *) idoms, (x, t) :: maps_to, env, uf | F.Interval (t, lb, ub) -> let tt = Term.apply_subst sbt t in assert (Term.is_ground tt); let uf, _ = Uf.add uf tt in let rr, ex = Uf.find uf tt in let p = poly_of rr in let p', c', d = P.normal_form_pos p in let env, i' = best_interval_of optimized env p' in let ic = I.point c' (P.type_info p') Explanation.empty in let i = I.scale d (I.add i' ic) in begin match I.match_interval lb ub i idoms with | None -> raise (Sem_match_fails env) | Some idoms -> idoms, maps_to, env, uf end | F.NotTheoryConst t -> let tt = Term.apply_subst sbt t in let uf, _ = Uf.add uf tt in if X.leaves (fst (Uf.find uf tt)) == [] || X.leaves (fst (X.make tt)) == [] then raise (Sem_match_fails env); idoms, maps_to, env, uf | F.IsTheoryConst t -> let tt = Term.apply_subst sbt t in let uf, _ = Uf.add uf tt in let r, _ = X.make tt in if X.leaves r != [] then raise (Sem_match_fails env); idoms, maps_to, env, uf | F.LinearDependency (x, y) -> let x = Term.apply_subst sbt x in let y = Term.apply_subst sbt y in if not (terms_linear_dep env [x;y]) then raise (Sem_match_fails env); let uf, _ = Uf.add uf x in let uf, _ = Uf.add uf y in idoms, maps_to, env, uf )(Hstring.Map.empty, [], env, uf) tr.F.semantic in env, Some (idoms, maps_to) with Sem_match_fails env -> env, None let semantic_matching lem_name tr sbt env uf optimized = match domain_matching lem_name tr sbt env uf optimized with | env, None -> env, None | env, Some(idom, mapsTo) -> begin match extend_with_domain_substitution sbt idom with | None -> env, None | Some sbs -> env, integrate_mapsTo_bindings sbs mapsTo end let record_this_instance f accepted lorig = if Options.profiling() then match F.view lorig with | F.Lemma {F.name;loc} -> Profiling.new_instance_of name f loc accepted | _ -> assert false let profile_produced_terms menv lorig nf s trs = if Options.profiling() then let st0 = List.fold_left (fun st t -> Term.subterms st (Term.apply_subst s t)) Term.Set.empty trs in let name, loc, f = match F.view lorig with | F.Lemma {F.name;main;loc} -> name, loc, main | _ -> assert false in let st1 = F.ground_terms_rec nf in let diff = Term.Set.diff st1 st0 in let info, _ = EM.terms_info menv in let _new = Term.Set.filter (fun t -> not (MT.mem t info)) diff in Profiling.register_produced_terms name loc st0 st1 diff _new let new_facts_for_axiom ~do_syntactic_matching menv uf selector optimized substs accu = List.fold_left (fun acc ({trigger_formula=f; trigger_age=age; trigger_dep=dep; trigger_orig=orig; trigger = tr}, subst_list) -> List.fold_left (fun (env, acc) {sbs = sbs; sty = sty; gen = g; goal = b; s_term_orig = torig; s_lem_orig = lorig} -> (* Here, we'll try to extends subst 's' to conver variables appearing in semantic triggers *) let lem_name = F.name_of_lemma orig in let s = sbs, sty in if debug_fpa () >= 2 then begin fprintf fmt "[IC] try to extend synt sbt %a of ax %a@." (Term.Subst.print Term.print) sbs F.print orig; end; match tr.F.guard with | Some a -> assert false (*guards not supported for TH axioms*) | None when tr.F.semantic == [] && not do_syntactic_matching -> (* pure syntactic insts already generated *) env, acc | None when not (terms_linear_dep env torig) -> if debug_fpa () >= 2 then fprintf fmt "semantic matching failed(1)@."; env, acc | None -> match semantic_matching lem_name tr s env uf optimized with | env, None -> if debug_fpa () >= 2 then fprintf fmt "semantic matching failed(2)@."; env, acc | env, Some sbs -> if debug_fpa () >= 2 then fprintf fmt "semantic matching succeeded:@.%a@." (Term.Subst.print Term.print) (fst sbs); let nf = F.apply_subst sbs f in let accepted = selector nf orig in record_this_instance nf accepted lorig; if accepted then begin let hyp = List.map (fun f -> F.apply_subst sbs f) tr.F.hyp in let p = { F.f = nf; origin_name = F.name_of_lemma lorig; trigger_depth = tr.F.depth; gdist = -1; hdist = -1; nb_reductions = 0; age = 1+(max g age); mf = true; gf = b; lem = Some lorig; from_terms = torig; (* does'nt work if a 'gf' with theory_elim = true was already assumed in the SAT !!! *) theory_elim = false; } in profile_produced_terms menv lorig nf s tr.F.content; let dep = if not (Options.proof() || Options.profiling()) then dep else Ex.union dep (Ex.singleton (Ex.Dep lorig)) in env, (hyp, p, dep) :: acc end else (* instance not 'accepted' *) env, acc ) acc subst_list ) accu substs let syntactic_matching menv env uf selector = let synt_match = MF.fold (fun f th_ax accu -> (* currently, No diff between propagators and case-split axs *) let forms = MF.singleton f (0 (*0 = age *), Ex.empty) in let menv = EM.add_triggers ~backward:Util.Normal menv forms in let res = EM.query menv uf in if debug_fpa () >= 2 then begin let cpt = ref 0 in List.iter (fun (_, l) -> List.iter (fun _ -> incr cpt) l) res; fprintf fmt "syntactic matching of Ax %s: got %d substs@." (F.name_of_lemma f) !cpt end; res:: accu )env.th_axioms [] in {env with syntactic_matching = synt_match} let instantiate ~do_syntactic_matching match_terms env uf selector = if debug_fpa () >= 2 then fprintf fmt "entering IC.instantiate@."; let optimized = ref (SP.empty) in let t_infos, t_subterms = match_terms in let menv = EM.make ~max_t_depth:100 t_infos t_subterms [] in let env = if not do_syntactic_matching then env else syntactic_matching menv env uf selector in let env, insts = List.fold_left (fun accu substs -> new_facts_for_axiom ~do_syntactic_matching menv uf selector optimized substs accu )(env, []) env.syntactic_matching in if debug_fpa () >= 2 then fprintf fmt "IC.instantiate: %d insts generated@." (List.length insts); env, insts let separate_semantic_triggers = let not_theory_const = Hstring.make "not_theory_constant" in let is_theory_const = Hstring.make "is_theory_constant" in let linear_dep = Hstring.make "linear_dependency" in fun th_form -> let {F.triggers} as q = match F.view th_form with F.Lemma q -> q | _ -> assert false in let r_triggers = List.rev_map (fun tr -> (* because sem-triggers will be set by theories *) assert (tr.F.semantic == []); let syn, sem = List.fold_left (fun (syn, sem) t -> match Term.view t with | {Term.f=Symbols.In (lb, ub); xs=[x]} -> syn, (F.Interval (x, lb, ub)) :: sem | {Term.f=Symbols.MapsTo x; xs=[t]} -> syn, (F.MapsTo (x, t)) :: sem | {Term.f=Sy.Name(hs,_); xs=[x]} when Hstring.equal hs not_theory_const -> syn, (F.NotTheoryConst x) :: sem | {Term.f=Sy.Name(hs,_); xs=[x]} when Hstring.equal hs is_theory_const -> syn, (F.IsTheoryConst x) :: sem | {Term.f=Sy.Name(hs,_); xs=[x;y]} when Hstring.equal hs linear_dep -> syn, (F.LinearDependency(x,y)) :: sem | _ -> t::syn, sem )([], []) (List.rev tr.F.content) in {tr with F.content = syn; semantic = sem} )triggers in F.mk_forall q.F.name q.F.loc q.F.binders (List.rev r_triggers) q.F.main (F.id th_form) (Some (q.F.free_v, q.F.free_vty)) let assume_th_elt t th_elt = let {Commands.axiom_kind; th_form; th_name; extends} = th_elt in let kd_str = if axiom_kind == Parsed.Propagator then "Th propagator" else "Th CS" in match extends with | Typed.NIA | Typed.NRA | Typed.FPA -> if EM.unused_context th_form then begin if debug_fpa () >= 2 then fprintf fmt "[IC][Theory %s][%s] %a not in used-context. Ignore@." th_name kd_str F.print th_form; t end else begin let th_form = separate_semantic_triggers th_form in let th_elt = {th_elt with Commands.th_form} in if debug_fpa () >= 2 then fprintf fmt "[IC][Theory %s][%s] %a@." th_name kd_str F.print th_form; assert (not (MF.mem th_form t.th_axioms)); {t with th_axioms = MF.add th_form th_elt t.th_axioms} end | _ -> t let retrieve_used_context {th_axioms} dep = let deps = Ex.formulas_of dep in let used, unused = Formula.Set.fold (fun f ((used, assumed) as acc) -> if MF.mem f th_axioms then f :: used, MF.remove f assumed else acc ) deps ([], th_axioms) in let unused = MF.fold (fun f _ acc -> f::acc) unused [] in used, unused let instantiate ~do_syntactic_matching env uf selector = if Options.timers() then try Timers.exec_timer_start Timers.M_Arith Timers.F_instantiate; let res = instantiate ~do_syntactic_matching env uf selector in Timers.exec_timer_pause Timers.M_Arith Timers.F_instantiate; res with e -> Timers.exec_timer_pause Timers.M_Arith Timers.F_instantiate; raise e else instantiate ~do_syntactic_matching env uf selector end alt-ergo-free-2.0.0/lib/reasoners/arith.ml0000664000175000017500000006425313430774474016177 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Format open Options open Sig module A = Literal module Sy = Symbols module T = Term module Z = Numbers.Z module Q = Numbers.Q let ale = Hstring.make "<=" let alt = Hstring.make "<" let is_mult h = Sy.equal (Sy.Op Sy.Mult) h let mod_symb = Sy.name "@mod" module Type (X:Sig.X) : Polynome.T with type r = X.r = struct include Polynome.Make(struct include X module Ac = Ac.Make(X) let mult v1 v2 = X.ac_embed { distribute = true; h = Sy.Op Sy.Mult; t = X.type_info v1; l = let l2 = match X.ac_extract v1 with | Some {h=h; l=l} when Sy.equal h (Sy.Op Sy.Mult) -> l | _ -> [v1, 1] in Ac.add (Sy.Op Sy.Mult) (v2,1) l2 } end) end module Shostak (X : Sig.X) (P : Polynome.EXTENDED_Polynome with type r = X.r) = struct type t = P.t type r = P.r module Ac = Ac.Make(X) let name = "arith" (*BISECT-IGNORE-BEGIN*) module Debug = struct let solve_aux r1 r2 = if debug_arith () then fprintf fmt "[arith:solve-aux] we solve %a=%a@." X.print r1 X.print r2 let solve_one r1 r2 sbs = if debug_arith () then begin fprintf fmt "[arith:solve-one] solving %a = %a yields:@." X.print r1 X.print r2; let c = ref 0 in List.iter (fun (p,v) -> incr c; fprintf fmt " %d) %a |-> %a@." !c X.print p X.print v) sbs end end (*BISECT-IGNORE-END*) let is_mine_symb sy = let open Sy in match sy with | Int _ | Real _ -> true | Op (Plus | Minus | Mult | Div | Modulo | Float | Fixed | Abs_int | Abs_real | Sqrt_real | Sqrt_real_default | Sqrt_real_excess | Real_of_int | Int_floor | Int_ceil | Max_int | Max_real | Min_int | Min_real | Pow_real_int | Pow_real_real | Integer_log2 | Integer_round) -> true | _ -> false let empty_polynome ty = P.create [] Q.zero ty let is_mine p = match P.is_monomial p with | Some (a,x,b) when Q.equal a Q.one && Q.sign b = 0 -> x | _ -> P.embed p let embed r = match P.extract r with | Some p -> p | _ -> P.create [Q.one, r] Q.zero (X.type_info r) (* t1 % t2 = md <-> c1. 0 <= md ; c2. md < t2 ; c3. exists k. t1 = t2 * k + t ; c4. t2 <> 0 (already checked) *) let mk_modulo md t1 t2 p2 ctx = let zero = T.int "0" in let c1 = A.LT.mk_builtin true ale [zero; md] in let c2 = match P.is_const p2 with | Some n2 -> let an2 = Q.abs n2 in assert (Q.is_int an2); let t2 = T.int (Q.to_string an2) in A.LT.mk_builtin true alt [md; t2] | None -> A.LT.mk_builtin true alt [md; t2] in let k = T.fresh_name Ty.Tint in let t3 = T.make (Sy.Op Sy.Mult) [t2;k] Ty.Tint in let t3 = T.make (Sy.Op Sy.Plus) [t3;md] Ty.Tint in let c3 = A.LT.mk_eq t1 t3 in c3 :: c2 :: c1 :: ctx let mk_euc_division p p2 t1 t2 ctx = match P.to_list p2 with | [], coef_p2 -> let md = T.make (Sy.Op Sy.Modulo) [t1;t2] Ty.Tint in let r, ctx' = X.make md in let rp = P.mult_const (Q.div Q.one coef_p2) (embed r) in P.sub p rp, ctx' @ ctx | _ -> assert false let exact_sqrt_or_Exit q = (* this function is probably not accurate because it works on Z.t to compute eventual exact sqrt *) let c = Q.sign q in if c < 0 then raise Exit; let n = Q.num q in let d = Q.den q in let s_n, _ = Z.sqrt_rem n in assert (Z.sign s_n >= 0); if not (Z.equal (Z.mult s_n s_n) n) then raise Exit; let s_d, _ = Z.sqrt_rem d in assert (Z.sign s_d >= 0); if not (Z.equal (Z.mult s_d s_d) d) then raise Exit; let res = Q.from_zz s_n s_d in assert (Q.equal (Q.mult res res) q); res let default_sqrt_or_Exit q = let c = Q.sign q in if c < 0 then raise Exit; match Q.sqrt_default q with | None -> raise Exit | Some res -> assert (Q.compare (Q.mult res res) q <= 0); res let excess_sqrt_or_Exit q = let c = Q.sign q in if c < 0 then raise Exit; match Q.sqrt_excess q with | None -> raise Exit | Some res -> assert (Q.compare (Q.mult res res) q >= 0); res let mk_partial_interpretation_1 aux_func coef p_acc ty t x = let r_x, ctx_x = X.make x in try match P.to_list (embed r_x) with | [], d -> let d = aux_func d in (* may raise Exit *) P.add_const (Q.mult coef d) p_acc | _ -> raise Exit with Exit -> let a = X.term_embed t in P.add (P.create [coef, a] Q.zero ty) p_acc let mk_partial_interpretation_2 aux_func coef p_acc ty t x y = let px = embed (fst (X.make x)) in let py = embed (fst (X.make y)) in try match P.is_const px, P.is_const py with | Some c_x, Some c_y -> P.add_const (Q.mult coef (aux_func c_x c_y)) p_acc | _ -> P.add (P.create [coef, (X.term_embed t)] Q.zero ty) p_acc with Exit -> P.add (P.create [coef, (X.term_embed t)] Q.zero ty) p_acc let rec mke coef p t ctx = let {T.f = sb ; xs = xs; ty = ty} = T.view t in match sb, xs with | (Sy.Int n | Sy.Real n) , _ -> let c = Q.mult coef (Q.from_string (Hstring.view n)) in P.add_const c p, ctx | Sy.Op Sy.Mult, [t1;t2] -> let p1, ctx = mke coef (empty_polynome ty) t1 ctx in let p2, ctx = mke Q.one (empty_polynome ty) t2 ctx in if Options.no_NLA() && P.is_const p1 == None && P.is_const p2 == None then (* becomes uninterpreted *) let tau = Term.make (Sy.name ~kind:Sy.Ac "@*") [t1; t2] ty in let xtau, ctx' = X.make tau in P.add p (P.create [coef, xtau] Q.zero ty), List.rev_append ctx' ctx else P.add p (P.mult p1 p2), ctx | Sy.Op Sy.Div, [t1;t2] -> let p1, ctx = mke Q.one (empty_polynome ty) t1 ctx in let p2, ctx = mke Q.one (empty_polynome ty) t2 ctx in if Options.no_NLA() && (P.is_const p2 == None || (ty == Ty.Tint && P.is_const p1 == None)) then (* becomes uninterpreted *) let tau = Term.make (Sy.name "@/") [t1; t2] ty in let xtau, ctx' = X.make tau in P.add p (P.create [coef, xtau] Q.zero ty), List.rev_append ctx' ctx else let p3, ctx = try let p, approx = P.div p1 p2 in if approx then mk_euc_division p p2 t1 t2 ctx else p, ctx with Division_by_zero | Polynome.Maybe_zero -> P.create [Q.one, X.term_embed t] Q.zero ty, ctx in P.add p (P.mult_const coef p3), ctx | Sy.Op Sy.Plus , [t1;t2] -> let p2, ctx = mke coef p t2 ctx in mke coef p2 t1 ctx | Sy.Op Sy.Minus , [t1;t2] -> let p2, ctx = mke (Q.minus coef) p t2 ctx in mke coef p2 t1 ctx | Sy.Op Sy.Modulo , [t1;t2] -> let p1, ctx = mke Q.one (empty_polynome ty) t1 ctx in let p2, ctx = mke Q.one (empty_polynome ty) t2 ctx in if Options.no_NLA() && (P.is_const p1 == None || P.is_const p2 == None) then (* becomes uninterpreted *) let tau = Term.make (Sy.name "@%") [t1; t2] ty in let xtau, ctx' = X.make tau in P.add p (P.create [coef, xtau] Q.zero ty), List.rev_append ctx' ctx else let p3, ctx = try P.modulo p1 p2, ctx with e -> let t = T.make mod_symb [t1; t2] Ty.Tint in let ctx = match e with | Division_by_zero | Polynome.Maybe_zero -> ctx | Polynome.Not_a_num -> mk_modulo t t1 t2 p2 ctx | _ -> assert false in P.create [Q.one, X.term_embed t] Q.zero ty, ctx in P.add p (P.mult_const coef p3), ctx (*** : partial handling of some arith/FPA operators **) | Sy.Op Sy.Float, [prec; exp; mode; x] -> let aux_func e = let res, _, _ = Fpa_rounding.float_of_rational prec exp mode e in res in mk_partial_interpretation_1 aux_func coef p ty t x, ctx | Sy.Op Sy.Integer_round, [mode; x] -> let aux_func = Fpa_rounding.round_to_integer mode in mk_partial_interpretation_1 aux_func coef p ty t x, ctx | Sy.Op (Sy.Abs_int | Sy.Abs_real) , [x] -> mk_partial_interpretation_1 Q.abs coef p ty t x, ctx | Sy.Op Sy.Sqrt_real, [x] -> mk_partial_interpretation_1 exact_sqrt_or_Exit coef p ty t x, ctx | Sy.Op Sy.Sqrt_real_default, [x] -> mk_partial_interpretation_1 default_sqrt_or_Exit coef p ty t x, ctx | Sy.Op Sy.Sqrt_real_excess, [x] -> mk_partial_interpretation_1 excess_sqrt_or_Exit coef p ty t x, ctx | Sy.Op Sy.Real_of_int, [x] -> mk_partial_interpretation_1 (fun d -> d) coef p ty t x, ctx | Sy.Op Sy.Int_floor, [x] -> mk_partial_interpretation_1 Q.floor coef p ty t x, ctx | Sy.Op Sy.Int_ceil, [x] -> mk_partial_interpretation_1 Q.ceiling coef p ty t x, ctx | Sy.Op (Sy.Max_int | Sy.Max_real), [x;y] -> let aux_func c d = if Q.compare c d >= 0 then c else d in mk_partial_interpretation_2 aux_func coef p ty t x y, ctx | Sy.Op (Sy.Min_int | Sy.Min_real), [x;y] -> let aux_func c d = if Q.compare c d <= 0 then c else d in mk_partial_interpretation_2 aux_func coef p ty t x y, ctx | Sy.Op Sy.Integer_log2, [x] -> let aux_func q = if Q.compare_to_0 q <= 0 then raise Exit; Q.from_int (Fpa_rounding.integer_log_2 q) in mk_partial_interpretation_1 aux_func coef p ty t x, ctx | Sy.Op Sy.Pow_real_int, [x; y] -> let aux_func (c : Q.t) (d : Q.t) = assert (Q.is_int d); let n = match Z.to_machine_int (Q.to_z d) with | Some n -> n | None -> raise Exit in let sz = Z.numbits (Q.num c) + Z.numbits (Q.den c) in if sz <> 0 && abs n > 100_000 / sz then raise Exit; Q.power c n in mk_partial_interpretation_2 aux_func coef p ty t x y, ctx | Sy.Op Sy.Pow_real_real, [x; y] -> let aux_func (c : Q.t) (d : Q.t) = if not (Q.is_int d) then raise Exit; let n = match Z.to_machine_int (Q.to_z d) with | Some n -> n | None -> raise Exit in let sz = Z.numbits (Q.num c) + Z.numbits (Q.den c) in if sz <> 0 && abs n > 100_000 / sz then raise Exit; Q.power c n in mk_partial_interpretation_2 aux_func coef p ty t x y, ctx | Sy.Op Sy.Fixed, _ -> (* Fixed-Point arithmetic currently not implemented *) assert false (*** : partial handling of some arith/FPA operators **) | _ -> let a, ctx' = X.make t in let ctx = ctx' @ ctx in match P.extract a with | Some p' -> P.add p (P.mult_const coef p'), ctx | _ -> P.add p (P.create [coef, a] Q.zero ty), ctx let make t = Options.tool_req 4 "TR-Arith-Make"; let {T.ty = ty} = T.view t in let p, ctx = mke Q.one (empty_polynome ty) t [] in is_mine p, ctx let rec expand p n acc = assert (n >=0); if n = 0 then acc else expand p (n-1) (p::acc) let unsafe_ac_to_arith {h=sy; l=rl; t=ty} = let mlt = List.fold_left (fun l (r,n) -> expand (embed r)n l) [] rl in List.fold_left P.mult (P.create [] Q.one ty) mlt let rec number_of_vars l = List.fold_left (fun acc (r, n) -> acc + n * nb_vars_in_alien r) 0 l and nb_vars_in_alien r = match P.extract r with | Some p -> let l, _ = P.to_list p in List.fold_left (fun acc (a, x) -> max acc (nb_vars_in_alien x)) 0 l | None -> begin match X.ac_extract r with | Some ac when is_mult ac.h -> number_of_vars ac.l | _ -> 1 end let max_list_ = function | [] -> 0 | [ _, x ] -> nb_vars_in_alien x | (_, x) :: l -> let acc = nb_vars_in_alien x in List.fold_left (fun acc (_, x) -> max acc (nb_vars_in_alien x)) acc l let contains_a_fresh_alien xp = List.exists (fun x -> match X.term_extract x with | Some t, _ -> Term.is_fresh t | _ -> false ) (X.leaves xp) let has_ac p kind = List.exists (fun (_, x) -> match X.ac_extract x with Some ac -> kind ac | _ -> false) (fst (P.to_list p)) let color ac = match ac.l with | [(r, 1)] -> assert false | _ -> let p = unsafe_ac_to_arith ac in if not ac.distribute then if has_ac p (fun ac -> is_mult ac.h) then X.ac_embed ac else is_mine p else let xp = is_mine p in if contains_a_fresh_alien xp then let l, _ = P.to_list p in let mx = max_list_ l in if mx = 0 || mx = 1 || number_of_vars ac.l > mx then is_mine p else X.ac_embed ac else xp let type_info p = P.type_info p module SX = Set.Make(struct type t = r let compare = X.hash_cmp end) let leaves p = P.leaves p let subst x t p = let p = P.subst x (embed t) p in let ty = P.type_info p in let l, c = P.to_list p in let p = List.fold_left (fun p (ai, xi) -> let xi' = X.subst x t xi in let p' = match P.extract xi' with | Some p' -> P.mult_const ai p' | _ -> P.create [ai, xi'] Q.zero ty in P.add p p') (P.create [] c ty) l in is_mine p let compare_mine = P.compare let compare x y = P.compare (embed x) (embed y) let equal p1 p2 = P.equal p1 p2 let hash = P.hash (* symmetric modulo p 131 *) let mod_sym a b = let m = Q.modulo a b in let m = if Q.sign m < 0 then if Q.compare m (Q.minus b) >= 0 then Q.add m b else assert false else if Q.compare m b <= 0 then m else assert false in if Q.compare m (Q.div b (Q.from_int 2)) < 0 then m else Q.sub m b let map_monomes f l ax = List.fold_left (fun acc (a,x) -> let a = f a in if Q.sign a = 0 then acc else (a, x) :: acc) [ax] l let apply_subst sb v = is_mine (List.fold_left (fun v (x, p) -> embed (subst x p v)) v sb) (* substituer toutes variables plus grandes que x *) let subst_bigger x l = List.fold_left (fun (l, sb) (b, y) -> if X.ac_extract y != None && X.str_cmp y x > 0 then let k = X.term_embed (T.fresh_name Ty.Tint) in (b, k) :: l, (y, embed k)::sb else (b, y) :: l, sb) ([], []) l let is_mine_p = List.map (fun (x,p) -> x, is_mine p) let extract_min = function | [] -> assert false | [c] -> c, [] | (a, x) :: s -> List.fold_left (fun ((a, x), l) (b, y) -> if Q.compare (Q.abs a) (Q.abs b) <= 0 then (a, x), ((b, y) :: l) else (b, y), ((a, x):: l)) ((a, x),[]) s (* Decision Procedures. Page 131 *) let rec omega l b = (* 1. choix d'une variable donc le |coef| est minimal *) let (a, x), l = extract_min l in (* 2. substituer les aliens plus grand que x pour assurer l'invariant sur l'ordre AC *) let l, sbs = subst_bigger x l in let p = P.create l b Ty.Tint in assert (Q.sign a <> 0); if Q.equal a Q.one then (* 3.1. si a = 1 alors on a une substitution entiere pour x *) let p = P.mult_const Q.m_one p in (x, is_mine p) :: (is_mine_p sbs) else if Q.equal a Q.m_one then (* 3.2. si a = -1 alors on a une subst entiere pour x*) (x,is_mine p) :: (is_mine_p sbs) else (* 4. sinon, (|a| <> 1) et a <> 0 *) (* 4.1. on rend le coef a positif s'il ne l'est pas deja *) let a, l, b = if Q.sign a < 0 then (Q.minus a, List.map (fun (a,x) -> Q.minus a,x) l, (Q.minus b)) else (a, l, b) in (* 4.2. on reduit le systeme *) omega_sigma sbs a x l b and omega_sigma sbs a x l b = (* 1. on definie m qui vaut a + 1 *) let m = Q.add a Q.one in (* 2. on introduit une variable fraiche *) let sigma = X.term_embed (T.fresh_name Ty.Tint) in (* 3. l'application de la formule (5.63) nous donne la valeur du pivot x*) let mm_sigma = (Q.minus m, sigma) in let l_mod = map_monomes (fun a -> mod_sym a m) l mm_sigma in (* 3.1. Attention au signe de b : on le passe a droite avant de faire mod_sym, d'ou Q.minus *) let b_mod = Q.minus (mod_sym (Q.minus b) m) in let p = P.create l_mod b_mod Ty.Tint in let sbs = (x, p) :: sbs in (* 4. on substitue x par sa valeur dans l'equation de depart. Voir la formule (5.64) *) let p' = P.add (P.mult_const a p) (P.create l b Ty.Tint) in (* 5. on resoud sur l'equation simplifiee *) let sbs2 = solve_int p' in (* 6. on normalise sbs par sbs2 *) let sbs = List.map (fun (x, v) -> x, apply_subst sbs2 v) sbs in (* 7. on supprime les liaisons inutiles de sbs2 et on merge avec sbs *) let sbs2 = List.filter (fun (y, _) -> not (X.equal y sigma)) sbs2 in List.rev_append sbs sbs2 and solve_int p = if P.is_empty p then raise Not_found; let pgcd = P.pgcd_numerators p in let ppmc = P.ppmc_denominators p in let p = P.mult_const (Q.div ppmc pgcd) p in let l, b = P.to_list p in if not (Q.is_int b) then raise Exception.Unsolvable; omega l b let is_null p = if Q.sign (snd (P.separate_constant p)) <> 0 then raise Exception.Unsolvable; [] let solve_int p = try solve_int p with Not_found -> is_null p let solve_real p = try let a, x = P.choose p in let p = P.mult_const (Q.div Q.m_one a) (P.remove x p) in [x, is_mine p] with Not_found -> is_null p let unsafe_ac_to_arith {h=sy; l=rl; t=ty} = let mlt = List.fold_left (fun l (r, n) -> expand (embed r) n l) [] rl in List.fold_left P.mult (P.create [] Q.one ty) mlt let polynome_distribution p unsafe_mode = let l, c = P.to_list p in let ty = P.type_info p in let pp = List.fold_left (fun p (coef, x) -> match X.ac_extract x with | Some ac when is_mult ac.h -> P.add p (P.mult_const coef (unsafe_ac_to_arith ac)) | _ -> P.add p (P.create [coef,x] Q.zero ty) ) (P.create [] c ty) l in if not unsafe_mode && has_ac pp (fun ac -> is_mult ac.h) then p else pp let solve_aux r1 r2 unsafe_mode = Options.tool_req 4 "TR-Arith-Solve"; Debug.solve_aux r1 r2; let p = P.sub (embed r1) (embed r2) in let pp = polynome_distribution p unsafe_mode in let ty = P.type_info p in let sbs = if ty == Ty.Treal then solve_real pp else solve_int pp in let sbs = List.fast_sort (fun (a,_) (x,y) -> X.str_cmp x a)sbs in sbs let apply_subst r l = List.fold_left (fun r (p,v) -> X.subst p v r) r l exception Unsafe let check_pivot_safety p nsbs unsafe_mode = let q = apply_subst p nsbs in if X.equal p q then p else match X.ac_extract p with | Some ac when unsafe_mode -> raise Unsafe | Some ac -> X.ac_embed {ac with distribute = false} | None -> assert false (* p is a leaf and not interpreted *) let triangular_down sbs unsafe_mode = List.fold_right (fun (p,v) nsbs -> (check_pivot_safety p nsbs unsafe_mode, apply_subst v nsbs) :: nsbs) sbs [] let is_non_lin pv = match X.ac_extract pv with | Some {Sig.h} -> is_mult h | _ -> false let make_idemp a b sbs lvs unsafe_mode = let sbs = triangular_down sbs unsafe_mode in let sbs = triangular_down (List.rev sbs) unsafe_mode in (*triangular up*) let sbs = List.filter (fun (p,v) -> SX.mem p lvs || is_non_lin p) sbs in (* This assert is not TRUE because of AC and distributivity of '*' assert (not (Options.enable_assertions ()) || X.equal (apply_subst a sbs) (apply_subst b sbs)); *) List.iter (fun (p, v) -> if not (SX.mem p lvs) then (assert (is_non_lin p); raise Unsafe) )sbs; sbs let solve_one pb r1 r2 lvs unsafe_mode = let sbt = solve_aux r1 r2 unsafe_mode in let sbt = make_idemp r1 r2 sbt lvs unsafe_mode in (*may raise Unsafe*) Debug.solve_one r1 r2 sbt; {pb with sbt = List.rev_append sbt pb.sbt} let solve r1 r2 pb = let lvs = List.fold_right SX.add (X.leaves r1) SX.empty in let lvs = List.fold_right SX.add (X.leaves r2) lvs in try if debug_arith () then fprintf fmt "[arith] Try solving with unsafe mode.@."; solve_one pb r1 r2 lvs true (* true == unsafe mode *) with Unsafe -> try if debug_arith () then fprintf fmt "[arith] Cancel unsafe solving mode. Try safe mode@."; solve_one pb r1 r2 lvs false (* false == safe mode *) with Unsafe -> assert false let make t = if Options.timers() then try Timers.exec_timer_start Timers.M_Arith Timers.F_make; let res = make t in Timers.exec_timer_pause Timers.M_Arith Timers.F_make; res with e -> Timers.exec_timer_pause Timers.M_Arith Timers.F_make; raise e else make t let solve r1 r2 pb = if Options.timers() then try Timers.exec_timer_start Timers.M_Arith Timers.F_solve; let res = solve r1 r2 pb in Timers.exec_timer_pause Timers.M_Arith Timers.F_solve; res with e -> Timers.exec_timer_pause Timers.M_Arith Timers.F_solve; raise e else solve r1 r2 pb let print = P.print let fully_interpreted sb = match sb with | Sy.Op (Sy.Plus | Sy.Minus) -> true | _ -> false let term_extract _ = None, false let abstract_selectors p acc = let p, acc = P.abstract_selectors p acc in is_mine p, acc (* this function is only called when some arithmetic values do not yet appear in IntervalCalculus. Otherwise, the simplex with try to assign a value *) let assign_value = let cpt_int = ref Q.m_one in let cpt_real = ref Q.m_one in let max_constant distincts acc = List.fold_left (fun acc x -> match P.is_const (embed x) with None -> acc | Some c -> Q.max c acc) acc distincts in fun r distincts eq -> if P.is_const (embed r) != None then None else if List.exists (fun (t,x) ->is_mine_symb (Term.view t).Term.f && X.leaves x == []) eq then None else let term_of_cst, cpt = match X.type_info r with | Ty.Tint -> Term.int, cpt_int | Ty.Treal -> Term.real, cpt_real | _ -> assert false in cpt := Q.add Q.one (max_constant distincts !cpt); Some (term_of_cst (Q.to_string !cpt), true) let pprint_const_for_model = let pprint_positive_const c = let num = Q.num c in let den = Q.den c in if Z.is_one den then Z.to_string num else Format.sprintf "(/ %s %s)" (Z.to_string num) (Z.to_string den) in fun r -> match P.is_const (embed r) with | None -> assert false | Some c -> let sg = Q.sign c in if sg = 0 then "0" else if sg > 0 then pprint_positive_const c else Format.sprintf "(- %s)" (pprint_positive_const (Q.abs c)) let choose_adequate_model t r l = if debug_interpretation() then fprintf fmt "[arith] choose_adequate_model for %a@." Term.print t; let l = List.filter (fun (_, r) -> P.is_const (embed r) != None) l in let r = match l with | [] -> (* We do this, because terms of some semantic values created by CS are not created and added to UF *) assert (P.is_const (embed r) != None); r | (_,r)::l -> List.iter (fun (_,x) -> assert (X.equal x r)) l; r in r, pprint_const_for_model r end module Relation = IntervalCalculus.Make alt-ergo-free-2.0.0/lib/reasoners/intervalCalculus.mli0000664000175000017500000000446313430774474020556 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) module Make (X : Sig.X) (Uf : Uf.S with type r = X.r) (P : Polynome.EXTENDED_Polynome with type r = X.r) : Sig.RELATION with type r = X.r and type uf = Uf.t alt-ergo-free-2.0.0/lib/reasoners/bitv.ml0000664000175000017500000006030513430774474016026 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Format open Sig module Sy = Symbols module T = Term type sort_var = A | B | C type tvar = { var : int ; sorte : sort_var } type 'a xterm = Var of tvar | Alien of 'a type 'a alpha_term = { bv : 'a; sz : int; } type 'a simple_term_aux = | Cte of bool | Other of 'a xterm | Ext of 'a xterm * int * int * int (*// id * size * i * j //*) type 'a simple_term = ('a simple_term_aux) alpha_term type 'a abstract = ('a simple_term) list (* for the solver *) type solver_simple_term_aux = | S_Cte of bool | S_Var of tvar type solver_simple_term = solver_simple_term_aux alpha_term module type ALIEN = sig include Sig.X val embed : r abstract -> r val extract : r -> (r abstract) option end module Shostak(X : ALIEN) = struct type t = X.r abstract type r = X.r let name = "bitv" let is_mine_symb = function | Sy.Bitv _ | Sy.Op (Sy.Concat | Sy.Extract) -> true | _ -> false let embed r = match X.extract r with | None -> begin match X.type_info r with | Ty.Tbitv n -> [{bv = Other (Alien r) ; sz = n}] | _ -> assert false end | Some b -> b let err = err_formatter let compare_xterm xt1 xt2 = match xt1,xt2 with | Var v1, Var v2 -> let c1 = compare v1.sorte v2.sorte in if c1 <> 0 then c1 else -(compare v1.var v2.var) (* on inverse le signe : les variables les plus fraiches sont les plus jeunes (petites)*) | Alien t1, Alien t2 -> X.str_cmp t1 t2 | Var v, Alien t -> 1 | Alien t, Var v -> -1 let compare_simple_term st1 st2 = if st1.sz <> st2.sz then st1.sz - st2.sz else begin match st1.bv,st2.bv with | Cte b,Cte b' -> compare b b' | Cte false , _ | _ , Cte true -> -1 | _ , Cte false | Cte true,_ -> 1 | Other t1 , Other t2 -> compare_xterm t1 t2 | _ , Other _ -> -1 | Other _ , _ -> 1 | Ext(t1,s1,i1,_) , Ext(t2,s2,i2,_) -> let c1 = compare s1 s2 in if c1<>0 then c1 else let c2 = compare i1 i2 in if c2 <> 0 then c2 else compare_xterm t1 t2 end module ST_Set = Set.Make ( struct type t = solver_simple_term let compare st1 st2 = if st1.sz <> st2.sz then st1.sz - st2.sz else begin match st1.bv,st2.bv with | S_Cte b, S_Cte b' -> compare b b' | S_Cte false, _ | _, S_Cte true -> -1 | _ , S_Cte false | S_Cte true,_ -> 1 | S_Var v1, S_Var v2 -> let c1 = compare v1.sorte v2.sorte in if c1 <> 0 then c1 else compare v1.var v2.var end end) module Canonizer = struct type term_aux = | I_Cte of bool | I_Other of X.r xterm | I_Ext of term * int * int | I_Comp of term * term and term = term_aux alpha_term (** **) let rec alpha t = match t.bv with |I_Cte _ -> [t] |I_Other _ -> [t] |I_Comp (t1,t2) -> (alpha t1)@(alpha t2) |I_Ext(t',i,j) -> begin match t'.bv with |I_Cte _ -> [{t' with sz = j-i+1}] |I_Other _ -> [t] |I_Ext(t'',k,_) -> alpha {t with bv = I_Ext(t'',i+k,j+k)} |I_Comp(u,v) when j < v.sz -> alpha{t with bv =I_Ext(v,i,j)} |I_Comp(u,v) when i >= v.sz -> alpha{t with bv=I_Ext(u,i-v.sz,j-v.sz)} |I_Comp(u,v) -> (alpha {sz = j-v.sz+1 ; bv = I_Ext(u,0,j-v.sz)}) @(alpha{sz = v.sz-i ; bv = I_Ext(v,i,v.sz-1)}) end (** **) let rec beta lt = let simple_t st = match st.bv with |I_Cte b -> {bv = Cte b ; sz = st.sz} |I_Other x -> {bv = Other x ; sz = st.sz} |I_Ext(t',i,j) -> begin match t'.bv with |I_Other v -> let siz = j-i+1 in {sz=siz ; bv =if siz=t'.sz then Other v else Ext(v,t'.sz,i,j)} |I_Comp _ |I_Ext _ |I_Cte _ -> assert false end |I_Comp(_,_) -> assert false in match lt with |[] -> [] (*on peut passer de 2 elts a 0 elts*) |[s] -> [simple_t s] |s::t::tl' -> begin match s.bv , t.bv with |I_Cte b1,I_Cte b2 when b1=b2 ->beta({s with sz=s.sz+t.sz}::tl') |I_Ext(d1,i,j),I_Ext(d2,k,l) when d1=d2 && l=i-1 -> let tmp = {sz = s.sz + t.sz ; bv = I_Ext(d1,k,j)} in if k=0 then (simple_t tmp)::(beta tl') else beta (tmp::tl') |_ -> (simple_t s)::(beta (t::tl')) end (** **) let sigma term = beta (alpha term) let bitv_to_icomp = List.fold_left (fun ac bt ->{ bv = I_Comp (ac,bt) ; sz = bt.sz + ac.sz }) let string_to_bitv s = let tmp = ref[] in String.iter(fun car -> tmp := (car<>'0',1)::(!tmp)) s; let rec f_aux l acc = match l with | [] -> assert false | [(b,n)] -> { sz = n ; bv = I_Cte b }::acc | (b1,n)::(b2,m)::r when b1 = b2 -> f_aux ((b1,n+m)::r) acc | (b1,n)::(b2,m)::r -> (f_aux ((b2,m)::r)) ({ sz = n ; bv = I_Cte b1 }::acc) in let res = f_aux (!tmp) [] in bitv_to_icomp (List.hd res) (List.tl res) let make t = let rec make_rec t' ctx = match T.view t' with | {T.f = Sy.Bitv s } -> string_to_bitv s, ctx | {T.f = Sy.Op Sy.Concat ; xs = [t1;t2] ; ty = Ty.Tbitv n} -> let r1, ctx = make_rec t1 ctx in let r2, ctx = make_rec t2 ctx in { bv = I_Comp (r1, r2) ; sz = n }, ctx | {T.f = Sy.Op Sy.Extract; xs = [t1;ti;tj] ; ty = Ty.Tbitv n} -> begin match T.view ti , T.view tj with | { T.f = Sy.Int i } , { T.f = Sy.Int j } -> let i = int_of_string (Hstring.view i) in let j = int_of_string (Hstring.view j) in let r1, ctx = make_rec t1 ctx in { sz = j - i + 1 ; bv = I_Ext (r1,i,j)}, ctx | _ -> assert false end | {T.ty = Ty.Tbitv n} -> let r', ctx' = X.make t' in let ctx = ctx' @ ctx in {bv = I_Other (Alien r') ; sz = n}, ctx | _ -> assert false in let r, ctx = make_rec t [] in sigma r, ctx end (*BISECT-IGNORE-BEGIN*) module Debug = struct open Canonizer let print_tvar fmt ({var=v;sorte=s},sz) = fprintf fmt "%s_%d[%d]@?" (match s with | A -> "a" | B -> "b" | C -> "c") v sz let rec print_I_ast fmt ast = match ast.bv with | I_Cte b -> fprintf fmt "%d[%d]@?" (if b then 1 else 0) ast.sz | I_Other (Alien t) -> fprintf fmt "%a[%d]@?" X.print t ast.sz | I_Other (Var tv) -> fprintf fmt "%a@?" print_tvar (tv,ast.sz) | I_Ext (u,i,j) -> fprintf fmt "%a<%d,%d>@?" print_I_ast u i j | I_Comp(u,v) -> fprintf fmt "@[(%a * %a)@]" print_I_ast u print_I_ast v let print fmt ast = match ast.bv with | Cte b -> fprintf fmt "%d[%d]@?" (if b then 1 else 0) ast.sz | Other (Alien t) -> fprintf fmt "%a@?" X.print t | Other (Var tv) -> fprintf fmt "%a@?" print_tvar (tv,ast.sz) | Ext (Alien t,sz,i,j) -> fprintf fmt "%a@?" X.print t; fprintf fmt "<%d,%d>@?" i j | Ext (Var tv,sz,i,j) -> fprintf fmt "%a@?" print_tvar (tv,ast.sz); fprintf fmt "<%d,%d>@?" i j let print_C_ast fmt = function [] -> assert false | x::l -> print fmt x; List.iter (fprintf fmt " @@ %a" print) l let print_s fmt ast = match ast.bv with | S_Cte b -> fprintf fmt "%d[%d]@?" (if b then 1 else 0) ast.sz | S_Var tv -> fprintf fmt "%a@?" print_tvar (tv,ast.sz) let print_S_ast fmt = function [] -> assert false | x::l -> print_s fmt x; List.iter (fprintf fmt " @@ %a" print_s) l let print_sliced_sys fmt l = fprintf fmt "\nSlicing :\n"; List.iter (fun (a,b) -> fprintf fmt " %a == %a\n" print a print b) l let print_c_solve_res fmt l = fprintf fmt "\n(map)c_solve :\n"; List.iter (fun (a,b) -> fprintf fmt " %a == %a\n" print a print_S_ast b) l let print_partition_res fmt l = fprintf fmt "\npartition :\n"; List.iter (fun (t,cte_l) -> fprintf fmt " %a%a \n" print t (fun fmt -> List.iter (fun l' -> fprintf fmt " == %a" print_S_ast l')) cte_l) l let print_final_solution fmt l = fprintf fmt "\nSolution :\n"; List.iter (fun (a,value) -> fprintf fmt " %a = %a \n" print a print_C_ast value ) l; fprintf fmt "@." end (*BISECT-IGNORE-END*) module Solver = struct exception Valid let add elt l = if List.mem elt l then l else elt::l let get_vars = List.fold_left (fun ac st -> match st.bv with |Other v |Ext(v,_,_,_) -> add v ac |_ -> ac )[] let st_slice st siz = let siz_bis = st.sz - siz in match st.bv with |Cte b -> {st with sz = siz},{st with sz = siz_bis} |Other x -> let s1 = Ext(x,st.sz, siz_bis, st.sz - 1) in let s2 = Ext(x,st.sz, 0, siz_bis - 1) in {bv = s1 ; sz = siz},{bv = s2 ; sz = siz_bis} |Ext(x,s,p,q) -> let s1 = Ext(x,s,p+siz_bis,q) in let s2 = Ext(x,s,p,p+siz_bis-1) in {bv = s1 ; sz = siz},{bv = s2 ; sz = siz_bis} let slice t u = let f_add (s1,s2) acc = if (s1 = s2 || List.mem (s1,s2) acc || List.mem (s2,s1) acc) then acc else (s1,s2)::acc in let rec f_rec acc = function |[],[] | _,[] | [],_ -> assert false |[s1],[s2] ->if s1.sz<>s2.sz then assert false else f_add (s1,s2) acc |s1::r1,s2::r2 -> if s1.sz = s2.sz then f_rec (f_add (s1,s2) acc) (r1,r2) else begin if s1.sz > s2.sz then let (s11,s12) = st_slice s1 s2.sz in f_rec (f_add (s11,s2) acc) (s12::r1,r2) else let (s21,s22) = st_slice s2 s1.sz in f_rec (f_add (s1,s21) acc) (r1,s22::r2) end in f_rec [] (t,u) let fresh_var = let cpt = ref 0 in fun t -> incr cpt; { var = !cpt ; sorte = t} let fresh_bitv genre size = if size <= 0 then [] else [ { bv = S_Var (fresh_var genre) ; sz = size } ] let cte_vs_other bol st = st , [{bv = S_Cte bol ; sz = st.sz}] let cte_vs_ext bol xt s_xt i j = let a1 = fresh_bitv A i in let a2 = fresh_bitv A (s_xt - 1 - j) in let cte = [ {bv = S_Cte bol ; sz =j - i + 1 } ] in let var = { bv = Other xt ; sz = s_xt } in var, a2@cte@a1 let other_vs_other st1 st2 = let c = fresh_bitv C st1.sz in [ (st1,c) ; (st2,c) ] let other_vs_ext st xt s_xt i j = let c = fresh_bitv C st.sz in let a1 = fresh_bitv A i in let a2 = fresh_bitv A (s_xt - 1 - j) in let extr = { bv = Other xt ; sz = s_xt } in [ (st,c) ; (extr,a2 @ c @ a1) ] let ext1_vs_ext2 (id,s,i,j) (id',s',i',j') = (* id != id' *) let c = fresh_bitv (C) (j - i + 1) in let a1 = fresh_bitv A i in let a1' = fresh_bitv A i' in let a2 = fresh_bitv A (s - 1 - j) in let a2' = fresh_bitv A (s' - 1 - j') in let x_v = { sz = s ; bv = Other id } in let y_v = { sz = s' ; bv = Other id' } in [ (x_v , a2 @ c @ a1) ; (y_v , a2' @ c @ a1') ] let ext_vs_ext xt siz (i1,i2) tai = let overl = i1 + tai -i2 in if overl <= 0 then begin let a1 = fresh_bitv A i1 in let a2 = fresh_bitv A (-overl) in let a3 = fresh_bitv A (siz - tai - i2) in let b = fresh_bitv B tai in ({ bv = Other xt ; sz = siz } , a3 @ b @ a2 @ b @ a1) end else begin let b_box = i2 + tai - i1 in let nn_overl = tai - overl in(* =i2-i1 >0 sinon egalite sytaxique*) let sz_b1 = b_box mod nn_overl in let a1 = fresh_bitv A i1 in let a3 = fresh_bitv A (siz - tai - i2) in let b1 = fresh_bitv B sz_b1 in let b2 = fresh_bitv B (nn_overl - sz_b1 )in let acc = ref b1 in let cpt = ref nn_overl in while !cpt <= b_box do acc := b1 @ b2 @(!acc); cpt := !cpt + nn_overl done; ({ bv = Other xt ; sz = siz } , a3 @ (!acc) @ a1) end let sys_solve sys = let c_solve (st1,st2) = match st1.bv,st2.bv with |Cte _, Cte _ -> raise Exception.Unsolvable (* forcement un 1 et un 0 *) |Cte b, Other (Var _) -> [cte_vs_other b st2] |Other (Var _), Cte b -> [cte_vs_other b st1] |Cte b, Other (Alien t) -> [cte_vs_other b st2] |Other (Alien t), Cte b -> [cte_vs_other b st1] |Cte b, Ext(xt,s_xt,i,j) -> [cte_vs_ext b xt s_xt i j] |Ext(xt,s_xt,i,j), Cte b -> [cte_vs_ext b xt s_xt i j] |Other _, Other _ -> other_vs_other st1 st2 |Other _, Ext(xt,s_xt,i,j) -> other_vs_ext st1 xt s_xt i j |Ext(xt,s_xt,i,j), Other _ -> other_vs_ext st2 xt s_xt i j |Ext(id,s,i,j), Ext(id',s',i',j') -> if id <> id' then ext1_vs_ext2 (id,s,i,j) (id',s',i',j') else[ext_vs_ext id s (if i [(t,[cnf])] |(t',cnf')::r -> if t = t' then (t',cnf::cnf')::r else (t',cnf')::(add r (t,cnf)) in List.fold_left add [] l let rec slicing_pattern s_l = let rec f_aux l1 l2 = match (l1,l2) with |[],[] -> [] |a::r1,b::r2 when a = b -> a::(f_aux r1 r2) |a::r1,b::r2 -> if a < b then a::(f_aux r1 ((b-a)::r2)) else b::(f_aux ((a-b)::r1) r2) |_ -> assert false in List.fold_left f_aux (List.hd s_l)(List.tl s_l) let slice_var var s1 = let s2 = var.sz - s1 in match var.bv with |S_Cte _ -> {var with sz = s1},{var with sz = s2},None |S_Var v -> let (fs,sn,tr) = match v.sorte with |A -> (fresh_var A), (fresh_var A), A |B -> (fresh_var B), (fresh_var B), B |C -> (fresh_var C), (fresh_var C), C in {bv = S_Var fs; sz = s1},{bv = S_Var sn; sz = s2},Some tr let rec slice_composition eq pat (ac_eq,c_sub) = match (eq,pat) with |[],[] -> (ac_eq,c_sub) |st::_,n::_ when st.sz < n -> assert false |st::comp,n::pt -> if st.sz = n then slice_composition comp pt (st::ac_eq , c_sub) else let (st_n,res,flag) = slice_var st n in begin match flag with |Some B -> let comp' = List.fold_right (fun s_t acc -> if s_t <> st then s_t::acc else st_n::res::acc )comp [] in slice_composition (res::comp') pt (st_n::ac_eq,c_sub) |Some C -> let ac' = (st_n::ac_eq,(st,(st_n,res))::c_sub) in slice_composition (res::comp) pt ac' | _ -> slice_composition (res::comp) pt (st_n::ac_eq,c_sub) end | _ -> assert false let uniforme_slice vls = let pat = slicing_pattern(List.map (List.map(fun bv ->bv.sz))vls) in let rec f_aux acc subs l_vs = match l_vs with |[] -> acc,subs |eq::eqs -> let (eq',c_subs) = slice_composition eq pat ([],[]) in f_aux (List.rev eq'::acc) (c_subs@subs) eqs in f_aux [] [] vls let rec apply_subs subs sys = let rec f_aux = function |[] -> assert false |v::r -> try let (v1,v2) = List.assoc v subs in v1::v2::(f_aux r) with _ -> v::(f_aux r) in List.map (fun (t,vls) ->(t,List.map f_aux vls))sys let equations_slice parts = let rec slice_rec bw = function |[] -> bw |(t,vls)::r -> let (vls',subs) = uniforme_slice vls in if subs =[] then slice_rec ((t,vls')::bw) r else begin let _bw = apply_subs subs bw in let _fw = apply_subs subs r in if _bw = bw then slice_rec ((t,vls')::bw) _fw else slice_rec [] (bw@((t,vls'):: _fw)) end in slice_rec [] parts let rec union_sets sets = let included e1 e2 = try ST_Set.iter (fun at -> if ST_Set.mem at e2 then raise Exit)e1; false with Exit -> true in match sets with |[] -> [] |st::tl -> let (ok,ko) = List.partition (included st) tl in if ok = [] then st::union_sets tl else union_sets ((List.fold_left ST_Set.union st ok)::ko) let rec init_sets vals = let acc = List.map (fun at -> ST_Set.singleton at) (List.hd vals) in let tl = (List.tl vals) in let f_aux = List.map2 (fun ac_e e -> ST_Set.add e ac_e) in List.fold_left f_aux acc tl let equalities_propagation eqs_slic = let init_sets = List.map (fun (t,vls) -> init_sets vls) eqs_slic in let init_sets = List.flatten init_sets in List.map (fun set -> let st1 = ST_Set.min_elt set and st2 = ST_Set.max_elt set in match st1.bv , st2.bv with |S_Cte false, S_Cte true -> raise Exception.Unsolvable |S_Cte false , _ -> st1,set |_ , _ -> st2,set ) (union_sets init_sets) let build_solution unif_slic sets = let get_rep var = fst(List.find ( fun(rep,set)->ST_Set.mem var set ) sets) in let to_external_ast v = {sz = v.sz; bv = match v.bv with |S_Cte b -> Cte b |S_Var _ -> begin match (get_rep v).bv with |S_Cte b -> Cte b |S_Var tv -> Other (Var tv) end }in let rec cnf_max l = match l with |[] -> [] |[elt]-> [elt] |a::b::r -> begin match a.bv,b.bv with |Cte bol,Cte bol' when bol = bol' -> cnf_max ({ b with sz = a.sz + b.sz }::r) | _,Cte _ -> a::(cnf_max (b::r)) | _ -> a::b::(cnf_max r) end in List.map (fun (t,vls) -> t,cnf_max (List.map to_external_ast (List.hd vls)) )unif_slic let solve u v = if u = v then raise Valid else begin let varsU = get_vars u in let varsV = get_vars v in if varsU = [] && varsV = [] then raise Exception.Unsolvable else begin let st_sys = slice u v in let sys_sols = sys_solve st_sys in let parts = partition sys_sols in let unif_slic = equations_slice parts in let eq_pr = equalities_propagation unif_slic in let sol = build_solution unif_slic eq_pr in if Options.debug_bitv () then begin Debug.print_sliced_sys err st_sys; Debug.print_c_solve_res err sys_sols; Debug.print_partition_res err parts; Debug.print_partition_res err unif_slic; Debug.print_final_solution err sol; end; sol end end end let compare_mine b1 b2 = let rec comp l1 l2 = match l1,l2 with [] , [] -> 0 | [] , _ -> -1 | _ , [] -> 1 | st1::l1 , st2::l2 -> let c = compare_simple_term st1 st2 in if c<>0 then c else comp l1 l2 in comp b1 b2 let compare x y = compare (embed x) (embed y) (* should use hashed compare to be faster, not structural comparison *) let equal bv1 bv2 = compare_mine bv1 bv2 = 0 let hash_xterm = function | Var {var = i; sorte = A} -> 11 * i | Var {var = i; sorte = B} -> 17 * i | Var {var = i; sorte = C} -> 19 * i | Alien r -> 23 * X.hash r let hash_simple_term_aux = function | Cte b -> 11 * Hashtbl.hash b | Other x -> 17 * hash_xterm x | Ext (x, a, b, c) -> hash_xterm x + 19 * (a + b + c) let hash l = List.fold_left (fun acc {bv=r; sz=sz} -> acc + 19 * (sz + hash_simple_term_aux r) ) 19 l let leaves bitv = List.fold_left (fun acc x -> match x.bv with | Cte _ -> acc | Ext( Var v,sz,_,_) -> (X.embed [{bv=Other (Var v) ; sz = sz }])::acc | Other (Var _) -> (X.embed [x])::acc | Other (Alien t) | Ext(Alien t,_,_,_) -> (X.leaves t)@acc ) [] bitv let is_mine = function [{bv = Other (Alien r)}] -> r | bv -> X.embed bv let print = Debug.print_C_ast let make t = let r, ctx = Canonizer.make t in is_mine r, ctx let color _ = assert false let type_info bv = let sz = List.fold_left (fun acc bv -> bv.sz + acc) 0 bv in Ty.Tbitv sz let to_i_ast biv = let f_aux st = {sz = st.sz; bv = match st.bv with | Cte b -> Canonizer.I_Cte b | Other tt -> Canonizer.I_Other tt | Ext(tt,siz,i,j) -> let tt' = { sz = siz ; bv = Canonizer.I_Other tt } in Canonizer.I_Ext(tt',i,j) } in List.fold_left (fun acc st -> let tmp = f_aux st in { bv = Canonizer.I_Comp(acc,tmp) ; sz = acc.sz + tmp.sz } ) (f_aux (List.hd biv)) (List.tl biv) let size_of r = match X.type_info r with Ty.Tbitv i -> i | _ -> Format.eprintf "ici=%a@." X.print r; assert false let extract r ty = match X.extract r with Some (u::_ as bv) -> to_i_ast bv | None -> {bv = Canonizer.I_Other (Alien r); sz = ty} | Some [] -> assert false let extract_xterm r = match X.extract r with Some ([{bv=Other(Var _ as x)}]) -> x | None -> Alien r | _ -> assert false let var_or_term x = match x.bv with Other (Var _) -> X.embed [x] | Other (Alien r) -> r | _ -> assert false (* ne resout pas quand c'est deja resolu *) let solve_bis u t = if Options.debug_bitv () then eprintf "[Bitv] solve %a = %a@." X.print u X.print t; match X.extract u , X.extract t with | None , None -> if X.str_cmp u t > 0 then [u,t] else [t,u] | None , Some _ -> [u , t] | Some _ , None -> [t , u] | Some u , Some t -> try List.map (fun (p,v) -> var_or_term p,is_mine v) (Solver.solve u t) with Solver.Valid -> [] let rec subst_rec x subs biv = match biv.bv , extract_xterm x with | Canonizer.I_Cte _ , _ -> biv | Canonizer.I_Other (Var y) , Var z when y=z -> extract subs biv.sz | Canonizer.I_Other (Var _) , _ -> biv | Canonizer.I_Other (Alien tt) , _ -> if X.equal x tt then extract subs biv.sz else extract (X.subst x subs tt) biv.sz | Canonizer.I_Ext (t,i,j) , _ -> { biv with bv = Canonizer.I_Ext(subst_rec x subs t,i,j) } | Canonizer.I_Comp (u,v) , _ -> { biv with bv = Canonizer.I_Comp(subst_rec x subs u ,subst_rec x subs v)} let subst x subs biv = if Options.debug_bitv () then eprintf "[Bitv] subst %a |-> %a in %a@." X.print x X.print subs print biv; if biv = [] then is_mine biv else let r = Canonizer.sigma (subst_rec x subs (to_i_ast biv)) in is_mine r (* module M = Map.Make (struct type t = X.r let compare = X.compare end) module Map = Map.Make (struct type t = (X.r simple_term) list let compare = compare_mine end) module Set = Set.Make ( struct type t = (X.r simple_term) list let compare = compare_mine end) *) let fully_interpreted sb = true let term_extract _ = None, false let abstract_selectors v acc = is_mine v, acc let solve r1 r2 pb = {pb with sbt = List.rev_append (solve_bis r1 r2) pb.sbt} let assign_value _ __ = failwith "[Bitv.assign_value] not implemented for theory Bitv" let choose_adequate_model t l = assert false end module Relation (X : ALIEN) (Uf : Uf.S) = struct type r = X.r type t = unit type uf = Uf.t exception Inconsistent let empty _ = () let assume _ _ _ = (), { assume = []; remove = []} let query _ _ _ = Sig.No let case_split env _ ~for_model = [] let add env _ _ _ = env let print_model _ _ _ = () let new_terms env = T.Set.empty let instantiate ~do_syntactic_matching _ env uf _ = env, [] let retrieve_used_context _ _ = [], [] let assume_th_elt t th_elt = match th_elt.Commands.extends with | Typed.Bitv -> failwith "This Theory does not support theories extension" | _ -> t end alt-ergo-free-2.0.0/lib/reasoners/polynome.ml0000664000175000017500000002506213430774474016725 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Format open Options module Z = Numbers.Z module Q = Numbers.Q exception Not_a_num exception Maybe_zero module type S = sig include Sig.X val mult : r -> r -> r end module type T = sig type r type t val compare : t -> t -> int val equal : t -> t -> bool val hash : t -> int val create : (Q.t * r) list -> Q.t -> Ty.t-> t val add : t -> t -> t val sub : t -> t -> t val mult : t -> t -> t val mult_const : Q.t -> t -> t val add_const : Q.t -> t -> t val div : t -> t -> t * bool val modulo : t -> t -> t val is_const : t -> Q.t option val is_empty : t -> bool val find : r -> t -> Q.t val choose : t -> Q.t * r val subst : r -> t -> t -> t val remove : r -> t -> t val to_list : t -> (Q.t * r) list * Q.t val leaves : t -> r list val print : Format.formatter -> t -> unit val type_info : t -> Ty.t val is_monomial : t -> (Q.t * r * Q.t) option val ppmc_denominators : t -> Q.t val pgcd_numerators : t -> Q.t val normal_form : t -> t * Q.t * Q.t val normal_form_pos : t -> t * Q.t * Q.t val abstract_selectors : t -> (r * r) list -> t * (r * r) list val separate_constant : t -> t * Numbers.Q.t end module type EXTENDED_Polynome = sig include T val extract : r -> t option val embed : t -> r end module Make (X : S) = struct type r = X.r module M : Map.S with type key = r = Map.Make( struct type t = r (*sorted in decreasing order to comply with AC(X) order requirements*) let compare x y = X.str_cmp y x end) type t = { m : Q.t M.t; c : Q.t; ty : Ty.t } let map_to_list m = List.rev (M.fold (fun x a aliens -> (a, x)::aliens) m []) exception Out of int let compare_maps l1 l2 = try List.iter2 (fun (a,x) (b,y) -> let c = X.str_cmp x y in if c <> 0 then raise (Out c); let c = Q.compare a b in if c <> 0 then raise (Out c) )l1 l2; 0 with | Out c -> c | Invalid_argument s -> assert (String.compare s "List.iter2" = 0); List.length l1 - List.length l2 let compare p1 p2 = let c = Ty.compare p1.ty p2.ty in if c <> 0 then c else match M.is_empty p1.m, M.is_empty p2.m with | true , false -> -1 | false, true -> 1 | true , true -> Q.compare p1.c p2.c | false, false -> let c = compare_maps (map_to_list p1.m) (map_to_list p2.m) in if c = 0 then Q.compare p1.c p2.c else c let equal {m=m1; c=c1} {m=m2; c=c2} = Q.equal c1 c2 && M.equal Q.equal m1 m2 let hash p = let h = M.fold (fun k v acc -> 23 * acc + (X.hash k) * Q.hash v )p.m (19 * Q.hash p.c + 17 * Ty.hash p.ty) in abs h (*BISECT-IGNORE-BEGIN*) module Debug = struct let pprint fmt p = let zero = ref true in M.iter (fun x n -> let s, n, op = if Q.equal n Q.one then (if !zero then "" else "+"), "", "" else if Q.equal n Q.m_one then "-", "", "" else if Q.sign n > 0 then (if !zero then "" else "+"), Q.to_string n, "*" else "-", Q.to_string (Q.minus n), "*" in zero := false; fprintf fmt "%s%s%s%a" s n op X.print x ) p.m; let s, n = if Q.sign p.c > 0 then (if !zero then "" else "+"), Q.to_string p.c else if Q.sign p.c < 0 then "-", Q.to_string (Q.minus p.c) else (if !zero then "","0" else "","") in fprintf fmt "%s%s" s n let print fmt p = if Options.term_like_pp () then pprint fmt p else begin M.iter (fun t n -> fprintf fmt "%s*%a " (Q.to_string n) X.print t) p.m; fprintf fmt "%s" (Q.to_string p.c); fprintf fmt " [%a]" Ty.print p.ty end end (*BISECT-IGNORE-END*) let print = Debug.print let is_const p = if M.is_empty p.m then Some p.c else None let find x m = try M.find x m with Not_found -> Q.zero let create l c ty = let m = List.fold_left (fun m (n, x) -> let n' = Q.add n (find x m) in if Q.sign n' = 0 then M.remove x m else M.add x n' m) M.empty l in { m = m; c = c; ty = ty } let add p1 p2 = Options.tool_req 4 "TR-Arith-Poly plus"; let m = M.fold (fun x a m -> let a' = Q.add (find x m) a in if Q.sign a' = 0 then M.remove x m else M.add x a' m) p2.m p1.m in { m = m; c = Q.add p1.c p2.c; ty = p1.ty } let mult_const n p = if Q.sign n = 0 then { m = M.empty; c = Q.zero; ty = p.ty } else { p with m = M.map (Q.mult n) p.m; c = Q.mult n p.c } let add_const n p = {p with c = Q.add p.c n} let mult_monome a x p = let ax = { m = M.add x a M.empty; c = Q.zero; ty = p.ty} in let acx = mult_const p.c ax in let m = M.fold (fun xi ai m -> M.add (X.mult x xi) (Q.mult a ai) m) p.m acx.m in { acx with m = m} let mult p1 p2 = Options.tool_req 4 "TR-Arith-Poly mult"; let p = mult_const p1.c p2 in M.fold (fun x a p -> add (mult_monome a x p2) p) p1.m p let sub p1 p2 = Options.tool_req 4 "TR-Arith-Poly moins"; let m = M.fold (fun x a m -> let a' = Q.sub (find x m) a in if Q.sign a' = 0 then M.remove x m else M.add x a' m) p2.m p1.m in { m = m; c = Q.sub p1.c p2.c; ty = p1.ty } let euc_mod_num c1 c2 = let c = Q.modulo c1 c2 in if Q.sign c < 0 then Q.add c (Q.abs c2) else c let euc_div_num c1 c2 = Q.div (Q.sub c1 (euc_mod_num c1 c2)) c2 let div p1 p2 = Options.tool_req 4 "TR-Arith-Poly div"; if not (M.is_empty p2.m) then raise Maybe_zero; if Q.sign p2.c = 0 then raise Division_by_zero; let p = mult_const (Q.div Q.one p2.c) p1 in match M.is_empty p.m, p.ty with | _ , Ty.Treal -> p, false | true, Ty.Tint -> {p with c = euc_div_num p1.c p2.c}, false | false, Ty.Tint -> p, true (* XXX *) | _ -> assert false let modulo p1 p2 = Options.tool_req 4 "TR-Arith-Poly mod"; if not (M.is_empty p2.m) then raise Maybe_zero; if Q.sign p2.c = 0 then raise Division_by_zero; if not (M.is_empty p1.m) then raise Not_a_num; { p1 with c = euc_mod_num p1.c p2.c } let find x p = M.find x p.m let is_empty p = M.is_empty p.m let choose p = let tn= ref None in (*version I : prend le premier element de la table*) (try M.iter (fun x a -> tn := Some (a, x); raise Exit) p.m with Exit -> ()); (*version II : prend le dernier element de la table i.e. le plus grand M.iter (fun x a -> tn := Some (a, x)) p.m;*) match !tn with Some p -> p | _ -> raise Not_found let subst x p1 p2 = try let a = M.find x p2.m in add (mult_const a p1) { p2 with m = M.remove x p2.m} with Not_found -> p2 let remove x p = { p with m = M.remove x p.m } let to_list p = map_to_list p.m , p.c module SX = Set.Make(struct type t = r let compare = X.hash_cmp end) let xs_of_list sx l = List.fold_left (fun s x -> SX.add x s) sx l let leaves p = let s = M.fold (fun a _ s -> xs_of_list s (X.leaves a)) p.m SX.empty in SX.elements s let type_info p = p.ty let is_monomial p = try M.fold (fun x a r -> match r with | None -> Some (a, x, p.c) | _ -> raise Exit) p.m None with Exit -> None let ppmc_denominators {m=m} = let res = M.fold (fun k c acc -> Z.my_lcm (Q.den c) acc) m Z.one in Q.abs (Q.from_z res) let pgcd_numerators {m=m} = let res = M.fold (fun k c acc -> Z.my_gcd (Q.num c) acc) m Z.zero in Q.abs (Q.from_z res) let normal_form ({ m = m; c = c } as p) = if M.is_empty m then { p with c = Q.zero }, p.c, Q.one else let ppcm = ppmc_denominators p in let pgcd = pgcd_numerators p in let p = mult_const (Q.div ppcm pgcd) p in { p with c = Q.zero }, p.c, (Q.div pgcd ppcm) let normal_form_pos p = let p, c, d = normal_form p in try let a,x = choose p in if Q.sign a > 0 then p, c, d else mult_const Q.m_one p, Q.minus c, Q.minus d with Not_found -> p, c, d let abstract_selectors p acc = let mp, acc = M.fold (fun r i (mp, acc) -> let r, acc = X.abstract_selectors r acc in let mp = try let j = M.find r mp in let k = Q.add i j in if Q.sign k = 0 then M.remove r mp else M.add r k mp with Not_found -> M.add r i mp in mp, acc )p.m (M.empty, acc) in {p with m=mp}, acc let separate_constant t = { t with c = Q.zero}, t.c end alt-ergo-free-2.0.0/lib/reasoners/ac.mli0000664000175000017500000000662613430774474015624 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) module type S = sig (* the type of amalgamated AC semantic values *) type r (* the type of AC semantic values used by the theory *) type t = r Sig.ac (* builds an embeded semantic value from an AC term *) val make : Term.t -> r * Literal.LT.t list (* tells whether the given term is AC*) val is_mine_symb : Symbols.t -> bool (* compares two AC semantic values *) val compare : t -> t -> int (* tests if two values are equal (using tags) *) val equal : t -> t -> bool (* hash function for ac values *) val hash : t -> int (* returns the type infos of the given term *) val type_info : t -> Ty.t (* prints the AC semantic value *) val print : Format.formatter -> t -> unit (* returns the leaves of the given AC semantic value *) val leaves : t -> r list (* replaces the first argument by the second one in the given AC value *) val subst : r -> r -> t -> r (* add flatten the 2nd arg w.r.t HS.t, add it to the given list and compact the result *) val add : Symbols.t -> r * int -> (r * int) list -> (r * int) list val fully_interpreted : Symbols.t -> bool val abstract_selectors : t -> (r * r) list -> r * (r * r) list val compact : (r * int) list -> (r * int) list end module Make (X : Sig.X) : S with type r = X.r alt-ergo-free-2.0.0/lib/reasoners/ccx.mli0000664000175000017500000000715013430774474016007 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Format open Options open Sig open Exception module type S = sig type t type r = Combine.Shostak.r val empty : unit -> t val empty_facts : unit -> r Sig.facts val add_fact : r Sig.facts -> r fact -> unit val add_term : t -> r Sig.facts -> (* acc *) Term.t -> Explanation.t -> t * r Sig.facts val add : t -> r Sig.facts -> (* acc *) Literal.LT.t -> Explanation.t -> t * r Sig.facts val assume_literals : t -> (r Sig.literal * Explanation.t * Sig.lit_origin) list -> r Sig.facts -> t * (r Sig.literal * Explanation.t * Sig.lit_origin) list val case_split : t -> for_model:bool -> (r Literal.view * bool * Sig.lit_origin) list * t val query : t -> Literal.LT.t -> Sig.answer val new_terms : t -> Term.Set.t val class_of : t -> Term.t -> Term.t list val are_equal : t -> Term.t -> Term.t -> added_terms:bool -> Sig.answer val are_distinct : t -> Term.t -> Term.t -> Sig.answer val cl_extract : t -> Term.Set.t list val term_repr : t -> Term.t -> Term.t val print_model : Format.formatter -> t -> unit val get_union_find : t -> Combine.Uf.t val assume_th_elt : t -> Commands.th_elt -> t val theories_instances : do_syntactic_matching:bool -> Matching_types.info Term.Map.t * Term.t list Term.Map.t Term.Subst.t -> t -> (Formula.t -> Formula.t -> bool) -> t * Sig.instances val retrieve_used_context : t -> Explanation.t -> Formula.t list * Formula.t list end module Main : S alt-ergo-free-2.0.0/lib/reasoners/sum.ml0000664000175000017500000003440013430774474015663 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Options open Format open Sig open Exception module Sy = Symbols module T = Term module A = Literal module L = List module Hs = Hstring module Ex = Explanation type 'a abstract = Cons of Hs.t * Ty.t | Alien of 'a module type ALIEN = sig include Sig.X val embed : r abstract -> r val extract : r -> (r abstract) option end module Shostak (X : ALIEN) = struct type t = X.r abstract type r = X.r let name = "Sum" let is_mine_symb = function | Sy.Name(_, Sy.Constructor) -> true | _ -> false let fully_interpreted sb = true let type_info = function | Cons (_, ty) -> ty | Alien x -> X.type_info x let color _ = assert false (*BISECT-IGNORE-BEGIN*) module Debug = struct let print fmt = function | Cons (hs,ty) -> fprintf fmt "%s" (Hs.view hs) | Alien x -> fprintf fmt "%a" X.print x let solve_bis a b = if debug_sum () then fprintf fmt "[Sum] we solve %a = %a@." X.print a X.print b let solve_bis_result res = if debug_sum () then match res with | [p,v] -> fprintf fmt "\twe get: %a |-> %a@." X.print p X.print v | [] -> fprintf fmt "\tthe equation is trivial@." | _ -> assert false let solve_bis_unsolvable () = if debug_sum () then fprintf fmt "\tthe equation is unsolvable@." end (*BISECT-IGNORE-END*) let print = Debug.print let embed r = match X.extract r with | Some c -> c | None -> Alien r let is_mine = function | Alien r -> r | Cons(hs,ty) as c -> X.embed c let compare_mine c1 c2 = match c1 , c2 with | Cons (h1,ty1) , Cons (h2,ty2) -> let n = Hs.compare h1 h2 in if n <> 0 then n else Ty.compare ty1 ty2 | Alien r1, Alien r2 -> X.str_cmp r1 r2 | Alien _ , Cons _ -> 1 | Cons _ , Alien _ -> -1 let compare x y = compare_mine (embed x) (embed y) let equal s1 s2 = match s1, s2 with | Cons (h1,ty1) , Cons (h2,ty2) -> Hs.equal h1 h2 && Ty.equal ty1 ty2 | Alien r1, Alien r2 -> X.equal r1 r2 | Alien _ , Cons _ | Cons _ , Alien _ -> false let hash = function | Cons (h, ty) -> Hstring.hash h + 19 * Ty.hash ty | Alien r -> X.hash r let leaves _ = [] let subst p v c = let cr = is_mine c in if X.equal p cr then v else match c with | Cons(hs,t) -> cr | Alien r -> X.subst p v r let make t = match T.view t with | {T.f=Sy.Name(hs, Sy.Constructor); xs=[];ty=ty} -> is_mine (Cons(hs,ty)), [] | _ -> assert false let solve a b = match embed a, embed b with | Cons(c1,_) , Cons(c2,_) when Hs.equal c1 c2 -> [] | Cons(c1,_) , Cons(c2,_) -> raise Unsolvable | Cons _ , Alien r2 -> [r2,a] | Alien r1 , Cons _ -> [r1,b] | Alien _ , Alien _ -> if X.str_cmp a b > 0 then [a,b] else [b,a] let solve_bis a b = Debug.solve_bis a b; try let res = solve a b in Debug.solve_bis_result res; res with Unsolvable -> Debug.solve_bis_unsolvable (); raise Unsolvable let abstract_selectors v acc = is_mine v, acc let term_extract _ = None, false let solve r1 r2 pb = {pb with sbt = List.rev_append (solve_bis r1 r2) pb.sbt} let solve r1 r2 pb = if Options.timers() then try Timers.exec_timer_start Timers.M_Sum Timers.F_solve; let res = solve r1 r2 pb in Timers.exec_timer_pause Timers.M_Sum Timers.F_solve; res with e -> Timers.exec_timer_pause Timers.M_Sum Timers.F_solve; raise e else solve r1 r2 pb let assign_value r _ _ = (* values of theory sum should be assigned by case_split *) None let choose_adequate_model t r l = let l = List.filter (fun (_, r) -> match embed r with Cons _ -> true | _ -> false) l in let r = match l with | (_,r)::l -> List.iter (fun (_,x) -> assert (X.equal x r)) l; r | [] -> (* We do this, because terms of some semantic values created by CS are not created and added to UF *) match embed r with Cons _ -> r | _ -> assert false in ignore (flush_str_formatter ()); fprintf str_formatter "%a" print (embed r); r, flush_str_formatter () end module Relation (X : ALIEN) (Uf : Uf.S) = struct type r = X.r type uf = Uf.t module Sh = Shostak(X) open Sh exception Not_Cons module Ex = Explanation module MX = Map.Make(struct type t = X.r let compare = X.hash_cmp end) module HSS = Set.Make (struct type t=Hs.t let compare = Hs.compare end) module LR = Literal.Make(struct type t = X.r let compare = X.hash_cmp include X end) type t = { mx : (HSS.t * Ex.t) MX.t; classes : Term.Set.t list; size_splits : Numbers.Q.t } let empty classes = { mx = MX.empty; classes = classes; size_splits = Numbers.Q.one } (*BISECT-IGNORE-BEGIN*) module Debug = struct let assume bol r1 r2 = if debug_sum () then fprintf fmt "[Sum.Rel] we assume %a %s %a@." X.print r1 (if bol then "=" else "<>") X.print r2 let print_env env = if debug_sum () then begin fprintf fmt "--SUM env ---------------------------------@."; MX.iter (fun r (hss, ex) -> fprintf fmt "%a ::= " X.print r; begin match HSS.elements hss with [] -> () | hs :: l -> fprintf fmt " %s" (Hs.view hs); L.iter (fun hs -> fprintf fmt " | %s" (Hs.view hs)) l end; fprintf fmt " : %a@." Ex.print ex; ) env.mx; fprintf fmt "-------------------------------------------@."; end let case_split r r' = if debug_sum () then fprintf fmt "[case-split] %a = %a@." X.print r X.print r' let no_case_split () = if debug_sum () then fprintf fmt "[case-split] sum: nothing@." let add r = if debug_sum () then fprintf fmt "Sum.Rel.add: %a@." X.print r end (*BISECT-IGNORE-END*) let values_of r = match X.type_info r with | Ty.Tsum (_,l) -> Some (List.fold_left (fun st hs -> HSS.add hs st) HSS.empty l) | _ -> None let add_diseq hss sm1 sm2 dep env eqs = match sm1, sm2 with | Alien r , Cons(h,ty) | Cons (h,ty), Alien r -> let enum, ex = try MX.find r env.mx with Not_found -> hss, Ex.empty in let enum = HSS.remove h enum in let ex = Ex.union ex dep in if HSS.is_empty enum then raise (Inconsistent (ex, env.classes)) else let env = { env with mx = MX.add r (enum, ex) env.mx } in if HSS.cardinal enum = 1 then let h' = HSS.choose enum in env, (LSem (LR.mkv_eq r (is_mine (Cons(h',ty)))), ex, Sig.Other)::eqs else env, eqs | Alien r1, Alien r2 -> let enum1,ex1= try MX.find r1 env.mx with Not_found -> hss,Ex.empty in let enum2,ex2= try MX.find r2 env.mx with Not_found -> hss,Ex.empty in let eqs = if HSS.cardinal enum1 = 1 then let ex = Ex.union dep ex1 in let h' = HSS.choose enum1 in let ty = X.type_info r1 in (LSem (LR.mkv_eq r1 (is_mine (Cons(h',ty)))), ex, Sig.Other)::eqs else eqs in let eqs = if HSS.cardinal enum2 = 1 then let ex = Ex.union dep ex2 in let h' = HSS.choose enum2 in let ty = X.type_info r2 in (LSem (LR.mkv_eq r2 (is_mine (Cons(h',ty)))), ex, Sig.Other)::eqs else eqs in env, eqs | _ -> env, eqs let add_eq hss sm1 sm2 dep env eqs = match sm1, sm2 with | Alien r, Cons(h,ty) | Cons (h,ty), Alien r -> let enum, ex = try MX.find r env.mx with Not_found -> hss, Ex.empty in let ex = Ex.union ex dep in if not (HSS.mem h enum) then raise (Inconsistent (ex, env.classes)); {env with mx = MX.add r (HSS.singleton h, ex) env.mx} , eqs | Alien r1, Alien r2 -> let enum1,ex1 = try MX.find r1 env.mx with Not_found -> hss, Ex.empty in let enum2,ex2 = try MX.find r2 env.mx with Not_found -> hss, Ex.empty in let ex = Ex.union dep (Ex.union ex1 ex2) in let diff = HSS.inter enum1 enum2 in if HSS.is_empty diff then raise (Inconsistent (ex, env.classes)); let mx = MX.add r1 (diff, ex) env.mx in let env = {env with mx = MX.add r2 (diff, ex) mx } in if HSS.cardinal diff = 1 then let h' = HSS.choose diff in let ty = X.type_info r1 in env, (LSem (LR.mkv_eq r1 (is_mine (Cons(h',ty)))), ex, Sig.Other)::eqs else env, eqs | _ -> env, eqs let count_splits env la = let nb = List.fold_left (fun nb (_,_,_,i) -> match i with | CS (Th_sum, n) -> Numbers.Q.mult nb n | _ -> nb )env.size_splits la in {env with size_splits = nb} let add_aux env r = Debug.add r; match embed r, values_of r with | Alien r, Some hss -> if MX.mem r env.mx then env else { env with mx = MX.add r (hss, Ex.empty) env.mx } | _ -> env (* needed for models generation because fresh terms are not added with function add *) let add_rec env r = List.fold_left add_aux env (X.leaves r) let assume env uf la = let env = count_splits env la in let classes = Uf.cl_extract uf in let env = { env with classes = classes } in let aux bol r1 r2 dep env eqs = function | None -> env, eqs | Some hss -> Debug.assume bol r1 r2; if bol then add_eq hss (embed r1) (embed r2) dep env eqs else add_diseq hss (embed r1) (embed r2) dep env eqs in Debug.print_env env; let env, eqs = List.fold_left (fun (env,eqs) -> function | A.Eq(r1,r2), _, ex, _ -> (* needed for models generation because fresh terms are not added with function add *) let env = add_rec (add_rec env r1) r2 in aux true r1 r2 ex env eqs (values_of r1) | A.Distinct(false, [r1;r2]), _, ex, _ -> (* needed for models generation because fresh terms are not added with function add *) let env = add_rec (add_rec env r1) r2 in aux false r1 r2 ex env eqs (values_of r1) | _ -> env, eqs ) (env,[]) la in env, { assume = eqs; remove = [] } let add env _ r _ = add_aux env r let case_split env uf ~for_model = let acc = MX.fold (fun r (hss, ex) acc -> let sz = HSS.cardinal hss in if sz = 1 then acc else match acc with | Some (n,r,hs) when n <= sz -> acc | _ -> Some (sz, r, HSS.choose hss) ) env.mx None in match acc with | Some (n,r,hs) -> let n = Numbers.Q.from_int n in if for_model || Numbers.Q.compare (Numbers.Q.mult n env.size_splits) (max_split ()) <= 0 || Numbers.Q.sign (max_split ()) < 0 then let r' = is_mine (Cons(hs,X.type_info r)) in Debug.case_split r r'; [LR.mkv_eq r r', true, CS(Th_sum, n)] else [] | None -> Debug.no_case_split (); [] let query env uf a_ex = try ignore(assume env uf [a_ex]); Sig.No with Inconsistent (expl, classes) -> Sig.Yes (expl, classes) let assume env uf la = if Options.timers() then try Timers.exec_timer_start Timers.M_Sum Timers.F_assume; let res =assume env uf la in Timers.exec_timer_pause Timers.M_Sum Timers.F_assume; res with e -> Timers.exec_timer_pause Timers.M_Sum Timers.F_assume; raise e else assume env uf la let query env uf la = if Options.timers() then try Timers.exec_timer_start Timers.M_Sum Timers.F_query; let res = query env uf la in Timers.exec_timer_pause Timers.M_Sum Timers.F_query; res with e -> Timers.exec_timer_pause Timers.M_Sum Timers.F_query; raise e else query env uf la let print_model _ _ _ = () let new_terms env = Term.Set.empty let instantiate ~do_syntactic_matching _ env uf _ = env, [] let retrieve_used_context _ _ = [], [] let assume_th_elt t th_elt = match th_elt.Commands.extends with | Typed.Sum -> failwith "This Theory does not support theories extension" | _ -> t end alt-ergo-free-2.0.0/lib/reasoners/combine.ml0000664000175000017500000006330713430774474016503 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Format open Options open Sig (*** Combination module of Shostak theories ***) module rec CX : sig include Sig.X val extract1 : r -> X1.t option val embed1 : X1.t -> r val extract2 : r -> X2.t option val embed2 : X2.t -> r val extract3 : r -> X3.t option val embed3 : X3.t -> r val extract4 : r -> X4.t option val embed4 : X4.t -> r val extract5 : r -> X5.t option val embed5 : X5.t -> r end = struct type rview = | Term of Term.t | Ac of AC.t | X1 of X1.t | X2 of X2.t | X3 of X3.t | X4 of X4.t | X5 of X5.t type r = {v : rview ; id : int} (* begin: Hashconsing modules and functions *) module View = struct type elt = r let set_id tag r = { r with id=tag } let hash r = match r.v with | X1 x -> 1 + 8 * X1.hash x | X2 x -> 2 + 8 * X2.hash x | X3 x -> 3 + 8 * X3.hash x | X4 x -> 4 + 8 * X4.hash x | X5 x -> 5 + 8 * X5.hash x | Ac ac -> 7 + 8 * AC.hash ac | Term t -> 6 + 8 * Term.hash t let eq r1 r2 = match r1.v, r2.v with | X1 x, X1 y -> X1.equal x y | X2 x, X2 y -> X2.equal x y | X3 x, X3 y -> X3.equal x y | X4 x, X4 y -> X4.equal x y | X5 x, X5 y -> X5.equal x y | Term x , Term y -> Term.equal x y | Ac x , Ac y -> AC.equal x y | _ -> false let initial_size = 4096 let disable_weaks () = Options.disable_weaks () end module HC = Hconsing.Make(View) let hcons v = HC.make v (* end: Hconsinging modules and functions *) let embed1 x = hcons {v = X1 x; id = -1000 (* dummy *)} let embed2 x = hcons {v = X2 x; id = -1000 (* dummy *)} let embed3 x = hcons {v = X3 x; id = -1000 (* dummy *)} let embed4 x = hcons {v = X4 x; id = -1000 (* dummy *)} let embed5 x = hcons {v = X5 x; id = -1000 (* dummy *)} let ac_embed ({Sig.l = l} as t) = match l with | [] -> assert false | [x, 1] -> x | l -> let sort = List.fast_sort (fun (x,n) (y,m) -> CX.str_cmp x y) in let ac = { t with Sig.l = List.rev (sort l) } in hcons {v = Ac ac; id = -1000 (* dummy *)} let term_embed t = hcons {v = Term t; id = -1000 (* dummy *)} let extract1 = function {v=X1 r} -> Some r | _ -> None let extract2 = function {v=X2 r} -> Some r | _ -> None let extract3 = function {v=X3 r} -> Some r | _ -> None let extract4 = function {v=X4 r} -> Some r | _ -> None let extract5 = function {v=X5 r} -> Some r | _ -> None let ac_extract = function | {v = Ac t} -> Some t | _ -> None let term_extract r = match r.v with | X1 _ -> X1.term_extract r | X2 _ -> X2.term_extract r | X3 _ -> X3.term_extract r | X4 _ -> X4.term_extract r | X5 _ -> X5.term_extract r | Ac _ -> None, false (* SYLVAIN : TODO *) | Term t -> Some t, true let top () = term_embed Term.vrai let bot () = term_embed Term.faux let is_an_eq a = match Literal.LT.view a with Literal.Builtin _ -> false | _ -> true let is_int v = let ty = match v with | X1 x -> X1.type_info x | X2 x -> X2.type_info x | X3 x -> X3.type_info x | X4 x -> X4.type_info x | X5 x -> X5.type_info x | Term t -> (Term.view t).Term.ty | Ac x -> AC.type_info x in ty == Ty.Tint let type_info = function | {v=X1 t} -> X1.type_info t | {v=X2 t} -> X2.type_info t | {v=X3 t} -> X3.type_info t | {v=X4 t} -> X4.type_info t | {v=X5 t} -> X5.type_info t | {v=Ac x} -> AC.type_info x | {v=Term t} -> let {Term.ty = ty} = Term.view t in ty (* Xi < Term < Ac *) let theory_num x = match x with | Ac _ -> -1 | Term _ -> -2 | X1 _ -> -3 | X2 _ -> -4 | X3 _ -> -5 | X4 _ -> -6 | X5 _ -> -7 let compare_tag a b = theory_num a - theory_num b let str_cmp a b = if CX.equal a b then 0 else match a.v, b.v with | X1 x, X1 y -> X1.compare a b | X2 x, X2 y -> X2.compare a b | X3 x, X3 y -> X3.compare a b | X4 x, X4 y -> X4.compare a b | X5 x, X5 y -> X5.compare a b | Term x , Term y -> Term.compare x y | Ac x , Ac y -> AC.compare x y | va, vb -> compare_tag va vb (*** implementations before hash-consing semantic values let equal a b = CX.compare a b = 0 let hash r = match r.v with | Term t -> Term.hash t | Ac x -> AC.hash x | X1 x -> X1.hash x | X2 x -> X2.hash x | X3 x -> X3.hash x | X4 x -> X4.hash x | X5 x -> X5.hash x ***) let equal a b = a.id = b.id let hash v = v.id let hash_cmp a b = a.id - b.id (* should be called hash_cmp and used where structural_compare is not needed let compare a b = let c = Pervasives.compare a.id b.id in let c' = Pervasives.compare b.id a.id in assert ((c = 0 && c' = 0) || (c*c' < 0)); c *) module SX = Set.Make(struct type t = r let compare = CX.hash_cmp end) let leaves r = match r.v with | X1 t -> X1.leaves t | X2 t -> X2.leaves t | X3 t -> X3.leaves t | X4 t -> X4.leaves t | X5 t -> X5.leaves t | Ac t -> r :: (AC.leaves t) | Term _ -> [r] let subst p v r = if equal p v then r else match r.v with | X1 t -> X1.subst p v t | X2 t -> X2.subst p v t | X3 t -> X3.subst p v t | X4 t -> X4.subst p v t | X5 t -> X5.subst p v t | Ac t -> if equal p r then v else AC.subst p v t | Term _ -> if equal p r then v else r let make t = let {Term.f=sb} = Term.view t in match X1.is_mine_symb sb, not (restricted ()) && X2.is_mine_symb sb, not (restricted ()) && X3.is_mine_symb sb, not (restricted ()) && X4.is_mine_symb sb, not (restricted ()) && X5.is_mine_symb sb, AC.is_mine_symb sb with | true , false , false, false, false, false -> X1.make t | false , true , false, false, false, false -> X2.make t | false , false , true , false, false, false -> X3.make t | false , false , false, true , false, false -> X4.make t | false , false , false, false, true , false -> X5.make t | false , false , false, false, false, true -> AC.make t | false , false , false, false, false, false -> term_embed t, [] | _ -> assert false let fully_interpreted sb = match X1.is_mine_symb sb, not (restricted ()) && X2.is_mine_symb sb, not (restricted ()) && X3.is_mine_symb sb, not (restricted ()) && X4.is_mine_symb sb, not (restricted ()) && X5.is_mine_symb sb, AC.is_mine_symb sb with | true , false , false, false, false, false -> X1.fully_interpreted sb | false , true , false, false, false, false -> X2.fully_interpreted sb | false , false , true , false, false, false -> X3.fully_interpreted sb | false , false , false, true , false, false -> X4.fully_interpreted sb | false , false , false, false, true , false -> X5.fully_interpreted sb | false , false , false, false, false, true -> AC.fully_interpreted sb | false , false , false, false, false, false -> false | _ -> assert false let is_solvable_theory_symbol sb = X1.is_mine_symb sb || not (restricted ()) && ((*X2.is_mine_symb sb || print records*) X3.is_mine_symb sb || X4.is_mine_symb sb || X5.is_mine_symb sb)(* || AC.is_mine_symb sb*) let is_a_leaf r = match r.v with | Term _ | Ac _ -> true | _ -> false let color ac = match ac.Sig.l with | [] -> assert false | [r,1] -> r | _ -> match X1.is_mine_symb ac.Sig.h, X2.is_mine_symb ac.Sig.h, X3.is_mine_symb ac.Sig.h, X4.is_mine_symb ac.Sig.h, X5.is_mine_symb ac.Sig.h, AC.is_mine_symb ac.Sig.h with | true , false , false, false, false, false -> X1.color ac | false , true , false, false, false, false -> X2.color ac | false , false , true , false, false, false -> X3.color ac | false , false , false, true , false, false -> X4.color ac | false , false , false, false, true, false -> X5.color ac (*AC.is_mine may say F if Options.no_ac is set to F dynamically *) | _ -> ac_embed ac (*BISECT-IGNORE-BEGIN*) module Debug = struct let print fmt r = if term_like_pp () then match r.v with | X1 t -> fprintf fmt "%a" X1.print t | X2 t -> fprintf fmt "%a" X2.print t | X3 t -> fprintf fmt "%a" X3.print t | X4 t -> fprintf fmt "%a" X4.print t | X5 t -> fprintf fmt "%a" X5.print t | Term t -> fprintf fmt "%a" Term.print t | Ac t -> fprintf fmt "%a" AC.print t else match r.v with | X1 t -> fprintf fmt "X1(%s):[%a]" X1.name X1.print t | X2 t -> fprintf fmt "X2(%s):[%a]" X2.name X2.print t | X3 t -> fprintf fmt "X3(%s):[%a]" X3.name X3.print t | X4 t -> fprintf fmt "X3(%s):[%a]" X4.name X4.print t | X5 t -> fprintf fmt "X3(%s):[%a]" X5.name X5.print t | Term t -> fprintf fmt "FT:[%a]" Term.print t | Ac t -> fprintf fmt "Ac:[%a]" AC.print t let print_sbt msg sbs = if debug_combine () then begin let c = ref 0 in fprintf fmt "%s subst:@." msg; List.iter (fun (p,v) -> incr c; fprintf fmt " %d) %a |-> %a@." !c print p print v) sbs; fprintf fmt "@." end let debug_abstraction_result oa ob a b acc = if debug_combine () then begin fprintf fmt "@.== debug_abstraction_result ==@."; fprintf fmt "@.Initial equaliy: %a = %a@." CX.print oa CX.print ob; fprintf fmt "abstracted equality: %a = %a@." CX.print a CX.print b; fprintf fmt "selectors elimination result:@."; let cpt = ref 0 in List.iter (fun (p,v) -> incr cpt; fprintf fmt "\t(%d) %a |-> %a@." !cpt CX.print p CX.print v )acc; fprintf fmt "@." end let solve_one a b = if debug_combine () then fprintf fmt "solve one %a = %a@." CX.print a CX.print b let debug_abstract_selectors a = if debug_combine () then fprintf fmt "abstract selectors of %a@." CX.print a let assert_have_mem_types tya tyb = assert ( not (Options.enable_assertions()) || if not (Ty.compare tya tyb = 0) then ( fprintf fmt "@.Tya = %a and @.Tyb = %a@.@." Ty.print tya Ty.print tyb; false) else true) let solve a b = if debug_combine () then fprintf fmt "@.[combine] I solve %a = %a:@." print a print b end (*BISECT-IGNORE-END*) let print = Debug.print let abstract_selectors a acc = Debug.debug_abstract_selectors a; match a.v with | X1 a -> X1.abstract_selectors a acc | X2 a -> X2.abstract_selectors a acc | X3 a -> X3.abstract_selectors a acc | X4 a -> X4.abstract_selectors a acc | X5 a -> X5.abstract_selectors a acc | Term _ -> a, acc | Ac a -> AC.abstract_selectors a acc let abstract_equality a b = let aux r acc = match r.v with | Ac ({l=args} as ac) -> let args, acc = List.fold_left (fun (args, acc) (r, i) -> let r, acc = abstract_selectors r acc in (r, i) :: args, acc )([],acc) args in ac_embed {ac with l = AC.compact args}, acc | _ -> abstract_selectors r acc in let a', acc = aux a [] in let b', acc = aux b acc in a', b', acc let apply_subst r l = List.fold_left (fun r (p,v) -> CX.subst p v r) r l let triangular_down sbs = List.fold_right (fun (p,v) nsbs -> (p, apply_subst v nsbs) :: nsbs) sbs [] let make_idemp a b sbs = Debug.print_sbt "Non triangular" sbs; let sbs = triangular_down sbs in let sbs = triangular_down (List.rev sbs) in (* triangular up *) let original = List.fold_right SX.add (CX.leaves a) SX.empty in let original = List.fold_right SX.add (CX.leaves b) original in let sbs = List.filter (fun (p,v) -> match p.v with | Ac _ -> true | Term _ -> SX.mem p original | _ -> assert false )sbs in Debug.print_sbt "Triangular and cleaned" sbs; (* This assert is not TRUE because of AC and distributivity of '*' assert (not (Options.enable_assertions()) || equal (apply_subst a sbs) (apply_subst b sbs)); *) sbs let apply_subst_right r sbt = List.fold_right (fun (p,v)r -> CX.subst p v r) sbt r let merge_sbt sbt1 sbt2 = sbt1 @ sbt2 let solve_uninterpreted r1 r2 pb = (* r1 != r2*) if CX.str_cmp r1 r2 > 0 then { pb with sbt = (r1,r2)::pb.sbt } else { pb with sbt = (r2,r1)::pb.sbt } let rec solve_list pb = match pb.eqs with | [] -> Debug.print_sbt "Should be triangular and cleaned" pb.sbt; pb.sbt | (a,b) :: eqs -> let pb = {pb with eqs=eqs} in Debug.solve_one a b; let ra = apply_subst_right a pb.sbt in let rb = apply_subst_right b pb.sbt in if CX.equal ra rb then solve_list pb else let tya = CX.type_info ra in let tyb = CX.type_info rb in Debug.assert_have_mem_types tya tyb; let pb = match tya with | Ty.Tint | Ty.Treal -> X1.solve ra rb pb | Ty.Trecord _ -> X2.solve ra rb pb | Ty.Tbitv _ -> X3.solve ra rb pb | Ty.Tsum _ -> X5.solve ra rb pb [@ocaml.ppwarning "TODO: a simple way of handling equalities \ with void and unit is to add this case is the solver !"] (*| Ty.Tunit -> pb *) | _ -> solve_uninterpreted ra rb pb in solve_list pb let solve_abstracted oa ob a b sbt = Debug.debug_abstraction_result oa ob a b sbt; let ra = apply_subst_right a sbt in let rb = apply_subst_right b sbt in let sbt' = solve_list { sbt=[] ; eqs=[ra,rb] } in match sbt', sbt with | [], _::_ -> [] (* the original equality was trivial *) | _ -> make_idemp oa ob (List.rev_append sbt sbt') let solve a b = let a', b', acc = abstract_equality a b in let sbs = solve_abstracted a b a' b' acc in List.fast_sort (fun (p1, _) (p2, _) -> let c = CX.str_cmp p2 p1 in assert (c <> 0); c )sbs let assign_value r distincts eq = let opt = match r.v, type_info r with | _, Ty.Tint | _, Ty.Treal -> X1.assign_value r distincts eq | _, Ty.Trecord _ -> X2.assign_value r distincts eq | _, Ty.Tbitv _ -> X3.assign_value r distincts eq | _, Ty.Tfarray _ -> X4.assign_value r distincts eq | _, Ty.Tsum _ -> X5.assign_value r distincts eq | Term t, ty -> if (Term.view t).Term.depth = 1 || List.exists (fun (t,_) -> (Term.view t).Term.depth = 1) eq then None else Some (Term.fresh_name ty, false) (* false <-> not a case-split *) | _ -> assert false in if debug_interpretation() then begin fprintf fmt "[combine] assign value to representative %a : " print r; match opt with | None -> fprintf fmt "None@." | Some(res, is_cs) -> fprintf fmt " %a@." Term.print res end; opt let choose_adequate_model t rep l = let r, pprint = match Term.type_info t with | Ty.Tint | Ty.Treal -> X1.choose_adequate_model t rep l | Ty.Tbitv _ -> X3.choose_adequate_model t rep l | Ty.Tsum _ -> X5.choose_adequate_model t rep l | Ty.Trecord _ -> X2.choose_adequate_model t rep l | Ty.Tfarray _ -> X4.choose_adequate_model t rep l | _ -> let acc = List.fold_left (fun acc (s, r) -> if (Term.view s).Term.depth <= 1 then match acc with | Some(s', r') when Term.compare s' s > 0 -> acc | _ -> Some (s, r) else acc ) None l in let r = match acc with | Some (_,r) -> r | None -> match term_extract rep with | Some t, true when (Term.view t).Term.depth = 1 -> rep | _ -> if debug_interpretation() then begin fprintf fmt "[Combine.choose_adequate_model] "; fprintf fmt "What to choose for term %a with rep %a ??@." Term.print t print rep; List.iter (fun (t, r) -> fprintf fmt " > impossible case: %a -- %a@." Term.print t print r )l; end; assert false in ignore (flush_str_formatter ()); fprintf str_formatter "%a" print r; (* it's a EUF constant *) r, flush_str_formatter () in if debug_interpretation() then fprintf fmt "[combine] %a selected as a model for %a@." print r Term.print t; r, pprint end and TX1 : Polynome.T with type r = CX.r = Arith.Type(CX) and X1 : Sig.SHOSTAK with type t = TX1.t and type r = CX.r = Arith.Shostak (CX) (struct include TX1 let extract = CX.extract1 let embed = CX.embed1 end) and X2 : Sig.SHOSTAK with type r = CX.r and type t = CX.r Records.abstract = Records.Shostak (struct include CX let extract = extract2 let embed = embed2 end) and X3 : Sig.SHOSTAK with type r = CX.r and type t = CX.r Bitv.abstract = Bitv.Shostak (struct include CX let extract = extract3 let embed = embed3 end) and X4 : Sig.SHOSTAK with type r = CX.r and type t = CX.r Arrays.abstract = Arrays.Shostak (struct include CX let extract = extract4 let embed = embed4 end) and X5 : Sig.SHOSTAK with type r = CX.r and type t = CX.r Sum.abstract = Sum.Shostak (struct include CX let extract = extract5 let embed = embed5 end) (* Its signature is not Sig.SHOSTAK because it does not provide a solver *) and AC : Ac.S with type r = CX.r = Ac.Make(CX) (*** Instantiation of Uf.Make and Use.Make with CX ***) module Uf : Uf.S with type r = CX.r = Uf.Make(CX) module Use = Use.Make(CX) (*** Combination module of Relations ***) module Rel1 : Sig.RELATION with type r = CX.r and type uf = Uf.t = Arith.Relation (CX)(Uf) (struct include TX1 let extract = CX.extract1 let embed = CX.embed1 end) module Rel2 : Sig.RELATION with type r = CX.r and type uf = Uf.t = Records.Relation (struct include CX let extract = extract2 let embed = embed2 end)(Uf) module Rel3 : Sig.RELATION with type r = CX.r and type uf = Uf.t = Bitv.Relation (struct include CX let extract = extract3 let embed = embed3 end)(Uf) module Rel4 : Sig.RELATION with type r = CX.r and type uf = Uf.t = Arrays.Relation (struct include CX let extract = extract4 let embed = embed4 end)(Uf) module Rel5 : Sig.RELATION with type r = CX.r and type uf = Uf.t = Sum.Relation (struct include CX let extract = extract5 let embed = embed5 end)(Uf) module Relation : Sig.RELATION with type r = CX.r and type uf = Uf.t = struct type r = CX.r type uf = Uf.t type t = { r1: Rel1.t; r2: Rel2.t; r3: Rel3.t; r4: Rel4.t; r5: Rel5.t; } let empty classes = { r1=Rel1.empty classes; r2=Rel2.empty classes; r3=Rel3.empty classes; r4=Rel4.empty classes; r5=Rel5.empty classes; } let (|@|) l1 l2 = if l1 == [] then l2 else if l2 == [] then l1 else List.rev_append l1 l2 let assume env uf sa = Options.exec_thread_yield (); let env1, { assume = a1; remove = rm1} = Rel1.assume env.r1 uf sa in let env2, { assume = a2; remove = rm2} = Rel2.assume env.r2 uf sa in let env3, { assume = a3; remove = rm3} = Rel3.assume env.r3 uf sa in let env4, { assume = a4; remove = rm4} = Rel4.assume env.r4 uf sa in let env5, { assume = a5; remove = rm5} = Rel5.assume env.r5 uf sa in {r1=env1; r2=env2; r3=env3; r4=env4; r5=env5}, { assume = a1 |@| a2 |@| a3 |@| a4 |@| a5; remove = rm1 |@| rm2 |@| rm3 |@| rm4 |@| rm5;} let assume_th_elt env th_elt = Options.exec_thread_yield (); let env1 = Rel1.assume_th_elt env.r1 th_elt in let env2 = Rel2.assume_th_elt env.r2 th_elt in let env3 = Rel3.assume_th_elt env.r3 th_elt in let env4 = Rel4.assume_th_elt env.r4 th_elt in let env5 = Rel5.assume_th_elt env.r5 th_elt in {r1=env1; r2=env2; r3=env3; r4=env4; r5=env5} let query env uf a = Options.exec_thread_yield (); match Rel1.query env.r1 uf a with | Yes _ as ans -> ans | No -> match Rel2.query env.r2 uf a with | Yes _ as ans -> ans | No -> match Rel3.query env.r3 uf a with | Yes _ as ans -> ans | No -> match Rel4.query env.r4 uf a with | Yes _ as ans -> ans | No -> Rel5.query env.r5 uf a let case_split env uf ~for_model = Options.exec_thread_yield (); let seq1 = Rel1.case_split env.r1 uf for_model in let seq2 = Rel2.case_split env.r2 uf for_model in let seq3 = Rel3.case_split env.r3 uf for_model in let seq4 = Rel4.case_split env.r4 uf for_model in let seq5 = Rel5.case_split env.r5 uf for_model in let l = seq1 |@| seq2 |@| seq3 |@| seq4 |@| seq5 in List.sort (fun (_,_,sz1) (_,_,sz2) -> match sz1, sz2 with | CS(_,sz1), CS(_,sz2) -> Numbers.Q.compare sz1 sz2 | _ -> assert false )l let add env uf r t = Options.exec_thread_yield (); {r1=Rel1.add env.r1 uf r t; r2=Rel2.add env.r2 uf r t; r3=Rel3.add env.r3 uf r t; r4=Rel4.add env.r4 uf r t; r5=Rel5.add env.r5 uf r t; } let instantiate ~do_syntactic_matching t_match env uf selector = Options.exec_thread_yield (); let r1, l1 = Rel1.instantiate ~do_syntactic_matching t_match env.r1 uf selector in let r2, l2 = Rel2.instantiate ~do_syntactic_matching t_match env.r2 uf selector in let r3, l3 = Rel3.instantiate ~do_syntactic_matching t_match env.r3 uf selector in let r4, l4 = Rel4.instantiate ~do_syntactic_matching t_match env.r4 uf selector in let r5, l5 = Rel5.instantiate ~do_syntactic_matching t_match env.r5 uf selector in {r1=r1; r2=r2; r3=r3; r4=r4; r5=r5}, l5 |@| l4 |@| l3 |@| l2 |@| l1 let retrieve_used_context env dep = Options.exec_thread_yield (); let r1, l1 = Rel1.retrieve_used_context env.r1 dep in let r2, l2 = Rel2.retrieve_used_context env.r2 dep in let r3, l3 = Rel3.retrieve_used_context env.r3 dep in let r4, l4 = Rel4.retrieve_used_context env.r4 dep in let r5, l5 = Rel5.retrieve_used_context env.r5 dep in r5 |@| r4 |@| r3 |@| r2 |@| r1, l5 |@| l4 |@| l3 |@| l2 |@| l1 let print_model fmt env rs = Rel1.print_model fmt env.r1 rs; Rel2.print_model fmt env.r2 rs; Rel3.print_model fmt env.r3 rs; Rel4.print_model fmt env.r4 rs; Rel5.print_model fmt env.r5 rs let new_terms env = let t1 = Rel1.new_terms env.r1 in let t2 = Rel2.new_terms env.r2 in let t3 = Rel3.new_terms env.r3 in let t4 = Rel4.new_terms env.r4 in let t5 = Rel5.new_terms env.r5 in Term.Set.union t1 (Term.Set.union t2 (Term.Set.union t3 (Term.Set.union t4 t5))) end module Shostak = CX alt-ergo-free-2.0.0/lib/reasoners/theory.mli0000664000175000017500000000664513430774474016554 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) module type S = sig type t val empty : unit -> t (* the first int is the decision level (dlvl) and the second one is the propagation level (plvl). The facts (first argument) are sorted in decreasing order with respect to (dlvl, plvl) *) val assume : ?ordered:bool -> (Literal.LT.t * Explanation.t * int * int) list -> t -> t * Term.Set.t * int val query : Literal.LT.t -> t -> Sig.answer val class_of : t -> Term.t -> Term.t list val are_equal : t -> Term.t -> Term.t -> add_terms:bool -> Sig.answer val print_model : Format.formatter -> t -> unit val cl_extract : t -> Term.Set.t list val term_repr : t -> Term.t -> Term.t val extract_ground_terms : t -> Term.Set.t val get_real_env : t -> Ccx.Main.t val get_case_split_env : t -> Ccx.Main.t val do_case_split : t -> t * Term.Set.t val add_term : t -> Term.t -> add_in_cs:bool -> t val compute_concrete_model : t -> t val assume_th_elt : t -> Commands.th_elt -> t val theories_instances : do_syntactic_matching:bool -> Matching_types.info Term.Map.t * Term.t list Term.Map.t Term.Subst.t -> t -> (Formula.t -> Formula.t -> bool) -> int -> int -> t * Sig.instances val retrieve_used_context : t -> Explanation.t -> Formula.t list * Formula.t list end module Main : S alt-ergo-free-2.0.0/lib/reasoners/sat_solver.ml0000664000175000017500000000471613430774474017247 0ustar mimi(******************************************************************************) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the license indicated *) (* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) (* present, please contact us to clarify licensing. *) (* *) (******************************************************************************) open Options open Format let current = ref (module Fun_sat : Sat_solver_sig.S) let initialized = ref false let set_current sat = current := sat let load_current_sat () = match sat_plugin () with | "" -> if debug_sat () then eprintf "[Dynlink] Using Fun_sat solver@." | path -> if debug_sat () then eprintf "[Dynlink] Loading the SAT-solver in %s ...@." path; try MyDynlink.loadfile path; if debug_sat () then eprintf "Success !@.@." with | MyDynlink.Error m1 -> if debug_sat() then begin eprintf "[Dynlink] Loading the SAT-solver in plugin \"%s\" failed!@." path; Format.eprintf ">> Failure message: %s@.@." (MyDynlink.error_message m1); end; let prefixed_path = sprintf "%s/%s" Config.pluginsdir path in if debug_sat () then eprintf "[Dynlink] Loading the SAT-solver in %s ... with prefix %s@." path Config.pluginsdir; try MyDynlink.loadfile prefixed_path; if debug_sat () then eprintf "Success !@.@." with | MyDynlink.Error m2 -> if not (debug_sat()) then begin eprintf "[Dynlink] Loading the SAT-solver in plugin \"%s\" failed!@." path; Format.eprintf ">> Failure message: %s@.@." (MyDynlink.error_message m1); end; eprintf "[Dynlink] Trying to load the plugin from \"%s\" failed too!@." prefixed_path; Format.eprintf ">> Failure message: %s@.@." (MyDynlink.error_message m2); exit 1 let get_current () = if not !initialized then begin load_current_sat (); initialized := true; end; !current alt-ergo-free-2.0.0/lib/reasoners/uf.mli0000664000175000017500000000636313430774474015651 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) module type S = sig type t type r val empty : unit -> t val add : t -> Term.t -> t * Literal.LT.t list val mem : t -> Term.t -> bool val find : t -> Term.t -> r * Explanation.t val find_r : t -> r -> r * Explanation.t val union : t -> r -> r -> Explanation.t -> t * (r * (r * r * Explanation.t) list * r) list val distinct : t -> r list -> Explanation.t -> t val are_equal : t -> Term.t -> Term.t -> added_terms:bool -> Sig.answer val are_distinct : t -> Term.t -> Term.t -> Sig.answer val already_distinct : t -> r list -> bool val class_of : t -> Term.t -> Term.t list val rclass_of : t -> r -> Term.Set.t val cl_extract : t -> Term.Set.t list val model : t -> (r * Term.t list * (Term.t * r) list) list * (Term.t list) list val print : Format.formatter -> t -> unit val term_repr : t -> Term.t -> Term.t val make : t -> Term.t -> r (* may raise Not_found *) val is_normalized : t -> r -> bool val assign_next : t -> (r Literal.view * bool * Sig.lit_origin) list * t val output_concrete_model : t -> unit end module Make (X : Sig.X) : S with type r = X.r alt-ergo-free-2.0.0/lib/reasoners/ac.ml0000664000175000017500000002314113430774474015442 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Options open Format module HS = Hstring module Sy = Symbols module type S = sig (* embeded AC semantic values *) type r (* extracted AC semantic values *) type t = r Sig.ac (* builds an embeded semantic value from an AC term *) val make : Term.t -> r * Literal.LT.t list (* tells whether the given term is AC*) val is_mine_symb : Sy.t -> bool (* compares two AC semantic values *) val compare : t -> t -> int (* tests if two values are equal (using tags) *) val equal : t -> t -> bool (* hash function for ac values *) val hash : t -> int (* returns the type infos of the given term *) val type_info : t -> Ty.t (* prints the AC semantic value *) val print : formatter -> t -> unit (* returns the leaves of the given AC semantic value *) val leaves : t -> r list (* replaces the first argument by the second one in the given AC value *) val subst : r -> r -> t -> r (* add flatten the 2nd arg w.r.t HS.t, add it to the given list and compact the result *) val add : Symbols.t -> r * int -> (r * int) list -> (r * int) list val fully_interpreted : Symbols.t -> bool val abstract_selectors : t -> (r * r) list -> r * (r * r) list val compact : (r * int) list -> (r * int) list end module Make (X : Sig.X) = struct open Sig type r = X.r type t = X.r Sig.ac (*BISECT-IGNORE-BEGIN*) module Debug = struct let print_x fmt v = match X.leaves v with | [w] when X.equal v w -> fprintf fmt "%a" X.print v | _ -> fprintf fmt "(%a)" X.print v let rec pr_elt sep fmt (e,n) = assert (n >=0); if n = 0 then () else fprintf fmt "%s%a%a" sep print_x e (pr_elt sep) (e,n-1) let pr_xs sep fmt = function | [] -> assert false | (p,n)::l -> fprintf fmt "%a" print_x p; List.iter (fprintf fmt "%a" (pr_elt sep))((p,n-1)::l) let print fmt {h=h ; l=l} = if Sy.equal h (Sy.Op Sy.Mult) then fprintf fmt "%a" (pr_xs "'*'") l else fprintf fmt "%a(%a)" Sy.print h (pr_xs ",") l let assert_compare a b c1 c2 = assert ( if not (c1 = 0 && c2 = 0 || c1 < 0 && c2 > 0 || c1 > 0 && c2 < 0) then begin fprintf fmt "Ac.compare:@.%a vs @.%a@. = %d@.@." print a print b c1; fprintf fmt "But@."; fprintf fmt "Ac.compare:@.%a vs @.%a@. = %d@.@." print b print a c2; false end else true ) let subst p v tm = if debug_ac () then fprintf fmt "[ac] subst %a by %a in %a@." X.print p X.print v X.print (X.ac_embed tm) end (*BISECT-IGNORE-END*) let print = Debug.print let flatten h (r,m) acc = match X.ac_extract r with | Some ac when Sy.equal ac.h h -> List.fold_left (fun z (e,n) -> (e,m * n) :: z) acc ac.l | _ -> (r,m) :: acc let sort = List.fast_sort (fun (x,n) (y,m) -> X.str_cmp x y) let rev_sort l = List.rev (sort l) let compact xs = let rec f acc = function | [] -> acc | [(x,n)] -> (x,n) :: acc | (x,n) :: (y,m) :: r -> if X.equal x y then f acc ((x,n+m) :: r) else f ((x,n)::acc) ((y,m) :: r) in f [] (sort xs) (* increasing order - f's result in a decreasing order*) let fold_flatten sy f = List.fold_left (fun z (rt,n) -> flatten sy ((f rt),n) z) [] let expand = List.fold_left (fun l (x,n) -> let l= ref l in for i=1 to n do l:=x::!l done; !l) [] let abstract2 sy t r acc = match X.ac_extract r with | Some ac when Sy.equal sy ac.h -> r, acc | None -> r, acc | Some _ -> match Term.view t with | {Term.f=Sy.Name(hs,Sy.Ac) ;xs=xs;ty=ty} -> let aro_sy = Sy.name ("@" ^ (HS.view hs)) in let aro_t = Term.make aro_sy xs ty in let eq = Literal.LT.mk_eq aro_t t in X.term_embed aro_t, eq::acc | {Term.f=Sy.Op Sy.Mult ;xs=xs;ty=ty} -> let aro_sy = Sy.name "@*" in let aro_t = Term.make aro_sy xs ty in let eq = Literal.LT.mk_eq aro_t t in X.term_embed aro_t, eq::acc | {Term.ty=ty} -> let k = Term.fresh_name ty in let eq = Literal.LT.mk_eq k t in X.term_embed k, eq::acc let make t = Timers.exec_timer_start Timers.M_AC Timers.F_make; let x = match Term.view t with | {Term.f= sy; xs=[a;b]; ty=ty} when Sy.is_ac sy -> let ra, ctx1 = X.make a in let rb, ctx2 = X.make b in let ra, ctx = abstract2 sy a ra (ctx1 @ ctx2) in let rb, ctx = abstract2 sy b rb ctx in let rxs = [ ra,1 ; rb,1 ] in X.ac_embed {h=sy; l=compact (fold_flatten sy (fun x -> x) rxs); t=ty; distribute = true}, ctx | _ -> assert false in Timers.exec_timer_pause Timers.M_AC Timers.F_make; x let is_mine_symb sy = Options.no_ac() == false && Sy.is_ac sy let type_info {t=ty} = ty let leaves { l=l } = List.fold_left (fun z (a,_) -> (X.leaves a) @ z)[] l let rec mset_cmp = function | [] , [] -> 0 | [] , _::_ -> -1 | _::_ , [] -> 1 | (a,m)::r , (b,n)::s -> let c = X.str_cmp a b in if c <> 0 then c else let c = m - n in if c <> 0 then c else mset_cmp(r,s) let size = List.fold_left (fun z (rx,n) -> z + n) 0 module SX = Set.Make(struct type t=r let compare = X.str_cmp end) let leaves_list l = let l = List.fold_left (fun acc (x,n) -> let sx = List.fold_right SX.add (X.leaves x) SX.empty in SX.fold (fun lv acc -> (lv, n) :: acc) sx acc ) []l in compact l (* x et y are sorted in a decreasing order *) let compare {h=f ; l=x} {h=g ; l=y} = let c = Sy.compare f g in if c <> 0 then c else let llx = leaves_list x in let lly = leaves_list y in let c = size llx - size lly in if c <> 0 then c else let c = mset_cmp (leaves_list x , leaves_list y) in if c <> 0 then c else mset_cmp (x , y) let compare a b = let c1 = compare a b in let c2 = compare b a in Debug.assert_compare a b c1 c2; c1 (* let mset_compare ord {h=f ; l=x} {h=g ; l=y} = let c = Sy.compare f g in if c <> 0 then c else assert false *) let equal {h=f ; l=lx} {h=g ; l=ly} = Sy.equal f g && try List.for_all2 (fun (x, m) (y, n) -> m = n && X.equal x y) lx ly with Invalid_argument _ -> false let hash {h = f ; l = l; t = t} = let acc = Sy.hash f + 19 * Ty.hash t in abs (List.fold_left (fun acc (x, y) -> acc + 19 * (X.hash x + y)) acc l) let subst p v ({h=h;l=l;t=t} as tm) = Options.exec_thread_yield (); Timers.exec_timer_start Timers.M_AC Timers.F_subst; Debug.subst p v tm; let t = X.color {tm with l=compact (fold_flatten h (X.subst p v) l)} in Timers.exec_timer_pause Timers.M_AC Timers.F_subst; t let add h arg arg_l = Timers.exec_timer_start Timers.M_AC Timers.F_add; let r = compact (flatten h arg arg_l) in Timers.exec_timer_pause Timers.M_AC Timers.F_add; r let fully_interpreted sb = true let abstract_selectors ({l=args} as ac) acc = let args, acc = List.fold_left (fun (args, acc) (r, i) -> let r, acc = X.abstract_selectors r acc in (r, i) :: args, acc )([],acc) args in let xac = X.ac_embed {ac with l = compact args} in xac, acc (* Ne suffit pas. Il faut aussi prevoir le collapse ? *) (*try List.assoc xac acc, acc with Not_found -> let v = X.term_embed (Term.fresh_name ac.t) in v, (xac, v) :: acc*) end alt-ergo-free-2.0.0/lib/reasoners/uf.ml0000664000175000017500000011447513430774474015504 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Format open Options open Exception open Sig module type S = sig type t type r val empty : unit -> t val add : t -> Term.t -> t * Literal.LT.t list val mem : t -> Term.t -> bool val find : t -> Term.t -> r * Explanation.t val find_r : t -> r -> r * Explanation.t val union : t -> r -> r -> Explanation.t -> t * (r * (r * r * Explanation.t) list * r) list val distinct : t -> r list -> Explanation.t -> t val are_equal : t -> Term.t -> Term.t -> added_terms:bool -> Sig.answer val are_distinct : t -> Term.t -> Term.t -> Sig.answer val already_distinct : t -> r list -> bool val class_of : t -> Term.t -> Term.t list val rclass_of : t -> r -> Term.Set.t val cl_extract : t -> Term.Set.t list val model : t -> (r * Term.t list * (Term.t * r) list) list * (Term.t list) list val print : Format.formatter -> t -> unit val term_repr : t -> Term.t -> Term.t val make : t -> Term.t -> r val is_normalized : t -> r -> bool val assign_next : t -> (r Literal.view * bool * Sig.lit_origin) list * t val output_concrete_model : t -> unit end module Make (X : Sig.X) : S with type r = X.r = struct module Ac = Ac.Make(X) module Ex = Explanation module Sy = Symbols module T = Term module MapT = Term.Map module SetT = Term.Set module LX = Literal.Make(struct type t = X.r let compare = X.hash_cmp include X end) module MapL = Emap.Make(LX) module MapX = Map.Make(struct type t = X.r let compare = X.hash_cmp end) module SetX = Set.Make(struct type t = X.r let compare = X.hash_cmp end) module SetXX = Set.Make(struct type t = X.r * X.r let compare (r1, r1') (r2, r2') = let c = X.hash_cmp r1 r2 in if c <> 0 then c else X.hash_cmp r1' r2' end) module SetAc = Set.Make(struct type t = Ac.t let compare = Ac.compare end) module SetRL = Set.Make (struct type t = Ac.t * X.r * Ex.t let compare (ac1,_,_) (ac2,_,_)= Ac.compare ac1 ac2 end) module RS = struct include Map.Make(struct type t = Sy.t let compare = Sy.compare end) let find k m = try find k m with Not_found -> SetRL.empty let add_rule (({h=h},_,_) as rul) mp = add h (SetRL.add rul (find h mp)) mp let remove_rule (({h=h},_,_) as rul) mp = add h (SetRL.remove rul (find h mp)) mp end type r = X.r type t = { (* term -> [t] *) make : r MapT.t; (* representative table *) repr : (r * Ex.t) MapX.t; (* r -> class (of terms) *) classes : SetT.t MapX.t; (*associates each value r with the set of semantical values whose representatives contains r *) gamma : SetX.t MapX.t; (* the disequations map *) neqs: Ex.t MapL.t MapX.t; (*AC rewrite system *) ac_rs : SetRL.t RS.t; } exception Found_term of T.t (* hack: would need an inverse map from semantic values to terms *) let terms_of_distinct env l = match LX.view l with | Literal.Distinct (false, rl) -> let lt = List.fold_left (fun acc r -> try let cl = MapX.find r env.classes in SetT.iter (fun t -> if X.equal (MapT.find t env.make) r then raise (Found_term t)) cl; acc with | Found_term t -> t :: acc | Not_found -> acc) [] rl in let rec distrib = function | x :: r -> (distrib r) @ (List.map (fun y -> SetT.add x (SetT.singleton y)) r) | [] -> [] in distrib lt | _ -> assert false let cl_extract env = if bottom_classes () then let classes = MapX.fold (fun _ cl acc -> cl :: acc) env.classes [] in MapX.fold (fun _ ml acc -> MapL.fold (fun l _ acc -> (terms_of_distinct env l) @ acc) ml acc ) env.neqs classes else [] (*BISECT-IGNORE-BEGIN*) module Debug = struct let rs_print fmt = SetX.iter (fprintf fmt "\t%a@." X.print) let lm_print fmt = MapL.iter (fun k dep -> fprintf fmt "%a %a" LX.print k Ex.print dep) let t_print fmt = SetT.iter (fprintf fmt "%a " T.print) let pmake fmt m = fprintf fmt "[.] map:\n"; MapT.iter (fun t r -> fprintf fmt "%a -> %a\n" T.print t X.print r) m let prepr fmt m = fprintf fmt "------------- UF: Representatives map ----------------@."; MapX.iter (fun r (rr,dep) -> fprintf fmt "%a --> %a %a\n" X.print r X.print rr Ex.print dep) m let prules fmt s = fprintf fmt "------------- UF: AC rewrite rules ----------------------@."; RS.iter (fun k srl -> SetRL.iter (fun (ac,d,dep)-> fprintf fmt "%a ~~> %a %a\n" X.print (X.ac_embed ac) X.print d Ex.print dep )srl )s let pclasses fmt m = fprintf fmt "------------- UF: Class map --------------------------@."; MapX.iter (fun k s -> fprintf fmt "%a -> %a\n" X.print k Term.print_list (SetT.elements s)) m let pgamma fmt m = fprintf fmt "------------- UF: Gamma map --------------------------@."; MapX.iter (fun k s -> fprintf fmt "%a -> \n%a" X.print k rs_print s) m let pneqs fmt m = fprintf fmt "------------- UF: Disequations map--------------------@."; MapX.iter (fun k s -> fprintf fmt "%a -> %a\n" X.print k lm_print s) m let all fmt env = if debug_uf () then begin fprintf fmt "-------------------------------------------------@."; fprintf fmt "%a %a %a %a %a" pmake env.make prepr env.repr prules env.ac_rs pclasses env.classes pneqs env.neqs; fprintf fmt "-------------------------------------------------@." end let lookup_not_found t env = fprintf fmt "Uf: %a Not_found in env@." T.print t; all fmt env let canon_of r rr = if rewriting () && verbose () then fprintf fmt "canon %a = %a@." X.print r X.print rr let init_leaf p = if debug_uf () then fprintf fmt "init_leaf: %a@." X.print p let critical_pair rx ry = if debug_uf () then fprintf fmt "[uf] critical pair: %a = %a@." X.print rx X.print ry let collapse_mult g2 d2 = if debug_ac () then fprintf fmt "[uf] collapse *: %a = %a@." X.print g2 X.print d2 let collapse g2 d2 = if debug_ac () then fprintf fmt "[uf] collapse: %a = %a@." X.print g2 X.print d2 let compose p v g d = if debug_ac () then Format.eprintf "Compose : %a -> %a on %a and %a@." X.print p X.print v Ac.print g X.print d let x_solve rr1 rr2 dep = if debug_uf () then printf "[uf] x-solve: %a = %a %a@." X.print rr1 X.print rr2 Ex.print dep let ac_solve p v dep = if debug_uf () then printf "[uf] ac-solve: %a |-> %a %a@." X.print p X.print v Ex.print dep let ac_x r1 r2 = if debug_uf () then printf "[uf] ac(x): delta (%a) = delta (%a)@." X.print r1 X.print r2 let distinct d = if debug_uf () then fprintf fmt "[uf] distinct %a@." LX.print d let are_distinct t1 t2 = if debug_uf () then printf " [uf] are_distinct %a %a @." T.print t1 T.print t2 let check_inv_repr_normalized = let trace orig = fprintf fmt "[uf.%s] invariant broken when calling %s@." "check_inv_repr_normalized" orig in fun orig repr -> MapX.iter (fun _ (rr, ex) -> List.iter (fun x -> try if not (X.equal x (fst (MapX.find x repr))) then let () = trace orig in assert false with Not_found -> (* all leaves that are in normal form should be in repr ? not AC leaves, which can be created dynamically, not for other, that can be introduced by make and solve*) () )(X.leaves rr) )repr let check_invariants orig env = if Options.enable_assertions() then begin check_inv_repr_normalized orig env.repr; end end (*BISECT-IGNORE-END*) module Env = struct let mem env t = MapT.mem t env.make let lookup_by_t t env = Options.exec_thread_yield (); try MapX.find (MapT.find t env.make) env.repr with Not_found -> Debug.lookup_not_found t env; assert false (*X.make t, Ex.empty*) (* XXXX *) let lookup_by_t___without_failure t env = try MapX.find (MapT.find t env.make) env.repr with Not_found -> fst (X.make t), Ex.empty let lookup_by_r r env = Options.exec_thread_yield (); try MapX.find r env.repr with Not_found -> r, Ex.empty let disjoint_union l_1 l_2 = let rec di_un (l1,c,l2) (l_1,l_2)= Options.exec_thread_yield (); match l_1,l_2 with | [],[] -> l1, c, l2 | l, [] -> di_un (l @ l1,c,l2) ([],[]) | [], l -> di_un (l1,c,l @ l2) ([],[]) | (a,m)::r, (b,n)::s -> let cmp = X.str_cmp a b in if cmp = 0 then if m = n then di_un (l1,(a,m)::c,l2) (r,s) else if m > n then di_un ((a,m-n)::l1,(a,n)::c,l2) (r,s) else di_un (l1,(b,n)::c,(b,n-m)::l2) (r,s) else if cmp > 0 then di_un ((a,m)::l1,c,l2) (r,(b,n)::s) else di_un (l1,c,(b,n)::l2) ((a,m)::r,s) in di_un ([],[],[]) (l_1,l_2) (* Debut : Code pour la mise en forme normale modulo env *) exception List_minus_exn let list_minus l_1 l_2 = let rec di_un l1 l_1 l_2 = match l_1, l_2 with [],[] -> l1 | l, [] -> l @ l1 | [], l -> raise List_minus_exn | (a,m)::r, (b,n)::s -> let cmp = X.str_cmp a b in if cmp = 0 then if m = n then di_un l1 r s else if m > n then di_un ((a,m-n)::l1) r s else raise List_minus_exn else if cmp > 0 then di_un ((a,m)::l1) r ((b,n)::s) else raise List_minus_exn in di_un [] l_1 l_2 let apply_rs r rls = let fp = ref true in let r = ref r in let ex = ref Ex.empty in let rec apply_rule ((p, v, dep) as rul) = let c = Ac.compare !r p in if c = 0 then begin r := {!r with l=[v, 1]}; ex := Ex.union !ex dep end else if c < 0 then raise Exit else try r := {!r with l = Ac.add !r.h (v, 1) (list_minus !r.l p.l)}; ex := Ex.union !ex dep; fp := false; apply_rule rul with List_minus_exn -> () in let rec fixpoint () = Options.exec_thread_yield (); (try SetRL.iter apply_rule rls with Exit -> ()); if !fp then !r, !ex else (fp := true; fixpoint ()) in fixpoint() let filter_leaves r = List.fold_left (fun (p,q) r -> match X.ac_extract r with | None -> SetX.add r p, q | Some ac -> p, SetAc.add ac q )(SetX.empty,SetAc.empty) (X.leaves r) let canon_empty st env = SetX.fold (fun p ((z, ex) as acc) -> let q, ex_q = lookup_by_r p env in if X.equal p q then acc else (p,q)::z, Ex.union ex_q ex) st ([], Ex.empty) let canon_ac st env = SetAc.fold (fun ac (z,ex) -> let rac, ex_ac = apply_rs ac (RS.find ac.h env.ac_rs) in if Ac.compare ac rac = 0 then z, ex else (X.color ac, X.color rac) :: z, Ex.union ex ex_ac) st ([], Ex.empty) let canon_aux rx = List.fold_left (fun r (p,v) -> X.subst p v r) rx let rec canon env r ex_r = let se, sac = filter_leaves r in let subst, ex_subst = canon_empty se env in let subst_ac, ex_ac = canon_ac sac env in (* explications? *) let r2 = canon_aux (canon_aux r subst_ac) subst in let ex_r2 = Ex.union (Ex.union ex_r ex_subst) ex_ac in if X.equal r r2 then r2, ex_r2 else canon env r2 ex_r2 let normal_form env r = let rr, ex = canon env r Ex.empty in Debug.canon_of r rr; rr,ex (* Fin : Code pour la mise en forme normale modulo env *) let find_or_normal_form env r = Options.exec_thread_yield (); try MapX.find r env.repr with Not_found -> normal_form env r let lookup_for_neqs env r = Options.exec_thread_yield (); try MapX.find r env.neqs with Not_found -> MapL.empty let add_to_classes t r classes = MapX.add r (SetT.add t (try MapX.find r classes with Not_found -> SetT.empty)) classes let update_classes c nc classes = let s1 = try MapX.find c classes with Not_found -> SetT.empty in let s2 = try MapX.find nc classes with Not_found -> SetT.empty in MapX.add nc (SetT.union s1 s2) (MapX.remove c classes) let add_to_gamma r c gamma = Options.exec_thread_yield (); List.fold_left (fun gamma x -> let s = try MapX.find x gamma with Not_found -> SetX.empty in MapX.add x (SetX.add r s) gamma) gamma (X.leaves c) let explain_repr_of_distinct dep lit env = let l = match LX.view lit with | Literal.Distinct (false, ([_;_] as args)) -> args | Literal.Pred (r, _) -> [r] | Literal.Distinct (false, _) -> failwith "TODO: only take equal args repr" | _ -> assert false in List.fold_left (fun dep r -> Ex.union dep (snd (find_or_normal_form env r))) dep l (* r1 = r2 => neqs(r1) \uplus neqs(r2) *) let update_neqs r1 r2 dep env = let merge_disjoint_maps l1 ex1 mapl = try let ex2 = MapL.find l1 mapl in Options.tool_req 3 "TR-CCX-Congruence-Conflict"; let ex = Ex.union (Ex.union ex1 ex2) dep in let ex = explain_repr_of_distinct ex l1 env in raise (Inconsistent (ex, cl_extract env)) with Not_found -> (* with the use of explain_repr_of_distinct above, I don't need to propagate dep to ex1 here *) MapL.add l1 ex1 mapl in let nq_r1 = lookup_for_neqs env r1 in let nq_r2 = lookup_for_neqs env r2 in let small, big = if MapL.height nq_r1 < MapL.height nq_r2 then nq_r1, nq_r2 else nq_r2, nq_r1 in let mapl = MapL.fold merge_disjoint_maps small big in MapX.add r2 mapl (MapX.add r1 mapl env.neqs) let init_leaf env p = Debug.init_leaf p; let in_repr = MapX.mem p env.repr in let rp, ex_rp = if in_repr then MapX.find p env.repr else normal_form env p in let mk_env = env.make in let make = match X.term_extract p with | Some t, true when not (MapT.mem t mk_env) -> MapT.add t p mk_env | _ -> mk_env in let env = { env with make = make; repr = if in_repr then env.repr else MapX.add p (rp, ex_rp) env.repr; classes = if MapX.mem p env.classes then env.classes else update_classes p rp env.classes; gamma = if in_repr then env.gamma else add_to_gamma p rp env.gamma ; neqs = if MapX.mem p env.neqs then env.neqs else update_neqs p rp Ex.empty env } in Debug.check_invariants "init_leaf" env; env let init_leaves env v = let env = List.fold_left init_leaf env (X.leaves v) in init_leaf env v let init_new_ac_leaves env mkr = List.fold_left (fun env x -> match X.ac_extract x with | None -> env | Some _ -> if MapX.mem x env.repr then env else init_leaves env x ) env (X.leaves mkr) let init_term env t = let mkr, ctx = X.make t in let rp, ex = normal_form env mkr in let env = {env with make = MapT.add t mkr env.make; repr = MapX.add mkr (rp,ex) env.repr; classes = add_to_classes t rp env.classes; gamma = add_to_gamma mkr rp env.gamma; neqs = if MapX.mem rp env.neqs then env.neqs (* pourquoi ce test *) else MapX.add rp MapL.empty env.neqs} in (init_new_ac_leaves env mkr), ctx let head_cp eqs env pac ({h=h} as ac) v dep = try (*if RS.mem h env.ac_rs then*) SetRL.iter (fun (g, d, dep_rl) -> if X.equal pac (X.ac_embed g) && X.equal v d then () else match disjoint_union ac.l g.l with | _ , [] , _ -> () | l1 , cm , l2 -> let rx = X.color {ac with l = Ac.add h (d,1) l1} in let ry = X.color {g with l = Ac.add h (v,1) l2} in Debug.critical_pair rx ry; if not (X.equal rx ry) then Queue.push (rx, ry, Ex.union dep dep_rl) eqs) (RS.find h env.ac_rs) with Not_found -> assert false let comp_collapse eqs env (p, v, dep) = RS.fold (fun h rls env -> SetRL.fold (fun ((g, d, dep_rl) as rul) env -> Options.exec_thread_yield (); let env = {env with ac_rs = RS.remove_rule rul env.ac_rs} in let gx = X.color g in let g2, ex_g2 = normal_form env (Ac.subst p v g) in let d2, ex_d2 = normal_form env (X.subst p v d) in if X.str_cmp g2 d2 <= 0 then begin Debug.collapse_mult g2 d2; let ex = Ex.union (Ex.union ex_g2 ex_d2) (Ex.union dep_rl dep) in Queue.push (g2, d2, ex) eqs; env end else if X.equal g2 gx then (* compose *) begin Debug.compose p v g d; let ex = Ex.union ex_d2 (Ex.union dep_rl dep) in {env with ac_rs = RS.add_rule (g,d2, ex) env.ac_rs} end else (* collapse *) begin Debug.collapse g2 d2; let ex = Ex.union (Ex.union ex_g2 ex_d2) (Ex.union dep_rl dep) in Queue.push (g2, d2, ex) eqs; env end ) rls env ) env.ac_rs env (* TODO explications: ajout de dep dans ac_rs *) let apply_sigma_ac eqs env ((p, v, dep) as sigma) = match X.ac_extract p with | None -> comp_collapse eqs env sigma | Some r -> let env = {env with ac_rs = RS.add_rule (r, v, dep) env.ac_rs} in let env = comp_collapse eqs env sigma in head_cp eqs env p r v dep; env let update_aux dep set env= SetXX.fold (fun (rr, nrr) env -> { env with neqs = update_neqs rr nrr dep env ; classes = update_classes rr nrr env.classes}) set env (* Patch modudo AC for CC: if p is a leaf different from r and r is AC and reduced by p, then r --> nrr should be added as a PIVOT, not just as TOUCHED by p |-> ... This is required for a correct update of USE *) let update_global_tch global_tch p r nrr ex = if X.equal p r then global_tch else match X.ac_extract r with | None -> global_tch | Some _ -> (r, [r, nrr, ex], nrr) :: global_tch let apply_sigma_uf env (p, v, dep) global_tch = assert (MapX.mem p env.gamma); let use_p = MapX.find p env.gamma in try let env, touched_p, global_tch, neqs_to_up = SetX.fold (fun r ((env, touched_p, global_tch, neqs_to_up) as acc) -> Options.exec_thread_yield (); let rr, ex = MapX.find r env.repr in let nrr = X.subst p v rr in if X.equal rr nrr then acc else let ex = Ex.union ex dep in let env = {env with repr = MapX.add r (nrr, ex) env .repr; gamma = add_to_gamma r nrr env.gamma } in env, (r, nrr, ex)::touched_p, update_global_tch global_tch p r nrr ex, SetXX.add (rr, nrr) neqs_to_up ) use_p (env, [], global_tch, SetXX.empty) in (* Correction : Do not update neqs twice for the same r *) update_aux dep neqs_to_up env, touched_p, global_tch with Not_found -> assert false let up_uf_rs dep env tch = if RS.is_empty env.ac_rs then env, tch else let env, tch, neqs_to_up = MapX.fold (fun r (rr,ex) ((env, tch, neqs_to_up) as acc) -> Options.exec_thread_yield (); let nrr, ex_nrr = normal_form env rr in if X.equal nrr rr then acc else let ex = Ex.union ex ex_nrr in let env = {env with repr = MapX.add r (nrr, ex) env.repr; gamma = add_to_gamma r nrr env.gamma } in let tch = if X.is_a_leaf r then (r,[r, nrr, ex],nrr) :: tch else tch in env, tch, SetXX.add (rr, nrr) neqs_to_up ) env.repr (env, tch, SetXX.empty) in (* Correction : Do not update neqs twice for the same r *) update_aux dep neqs_to_up env, tch let apply_sigma eqs env tch ((p, v, dep) as sigma) = let env = init_leaves env p in let env = init_leaves env v in let env = apply_sigma_ac eqs env sigma in let env, touched_sigma, tch = apply_sigma_uf env sigma tch in up_uf_rs dep env ((p, touched_sigma, v) :: tch) end let add env t = Options.tool_req 3 "TR-UFX-Add"; if MapT.mem t env.make then env, [] else let env, l = Env.init_term env t in Debug.check_invariants "add" env; env, l let ac_solve eqs dep (env, tch) (p, v) = Debug.ac_solve p v dep; let rv, ex_rv = Env.find_or_normal_form env v in if not (X.equal v rv) then begin (* v is not in normal form ==> replay *) Queue.push (p, rv, Ex.union dep ex_rv) eqs; env, tch end else let rp, ex_rp = Env.find_or_normal_form env p in if not (X.equal p rp) then begin (* p is not in normal form ==> replay *) Queue.push (rp, v, Ex.union dep ex_rp) eqs; env, tch end else (* both p and v are in normal form ==> apply subst p |-> v *) Env.apply_sigma eqs env tch (p, v, dep) let x_solve env r1 r2 dep = let rr1, ex_r1 = Env.find_or_normal_form env r1 in let rr2, ex_r2 = Env.find_or_normal_form env r2 in let dep = Ex.union dep (Ex.union ex_r1 ex_r2) in Debug.x_solve rr1 rr2 dep; if X.equal rr1 rr2 then begin Options.tool_req 3 "TR-CCX-Remove"; [], dep (* Remove rule *) end else begin ignore (Env.update_neqs rr1 rr2 dep env); try X.solve rr1 rr2, dep with Unsolvable -> Options.tool_req 3 "TR-CCX-Congruence-Conflict"; raise (Inconsistent (dep, cl_extract env)) end let rec ac_x eqs env tch = if Queue.is_empty eqs then env, tch else let r1, r2, dep = Queue.pop eqs in Debug.ac_x r1 r2; let sbs, dep = x_solve env r1 r2 dep in let env, tch = List.fold_left (ac_solve eqs dep) (env, tch) sbs in if debug_uf () then Debug.all fmt env; ac_x eqs env tch let union env r1 r2 dep = Options.tool_req 3 "TR-UFX-Union"; let equations = Queue.create () in Queue.push (r1,r2, dep) equations; let env, res = ac_x equations env [] in Debug.check_invariants "union" env; env, res let union env r1 r2 dep = if Options.timers() then try Timers.exec_timer_start Timers.M_UF Timers.F_union; let res = union env r1 r2 dep in Timers.exec_timer_pause Timers.M_UF Timers.F_union; res with e -> Timers.exec_timer_pause Timers.M_UF Timers.F_union; raise e else union env r1 r2 dep let rec distinct env rl dep = Debug.all fmt env; let d = LX.mk_distinct false rl in Debug.distinct d; let env, _, newds = List.fold_left (fun (env, mapr, newds) r -> Options.exec_thread_yield (); let rr, ex = Env.find_or_normal_form env r in try let exr = MapX.find rr mapr in Options.tool_req 3 "TR-CCX-Distinct-Conflict"; raise (Inconsistent ((Ex.union ex exr), cl_extract env)) with Not_found -> let uex = Ex.union ex dep in let mdis = try MapX.find rr env.neqs with Not_found -> MapL.empty in let mdis = try MapL.add d (Ex.merge uex (MapL.find d mdis)) mdis with Not_found -> MapL.add d uex mdis in let env = Env.init_leaf env rr in let env = {env with neqs = MapX.add rr mdis env.neqs} in env, MapX.add rr uex mapr, (rr, ex, mapr)::newds ) (env, MapX.empty, []) rl in List.fold_left (fun env (r1, ex1, mapr) -> MapX.fold (fun r2 ex2 env -> let ex = Ex.union ex1 (Ex.union ex2 dep) in try match X.solve r1 r2 with | [a, b] -> if (X.equal a r1 && X.equal b r2) || (X.equal a r2 && X.equal b r1) then env else distinct env [a; b] ex | [] -> Options.tool_req 3 "TR-CCX-Distinct-Conflict"; raise (Inconsistent (ex, cl_extract env)) | _ -> env with Unsolvable -> env) mapr env) env newds let distinct env rl dep = let env = distinct env rl dep in Debug.check_invariants "distinct" env; env let are_equal env t1 t2 ~added_terms = if Term.equal t1 t2 then Sig.Yes (Ex.empty, cl_extract env) else let lookup = if added_terms then Env.lookup_by_t else Env.lookup_by_t___without_failure in let r1, ex_r1 = lookup t1 env in let r2, ex_r2 = lookup t2 env in if X.equal r1 r2 then Yes (Ex.union ex_r1 ex_r2, cl_extract env) else No let are_distinct env t1 t2 = Debug.are_distinct t1 t2; let r1, ex_r1 = Env.lookup_by_t t1 env in let r2, ex_r2 = Env.lookup_by_t t2 env in try ignore (union env r1 r2 (Ex.union ex_r1 ex_r2)); No with Inconsistent (ex, classes) -> Yes (ex, classes) let already_distinct env lr = let d = LX.mk_distinct false lr in try List.iter (fun r -> let mdis = MapX.find r env.neqs in ignore (MapL.find d mdis) ) lr; true with Not_found -> false let mapt_choose m = let r = ref None in (try MapT.iter (fun x rx -> r := Some (x, rx); raise Exit ) m with Exit -> ()); match !r with Some b -> b | _ -> raise Not_found let model env = let eqs = MapX.fold (fun r cl acc -> let l, to_rel = List.fold_left (fun (l, to_rel) t -> let rt = MapT.find t env.make in if complete_model () || T.is_in_model t then if X.equal rt r then l, (t,rt)::to_rel else t::l, (t,rt)::to_rel else l, to_rel ) ([], []) (SetT.elements cl) in (r, l, to_rel)::acc ) env.classes [] in let rec extract_neqs acc makes = try let x, rx = mapt_choose makes in let makes = MapT.remove x makes in let acc = if complete_model () || T.is_in_model x then MapT.fold (fun y ry acc -> if (complete_model () || T.is_in_model y) && (already_distinct env [rx; ry] || already_distinct env [ry; rx]) then [y; x]::acc else acc ) makes acc else acc in extract_neqs acc makes with Not_found -> acc in let neqs = extract_neqs [] env.make in eqs, neqs let find env t = Options.tool_req 3 "TR-UFX-Find"; Env.lookup_by_t t env let find_r = Options.tool_req 3 "TR-UFX-Find"; Env.find_or_normal_form let print = Debug.all let mem = Env.mem let class_of env t = try let rt, _ = MapX.find (MapT.find t env.make) env.repr in MapX.find rt env.classes with Not_found -> SetT.singleton t let rclass_of env r = try MapX.find r env.classes with Not_found -> SetT.empty let term_repr uf t = let st = class_of uf t in SetT.fold (fun s t -> let c = let c = (T.view t).T.depth - (T.view s).T.depth in if c <> 0 then c else T.compare s t in if c > 0 then s else t ) st t let class_of env t = SetT.elements (class_of env t) let empty () = let env = { make = MapT.empty; repr = MapX.empty; classes = MapX.empty; gamma = MapX.empty; neqs = MapX.empty; ac_rs = RS.empty } in let env, _ = add env Term.vrai in let env, _ = add env Term.faux in distinct env [X.top (); X.bot ()] Ex.empty let make uf t = MapT.find t uf.make (*** add wrappers to profile exported functions ***) let add env t = if Options.timers() then try Timers.exec_timer_start Timers.M_UF Timers.F_add_terms; let res = add env t in Timers.exec_timer_pause Timers.M_UF Timers.F_add_terms; res with e -> Timers.exec_timer_pause Timers.M_UF Timers.F_add_terms; raise e else add env t let is_normalized env r = List.for_all (fun x -> try X.equal x (fst (MapX.find x env.repr)) with Not_found -> true) (X.leaves r) let distinct_from_constants rep env = let neqs = try MapX.find rep env.neqs with Not_found -> assert false in MapL.fold (fun lit _ acc -> let contains_rep = ref false in let lit_vals = match LX.view lit with | Literal.Distinct (_, l) -> l | _ -> [] in let acc2 = List.fold_left (fun acc r -> if X.equal rep r then contains_rep := true; match X.leaves r with | [] -> r::acc | _ -> acc )acc lit_vals in if !contains_rep then acc2 else acc )neqs [] let assign_next env = let acc = ref None in let res, env = try MapX.iter (fun r eclass -> let eclass = try SetT.fold (fun t z -> (t, MapT.find t env.make)::z) eclass [] with Not_found -> assert false in let opt = X.assign_value r (distinct_from_constants r env) eclass in match opt with | None -> () | Some (s, is_cs) -> acc := Some (s, r, is_cs); raise Exit )env.classes; [], env (* no cs *) with Exit -> match !acc with | None -> assert false | Some (s, rep, is_cs) -> if Options.debug_interpretation() then fprintf fmt "TRY assign-next %a = %a@." X.print rep Term.print s; (* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! modify this to be able to returns CS on terms. This way, we will not modify env in this function !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *) let env, _ = add env s in (* important for termination *) let eq = LX.view (LX.mk_eq rep (make env s)) in [eq, is_cs, Sig.CS (Sig.Th_UF, Numbers.Q.one)], env in Debug.check_invariants "assign_next" env; res, env module Profile = struct module P = Map.Make (struct type t = Sy.t * Ty.t list * Ty.t let (|||) c1 c2 = if c1 <> 0 then c1 else c2 let compare (a1, b1, c1) (a2, b2, c2) = let l1_l2 = List.length b1 - List.length b2 in let c = l1_l2 ||| (Ty.compare c1 c2) ||| (Sy.compare a1 a2) in if c <> 0 then c else let c = ref 0 in try List.iter2 (fun ty1 ty2 -> let d = Ty.compare ty1 ty2 in if d <> 0 then begin c := d; raise Exit end ) b1 b2; 0 with | Exit -> assert (!c <> 0); !c | Invalid_argument _ -> assert false end) module V = Set.Make (struct type t = (T.t * (X.r * string)) list * (X.r * string) let compare (l1, (v1,_)) (l2, (v2,_)) = let c = X.hash_cmp v1 v2 in if c <> 0 then c else let c = ref 0 in try List.iter2 (fun (_,(x,_)) (_,(y,_)) -> let d = X.hash_cmp x y in if d <> 0 then begin c := d; raise Exit end ) l1 l2; !c with | Exit -> !c | Invalid_argument _ -> List.length l1 - List.length l2 end) type t = V.t P.t let add p v mp = let prof_p = try P.find p mp with Not_found -> V.empty in if V.mem v prof_p then mp else P.add p (V.add v prof_p) mp let iter = P.iter let empty = P.empty let is_empty = P.is_empty end let assert_has_depth_one (e, _) = match X.term_extract e with | Some t, true -> assert ((T.view t).T.depth = 1); | _ -> () module SMT2LikeModelOutput = struct let x_print fmt (rep , ppr) = fprintf fmt "%s" ppr let print_args fmt l = match l with | [] -> assert false | [t,e] -> fprintf fmt "%a" x_print e; | (t,e) :: l -> fprintf fmt "%a" x_print e; List.iter (fun (t, e) -> fprintf fmt " %a" x_print e) l let print_symb ty fmt f = match f, ty with | Sy.Op Sy.Record, Ty.Trecord {Ty.name} -> fprintf fmt "%a__%s" Sy.print f (Hstring.view name) | _ -> Sy.print fmt f let output_constants_model cprofs = (*printf "; constants:@.";*) Profile.iter (fun (f, xs_ty, ty) st -> match Profile.V.elements st with | [[], rep] -> (*printf " (%a %a) ; %a@." (print_symb ty) f x_print rep Ty.print ty*) printf " (%a %a)@." (print_symb ty) f x_print rep | _ -> assert false )cprofs let output_functions_model fprofs = if not (Profile.is_empty fprofs) then printf "@."; (*printf "@.; functions:@.";*) Profile.iter (fun (f, xs_ty, ty) st -> (*printf " ; fun %a : %a -> %a@." (print_symb ty) f Ty.print_list xs_ty Ty.print ty;*) Profile.V.iter (fun (xs, rep) -> printf " ((%a %a) %a)@." (print_symb ty) f print_args xs x_print rep; List.iter (fun (_,x) -> assert_has_depth_one x) xs; )st; printf "@." ) fprofs let output_arrays_model arrays = (*printf "; arrays:@.";*) Profile.iter (fun (f, xs_ty, ty) st -> match xs_ty with [tyi] -> (*printf " ; array %a : %a -> %a@." (print_symb ty) f Ty.print tyi Ty.print ty;*) Profile.V.iter (fun (xs, rep) -> printf " ((%a %a) %a)@." (print_symb ty) f print_args xs x_print rep; List.iter (fun (_,x) -> assert_has_depth_one x) xs; )st; printf "@." | _ -> assert false ) arrays end (* of module SMT2LikeModelOutput *) let is_a_good_model_value (x, _) = match X.leaves x with [] -> true | [y] -> X.equal x y | _ -> false let model_repr_of_term t env mrepr = try MapT.find t mrepr, mrepr with Not_found -> let mk = try MapT.find t env.make with Not_found -> assert false in let rep,_ = try MapX.find mk env.repr with Not_found -> assert false in let cls = try SetT.elements (MapX.find rep env.classes) with Not_found -> assert false in let cls = try List.rev_map (fun s -> s, MapT.find s env.make) cls with Not_found -> assert false in let e = X.choose_adequate_model t rep cls in e, MapT.add t e mrepr let output_concrete_model ({make; repr} as env) = let i = interpretation () in let abs_i = abs i in if abs_i = 1 || abs_i = 2 || abs_i = 3 then let functions, constants, arrays, _ = MapT.fold (fun t mk ((fprofs, cprofs, carrays, mrepr) as acc) -> let {T.f; xs; ty} = T.view t in if X.is_solvable_theory_symbol f || T.is_fresh t || T.is_fresh_skolem t || T.equal t T.vrai || T.equal t T.faux then acc else let xs, tys, mrepr = List.fold_left (fun (xs, tys, mrepr) x -> let rep_x, mrepr = model_repr_of_term x env mrepr in assert (is_a_good_model_value rep_x); (x, rep_x)::xs, (T.type_info x)::tys, mrepr ) ([],[], mrepr) (List.rev xs) in let rep, mrepr = model_repr_of_term t env mrepr in assert (is_a_good_model_value rep); match f, xs, ty with | Sy.Op Sy.Set, _, _ -> acc | Sy.Op Sy.Get, [(_,(a,_));((_,(i,_)) as e)], _ -> begin match X.term_extract a with | Some ta, true -> let {T.f=f_ta;xs=xs_ta; ty=ty_ta} = T.view ta in assert (xs_ta == []); fprofs, cprofs, Profile.add (f_ta,[X.type_info i], ty) ([e], rep) carrays, mrepr | _ -> assert false end | _ -> if tys == [] then fprofs, Profile.add (f, tys, ty) (xs, rep) cprofs, carrays, mrepr else Profile.add (f, tys, ty) (xs, rep) fprofs, cprofs, carrays, mrepr ) make (Profile.empty, Profile.empty, Profile.empty, MapT.empty) in if i > 0 then begin printf "(\n"; SMT2LikeModelOutput.output_constants_model constants; SMT2LikeModelOutput.output_functions_model functions; SMT2LikeModelOutput.output_arrays_model arrays; printf ")@."; end end alt-ergo-free-2.0.0/lib/reasoners/records.mli0000664000175000017500000000471213430774474016674 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) type 'a abstract module type ALIEN = sig include Sig.X val embed : r abstract -> r val extract : r -> (r abstract) option end module Shostak (X : ALIEN) : Sig.SHOSTAK with type r = X.r and type t = X.r abstract module Relation (X : ALIEN) (Uf : Uf.S) : Sig.RELATION with type r = X.r and type uf = Uf.t alt-ergo-free-2.0.0/lib/reasoners/theory.ml0000664000175000017500000006031613430774474016376 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Format open Options open Sig open Exception module X = Combine.Shostak module Ex = Explanation module SetF = Formula.Set module T = Term module A = Literal module LR = A.Make(struct type t = X.r let compare = X.str_cmp include X end) module SetT = Term.Set module Sy = Symbols module CC_X = Ccx.Main module type S = sig type t val empty : unit -> t (* the first int is the decision level (dlvl) and the second one is the propagation level (plvl). The facts (first argument) are sorted in decreasing order with respect to (dlvl, plvl) *) val assume : ?ordered:bool -> (Literal.LT.t * Explanation.t * int * int) list -> t -> t * Term.Set.t * int val query : Literal.LT.t -> t -> answer val class_of : t -> Term.t -> Term.t list val are_equal : t -> Term.t -> Term.t -> add_terms:bool -> Sig.answer val print_model : Format.formatter -> t -> unit val cl_extract : t -> Term.Set.t list val term_repr : t -> Term.t -> Term.t val extract_ground_terms : t -> Term.Set.t val get_real_env : t -> Ccx.Main.t val get_case_split_env : t -> Ccx.Main.t val do_case_split : t -> t * Term.Set.t val add_term : t -> Term.t -> add_in_cs:bool -> t val compute_concrete_model : t -> t val assume_th_elt : t -> Commands.th_elt -> t val theories_instances : do_syntactic_matching:bool -> Matching_types.info Term.Map.t * Term.t list Term.Map.t Term.Subst.t -> t -> (Formula.t -> Formula.t -> bool) -> int -> int -> t * Sig.instances val retrieve_used_context : t -> Explanation.t -> Formula.t list * Formula.t list end module Main_Default : S = struct (*BISECT-IGNORE-BEGIN*) module Debug = struct let subterms_of_assumed l = List.fold_left (List.fold_left (fun st (a, _, _) -> Term.Set.union st (A.LT.terms_rec a)) )SetT.empty l let types_of_subterms st = SetT.fold (fun t acc -> Ty.Set.add (T.type_info t) acc) st Ty.Set.empty let generalize_types ty1 ty2 = match ty1, ty2 with | Ty.Tvar _, _ -> ty1 | _, Ty.Tvar _ -> ty2 | _ -> Ty.fresh_tvar () let logics_of_assumed st = SetT.fold (fun t mp -> match T.view t with | {T.f = Sy.Name (hs, ((Sy.Ac | Sy.Other) as is_ac)); xs=xs; ty=ty} -> let xs = List.map T.type_info xs in let xs, ty = try let xs', ty', is_ac' = Hstring.Map.find hs mp in assert (is_ac == is_ac'); let ty = generalize_types ty ty' in let xs = try List.map2 generalize_types xs xs' with _ -> assert false in xs, ty with Not_found -> xs, ty in Hstring.Map.add hs (xs, ty, is_ac) mp | _ -> mp )st Hstring.Map.empty let types_of_assumed sty = let open Ty in Ty.Set.fold (fun ty mp -> match ty with | Tint | Treal | Tbool | Tunit | Tbitv _ | Tfarray _ -> mp | Tvar _ | Tnext _ -> assert false | Text (_, hs) | Tsum (hs, _) | Trecord {name=hs} when Hstring.Map.mem hs mp -> mp | Text (l, hs) -> let l = List.map (fun _ -> Ty.fresh_tvar()) l in Hstring.Map.add hs (Text(l, hs)) mp | Tsum (hs, l) -> Hstring.Map.add hs (Tsum(hs, l)) mp | Trecord {args; name; lbs} -> (* cannot do better for records ? *) Hstring.Map.add name ty mp )sty Hstring.Map.empty let print_types_decls types = let open Ty in Hstring.Map.iter (fun _ ty -> match ty with | Tint | Treal | Tbool | Tunit | Tbitv _ | Tfarray _ -> () | Tvar _ | Tnext _ -> assert false | Text _ -> fprintf fmt "@.type %a@." Ty.print ty | Tsum (_, l) -> fprintf fmt "@.type %a = " Ty.print ty; begin match l with | [] -> assert false | e::l -> fprintf fmt "%s" (Hstring.view e); List.iter (fun e -> fprintf fmt " | %s" (Hstring.view e)) l; fprintf fmt "@." end | Trecord {Ty.lbs} -> fprintf fmt "@.type %a = " Ty.print ty; begin match lbs with | [] -> assert false | (lbl, ty)::l -> fprintf fmt "{ %s : %a" (Hstring.view lbl) Ty.print ty; List.iter (fun (lbl, ty) -> fprintf fmt " ; %s : %a" (Hstring.view lbl) Ty.print ty) l; fprintf fmt " }@." end )types; fprintf fmt "@." let print_arrow_type fmt xs = match xs with | [] -> () | e :: l -> fprintf fmt "%a" Ty.print e; List.iter (fprintf fmt ", %a" Ty.print) l; fprintf fmt " -> " let print_logics logics = Hstring.Map.iter (fun hs (xs, ty, is_ac) -> fprintf fmt "logic %s%s : %a%a@.@." (if is_ac == Sy.Ac then "ac " else "") (Hstring.view hs) print_arrow_type xs Ty.print ty )logics let print_declarations l = let st = subterms_of_assumed l in let sty = types_of_subterms st in let types = types_of_assumed sty in let logics = logics_of_assumed st in print_types_decls types; print_logics logics let assumed = let cpt = ref 0 in fun l -> if debug_cc () then begin fprintf fmt "[cc] Assumed facts (in this order):@.@."; print_declarations l; incr cpt; fprintf fmt "@.goal g_%d :@." !cpt; List.iter (fun l -> fprintf fmt "@.(*call to assume*)@."; match List.rev l with | [] -> assert false | (a,dlvl,plvl)::l -> fprintf fmt "( (* %d , %d *) %a " dlvl plvl Literal.LT.print a; List.iter (fun (a, dlvl, plvl) -> fprintf fmt " and@. (* %d , %d *) %a " dlvl plvl Literal.LT.print a ) l; fprintf fmt " ) ->@." ) (List.rev l); fprintf fmt "false@."; end let theory_of k = match k with | Th_arith -> "Th_arith " | Th_sum -> "Th_sum " | Th_arrays -> "Th_arrays" | Th_UF -> "Th_UF" let made_choices fmt choices = match choices with | [] -> () | _ -> fprintf fmt "Stack of choices:@."; List.iter (fun (rx, lit_orig, _, ex) -> match lit_orig with | CS(k, sz) -> fprintf fmt " > %s cs: %a (because %a)@." (theory_of k) LR.print (LR.make rx) Ex.print ex | NCS(k, sz) -> fprintf fmt " > %s ncs: %a (because %a)@." (theory_of k) LR.print (LR.make rx) Ex.print ex | _ -> assert false )choices; fprintf fmt "==============================================@." let begin_case_split choices = if debug_split () then fprintf fmt "============= Begin CASE-SPLIT ===============@.%a@." made_choices choices let end_case_split choices = if debug_split () then fprintf fmt "============= End CASE-SPLIT =================@.%a@." made_choices choices let split_size sz = if debug_split () then fprintf fmt ">size case-split: %s@." (Numbers.Q.to_string sz) let print_lr_view fmt ch = LR.print fmt (LR.make ch) let split_backtrack neg_c ex_c = if debug_split () then fprintf fmt "[case-split] I backtrack on %a : %a@." print_lr_view neg_c Ex.print ex_c let split_assume c ex_c = if debug_split () then fprintf fmt "[case-split] I assume %a : %a@." print_lr_view c Ex.print ex_c let split_backjump c dep = if debug_split () then fprintf fmt "[case-split] I backjump on %a : %a@." print_lr_view c Ex.print dep let query a = if debug_cc () then fprintf fmt "[cc] query : %a@." A.LT.print a let split_sat_contradicts_cs filt_choices = if debug_split () then fprintf fmt "[case-split] The SAT contradicts CS! I'll replay choices@.%a@." made_choices filt_choices end (*BISECT-IGNORE-END*) type choice_sign = | CPos of Ex.exp (* The explication of this choice *) | CNeg (* The choice has been already negated *) type t = { assumed : (Literal.LT.t * int * int) list list; cs_pending_facts : (Literal.LT.t * Ex.t * int * int) list list; terms : Term.Set.t; gamma : CC_X.t; gamma_finite : CC_X.t; choices : (X.r Literal.view * lit_origin * choice_sign * Ex.t) list; (** the choice, the size, choice_sign, the explication set, the explication for this choice. *) } let look_for_sat ?(bad_last=No) ch t base_env l ~for_model = let rec aux ch bad_last dl base_env li = Options.exec_thread_yield (); match li, bad_last with | [], _ -> begin Options.tool_req 3 "TR-CCX-CS-Case-Split"; let l, base_env = CC_X.case_split base_env for_model in match l with | [] -> { t with gamma_finite = base_env; choices = List.rev dl }, ch | l -> let l = List.map (fun (c, is_cs, size) -> Options.incr_cs_steps(); let exp = Ex.fresh_exp () in let ex_c_exp = if is_cs then Ex.add_fresh exp Ex.empty else Ex.empty in (* A new explanation in order to track the choice *) (c, size, CPos exp, ex_c_exp)) l in aux ch No dl base_env l end | ((c, lit_orig, CNeg, ex_c) as a)::l, _ -> let facts = CC_X.empty_facts () in CC_X.add_fact facts (LSem c,ex_c,lit_orig); let base_env, ch = CC_X.assume_literals base_env ch facts in aux ch bad_last (a::dl) base_env l (** This optimisation is not correct with the current explanation *) (* | [(c, lit_orig, CPos exp, ex_c)], Yes (dep,_) -> *) (* let neg_c = CC_X.Rel.choice_mk_not c in *) (* let ex_c = Ex.union ex_c dep in *) (* Debug.split_backtrack neg_c ex_c; *) (* aux ch No dl base_env [neg_c, Numbers.Q.Int 1, CNeg, ex_c] *) | ((c, lit_orig, CPos exp, ex_c_exp) as a)::l, _ -> try Debug.split_assume c ex_c_exp; let facts = CC_X.empty_facts () in CC_X.add_fact facts (LSem c, ex_c_exp, lit_orig); let base_env, ch = CC_X.assume_literals base_env ch facts in Options.tool_req 3 "TR-CCX-CS-Normal-Run"; aux ch bad_last (a::dl) base_env l with Exception.Inconsistent (dep, classes) -> match Ex.remove_fresh exp dep with | None -> (* The choice doesn't participate to the inconsistency *) Debug.split_backjump c dep; Options.tool_req 3 "TR-CCX-CS-Case-Split-Conflict"; raise (Exception.Inconsistent (dep, classes)) | Some dep -> Options.tool_req 3 "TR-CCX-CS-Case-Split-Progress"; (* The choice participates to the inconsistency *) let neg_c = LR.view (LR.neg (LR.make c)) in let lit_orig = match lit_orig with | CS(k, sz) -> NCS(k, sz) | _ -> assert false in Debug.split_backtrack neg_c dep; if bottom_classes () then printf "bottom (case-split):%a\n@." Term.print_tagged_classes classes; aux ch No dl base_env [neg_c, lit_orig, CNeg, dep] in aux ch bad_last (List.rev t.choices) base_env l (* remove old choices involving fresh variables that are no longer in UF *) let filter_choice uf (ra,_,_,_) = let l = match ra with | A.Eq(r1, r2) -> [r1; r2] | A.Distinct (_, l) -> l | A.Builtin (_,_, l) -> l | A.Pred(p, _) -> [p] in List.for_all (fun r -> List.for_all (fun x -> match X.term_extract x with | Some t, _ -> Combine.Uf.mem uf t | _ -> true )(X.leaves r) )l let try_it t facts ~for_model = Options.exec_thread_yield (); Debug.begin_case_split t.choices; let r = try if t.choices == [] then look_for_sat [] t t.gamma [] for_model else try let env, ch = CC_X.assume_literals t.gamma_finite [] facts in look_for_sat ch t env [] for_model with Exception.Inconsistent (dep, classes) -> Options.tool_req 3 "TR-CCX-CS-Case-Split-Erase-Choices"; (* we replay the conflict in look_for_sat, so we can safely ignore the explanation which is not useful *) let uf = CC_X.get_union_find t.gamma in let filt_choices = List.filter (filter_choice uf) t.choices in Debug.split_sat_contradicts_cs filt_choices; look_for_sat ~bad_last:(Yes (dep, classes)) [] { t with choices = []} t.gamma filt_choices ~for_model with Exception.Inconsistent (d, cl) -> Debug.end_case_split t.choices; Options.tool_req 3 "TR-CCX-CS-Conflict"; raise (Exception.Inconsistent (d, cl)) in Debug.end_case_split (fst r).choices; r let extract_from_semvalues acc l = List.fold_left (fun acc r -> match X.term_extract r with | Some t, _ -> SetT.add t acc | _ -> acc) acc l let extract_terms_from_choices = List.fold_left (fun acc (a, _, _, _) -> match a with | A.Eq(r1, r2) -> extract_from_semvalues acc [r1; r2] | A.Distinct (_, l) -> extract_from_semvalues acc l | A.Pred(p, _) -> extract_from_semvalues acc [p] | _ -> acc ) let extract_terms_from_assumed = List.fold_left (fun acc (a, _, _) -> match a with | LTerm r -> begin match Literal.LT.view r with | Literal.Eq (t1, t2) -> SetT.add t1 (SetT.add t2 acc) | Literal.Distinct (_, l) | Literal.Builtin (_, _, l) -> List.fold_right SetT.add l acc | Literal.Pred (t1, _) -> SetT.add t1 acc end | _ -> acc) let rec is_ordered_list l = match l with | [] | [[_]] -> true | []::r -> is_ordered_list r | [e]::r1::r2 -> is_ordered_list ((e::r1)::r2) | (e1::e2::l)::r -> let _, d1, p1 = e1 in let _, d2, p2 = e2 in (d1 > d2 || d1 = d2 && p1 > p2) && is_ordered_list ((e2::l)::r) let do_case_split t = let in_facts_l = t.cs_pending_facts in let t = {t with cs_pending_facts = []} in let facts = CC_X.empty_facts () in List.iter (List.iter (fun (a,ex,dlvl,plvl) -> CC_X.add_fact facts (LTerm a, ex, Sig.Other)) ) in_facts_l; let t, ch = try_it t facts ~for_model:false in let choices = extract_terms_from_choices SetT.empty t.choices in let choices_terms = extract_terms_from_assumed choices ch in {t with terms = Term.Set.union t.terms choices_terms}, choices_terms (* facts are sorted in decreasing order with respect to (dlvl, plvl) *) let assume ordered in_facts t = let facts = CC_X.empty_facts () in let assumed, cpt = List.fold_left (fun (assumed, cpt) ((a, ex, dlvl, plvl)) -> CC_X.add_fact facts (LTerm a, ex, Sig.Other); (a, dlvl, plvl) :: assumed, cpt+1 )([], 0) in_facts in let t = {t with assumed = assumed :: t.assumed; cs_pending_facts = in_facts :: t.cs_pending_facts} in if Options.profiling() then Profiling.assume cpt; Debug.assumed t.assumed; assert (not ordered || is_ordered_list t.assumed); let gamma, ch = CC_X.assume_literals t.gamma [] facts in let new_terms = CC_X.new_terms gamma in {t with gamma = gamma; terms = Term.Set.union t.terms new_terms}, new_terms, cpt let class_of t term = CC_X.class_of t.gamma term let debug_theories_instances th_instances ilvl dlvl = let module MF = Formula.Map in fprintf fmt "===========================================================@."; fprintf fmt "[Theory] dec. level = %d, instant. level = %d, %d new Th instances@." dlvl ilvl (List.length th_instances); let mp = List.fold_left (fun acc ((hyps:Formula.t list),gf, _) -> match gf.Formula.lem with | None -> assert false | Some lem -> let inst = try MF.find lem acc with Not_found -> MF.empty in MF.add lem (MF.add gf.Formula.f hyps inst) acc )MF.empty th_instances in let l = MF.fold (fun f inst acc -> (f, MF.cardinal inst, inst) :: acc) mp [] in let l = List.fast_sort (fun (_,m,_) (_,n,_) -> n - m) l in List.iter (fun (f, m, inst) -> fprintf fmt "@.%3d --> %a@." m Formula.print f; if true then begin MF.iter (fun f hyps -> fprintf fmt " [inst]@."; List.iter (fun h -> fprintf fmt " hypothesis: %a@." Formula.print h; )hyps; fprintf fmt " conclusion: %a@." Formula.print f; ) inst; end ) l let theories_instances ~do_syntactic_matching t_match t selector dlvl ilvl = let gamma, instances = CC_X.theories_instances ~do_syntactic_matching t_match t.gamma selector in if debug_fpa() > 0 then debug_theories_instances instances dlvl ilvl; {t with gamma = gamma}, instances let query = let add_and_process_conseqs a t = (* !!! query does not modify gamma_finite anymore *) Options.exec_thread_yield (); let gamma, facts = CC_X.add t.gamma (CC_X.empty_facts()) a Ex.empty in let gamma, _ = CC_X.assume_literals gamma [] facts in { t with gamma = gamma } in fun a t -> if Options.profiling() then Profiling.query(); Options.exec_thread_yield (); Debug.query a; try match A.LT.view a with | A.Eq (t1, t2) -> let t = add_and_process_conseqs a t in CC_X.are_equal t.gamma t1 t2 ~added_terms:true | A.Distinct (false, [t1; t2]) -> let na = A.LT.neg a in let t = add_and_process_conseqs na t in (* na ? *) CC_X.are_distinct t.gamma t1 t2 | A.Distinct _ -> assert false (* devrait etre capture par une analyse statique *) | A.Pred (t1,b) -> let t = add_and_process_conseqs a t in if b then CC_X.are_distinct t.gamma t1 (Term.top()) else CC_X.are_equal t.gamma t1 (Term.top()) ~added_terms:true | _ -> let na = A.LT.neg a in let t = add_and_process_conseqs na t in CC_X.query t.gamma na with Exception.Inconsistent (d, classes) -> Yes (d, classes) let are_equal t t1 t2 add_terms = if add_terms then let facts = CC_X.empty_facts() in let gamma, facts = CC_X.add_term t.gamma facts t1 Ex.empty in let gamma, facts = CC_X.add_term gamma facts t2 Ex.empty in try let gamma, _ = CC_X.assume_literals gamma [] facts in CC_X.are_equal gamma t1 t2 ~added_terms:true with Inconsistent (ex,cl) -> Yes(ex, cl) else CC_X.are_equal t.gamma t1 t2 ~added_terms:false let add_term_in_gm gm t = let facts = CC_X.empty_facts() in let gm, facts = CC_X.add_term gm facts t Ex.empty in fst (CC_X.assume_literals gm [] facts) (* may raise Inconsistent *) let add_term env t ~add_in_cs = let gm = add_term_in_gm env.gamma t in if not add_in_cs then {env with gamma = gm} else {env with gamma=gm; gamma_finite=add_term_in_gm env.gamma_finite t} let empty () = let env = CC_X.empty () in let env, _ = CC_X.add_term env (CC_X.empty_facts()) T.vrai Ex.empty in let env, _ = CC_X.add_term env (CC_X.empty_facts()) T.faux Ex.empty in let t = { gamma = env; gamma_finite = env; choices = []; assumed = []; cs_pending_facts = []; terms = Term.Set.empty } in let a = A.LT.mk_distinct false [T.vrai; T.faux] in let t, _, _ = assume true [a, Ex.empty, 0, -1] t in t let print_model fmt t = CC_X.print_model fmt t.gamma_finite let cl_extract env = CC_X.cl_extract env.gamma let term_repr env t = CC_X.term_repr env.gamma t let assume ?(ordered=true) facts t = if Options.timers() then try Timers.exec_timer_start Timers.M_CC Timers.F_assume; let res = assume ordered facts t in Timers.exec_timer_pause Timers.M_CC Timers.F_assume; res with e -> Timers.exec_timer_pause Timers.M_CC Timers.F_assume; raise e else assume ordered facts t let query a t = if Options.timers() then try Timers.exec_timer_start Timers.M_CC Timers.F_query; let res = query a t in Timers.exec_timer_pause Timers.M_CC Timers.F_query; res with e -> Timers.exec_timer_pause Timers.M_CC Timers.F_query; raise e else query a t let extract_ground_terms env = env.terms let get_real_env t = t.gamma let get_case_split_env t = t.gamma_finite let are_equal env t1 t2 ~add_terms = if Options.timers() then try Timers.exec_timer_start Timers.M_CC Timers.F_are_equal; let res = are_equal env t1 t2 add_terms in Timers.exec_timer_pause Timers.M_CC Timers.F_are_equal; res with e -> Timers.exec_timer_pause Timers.M_CC Timers.F_are_equal; raise e else are_equal env t1 t2 add_terms let compute_concrete_model env = fst (try_it env (CC_X.empty_facts ()) ~for_model:true) let assume_th_elt t th_elt = { t with gamma = CC_X.assume_th_elt t.gamma th_elt } let retrieve_used_context env dep = CC_X.retrieve_used_context env.gamma dep end module Main_Empty : S = struct type t = int let empty () = -1 let assume ?(ordered=true) _ _ = 0, T.Set.empty, 0 let query a t = No let class_of env t = [t] let are_equal env t1 t2 ~add_terms = if T.equal t1 t2 then Yes(Ex.empty, []) else No let print_model _ _ = () let cl_extract _ = [] let term_repr _ t = t let extract_ground_terms _ = Term.Set.empty let empty_ccx = CC_X.empty () let get_real_env _ = empty_ccx let get_case_split_env _ = empty_ccx let do_case_split _ = 0, T.Set.empty let add_term env t ~add_in_cs = env let compute_concrete_model e = e let terms_in_repr e = Term.Set.empty let assume_th_elt e _ = e let theories_instances ~do_syntactic_matching _ e _ _ _ = e, [] let retrieve_used_context _ _ = [], [] end module Main = (val ( if Options.no_theory() then (module Main_Empty : S) else (module Main_Default : S) ) : S ) alt-ergo-free-2.0.0/lib/reasoners/intervals.ml0000664000175000017500000011577113430774474017101 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Format open Options module Z = Numbers.Z module Q = Numbers.Q module Ex = Explanation type borne = | Strict of (Q.t * Ex.t) | Large of (Q.t * Ex.t) | Pinfty | Minfty type t = { ints : (borne * borne) list; is_int : bool; expl: Ex.t } exception EmptyInterval of Ex.t exception NotConsistent of Ex.t exception No_finite_bound (*BISECT-IGNORE-BEGIN*) module Debug = struct let print_borne fmt = function | Minfty -> fprintf fmt "-inf" | Pinfty -> fprintf fmt "+inf" | Strict (v, e) | Large (v, e) -> fprintf fmt "%s" (Q.to_string v); if verbose () || proof () then fprintf fmt " %a" Ex.print e let print_interval fmt (b1,b2) = let c1, c2 = match b1, b2 with | Large _, Large _ -> '[', ']' | Large _, _ -> '[', '[' | _, Large _ -> ']', ']' | _, _ -> ']', '[' in fprintf fmt "%c%a;%a%c" c1 print_borne b1 print_borne b2 c2 let print_list fmt = function | [] -> fprintf fmt "[empty]" | e::l -> print_interval fmt e; List.iter (fprintf fmt " U %a" print_interval) l let print fmt {ints = ints; is_int = b; expl = e } = print_list fmt ints; if verbose () || proof () then fprintf fmt " %a" Ex.print e end (*BISECT-IGNORE-END*) let print = Debug.print let pretty_print = Debug.print let large_borne_of n e = Large (n, e) let strict_borne_of n e = Strict (n, e) let undefined_int = {ints = [Minfty, Pinfty]; is_int = true ; expl = Ex.empty} let undefined_real = {ints = [Minfty, Pinfty]; is_int = false; expl = Ex.empty} let undefined ty = match ty with | Ty.Tint -> undefined_int | Ty.Treal -> undefined_real | _ -> assert false let is_undefined t = match t.ints with | [Minfty, Pinfty] -> true | _ -> false let point b ty e = { ints = [Large (b, e), Large (b, e)]; is_int = ty == Ty.Tint; expl = e } let is_point { ints = l; expl = e } = match l with | [Large (v1, e1) , Large (v2, e2)] when Q.equal v1 v2 -> Some (v1, Ex.union e (Ex.union e1 e2)) | _ -> None let finite_size {ints = l; is_int = is_int} = if not is_int then None else try let acc = ref [] in List.iter (fun (b1, b2) -> match b1, b2 with | Minfty, _ | _, Pinfty -> raise Exit | Large (v1, _) , Large (v2, _) -> acc := (v1, v2) :: !acc | _, _ -> assert false )l; let res = List.fold_left (fun n (v1, v2) -> Q.add n (Q.add (Q.sub v2 v1) Q.one)) Q.zero !acc in Some res with Exit -> None let borne_inf = function | {ints = (Large (v, ex), _)::_} -> v, ex, true | {ints = (Strict (v, ex), _)::_} -> v, ex, false | _ -> raise No_finite_bound let borne_sup {ints=ints} = match List.rev ints with | (_, Large (v, ex))::_ -> v, ex, true | (_, Strict (v, ex))::_ -> v, ex, false | _ -> raise No_finite_bound let explain_borne = function | Large (_, e) | Strict (_, e) -> e | _ -> Ex.empty let add_expl_to_borne b e = if Ex.is_empty e then b else match b with | Large (n, e') -> Large (n, Ex.union e e') | Strict (n, e') -> Strict (n, Ex.union e e') | Pinfty | Minfty -> b let add_expl_zero i expl = if Ex.is_empty expl then i else let res = List.rev_map (fun x -> match x with | Large (c1, e1), Large (c2, e2) when Q.sign c1 = 0 && Q.sign c2 = 0 -> Large (Q.zero, Ex.union e1 expl), Large (Q.zero, Ex.union e2 expl) | _ -> x ) i.ints in { i with ints = List.rev res } let int_of_borne_inf b = match b with | Minfty | Pinfty -> b | Large (v, e) -> Large ((if Q.is_int v then v else Q.ceiling v), e) | Strict (v, e) -> if Q.is_int v then Large (Q.add v Q.one, e) else let v' = Q.ceiling v in assert (Q.compare v' v > 0); Large (v', e) let int_of_borne_sup b = match b with | Minfty | Pinfty -> b | Large (v, e) -> Large ((if Q.is_int v then v else Q.floor v), e) | Strict (v, e) -> if Q.is_int v then Large (Q.sub v Q.one, e) else let v' = Q.floor v in assert (Q.compare v' v < 0); Large (v', e) let int_bornes (l, u) = int_of_borne_inf l, int_of_borne_sup u let compare_bounds b1 ~is_low1 b2 ~is_low2 = match b1, b2 with | Minfty, Minfty | Pinfty, Pinfty -> 0 | Minfty, _ | _, Pinfty -> -1 | _, Minfty | Pinfty, _ -> 1 | Large (v1, ex1), Large (v2, ex2) -> Q.compare v1 v2 | Strict (v1, ex1), Strict (v2, ex2) -> let c = Q.compare v1 v2 in if c <> 0 then c else if is_low1 == is_low2 then 0 (* bl_bl or bu_bu *) else if is_low1 then 1 (* implies not is_low2 *) else -1 (* implies not is_low1 and is_low2 *) | Strict (v1, ex1), Large (v2, ex2) -> let c = Q.compare v1 v2 in if c <> 0 then c else if is_low1 then 1 else -1 | Large (v1, ex1), Strict (v2, ex2) -> let c = Q.compare v1 v2 in if c <> 0 then c else if is_low2 then -1 else 1 let zero_endpoint b = match b with | Large (v, _) -> Q.is_zero v | _ -> false let min_of_lower_bounds b1 b2 = if compare_bounds b1 ~is_low1:true b2 ~is_low2:true <= 0 then b1 else b2 let max_of_upper_bounds b1 b2 = if compare_bounds b1 ~is_low1:false b2 ~is_low2:false >= 0 then b1 else b2 let zero_large = Large (Q.zero, Ex.empty) let low_borne_pos_strict b = compare_bounds b ~is_low1:true zero_large ~is_low2:true > 0 let up_borne_pos_strict b = compare_bounds b ~is_low1:false zero_large ~is_low2:false > 0 let low_borne_neg_strict b = compare_bounds b ~is_low1:true zero_large ~is_low2:true < 0 let up_borne_neg_strict b = compare_bounds b ~is_low1:false zero_large ~is_low2:false < 0 let low_borne_pos_large b = compare_bounds b ~is_low1:true zero_large ~is_low2:true >= 0 let up_borne_pos_large b = compare_bounds b ~is_low1:false zero_large ~is_low2:false >= 0 let low_borne_neg_large b = compare_bounds b ~is_low1:true zero_large ~is_low2:true <= 0 let up_borne_neg_large b = compare_bounds b ~is_low1:false zero_large ~is_low2:false <= 0 (* should be removed: probably buggy when mixing lower and upper bounds *) let pos_borne b = match b with | Pinfty -> true | Minfty -> false | Strict (v, _) | Large (v, _) -> Q.sign v >= 0 (* should be removed: probably buggy when mixing lower and upper bounds *) let neg_borne b = match b with | Pinfty -> false | Minfty -> true | Strict (v, _) | Large (v, _) -> Q.sign v <= 0 (* TODO: generalize the use of this type and the function joint below to other operations on intervals *) type kind = | Empty of Explanation.t | Int of (borne * borne) let join l glob_ex = (* l should not be empty *) let rec j_aux _todo _done = match _todo, _done with | [], [] -> assert false | [], _ -> List.rev _done, None | [Empty ex], [] -> [], Some ex | (Int b) :: l, _ -> j_aux l (b :: _done) | (Empty ex) :: l, _ -> let _done = match _done with | [] -> [] | (low, up) :: r -> (low, add_expl_to_borne up ex) :: r in let _todo = match l with | [] -> [] | (Empty ex') :: r -> (Empty (Ex.union ex ex')) :: r | (Int (low, up)) :: r -> (Int (add_expl_to_borne low ex, up)) :: r in j_aux _todo _done in match j_aux l [] with | [], None -> assert false | l , None -> l | [], Some ex -> raise (NotConsistent (Ex.union ex glob_ex)); | l , Some _ -> assert false let intersect = let rec step is_int l1 l2 acc = match l1, l2 with | [], _ | _, [] -> List.rev acc | (lo1, up1)::r1, (lo2, up2)::r2 when compare_bounds up1 ~is_low1:false lo2 ~is_low2:true < 0 -> (* No overlap. (lo1, up1) is smaller *) let nexpl = Ex.union (explain_borne up1) (explain_borne lo2) in step is_int r1 l2 ((Empty nexpl) :: acc) | (lo1, up1)::r1, (lo2, up2)::r2 when compare_bounds lo1 ~is_low1:true up2 ~is_low2:false > 0 -> (* No overlap. (lo2, up2) is smaller *) let nexpl = Ex.union (explain_borne up2) (explain_borne lo1) in step is_int l1 r2 ((Empty nexpl) :: acc) | (lo1, up1)::r1, (lo2, up2)::r2 -> let cll = compare_bounds lo1 ~is_low1:true lo2 ~is_low2:true in let cuu = compare_bounds up1 ~is_low1:false up2 ~is_low2:false in if cll <= 0 && cuu >= 0 then (* (lo1, up1) subsumes (lo2, up2) *) step is_int l1 r2 ((Int (lo2,up2))::acc) (* ex of lo1 and up1 ? *) else if cll >= 0 && cuu <= 0 then (* (lo2, up2) subsumes (lo1, up1) *) step is_int r1 l2 ((Int(lo1,up1))::acc) (* ex of lo2 and up2 ? *) else if cll <= 0 && cuu <= 0 then (* lo1 <= lo2 <= up1 <= up2 *) step is_int r1 l2 ((Int(lo2,up1))::acc) (* ex of lo1 and up2 ? *) else if cll >= 0 && cuu >= 0 then (* lo2 <= lo1 <= up2 <= up1 *) step is_int l1 r2 (Int((lo1,up2))::acc) (* ex of lo2 and up1 ? *) else assert false in fun ({ints=l1; expl=e1; is_int=is_int} as uints1) {ints=l2; expl=e2} -> (*l1 and l2 are supposed to be normalized *) let expl = Ex.union e1 e2 in let l = step is_int l1 l2 [] in let res = { uints1 with ints = join l expl; expl } in assert (res.ints != []); res let new_borne_sup expl b ~is_le uints = let aux b expl = let b = (if is_le then large_borne_of else strict_borne_of) b expl in if uints.is_int then int_of_borne_sup b else b in intersect { ints = [Minfty, aux b expl]; is_int = uints.is_int; expl = Ex.empty } uints let new_borne_inf expl b ~is_le uints = let aux b expl = let b = (if is_le then large_borne_of else strict_borne_of) b expl in if uints.is_int then int_of_borne_inf b else b in intersect { ints = [aux b expl, Pinfty]; is_int = uints.is_int; expl = Ex.empty } uints type interval_class = | P | M | N | Z let class_of l u = if zero_endpoint l && zero_endpoint u then Z else if pos_borne l && pos_borne u then begin assert (up_borne_pos_strict u); P end else if neg_borne l && neg_borne u then begin assert (low_borne_neg_strict l); N end else begin assert (low_borne_neg_strict l); assert (up_borne_pos_strict u); M end let union_bornes is_int l = let rec aux is_int l acc = match l with | [] -> acc | [e] -> e::acc | (l1, u1)::((l2, u2)::r as r2) -> if compare_bounds u1 ~is_low1:false l2 ~is_low2:true < 0 then match is_int, u1, l2 with | true, Large(x,_), Large (y, _) when Q.equal (Q.sub y x) Q.one -> aux is_int ((l1, u2)::r) acc | _ -> (* the only case where we put things in acc *) aux is_int r2 ((l1, u1)::acc) else if compare_bounds u1 ~is_low1:false u2 ~is_low2:false > 0 then aux is_int ((l1, u1)::r) acc else aux is_int ((l1, u2)::r) acc in List.rev (aux is_int l []) let union_intervals uints = let l = List.fast_sort (fun (l1, _) (l2, _) -> compare_bounds l1 ~is_low1:true l2 ~is_low2:true) uints.ints in {uints with ints = union_bornes uints.is_int l} let minus_borne = function | Minfty -> Pinfty | Pinfty -> Minfty | Large (v, e) -> Large (Q.minus v, e) | Strict (v, e) -> Strict (Q.minus v, e) let rev_normalize_int_bounds rl ex n = let l = List.rev_map (fun b -> let b = int_bornes b in match b with | Large (v, ex1), Large (w, ex2) when Q.compare w v < 0 -> Empty (Ex.union ex1 ex2) | Strict (v, ex1), Large (w, ex2) | Large (v, ex1) , Strict (w, ex2) | Strict (v, ex1), Strict (w, ex2) when Q.compare w v <= 0 -> Empty (Ex.union ex1 ex2) | _ -> Int b ) rl in if Q.compare n Q.zero > 0 (* !!! this test should be checked *) then join l ex else List.rev (join (List.rev l) ex) let exclude = let rec complement l prev acc = match l with | (b1,b2)::r -> let bu = match b1 with | Strict v -> Large v | Large v -> Strict v | _ -> b1 in let bl = match b2 with | Strict v -> Large v | Large v -> Strict v | _ -> b2 in if bu == Minfty then complement r bl acc else complement r bl ((prev, bu)::acc) | [] -> List.rev (if prev == Pinfty then acc else (prev, Pinfty)::acc) in fun uints1 uints2 -> let l_c = complement uints1.ints Minfty [] in let l_c = if uints2.is_int then List.rev (List.rev_map int_bornes l_c) else l_c in let uints1_c = union_intervals {uints1 with ints = l_c} in intersect uints1_c uints2 let scale_interval_zero n (b1, b2) = assert (Q.sign n = 0); Large (Q.zero, explain_borne b1), Large (Q.zero, explain_borne b2) let scale_borne_non_zero n b = assert (Q.sign n > 0); match b with | Pinfty | Minfty -> b | Large (v, e) -> Large (Q.mult n v, e) | Strict (v, e) -> Strict (Q.mult n v, e) let scale_interval_pos n (b1, b2) = scale_borne_non_zero n b1, scale_borne_non_zero n b2 let scale_interval_neg n (b1, b2) = minus_borne (scale_borne_non_zero (Q.minus n) b2), minus_borne (scale_borne_non_zero (Q.minus n) b1) let scale n uints = Options.tool_req 4 "TR-Arith-Axiomes scale"; if Q.equal n Q.one then uints else let sgn = Q.sign n in let aux = if sgn = 0 then scale_interval_zero else if sgn > 0 then scale_interval_pos else scale_interval_neg in let rl = List.rev_map (aux n) uints.ints in let l = if uints.is_int then rev_normalize_int_bounds rl uints.expl n else List.rev rl in let res = union_intervals { uints with ints = l } in assert (res.ints != []); res let add_borne b1 b2 = match b1,b2 with | Minfty, Pinfty | Pinfty, Minfty -> assert false | Minfty, _ | _, Minfty -> Minfty | Pinfty, _ | _, Pinfty -> Pinfty | Large (v1, e1), Large (v2, e2) -> Large (Q.add v1 v2, Ex.union e1 e2) | (Large (v1, e1) | Strict (v1, e1)), (Large (v2, e2) | Strict (v2, e2)) -> Strict (Q.add v1 v2, Ex.union e1 e2) let add_interval is_int l (b1,b2) = List.fold_right (fun (b1', b2') l -> let l1 = ((add_borne b1 b1'),(add_borne b2 b2'))::l in union_bornes is_int (l1) ) l [] let add {ints = l1; is_int = is_int; expl = e1} {ints = l2; expl = e2}= let l = List.fold_left (fun l bs -> let i = add_interval is_int l1 bs in i@l) [] l2 in let res = union_intervals { ints = l ; is_int; expl = Ex.union e1 e2 } in assert (res.ints != []); res let sub i1 i2 = add i1 (scale Q.m_one i2) let merge i1 i2 = union_intervals {ints = List.rev_append i1.ints i2.ints; is_int = i1.is_int; expl = Explanation.union i1.expl i2.expl} let contains i q = List.exists (fun (b1, b2) -> begin match b1 with | Minfty -> true | Pinfty -> assert false | Large(v, _) -> Q.compare v q <= 0 | Strict(v, _) -> Q.compare v q < 0 end && begin match b2 with | Pinfty -> true | Minfty -> assert false | Large(v, _) -> Q.compare v q >= 0 | Strict(v, _) -> Q.compare v q > 0 end ) i.ints let doesnt_contain_0 = let rec explain_no_zero l = match l with | [] -> assert false | (b1, b2) :: l -> let pos_strict_b1 = low_borne_pos_strict b1 in let pos_strict_b2 = up_borne_pos_strict b2 in if pos_strict_b1 && pos_strict_b2 then (* there is no negative values at all *) Sig.Yes (Ex.union (explain_borne b1) (explain_borne b2), []) else begin (* we know l does not contain 0. So, these asserts should hold *) assert (not pos_strict_b1); assert (not pos_strict_b2); assert (low_borne_neg_strict b1); assert (up_borne_neg_strict b2); match l with | [] -> (* there is no positive values at all *) Sig.Yes (Ex.union (explain_borne b1) (explain_borne b2), []) | (c1,_)::_ -> if low_borne_pos_strict c1 then Sig.Yes (Ex.union (explain_borne b2) (explain_borne c1), []) else explain_no_zero l end in fun int -> if contains int Q.zero then Sig.No else explain_no_zero int.ints let is_positive {ints=ints; expl=expl} = match ints with | [] -> assert false | (lb,_)::_ -> if pos_borne lb then Sig.Yes (expl, []) else Sig.No let root_default_num v n = if n = 2 then Q.sqrt_default v else Q.root_default v n let root_exces_num v n = if n = 2 then Q.sqrt_excess v else Q.root_excess v n (* should be removed and replaced with compare_bounds, with makes distinction between lower and upper bounds *) let compare_bornes b1 b2 = match b1, b2 with | Minfty, Minfty | Pinfty, Pinfty -> 0 | Minfty, _ | _, Pinfty -> -1 | Pinfty, _ | _, Minfty -> 1 | Strict (v1, _), Strict (v2, _) | Large (v1, _), Large (v2, _) | Strict (v1, _), Large (v2, _) | Large (v1, _), Strict (v2, _) -> Q.compare v1 v2 let is_strict_smaller = let rec aux l1 l2 nb_eq sz_l1 sz_l2 = match l1, l2 with [], _ -> true, nb_eq, sz_l1, (sz_l2 + List.length l2) | _, [] -> false, nb_eq, (sz_l1 + List.length l1), sz_l2 | b1::r1, b2::r2 -> let lo1, up1 = b1 in let lo2, up2 = b2 in let c_l1_l2 = compare_bounds lo1 ~is_low1:true lo2 ~is_low2:true in let c_u1_u2 = compare_bounds up1 ~is_low1:false up2 ~is_low2:false in let c_l1_u2 = compare_bounds lo1 ~is_low1:true up2 ~is_low2:false in let c_u1_l2 = compare_bounds up1 ~is_low1:false lo2 ~is_low2:true in if c_l1_l2 = 0 && c_u1_u2 = 0 then aux r1 r2 (nb_eq + 1) (sz_l1 + 1) (sz_l2 + 1) else if c_l1_l2 >= 0 && c_u1_u2 <= 0 then (* without being equal *) (* b1 \subset b2! look for inclusion of r1 in l2 *) aux r1 l2 nb_eq (sz_l1 + 1) sz_l2 else if c_l1_u2 >= 0 then (*ignore b2, and look for inclusion of l1 in r2*) aux l1 r2 nb_eq sz_l1 (sz_l2 + 1) else if c_u1_l2 < 0 then raise Exit(* b1 is not included in any part of l2*) else if c_l1_l2 <= 0 && c_u1_u2 >= 0 then (* without being equal *) raise Exit (*no inclusion, we have b2 \subset b1 !! *) else if c_l1_l2 < 0 && c_u1_u2 < 0 || c_l1_l2 > 0 && c_u1_u2 > 0 then raise Exit (* intersection and differences are not empty *) else assert false in fun i1 i2 -> try let res, nb_eq, sz_l1, sz_l2 = aux i1.ints i2.ints 0 0 0 in (* if res is true, we should check that i1 and i2 are not equal *) res && (sz_l1 <> sz_l2 || nb_eq <> sz_l1) with Exit -> false let mult_borne b1 b2 = match b1,b2 with | Minfty, Pinfty | Pinfty, Minfty -> assert false | Minfty, b | b, Minfty -> if compare_bornes b (large_borne_of Q.zero Ex.empty) = 0 then b else if pos_borne b then Minfty else Pinfty | Pinfty, b | b, Pinfty -> if compare_bornes b (large_borne_of Q.zero Ex.empty) = 0 then b else if pos_borne b then Pinfty else Minfty | Strict (_, e1), Large (v, e2) | Large (v, e1), Strict (_, e2) when Q.is_zero v -> Large (Q.zero, Ex.union e1 e2) | Strict (v1, e1), Strict (v2, e2) | Strict (v1, e1), Large (v2, e2) | Large (v1, e1), Strict (v2, e2) -> Strict (Q.mult v1 v2, Ex.union e1 e2) | Large (v1, e1), Large (v2, e2) -> Large (Q.mult v1 v2, Ex.union e1 e2) let mult_borne_inf b1 b2 = match b1,b2 with | Minfty, Pinfty | Pinfty, Minfty -> Minfty | _, _ -> mult_borne b1 b2 let mult_borne_sup b1 b2 = match b1,b2 with | Minfty, Pinfty | Pinfty, Minfty -> Pinfty | _, _ -> mult_borne b1 b2 let mult_bornes (a,b) (c,d) = (* see ../extra/intervals_mult.png *) (* put the explanation of both bounds for multiplication. Putting just one of them is probably incorrect. When a bound is [0,0], put the explanation of that bound instead of empty. TODO: make a deeper study!!!*) let ex_a_b = Ex.union (explain_borne a) (explain_borne b) in let ex_c_d = Ex.union (explain_borne c) (explain_borne d) in let all_ex = Ex.union ex_a_b ex_c_d in match class_of a b, class_of c d with | P, P -> mult_borne_inf a c, mult_borne_sup b d, all_ex | P, M -> mult_borne_inf b c, mult_borne_sup b d, all_ex | P, N -> mult_borne_inf b c, mult_borne_sup a d, all_ex | M, P -> mult_borne_inf a d, mult_borne_sup b d, all_ex | M, M -> min_of_lower_bounds (mult_borne_inf a d) (mult_borne_inf b c), max_of_upper_bounds (mult_borne_sup a c) (mult_borne_sup b d), all_ex | M, N -> mult_borne_inf b c, mult_borne_sup a c, all_ex | N, P -> mult_borne_inf a d, mult_borne_sup b c, all_ex | N, M -> mult_borne_inf a d, mult_borne_sup a c, all_ex | N, N -> mult_borne_inf b d, mult_borne_sup a c, all_ex | Z, (P | M | N | Z) -> (a, b, ex_a_b) | (P | M | N ), Z -> (c, d, ex_c_d) let rec power_borne_inf p b = match p with | 1 -> b | p -> mult_borne_inf b (power_borne_inf (p-1) b) let rec power_borne_sup p b = match p with | 1 -> b | p -> mult_borne_sup b (power_borne_sup (p-1) b) let max_merge b1 b2 = let ex = Ex.union (explain_borne b1) (explain_borne b2) in let max = max_of_upper_bounds b1 b2 in match max with | Minfty | Pinfty -> max | Large (v, _) -> Large (v, ex) | Strict (v, _) -> Strict (v, ex) let power_bornes p (b1,b2) = if neg_borne b1 && pos_borne b2 then match p with | 0 -> assert false | p when p mod 2 = 0 -> (* max_merge to have explanations !!! *) let m = max_merge (power_borne_sup p b1) (power_borne_sup p b2) in (Large (Q.zero, Ex.empty), m) | _ -> (power_borne_inf p b1, power_borne_sup p b2) else if pos_borne b1 && pos_borne b2 then (power_borne_inf p b1, power_borne_sup p b2) else if neg_borne b1 && neg_borne b2 then match p with | 0 -> assert false | p when p mod 2 = 0 -> (power_borne_inf p b2, power_borne_sup p b1) | _ -> (power_borne_inf p b1, power_borne_sup p b2) else assert false let int_div_of_borne_inf min_f b = match b with | Minfty | Pinfty -> b | Large (v, e) -> Large ((if Q.is_int v then v else (*Q.floor*) min_f v), e) | Strict (v, e) -> (* this case really happens ?? *) if Q.is_int v then Large (Q.add v Q.one, e) else let v' = (*Q.floor*) min_f v in (* correct ? *) assert (Q.compare v' v > 0); Large (v', e) let int_div_of_borne_sup max_f b = match b with | Minfty | Pinfty -> b | Large (v, e) -> Large ((if Q.is_int v then v else (*Q.floor*) max_f v), e) | Strict (v, e) -> (* this case really happens ?? *) if Q.is_int v then Large (Q.sub v Q.one, e) else let v' = (*Q.floor*) max_f v in (* correct ? *) assert (Q.compare v' v < 0); Large (v', e) (* we use int_div_bornes for division of integer intervals instead of int_bornes because the div op is Euclidean division is this case *) let int_div_bornes min_f max_f l u = int_div_of_borne_inf min_f l, int_div_of_borne_sup max_f u let mult u1 u2 = Options.tool_req 4 "TR-Arith-Axiomes mult"; let resl, expl = List.fold_left (fun (l', expl) b1 -> List.fold_left (fun (l, ex) b2 -> let bl, bu, ex' = mult_bornes b1 b2 in let bl = add_expl_to_borne bl ex' in let bu = add_expl_to_borne bu ex' in (bl, bu)::l, Ex.union ex ex') (l', expl) u2.ints) ([], Ex.empty) u1.ints in let res = union_intervals { ints= resl; is_int = u1.is_int; expl = Ex.union expl (Ex.union u1.expl u2.expl) } in assert (res.ints != []); res let power n u = Options.tool_req 4 "TR-Arith-Axiomes power"; let l = List.map (power_bornes n) u.ints in union_intervals { u with ints = l } let root_default_borne is_int x n = match x with | Pinfty -> Pinfty | Minfty -> Minfty | Large (v, e) | Strict (v, e) -> let sign, s = if Q.sign v >= 0 then (fun q -> q), root_default_num v n else Q.minus, root_exces_num (Q.minus v) n in match s with | None -> Minfty | Some s -> let s = sign s in if is_int then let cs = Q.ceiling s in let cs2 = Q.power cs n in if Q.compare v cs2 <= 0 then Large (cs, e) else Large (Q.add cs Q.one, e) else Large (s, e) let root_exces_borne is_int x n = match x with | Pinfty -> Pinfty | Minfty -> Minfty | Large (v, e) | Strict (v, e) -> let sign, s = if Q.sign v >= 0 then (fun d -> d), root_exces_num v n else Q.minus, root_default_num (Q.minus v) n in match s with | None -> Pinfty | Some s -> let s = sign s in if is_int then let cs = Q.floor s in let cs2 = Q.power cs n in if Q.compare v cs2 >= 0 then Large (cs, e) else Large (Q.sub cs Q.one, e) else Large (s, e) let sqrt_interval is_int (l, ex) (b1,b2) = let l1 = minus_borne (root_exces_borne is_int b2 2) in let u1 = minus_borne (root_default_borne is_int b1 2) in let l2 = root_default_borne is_int b1 2 in let u2 = root_exces_borne is_int b2 2 in let c1 = compare_bornes l1 u1 in let c2 = compare_bornes l2 u2 in if c1 > 0 then if c2 > 0 then l, Ex.union ex (Ex.union (explain_borne b1) (explain_borne b2)) else (l2,u2)::l, ex else if c2 > 0 then (l1, u1)::l, ex else (union_bornes is_int [(l1,u1); (l2, u2)]) @ l, ex let sqrt {ints = l; is_int = is_int; expl} = Options.tool_req 4 "TR-Arith-Axiomes sqrt"; let l, expl = List.fold_left (sqrt_interval is_int) ([], expl) l in if l == [] then raise (NotConsistent expl); let res = union_intervals { ints = l; is_int; expl} in assert (res.ints != []); res let root_interval is_int (b1,b2) n = let u,l = (root_default_borne is_int b1 n, root_exces_borne is_int b2 n) in if compare_bornes u l <= 0 then Int(u,l) else Empty (Ex.union (explain_borne b1) (explain_borne b2)) let rec root n ({ints = l; is_int = is_int; expl } as u) = Options.tool_req 4"TR-Arith-Axiomes root"; if n mod 2 = 0 then root (n/2) (sqrt u) else let l = List.rev_map (fun bs -> root_interval is_int bs n) l in let l = join (List.rev l) expl in let res = union_intervals {u with ints = l; is_int = is_int} in assert (res.ints != []); res let inv_borne_inf b is_int ~other = match b with | Pinfty -> assert false | Minfty -> if is_int then Large (Q.zero, explain_borne other) else Strict (Q.zero, explain_borne other) | Strict (c, e) | Large (c, e) when Q.sign c = 0 -> Pinfty | Strict (v, e) -> Strict (Q.div Q.one v, e) | Large (v, e) -> Large (Q.div Q.one v, e) let inv_borne_sup b is_int ~other = match b with | Minfty -> assert false | Pinfty -> if is_int then Large (Q.zero, explain_borne other) else Strict (Q.zero, explain_borne other) | Strict (c, e) | Large (c, e) when Q.sign c = 0 -> Minfty | Strict (v, e) -> Strict (Q.div Q.one v, e) | Large (v, e) -> Large (Q.div Q.one v, e) let inv_bornes (l, u) is_int = inv_borne_sup u is_int ~other:l, inv_borne_inf l is_int ~other:u let inv ({ints=l; is_int=is_int} as u) = match doesnt_contain_0 u with | Sig.No -> { u with ints = [Minfty, Pinfty] } | Sig.Yes (ex, _) -> let l' = List.fold_left (fun acc (l,u) -> let l = add_expl_to_borne l ex in let u = add_expl_to_borne u ex in (inv_bornes (l, u) is_int) :: acc ) [] l in assert (l' != []); (* ! SHOULD NOT try to simplify here if is_int is true *) union_intervals { u with ints = l' } type sign_of_interval = Zero | Pos | Neg | Mixed let sign_of_interval {ints} = match ints, List.rev ints with | [], _ | _, [] -> assert false | (inf, _)::_, (_,sup)::_ -> match inf, sup with | Pinfty, _ | _, Minfty -> assert false | Minfty, Pinfty -> Mixed | Large(v,_), Large(v',_) -> if Q.compare v Q.zero > 0 then Pos else if Q.compare v' Q.zero < 0 then Neg else if Q.is_zero v && Q.is_zero v' then Zero else Mixed | (Strict(v,_) | Large(v,_)), (Strict(v',_) | Large(v',_)) -> if Q.compare v Q.zero >= 0 then Pos else if Q.compare v' Q.zero <= 0 then Neg else Mixed | (Strict(v,_) | Large(v,_)), Pinfty -> if Q.compare v Q.zero >= 0 then Pos else Mixed | Minfty, (Strict(v',_) | Large(v',_)) -> if Q.compare v' Q.zero <= 0 then Neg else Mixed let div i1 i2 = Options.tool_req 4 "TR-Arith-Axiomes div"; let inv_i2 = inv i2 in if is_undefined inv_i2 then inv_i2 else let i1 = match doesnt_contain_0 i2 with | Sig.Yes (ex, _) -> add_expl_zero i1 ex | Sig.No -> i1 in let ({ints=l; is_int=is_int} as i) = mult i1 inv_i2 in assert (l != []); if is_int then (* not just int_bornes because it's Euclidean division *) let min_f, max_f = match sign_of_interval i2 with | Zero -> assert false (* inv_i2 is not undefined *) | Pos -> Q.floor, Q.floor | Neg -> Q.ceiling, Q.ceiling | Mixed -> Q.floor, Q.ceiling in let rl = List.rev_map (fun (l,u) -> int_div_bornes min_f max_f l u) l in union_intervals { i with ints = List.rev rl } else { i with ints = l } let abs = let zero_inf_r = new_borne_inf Ex.empty Q.zero true (undefined Ty.Treal) in let zero_inf_i = new_borne_inf Ex.empty Q.zero true (undefined Ty.Tint) in fun i -> let xx = if i.is_int then zero_inf_i else zero_inf_r in intersect (merge i (scale Q.m_one i)) xx let mk_closed l u llarge ularge lexp uexp ty = let lb = if llarge then Large(l, lexp) else Strict (l, lexp) in let ub = if ularge then Large(u, uexp) else Strict (u, uexp) in { ints = [lb, ub]; is_int = ty == Ty.Tint; expl = Ex.union lexp uexp } type bnd = (Numbers.Q.t * Numbers.Q.t) option * Explanation.t let bnd_of_borne b ex0 low = match b with | Pinfty when not low -> None, ex0 | Minfty when low -> None, ex0 | Pinfty | Minfty -> assert false | Large (c, ex) -> Some (c, Q.zero), Ex.union ex0 ex | Strict (c, ex) -> Some (c, if low then Q.one else Q.m_one), Ex.union ex0 ex let bounds_of env = let ex = env.expl in match env.ints with | [] -> [(None, ex), (None, ex)] | l -> List.rev (List.rev_map (fun (b1, b2) -> bnd_of_borne b1 ex true, bnd_of_borne b2 ex false) l) let add_explanation i ex = if Ex.is_empty ex then i else let rl = List.rev_map (fun (l, u) -> add_expl_to_borne l ex, add_expl_to_borne u ex) i.ints in {i with ints = List.rev rl; expl = Ex.union i.expl ex} let equal i1 i2 = try List.iter2 (fun (b1,c1) (b2,c2) -> if compare_bounds b1 ~is_low1:true b2 ~is_low2:true <> 0 || compare_bounds c1 ~is_low1:false c2 ~is_low2:false <> 0 then raise Exit )i1.ints i2.ints; true with Exit | Invalid_argument _ -> false let min_bound {ints; is_int; expl} = match ints with | [] -> assert false | (b, _) :: _ -> b let max_bound {ints; is_int; expl} = match List.rev ints with | [] -> assert false | (_, b) :: _ -> b type interval_matching = ((Q.t * bool) option * (Q.t * bool) option * Ty.t) Hstring.Map.t module MH = Hstring.Map module Sy = Symbols let is_question_mark = let qm = Hstring.make "?" in fun s -> Hstring.equal qm s let consistent_bnds low up = match low, up with | Some (q_low, str_low), Some (q_up, str_up) -> let c = Q.compare q_up q_low in c > 0 || (c = 0 && not str_low && not str_up) | _ -> true let new_up_bound idoms s ty q is_strict = let old_low, old_up, ty = try MH.find s idoms with Not_found -> None,None,ty in let new_up = match old_up with | None -> Some (q, is_strict) | Some (r, str) -> let c = Q.compare r q in if c < 0 then old_up else if c > 0 then Some (q, is_strict) else if is_strict == str || is_strict then old_up else Some (q, is_strict) in if new_up == old_up then idoms else if consistent_bnds old_low new_up then MH.add s (old_low, new_up, ty) idoms else raise Exit let new_low_bound idoms s ty q is_strict = let old_low, old_up, ty = try MH.find s idoms with Not_found -> None,None,ty in let new_low = match old_low with | None -> Some (q, is_strict) | Some (r, str) -> let c = Q.compare r q in if c > 0 then old_low else if c < 0 then Some (q, is_strict) else if is_strict == str || is_strict then old_low else Some (q, is_strict) in if new_low == old_low then idoms else if consistent_bnds new_low old_up then MH.add s (new_low, old_up, ty) idoms else raise Exit let new_var idoms s ty = if MH.mem s idoms then idoms else MH.add s (None, None, ty) idoms let match_interval_upper {Sy.sort; is_open; kind; is_lower} i imatch = assert (not is_lower); match kind, max_bound i with | Sy.VarBnd s, _ when is_question_mark s -> imatch (* ? var *) | Sy.VarBnd s, Minfty -> assert false | Sy.VarBnd s, Pinfty -> new_var imatch s sort | Sy.VarBnd s, Strict (v, _) -> new_low_bound imatch s sort v false | Sy.VarBnd s, Large (v, _) -> new_low_bound imatch s sort v is_open | Sy.ValBnd vl, Minfty -> assert false | Sy.ValBnd vl, Pinfty -> raise Exit | Sy.ValBnd vl, Strict (v, _) -> let c = Q.compare v vl in if c > 0 then raise Exit; imatch | Sy.ValBnd vl, Large (v, _) -> let c = Q.compare v vl in if c > 0 || c = 0 && is_open then raise Exit; imatch let match_interval_lower {Sy.sort; is_open; kind; is_lower} i imatch = assert (is_lower); match kind, min_bound i with | Sy.VarBnd s, _ when is_question_mark s -> imatch (* ? var *) | Sy.VarBnd s, Pinfty -> assert false | Sy.VarBnd s, Minfty -> new_var imatch s sort | Sy.VarBnd s, Strict (v, _) -> new_up_bound imatch s sort v false | Sy.VarBnd s, Large (v, _) -> new_up_bound imatch s sort v is_open | Sy.ValBnd vl, Minfty -> raise Exit | Sy.ValBnd vl, Pinfty -> assert false | Sy.ValBnd vl, Strict (v, _) -> let c = Q.compare v vl in if c < 0 then raise Exit; imatch | Sy.ValBnd vl, Large (v, _) -> let c = Q.compare v vl in if c < 0 || c = 0 && is_open then raise Exit; imatch let match_interval lb ub i accu = try Some (match_interval_upper ub i (match_interval_lower lb i accu)) with Exit -> None (*****************) (* Some debug code for Intervals: commented by default let no_inclusion = let not_included (b1, c1) (b2, c2) = not ( compare_bounds b1 ~is_low1:true b2 ~is_low2:true >= 0 && compare_bounds c1 ~is_low1:false c2 ~is_low2:false <= 0 ) in let b_inc_list d l = List.iter (fun e -> assert (not_included d e); assert (not_included e d) ) l in let rec aux todo = match todo with | [] -> assert false | [e] -> () | d::l -> b_inc_list d l; aux l in fun i -> (*fprintf fmt "[no_inclusion] i = %a@." print i;*) aux i.ints let not_mergeable = let rec aux is_int l = match l with | [] -> assert false | [e] -> () | (_,a)::(((b,_)::_) as l) -> begin match a, b with | Minfty, _ | _, Pinfty -> assert false (*should not happen*) | Pinfty, _ | _, Minfty -> assert false (*should not happen or not norm*) | Large(q1,_) , Large(q2,_) -> assert (Q.compare q1 q2 < 0); (* otherwise, we can merge *) if is_int then (* the gap between q1 and q2 should be > 1. Otherwise, we can merge *) assert (Q.compare (Q.sub q2 q1) Q.one > 0) | Strict(q1,_), Large(q2,_) -> assert (not is_int); assert (Q.compare q1 q2 < 0) (* otherwise, we can merge *) | Large(q1,_) , Strict(q2,_) -> assert (not is_int); assert (Q.compare q1 q2 < 0) (* otherwise, we can merge *) | Strict(q1,_) , Strict(q2,_) -> assert (not is_int); assert (Q.compare q1 q2 <= 0) (* otherwise, we can merge *) end; aux is_int l; in fun i -> (*fprintf fmt "[no_mergeable] i = %a@." print i;*) aux i.is_int i.ints let assert_is_normalized i = not_mergeable i; no_inclusion i; i let exclude i j = try let k = exclude i j in k |> assert_is_normalized with Assert_failure _ -> assert false let intersect i j = try let k = intersect i j in k |> assert_is_normalized with Assert_failure _ -> assert false let mult i j = try mult i j |> assert_is_normalized with Assert_failure _ -> assert false let power i j = try power i j |> assert_is_normalized with Assert_failure _ -> assert false let sqrt i = try sqrt i |> assert_is_normalized with Assert_failure _ -> assert false let root n i = try root n i |> assert_is_normalized with Assert_failure _ -> assert false let add i j = try (*fprintf fmt "@.i = %a@." print i; fprintf fmt "j = %a@." print j;*) let k = add i j in (*fprintf fmt "res = %a@." print k;*) k |> assert_is_normalized with Assert_failure _ -> assert false let scale q i = try scale q i |> assert_is_normalized with Assert_failure _ -> assert false let sub i j = try sub i j |> assert_is_normalized with Assert_failure _ -> assert false let merge i j = try merge i j |> assert_is_normalized with Assert_failure _ -> assert false let abs i = try abs i |> assert_is_normalized with Assert_failure _ -> assert false let div i j = try div i j |> assert_is_normalized with Assert_failure _ -> assert false *) alt-ergo-free-2.0.0/lib/reasoners/sum.mli0000664000175000017500000000471213430774474016037 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) type 'a abstract module type ALIEN = sig include Sig.X val embed : r abstract -> r val extract : r -> (r abstract) option end module Shostak (X : ALIEN) : Sig.SHOSTAK with type r = X.r and type t = X.r abstract module Relation (X : ALIEN) (Uf : Uf.S) : Sig.RELATION with type r = X.r and type uf = Uf.t alt-ergo-free-2.0.0/lib/reasoners/combine.mli0000664000175000017500000000450413430774474016646 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) module Shostak : Sig.X module Use : Use.S with type r = Shostak.r module Uf : Uf.S with type r = Shostak.r module Relation : Sig.RELATION with type r = Shostak.r and type uf = Uf.t alt-ergo-free-2.0.0/lib/reasoners/records.ml0000664000175000017500000003366513430774474016534 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Format open Options open Sig module Hs = Hstring module T = Term type ('a, 'b) mine = Yes of 'a | No of 'b type 'a abstract = | Record of (Hs.t * 'a abstract) list * Ty.t | Access of Hs.t * 'a abstract * Ty.t | Other of 'a * Ty.t module type ALIEN = sig include Sig.X val embed : r abstract -> r val extract : r -> (r abstract) option end module Shostak (X : ALIEN) = struct module XS = Set.Make(struct type t = X.r let compare = X.hash_cmp end) let name = "records" type t = X.r abstract type r = X.r (*BISECT-IGNORE-BEGIN*) module Debug = struct let rec print fmt = function | Record (lbs, _) -> fprintf fmt "{"; let _ = List.fold_left (fun first (lb, e) -> fprintf fmt "%s%s = %a" (if first then "" else "; ") (Hs.view lb) print e; false ) true lbs in fprintf fmt "}" | Access(a, e, _) -> fprintf fmt "%a.%s" print e (Hs.view a) | Other(t, _) -> X.print fmt t end (*BISECT-IGNORE-END*) let print = Debug.print let rec raw_compare r1 r2 = match r1, r2 with | Other (u1, ty1), Other (u2, ty2) -> let c = Ty.compare ty1 ty2 in if c <> 0 then c else X.str_cmp u1 u2 | Other _, _ -> -1 | _, Other _ -> 1 | Access (s1, u1, ty1), Access (s2, u2, ty2) -> let c = Ty.compare ty1 ty2 in if c <> 0 then c else let c = Hs.compare s1 s2 in if c <> 0 then c else raw_compare u1 u2 | Access _, _ -> -1 | _, Access _ -> 1 | Record (lbs1, ty1), Record (lbs2, ty2) -> let c = Ty.compare ty1 ty2 in if c <> 0 then c else raw_compare_list lbs1 lbs2 and raw_compare_list l1 l2 = match l1, l2 with | [], [] -> 0 | [], _ -> 1 | _, [] -> -1 | (_, x1)::l1, (_, x2)::l2 -> let c = raw_compare x1 x2 in if c<>0 then c else raw_compare_list l1 l2 let rec normalize v = match v with | Record (lbs, ty) -> begin let lbs_n = List.map (fun (lb, x) -> lb, normalize x) lbs in match lbs_n with | (lb1, Access(lb2, x, _)) :: l when Hs.equal lb1 lb2 -> if List.for_all (function | (lb1, Access(lb2, y, _)) -> Hs.equal lb1 lb2 && raw_compare x y = 0 | _ -> false) l then x else Record (lbs_n, ty) | _ -> Record (lbs_n, ty) end | Access (a, x, ty) -> begin match normalize x with | Record (lbs, _) -> Hs.list_assoc a lbs | x_n -> Access (a, x_n, ty) end | Other _ -> v let embed r = match X.extract r with | Some p -> p | None -> Other(r, X.type_info r) let compare_mine t u = raw_compare (normalize t) (normalize u) let compare x y = compare_mine (embed x) (embed y) let rec equal r1 r2 = match r1, r2 with | Other (u1, ty1), Other (u2, ty2) -> Ty.equal ty1 ty2 && X.equal u1 u2 | Access (s1, u1, ty1), Access (s2, u2, ty2) -> Hs.equal s1 s2 && Ty.equal ty1 ty2 && equal u1 u2 | Record (lbs1, ty1), Record (lbs2, ty2) -> Ty.equal ty1 ty2 && equal_list lbs1 lbs2 | Other _, _ | _, Other _ | Access _, _ | _, Access _ -> false and equal_list l1 l2 = try List.for_all2 (fun (_,r1) (_,r2) -> equal r1 r2) l1 l2 with Invalid_argument _ -> false let is_mine t = match normalize t with | Other(r, _) -> r | x -> X.embed x let type_info = function | Record (_, ty) | Access (_, _, ty) | Other (_, ty) -> ty let make t = let rec make_rec t ctx = let { T.f = f; xs = xs; ty = ty} = T.view t in match f, ty with | Symbols.Op (Symbols.Record), Ty.Trecord {Ty.lbs=lbs} -> assert (List.length xs = List.length lbs); let l, ctx = List.fold_right2 (fun x (lb, _) (l, ctx) -> let r, ctx = make_rec x ctx in let tyr = type_info r in let dlb = T.make (Symbols.Op (Symbols.Access lb)) [t] tyr in let c = Literal.LT.mk_eq dlb x in (lb, r)::l, c::ctx ) xs lbs ([], ctx) in Record (l, ty), ctx | Symbols.Op (Symbols.Access a), _ -> begin match xs with | [x] -> let r, ctx = make_rec x ctx in Access (a, r, ty), ctx | _ -> assert false end | _, _ -> let r, ctx' = X.make t in Other (r, ty), ctx'@ctx in let r, ctx = make_rec t [] in let is_m = is_mine r in is_m, ctx let color _ = assert false let embed r = match X.extract r with | Some p -> p | None -> Other(r, X.type_info r) let xs_of_list = List.fold_left (fun s x -> XS.add x s) XS.empty let leaves t = let rec leaves t = match normalize t with | Record (lbs, _) -> List.fold_left (fun s (_, x) -> XS.union (leaves x) s) XS.empty lbs | Access (_, x, _) -> leaves x | Other (x, _) -> xs_of_list (X.leaves x) in XS.elements (leaves t) let rec hash = function | Record (lbs, ty) -> List.fold_left (fun h (lb, x) -> 17 * hash x + 13 * Hs.hash lb + h) (Ty.hash ty) lbs | Access (a, x, ty) -> 19 * hash x + 17 * Hs.hash a + Ty.hash ty | Other (x, ty) -> Ty.hash ty + 23 * X.hash x let rec subst_rec p v r = match r with | Other (t, ty) -> embed (if X.equal p t then v else X.subst p v t) | Access (a, t, ty) -> Access (a, subst_rec p v t, ty) | Record (lbs, ty) -> let lbs = List.map (fun (lb, t) -> lb, subst_rec p v t) lbs in Record (lbs, ty) let subst p v r = is_mine (subst_rec p v r) let is_mine_symb = function | Symbols.Op (Symbols.Record | Symbols.Access _) -> true | _ -> false let abstract_access field e ty acc = let xe = is_mine e in let abs_right_xe, acc = try List.assoc xe acc, acc with Not_found -> let left_abs_xe2, acc = X.abstract_selectors xe acc in match X.type_info left_abs_xe2 with | (Ty.Trecord { Ty.args=args; name=name; lbs=lbs }) as tyr -> let flds = List.map (fun (lb,ty) -> lb, embed (X.term_embed (T.fresh_name ty))) lbs in let record = is_mine (Record (flds, tyr)) in record, (left_abs_xe2, record) :: acc | _ -> assert false in let abs_access = normalize (Access (field, embed abs_right_xe, ty)) in is_mine abs_access, acc let abstract_selectors v acc = match v with (* Handled by combine. Should not happen! *) | Other (r, ty) -> assert false (* This is not a selector *) | Record (fields,ty) -> let flds, acc = List.fold_left (fun (flds,acc) (lbl,e) -> let e, acc = X.abstract_selectors (is_mine e) acc in (lbl, embed e)::flds, acc )([], acc) fields in is_mine (Record (List.rev flds, ty)), acc (* Selector ! Interesting case !*) | Access (field, e, ty) -> abstract_access field e ty acc (* Shostak'pair solver adapted to records *) let mk_fresh_record x info = let ty = type_info x in let lbs = match ty with Ty.Trecord r -> r.Ty.lbs | _ -> assert false in let lbs = List.map (fun (lb, ty) -> match info with | Some (a, v) when Hs.equal lb a -> lb, v | _ -> let n = embed (X.term_embed (T.fresh_name ty)) in lb, n) lbs in Record (lbs, ty), lbs let rec occurs x = function | Record (lbs, _) -> List.exists (fun (_, v) -> occurs x v) lbs | Access (_, v, _) -> occurs x v | Other _ as v -> compare_mine x v = 0 (* XXX *) let direct_args_of_labels x = List.exists (fun (_, y)-> compare_mine x y = 0) let rec subst_access x s e = match e with | Record (lbs, ty) -> Record (List.map (fun (n,e') -> n, subst_access x s e') lbs, ty) | Access (lb, e', _) when compare_mine x e' = 0 -> Hs.list_assoc lb s | Access (lb', e', ty) -> Access (lb', subst_access x s e', ty) | Other _ -> e let rec find_list x = function | [] -> raise Not_found | (y, t) :: _ when compare_mine x y = 0 -> t | _ :: l -> find_list x l let split l = let rec split_rec acc = function | [] -> acc, [] | ((x, t) as v) :: l -> try acc, (t, find_list x acc) :: l with Not_found -> split_rec (v::acc) l in split_rec [] l let fully_interpreted _ = false let rec term_extract r = match X.extract r with | Some v -> begin match v with | Record (lbs, ty) -> begin try let lbs = List.map (fun (_, r) -> match term_extract (is_mine r) with | None, _ -> raise Not_found | Some t, _ -> t) lbs in Some (T.make (Symbols.Op Symbols.Record) lbs ty), false with Not_found -> None, false end | Access (a, r, ty) -> begin match X.term_extract (is_mine r) with | None, _ -> None, false | Some t, _ -> Some (T.make (Symbols.Op (Symbols.Access a)) [t] ty), false end | Other (r, _) -> X.term_extract r end | None -> X.term_extract r let orient_solved p v pb = if List.mem p (X.leaves v) then raise Exception.Unsolvable; { pb with sbt = (p,v) :: pb.sbt } let solve r1 r2 pb = match embed r1, embed r2 with | Record (l1, _), Record (l2, _) -> let eqs = List.fold_left2 (fun eqs (a,b) (x,y) -> assert (Hs.compare a x = 0); (is_mine y, is_mine b) :: eqs )pb.eqs l1 l2 in {pb with eqs=eqs} | Other (a1,_), Other (a2,_) -> if X.str_cmp r1 r2 > 0 then { pb with sbt = (r1,r2)::pb.sbt } else { pb with sbt = (r2,r1)::pb.sbt } | Other (a1,_), Record (l2, _) -> orient_solved r1 r2 pb | Record (l1, _), Other (a2,_) -> orient_solved r2 r1 pb | Access _ , _ -> assert false | _ , Access _ -> assert false let make t = if Options.timers() then try Timers.exec_timer_start Timers.M_Records Timers.F_make; let res = make t in Timers.exec_timer_pause Timers.M_Records Timers.F_make; res with e -> Timers.exec_timer_pause Timers.M_Records Timers.F_make; raise e else make t let solve r1 r2 pb = if Options.timers() then try Timers.exec_timer_start Timers.M_Records Timers.F_solve; let res = solve r1 r2 pb in Timers.exec_timer_pause Timers.M_Records Timers.F_solve; res with e -> Timers.exec_timer_pause Timers.M_Records Timers.F_solve; raise e else solve r1 r2 pb let assign_value t _ eq = match embed t with | Access _ -> None | Record (_, ty) -> if List.exists (fun (t,_) -> (Term.view t).Term.depth = 1) eq then None else Some (Term.fresh_name ty, false) | Other (_,ty) -> match ty with | Ty.Trecord {Ty.args; name; lbs} -> let rev_lbs = List.rev_map (fun (hs, ty) -> Term.fresh_name ty) lbs in let s = Term.make (Symbols.Op Symbols.Record) (List.rev rev_lbs) ty in Some (s, false) (* false <-> not a case-split *) | _ -> assert false let choose_adequate_model t _ l = let acc = List.fold_left (fun acc (s, r) -> if (Term.view s).Term.depth <> 1 then acc else match acc with | Some(s', r') when Term.compare s' s > 0 -> acc | _ -> Some (s, r) ) None l in match acc with | Some (_,r) -> ignore (flush_str_formatter ()); fprintf str_formatter "%a" X.print r; (* it's a EUF constant *) r, flush_str_formatter () | _ -> assert false end module Relation (X : ALIEN) (Uf : Uf.S) = struct type r = X.r type uf = Uf.t type t = unit exception Inconsistent let empty _ = () let assume _ _ _ = (), { assume = []; remove = []} let query _ _ _ = Sig.No let case_split env _ ~for_model = [] let add env _ _ _ = env let print_model _ _ _ = () let new_terms env = T.Set.empty let instantiate ~do_syntactic_matching _ env uf _ = env, [] let retrieve_used_context _ _ = [], [] let assume_th_elt t th_elt = match th_elt.Commands.extends with | Typed.Records -> failwith "This Theory does not support theories extension" | _ -> t end alt-ergo-free-2.0.0/lib/reasoners/use.mli0000664000175000017500000000517213430774474016030 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) module SA : Set.S with type elt = Literal.LT.t * Explanation.t module type S = sig type t type r val empty : t val find : r -> t -> Term.Set.t * SA.t val add : r -> Term.Set.t * SA.t -> t -> t val mem : r -> t -> bool val print : t -> unit val up_add : t -> Term.t -> r -> r list -> t val congr_add : t -> r list -> Term.Set.t val up_close_up :t -> r -> r -> t val congr_close_up : t -> r -> r list -> Term.Set.t * SA.t end module Make (X : Sig.X) : S with type r = X.r alt-ergo-free-2.0.0/lib/reasoners/matching_types.mli0000664000175000017500000000625113430774474020251 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) type gsubst = { sbs : Term.t Term.Subst.t; sty : Ty.subst; gen : int ; (* l'age d'une substitution est l'age du plus vieux terme qu'elle contient *) goal : bool; (* vrai si la substitution contient un terme ayant un lien avec le but de la PO *) s_term_orig : Term.t list; s_lem_orig : Formula.t; } type trigger_info = { trigger : Formula.trigger; trigger_age : int ; (* age d'un trigger *) trigger_orig : Formula.t ; (* lemme d'origine *) trigger_formula : Formula.t ; (* formule associee au trigger *) trigger_dep : Explanation.t ; } type term_info = { term_age : int ; (* age du terme *) term_from_goal : bool ; (* vrai si le terme provient du but de la PO *) term_from_formula : Formula.t option; (* lemme d'origine du terme *) term_from_terms : Term.t list; } type info = { age : int ; (* age du terme *) lem_orig : Formula.t list ; (* lemme d'ou provient eventuellement le terme *) t_orig : Term.t list; but : bool (* le terme a-t-il un lien avec le but final de la PO *) } alt-ergo-free-2.0.0/lib/reasoners/.merlin0000664000175000017500000000000413430774474016005 0ustar mimiREC alt-ergo-free-2.0.0/lib/reasoners/arrays.ml0000664000175000017500000004273613430774474016373 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Options open Format open Sig module Sy = Symbols module T = Term module A = Literal module L = List type 'a abstract = unit module type ALIEN = sig include Sig.X val embed : r abstract -> r val extract : r -> (r abstract) option end module Shostak (X : ALIEN) = struct type t = X.r abstract type r = X.r let name = "Farrays" let is_mine_symb _ = false let fully_interpreted sb = assert false let type_info _ = assert false let color _ = assert false let print _ _ = assert false let embed _ = assert false let is_mine _ = assert false let compare _ _ = assert false let equal _ _ = assert false let hash _ = assert false let leaves _ = assert false let subst _ _ _ = assert false let make _ = assert false let term_extract _ = None, false let abstract_selectors p acc = assert false let solve r1 r2 = assert false let assign_value r _ eq = if List.exists (fun (t,_) -> (Term.view t).Term.depth = 1) eq then None else match X.term_extract r with | Some t, true -> Some (Term.fresh_name (X.type_info r), false) | _ -> assert false let choose_adequate_model t _ l = let acc = List.fold_left (fun acc (s, r) -> if (Term.view s).Term.depth <> 1 then acc else match acc with | Some(s', r') when Term.compare s' s > 0 -> acc | _ -> Some (s, r) ) None l in match acc with | Some (_, r) -> ignore (flush_str_formatter ()); fprintf str_formatter "%a" X.print r; (* it's a EUF constant *) r, flush_str_formatter () | _ -> assert false end module Relation (X : ALIEN) (Uf : Uf.S) = struct open Sig module Ex = Explanation type r = X.r type uf = Uf.t module LR = Literal.Make(struct type t = X.r let compare = X.hash_cmp include X end) (* map get |-> { set } des associations (get,set) deja splites *) module Tmap = struct include T.Map let update t a mp = try add t (T.Set.add a (find t mp)) mp with Not_found -> add t (T.Set.singleton a) mp let splited t a mp = try T.Set.mem a (find t mp) with Not_found -> false end module LRset= LR.Set module Conseq = Set.Make (struct type t = A.LT.t * Ex.t let compare (lt1,_) (lt2,_) = A.LT.compare lt1 lt2 end) (* map k |-> {sem Atom} d'egalites/disegalites sur des atomes semantiques*) module LRmap = struct include LR.Map let find k mp = try find k mp with Not_found -> Conseq.empty let add k v ex mp = add k (Conseq.add (v,ex) (find k mp)) mp end type gtype = {g:Term.t; gt:Term.t; gi:Term.t; gty:Ty.t} module G :Set.S with type elt = gtype = Set.Make (struct type t = gtype let compare t1 t2 = T.compare t1.g t2.g end) (* ensemble de termes "set" avec leurs arguments et leurs types *) type stype = {s:T.t; st:T.t; si:T.t; sv:T.t; sty:Ty.t} module S :Set.S with type elt = stype = Set.Make (struct type t = stype let compare t1 t2 = T.compare t1.s t2.s end) (* map t |-> {set(t,-,-)} qui associe a chaque tableau l'ensemble de ses affectations *) module TBS = struct include Map.Make(T) let find k mp = try find k mp with Not_found -> S.empty (* add reutilise find ci-dessus *) let add k v mp = add k (S.add v (find k mp)) mp end type t = {gets : G.t; (* l'ensemble des "get" croises*) tbset : S.t TBS.t ; (* map t |-> set(t,-,-) *) split : LRset.t; (* l'ensemble des case-split possibles *) conseq : Conseq.t LRmap.t; (* consequences des splits *) seen : T.Set.t Tmap.t; (* combinaisons (get,set) deja splitees *) new_terms : T.Set.t; size_splits : Numbers.Q.t; } let empty _ = {gets = G.empty; tbset = TBS.empty; split = LRset.empty; conseq = LRmap.empty; seen = Tmap.empty; new_terms = T.Set.empty; size_splits = Numbers.Q.one; } (*BISECT-IGNORE-BEGIN*) module Debug = struct let assume fmt la = if debug_arrays () && la != [] then begin fprintf fmt "[Arrays.Rel] We assume@."; L.iter (fun (a,_,_,_) -> fprintf fmt " > %a@." LR.print (LR.make a)) la; end let print_gets fmt = G.iter (fun t -> fprintf fmt "%a@." T.print t.g) let print_sets fmt = S.iter (fun t -> fprintf fmt "%a@." T.print t.s) let print_splits fmt = LRset.iter (fun a -> fprintf fmt "%a@." LR.print a) let print_tbs fmt = TBS.iter (fun k v -> fprintf fmt "%a --> %a@." T.print k print_sets v) let env fmt env = if debug_arrays () then begin fprintf fmt "-- gets ----------------------------------------@."; print_gets fmt env.gets; fprintf fmt "-- tabs of sets --------------------------------@."; print_tbs fmt env.tbset; fprintf fmt "-- splits --------------------------------------@."; print_splits fmt env.split; fprintf fmt "------------------------------------------------@." end let new_equalities fmt st = if debug_arrays () then begin fprintf fmt "[Arrays] %d implied equalities@." (Conseq.cardinal st); Conseq.iter (fun (a,ex) -> fprintf fmt " %a : %a@." A.LT.print a Ex.print ex) st end let case_split a = if debug_arrays () then fprintf fmt "[Arrays.case-split] %a@." LR.print a let case_split_none () = if debug_arrays () then fprintf fmt "[Arrays.case-split] Nothing@." end (*BISECT-IGNORE-END*) (* met a jour gets et tbset en utilisant l'ensemble des termes donne*) let rec update_gets_sets acc t = let {T.f=f;xs=xs;ty=ty} = T.view t in let gets, tbset = List.fold_left update_gets_sets acc xs in match Sy.is_get f, Sy.is_set f, xs with | true , false, [a;i] -> G.add {g=t; gt=a; gi=i; gty=ty} gets, tbset | false, true , [a;i;v] -> gets, TBS.add a {s=t; st=a; si=i; sv=v; sty=ty} tbset | false, false, _ -> (gets,tbset) | _ -> assert false (* met a jour les composantes gets et tbset de env avec les termes contenus dans les atomes de la *) let new_terms env la = let fct acc r = List.fold_left (fun acc x -> match X.term_extract x with | Some t, _ -> update_gets_sets acc t | None, _ -> acc )acc (X.leaves r) in let gets, tbset = L.fold_left (fun acc (a,_,_,_)-> match a with | A.Eq (r1,r2) -> fct (fct acc r1) r2 | A.Builtin (_,_,l) | A.Distinct (_, l) -> L.fold_left fct acc l | A.Pred (r1,_) -> fct acc r1 ) (env.gets,env.tbset) la in {env with gets=gets; tbset=tbset} (* mise a jour de env avec les instances 1) p => p_ded 2) n => n_ded *) let update_env are_eq are_dist dep env acc gi si p p_ded n n_ded = match are_eq gi si, are_dist gi si with | Sig.Yes (idep, _) , Sig.No -> let conseq = LRmap.add n n_ded dep env.conseq in {env with conseq = conseq}, Conseq.add (p_ded, Ex.union dep idep) acc | Sig.No, Sig.Yes (idep, _) -> let conseq = LRmap.add p p_ded dep env.conseq in {env with conseq = conseq}, Conseq.add (n_ded, Ex.union dep idep) acc | Sig.No, Sig.No -> let sp = LRset.add p env.split in let conseq = LRmap.add p p_ded dep env.conseq in let conseq = LRmap.add n n_ded dep conseq in { env with split = sp; conseq = conseq }, acc | Sig.Yes _, Sig.Yes _ -> assert false (*---------------------------------------------------------------------- get(set(-,-,-),-) modulo egalite ---------------------------------------------------------------------*) let get_of_set are_eq are_dist gtype (env,acc) class_of = let {g=get; gt=gtab; gi=gi; gty=gty} = gtype in L.fold_left (fun (env,acc) set -> if Tmap.splited get set env.seen then (env,acc) else let env = {env with seen = Tmap.update get set env.seen} in let {T.f=f;xs=xs;ty=sty} = T.view set in match Sy.is_set f, xs with | true , [stab;si;sv] -> let xi, _ = X.make gi in let xj, _ = X.make si in let get_stab = T.make (Sy.Op Sy.Get) [stab;gi] gty in let p = LR.mk_eq xi xj in let p_ded = A.LT.mk_eq get sv in let n = LR.mk_distinct false [xi;xj] in let n_ded = A.LT.mk_eq get get_stab in let dep = match are_eq gtab set with Yes (dep, _) -> dep | No -> assert false in let env = {env with new_terms = T.Set.add get_stab env.new_terms } in update_env are_eq are_dist dep env acc gi si p p_ded n n_ded | _ -> (env,acc) ) (env,acc) (class_of gtab) (*---------------------------------------------------------------------- set(-,-,-) modulo egalite ---------------------------------------------------------------------*) let get_from_set are_eq are_dist stype (env,acc) class_of = let {s=set; st=stab; si=si; sv=sv; sty=sty} = stype in let ty_si = (T.view sv).T.ty in let stabs = L.fold_left (fun acc t -> S.union acc (TBS.find t env.tbset)) S.empty (class_of stab) in S.fold (fun stab' (env,acc) -> let get = T.make (Sy.Op Sy.Get) [set; si] ty_si in if Tmap.splited get set env.seen then (env,acc) else let env = {env with seen = Tmap.update get set env.seen; new_terms = T.Set.add get env.new_terms } in let p_ded = A.LT.mk_eq get sv in env, Conseq.add (p_ded, Ex.empty) acc ) stabs (env,acc) (*---------------------------------------------------------------------- get(t,-) and set(t,-,-) modulo egalite ---------------------------------------------------------------------*) let get_and_set are_eq are_dist gtype (env,acc) class_of = let {g=get; gt=gtab; gi=gi; gty=gty} = gtype in let suff_sets = L.fold_left (fun acc t -> S.union acc (TBS.find t env.tbset)) S.empty (class_of gtab) in S.fold (fun {s=set; st=stab; si=si; sv=sv; sty=sty} (env,acc) -> if Tmap.splited get set env.seen then (env,acc) else begin let env = {env with seen = Tmap.update get set env.seen} in let xi, _ = X.make gi in let xj, _ = X.make si in let get_stab = T.make (Sy.Op Sy.Get) [stab;gi] gty in let gt_of_st = T.make (Sy.Op Sy.Get) [set;gi] gty in let p = LR.mk_eq xi xj in let p_ded = A.LT.mk_eq gt_of_st sv in let n = LR.mk_distinct false [xi;xj] in let n_ded = A.LT.mk_eq gt_of_st get_stab in let dep = match are_eq gtab stab with Yes (dep, _) -> dep | No -> assert false in let env = {env with new_terms = T.Set.add get_stab (T.Set.add gt_of_st env.new_terms) } in update_env are_eq are_dist dep env acc gi si p p_ded n n_ded end ) suff_sets (env,acc) (* Generer de nouvelles instantiations de lemmes *) let new_splits are_eq are_dist env acc class_of = let accu = G.fold (fun gt_info accu -> let accu = get_of_set are_eq are_dist gt_info accu class_of in get_and_set are_eq are_dist gt_info accu class_of ) env.gets (env,acc) in TBS.fold (fun _ tbs accu -> S.fold (fun stype accu -> get_from_set are_eq are_dist stype accu class_of) tbs accu ) env.tbset accu (* nouvelles disegalites par instantiation du premier axiome d'exentionnalite *) let extensionality accu la class_of = List.fold_left (fun ((env, acc) as accu) (a, _, dep,_) -> match a with | A.Distinct(false, [r;s]) -> begin match X.type_info r, X.term_extract r, X.term_extract s with | Ty.Tfarray (ty_k, ty_v), (Some t1, _), (Some t2, _) -> let i = T.fresh_name ty_k in let g1 = T.make (Sy.Op Sy.Get) [t1;i] ty_v in let g2 = T.make (Sy.Op Sy.Get) [t2;i] ty_v in let d = A.LT.mk_distinct false [g1;g2] in let acc = Conseq.add (d, dep) acc in let env = {env with new_terms = T.Set.add g2 (T.Set.add g1 env.new_terms) } in env, acc | _ -> accu end | _ -> accu ) accu la let implied_consequences env eqs la = let spl, eqs = L.fold_left (fun (spl,eqs) (a,_,dep,_) -> let a = LR.make a in let spl = LRset.remove (LR.neg a) (LRset.remove a spl) in let eqs = Conseq.fold (fun (fact,ex) acc -> Conseq.add (fact, Ex.union ex dep) acc) (LRmap.find a env.conseq) eqs in spl, eqs )(env.split, eqs) la in {env with split=spl}, eqs (* deduction de nouvelles dis/egalites *) let new_equalities env eqs la class_of = let la = L.filter (fun (a,_,_,_) -> match a with A.Builtin _ -> false | _ -> true) la in let env, eqs = extensionality (env, eqs) la class_of in implied_consequences env eqs la (* choisir une egalite sur laquelle on fait un case-split *) let two = Numbers.Q.from_int 2 let case_split env uf ~for_model = (*if Numbers.Q.compare (Numbers.Q.mult two env.size_splits) (max_split ()) <= 0 || Numbers.Q.sign (max_split ()) < 0 then*) try let a = LR.neg (LRset.choose env.split) in Debug.case_split a; [LR.view a, true, CS (Th_arrays, two)] with Not_found -> Debug.case_split_none (); [] let count_splits env la = let nb = List.fold_left (fun nb (_,_,_,i) -> match i with | CS (Th_arrays, n) -> Numbers.Q.mult nb n | _ -> nb )env.size_splits la in {env with size_splits = nb} let assume env uf la = let are_eq = Uf.are_equal uf ~added_terms:true in let are_neq = Uf.are_distinct uf in let class_of = Uf.class_of uf in let env = count_splits env la in (* instantiation des axiomes des tableaux *) Debug.assume fmt la; let env = new_terms env la in let env, atoms = new_splits are_eq are_neq env Conseq.empty class_of in let env, atoms = new_equalities env atoms la class_of in (*Debug.env fmt env;*) Debug.new_equalities fmt atoms; let l = Conseq.fold (fun (a,ex) l -> ((LTerm a, ex, Sig.Other)::l)) atoms [] in env, { assume = l; remove = [] } let assume env uf la = if Options.timers() then try Timers.exec_timer_start Timers.M_Arrays Timers.F_assume; let res =assume env uf la in Timers.exec_timer_pause Timers.M_Arrays Timers.F_assume; res with e -> Timers.exec_timer_pause Timers.M_Arrays Timers.F_assume; raise e else assume env uf la let query _ _ _ = Sig.No let add env _ r _ = env let print_model _ _ _ = () let new_terms env = env.new_terms let instantiate ~do_syntactic_matching _ env uf _ = env, [] let retrieve_used_context _ _ = [], [] let assume_th_elt t th_elt = match th_elt.Commands.extends with | Typed.Arrays -> failwith "This Theory does not support theories extension" | _ -> t end alt-ergo-free-2.0.0/lib/reasoners/polynome.mli0000664000175000017500000000756313430774474017104 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) open Numbers.Z open Numbers.Q exception Not_a_num exception Maybe_zero module type S = sig include Sig.X val mult : r -> r -> r end module type T = sig type r type t val compare : t -> t -> int val equal : t -> t -> bool val hash : t -> int val create : (Numbers.Q.t * r) list -> Numbers.Q.t -> Ty.t-> t val add : t -> t -> t val sub : t -> t -> t val mult : t -> t -> t val mult_const : Numbers.Q.t -> t -> t val add_const : Numbers.Q.t -> t -> t val div : t -> t -> t * bool val modulo : t -> t -> t val is_const : t -> Numbers.Q.t option val is_empty : t -> bool val find : r -> t -> Numbers.Q.t val choose : t -> Numbers.Q.t * r val subst : r -> t -> t -> t val remove : r -> t -> t val to_list : t -> (Numbers.Q.t * r) list * Numbers.Q.t val leaves : t -> r list val print : Format.formatter -> t -> unit val type_info : t -> Ty.t val is_monomial : t -> (Numbers.Q.t * r * Numbers.Q.t) option (* PPMC des denominateurs des coefficients excepte la constante *) val ppmc_denominators : t -> Numbers.Q.t (* PGCD des numerateurs des coefficients excepte la constante *) val pgcd_numerators : t -> Numbers.Q.t (* retourne un polynome sans constante et sa constante et la constante multiplicative: normal_form p = (p',c,d) <=> p = (p' + c) * d *) val normal_form : t -> t * Numbers.Q.t * Numbers.Q.t (* comme normal_form mais le signe est aussi normalise *) val normal_form_pos : t -> t * Numbers.Q.t * Numbers.Q.t val abstract_selectors : t -> (r * r) list -> t * (r * r) list val separate_constant : t -> t * Numbers.Q.t end module type EXTENDED_Polynome = sig include T val extract : r -> t option val embed : t -> r end module Make (X : S) : T with type r = X.r alt-ergo-free-2.0.0/lib/reasoners/sat_solver_sig.mli0000664000175000017500000000631613430774474020260 0ustar mimi(******************************************************************************) (* *) (* The Alt-Ergo theorem prover *) (* Copyright (C) 2006-2013 *) (* *) (* Sylvain Conchon *) (* Evelyne Contejean *) (* *) (* Francois Bobot *) (* Mohamed Iguernelala *) (* Stephane Lescuyer *) (* Alain Mebsout *) (* *) (* CNRS - INRIA - Universite Paris Sud *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (* ------------------------------------------------------------------------ *) (* *) (* Alt-Ergo: The SMT Solver For Software Verification *) (* Copyright (C) 2013-2017 --- OCamlPro SAS *) (* *) (* This file is distributed under the terms of the Apache Software *) (* License version 2.0 *) (* *) (******************************************************************************) module type S = sig type t exception Sat of t exception Unsat of Explanation.t exception I_dont_know of t (* the empty sat-solver context *) val empty : unit -> t val empty_with_inst : (Formula.t -> bool) -> t (* [assume env f] assume a new formula [f] in [env]. Raises Unsat if [f] is unsatisfiable in [env] *) val assume : t -> Formula.gformula -> t val assume_th_elt : t -> Commands.th_elt -> t (* [pred_def env f] assume a new predicate definition [f] in [env]. *) val pred_def : t -> Formula.t -> string -> Loc.t -> t (* [unsat env f size] checks the unsatisfiability of [f] in [env]. Raises I_dont_know when the proof tree's height reaches [size]. Raises Sat if [f] is satisfiable in [env] *) val unsat : t -> Formula.gformula -> Explanation.t val print_model : header:bool -> Format.formatter -> t -> unit val reset_refs : unit -> unit val get_steps : unit -> int64 (* returns used axioms/predicates * unused axioms/predicates *) val retrieve_used_context : t -> Explanation.t -> Formula.t list * Formula.t list end alt-ergo-free-2.0.0/lib/.merlin0000664000175000017500000000034413430774474014013 0ustar mimiS main B main S gui B gui S parsing B parsing S preprocess B preprocess S theories B theories S sat B sat S structures B structures S util B util FLG -short-paths FLG -strict-sequence PKG zarith PKG camlzip PKG ocplib-simplex alt-ergo-free-2.0.0/doc/0000755000175000017500000000000013430774474012520 5ustar mimialt-ergo-free-2.0.0/doc/gtk-lang/0000755000175000017500000000000013430774474014224 5ustar mimialt-ergo-free-2.0.0/doc/gtk-lang/alt-ergo.lang0000644000175000017500000001650213430774474016605 0ustar mimi text/x-alt-ergo (* *)