├── .gitignore ├── COPYRIGHT ├── LICENSE.txt ├── Makefile ├── README ├── TODO ├── _tags ├── bin └── .gitignore ├── configure ├── doc ├── jstar_module_dependencies.graffle ├── jstar_module_dependencies.pdf ├── release.txt └── tutorial │ ├── .cvsignore │ ├── Makefile │ ├── architecture-new.graffle │ ├── architecture2.pdf │ ├── jstartut.tex │ ├── logo.pdf │ ├── objects.bib │ └── proof.sty ├── lib └── .gitignore ├── library └── logic │ ├── boolean_logic │ ├── builtin_plus_logic │ ├── field_logic │ ├── listdatatype_logic │ └── rewrites_logic ├── playground ├── abduction │ ├── boolean_logic │ ├── example0 │ ├── example0.abduct_logic │ ├── example0.abs │ ├── example0.logic_test │ ├── example0.symexec_logic │ ├── field_abduct_logic │ ├── field_logic │ ├── test_if │ ├── test_if.abs │ ├── test_while │ ├── test_while.abduct_logic │ ├── test_while.abs │ └── test_while.symexec_logic ├── context │ ├── context_logic │ └── context_test ├── fresh │ ├── fresh_logic │ └── fresh_tests ├── neq │ ├── logic │ └── test ├── without │ ├── list_ext.logic │ └── list_ext.test └── without_rhs │ ├── logic │ └── test ├── scripts ├── Makefile ├── id_extractor.mll ├── infermli.ml ├── make_release.sh ├── unused.ml └── utils.ml ├── setenv ├── setenv.bat ├── src ├── abs_int │ └── syntactic.ml ├── parsing │ ├── .depend │ ├── lexer.mll │ ├── load_logic.ml │ ├── load_logic.mli │ └── parser.mly ├── plugin_interface │ ├── plugin.ml │ ├── plugin_callback.ml │ ├── plugin_callback.mli │ ├── plugin_manager.ml │ ├── plugin_manager.mli │ └── registry.ml ├── prover │ ├── clogic.ml │ ├── clogic.mli │ ├── congruence.ml │ ├── congruence.mli │ ├── cterm.ml │ ├── cterm.mli │ ├── prover.ml │ ├── prover.mli │ ├── sepprover.ml │ ├── sepprover.mli │ ├── smt.ml │ ├── smtlex.mll │ ├── smtparse.mly │ └── smtsyntax.ml ├── prover_syntax │ ├── psyntax.ml │ └── psyntax.mli ├── proverfront │ ├── run_prover.ml │ ├── run_prover.mli │ ├── test_logic.ml │ └── test_logic.mli ├── symbexe │ ├── specification.ml │ ├── specification.mli │ ├── symexec.ml │ └── symexec.mli ├── symbexe_syntax │ ├── cfg_core.ml │ ├── cfg_core.mli │ ├── core.ml │ ├── core.mli │ ├── pprinter_core.ml │ ├── pprinter_core.mli │ ├── spec.ml │ └── spec.mli ├── symbfront │ ├── corestar.ml │ ├── corestar.mli │ └── test_symb.ml └── utils │ ├── backtrack.ml │ ├── backtrack.mli │ ├── cli_utils.ml │ ├── cli_utils.mli │ ├── config.ml │ ├── config.mli │ ├── corestar_std.ml │ ├── corestar_std.mli │ ├── debug.ml │ ├── debug.mli │ ├── dot.ml │ ├── dot.mli │ ├── load.ml │ ├── load.mli │ ├── misc.ml │ ├── misc.mli │ ├── multiset.ml │ ├── multiset.mli │ ├── persistentarray.ml │ ├── persistentarray.mli │ ├── printing.ml │ ├── printing.mli │ ├── system.ml │ ├── system.mli │ ├── vars.ml │ └── vars.mli └── unit_tests ├── Makefile ├── prover_tests ├── Makefile ├── abduction_logic ├── abs_logic ├── abs_test ├── bitvect_logic ├── bitvect_test ├── boolean_logic ├── builtin_plus_logic ├── cons_logic ├── cons_test ├── eq_logic ├── eq_test ├── exists_logic ├── exists_test ├── field_basic_logic ├── field_basic_test ├── field_logic ├── field_test ├── listdatatype_logic ├── listdatatype_test ├── plain_logic ├── plain_test ├── rewrites_logic ├── rewrites_test ├── rz_plus4_logic ├── rz_plus4_test ├── smt_logic ├── smt_test ├── spat2_logic ├── spat2_test ├── spat_logic ├── spat_test ├── weird_logic ├── weird_test ├── where_logic └── where_test └── symb_tests ├── Makefile ├── test.sh ├── trivial_abs ├── trivial_logic ├── trivial_test ├── weird_abs ├── weird_logic └── weird_test /.gitignore: -------------------------------------------------------------------------------- 1 | *.core 2 | *.swp 3 | .depend 4 | _build 5 | tags 6 | .install.mk 7 | rg.log 8 | -------------------------------------------------------------------------------- /COPYRIGHT: -------------------------------------------------------------------------------- 1 | Copyright (c) 2 | 2007-2011 Dino Distefano (Queen Mary, University of London) 3 | 2007-2011 Matthew Parkinson (University of Cambridge) 4 | 2010-2011 Matko Botincan (University of Cambridge) 5 | 2010-2011 Mike Dodds (University of Cambridge) 6 | 2010-2011 Radu Grigore (Queen Mary, University of London) 7 | 2010-2011 Daiva Naudziuniene (University of Cambridge) 8 | See individual files for details. 9 | 10 | All rights reserved. -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | All rights reserved. 2 | 3 | Redistribution and use in source and binary forms, with or without 4 | modification, are permitted provided that the following conditions 5 | are met: 6 | 7 | * Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in 12 | the documentation and/or other materials provided with the 13 | distribution. 14 | 15 | * Neither the name of the organisations (Queen Mary University of 16 | London and University of Cambridge) nor the names of its 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 23 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 24 | COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, 25 | INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 26 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 27 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 29 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 30 | ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED 31 | OF THE POSSIBILITY OF SUCH DAMAGE. 32 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # section that changes often 2 | 3 | ifndef CORESTAR_HOME 4 | CORESTAR_HOME=$(CURDIR) 5 | endif 6 | export CORESTAR_HOME 7 | 8 | SRC_DIRS=src 9 | MAINS=corestar test_symb test_logic 10 | LIBS=dynlink str unix 11 | 12 | # section that shouldn't change often 13 | 14 | SHELL=/bin/bash 15 | SRC_SUBDIRS=$(addsuffix .subdirs,$(SRC_DIRS)) 16 | OCAMLBUILD=ocamlbuild -cflag -dtypes \ 17 | `cat $(SRC_SUBDIRS)` $(addprefix -lib ,$(LIBS)) 18 | 19 | build: native 20 | 21 | native byte: $(SRC_SUBDIRS) 22 | $(OCAMLBUILD) $(addsuffix .$@,$(MAINS)) 23 | for f in $(MAINS); do ln -sf `readlink $$f.$@` bin/$$f; rm $$f.$@; done 24 | 25 | test: test-native 26 | 27 | test-native test-byte: test-%: % 28 | $(MAKE) -s -C unit_tests 29 | 30 | doc: 31 | $(MAKE) -C doc/tutorial # DEV 32 | 33 | scripts: 34 | $(MAKE) -C scripts # DEV 35 | 36 | all: build test 37 | 38 | clean: 39 | ocamlbuild -clean 40 | rm -f lib/*.a lib/* bin/* *.subdirs 41 | $(MAKE) -C unit_tests clean 42 | $(MAKE) -C scripts clean # DEV 43 | $(MAKE) -C doc/tutorial clean # DEV 44 | 45 | %.subdirs: % 46 | ls -F $*/ | grep / | sed "s./.." | sed "s.^.-I $*/." > $*.subdirs 47 | 48 | .PHONY: all build byte clean doc native scripts test 49 | 50 | -include .install.mk 51 | 52 | #vim:noet: 53 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | The coreStar Verification Framework 2 | =================================== 3 | 4 | coreStar is a highly-customisable automatic generic core symbolic execution 5 | engine for analysis and verification with separation logic. 6 | 7 | For more information, see http://www.jstarverifier.org 8 | 9 | 10 | 11 | Building on *nix / Mac OSX / Cygwin 12 | ----------------------------------- 13 | 14 | Use the standard incantation. 15 | ./configure --prefix DIR 16 | make install 17 | 18 | (NOTE: In some environments, such as Mac OS Leopard, dynlink.cmxa is 19 | unavailable, leading to a compile error. In that case, try "make install.byte".) 20 | 21 | And then run, assuming DIR/bin is in your path. 22 | corestar 23 | 24 | Optionally, run the tests to make sure all is OK. 25 | make test 26 | 27 | Dependencies: 28 | 29 | * OCaml >=3.11 30 | http://caml.inria.fr/download.en.html 31 | Debian / Ubuntu: ocaml, ocaml-native-compilers 32 | 33 | 34 | Building on Win32 (native) 35 | -------------------------- 36 | 37 | Open the Visual Studio Command Prompt. 38 | - If you obtained Microsoft tools not as a part of Visual Studio, just open 39 | Command Prompt and manually set up necessary PATH and INCLUDE directories.) 40 | 41 | Check that the make tool is in path. 42 | - If using Cywgin/MinGW based make, then just add Cygwin/MinGW bin directory 43 | to path. In addition, set the LIB environment variable to empty. This is 44 | due to problems that arise when make deals with directories containing 45 | empty spaces (like "Program Files"). You will probably have to manually set 46 | up additional include path for OCaml compiler to Visual C++ Runtime 47 | Libraries and Windows SDK libraries. 48 | 49 | To run the build process, call: 50 | make build 51 | 52 | To set the environment variables necessary for coreStar to run: 53 | setenv.bat 54 | 55 | After the build process has finished, you may have to add extension .exe to 56 | compiled binaries located in coreStar's bin subdirectory. 57 | 58 | 59 | Dependencies: 60 | 61 | * Microsoft-based native Win32 port of OCaml: 62 | http://caml.inria.fr/pub/distrib/ocaml-3.11/ocaml-3.11.0-win-msvc.exe 63 | 64 | * FlexDLL: http://alain.frisch.fr/flexdll.html 65 | (solves the problem that Windows DLL cannot refer to symbols defined 66 | in the main application or in previously loaded DLLs) 67 | 68 | * Microsoft Macro Assembler (ml.exe), Microsoft Visual C++ and 69 | Microsoft Windows SDK libraries. (if you are not using Visual Studio, 70 | these tools can be obtained for free at Microsoft site) 71 | 72 | * Unix make tool (e.g., the one distributed with Cygwin or MinGW) 73 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | TASKS 2 | ===== 3 | 4 | Documentation: 5 | - Prapare smallfoot example 6 | - Prepare coreStar tutorial 7 | 8 | Testing: 9 | - Generate unit tests from examples in playground 10 | - Add test input files for abduction 11 | - Add unit tests for abduction 12 | 13 | Parser: 14 | - Rename MULT to STAR, and add Mult as a binop 15 | - Rename lex.OR to lex.BAR 16 | - Rename lex.MULT to lex.STAR 17 | - Check whether precedence is needed in parser 18 | - Check translation of parser.equiv_rule 19 | - Add syntactic sugar for multiplication in input syntax for prover testfiles, also for tuples 20 | 21 | Refactoring: 22 | - Sort out loading of logic files (location, ...) 23 | - TODO(rgrig): Functions in Vars should be used instead of new*Var. (Parser.mly) 24 | - Token information passing to core files 25 | - Sort out spec parameter handling 26 | 27 | Prover: 28 | - Rename JSTAR_SMT_PATH and JSTAR_SMT_ARGUMENTS 29 | - Check all pure guards of a rule at once 30 | - Smt output to proof files 31 | - Selectively decide when to output smt 32 | 33 | 34 | THINK ABOUT 35 | =========== 36 | - Exceptions handling 37 | - Sharing support syntax between smt, ai, ... 38 | - Support for quoting of external syntax 39 | - Revisit rewrite rules distinction (saturate=true,false); 40 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | true: debug 2 | -------------------------------------------------------------------------------- /bin/.gitignore: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/seplogic/corestar/a352b3dada6a399a1dae6546be36e3d8a56f9368/bin/.gitignore -------------------------------------------------------------------------------- /configure: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # Helpers {{{ 4 | 5 | # just a shorthand for populating .install.mk 6 | inst () { 7 | echo -e "\t@install $1" >> .install.mk 8 | } 9 | 10 | split () { 11 | local i=0 12 | OLDIFS=$IFS 13 | IFS=$2 14 | for x in $3; do 15 | eval $1[$i]=$x 16 | i=$((i+1)) 17 | done 18 | IFS=$OLDIFS 19 | } 20 | 21 | # returns 0 iff $1 > $2 22 | # $1 and $2 must be lists of numbers, dot-separated 23 | too_old () { 24 | local A 25 | local B 26 | split A . "$1" 27 | split B . "$2" 28 | for (( i=0; i<${#A[*]} || i<${#B[*]}; ++i )); do 29 | if (( ${A[$i]:-0} > ${B[$i]:-0} )); then 30 | return 0 31 | fi 32 | if (( ${A[$i]:-0} < ${B[$i]:-0} )); then 33 | return 1 34 | fi 35 | done 36 | return 1 37 | } 38 | 39 | # }}} 40 | # Parse arguments {{{ 41 | while (( $# )); do 42 | case "$1" in 43 | --prefix=*) 44 | PREFIX="${1:9}";; 45 | --prefix) 46 | shift 47 | if (( $# == 0 )); then 48 | echo "Missing prefix." 49 | exit 2 50 | fi 51 | PREFIX=$1;; 52 | *) 53 | echo "Strange argument: $1" 2> /dev/stderr 54 | exit 2;; 55 | esac 56 | shift 57 | done 58 | # }}} 59 | # Check that an OCaml compiler is present. {{{ 60 | OCAML_VERSION=$(ocamlc -version 2> /dev/null) 61 | if too_old 3.11 $OCAML_VERSION; then 62 | echo "Please make sure that ocamlc >=3.11 is in your PATH." 2>&1 63 | echo "See http://caml.inria.fr/ocaml/release.en.html" 2>&1 64 | exit 1 65 | fi 66 | # }}} 67 | # Generate install target {{{ 68 | echo -e "install: install.native\n\ninstall.%:%" > .install.mk 69 | inst "-d $PREFIX/bin" 70 | inst "-m=rx bin/corestar $PREFIX/bin/corestar" 71 | for d in `find library -type d`; do inst "-d $PREFIX/$d"; done 72 | for f in `find library -type f`; do inst "-m=r $f $PREFIX/$f"; done 73 | # }}} 74 | -------------------------------------------------------------------------------- /doc/jstar_module_dependencies.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/seplogic/corestar/a352b3dada6a399a1dae6546be36e3d8a56f9368/doc/jstar_module_dependencies.pdf -------------------------------------------------------------------------------- /doc/release.txt: -------------------------------------------------------------------------------- 1 | All UNIX releases *must* conform to what experienced users expect. 2 | tar xaf corestar-VERSION.tar.bz2 3 | cd corestar-VERSION 4 | ./configure --prefix=HOME # may fail with 'Install such and such.' 5 | make 6 | make test 7 | make install # may fail due to file permissions, but should always work as root 8 | 9 | The commands above may fail only if at least one of these holds: 10 | 1. Reasonable versions of bash, tar, bunzip2, bash, GNU Make are 11 | are not available. 12 | 2. The command ./configure notices that some dependency is unmet. 13 | 3. The command 'make install' is run without super-user privilege and 14 | there are some permission problems. 15 | To make this more precise, "reasonable version" means whatever version 16 | shipped with the latest Ubuntu LTS at the date of the release. 17 | 18 | Any other failure is a bug in the release. 19 | 20 | Mandatory testing: The above procedure must work on the latest Ubuntu LTS, 21 | with HOME=/, HOME=~, and HOME=~/temp. 22 | -------------------------------------------------------------------------------- /doc/tutorial/.cvsignore: -------------------------------------------------------------------------------- 1 | jstartut.pdf -------------------------------------------------------------------------------- /doc/tutorial/Makefile: -------------------------------------------------------------------------------- 1 | default : jstartut.pdf 2 | 3 | jstartut.pdf : jstartut.tex objects.bbl logo.pdf architecture2.pdf 4 | pdflatex jstartut.tex 5 | pdflatex jstartut.tex 6 | 7 | objects.bbl : objects.bib jstartut.aux 8 | bibtex jstartut 9 | 10 | jstartut.aux : jstartut.tex 11 | pdflatex jstartut.tex 12 | 13 | clean: 14 | rm -f jstartut.aux jstartut.bbl jstartut.blg jstartut.log jstartut.pdf 15 | -------------------------------------------------------------------------------- /doc/tutorial/architecture-new.graffle: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/seplogic/corestar/a352b3dada6a399a1dae6546be36e3d8a56f9368/doc/tutorial/architecture-new.graffle -------------------------------------------------------------------------------- /doc/tutorial/architecture2.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/seplogic/corestar/a352b3dada6a399a1dae6546be36e3d8a56f9368/doc/tutorial/architecture2.pdf -------------------------------------------------------------------------------- /doc/tutorial/logo.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/seplogic/corestar/a352b3dada6a399a1dae6546be36e3d8a56f9368/doc/tutorial/logo.pdf -------------------------------------------------------------------------------- /doc/tutorial/objects.bib: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/seplogic/corestar/a352b3dada6a399a1dae6546be36e3d8a56f9368/doc/tutorial/objects.bib -------------------------------------------------------------------------------- /lib/.gitignore: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/seplogic/corestar/a352b3dada6a399a1dae6546be36e3d8a56f9368/lib/.gitignore -------------------------------------------------------------------------------- /library/logic/boolean_logic: -------------------------------------------------------------------------------- 1 | /********* 2 | * false and true rules 3 | *********/ 4 | rewrite false: false() = numeric_const("0") 5 | 6 | rewrite zero: zero() = numeric_const("0") 7 | 8 | rewrite true : true() = numeric_const("1") 9 | 10 | 11 | 12 | 13 | /********** 14 | * Injectivity of numeric_const 15 | **********/ 16 | rule numeric_eq_left : 17 | | numeric_const(?x) = numeric_const(?y) |- 18 | without 19 | ?x=?y 20 | if 21 | | ?x =?y |- 22 | 23 | rule numeric_eq_right : 24 | | |- numeric_const(?x) = numeric_const(?y) 25 | without 26 | ?x=?y 27 | if 28 | | |- ?x=?y 29 | 30 | rule numeric_neq_left : 31 | | numeric_const(?x) != numeric_const(?y) |- 32 | if 33 | | ?x !=?y |- 34 | 35 | rule numeric_neq_right : 36 | | |- numeric_const(?x) != numeric_const(?y) 37 | if 38 | | |- ?x!=?y 39 | 40 | 41 | 42 | -------------------------------------------------------------------------------- /library/logic/builtin_plus_logic: -------------------------------------------------------------------------------- 1 | /****************** 2 | * Some simple properties of addition 3 | ******************/ 4 | 5 | rule builtin_plus_inj_first : 6 | | |- builtin_plus(?t,?g) = builtin_plus(?t,?h) 7 | without 8 | ?g = ?h 9 | if 10 | | |- ?g = ?h 11 | 12 | rule builtin_plus_inj_second : 13 | | |- builtin_plus(?g,?t) = builtin_plus(?h,?t) 14 | without 15 | ?g = ?h 16 | if 17 | | |- ?g = ?h 18 | 19 | 20 | 21 | rewrite builtin_plus_assoc : 22 | builtin_plus(builtin_plus(?x,?y),?z) = builtin_plus(?x,builtin_plus(?y,?z)) 23 | 24 | /* 25 | rewrite builtin_plus_comm : 26 | builtin_plus(?x,?y) = builtin_plus(?y,?x) 27 | */ 28 | 29 | rule bp : 30 | | |- builtin_plus(?x,?x) = builtin_plus(?y,?y) 31 | without 32 | ?x = ?y |- 33 | if 34 | | |- ?x=?y 35 | -------------------------------------------------------------------------------- /library/logic/field_logic: -------------------------------------------------------------------------------- 1 | /************************************* 2 | * Simple subtraction rules 3 | *************************************/ 4 | 5 | /* 6 | If you have a field for the same object 7 | on both sides of an implication, add the 8 | field to the matched fields, and require 9 | that proof obligation that there values 10 | are the same. 11 | 12 | The "without" clause prevents the matching 13 | if we already know the fields have different 14 | values. 15 | */ 16 | rule field_remove1: 17 | | field(?x,?f,?y) |- field(?x,?f,?t) 18 | without 19 | ?y!=?t 20 | if 21 | field(?x,?f,?y) | |- ?y=?t 22 | 23 | 24 | /************************************* 25 | * rules for contradictions 26 | *************************************/ 27 | 28 | /* 29 | If two fields for the same object with the 30 | same name exists in an assumption, then there 31 | is a contradiction and the proof is complete. 32 | */ 33 | rule field_field_contradiction1 : 34 | field(?x,?f,?y) * field(?x,?f,?z) | |- 35 | if 36 | 37 | /* 38 | If we have an assumption of a field for null 39 | then we have a contradiction. 40 | */ 41 | rule field_nil_contradiction : 42 | field(nil(),?f,?z) | |- 43 | if 44 | 45 | /************************************** 46 | * Rules for failed proofs 47 | **************************************/ 48 | 49 | /* 50 | If we need to prove that field exists for null 51 | then we are going to fail, unless we can find 52 | a contradiction. 53 | */ 54 | rule field_nil_failed : 55 | | |- field(nil(),?f,?z) 56 | if 57 | | |- field(nil(),?f,?z) * False 58 | 59 | /* 60 | If we need to match to fields which have 61 | distinct values, then we need to search for a 62 | contradiction (False). 63 | */ 64 | /* 65 | rule field_field_no_match : 66 | | ?y!=?t * field(?x,?f,?y) |- field(?x,?f,?t) 67 | if 68 | | ?y!=?t * field(?x,?f,?y) |- field(?x,?f,?t) * False 69 | */ 70 | 71 | 72 | rule field_not_null : 73 | field(?x,?f,?y) | |- ?x!=nil() 74 | if 75 | | |- 76 | 77 | 78 | -------------------------------------------------------------------------------- /library/logic/listdatatype_logic: -------------------------------------------------------------------------------- 1 | /***************************** 2 | * Declare as constructors 3 | *****************************/ 4 | 5 | constructor cons 6 | constructor empty 7 | 8 | 9 | /******************************************* 10 | * Definitions for datatype of list 11 | *******************************************/ 12 | 13 | rewrite cons_hd: 14 | hd(cons(?x,?y)) = ?x 15 | 16 | rewrite cons_tl: 17 | tl(cons(?x,?y)) = ?y 18 | 19 | rewrite app_nil: 20 | app(empty(), ?x) = ?x 21 | 22 | rewrite app_nil2: 23 | app(?x, empty()) = ?x 24 | 25 | 26 | /*********************************** 27 | * Rules for simplifying app 28 | ***********************************/ 29 | 30 | rule app_is_emp_left : 31 | | app(?x,?y) = empty() |- 32 | without 33 | ?x = empty() 34 | if 35 | | ?x = empty() * ?y = empty() |- 36 | 37 | rule app_is_emp_right : 38 | | |- app(?x,?y) = empty() 39 | without 40 | ?x = empty() * ?y = empty() |- 41 | if 42 | | |- ?x = empty() * ?y = empty() 43 | 44 | rule app_neq_emp_left : 45 | | app(?x,?y) != empty() |- 46 | if 47 | | ?x != empty() || ?y != empty() |- 48 | 49 | 50 | rule app_neq_emp_right : 51 | | |- app(?x,?y) != empty() 52 | if 53 | | |- ?x != empty() || ?y != empty() 54 | -------------------------------------------------------------------------------- /library/logic/rewrites_logic: -------------------------------------------------------------------------------- 1 | rewrite foo : 2 | f(?x) = "1" 3 | 4 | 5 | rewrite baa1 : 6 | h(?x) = g(?x) 7 | 8 | rewrite baa2 : 9 | g(?x) = h(?x) 10 | 11 | 12 | rewrite foo2: 13 | y(?x) = y(y(?x)) 14 | 15 | rewrite foo3: 16 | a(?x) = a(b(?x)) 17 | 18 | rewrite foo4: 19 | b(?x) = b(a(?x)) 20 | 21 | rewrite cons_hd: 22 | hd(cons(?x,?y)) = ?x 23 | 24 | rewrite cons_tl: 25 | tl(cons(?x,?y)) = ?y 26 | 27 | rewrite app_nil: 28 | app(nil(), ?x) = ?x 29 | 30 | rewrite app_nil2: 31 | app(?x, nil()) = ?x 32 | -------------------------------------------------------------------------------- /playground/abduction/boolean_logic: -------------------------------------------------------------------------------- 1 | /********* 2 | * false and true rules 3 | *********/ 4 | rewrite false: false() = numeric_const("0") 5 | 6 | rewrite zero: zero() = numeric_const("0") 7 | 8 | rewrite true : true() = numeric_const("1") 9 | 10 | 11 | 12 | 13 | /********** 14 | * Injectivity of numeric_const 15 | **********/ 16 | rule numeric_eq_left : 17 | | numeric_const(?x) = numeric_const(?y) |- 18 | without 19 | ?x=?y 20 | if 21 | | ?x =?y |- 22 | 23 | rule numeric_eq_right : 24 | | |- numeric_const(?x) = numeric_const(?y) 25 | without 26 | ?x=?y 27 | if 28 | | |- ?x=?y 29 | 30 | rule numeric_neq_left : 31 | | numeric_const(?x) != numeric_const(?y) |- 32 | if 33 | | ?x !=?y |- 34 | 35 | rule numeric_neq_right : 36 | | |- numeric_const(?x) != numeric_const(?y) 37 | if 38 | | |- ?x!=?y 39 | 40 | 41 | 42 | -------------------------------------------------------------------------------- /playground/abduction/example0: -------------------------------------------------------------------------------- 1 | Specification example0 : { something() } { } ? 2 | assign {lseg(a(),b())} {} (); 3 | assign {} {lseg(a(),b())} (); 4 | end; 5 | -------------------------------------------------------------------------------- /playground/abduction/example0.abduct_logic: -------------------------------------------------------------------------------- 1 | /* 2 | emp |- emp -| lseg(a,b) 3 | ----------------------- 4 | emp |- lseg(a,b) -| emp 5 | */ 6 | 7 | rule test1: 8 | | |- lseg(?a,?b) -| 9 | if 10 | | |- -| lseg(?a,?b) 11 | 12 | rule abduct_field : 13 | | |- field(?x,?f,?y) -| 14 | without 15 | ls(?x,?z) || NodeLL(?x,?z) || lspe(?x,?z) 16 | if 17 | | |- -| field(?x,?f,?y) 18 | -------------------------------------------------------------------------------- /playground/abduction/example0.abs: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/seplogic/corestar/a352b3dada6a399a1dae6546be36e3d8a56f9368/playground/abduction/example0.abs -------------------------------------------------------------------------------- /playground/abduction/example0.logic_test: -------------------------------------------------------------------------------- 1 | Implication: |- lseg(a(),b()) 2 | 3 | Abduction: |- lseg(a(),b()) 4 | 5 | Abduction: field(r0, "foo", nil()) |- field(r0, "foo", nil()) * field(r1, "bar", nil()) 6 | -------------------------------------------------------------------------------- /playground/abduction/example0.symexec_logic: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/seplogic/corestar/a352b3dada6a399a1dae6546be36e3d8a56f9368/playground/abduction/example0.symexec_logic -------------------------------------------------------------------------------- /playground/abduction/field_abduct_logic: -------------------------------------------------------------------------------- 1 | /************************************* 2 | * Simple subtraction rules 3 | *************************************/ 4 | 5 | /* 6 | If you have a field for the same object 7 | on both sides of an implication, add the 8 | field to the matched fields, and require 9 | that proof obligation that there values 10 | are the same. 11 | 12 | The "without" clause prevents the matching 13 | if we already know the fields have different 14 | values. 15 | */ 16 | rule field_remove1: 17 | | field(?x,?f,?y) |- field(?x,?f,?t) 18 | without 19 | ?y!=?t 20 | if 21 | field(?x,?f,?y) | |- ?y=?t 22 | 23 | 24 | /************************************* 25 | * rules for contradictions 26 | *************************************/ 27 | 28 | /* 29 | If two fields for the same object with the 30 | same name exists in an assumption, then there 31 | is a contradiction and the proof is complete. 32 | */ 33 | rule field_field_contradiction1 : 34 | field(?x,?f,?y) * field(?x,?f,?z) | |- 35 | if 36 | 37 | /* 38 | If we have an assumption of a field for null 39 | then we have a contradiction. 40 | */ 41 | rule field_nil_contradiction : 42 | field(nil(),?f,?z) | |- 43 | if 44 | 45 | /************************************** 46 | * Rules for failed proofs 47 | **************************************/ 48 | 49 | /* 50 | If we need to prove that field exists for null 51 | then we are going to fail, unless we can find 52 | a contradiction. 53 | */ 54 | rule field_nil_failed : 55 | | |- field(nil(),?f,?z) 56 | if 57 | | |- field(nil(),?f,?z) * False 58 | 59 | /* 60 | If we need to match to fields which have 61 | distinct values, then we need to search for a 62 | contradiction (False). 63 | */ 64 | /* 65 | rule field_field_no_match : 66 | | ?y!=?t * field(?x,?f,?y) |- field(?x,?f,?t) 67 | if 68 | | ?y!=?t * field(?x,?f,?y) |- field(?x,?f,?t) * False 69 | */ 70 | 71 | 72 | rule field_not_null : 73 | field(?x,?f,?y) | |- ?x!=nil() 74 | if 75 | | |- 76 | 77 | 78 | /************************************** 79 | * Abduction of fields 80 | **************************************/ 81 | rule abduct_field : 82 | | |- field(?x,?f,?y) -| 83 | /* 84 | without 85 | ls(?x,?z) || NodeLL(?x,?z) || lspe(?x,?z) 86 | */ 87 | if 88 | | |- -| field(?x,?f,?y) 89 | -------------------------------------------------------------------------------- /playground/abduction/field_logic: -------------------------------------------------------------------------------- 1 | /************************************* 2 | * Simple subtraction rules 3 | *************************************/ 4 | 5 | /* 6 | If you have a field for the same object 7 | on both sides of an implication, add the 8 | field to the matched fields, and require 9 | that proof obligation that there values 10 | are the same. 11 | 12 | The "without" clause prevents the matching 13 | if we already know the fields have different 14 | values. 15 | */ 16 | rule field_remove1: 17 | | field(?x,?f,?y) |- field(?x,?f,?t) 18 | without 19 | ?y!=?t 20 | if 21 | field(?x,?f,?y) | |- ?y=?t 22 | 23 | 24 | /************************************* 25 | * rules for contradictions 26 | *************************************/ 27 | 28 | /* 29 | If two fields for the same object with the 30 | same name exists in an assumption, then there 31 | is a contradiction and the proof is complete. 32 | */ 33 | rule field_field_contradiction1 : 34 | field(?x,?f,?y) * field(?x,?f,?z) | |- 35 | if 36 | 37 | /* 38 | If we have an assumption of a field for null 39 | then we have a contradiction. 40 | */ 41 | rule field_nil_contradiction : 42 | field(nil(),?f,?z) | |- 43 | if 44 | 45 | /************************************** 46 | * Rules for failed proofs 47 | **************************************/ 48 | 49 | /* 50 | If we need to prove that field exists for null 51 | then we are going to fail, unless we can find 52 | a contradiction. 53 | */ 54 | rule field_nil_failed : 55 | | |- field(nil(),?f,?z) 56 | if 57 | | |- field(nil(),?f,?z) * False 58 | 59 | /* 60 | If we need to match to fields which have 61 | distinct values, then we need to search for a 62 | contradiction (False). 63 | */ 64 | /* 65 | rule field_field_no_match : 66 | | ?y!=?t * field(?x,?f,?y) |- field(?x,?f,?t) 67 | if 68 | | ?y!=?t * field(?x,?f,?y) |- field(?x,?f,?t) * False 69 | */ 70 | 71 | 72 | rule field_not_null : 73 | field(?x,?f,?y) | |- ?x!=nil() 74 | if 75 | | |- 76 | -------------------------------------------------------------------------------- /playground/abduction/test_if: -------------------------------------------------------------------------------- 1 | Specification test_if : { } { } ? 2 | goto l_1, l_2; 3 | label l_1; 4 | assign {} {c="True"} (); 5 | assign {field(x,"f",_v)} {field(x,"f","5")} (); 6 | goto l_end; 7 | label l_2; 8 | assign {} {c="False"} (); 9 | assign {field(y,f,_v)} {field(y,f,"7")} (); 10 | goto l_end; 11 | label l_end; 12 | end; 13 | -------------------------------------------------------------------------------- /playground/abduction/test_if.abs: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/seplogic/corestar/a352b3dada6a399a1dae6546be36e3d8a56f9368/playground/abduction/test_if.abs -------------------------------------------------------------------------------- /playground/abduction/test_while: -------------------------------------------------------------------------------- 1 | Specification test_while : { } { } ? 2 | assign x := {} {$ret_v1 = p} (); 3 | label loop_top; 4 | goto loop_body, loop_exit; 5 | label loop_body; 6 | assign {} {x != nil()} (); 7 | assign {field(x,"",_y)} {field(x,"","123")} (); 8 | assign x := {field(x,"",_n)} {field(x,"",_n) * $ret_v1 = _n} (); 9 | goto loop_top; 10 | label loop_exit; 11 | assign {} {x = nil()} (); 12 | end; 13 | -------------------------------------------------------------------------------- /playground/abduction/test_while.abduct_logic: -------------------------------------------------------------------------------- 1 | import "field_abduct_logic"; 2 | 3 | 4 | /*************************************** 5 | * This file defines 6 | * 7 | * NodeLL 8 | * ls 9 | * lspe 10 | * 11 | ***************************************/ 12 | 13 | 14 | 15 | rule NodeLL_not_nil: 16 | NodeLL(nil(),?y) | |- 17 | if 18 | 19 | rule ls_not_nil: 20 | ls(nil(),?y) | |- 21 | if 22 | 23 | rule lspe_not_nil: 24 | lspe(nil(),?y) | |- 25 | if 26 | | ?y=nil() |- 27 | 28 | 29 | rule NodeLL_not_nil: 30 | NodeLL(?x,?y) | |- ?x!=nil() 31 | if 32 | | |- 33 | 34 | rule NodeLL_not_eq: 35 | NodeLL(?x,?y) * NodeLL(?x,?w) | |- 36 | if 37 | 38 | 39 | 40 | 41 | /************************************* 42 | * Rule for unpacking Nodell 43 | * 44 | * These rules could potentially cycle forever 45 | * but due to their order cannot. 46 | *************************************/ 47 | 48 | //Unroll NodeLL if we are looking for its next field 49 | rule field_remove1a: 50 | | NodeLL(?x,?e1) |- field(?x,"",?e2) 51 | if 52 | field(?x,"",?e1) | field(?x,"",_w) |- ?e1=?e2 53 | 54 | //Unroll NodeLL if we are looking for its content field 55 | rule field_remove1b: 56 | | NodeLL(?x,?e1) |- field(?x,"",?e2) 57 | if 58 | field(?x,"",w) | field(?x,"",?e1) |- w=?e2 59 | 60 | 61 | //Roll up a complete NodeLL if we have both fields. 62 | rule field_remove2: 63 | | field(?x,"",?e1) * field(?x,"",?z) |- 64 | if 65 | | NodeLL(?x,?e1) |- 66 | 67 | 68 | 69 | 70 | /************************************* 71 | * Simple subtraction rules 72 | *************************************/ 73 | 74 | 75 | rule ls_unroll_exists : 76 | | ls(?x,?y) |- field(?x,?w,?Z) 77 | if 78 | | NodeLL(?x,_fooz) * lspe(_fooz,?y) |- field(?x,?w,?Z) 79 | 80 | 81 | 82 | rule ls_ls_match : 83 | ls(?z,?w) | ls(?x,?y) |- ls(?x,?z) 84 | if 85 | ls(?x,?y) | |- lspe(?y,?z) 86 | 87 | rule ls_NodeLL_match : 88 | NodeLL(?z,?w) | ls(?x,?y) |- ls(?x,?z) 89 | if 90 | ls(?x,?y) | |- lspe(?y,?z) 91 | 92 | rule ls_field_match : 93 | field(?z,?f,?w) | ls(?x,?y) |- ls(?x,?z) 94 | if 95 | ls(?x,?y) | |- lspe(?y,?z) 96 | 97 | 98 | 99 | rule nl_ls_match : 100 | ls(?z,?w) | NodeLL(?x,?y) |- ls(?x,?z) 101 | if 102 | NodeLL(?x,?y) | |- lspe(?y,?z) 103 | 104 | rule nl_NodeLL_match : 105 | NodeLL(?z,?w) | NodeLL(?x,?y) |- ls(?x,?z) 106 | if 107 | NodeLL(?x,?y) | |- lspe(?y,?z) 108 | 109 | rule nl_field_match : 110 | field(?z,?f,?w) | NodeLL(?x,?y) |- ls(?x,?z) 111 | if 112 | ls(?x,?y) | |- lspe(?y,?z) 113 | 114 | 115 | 116 | 117 | rule lspe_left : 118 | | lspe(?x,?y) |- 119 | if 120 | | ls(?x,?y) |- 121 | or 122 | | ?x=?y |- 123 | 124 | 125 | rule lspe_right : 126 | | |- lspe(?x,?y) 127 | if 128 | | |- ls(?x,?y) 129 | or 130 | | |- ?x=?y 131 | 132 | 133 | /************************************* 134 | * rules for contradictions 135 | *************************************/ 136 | rule ls_field_contradiction1 : 137 | ls(?x,?t) * field(?x,"",?z) | |- 138 | if 139 | 140 | rule ls_field_contradiction2 : 141 | ls(?x,?t) * field(?x,"",?z) | |- 142 | if 143 | 144 | rule ls_node_contradiction : 145 | ls(?x,?t) * NodeLL(?x,?z) | |- 146 | if 147 | 148 | rule ls_ls_contr : 149 | ls(?x,?t) * ls(?x,?z) | |- 150 | if 151 | 152 | rule ls_ls_contr : 153 | | |- ls(?x,?t) * ls(?x,?z) 154 | if 155 | | |- x!=x 156 | 157 | 158 | 159 | /************************************** 160 | * Abduction of list 161 | **************************************/ 162 | /* 163 | rule abduct_list : 164 | | |- ls(?x,nil()) -| 165 | without 166 | field(?x,?f,?y) 167 | if 168 | | |- -| ls(?x,nil()) 169 | */ 170 | 171 | /* 172 | rule rearrange1: 173 | | ?x=?p * ls(?x,nil()) |- 174 | without 175 | ?x != ?p 176 | if 177 | | ls(?p,?x) * ls(?x,nil()) |- 178 | */ 179 | -------------------------------------------------------------------------------- /playground/abduction/test_while.abs: -------------------------------------------------------------------------------- 1 | /************************************* 2 | * Simple subtraction rules from TACAS 2006 paper 3 | *************************************/ 4 | 5 | 6 | //Roll up a complete NodeLL if we have both fields. 7 | abstraction field_remove2: 8 | field(?x,"",?e1) * field(?x,"",?e2) 9 | ~~> 10 | NodeLL(?x,?e1) 11 | 12 | 13 | /****************nil() rules******************/ 14 | 15 | /* 16 | abstraction nil_neq_remove_nodell : 17 | ?x != nil() * NodeLL(?x,?y) 18 | ~~> 19 | NodeLL(?x,?y) 20 | 21 | abstraction nil_neq_remove_field : 22 | ?x != nil() * field(?x,?f,?y) 23 | ~~> 24 | field(?x,?f,?y) 25 | 26 | abstraction nil_neq_remove_ls : 27 | ?x != nil() * ls(?x,?y) 28 | ~~> 29 | ls(?x,?y) 30 | */ 31 | 32 | /*************** Junk Rules *******************/ 33 | 34 | abstraction Garbage_Garbage : 35 | Garbage() * Garbage() 36 | ~~> 37 | Garbage() 38 | 39 | 40 | abstraction gb1_ls : 41 | ls(_x,?e) ~~> Garbage() 42 | where 43 | _x notincontext 44 | 45 | 46 | abstraction gb1_ast : 47 | Ast(_x,?e) ~~> 48 | where 49 | _x notincontext 50 | 51 | 52 | abstraction gb1_pto : 53 | NodeLL(_x,?e) ~~> Garbage() 54 | where 55 | _x notincontext 56 | 57 | 58 | abstraction gb2_ls_ls: 59 | ls(_x,_y) * ls(_y,_x) ~~> Garbage() 60 | where 61 | _x,_y notincontext 62 | 63 | 64 | abstraction gb2_ls_pto: 65 | ls(_x,_y) * NodeLL(_y,_x) ~~> Garbage() 66 | where 67 | _x,_y notincontext 68 | 69 | 70 | abstraction gb2_pto_pto: 71 | NodeLL(_x,_y) * NodeLL(_y,_x) ~~> Garbage() 72 | where 73 | _x,_y notincontext 74 | 75 | /*************** End Junk Rules *******************/ 76 | 77 | 78 | /*************** Abs1 Rule *******************/ 79 | abstraction ls_ls: 80 | ls(?x,_x) * ls(_x,nil()) ~~> ls(?x,nil()) 81 | where 82 | _x notincontext; 83 | _x notin ?x 84 | 85 | 86 | abstraction ls_pto: 87 | ls(?x,_x) * NodeLL(_x,nil()) ~~> ls(?x,nil()) 88 | where 89 | _x notincontext; 90 | _x notin ?x 91 | 92 | 93 | abstraction pto_ls: 94 | NodeLL(?x,_x) * ls(_x,nil()) ~~> ls(?x,nil()) 95 | where 96 | _x notincontext; 97 | _x notin ?x 98 | 99 | 100 | abstraction pto_pto: 101 | NodeLL(?x,_x) * NodeLL(_x,nil()) ~~> ls(?x,nil()) 102 | where 103 | _x notincontext; 104 | _x notin ?x 105 | 106 | 107 | /*************** End Abs1 Rule *******************/ 108 | 109 | 110 | 111 | /*************** Abs2 Rule *******************/ 112 | abstraction ls_ls_ls: 113 | ls(?x,_x) * ls(_x,?y) * ls(?y,?z) ~~> ls(?x,?y) * ls(?y,?z) 114 | where 115 | _x notincontext; 116 | _x notin ?x; 117 | _x notin ?y; 118 | _x notin ?z 119 | 120 | 121 | abstraction ls_ls_pto: 122 | ls(?x,_x) * ls(_x,?y) * NodeLL(?y,?z) ~~> ls(?x,?y) * NodeLL(?y,?z) 123 | where 124 | _x notincontext; 125 | _x notin ?x; 126 | _x notin ?y; 127 | _x notin ?z 128 | 129 | 130 | abstraction ls_pto_ls: 131 | ls(?x,_x) * NodeLL(_x,?y) * ls(?y,?z) ~~> ls(?x,?y) * ls(?y,?z) 132 | where 133 | _x notincontext; 134 | _x notin ?x; 135 | _x notin ?y; 136 | _x notin ?z 137 | 138 | 139 | abstraction ls_pto_pto: 140 | ls(?x,_x) * NodeLL(_x,?y) * NodeLL(?y,?z) ~~> ls(?x,?y) * NodeLL(?y,?z) 141 | where 142 | _x notincontext; 143 | _x notin ?x; 144 | _x notin ?y; 145 | _x notin ?z 146 | 147 | 148 | abstraction pto_ls_ls: 149 | NodeLL(?x,_x) * ls(_x,?y) * ls(?y,?z) ~~> ls(?x,?y) * ls(?y,?z) 150 | where 151 | _x notincontext; 152 | _x notin ?x; 153 | _x notin ?y; 154 | _x notin ?z 155 | 156 | 157 | abstraction pto_ls_pto: 158 | NodeLL(?x,_x) * ls(_x,?y) * NodeLL(?y,?z) ~~> ls(?x,?y) * NodeLL(?y,?z) 159 | where 160 | _x notincontext; 161 | _x notin ?x; 162 | _x notin ?y; 163 | _x notin ?z 164 | 165 | 166 | abstraction pto_pto_ls: 167 | NodeLL(?x,_x) * NodeLL(_x,?y) * ls(?y,?z) ~~> ls(?x,?y) * ls(?y,?z) 168 | where 169 | _x notincontext; 170 | _x notin ?x; 171 | _x notin ?y; 172 | _x notin ?z 173 | 174 | 175 | abstraction pto_pto_pto: 176 | NodeLL(?x,_x) * NodeLL(_x,?y) * NodeLL(?y,?z) ~~> ls(?x,?y) * NodeLL(?y,?z) 177 | where 178 | _x notincontext; 179 | _x notin ?x; 180 | _x notin ?y; 181 | _x notin ?z 182 | 183 | 184 | 185 | /************************************* 186 | * Empty rules 187 | *********************************** 188 | rule NodeLL_nil2: 189 | NodeLL(nil(),?x) | |- 190 | if 191 | 192 | rule NodeLL_not_nil: 193 | NodeLL(?x,?y) | ?x!=nil() |- 194 | if 195 | | |- 196 | 197 | rule NodeLL_not_eq: 198 | NodeLL(?x,?y) * NodeLL(?z,?w) | ?x!=?z |- 199 | if 200 | | |- 201 | */ 202 | /*************** End Abs2 Rule *******************/ 203 | -------------------------------------------------------------------------------- /playground/abduction/test_while.symexec_logic: -------------------------------------------------------------------------------- 1 | import "field_logic"; 2 | 3 | 4 | /*************************************** 5 | * This file defines 6 | * 7 | * NodeLL 8 | * ls 9 | * lspe 10 | * 11 | ***************************************/ 12 | 13 | rule NodeLL_remove_exists: 14 | | NodeLL(_y, ?x) |- NodeLL(_z, ?x) 15 | without 16 | _y != _z 17 | if 18 | NodeLL(_z, ?x) | |- 19 | 20 | rule NodeLL_remove: 21 | | NodeLL(?x, ?y) |- NodeLL(?x, ?z) 22 | if 23 | NodeLL(?x, ?z) | |- ?y = ?z 24 | 25 | rule ls_remove_exists: 26 | | ls(_y, ?x) |- ls(_z, ?x) 27 | without 28 | _y != _z 29 | if 30 | ls(_z, ?x) | |- 31 | 32 | rule ls_remove: 33 | | ls(?x, ?y) |- ls(?x, ?z) 34 | if 35 | ls(?x, ?z) | |- ?y = ?z 36 | 37 | rule remove_exists_not_equal : 38 | | |- _x != ?y 39 | where 40 | _x notincontext; 41 | _x notin ?y 42 | if 43 | | |- 44 | 45 | 46 | /***************************************/ 47 | 48 | 49 | rule NodeLL_not_nil: 50 | NodeLL(nil(),?y) | |- 51 | if 52 | 53 | rule ls_not_nil: 54 | ls(nil(),?y) | |- 55 | if 56 | 57 | rule lspe_not_nil: 58 | lspe(nil(),?y) | |- 59 | if 60 | | ?y=nil() |- 61 | 62 | 63 | rule NodeLL_not_nil: 64 | NodeLL(?x,?y) | |- ?x!=nil() 65 | if 66 | | |- 67 | 68 | rule NodeLL_not_eq: 69 | NodeLL(?x,?y) * NodeLL(?x,?w) | |- 70 | if 71 | 72 | 73 | 74 | 75 | /************************************* 76 | * Rule for unpacking Nodell 77 | * 78 | * These rules could potentially cycle forever 79 | * but due to their order cannot. 80 | *************************************/ 81 | 82 | //Unroll NodeLL if we are looking for its next field 83 | rule field_remove1a: 84 | | NodeLL(?x,?e1) |- field(?x,"",?e2) 85 | if 86 | field(?x,"",?e1) | field(?x,"",_w) |- ?e1=?e2 87 | 88 | //Unroll NodeLL if we are looking for its content field 89 | rule field_remove1b: 90 | | NodeLL(?x,?e1) |- field(?x,"",?e2) 91 | if 92 | field(?x,"",w) | field(?x,"",?e1) |- w=?e2 93 | 94 | 95 | //Roll up a complete NodeLL if we have both fields. 96 | rule field_remove2: 97 | | field(?x,"",?e1) * field(?x,"",?z) |- 98 | if 99 | | NodeLL(?x,?e1) |- 100 | 101 | 102 | 103 | 104 | /************************************* 105 | * Simple subtraction rules 106 | *************************************/ 107 | 108 | 109 | rule ls_unroll_exists : 110 | | ls(?x,?y) |- field(?x,?w,?Z) 111 | if 112 | | NodeLL(?x,_fooz) * lspe(_fooz,?y) |- field(?x,?w,?Z) 113 | 114 | 115 | 116 | rule ls_ls_match : 117 | ls(?z,?w) | ls(?x,?y) |- ls(?x,?z) 118 | if 119 | ls(?x,?y) | |- lspe(?y,?z) 120 | 121 | rule ls_NodeLL_match : 122 | NodeLL(?z,?w) | ls(?x,?y) |- ls(?x,?z) 123 | if 124 | ls(?x,?y) | |- lspe(?y,?z) 125 | 126 | rule ls_field_match : 127 | field(?z,?f,?w) | ls(?x,?y) |- ls(?x,?z) 128 | if 129 | ls(?x,?y) | |- lspe(?y,?z) 130 | 131 | 132 | 133 | rule nl_ls_match : 134 | ls(?z,?w) | NodeLL(?x,?y) |- ls(?x,?z) 135 | if 136 | NodeLL(?x,?y) | |- lspe(?y,?z) 137 | 138 | rule nl_NodeLL_match : 139 | NodeLL(?z,?w) | NodeLL(?x,?y) |- ls(?x,?z) 140 | if 141 | NodeLL(?x,?y) | |- lspe(?y,?z) 142 | 143 | rule nl_field_match : 144 | field(?z,?f,?w) | NodeLL(?x,?y) |- ls(?x,?z) 145 | if 146 | ls(?x,?y) | |- lspe(?y,?z) 147 | 148 | 149 | 150 | 151 | rule lspe_left : 152 | | lspe(?x,?y) |- 153 | if 154 | | ls(?x,?y) |- 155 | or 156 | | ?x=?y |- 157 | 158 | 159 | rule lspe_right : 160 | | |- lspe(?x,?y) 161 | if 162 | | |- ls(?x,?y) 163 | or 164 | | |- ?x=?y 165 | 166 | 167 | /************************************* 168 | * rules for contradictions 169 | *************************************/ 170 | rule ls_field_contradiction1 : 171 | ls(?x,?t) * field(?x,"",?z) | |- 172 | if 173 | 174 | rule ls_field_contradiction2 : 175 | ls(?x,?t) * field(?x,"",?z) | |- 176 | if 177 | 178 | rule ls_node_contradiction : 179 | ls(?x,?t) * NodeLL(?x,?z) | |- 180 | if 181 | 182 | rule ls_ls_contr : 183 | ls(?x,?t) * ls(?x,?z) | |- 184 | if 185 | 186 | rule ls_ls_contr : 187 | | |- ls(?x,?t) * ls(?x,?z) 188 | if 189 | | |- x!=x 190 | -------------------------------------------------------------------------------- /playground/context/context_logic: -------------------------------------------------------------------------------- 1 | rewrite elist_cons_ex_s: 2 | elist(cons(_x, s(_y))) = match() 3 | where 4 | _x, _y notincontext 5 | 6 | rule s: 7 | | l = s(_x) | |- | 8 | without 9 | l = match() 10 | where 11 | _x notincontext 12 | if 13 | | l = match() | |- | 14 | -------------------------------------------------------------------------------- /playground/context/context_test: -------------------------------------------------------------------------------- 1 | /* 2 | Implication: 3 | l = app(elist(cons(_x, s(_y))), l1) | |- l = app(match(), l1) | 4 | ? True 5 | 6 | Implication: 7 | l = elist(cons(_x, s(_y))) | |- l = match() | 8 | ? True 9 | */ 10 | 11 | Implication: 12 | l = elist(cons(_x, s(_y))) * p(l) | |- l = match() | 13 | ? True 14 | 15 | /* 16 | Implication: 17 | l = s(_x) | |- l = match() | 18 | ? True 19 | */ -------------------------------------------------------------------------------- /playground/fresh/fresh_logic: -------------------------------------------------------------------------------- 1 | rewrite length_cons_abs: 2 | builtin_plus(numeric_const("1"), length(?alpha)) = length(cons(?a, ?alpha)) 3 | if 4 | cons(?a, ?alpha) = ?b 5 | -------------------------------------------------------------------------------- /playground/fresh/fresh_tests: -------------------------------------------------------------------------------- 1 | Implication: 2 | builtin_plus(numeric_const("1"), length(alpha)) = i * cons(a, alpha) = j | |- length(cons(a, alpha)) = i | 3 | ? True 4 | 5 | -------------------------------------------------------------------------------- /playground/neq/logic: -------------------------------------------------------------------------------- 1 | equiv lt_zero_n: 2 | (numeric_const("0") < numeric_const(?n)) <=> ?n != "0" 3 | -------------------------------------------------------------------------------- /playground/neq/test: -------------------------------------------------------------------------------- 1 | Implication: 2 | |- (numeric_const("0") < numeric_const("1")) 3 | ? True 4 | 5 | 6 | Implication: 7 | |- "0" != "1" 8 | ? True 9 | -------------------------------------------------------------------------------- /playground/without/list_ext.logic: -------------------------------------------------------------------------------- 1 | /** 2 | * Extends list logic. 3 | **/ 4 | 5 | /* 6 | Identity: (a::alpha) @ beta = a::(alpha @ beta). 7 | 8 | The rewrite rule pushes applications to deeper nesting levels. 9 | */ 10 | rewrite app_cons: 11 | app(cons(?a, ?alpha), ?beta) = cons(?a, app(?alpha, ?beta)) 12 | without 13 | app(cons(?a, ?alpha), ?beta) = cons(?a, ?alpha) 14 | || app(cons(?a, ?alpha), ?beta) = cons(?a, ?beta) 15 | || app(cons(?a, ?alpha), ?beta) = cons(?a, app(?alpha, ?beta)) 16 | || app(cons(?a, ?alpha), ?beta) = ?alpha 17 | || app(cons(?a, ?alpha), ?beta) = ?beta 18 | 19 | rule cons_contradication: 20 | | cons(?a, ?alpha) = ?alpha |- 21 | if 22 | 23 | /* 24 | Contradiction. 25 | 26 | If we have (a::alpha) @ beta = alpha, then we have a contradiction (since 27 | a::beta is non-empty) and we are done. 28 | */ 29 | /* 30 | rule app_cons_first_contradiction_left: 31 | | app(cons(?a, ?alpha), ?beta) = ?alpha |- 32 | if 33 | */ 34 | /* 35 | Associativity Rule. 36 | Identity: (alpha @ beta) @ gamma = alpha @ (beta @ gamma). 37 | 38 | Move appends to the right. Side conditions prevent the application of the 39 | rule in the trivial when one of the sub-lists is empty. In the trivial case, 40 | the terms should be simplified by the rules app_nil_1 and app_nil_2. 41 | */ 42 | rewrite app_assoc: 43 | app(app(?alpha, ?beta), ?gamma) = app(?alpha, app(?beta, ?gamma)) 44 | without 45 | ?alpha = empty() 46 | || ?beta = empty() 47 | || ?gamma = empty() 48 | || app(app(?alpha, ?beta), ?gamma) = app(?alpha, ?beta) 49 | || app(app(?alpha, ?beta), ?gamma) = app(?alpha, ?gamma) 50 | || app(app(?alpha, ?beta), ?gamma) = app(?beta, ?gamma) 51 | || app(app(?alpha, ?beta), ?gamma) = ?alpha 52 | || app(app(?alpha, ?beta), ?gamma) = ?beta 53 | || app(app(?alpha, ?beta), ?gamma) = ?gamma 54 | 55 | -------------------------------------------------------------------------------- /playground/without/list_ext.test: -------------------------------------------------------------------------------- 1 | /******************************* 2 | * Tests for "list_ext.logic". * 3 | *******************************/ 4 | 5 | Implication: 6 | app(cons(a, alpha), beta) = alpha | |- | False 7 | ? True 8 | -------------------------------------------------------------------------------- /playground/without_rhs/logic: -------------------------------------------------------------------------------- 1 | rule req: 2 | | |- ?i = ?j 3 | without 4 | |- ?i = ?j 5 | if 6 | -------------------------------------------------------------------------------- /playground/without_rhs/test: -------------------------------------------------------------------------------- 1 | Implication: 2 | |- i = j 3 | ? True 4 | -------------------------------------------------------------------------------- /scripts/Makefile: -------------------------------------------------------------------------------- 1 | ML=infermli unused 2 | BYTE=$(patsubst %,%.byte,$(ML)) 3 | 4 | byte: 5 | ocamlbuild -cflag -g -lflag -g $(BYTE) 6 | 7 | native: 8 | ocamlbuild -cflags -g,-p -lflags -g,-p $(patsubst %,%.native,$(ML)) 9 | 10 | clean: 11 | ocamlbuild -clean 12 | -------------------------------------------------------------------------------- /scripts/id_extractor.mll: -------------------------------------------------------------------------------- 1 | let id_re = ['A'-'Z' 'a'-'z'] ['A'-'Z' 'a'-'z' '0'-'9' '_' '\'']* 2 | 3 | rule id hash = parse 4 | | "(*" { comment lexbuf; id hash lexbuf } 5 | | id_re as x { Hashtbl.replace hash x (); id hash lexbuf } 6 | | eof { () } 7 | | _ { id hash lexbuf } 8 | and id_decl hash = parse 9 | | "(*" { comment lexbuf; id_decl hash lexbuf } 10 | | ("val"|"exception") [' ' '\t']+ (id_re as x) [^'\n']* 11 | { Hashtbl.replace hash x (); id_decl hash lexbuf } 12 | | eof { () } 13 | | _ { id_decl hash lexbuf } 14 | and comment = parse 15 | | "(*" { comment lexbuf; comment lexbuf } 16 | | "*)" { () } 17 | | eof { () } 18 | | _ { comment lexbuf } 19 | -------------------------------------------------------------------------------- /scripts/infermli.ml: -------------------------------------------------------------------------------- 1 | (** Run from the root directory of coreStar. *) 2 | 3 | let _ = 4 | let src_dirs = "src" :: Utils.files_map Sys.is_directory (fun x->x) "src" in 5 | let cmd_prefix = "ocamlbuild -I " ^ String.concat " -I " src_dirs in 6 | let infer_mli fn = 7 | let fn = Filename.basename fn in 8 | let fn = Filename.chop_suffix fn ".ml" in 9 | ignore (Sys.command (cmd_prefix ^ " " ^ fn ^ ".inferred.mli")) in 10 | let filter fn = 11 | Filename.check_suffix fn ".ml" && 12 | not (Sys.file_exists (fn ^ "i")) in 13 | Utils.files_iter filter infer_mli "src" 14 | -------------------------------------------------------------------------------- /scripts/make_release.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | PROGRAM="corestar" 3 | COPY="\ 4 | configure \ 5 | COPYRIGHT \ 6 | library \ 7 | LICENSE.txt \ 8 | README \ 9 | src \ 10 | unit_tests \ 11 | " 12 | 13 | log () { 14 | echo "$1" 15 | } 16 | 17 | usage () { 18 | echo "make_release.sh []" 19 | exit 1 20 | } 21 | 22 | try () { 23 | "$@" 24 | if (( $? )); then 25 | echo "Failed: $*" > /dev/stderr 26 | exit 2 27 | fi 28 | } 29 | 30 | HERE="$(pwd)" 31 | VERSION="$(date +%Y%m)" 32 | if (( $# < 1 )); then usage; fi 33 | ROOT="$1" 34 | if (( $# == 2 )); then VERSION="$2"; fi 35 | log "HERE=$HERE; ROOT=$ROOT; VERSION=$VERSION" 36 | 37 | DIR="$PROGRAM-$VERSION" 38 | TAR="$DIR.tar.bz2" 39 | log "DIR=$DIR; TAR=$TAR" 40 | 41 | mkdir -p "$DIR" 42 | rm -rf "$DIR/*" 43 | 44 | cd "$ROOT" 45 | try make clean 46 | for f in $COPY; do cp -r "$f" "$HERE/$DIR"; done 47 | grep -v -e "\" Makefile > "$HERE/$DIR/Makefile" 48 | mkdir -p "$HERE/$DIR/bin" 49 | 50 | cd "$HERE" 51 | rm -f "$TAR" 52 | tar caf "$TAR" "$DIR" 53 | 54 | rm -rf "$DIR" 55 | -------------------------------------------------------------------------------- /scripts/unused.ml: -------------------------------------------------------------------------------- 1 | (** Finds stuff declared in mli that is not used in *other* ml-s. *) 2 | 3 | open Format 4 | 5 | type file_info = { 6 | path : string; 7 | declarations : string list; (* ids appearing in mli *) 8 | uses : string list (* ids appearing in ml *) 9 | } 10 | 11 | let list_of_hashtbl h = Hashtbl.fold (fun x () xs -> x :: xs) h [] 12 | 13 | let get_ids fn lexer = 14 | let h = Hashtbl.create 101 in 15 | try 16 | let c = open_in fn in 17 | let lb = Lexing.from_channel (open_in fn) in 18 | lexer h lb; 19 | let r = list_of_hashtbl h in 20 | close_in c; 21 | r 22 | with Sys_error _ -> 23 | printf "@[Warning: missing %s@." fn; [] 24 | 25 | let parse fn = { 26 | path = fn; 27 | declarations = get_ids (fn ^ "i") Id_extractor.id_decl; 28 | uses = get_ids fn Id_extractor.id 29 | } 30 | 31 | module StringSet = Set.Make (String) 32 | 33 | let _ = 34 | let fis = 35 | Utils.files_map (fun x->Filename.check_suffix x ".ml") parse "src" in 36 | let fis = 37 | Utils.files_map 38 | (fun x->Filename.check_suffix x ".mly" || Filename.check_suffix x ".mll") 39 | (fun fn->{path=fn;declarations=[];uses=get_ids fn Id_extractor.id}) 40 | "src" 41 | @ fis in 42 | let h1 = Hashtbl.create 10007 in 43 | let h2 = Hashtbl.create 10007 in 44 | let add_use u = 45 | if not (Hashtbl.mem h2 u) then 46 | begin 47 | if not (Hashtbl.mem h1 u) then 48 | Hashtbl.add h1 u () 49 | else 50 | begin 51 | Hashtbl.remove h1 u; 52 | Hashtbl.add h2 u () 53 | end 54 | end in 55 | List.iter (fun {uses=uses;declarations=_;path=_} -> List.iter add_use uses) fis; 56 | let process {path=path; declarations=declarations; uses=_} = 57 | let bd = List.fold_left 58 | (fun s d -> if Hashtbl.mem h1 d then StringSet.add d s else s) 59 | StringSet.empty 60 | declarations in 61 | if not (StringSet.is_empty bd) then 62 | begin 63 | printf "@\n@[<4>%si@\n" path; 64 | StringSet.iter (fun x -> printf "%s@\n" x) bd; 65 | printf "@]" 66 | end in 67 | printf "@["; 68 | List.iter process fis; 69 | printf "@." 70 | 71 | -------------------------------------------------------------------------------- /scripts/utils.ml: -------------------------------------------------------------------------------- 1 | (** Functions used by more than one script. *) 2 | 3 | (** [files_fold p f init dir] folds over all filenames under [dir] 4 | * which satisfy [p]. *) 5 | let rec files_fold p f init dir = 6 | let acc = ref init in 7 | let sub = Sys.readdir dir in 8 | for i = 0 to Array.length sub - 1 do begin 9 | let fn = Filename.concat dir sub.(i) in 10 | if p fn then acc := f !acc fn; 11 | if Sys.is_directory fn then acc := files_fold p f !acc fn 12 | end done; 13 | !acc 14 | let files_map p f = files_fold p (fun xs y -> f y :: xs) [] 15 | let files_iter p f = files_fold p (fun () y -> f y) () 16 | 17 | 18 | -------------------------------------------------------------------------------- /setenv: -------------------------------------------------------------------------------- 1 | export CORESTAR_HOME=`pwd` 2 | export PATH=`pwd`/bin:$PATH 3 | -------------------------------------------------------------------------------- /setenv.bat: -------------------------------------------------------------------------------- 1 | @echo off 2 | set CORESTAR_HOME=%CD% 3 | set PATH=%PATH%;%CD%\bin 4 | -------------------------------------------------------------------------------- /src/abs_int/syntactic.ml: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/prover/abs.ml 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | (* Syntactic abstraction *) 15 | (* TODO: Possibly incorrect treatment of disjunctions *) 16 | (* TODO: Rewrite to operate on pform directly *) 17 | 18 | open Cterm 19 | open Clogic 20 | open Psyntax 21 | open Plugin 22 | 23 | 24 | (* Finds existentials in the spatial part *) 25 | let rec find_ev_sp syn = 26 | if syn.sdisjuncts = [] then 27 | SMSet.fold_to_list syn.sspat (fun t vs -> 28 | vs_union (ev_args_list (snd t) vs_empty) vs) vs_empty 29 | else begin 30 | List.fold_left (fun vs (s1, s2) -> 31 | vs_union (vs_union (find_ev_sp s1) (find_ev_sp s2)) vs 32 | ) vs_empty syn.sdisjuncts 33 | end 34 | 35 | 36 | (* Finds existentials in equalities and inequalities *) 37 | let rec find_ev_eq_neq syn vset = 38 | let get_evs a1 a2 = 39 | if (vs_is_empty (vs_inter vset (ev_args a1 vs_empty)) <> true || 40 | vs_is_empty (vs_inter vset (ev_args a2 vs_empty)) <> true) then 41 | vs_union vset (vs_union (ev_args a1 vs_empty) (ev_args a2 vs_empty)) 42 | else 43 | vset 44 | in 45 | if syn.sdisjuncts = [] then 46 | let evs_eqs = List.fold_left (fun vs (a1, a2) -> vs_union vs (get_evs a1 a2)) vs_empty syn.seqs in 47 | let evs_neqs = List.fold_left (fun vs (a1, a2) -> vs_union vs (get_evs a1 a2)) vs_empty syn.sneqs in 48 | vs_union evs_eqs evs_neqs 49 | else begin 50 | List.fold_left (fun vs (s1, s2) -> 51 | vs_union (vs_union (find_ev_eq_neq s1 vset) (find_ev_eq_neq s2 vset)) vs 52 | ) vs_empty syn.sdisjuncts 53 | end 54 | 55 | 56 | (* Heuristic abstraction on syntactic form that eliminates existentials which are not in the spatial part *) 57 | let kill_unused_existentials syn_form = 58 | (* iterates until the set of existentials becomes saturated *) 59 | let rec saturate_ev syn evars = 60 | let new_evars = find_ev_eq_neq syn evars in 61 | if (vs_is_empty (vs_diff new_evars evars)) then new_evars 62 | else saturate_ev syn new_evars 63 | in 64 | let rec saturate_ev_cnt syn evars cnt = 65 | if cnt = 0 then evars 66 | else saturate_ev_cnt syn (find_ev_eq_neq syn evars) (cnt-1) 67 | in 68 | (*let ev_sp = saturate_ev_cnt syn_form (find_ev_sp syn_form) 2 in*) 69 | let ev_sp = saturate_ev syn_form (find_ev_sp syn_form) in 70 | let rec elim_evars syn = 71 | (* ignore terms with heads from forbidden_heads *) 72 | let forbidden_heads = ["Ast"] in 73 | let rec is_not_forbidden arg = 74 | match arg with 75 | | Arg_var v -> true 76 | | Arg_string s -> true 77 | | Arg_op (name, args) -> 78 | ((List.mem name forbidden_heads) <> true) && 79 | (List.for_all (fun arg -> is_not_forbidden arg) args) 80 | | _ -> assert false 81 | in 82 | (* condition for killing a term *) 83 | let can_kill vs = 84 | (vs_is_empty vs <> true) && (* the set of free variables must be non empty *) 85 | (vs_is_empty (vs_inter ev_sp vs)) && (* the intersection with existentials in spatials must be empty *) 86 | (vs_for_all (fun v -> match v with Vars.EVar _ -> true | _ -> false) vs) (* in there should be only existential vars *) 87 | in 88 | (* filters terms in a multiset *) 89 | let rec filter_args_mset ms : SMSet.multiset = 90 | if SMSet.has_more ms then begin 91 | if can_kill (fv_args_list (snd (SMSet.peek ms)) vs_empty) && 92 | ((List.mem (fst (SMSet.peek ms)) forbidden_heads) <> true) then 93 | filter_args_mset (snd (SMSet.remove ms)) 94 | else 95 | filter_args_mset (SMSet.next ms) 96 | end 97 | else SMSet.restart ms 98 | in 99 | (* filters terms in a list of pairs *) 100 | let filter_args_pls xs = 101 | List.filter (fun (a1, a2) -> 102 | (can_kill (vs_union (fv_args a1 vs_empty) (fv_args a2 vs_empty)) <> true) && 103 | (is_not_forbidden a1) && (is_not_forbidden a2) 104 | ) xs 105 | in 106 | if syn.sdisjuncts = [] then 107 | let plain = filter_args_mset syn.splain in 108 | let eqs = filter_args_pls syn.seqs in 109 | let neqs = filter_args_pls syn.sneqs in 110 | { sspat = syn.sspat; 111 | splain = plain; 112 | sdisjuncts = syn.sdisjuncts; 113 | seqs = eqs; 114 | sneqs = neqs } 115 | else 116 | let disjuncts = 117 | List.map (fun (s1, s2) -> (elim_evars s1, elim_evars s2)) syn.sdisjuncts 118 | in 119 | { sspat = syn.sspat; 120 | splain = syn.splain; 121 | sdisjuncts = disjuncts; 122 | seqs = syn.seqs; 123 | sneqs = syn.sneqs } 124 | in 125 | if Config.symb_debug() then 126 | Format.printf "\nBefore syntactic abstraction: %a@\n" pp_syntactic_form syn_form; 127 | let abs_syn_form = elim_evars syn_form in 128 | if Config.symb_debug() then 129 | Format.printf "After syntactic abstraction: %a@\n" pp_syntactic_form abs_syn_form; 130 | abs_syn_form 131 | 132 | 133 | let syn_abs pform = 134 | let syn_form = convert_to_inner pform in 135 | let abs_syn_form = kill_unused_existentials syn_form in 136 | convert_to_pform abs_syn_form 137 | 138 | 139 | let my_abs_int = { 140 | abstract_val = Some (ref syn_abs); 141 | join = None; 142 | meet = None; 143 | widening = None; 144 | } 145 | 146 | (* Plugin registration *) 147 | let _ = 148 | Plugin_callback.add_abs_int (ref my_abs_int) 149 | -------------------------------------------------------------------------------- /src/parsing/.depend: -------------------------------------------------------------------------------- 1 | global_types.cmo: spec_def.cmo 2 | global_types.cmx: spec_def.cmx 3 | load.cmo: global_types.cmo 4 | load.cmx: global_types.cmx 5 | spec_def.cmo: 6 | spec_def.cmx: 7 | support_syntax.cmo: 8 | support_syntax.cmx: 9 | -------------------------------------------------------------------------------- /src/parsing/lexer.mll: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/parsing/lexer.mll 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | { 15 | 16 | open Lexing 17 | open Parser 18 | 19 | type error = 20 | | Illegal_character of char 21 | | Unterminated_comment 22 | 23 | exception Error of error * Lexing.lexbuf 24 | 25 | let nest_depth = ref 0 26 | let nest_start_pos = ref dummy_pos 27 | let nest x = incr nest_depth; nest_start_pos := x.lex_curr_p 28 | let unnest x = decr nest_depth; !nest_depth <> 0 29 | 30 | let string_of_position p = 31 | let r = Buffer.create 10 in 32 | if p.pos_fname <> "" then begin 33 | Buffer.add_string r p.pos_fname; Buffer.add_char r ':' 34 | end; 35 | Printf.bprintf r "%d:%d" p.pos_lnum (p.pos_cnum - p.pos_bol); 36 | Buffer.contents r 37 | 38 | let error_message e lb = 39 | match e with 40 | Illegal_character c -> 41 | Printf.sprintf "%s: illegal character: %s\n" 42 | (string_of_position lb.lex_curr_p) (Char.escaped c) 43 | | Unterminated_comment -> 44 | Printf.sprintf "%s: unterminated comment\n" 45 | (string_of_position !nest_start_pos) 46 | 47 | (* [kwd_or_else d s] is the token corresponding to [s] if there is one, 48 | or the default [d] otherwise. *) 49 | let kwd_or_else = 50 | let keyword_table = Hashtbl.create 53 in 51 | List.iter (fun (kwd, tok) -> Hashtbl.add keyword_table kwd tok) [ 52 | "Abduction", ABDUCTION; 53 | "abstraction", ABSRULE; 54 | "assign", ASSIGN; 55 | "axioms", AXIOMS; 56 | "constructor", CONSTRUCTOR; 57 | "Emp", EMP; 58 | "end", END; 59 | "equiv", EQUIV; 60 | "False", FALSE; 61 | "Frame", FRAME; 62 | "goto", GOTO; 63 | "if", IF; 64 | "Implication", IMPLICATION; 65 | "import", IMPORT; 66 | "Inconsistency", INCONSISTENCY; 67 | "label", LABEL; 68 | "nop", NOP; 69 | "notin", NOTIN; 70 | "notincontext", NOTINCONTEXT; 71 | "pureguard", PUREGUARD; 72 | "or", ORTEXT; 73 | "rewrite", REWRITERULE; 74 | "rule", RULE; 75 | "Specification", SPECIFICATION; 76 | "SpecTest", SPECTEST; 77 | "True", TRUE; 78 | "where", WHERE; 79 | "with", WITH; 80 | "without", WITHOUT; 81 | ]; 82 | fun d s -> 83 | try Hashtbl.find keyword_table s with Not_found -> d 84 | 85 | } 86 | 87 | 88 | (* ====================================================================== *) 89 | 90 | let dec_digit = ['0' - '9'] 91 | 92 | let not_cr_lf = [ ^ '\010' '\013'] 93 | 94 | let alpha_char = ['a' - 'z'] | ['A' - 'Z'] 95 | 96 | let simple_id_char = alpha_char | dec_digit | '_' | '.' | '$' 97 | 98 | let first_id_char = alpha_char | '_' | '$' 99 | 100 | let string_char = ['\000' - '\033'] | ['\035' - '\091'] | ['\093' - '\127'] 101 | 102 | let line_comment = "//" not_cr_lf* 103 | 104 | let blank = (' ' | '\009')+ 105 | 106 | let ignored_helper = (blank | line_comment)+ 107 | 108 | let newline = ('\013' | '\010' | "\010\013") 109 | 110 | let at_identifier = 111 | '@' (simple_id_char | ':')* 112 | 113 | let identifier = 114 | first_id_char simple_id_char* 115 | 116 | rule token = parse 117 | | newline { Lexing.new_line lexbuf; token lexbuf } 118 | | "/*" { nest lexbuf; comment lexbuf; token lexbuf } 119 | | ignored_helper { token lexbuf } 120 | | "," { COMMA } 121 | | "{" { L_BRACE } 122 | | "}" { R_BRACE } 123 | | ";" { SEMICOLON } 124 | | "[" { L_BRACKET } 125 | | "]" { R_BRACKET } 126 | | "(" { L_PAREN } 127 | | ")" { R_PAREN } 128 | | ":" { COLON } 129 | | "." { DOT } 130 | | "'" { QUOTE } 131 | | ":=" { COLON_EQUALS } 132 | | "=" { EQUALS } 133 | | "&" { AND } 134 | | "|" { OR } 135 | | "||" { OROR } 136 | | "!=" { NOT_EQUALS } 137 | | "*" { MULT } 138 | | "-*" { WAND } 139 | | "=>" { IMP } 140 | | "<=>" { BIMP } 141 | | "?" { QUESTIONMARK } 142 | | "!" { BANG } 143 | | "|-" { VDASH } 144 | | "-|" { DASHV } 145 | | "~~>" { LEADSTO } 146 | | "/" { OP_DIV } 147 | | "-" { OP_MINUS } 148 | | "+" { OP_PLUS } 149 | | "<=" { CMP_LE } 150 | | "<" { CMP_LT } 151 | | ">=" { CMP_GE } 152 | | ">" { CMP_GT } 153 | | eof { EOF } 154 | 155 | (* Both at_identifer and identifer should produce IDENTIFIER *) 156 | | at_identifier as s { kwd_or_else (IDENTIFIER s) s } 157 | | identifier as s { kwd_or_else (IDENTIFIER s) s } 158 | 159 | (* FIXME: What is the right lexing of string constants? *) 160 | | '"' (string_char* as s) '"' { STRING_CONSTANT s } 161 | | _ { Printf.printf "here2 %!"; failwith (error_message (Illegal_character ((Lexing.lexeme lexbuf).[0])) lexbuf)} 162 | and comment = parse 163 | | "/*" { nest lexbuf; comment lexbuf } 164 | | "*/" { if unnest lexbuf then comment lexbuf } 165 | | newline { Lexing.new_line lexbuf; comment lexbuf } 166 | | eof { failwith (error_message Unterminated_comment lexbuf)} 167 | | _ { comment lexbuf; } 168 | 169 | 170 | (* ====================================================================== *) 171 | 172 | { (* trailer *) 173 | } 174 | -------------------------------------------------------------------------------- /src/parsing/load_logic.ml: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/parsing/load_logic.ml 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | (* File to read a logic file and its imports. *) 15 | open Debug 16 | open Format 17 | open Load 18 | open Psyntax 19 | open System 20 | 21 | let load_logic_extra_rules 22 | dirs filename extra_rules 23 | : (Psyntax.sequent_rule list * Psyntax.rewrite_rule list * string list) = 24 | let fileentrys = 25 | import_flatten_extra_rules dirs filename extra_rules Parser.rule_file Lexer.token in 26 | let rl = expand_equiv_rules fileentrys in 27 | let sl,rm,cn = 28 | List.fold_left 29 | (fun (sl,rm,cn) rule -> 30 | match rule with 31 | | ConsDecl(f) -> (sl,rm,f::cn) 32 | | SeqRule(r) -> (r::sl,rm,cn) 33 | | RewriteRule(r) -> (sl,r::rm,cn) 34 | | EquivRule(r) -> assert false) 35 | ([], [], []) 36 | rl 37 | in 38 | if log log_load then 39 | fprintf logf "@[<2>Sequent rules%a@." (pp_list pp_sequent_rule) sl; 40 | (sl,rm,cn) 41 | 42 | let load_logic_internal 43 | dirs filename 44 | : (sequent_rule list * rewrite_rule list * string list) = 45 | load_logic_extra_rules dirs filename [] 46 | 47 | let load_logic = load_logic_internal Cli_utils.logic_dirs 48 | let load_abstractions = load_logic_internal Cli_utils.abs_dirs 49 | -------------------------------------------------------------------------------- /src/parsing/load_logic.mli: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/parsing/load_logic.mli 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | (* TODO(rgrig): replace tuple by record *) 15 | 16 | val load_logic_extra_rules : 17 | string list -> 18 | string -> 19 | Psyntax.rules Load.importoption list -> 20 | Psyntax.sequent_rule list * Psyntax.rewrite_rule list * string list 21 | 22 | val load_logic : 23 | string -> 24 | Psyntax.sequent_rule list * Psyntax.rewrite_rule list * string list 25 | (** [load_logic f] loads logic file [f] (see [Cli_utils]) and parses it. *) 26 | 27 | val load_abstractions : 28 | string -> 29 | Psyntax.sequent_rule list * Psyntax.rewrite_rule list * string list 30 | (** [load_abstractions f] loads logic file [f] (see [Cli_utils]) and 31 | parses it. *) 32 | 33 | -------------------------------------------------------------------------------- /src/plugin_interface/plugin.ml: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/plugins/plugin.ml 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | type abs_int = 16 | { 17 | abstract_val : (Psyntax.pform -> Psyntax.pform) ref option; 18 | join : (Psyntax.pform -> Psyntax.pform -> Psyntax.pform) ref option; 19 | meet : (Psyntax.pform -> Psyntax.pform -> Psyntax.pform) ref option; 20 | widening : (Psyntax.pform -> Psyntax.pform -> Psyntax.pform) ref option; 21 | } 22 | -------------------------------------------------------------------------------- /src/plugin_interface/plugin_callback.ml: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/plugins/plugin_callback.ml 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | (* Function to be called by a plugin for abstract interpretation *) 16 | let add_abs_int (impl : Plugin.abs_int ref) = 17 | Registry.abs_int_registry := !Registry.abs_int_registry @ [impl] 18 | -------------------------------------------------------------------------------- /src/plugin_interface/plugin_callback.mli: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/plugins/plugin_callback.mli 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | (* Function to be called by a plugin for abstract interpretation *) 16 | val add_abs_int : Plugin.abs_int ref -> unit 17 | -------------------------------------------------------------------------------- /src/plugin_interface/plugin_manager.ml: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/plugins/plugin_manager.ml 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | open Plugin 16 | 17 | 18 | (* Loads plugin using (nat) dynlink *) 19 | let load_plugin (filename : string) = 20 | try Dynlink.loadfile (Dynlink.adapt_filename filename) 21 | with Dynlink.Error e -> failwith (Dynlink.error_message e) 22 | 23 | 24 | (* Runs abstract_val from abstract interpretation plugins on a given pform *) 25 | let abstract_val (pheap : Psyntax.pform) : Psyntax.pform = 26 | List.fold_left (fun pform abs_int -> 27 | match (!abs_int).abstract_val with 28 | | None -> pform 29 | | Some abstract_val -> !abstract_val pform) 30 | pheap !Registry.abs_int_registry 31 | 32 | (* Runs join from abstract interpretation plugins on given pforms *) 33 | let join (pheap1 : Psyntax.pform) (pheap2 : Psyntax.pform) : Psyntax.pform list = 34 | List.map (fun join -> !join pheap1 pheap2) 35 | (Misc.map_option (fun abs_int -> (!abs_int).join) !Registry.abs_int_registry) 36 | 37 | (* Runs meet from abstract interpretation plugins on given pforms *) 38 | let meet (pheap1 : Psyntax.pform) (pheap2 : Psyntax.pform) : Psyntax.pform list = 39 | List.map (fun meet -> !meet pheap1 pheap2) 40 | (Misc.map_option (fun abs_int -> (!abs_int).meet) !Registry.abs_int_registry) 41 | 42 | (* Runs widening from abstract interpretation plugins on given pforms *) 43 | let widening (pheap1 : Psyntax.pform) (pheap2 : Psyntax.pform) : Psyntax.pform list = 44 | List.map (fun widening -> !widening pheap1 pheap2) 45 | (Misc.map_option (fun abs_int -> (!abs_int).widening) !Registry.abs_int_registry) 46 | 47 | 48 | (* Force Plugin_callback.add_abs_int to be linked with plugin_interface; 49 | there does not seem to be another way do achieve this from the code *) 50 | let _ = Plugin_callback.add_abs_int 51 | -------------------------------------------------------------------------------- /src/plugin_interface/plugin_manager.mli: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/plugins/plugin_manager.mli 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | (* Loads plugin using (nat) dynlink *) 16 | val load_plugin : string -> unit 17 | 18 | 19 | (* Runs abstract_val from abstract interpretation plugins on a given pform *) 20 | val abstract_val : Psyntax.pform -> Psyntax.pform 21 | 22 | (* Runs join from abstract interpretation plugins on given pforms *) 23 | val join : Psyntax.pform -> Psyntax.pform -> Psyntax.pform list 24 | 25 | (* Runs meet from abstract interpretation plugins on given pforms *) 26 | val meet : Psyntax.pform -> Psyntax.pform -> Psyntax.pform list 27 | 28 | (* Runs widening from abstract interpretation plugins on given pforms *) 29 | val widening : Psyntax.pform -> Psyntax.pform -> Psyntax.pform list 30 | -------------------------------------------------------------------------------- /src/plugin_interface/registry.ml: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/plugins/registry.ml 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | (* Registry of plugins for abstract interpretation *) 16 | let abs_int_registry : (Plugin.abs_int ref) list ref = ref [] 17 | -------------------------------------------------------------------------------- /src/prover/clogic.mli: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/prover/clogic.mli 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | exception Success 15 | exception Failed 16 | exception Assm_Contradiction 17 | module RMSet : 18 | sig 19 | type t = string * Cterm.term_handle 20 | type multiset 21 | val is_empty : multiset -> bool 22 | val has_more : multiset -> bool 23 | val next : multiset -> multiset 24 | val peek : multiset -> t 25 | val remove : multiset -> t * multiset 26 | val restart : multiset -> multiset 27 | val iter : (t -> unit) -> multiset -> unit 28 | val fold : ('a -> t -> 'a) -> 'a -> multiset -> 'a 29 | val lift_list : t list -> multiset 30 | val union : multiset -> multiset -> multiset 31 | val empty : multiset 32 | val intersect : multiset -> multiset -> multiset * multiset * multiset 33 | val back : multiset -> int -> multiset 34 | val map_to_list : multiset -> (t -> 'a) -> 'a list 35 | val fold_to_list : multiset -> (t -> 'a -> 'a) -> 'a -> 'a 36 | end 37 | type multiset = RMSet.multiset 38 | module SMSet : 39 | sig 40 | type t = string * Psyntax.args list 41 | type multiset 42 | val is_empty : multiset -> bool 43 | val has_more : multiset -> bool 44 | val next : multiset -> multiset 45 | val peek : multiset -> t 46 | val remove : multiset -> t * multiset 47 | val restart : multiset -> multiset 48 | val iter : (t -> unit) -> multiset -> unit 49 | val fold : ('a -> t -> 'a) -> 'a -> multiset -> 'a 50 | val lift_list : t list -> multiset 51 | val union : multiset -> multiset -> multiset 52 | val empty : multiset 53 | val intersect : multiset -> multiset -> multiset * multiset * multiset 54 | val back : multiset -> int -> multiset 55 | val map_to_list : multiset -> (t -> 'a) -> 'a list 56 | val fold_to_list : multiset -> (t -> 'a -> 'a) -> 'a -> 'a 57 | end 58 | type syntactic_form = { 59 | sspat : SMSet.multiset; 60 | splain : SMSet.multiset; 61 | sdisjuncts : (syntactic_form * syntactic_form) list; 62 | seqs : (Psyntax.args * Psyntax.args) list; 63 | sneqs : (Psyntax.args * Psyntax.args) list; 64 | } 65 | type formula = { 66 | spat : RMSet.multiset; 67 | plain : RMSet.multiset; 68 | disjuncts : (formula * formula) list; 69 | eqs : (Cterm.term_handle * Cterm.term_handle) list; 70 | neqs : (Cterm.term_handle * Cterm.term_handle) list; 71 | } 72 | module F: 73 | sig 74 | type ts_formula = { 75 | ts : Cterm.term_structure; 76 | form : formula; 77 | } 78 | end 79 | module AF: 80 | sig 81 | type ts_formula = { 82 | ts : Cterm.term_structure; 83 | form : formula; 84 | antiform : formula; 85 | } 86 | end 87 | val mk_ts_form : Cterm.term_structure -> formula -> F.ts_formula 88 | val mk_ts_form_af : Cterm.term_structure -> formula -> formula -> AF.ts_formula 89 | val break_ts_form : F.ts_formula -> Cterm.term_structure * formula 90 | val break_ts_form_af : AF.ts_formula -> Cterm.term_structure * formula * formula 91 | val kill_var : F.ts_formula -> Vars.var -> F.ts_formula 92 | val kill_var_af : AF.ts_formula -> Vars.var -> AF.ts_formula 93 | val update_var_to : F.ts_formula -> Vars.var -> Psyntax.args -> F.ts_formula 94 | val update_var_to_af : AF.ts_formula -> Vars.var -> Psyntax.args -> AF.ts_formula 95 | val pp_ts_formula : Format.formatter -> F.ts_formula -> unit 96 | val pp_ts_formula_af : Format.formatter -> AF.ts_formula -> unit 97 | val pp_syntactic_form : Format.formatter -> syntactic_form -> unit 98 | val conjunction : formula -> formula -> formula 99 | val empty : formula 100 | val false_sform : syntactic_form 101 | val truth : formula 102 | val is_sempty : syntactic_form -> bool 103 | val add_eqs_list : (Cterm.term_handle * Cterm.term_handle) list -> Cterm.term_structure -> Cterm.term_structure 104 | val add_neqs_list : (Cterm.term_handle * Cterm.term_handle) list -> Cterm.term_structure -> Cterm.term_structure 105 | val intersect_with_ts : Cterm.term_structure -> bool -> RMSet.multiset -> RMSet.multiset -> (RMSet.multiset * RMSet.multiset * RMSet.multiset) 106 | val normalise : 107 | Cterm.term_structure -> formula -> formula * Cterm.term_structure 108 | val convert_to_inner : Psyntax.pform -> syntactic_form 109 | val convert_to_pform : syntactic_form -> Psyntax.pform 110 | val conjoin : bool -> F.ts_formula -> syntactic_form -> F.ts_formula 111 | val conjoin_af : bool -> AF.ts_formula -> syntactic_form -> syntactic_form -> AF.ts_formula 112 | val combine : bool -> F.ts_formula -> syntactic_form -> AF.ts_formula 113 | type sequent = { 114 | matched : RMSet.multiset; 115 | ts : Cterm.term_structure; 116 | assumption : formula; 117 | obligation : formula; 118 | antiframe : formula; 119 | } 120 | val plain : formula -> bool 121 | val pp_sequent : Format.formatter -> sequent -> unit 122 | val true_sequent : sequent -> bool 123 | val frame_sequent : sequent -> bool 124 | val abductive_sequent : sequent -> bool 125 | type sequent_rule = 126 | Psyntax.psequent * Psyntax.psequent list list * string * 127 | (Psyntax.pform * Psyntax.pform) * Psyntax.where list 128 | type pat_sequent = { 129 | assumption_same : syntactic_form; 130 | assumption_diff : syntactic_form; 131 | obligation_diff : syntactic_form; 132 | antiframe_diff : syntactic_form; 133 | } 134 | val convert_sf : bool -> Cterm.term_structure -> syntactic_form -> (formula * Cterm.term_structure) 135 | val convert_sf_without_eqs : bool -> Cterm.term_structure -> syntactic_form -> (formula * Cterm.term_structure) 136 | val convert_sequent : Psyntax.psequent -> pat_sequent 137 | type inner_sequent_rule = { 138 | conclusion : pat_sequent; 139 | premises : pat_sequent list list; 140 | name : string; 141 | without_left : syntactic_form; 142 | without_right : syntactic_form; 143 | where : Psyntax.where list; 144 | } 145 | val convert_rule : sequent_rule -> inner_sequent_rule 146 | val match_form : bool -> Cterm.term_structure -> formula -> syntactic_form -> 147 | ('a -> 'a -> 'a) -> (Cterm.term_structure * formula -> 'a) -> 'a 148 | val apply_or_left : sequent -> sequent list 149 | val apply_or_right : sequent -> sequent list list 150 | val get_frame : sequent -> F.ts_formula 151 | val get_frames : sequent list -> F.ts_formula list 152 | val get_frames_antiframes : sequent list -> AF.ts_formula list 153 | val convert_with_eqs : bool -> Psyntax.pform -> F.ts_formula 154 | val convert : 155 | bool -> 156 | Cterm.term_structure -> Psyntax.pform -> formula * Cterm.term_structure 157 | val convert_ground : Cterm.term_structure -> syntactic_form -> (formula * Cterm.term_structure) 158 | val make_implies : F.ts_formula -> Psyntax.pform -> sequent 159 | val make_syntactic : F.ts_formula -> syntactic_form 160 | val make_implies_inner : F.ts_formula -> F.ts_formula -> sequent 161 | val ts_form_to_pform : F.ts_formula -> Psyntax.pform 162 | val ts_form_to_pform_no_ts : F.ts_formula -> Psyntax.pform 163 | val pform_to_ts_form : Psyntax.pform -> F.ts_formula 164 | -------------------------------------------------------------------------------- /src/prover/congruence.mli: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/prover/congruence.mli 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | module type PCC = 16 | sig 17 | type t 18 | type constant 19 | type term = TConstant of constant | Func of constant * term list 20 | type curry_term = Constant of constant | App of curry_term * curry_term 21 | type pattern = 22 | Hole of constant 23 | | PConstant of constant 24 | | PFunc of constant * pattern list 25 | type pattern_curry = 26 | CHole of constant 27 | | CPConstant of constant 28 | | CPApp of pattern_curry * pattern_curry 29 | type eq = constant * constant 30 | val create : unit -> t 31 | val add_term : t -> term -> constant * t 32 | val add_app : t -> constant -> constant -> constant * t 33 | val fresh : t -> constant * t 34 | val fresh_unifiable : t -> constant * t 35 | val fresh_exists : t -> constant * t 36 | val fresh_unifiable_exists : t -> constant * t 37 | val make_equal : t -> constant -> constant -> t 38 | val rep_eq : t -> constant -> constant -> bool 39 | val rep_uneq : t -> constant -> constant -> bool 40 | val rep_not_used_in : t -> constant -> constant list -> bool 41 | val make_not_equal : t -> constant -> constant -> t 42 | val make_constructor : t -> constant -> t 43 | val normalise : t -> constant -> constant 44 | val others : t -> constant -> constant list 45 | val eq_term : t -> curry_term -> curry_term -> bool 46 | val neq_term : t -> curry_term -> curry_term -> bool 47 | val patternmatch : t -> curry_term -> constant -> (t * eq list -> 'a) -> 'a 48 | val unifies : t -> curry_term -> constant -> (t * eq list -> 'a) -> 'a 49 | val unifies_any : t -> curry_term -> (t * eq list * constant -> 'a) -> 'a 50 | val determined_exists : 51 | t -> (constant list) -> constant -> constant -> t * (constant * constant) list 52 | val compress_full : t -> t * (constant -> constant) 53 | val print : t -> unit 54 | val pretty_print : 55 | (constant -> bool) -> 56 | (Format.formatter -> constant -> unit) -> Format.formatter -> t -> unit 57 | val pretty_print' : 58 | (constant -> bool) -> 59 | (Format.formatter -> constant -> unit) -> 60 | Printing.sep_wrapper -> Format.formatter -> bool -> t -> bool 61 | val pp_c : 62 | t -> 63 | (Format.formatter -> constant -> unit) -> 64 | Format.formatter -> constant -> unit 65 | val get_eqs : 66 | (constant -> bool) -> (constant -> 'a) -> t -> ('a * 'a) list 67 | val get_neqs : 68 | (constant -> bool) -> (constant -> 'a) -> t -> ('a * 'a) list 69 | 70 | val get_consts : t -> constant list 71 | val get_reps : (constant -> bool) -> (constant -> 'a) -> t -> 'a list 72 | 73 | (* surjective mapping from constants to integers *) 74 | val const_int : constant -> t -> int 75 | 76 | val test : unit -> unit 77 | val delete : t -> constant -> t 78 | end 79 | module PersistentCC : 80 | functor (A : Persistentarray.GrowablePersistentArray) -> PCC 81 | module CC : PCC 82 | -------------------------------------------------------------------------------- /src/prover/cterm.mli: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/prover/cterm.mli 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | open Format 16 | 17 | type term_structure 18 | 19 | type term_handle 20 | 21 | type pattern 22 | 23 | type eq = term_handle * term_handle 24 | 25 | (* 26 | Create a new term structure 27 | It is externally functional, however underneath it uses mutation, 28 | so best to create new ones, rather than having a single starting one. 29 | *) 30 | val new_ts : unit -> term_structure 31 | 32 | (* Convert a Psyntax.args with AnyVars into a pattern to match *) 33 | (*val make_pattern : Psyntax.args -> term_structure -> (pattern * term_structure)))))))))*) 34 | 35 | val unifies : term_structure -> pattern -> term_handle 36 | -> (term_structure * eq list -> 'a) -> 'a 37 | 38 | val determined_exists : term_structure -> (term_handle list) -> term_handle -> term_handle -> term_structure * (term_handle * term_handle) list 39 | 40 | 41 | (* Match pattern against the term_handle in the current term structure, 42 | the new term structure (with the unified variables) will be passed to the continuation 43 | Will raise No_match if no match can be found. 44 | Continutation can cause back tracking of pattern match by raising No_match 45 | *) 46 | (*val match_pattern : term_structure -> pattern -> term_handle -> (term_structure -> 'a) -> 'a*) 47 | 48 | (* 49 | Add Psyntax to the term_structure, and return a term_handle and updated term structure 50 | *) 51 | 52 | val ground_pattern_tuple : Psyntax.args list -> term_structure -> (term_handle * term_structure) 53 | 54 | val ground_pattern : Psyntax.args -> term_structure -> (term_handle * term_structure) 55 | 56 | val add_term : bool -> Psyntax.args -> term_structure -> (term_handle * term_structure) 57 | 58 | val add_pattern : Psyntax.args -> term_structure -> (pattern * term_structure) 59 | 60 | val equal : term_structure -> term_handle -> term_handle -> bool 61 | 62 | val unify_patterns : term_structure -> pattern -> pattern 63 | -> (term_structure * eq list -> 'a) -> 'a 64 | 65 | val not_equal : term_structure -> term_handle -> term_handle -> bool 66 | 67 | val unify_not_equal_pattern : term_structure -> pattern -> pattern 68 | -> (term_structure * eq list -> 'a) -> 'a 69 | 70 | val make_equal : term_structure -> term_handle -> term_handle -> term_structure 71 | 72 | val make_list_equal : term_structure -> term_handle list -> term_structure 73 | 74 | val normalise : term_structure -> term_handle -> term_handle 75 | 76 | (* 77 | Return a compressed term_structure, will remove redundant terms. 78 | *) 79 | val compress : term_structure -> term_structure * (term_handle -> term_handle) 80 | 81 | val make_not_equal : term_structure -> term_handle -> term_handle -> term_structure 82 | 83 | val add_tuple : bool -> Psyntax.args list -> term_structure -> term_handle * term_structure 84 | 85 | val make_tuple_pattern : Psyntax.args list -> term_structure -> pattern * term_structure 86 | 87 | 88 | val make_equal_t : bool -> term_structure -> Psyntax.args -> Psyntax.args -> term_structure 89 | val make_not_equal_t : bool -> term_structure -> Psyntax.args -> Psyntax.args -> term_structure 90 | 91 | 92 | val blank_pattern_vars : term_structure -> term_structure 93 | 94 | val pp_ts' : Printing.sep_wrapper -> formatter -> bool -> term_structure -> bool 95 | 96 | val get_pargs : bool -> term_structure -> term_handle list -> term_handle -> Psyntax.args 97 | val get_pargs_norecs : bool -> term_structure -> term_handle list -> term_handle -> Psyntax.args 98 | 99 | val pp_c : term_structure -> formatter -> term_handle -> unit 100 | val has_pp_c : term_structure -> term_handle -> bool 101 | 102 | val get_args_rep : term_structure -> (term_handle * Psyntax.args) list 103 | val get_args_all : term_structure -> Psyntax.args list 104 | 105 | val get_eqs : term_structure -> (Psyntax.args * Psyntax.args) list 106 | val get_neqs : term_structure -> (Psyntax.args * Psyntax.args) list 107 | 108 | (* TODO: temporary until the bug in has_pp_c gets resolved *) 109 | val get_eqs_all : term_structure -> (Psyntax.args * Psyntax.args) list 110 | val get_neqs_all : term_structure -> (Psyntax.args * Psyntax.args) list 111 | 112 | val get_eqs_norecs : term_structure -> (Psyntax.args * Psyntax.args) list 113 | val get_neqs_norecs : term_structure -> (Psyntax.args * Psyntax.args) list 114 | 115 | val get_term : term_structure -> term_handle-> Psyntax.args 116 | val kill_var : term_structure -> Vars.var -> term_structure 117 | val update_var_to : term_structure -> Vars.var -> Psyntax.args -> term_structure 118 | 119 | val rewrite : term_structure -> Psyntax.rewrite_rule list -> (term_structure * Psyntax.rewrite_guard -> bool) -> term_structure 120 | 121 | val ts_eq : term_structure -> term_structure -> bool 122 | 123 | val var_not_used_in : term_structure -> Vars.var -> term_handle list -> bool 124 | val var_not_used_in_term : term_structure -> Vars.var -> Psyntax.args -> bool 125 | 126 | val add_constructor : string -> term_structure -> term_structure 127 | 128 | -------------------------------------------------------------------------------- /src/prover/prover.mli: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/prover/prover.mli 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | (* NOTE: If you are looking for the prover's interface, it's not here. 15 | Instead, look at sepprover.mli. *) 16 | 17 | val pprint_counter_example : Format.formatter -> unit -> unit 18 | val print_counter_example : unit -> unit 19 | val get_counter_example : unit -> string 20 | val pprint_proof : Format.formatter -> unit 21 | val string_of_proof : unit -> string 22 | 23 | val check_implication_frame_pform : 24 | Psyntax.logic -> 25 | Clogic.F.ts_formula -> Psyntax.pform -> Clogic.F.ts_formula list option 26 | val check_implication_pform : 27 | Psyntax.logic -> Clogic.F.ts_formula -> Psyntax.pform -> bool 28 | val check_implication : 29 | Psyntax.logic -> Clogic.F.ts_formula -> Clogic.F.ts_formula -> bool 30 | val check_frame : 31 | Psyntax.logic -> 32 | Clogic.F.ts_formula -> Clogic.F.ts_formula -> Clogic.F.ts_formula list option 33 | val check_inconsistency : Psyntax.logic -> Clogic.F.ts_formula -> bool 34 | val check_implies_list : Clogic.F.ts_formula list -> Psyntax.pform -> bool 35 | 36 | val check_abduction_pform : 37 | Psyntax.logic -> Clogic.F.ts_formula -> Psyntax.pform -> Clogic.AF.ts_formula list option 38 | 39 | val abs : Psyntax.logic -> Clogic.F.ts_formula -> Clogic.F.ts_formula list 40 | 41 | -------------------------------------------------------------------------------- /src/prover/sepprover.mli: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/prover/sepprover.mli 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | (* I'm the main interface for src/prover. Read me. *) 15 | 16 | open Psyntax 17 | 18 | type inner_form 19 | type inner_form_af 20 | 21 | val lift_inner_form : inner_form -> inner_form_af 22 | val inner_form_af_to_form : inner_form_af -> inner_form 23 | val inner_form_af_to_af : inner_form_af -> inner_form 24 | val inner_truth : inner_form 25 | val inner_falsum : inner_form 26 | val convert : form -> inner_form option 27 | val conjoin : form -> inner_form -> inner_form 28 | val conjoin_inner : inner_form -> inner_form -> inner_form 29 | val conjoin_af : inner_form_af -> form -> inner_form -> inner_form_af 30 | val conjoin_inner_af : inner_form_af -> inner_form -> inner_form -> inner_form_af 31 | val combine : inner_form -> inner_form -> inner_form_af 32 | val kill_var : var -> inner_form -> inner_form 33 | val kill_var_af : var -> inner_form_af -> inner_form_af 34 | val abstract_val : inner_form -> inner_form 35 | val join : inner_form -> inner_form -> inner_form 36 | val meet : inner_form -> inner_form -> inner_form 37 | val widening : inner_form -> inner_form -> inner_form 38 | val join_over_numeric : inner_form -> inner_form -> inner_form * inner_form 39 | val update_var_to : var -> term -> inner_form -> inner_form 40 | val update_var_to_af : var -> term -> inner_form_af -> inner_form_af 41 | val string_inner_form : Format.formatter -> inner_form -> unit 42 | val string_inner_form_af : Format.formatter -> inner_form_af -> unit 43 | 44 | val implies : logic -> inner_form -> form -> bool 45 | val implies_opt : logic -> inner_form option -> form -> bool 46 | val inconsistent : logic -> inner_form -> bool 47 | val inconsistent_opt : logic -> inner_form option -> bool 48 | val frame : logic -> inner_form -> form -> inner_form list option 49 | val frame_opt : logic -> inner_form option -> form -> inner_form list option 50 | val frame_inner : logic -> inner_form -> inner_form -> inner_form list option 51 | val abs : logic -> inner_form -> inner_form list 52 | val abs_opt : logic -> inner_form option -> inner_form list 53 | val pprint_proof : Format.formatter -> unit 54 | val pprint_counter_example : Format.formatter -> unit -> unit 55 | val print_counter_example : unit -> unit 56 | val string_of_proof : unit -> string 57 | val get_counter_example : unit -> string 58 | val implies_list : inner_form list -> form -> bool 59 | val abduction_opt : logic -> (inner_form option) -> form -> inner_form_af list option 60 | -------------------------------------------------------------------------------- /src/prover/smtlex.mll: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/prover/smtlex.mll 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | { 16 | open Format 17 | open Smtparse 18 | } 19 | 20 | let quote = '\'' 21 | 22 | let escapable_char = '\\' | ' ' | quote | '.' | '#' | '\"' | 'n' | 't' | 'r' | 'b' | 'f' 23 | let escape_char = '\\' escapable_char 24 | 25 | let string_char = escape_char | ['\000' - '\033'] | ['\035' - '\091'] | ['\093' - '\127'] 26 | 27 | let string_constant = '"' string_char* '"' 28 | 29 | rule token = parse 30 | | [' ' '\t' '\n' '\r'] 31 | { token lexbuf } (* skip blanks *) 32 | | '(' { LPAREN } 33 | | ')' { RPAREN } 34 | | "unsupported" { UNSUPPORTED } 35 | | "error" { ERROR } 36 | | "sat" { SAT } 37 | | "unsat" { UNSAT } 38 | | "unknown" { UNKNOWN } 39 | | string_constant { STRING_CONSTANT (Lexing.lexeme lexbuf) } 40 | | eof { raise End_of_file } 41 | | _ as c { eprintf "@[offending character %x@." (Char.code c); assert false } 42 | -------------------------------------------------------------------------------- /src/prover/smtparse.mly: -------------------------------------------------------------------------------- 1 | /******************************************************** 2 | This file is part of coreStar 3 | src/prover/smtparse.ml 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************/ 13 | 14 | %{ 15 | open Format 16 | open Smtsyntax 17 | %} 18 | 19 | %token LPAREN 20 | %token RPAREN 21 | %token UNSUPPORTED 22 | %token SUCCESS 23 | %token ERROR 24 | %token SAT 25 | %token UNSAT 26 | %token UNKNOWN 27 | %token STRING_CONSTANT 28 | 29 | %start main /* the entry point */ 30 | %type main 31 | %% 32 | main: 33 | | UNSUPPORTED { Unsupported } 34 | | LPAREN ERROR STRING_CONSTANT RPAREN { Error $3 } 35 | | SAT { Sat } 36 | | UNSAT { Unsat } 37 | | UNKNOWN { Unknown } 38 | ; 39 | -------------------------------------------------------------------------------- /src/proverfront/run_prover.ml: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/proverfront/run.ml 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | open Congruence 15 | open Debug 16 | open Format 17 | open Load_logic 18 | open Psyntax 19 | 20 | let program_file_name = ref "";; 21 | let logic_file_name = ref "";; 22 | 23 | let arg_list = Config.args_default @ 24 | [ ("-f", Arg.Set_string(program_file_name), "program file name"); 25 | ("-l", Arg.Set_string(logic_file_name), "logic file name"); ] 26 | 27 | 28 | let main () = 29 | let usage_msg="Usage: -f -l " in 30 | Arg.parse arg_list (fun s ->()) usage_msg; 31 | 32 | if !program_file_name="" then 33 | printf "File name not specified. Can't continue....\n %s \n" usage_msg 34 | else if !logic_file_name="" then 35 | printf "Logic file name not specified. Can't continue....\n %s \n" usage_msg 36 | else 37 | if !Config.smt_run then Smt.smt_init(); 38 | (* Load abstract interpretation plugins *) 39 | List.iter (fun file_name -> Plugin_manager.load_plugin file_name) !Config.abs_int_plugins; 40 | 41 | let l1,l2,cn = load_logic !logic_file_name in 42 | let logic = {empty_logic with seq_rules = l1; rw_rules=l2; consdecl = cn} in 43 | (* let s = System.string_of_file !program_file_name in*) 44 | let question_list = System.parse_file Parser.question_file Lexer.token !program_file_name "Questions" in 45 | 46 | List.iter ( 47 | fun question -> 48 | match question with 49 | | Psyntax.Implication (heap1,heap2) -> 50 | printf "Check implication\n %a\n ===> \n %a\n" Psyntax.string_form heap1 Psyntax.string_form heap2; 51 | if (Sepprover.implies_opt logic (Sepprover.convert heap1) heap2) 52 | then printf("Holds!\n\n") else printf("Does not hold!\n\n"); 53 | if log log_prove then ( 54 | fprintf logf "@["; 55 | Prover.pprint_proof logf; 56 | fprintf logf "@.") 57 | | Psyntax.Frame (heap1, heap2) -> 58 | printf "Find frame for\n %a\n ===> \n %a\n" Psyntax.string_form heap1 Psyntax.string_form heap2; 59 | let x = Sepprover.frame_opt logic 60 | (Sepprover.convert heap1) heap2 in 61 | 62 | (match x with None -> printf "Can't find frame!" | Some x -> List.iter (fun form -> printf "Frame:\n %a\n" Sepprover.string_inner_form form) x); 63 | printf "\n"; 64 | if log log_prove then ( 65 | fprintf logf "@["; 66 | Prover.pprint_proof logf; 67 | fprintf logf "@.") 68 | | Psyntax.Abs (heap1) -> 69 | printf "Abstract@\n @[%a@]@\nresults in@\n " Psyntax.string_form heap1; 70 | let x = Sepprover.abs_opt logic (Sepprover.convert heap1) in 71 | List.iter (fun form -> printf "%a\n" Sepprover.string_inner_form form) x; 72 | printf "\n"; 73 | if log log_prove then ( 74 | fprintf logf "@["; 75 | Prover.pprint_proof logf; 76 | fprintf logf "@.") 77 | | Psyntax.Inconsistency (heap1) -> 78 | if Sepprover.inconsistent_opt logic (Sepprover.convert heap1) 79 | then printf("Inconsistent!\n\n") else printf("Consistent!\n\n"); 80 | if log log_prove then ( 81 | fprintf logf "@["; 82 | Prover.pprint_proof logf; 83 | fprintf logf "@.") 84 | | Psyntax.Equal (heap,arg1,arg2) -> () 85 | 86 | | Psyntax.Abduction (heap1, heap2) -> 87 | Format.printf "Find antiframe for\n %a\n ===> \n %a \n" 88 | Psyntax.string_form heap1 Psyntax.string_form heap2; 89 | let x = (Sepprover.abduction_opt logic (Sepprover.convert heap1) heap2) in 90 | (match x with 91 | | None -> Format.printf "Can't find antiframe!\n" 92 | | Some ls -> 93 | List.iter (fun inner_form_antiform -> 94 | Format.printf "%a\n\n" Sepprover.string_inner_form_af inner_form_antiform) ls; 95 | ); 96 | 97 | (* if Prover.check_equal logic heap arg1 arg2 98 | then Printf.printf("Equal!\n\n") else Printf.printf("Not equal!\n\n")*) 99 | (* | _ -> Printf.printf "Currently unsupported" *) 100 | ) 101 | question_list 102 | 103 | let _ = main () 104 | -------------------------------------------------------------------------------- /src/proverfront/run_prover.mli: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/proverfront/run.mli 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | val program_file_name : string ref 16 | val logic_file_name : string ref 17 | val arg_list : (string * Arg.spec * string) list 18 | val main : unit -> unit 19 | -------------------------------------------------------------------------------- /src/proverfront/test_logic.ml: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/proverfront/test.ml 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | (* TODO(rgrig): Factor the common parts of test.ml and run.ml. *) 16 | 17 | open Debug 18 | open Format 19 | open Load_logic 20 | open Psyntax 21 | 22 | let program_file_name = ref "" 23 | let logic_file_name = ref "" 24 | 25 | let arg_list = Config.args_default @ 26 | [ ("-f", Arg.Set_string(program_file_name), "program file name" ); 27 | ("-l", Arg.Set_string(logic_file_name), "logic file name" ); ] 28 | 29 | 30 | let main () = 31 | let usage_msg="Usage: -f -l " in 32 | Arg.parse arg_list (fun s ->()) usage_msg; 33 | 34 | if !program_file_name="" then 35 | printf "Test file name not specified. Can't continue....@\n %s @\n" usage_msg 36 | else if !logic_file_name="" then 37 | printf "Logic file name not specified. Can't continue....@\n %s @\n" usage_msg 38 | else 39 | if !Config.smt_run then Smt.smt_init(); 40 | if log log_phase then fprintf logf "@[Done initializing SMT.@."; 41 | (* Load abstract interpretation plugins *) 42 | List.iter (fun file_name -> Plugin_manager.load_plugin file_name) !Config.abs_int_plugins; 43 | 44 | let l1,l2,cn = load_logic_extra_rules Cli_utils.logic_dirs !logic_file_name [] in 45 | let logic = {empty_logic with seq_rules = l1; rw_rules=l2; consdecl = cn;} in 46 | let s = System.string_of_file !program_file_name in 47 | if log log_phase then 48 | fprintf logf "@[<4>Parsing tests in@ %s.@." !program_file_name; 49 | let test_list = Parser.test_file Lexer.token (Lexing.from_string s) in 50 | if log log_phase then fprintf logf "@[<4>Parsed@ %s.@." !program_file_name; 51 | printf "@["; 52 | List.iter ( 53 | fun test -> 54 | match test with 55 | | Psyntax.TImplication (heap1,heap2,result) -> 56 | (*Format.printf "Check implication\n %s\n ===> \n %s\n" (Plogic.string_form heap1) (Plogic.string_form heap2);*) 57 | (match (Sepprover.implies_opt logic (Sepprover.convert heap1) heap2), result with 58 | true,true | false,false -> printf "." 59 | | true,false -> printf "@[Test failed!@ Unsound as proved @\n@ %a@\n@ ===> @\n%a@\n@] " 60 | Psyntax.string_form heap1 61 | Psyntax.string_form heap2 62 | | false,true -> printf "@[Test@ failed!@ Could@ not@ prove@ @\n@ %a@\n ===> @\n%a@\n@] " 63 | Psyntax.string_form heap1 64 | Psyntax.string_form heap2 65 | ) 66 | | Psyntax.TFrame (heap1, heap2, result) -> 67 | (* Format.printf "Find frame for\n %s\n ===> \n %s\n" (Psyntax.string_form heap1) (Psyntax.string_form heap2);*) 68 | let x = Sepprover.frame_opt logic 69 | (Sepprover.convert heap1) heap2 in 70 | begin 71 | match x with 72 | None -> printf "@[Incorrect: cannot find frame. @\n%a@\n ===> @\n%a@\n@]" Psyntax.string_form heap1 Psyntax.string_form heap2 73 | | Some x -> 74 | if Sepprover.implies_list x result then printf "." 75 | else ( 76 | printf "@[Incorrect frame for:@\n%a@\n ===> @\n%a@\n@]" 77 | Psyntax.string_form heap1 78 | Psyntax.string_form heap2; 79 | List.iter 80 | (fun form -> 81 | printf "@[Resulted in frames:@\n %a@\n@]" Sepprover.string_inner_form form) x; 82 | printf "@[Was expecting:@\n%a@\n@]" Psyntax.string_form result 83 | ) 84 | end 85 | | Psyntax.TAbs (heap1,result) -> 86 | let x = Sepprover.abs_opt logic (Sepprover.convert heap1) in 87 | if Sepprover.implies_list x result then printf "." 88 | else ( 89 | printf "@[Incorrect Abstraction for:@\n%a@\n@] " 90 | Psyntax.string_form heap1; 91 | List.iter 92 | (fun form -> 93 | printf "@[Resulted in forms:@\n %a@\n@]" Sepprover.string_inner_form form) x; 94 | printf "@[Was expecting:@\n%a@\n@]" Psyntax.string_form result 95 | ) 96 | | Psyntax.TInconsistency (heap1,result) -> 97 | (match Sepprover.inconsistent_opt logic (Sepprover.convert heap1), result with 98 | true, true 99 | | false,false -> printf "." 100 | | true,false -> printf "@[Test failed! Prover found@ %a@ inconsistent, test said consistent.@\n@]" 101 | Psyntax.string_form heap1 102 | | false,true -> printf "@[Test failed! Prover could not prove@ %a@ inconsistent.@\n@]" 103 | Psyntax.string_form heap1 104 | ); 105 | | Psyntax.TEqual (heap,arg1,arg2,result) -> () 106 | (* if Prover.check_equal logic heap arg1 arg2 107 | then Format.printf("Equal!\n\n") else Format.printf("Not equal!\n\n")*) 108 | ) 109 | test_list; 110 | printf "@]"; 111 | if log log_phase then fprintf logf "@[Done.@." 112 | 113 | 114 | let _ = 115 | System.set_signal_handlers (); 116 | main () 117 | -------------------------------------------------------------------------------- /src/proverfront/test_logic.mli: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/proverfront/test.mli 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | val program_file_name : string ref 16 | val logic_file_name : string ref 17 | val arg_list : (string * Arg.spec * string) list 18 | val main : unit -> unit 19 | -------------------------------------------------------------------------------- /src/symbexe/specification.ml: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/symbexe/specification.ml 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | 16 | (** Support functions for symbolic execution and misc conversion facilities. *) 17 | 18 | open Corestar_std 19 | open Psyntax 20 | open Sepprover 21 | open Spec 22 | 23 | type ts_excep_post = inner_form ClassMap.t 24 | 25 | let empty_inner_form = 26 | match convert mkEmpty with 27 | None -> assert false; 28 | | Some emp -> emp 29 | 30 | let empty_inner_form_af = 31 | lift_inner_form empty_inner_form 32 | 33 | let conjunction_excep excep_post f1 = 34 | ClassMap.map (fun post -> Psyntax.pconjunction post f1) excep_post 35 | 36 | let conjunction_excep_convert excep_post f1 = 37 | ClassMap.map (fun post -> Sepprover.conjoin post f1) excep_post 38 | 39 | let combine_maps empty fold add find combine_values m1 m2 = 40 | let combine_add k v m = 41 | try add k (combine_values v (find k m)) m 42 | with Not_found -> add k v m in 43 | fold combine_add m1 m2 44 | 45 | let disjunction_excep = 46 | combine_maps ClassMap.empty ClassMap.fold ClassMap.add ClassMap.find (curry mkOr) 47 | 48 | let spec_conjunction spec1 spec2 = 49 | let var = Arg_var(Vars.freshe()) in 50 | let zero = Arg_string("**first**") in 51 | let one = Arg_string("**second**") in 52 | let eq = mkEQ(var,zero) in 53 | let neq = mkEQ(var,one) in 54 | match spec1,spec2 with 55 | {pre=pre1; post=post1; excep=excep1}, 56 | {pre=pre2; post=post2; excep=excep2} -> 57 | {pre= Psyntax.mkOr ((Psyntax.pconjunction pre1 eq),(Psyntax.pconjunction pre2 neq)); 58 | post= Psyntax.mkOr ((Psyntax.pconjunction post1 eq),(Psyntax.pconjunction post2 neq)); 59 | excep = disjunction_excep (conjunction_excep excep1 eq) (conjunction_excep excep2 neq)} 60 | 61 | 62 | 63 | (*************************************** 64 | Refinement type stuff 65 | ***************************************) 66 | 67 | 68 | (* 69 | { e1 : f1} , ... , {en : fn} (excep1) 70 | ===> 71 | { e1' : f1', ... , {em' : fm'} (excep2) 72 | iff 73 | forall ei :fi. exists ej' : fj'. ei=ej' /\ fi==>fj' 74 | *) 75 | exception Check_fails 76 | 77 | let implication_excep logic excep1 excep2 = 78 | try 79 | ClassMap.iter ( 80 | fun exname form -> 81 | if Sepprover.implies logic form (ClassMap.find exname excep2) 82 | then () 83 | else raise Check_fails 84 | ) excep1; true 85 | with check_fails -> false 86 | 87 | let sub_spec sub spec = 88 | match spec with 89 | {pre=pre; post=post; excep=excep} -> 90 | {pre=subst_pform sub pre; 91 | post=subst_pform sub post; 92 | excep=ClassMap.map (subst_pform sub) excep} 93 | 94 | let ev_spec spec = 95 | match spec with 96 | {pre=spec_pre; post=spec_post; excep =spec_excep} -> 97 | let ev = ev_form spec_pre in 98 | let ev = ev_form_acc spec_post ev in 99 | let ev = ClassMap.fold (fun key ex vs -> ev_form_acc ex vs) spec_excep ev in 100 | ev 101 | 102 | let ev_spec_pre spec = 103 | match spec with 104 | {pre=spec_pre; post=spec_post; excep =spec_excep} -> 105 | let ev = ev_form spec_pre in 106 | ev 107 | 108 | 109 | (* if pre_antiframe = None then perform jsr, otherwise perform jsr with abduction *) 110 | let jsr logic (pre : inner_form_af) (spec : spec) (abduct : bool) : inner_form_af list option = 111 | let ev = ev_spec spec in 112 | let subst = subst_kill_vars_to_fresh_exist ev in 113 | let spec = sub_spec subst spec in 114 | let pre_form = inner_form_af_to_form pre in 115 | match spec with 116 | {pre=spec_pre; post=spec_post; excep=spec_excep} -> 117 | let frame_antiframe_list = 118 | if abduct then 119 | Sepprover.abduction_opt logic (Some pre_form) spec_pre 120 | else 121 | (let frame_list = Sepprover.frame logic pre_form spec_pre in 122 | match frame_list with 123 | None -> None 124 | | Some frame_list -> 125 | Some (List.map (fun inner_form -> lift_inner_form inner_form) frame_list)) 126 | in 127 | match frame_antiframe_list with 128 | None -> None 129 | | Some frame_antiframe_list -> 130 | let res = Misc.map_option 131 | (fun frame_antiframe -> 132 | try Some (Sepprover.conjoin_af frame_antiframe spec_post (inner_form_af_to_af pre)) 133 | with Contradiction -> None) 134 | frame_antiframe_list in 135 | let res = List.map (fun frame_antiframe -> 136 | vs_fold (fun e ts_form -> kill_var_af e ts_form) ev frame_antiframe) res in 137 | Some res 138 | 139 | 140 | (* TODO: need exceptions in jsr? *) 141 | let jsr_excep logic (pre : inner_form) (spec : spec) : (inner_form list * ts_excep_post list) option = 142 | let ev = ev_spec spec in 143 | let subst = subst_kill_vars_to_fresh_exist ev in 144 | let spec = sub_spec subst spec in 145 | match spec with 146 | {pre=spec_pre; post=spec_post; excep=spec_excep} -> 147 | let frame_list = Sepprover.frame logic pre spec_pre in 148 | match frame_list with 149 | None -> None 150 | | Some frame_list -> 151 | let res = Misc.map_option 152 | (fun post -> (*Prover.tidy_one*) 153 | try Some (Sepprover.conjoin spec_post post) with Contradiction -> None) 154 | frame_list in 155 | let excep_res = List.map (conjunction_excep_convert spec_excep) frame_list in 156 | let res = List.map (fun ts -> vs_fold (fun e ts -> kill_var e ts) ev ts) res in 157 | Some (res,excep_res) 158 | 159 | 160 | let logical_vars_to_prog spec2 = 161 | let ev = ev_spec_pre spec2 in 162 | let sub = subst_kill_vars_to_fresh_prog ev in 163 | sub_spec sub spec2 164 | 165 | (* spec2={P}{Q} =[extra]=> spec1 166 | 167 | {P*extra}{Q} ===> spec1 168 | *) 169 | let refinement_extra (logic : logic) (spec1 : spec) (spec2 : spec) (extra : pform): bool = 170 | let spec2 = logical_vars_to_prog spec2 in 171 | match spec2 with 172 | {pre=pre; post=post; excep=excep} -> 173 | match (Sepprover.convert (extra&&&pre)) with 174 | None -> true 175 | | Some form -> 176 | match jsr_excep logic form spec1 with 177 | None -> false 178 | | Some (newposts, newexcep_posts) -> 179 | let res = List.for_all (fun newpost -> Sepprover.implies logic newpost post) newposts in 180 | let res2 = List.for_all (fun newexcep_post -> implication_excep logic newexcep_post excep) newexcep_posts in 181 | (res&&res2) 182 | 183 | 184 | (* spec2 ==> spec1 185 | That is 186 | spec2 187 | ----- 188 | : 189 | ----- 190 | spec1 191 | *) 192 | let refinement (logic : logic) (spec1 : spec) (spec2 : spec) : bool = 193 | refinement_extra logic spec1 spec2 [] 194 | 195 | 196 | 197 | -------------------------------------------------------------------------------- /src/symbexe/specification.mli: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/symbexe/specification.mli 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | type ts_excep_post = Sepprover.inner_form Spec.ClassMap.t 16 | val empty_inner_form : Sepprover.inner_form 17 | val empty_inner_form_af : Sepprover.inner_form_af 18 | val spec_conjunction : Spec.spec -> Spec.spec -> Spec.spec 19 | val sub_spec : Psyntax.varmap -> Spec.spec -> Spec.spec 20 | val jsr : 21 | Psyntax.logic -> 22 | Sepprover.inner_form_af -> 23 | Spec.spec -> 24 | bool -> (Sepprover.inner_form_af list) option 25 | val logical_vars_to_prog : Spec.spec -> Spec.spec 26 | val refinement_extra : 27 | Psyntax.logic -> Spec.spec -> Spec.spec -> Psyntax.pform -> bool 28 | val refinement : Psyntax.logic -> Spec.spec -> Spec.spec -> bool 29 | -------------------------------------------------------------------------------- /src/symbexe/symexec.mli: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/symbexe/symexec.mli 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | type ntype = Plain | Good | Error | Abs | UnExplored 16 | type etype = ExecE | AbsE | ContE | ExitE 17 | type id = int 18 | val file : string ref 19 | val set_group : bool -> unit 20 | type node = { 21 | mutable content : string; 22 | id : id; 23 | mutable ntype : ntype; 24 | mutable url : string; 25 | mutable outedges : edge list; 26 | mutable inedges : edge list; 27 | cfg : Cfg_core.cfg_node option; 28 | } 29 | and edge = { 30 | label : string; 31 | clabel : string; 32 | etype : etype; 33 | src : node; 34 | dest : node; 35 | file : string option; 36 | } 37 | 38 | val mk_node : 39 | string -> 40 | id -> 41 | ntype -> 42 | string -> 43 | edge list -> edge list -> Cfg_core.cfg_node option -> node 44 | module Idmap : 45 | sig 46 | type key = int option 47 | type +'a t 48 | val empty : 'a t 49 | val is_empty : 'a t -> bool 50 | val add : key -> 'a -> 'a t -> 'a t 51 | val find : key -> 'a t -> 'a 52 | val remove : key -> 'a t -> 'a t 53 | val mem : key -> 'a t -> bool 54 | val iter : (key -> 'a -> unit) -> 'a t -> unit 55 | val map : ('a -> 'b) -> 'a t -> 'b t 56 | val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t 57 | val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b 58 | val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int 59 | val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool 60 | end 61 | val pp_dotty_transition_system : unit -> unit 62 | val parameter : int -> string 63 | exception Contained 64 | val verify : 65 | string -> 66 | Cfg_core.cfg_node list -> 67 | Spec.spec -> Psyntax.logic -> Psyntax.logic -> bool 68 | val verify_ensures : 69 | string -> 70 | Cfg_core.cfg_node list -> 71 | Psyntax.pform -> 72 | (Psyntax.pform -> Psyntax.form) -> 73 | Sepprover.inner_form list list -> Psyntax.logic -> Psyntax.logic -> unit 74 | val bi_abduct : 75 | string -> 76 | Cfg_core.cfg_node list -> 77 | Spec.spec -> 78 | Psyntax.logic -> 79 | Psyntax.logic -> 80 | Psyntax.logic -> 81 | (Sepprover.inner_form * Sepprover.inner_form) list 82 | 83 | (* TODO: This is only used by translatejimple in jstar, so perhaps it should not be here. *) 84 | val get_frame : 85 | Cfg_core.cfg_node list -> 86 | Psyntax.pform -> 87 | Psyntax.logic -> Psyntax.logic -> Sepprover.inner_form list 88 | 89 | -------------------------------------------------------------------------------- /src/symbexe_syntax/cfg_core.ml: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/symbexe_syntax/cfg_core.ml 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | (** Data structures for representing flowgraphs of the core languages. 16 | Also, utilities to build such flowgraphs and to pretty-print them. *) 17 | 18 | open Core 19 | open Pprinter_core 20 | 21 | let cfg_debug () = false 22 | 23 | (* {{{ data structure to represent (core) flowgraphs *) 24 | 25 | (* A node in the flowgraph. The fields [succs] and [preds] are filled 26 | by [Cfg_core.stmts_to_cfg]. *) 27 | type cfg_node = { 28 | skind: core_statement; 29 | sid: int; 30 | mutable succs: cfg_node list; 31 | mutable preds: cfg_node list } 32 | 33 | (* data structure to represent (core) flowgraphs }}} *) 34 | (* {{{ utils for building flowgraphs *) 35 | let mk_node : core_statement -> cfg_node = 36 | let x = ref 0 in 37 | fun stmt -> 38 | incr x; 39 | { skind = stmt; sid = !x; succs = []; preds = [] } 40 | 41 | (** Fills the [succs] and [preds] fields of [stmts] by adding edges 42 | corresponding to program order and to goto-s. *) 43 | let stmts_to_cfg (stmts : cfg_node list) : unit = 44 | let l2s = Hashtbl.create 11 in (* maps labels to statements *) 45 | let al = function 46 | | {skind = Label_stmt_core l} as s -> Hashtbl.add l2s l s 47 | | _ -> () in 48 | let rec process = 49 | let connect m n = (* adds an edge from [m] to [n] *) 50 | m.succs <- n :: m.succs; n.preds <- m :: n.preds in 51 | let find l = (* looks up [l] in [l2s] and reports an error if not found *) 52 | try Hashtbl.find l2s l 53 | with Not_found -> Format.eprintf "Undefined label %s.@." l; assert false in 54 | function 55 | | {skind = Goto_stmt_core ls} as m :: ss -> 56 | List.iter (fun ln -> connect m (find ln)) ls; process ss 57 | | m :: ((n :: _) as ss)-> connect m n; process ss 58 | | _ -> () in 59 | List.iter (fun s -> s.succs <- []; s.preds <- []) stmts; 60 | List.iter al stmts; 61 | process stmts 62 | (* utils for building flowgraphs }}} *) 63 | (* {{{ pretty printing flowgraphs (to .dot) *) 64 | 65 | (* stmtsname is a list of programs and names, such that each program's 66 | cfg is printed in a subgraph with its name.*) 67 | let print_icfg_dotty 68 | (stmtsname : (cfg_node list * string) list) 69 | (filename : string) : unit = 70 | (* Print an edge between two stmts *) 71 | let d_cfgedge chan src dest = 72 | Printf.fprintf chan "\t\t%i -> %i\n" src.sid dest.sid in 73 | (* Print a node and edges to its successors *) 74 | let d_cfgnode chan (s : cfg_node) = 75 | Printf.fprintf chan 76 | "\t\t%i [label=\"%i: %s\"]\n" 77 | s.sid 78 | s.sid 79 | (Dot.escape_for_label (Debug.toString pp_stmt_core s.skind)); 80 | List.iter (d_cfgedge chan s) s.succs in 81 | 82 | if cfg_debug () then ignore (Printf.printf "\n\nPrinting iCFG as dot file..."); 83 | let chan = open_out (filename ^ ".icfg.dot") in 84 | Printf.fprintf chan "digraph iCFG {\n\tnode [shape=box, labeljust=l]\n"; 85 | List.iter 86 | (fun (stmts,name) -> 87 | stmts_to_cfg stmts; 88 | Printf.fprintf chan "\tsubgraph \"cluster_%s\" {\n\t\tlabel=\"%s\"\n" name (Dot.escape_for_label name); 89 | List.iter (d_cfgnode chan) stmts; 90 | Printf.fprintf chan "\t}\n"; 91 | ) 92 | stmtsname; 93 | Printf.fprintf chan "}\n"; 94 | close_out chan; 95 | if cfg_debug() then ignore (Printf.printf "\n\n Printing dot file done!") 96 | (* pretty printing flowgraphs (to .dot) }}} *) 97 | 98 | (* Print a sequence of core statements to a file *) 99 | let print_core 100 | (file: string) 101 | (mname: string) 102 | (stmts : cfg_node list) : unit = 103 | 104 | if core_debug () then ignore (Printf.printf "\n\nPrinting core file for method %s..." mname); 105 | 106 | (* FIXME: Don't understand why I can't use Format.formatter_of_out_channel *) 107 | Format.pp_set_margin Format.str_formatter 80; 108 | 109 | let cstr = Format.flush_str_formatter 110 | (List.iter (fun x -> pp_stmt_core Format.str_formatter x.skind; 111 | Format.pp_print_newline Format.str_formatter () ) stmts) in 112 | 113 | let chan = open_out (file ^ mname ^ ".core") in 114 | Printf.fprintf chan "%s" cstr; 115 | close_out chan; 116 | 117 | 118 | -------------------------------------------------------------------------------- /src/symbexe_syntax/cfg_core.mli: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/symbexe_syntax/cfg_core.mli 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | type cfg_node = { 16 | skind : Core.core_statement; 17 | sid : int; 18 | mutable succs : cfg_node list; 19 | mutable preds : cfg_node list; 20 | } 21 | val mk_node : Core.core_statement -> cfg_node 22 | val stmts_to_cfg : cfg_node list -> unit 23 | val print_icfg_dotty : (cfg_node list * string) list -> string -> unit 24 | val print_core : string -> string -> cfg_node list -> unit 25 | -------------------------------------------------------------------------------- /src/symbexe_syntax/core.ml: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/symbexe_syntax/core.ml 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | 16 | (* Manage methdec infos for a file *) 17 | 18 | open Spec 19 | 20 | type core_statement = 21 | | Nop_stmt_core 22 | | Label_stmt_core of string 23 | | Assignment_core of Vars.var list * spec * Psyntax.args list 24 | | Goto_stmt_core of string list 25 | | Throw_stmt_core of Psyntax.args 26 | | End 27 | 28 | type symb_question = 29 | | Specification of string * spec * core_statement list 30 | 31 | type symb_test = 32 | | SpecTest of string * spec * core_statement list * bool 33 | 34 | -------------------------------------------------------------------------------- /src/symbexe_syntax/core.mli: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/symbexe_syntax/core.mli 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | type core_statement = 16 | Nop_stmt_core 17 | | Label_stmt_core of string 18 | | Assignment_core of Vars.var list * Spec.spec * Psyntax.args list 19 | | Goto_stmt_core of string list 20 | | Throw_stmt_core of Psyntax.args 21 | | End 22 | type symb_question = 23 | Specification of string * Spec.spec * core_statement list 24 | type symb_test = 25 | | SpecTest of string * Spec.spec * core_statement list * bool 26 | -------------------------------------------------------------------------------- /src/symbexe_syntax/pprinter_core.ml: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/symbexe_syntax/pprinter_core.ml 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | open Core 15 | open Psyntax 16 | open Spec 17 | 18 | (** Pretty printer for core programs. Note that this handles a lot more 19 | than the data structure in core.ml. *) 20 | 21 | let core_debug () = false 22 | 23 | let rec args2str arg = 24 | match arg with 25 | | Arg_var v -> Vars.string_var v 26 | | Arg_string s -> s 27 | | Arg_op ("builtin_plus",[a1;a2]) -> "("^(args2str a1)^"+"^(args2str a2)^")" 28 | | Arg_op ("builtin_minus",[a1;a2]) -> "("^(args2str a1)^"-"^(args2str a2)^")" 29 | | Arg_op ("builtin_mult",[a1;a2]) -> "("^(args2str a1)^"*"^(args2str a2)^")" 30 | | Arg_op (name,args) -> name^"("^( args_list2str args)^")" 31 | | Arg_cons (name,args) -> name^"("^( args_list2str args)^")" 32 | | Arg_record fldlist -> "[{"^(args_fldlist2str fldlist)^"}]" 33 | and args_list2str argsl = 34 | match argsl with 35 | | [] -> "" 36 | | [a] -> args2str a 37 | | a::al -> (args2str a)^","^(args_list2str al) 38 | and args_fldlist2str fdl = 39 | match fdl with 40 | | [] -> "" 41 | | [(f,a)] -> f^"="^( args2str a) 42 | | (f,a)::fdl -> f^"="^(args2str a)^"; "^(args_fldlist2str fdl) 43 | 44 | 45 | 46 | let rec form_at2str pa = 47 | match pa with 48 | P_NEQ(a1,a2) ->(args2str a1)^ "!= "^ (args2str a2) 49 | | P_EQ(a1,a2) -> (args2str a1)^ " = "^ (args2str a2) 50 | | P_PPred(op,al) -> "!"^op^"("^ (args_list2str al)^")" 51 | | P_SPred (s,al) -> s^"("^ (args_list2str al)^")" 52 | | P_Or(f1,f2) -> "[[("^(list_form2str f1)^" || "^" [("^( list_form2str f2)^")]]" 53 | | P_Wand(f1,f2) -> "[[("^(list_form2str f1)^" -* "^" [("^( list_form2str f2)^")]]" 54 | | P_Septract(f1,f2) -> "[[("^(list_form2str f1)^" -o "^" [("^( list_form2str f2)^")]]" 55 | | P_False -> "False" 56 | and list_form2str list = 57 | match list with 58 | [] -> "" 59 | | [x] -> (form_at2str x) 60 | | x::xs -> (form_at2str x)^" * "^list_form2str xs 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | let variable_list2str lv = 69 | Debug.list_format "," Vars.pp_var lv 70 | 71 | let pp_stmt_core (ppf: Format.formatter) : core_statement -> unit = 72 | function 73 | | Nop_stmt_core -> 74 | Format.fprintf ppf "nop;" 75 | | Label_stmt_core l -> 76 | Format.fprintf ppf "label %s;" l 77 | | Assignment_core (v,spec,e)-> 78 | Format.fprintf ppf "assign %a@ @[%a@]@[(%a)@];" 79 | (fun ppf v -> match v with [] -> () | _ -> Format.fprintf ppf "%a@ :=@ " variable_list2str v) v 80 | spec2str spec 81 | string_args_list e 82 | | Goto_stmt_core l -> 83 | Format.fprintf ppf 84 | "goto %a;" 85 | (Debug.list_format "," (fun ppf -> Format.fprintf ppf "%s")) l 86 | | Throw_stmt_core a -> 87 | Format.fprintf ppf 88 | "throw %a;" 89 | string_args a 90 | | End -> Format.fprintf ppf "end;" 91 | 92 | 93 | 94 | -------------------------------------------------------------------------------- /src/symbexe_syntax/pprinter_core.mli: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/symbexe_syntax/pprinter_core.mli 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | val core_debug : unit -> bool 16 | val pp_stmt_core : Format.formatter -> Core.core_statement -> unit 17 | -------------------------------------------------------------------------------- /src/symbexe_syntax/spec.ml: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/symbexe_syntax/spec.ml 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | (** Data structures used to represent specifications. 16 | Also, their pretty-printing. *) 17 | 18 | module ClassMap = Map.Make (struct type t = string let compare = compare end) 19 | 20 | type excep_post = Psyntax.pform ClassMap.t 21 | 22 | type spec = 23 | { pre : Psyntax.pform; 24 | post : Psyntax.pform; 25 | excep : excep_post } 26 | 27 | 28 | let mk_spec pre post excep = 29 | { pre = pre; 30 | post = post; 31 | excep = excep } 32 | 33 | let spec2str ppf (spec: spec) = 34 | let po s = Format.fprintf ppf "@\n@[<4>{%a}@]" Psyntax.string_form s in 35 | po spec.pre; po spec.post; 36 | ClassMap.iter (fun _ s -> po s) spec.excep 37 | 38 | let pprinter_core_spec2str = ((Debug.toString spec2str) : (spec -> string)) 39 | 40 | let name_ret_v1 = "$ret_v1" 41 | let ret_v1 = Vars.concretep_str name_ret_v1 42 | 43 | let parameter n = "@parameter"^(string_of_int n)^":" 44 | let parameter_var n = (Vars.concretep_str (parameter n)) 45 | -------------------------------------------------------------------------------- /src/symbexe_syntax/spec.mli: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/symbexe_syntax/spec.mli 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | module ClassMap : 16 | sig 17 | type key = string 18 | type +'a t 19 | val empty : 'a t 20 | val is_empty : 'a t -> bool 21 | val add : key -> 'a -> 'a t -> 'a t 22 | val find : key -> 'a t -> 'a 23 | val remove : key -> 'a t -> 'a t 24 | val mem : key -> 'a t -> bool 25 | val iter : (key -> 'a -> unit) -> 'a t -> unit 26 | val map : ('a -> 'b) -> 'a t -> 'b t 27 | val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t 28 | val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b 29 | val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int 30 | val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool 31 | end 32 | type excep_post = Psyntax.pform ClassMap.t 33 | type spec = { 34 | pre : Psyntax.pform; 35 | post : Psyntax.pform; 36 | excep : excep_post; 37 | } 38 | val mk_spec : 39 | Psyntax.pform -> Psyntax.pform -> excep_post -> spec 40 | val spec2str : Format.formatter -> spec -> unit 41 | val pprinter_core_spec2str : spec -> string 42 | val name_ret_v1 : string 43 | val ret_v1 : Vars.var 44 | val parameter : int -> string 45 | val parameter_var : int -> Vars.var 46 | -------------------------------------------------------------------------------- /src/symbfront/corestar.ml: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/symbfront/symbfront.ml 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | (* This file is a front end to the symbolic execution *) 16 | 17 | open List 18 | open Printf 19 | open Core 20 | open Pprinter_core 21 | open Load_logic 22 | open Psyntax 23 | 24 | let question_file_name = ref "";; 25 | let logic_file_name = ref "";; 26 | let abduct_logic_file_name = ref "";; 27 | let absrules_file_name = ref "";; 28 | 29 | let set_question_file_name fn = 30 | question_file_name := fn; 31 | Symexec.file := Filename.basename fn 32 | 33 | let arg_list = Config.args_default @ 34 | [ ("-f", Arg.String set_question_file_name, "question file name" ); 35 | ("-l", Arg.Set_string logic_file_name, "logic file name" ); 36 | ("-al", Arg.Set_string abduct_logic_file_name, "abduction logic file name" ); 37 | ("-a", Arg.Set_string absrules_file_name, "abstraction rules file name" ); 38 | ] 39 | 40 | 41 | let main () : unit = 42 | let usage_msg = "Usage: -l [-al ] -a -f " in 43 | Arg.parse arg_list (fun s ->()) usage_msg; 44 | 45 | if !question_file_name="" then 46 | printf "Question file not specified. Can't continue....\n %s \n" usage_msg 47 | else if !logic_file_name="" then 48 | printf "Logic file name not specified. Can't continue....\n %s \n" usage_msg 49 | else if !absrules_file_name="" then 50 | printf "Abstraction rules file name not specified. Can't continue....\n %s \n" usage_msg 51 | else 52 | if !Config.smt_run then Smt.smt_init(); 53 | (* Load abstract interpretation plugins *) 54 | List.iter (fun file_name -> Plugin_manager.load_plugin file_name) !Config.abs_int_plugins; 55 | 56 | let l1,l2,cn = load_logic !logic_file_name in 57 | let lo = {empty_logic with seq_rules = l1; rw_rules = l2; consdecl = cn} in 58 | let l1,l2,cn = Load_logic.load_abstractions !absrules_file_name in 59 | let abs_rules = {empty_logic with seq_rules = l1; rw_rules = l2; consdecl = cn} in 60 | 61 | if !abduct_logic_file_name="" then 62 | let question_list = System.parse_file Parser.symb_question_file Lexer.token !question_file_name "Question" in 63 | List.iter ( 64 | fun question -> 65 | match question with 66 | | Specification(mname,spec,core) -> 67 | Format.printf "Method: %s\nSpec: %a" mname Spec.spec2str spec; 68 | let stmts_core = map Cfg_core.mk_node core in 69 | if Symexec.verify mname stmts_core spec lo abs_rules then 70 | Format.printf "\nGood specification!\n\n" else Format.printf "\nBad specification!\n\n" 71 | ) question_list 72 | else 73 | let l1,l2,cn = load_logic !abduct_logic_file_name in 74 | let abduct_lo = {empty_logic with seq_rules=l1; rw_rules=l2; consdecl=cn} in 75 | let question_list = System.parse_file Parser.symb_question_file Lexer.token !question_file_name "Question" in 76 | List.iter ( 77 | fun question -> 78 | match question with 79 | | Specification(mname,spec,core) -> 80 | Format.printf "\nMethod: %s\nSpec: %a" mname Spec.spec2str spec; 81 | let stmts_core = map Cfg_core.mk_node core in 82 | let specs = Symexec.bi_abduct mname stmts_core spec lo abduct_lo abs_rules in 83 | Format.printf "\nDiscovered specs:\n"; 84 | List.iter (fun (spec_pre, spec_post) -> 85 | Format.printf "@\npre:@\n %a@." Sepprover.string_inner_form spec_pre; 86 | Format.printf "@\npost:@\n %a@." Sepprover.string_inner_form spec_post;) 87 | specs 88 | ) question_list 89 | 90 | let _ = 91 | System.set_signal_handlers (); 92 | main () 93 | -------------------------------------------------------------------------------- /src/symbfront/corestar.mli: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/symbfront/symbfront.mli 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | val logic_file_name : string ref 16 | val absrules_file_name : string ref 17 | val arg_list : (string * Arg.spec * string) list 18 | val main : unit -> unit 19 | -------------------------------------------------------------------------------- /src/symbfront/test_symb.ml: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/symbfront/test_symb.ml 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | (* This file is a front end to the symbolic execution *) 16 | 17 | open Core 18 | open Format 19 | open List 20 | open Load_logic 21 | open Pprinter_core 22 | open Psyntax 23 | 24 | let question_file_name = ref "";; 25 | let logic_file_name = ref "";; 26 | let absrules_file_name = ref "";; 27 | 28 | let set_question_file_name fn = 29 | question_file_name := fn; 30 | Symexec.file := Filename.basename fn 31 | 32 | let proof_succes = ref true;; 33 | 34 | let arg_list = Config.args_default @ 35 | [ ("-f", Arg.String set_question_file_name, "question file name" ); 36 | ("-l", Arg.Set_string logic_file_name, "logic file name" ); 37 | ("-a", Arg.Set_string absrules_file_name, "abstraction rules file name" ); 38 | ] 39 | 40 | 41 | let main () : unit = 42 | let usage_msg = "Usage: -l -a -f " in 43 | Arg.parse arg_list (fun s ->()) usage_msg; 44 | let args_ok = ref true in 45 | let check_fn = fun (f, m) -> 46 | if f = "" then ( 47 | eprintf "@[%s file name missing.@." m; 48 | args_ok := false) in 49 | List.iter check_fn [ 50 | (!question_file_name, "Question"); 51 | (!logic_file_name, "Logic"); 52 | (!absrules_file_name, "Abstraction rules")]; 53 | if not !args_ok then 54 | printf "@[ %s@\n@]" usage_msg 55 | else begin 56 | if !Config.smt_run then Smt.smt_init(); 57 | (* Load abstract interpretation plugins *) 58 | List.iter (fun file_name -> Plugin_manager.load_plugin file_name) !Config.abs_int_plugins; 59 | 60 | let l1,l2,cn = load_logic !logic_file_name in 61 | let lo = {empty_logic with seq_rules = l1; rw_rules = l2; consdecl = cn} in 62 | let l1,l2,cn = Load_logic.load_logic !absrules_file_name in 63 | let abs_rules = {empty_logic with seq_rules = l1; rw_rules = l2; consdecl = cn} in 64 | 65 | let question_list = 66 | System.parse_file 67 | Parser.symb_test_file 68 | Lexer.token 69 | !question_file_name 70 | "Test" in 71 | printf "@["; 72 | List.iter ( 73 | function Core.SpecTest (mname,spec,core,result) -> 74 | let cfg = map Cfg_core.mk_node core in 75 | if Symexec.verify mname cfg spec lo abs_rules = result 76 | then printf "." 77 | else printf "@\nTest %s wrongly %s.@\n" mname 78 | (if result then "fails" else "passes") 79 | ) question_list; 80 | printf "@]" 81 | end 82 | 83 | let _ = 84 | System.set_signal_handlers (); 85 | main () 86 | -------------------------------------------------------------------------------- /src/utils/backtrack.ml: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/utils/backtrack.ml 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | exception No_match 15 | 16 | let rec find_no_match_simp f l = 17 | let rec fnm_inner f l = 18 | match l with 19 | [] -> raise No_match 20 | | x::l -> try f x with No_match -> fnm_inner f l 21 | in fnm_inner f l 22 | 23 | let rec tryall f l t cont = 24 | let rec fnm_inner l = 25 | match l with 26 | [] -> raise No_match 27 | | x::l -> try f x t cont with No_match -> fnm_inner l 28 | in fnm_inner l 29 | 30 | let andthen first second x cont = 31 | let mk_cont f cont (ts, eq1) = f ts (function y, eq2 -> cont (y, eq2 @ eq1)) in 32 | let cont = mk_cont second cont in 33 | let cont = mk_cont first cont in 34 | cont (x, []) 35 | 36 | let using x cont f = 37 | f x cont 38 | -------------------------------------------------------------------------------- /src/utils/backtrack.mli: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/utils/backtrack.mli 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | exception No_match 16 | val find_no_match_simp : ('a -> 'b) -> 'a list -> 'b 17 | val tryall : ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b -> 'c -> 'd 18 | val andthen 19 | : ('a -> ('b * 'c list -> 'd) -> 'e) -> 20 | ('b -> ('f * 'c list -> 'g) -> 'd) -> 21 | 'a -> ('f * 'c list -> 'g) -> 'e 22 | val using : 'a -> 'b -> ('a -> 'b -> 'c) -> 'c 23 | -------------------------------------------------------------------------------- /src/utils/cli_utils.ml: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/utils/cli_utils.ml 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | let ( / ) a b = if Filename.is_relative b then Filename.concat a b else b 15 | 16 | let corestar_executable = Sys.executable_name (* This is bit of a guess. *) 17 | let corestar_bin_dir = Filename.dirname corestar_executable 18 | let corestar_home = corestar_bin_dir/Filename.parent_dir_name 19 | 20 | (* TODO(rgrig): Ideally [env_var] should be computed from [default]. *) 21 | let library_dirs env_var default = 22 | System.getenv_dirlist env_var @ [corestar_home/"library"/default] 23 | 24 | let logic_dirs = library_dirs "CORESTAR_LOGIC_LIBRARY" "logic" 25 | let specs_dirs = library_dirs "CORESTAR_SPECS_LIBRARY" "specifications" 26 | let abs_dirs = library_dirs "CORESTAR_ABS_LIBRARY" "abstraction" 27 | 28 | (* DBG 29 | let pd a = List.iter (fun x->Printf.printf "dir %s\n" x) a; print_newline () 30 | let _ = List.iter pd [logic_dirs; specs_dirs; abs_dirs] 31 | *) 32 | -------------------------------------------------------------------------------- /src/utils/cli_utils.mli: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/utils/cli_utils.mli 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | val logic_dirs : string list 15 | (** search path for logic files *) 16 | 17 | val specs_dirs : string list 18 | (** search path for specification files *) 19 | 20 | val abs_dirs : string list 21 | (** search path for abstraction files *) 22 | -------------------------------------------------------------------------------- /src/utils/config.ml: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/utils/config.ml 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | (* In this file we can put all global flags *) 16 | 17 | (** Flag for empty creating specs template *) 18 | let specs_template_mode = ref false 19 | 20 | (** Flag to print heaps on every node in the cfg *) 21 | let dotty_print = ref false 22 | 23 | let symb_debug_ref = ref false 24 | let symb_debug() = !symb_debug_ref 25 | 26 | let eclipse_ref = ref false 27 | let eclipse_mode() = !eclipse_ref 28 | 29 | let verb_proof_ref = ref false 30 | let verb_proof() = !verb_proof_ref 31 | 32 | let parse_debug_ref = ref false 33 | let parse_debug() = !parse_debug_ref 34 | 35 | let cfg_debug_ref = ref false 36 | let cfg_debug() = !cfg_debug_ref 37 | 38 | let smt_debug_ref = ref false 39 | let smt_debug() = !smt_debug_ref 40 | 41 | let abs_int_join_ref = ref false 42 | let abs_int_join() = !abs_int_join_ref 43 | 44 | let smt_run = ref true 45 | let solver_path = ref "" 46 | let smt_custom_commands = ref "" 47 | 48 | let set_debug_char (c : char) : unit = 49 | match c with 50 | | 'p' -> parse_debug_ref := true 51 | | 's' -> symb_debug_ref := true 52 | | 'c' -> cfg_debug_ref := true 53 | | 'm' -> smt_debug_ref := true 54 | | _ -> () 55 | 56 | 57 | let abs_int_plugins = ref [] 58 | let set_abs_int_plugins (comma_sep_lis : string) : unit = 59 | abs_int_plugins := Str.split (Str.regexp ":") comma_sep_lis 60 | 61 | 62 | let args_default = [ 63 | ("-q", Arg.Clear(symb_debug_ref), "Run in quiet mode" ); 64 | ("-v", Arg.Set(verb_proof_ref), "Verbose proofs"); 65 | ("-d", Arg.String(String.iter set_debug_char), "Set debug modes"); 66 | ("-nosmt", Arg.Clear(smt_run),"Don't use the SMT solver"); 67 | ("-p", Arg.Set_string(solver_path), "SMT solver path"); 68 | ("-b", Arg.Set_string(smt_custom_commands), "Background predicate"); 69 | ("-ai", Arg.String(set_abs_int_plugins), "Colon separated list of AI plugins filenames"); 70 | ("-join", Arg.Set(abs_int_join_ref), "On abstraction join heaps over their numeric part"); 71 | ] 72 | -------------------------------------------------------------------------------- /src/utils/config.mli: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/utils/config.mli 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | val specs_template_mode : bool ref 16 | val dotty_print : bool ref 17 | val symb_debug : unit -> bool 18 | val eclipse_ref : bool ref 19 | val parse_debug : unit -> bool 20 | val smt_debug : unit -> bool 21 | val abs_int_join : unit -> bool 22 | val solver_path : string ref 23 | val smt_run : bool ref 24 | val smt_custom_commands : string ref 25 | val args_default : (string * Arg.spec * string) list 26 | val verb_proof : unit -> bool 27 | val eclipse_mode : unit -> bool 28 | val abs_int_plugins : string list ref 29 | -------------------------------------------------------------------------------- /src/utils/corestar_std.ml: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/utils/corestar_std.mli 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | module Int = struct type t = int let compare = compare end 16 | module StringSet = Set.Make (String) 17 | module IntSet = Set.Make (Int) 18 | module StringMap = Map.Make (String) 19 | module IntMap = Set.Make (Int) 20 | 21 | let ( @@ ) f g x = f (g x) 22 | let ( & ) f x = f x 23 | let ( |> ) x f = f x 24 | let ( =:: ) xs x = xs := x :: !xs 25 | let ( !* ) = Lazy.force 26 | 27 | let curry f a b = f (a, b) 28 | let uncurry f (a, b) = f a b 29 | 30 | let maybe n f = function 31 | | None -> n 32 | | Some x -> f x 33 | 34 | module CharH = struct 35 | let is_space = 36 | let spaces = " \t\n\r\x0b\x0c" in 37 | fun c -> String.contains spaces c 38 | end 39 | 40 | module StringH = struct 41 | let trim s = 42 | let n = String.length s in 43 | let i, j = ref 0, ref (n - 1) in 44 | while !i < n && CharH.is_space s.[!i] do incr i done; 45 | if !i = n then "" 46 | else begin 47 | while CharH.is_space s.[!j] do decr j done; 48 | String.sub s !i (!j - !i + 1) 49 | end 50 | 51 | let starts_with prefix s = 52 | let n = String.length prefix in 53 | if n > String.length s 54 | then false 55 | else String.sub s 0 n = prefix 56 | 57 | let ends_with suffix s = 58 | let m = String.length s in 59 | let n = String.length suffix in 60 | if n > m 61 | then false 62 | else String.sub s (m - n) n = suffix 63 | end 64 | 65 | module MapHelper = functor (M : Map.S) -> struct 66 | let filter (p : M.key -> 'a -> bool) (map : 'a M.t) : 'a M.t = 67 | M.fold (fun k v a -> if p k v then M.add k v a else a) map M.empty 68 | end 69 | 70 | module HashtblH = struct 71 | let of_list l = 72 | let h = Hashtbl.create (2 * List.length l + 1) in 73 | List.iter (uncurry (Hashtbl.replace h)) l; h 74 | end 75 | 76 | module ListH = struct 77 | let init n f = 78 | let rec loop acc = function 79 | | 0 -> acc 80 | | n -> loop (f (n - 1) :: acc) (n - 1) in 81 | loop [] n 82 | end 83 | -------------------------------------------------------------------------------- /src/utils/corestar_std.mli: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/utils/corestar_std.mli 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | (** Contains utilities that we'd like to have had in OCaml's stdlib. *) 16 | 17 | (* {{{ *) (** {2 Common operations} *) 18 | 19 | (** 20 | Function composition. Where a function is expected, you can write [g @@ 21 | f] instead of [fun x -> g (f x)]. 22 | *) 23 | val ( @@ ) : ('b -> 'c) -> ('a -> 'b) -> ('a -> 'c) 24 | 25 | (** Function feeding. You can write [x |> f |> g] instead of [g (f (x))]. *) 26 | val ( |> ) : 'a -> ('a -> 'b) -> 'b 27 | 28 | (** Function application. You can write [g & f & x] instead of [g (f (x))]. *) 29 | val ( & ) : ('a -> 'b) -> 'a -> 'b 30 | 31 | (** [xs =:: x] prepends [x] to [xs] *) 32 | val ( =:: ) : 'a list ref -> 'a -> unit 33 | 34 | (** Shortcut for [Lazy.force]. *) 35 | val ( !* ) : 'a Lazy.t -> 'a 36 | 37 | (** Converts an uncurried function into a curried one. *) 38 | val curry : ('a * 'b -> 'c) -> 'a -> 'b -> 'c 39 | 40 | (** Converts a curried function into an uncurried one. *) 41 | val uncurry : ('a -> 'b -> 'c) -> 'a * 'b -> 'c 42 | 43 | (** Like in Haskell. *) 44 | val maybe : 'b -> ('a -> 'b) -> 'a option -> 'b 45 | 46 | (* }}} *) 47 | (* {{{ *) (** {2 Sets and maps} *) 48 | 49 | (** A set of strings. *) 50 | module StringSet : Set.S with type elt = string 51 | 52 | (** A set of integers. *) 53 | module IntSet : Set.S with type elt = int 54 | 55 | (** 56 | A few helpers for dealing with maps. This is a workaround for the lack of 57 | some functions in the standard Map.S module. Whenever you define a map 58 | [module M = Map.Make (...)] you can also define [module MH = MapHelper 59 | (M)]. Normal functions like [M.fold] are used as before, but you can also 60 | say things like [MH.filter]. 61 | 62 | Should be removed once we move to OCaml 3.12. 63 | *) 64 | module MapHelper : 65 | functor (M : Map.S) -> sig 66 | (** 67 | [filter p m] returns a map with all the keys that satisfy predicate 68 | [p]. Takes O(|m|+|n| lg |n|) time, where [n] is the result. 69 | *) 70 | val filter : (M.key -> 'a -> bool) -> 'a M.t -> 'a M.t 71 | end 72 | 73 | module HashtblH : sig 74 | (** Builds a hashtable from an association list. *) 75 | val of_list : ('a * 'b) list -> ('a, 'b) Hashtbl.t 76 | end 77 | (* }}} *) 78 | (* {{{ *) (** {2 String and char utilities} *) 79 | 80 | (** Functions missing from [Char]. *) 81 | module CharH : sig 82 | (** Same as the C function [isspace] in the POSIX locale. *) 83 | val is_space : char -> bool 84 | end 85 | 86 | (** Functions missing from [String]. *) 87 | module StringH : sig 88 | (** 89 | Removes the longest prefix and the longest suffix made entierly of 90 | spaces. In particular, it returns the empty string if the input is all 91 | spaces. 92 | *) 93 | val trim : string -> string 94 | 95 | (** [starts_with prefix s] says whether [s] starts with [prefix]. *) 96 | val starts_with : string -> string -> bool 97 | 98 | (** [ends_with suffix s] says whether [s] ends with [suffix]. *) 99 | val ends_with : string -> string -> bool 100 | end 101 | 102 | (* }}} *) 103 | (* {{{ *) (** {2 List and array utilities} *) 104 | module ListH : sig 105 | val init : int -> (int -> 'a) -> 'a list 106 | (** Like [Array.init]. *) 107 | end 108 | (* }}} *) 109 | -------------------------------------------------------------------------------- /src/utils/debug.ml: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/utils/debug.ml 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | (* 15 | * Debug helpers. The code of coreStar supports debugging in two ways. First, by 16 | * setting [safe] mode (possibly expensive) sanity checks are run. (There is no 17 | * reason to ever turn off cheap sanity checks.) Second, the code is 18 | * interspersed with dumps of various state information. For logging, however, 19 | * there can't be only one control that turns it on or off, because that would 20 | * be confusing. For example, if the programmer suspects a bug in the proof 21 | * search, then messages that describe how symbolic execution proceeds are 22 | * distracting garbage. Hence, logging is split into categories, and each 23 | * subset of categories may be turned on at a time. As with sanity checks, 24 | * logging may be expensive, so the messages for categories that are turned off 25 | * are not even constructed (rather than being constructed but not printed). 26 | * 27 | * When sanity check or logging is turned off, the compiler throws away the 28 | * corresponding debugging code completely. That is why the on/off controls are 29 | * immutable and why bit-masks are used instead of fancier data structures like 30 | * lists. 31 | * 32 | * Guidelines for sanity checks. Expensive sanity (invariant) checks should 33 | * typically be put in functions starting with "check_". Then they should be 34 | * called by using the laziness of the if statement and that of boolean and. 35 | * if safe then check_inv data 36 | * The checking function is suposed to raise an exception or to assert if a 37 | * problem is detected. 38 | * 39 | * Guidelines for logging. The typical logging code is 40 | * if log log_category then 41 | * fprintf logf "@[Some message.@." 42 | * assuming that modules Debug and Format are open. Note that each log message 43 | * starts by opening a box ("@[") and finishes by flushing, closing boxes and 44 | * going to a new line ("@."). The first complication that may appear is that 45 | * a message belongs not to one log_category but to several log categories 46 | * log_a, log_b, and log_c. 47 | * if log_active land (log_a lor log_b lor log_c) <> 0 then 48 | * fprintf logf "Some message.@." 49 | * The second complication is that the message might be long. 50 | * if log log_category then 51 | * fprintf logf "@[<4>Some message with@ break hints.@." 52 | * Finally, to dump big data structures use %a. 53 | * if log log_category then 54 | * fprintf logf "@[<2>Here's a foo:%a@." print_function data 55 | * Note that while printing a hierarchical structure it is usually convenient to 56 | * (1) force a newline "@\n", (2) open a box and prepare the indent for the 57 | * children "@[<2>", (3) print some data, (4) recursively print the children 58 | * using %a, and (5) close the box "@]". Boxes should typically be opened only 59 | * after "@\n". A data type X should have a pretty printing function pp_X : 60 | * formatter -> X -> unit. 61 | * 62 | * Opening Format should make it less likely to mix Format with Printf. 63 | * 64 | * Finally, don't forget that guidelines are meant to be broken. 65 | *) 66 | 67 | (*F# 68 | open Microsoft.FSharp.Compatibility 69 | F#*) 70 | open Format 71 | 72 | let safe = true 73 | 74 | let log_exec = 1 lsl 0 75 | let log_load = 1 lsl 1 76 | let log_logic = 1 lsl 2 77 | let log_phase = 1 lsl 3 78 | let log_prove = 1 lsl 4 79 | let log_specs = 1 lsl 5 80 | let log_smt = 1 lsl 6 81 | 82 | let log_active = 0 83 | (* -1 means all, 0 means one, in general use lor *) 84 | 85 | let log x = log_active land x <> 0 86 | 87 | let logf = std_formatter 88 | 89 | 90 | (* TODO(rgrig): Review. *) 91 | let debug = false 92 | 93 | 94 | let buffer_dump = Buffer.create 10000 95 | 96 | let flagged_formatter frm flag = 97 | let sxy,fl = Format.pp_get_formatter_output_functions frm () in 98 | Format.make_formatter 99 | (fun s x y -> if flag then sxy s x y) (fun () -> fl ()) 100 | 101 | let merge_formatters frm1 frm2 = 102 | let sxy1,fl1 = Format.pp_get_formatter_output_functions frm1 () in 103 | let sxy2,fl2 = Format.pp_get_formatter_output_functions frm2 () in 104 | Format.make_formatter (fun s x y -> sxy1 s x y; sxy2 s x y) (fun () -> fl1 () ; fl2 ()) 105 | 106 | 107 | 108 | let proof_dump = ref (merge_formatters 109 | (Format.formatter_of_buffer buffer_dump) 110 | (flagged_formatter Format.std_formatter (log log_prove || (Config.verb_proof())))) 111 | 112 | (*IF-OCAML*) 113 | exception Unsupported 114 | let unsupported () = raise Unsupported 115 | 116 | exception Unsupported2 of string 117 | let unsupported_s s = raise (Unsupported2 s) 118 | 119 | (*ENDIF-OCAML*) 120 | 121 | (*F# 122 | let unsupported () = failwith "Assert false" 123 | F#*) 124 | 125 | let pp_list pp f = List.iter (pp f) 126 | 127 | (* TODO(rgrig): Move this out of debug. *) 128 | (* TODO(rgrig): Use a local buffer instead of the global str_formatter. *) 129 | let string_of pp x = pp str_formatter x; flush_str_formatter () 130 | 131 | let rec form_format sep emp f ppf list = 132 | match list with 133 | [] -> Format.fprintf ppf "%s" emp 134 | | [x] -> Format.fprintf ppf "%a" f x 135 | | x::xs -> Format.fprintf ppf "@[%a@]@ %s @[%a@]" f x sep (form_format sep emp f) xs 136 | 137 | 138 | let rec form_format_optional start sep emp f ppf list = 139 | Format.fprintf ppf "%s@ @[%a@]" start (form_format sep emp f) list 140 | 141 | let rec list_format sep f ppf = function 142 | | [] -> () 143 | | [x] -> fprintf ppf "%a" f x 144 | | x::xs -> fprintf ppf "%a@ %s %a" f x sep (list_format sep f) xs 145 | 146 | let rec list_format_optional start sep f ppf = function 147 | | [] -> () 148 | | xs -> fprintf ppf "%s@ %a" start (list_format sep f) xs 149 | 150 | let toString f a : string = 151 | fprintf (str_formatter) "%a" f a ; flush_str_formatter () 152 | -------------------------------------------------------------------------------- /src/utils/debug.mli: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/utils/debug.mli 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | val safe : bool 16 | val log_specs : int 17 | val log_phase : int 18 | val log_load : int 19 | val log_prove : int 20 | val log_exec : int 21 | val log_logic : int 22 | val log_smt : int 23 | val log : int -> bool 24 | val logf : Format.formatter 25 | val debug : bool 26 | val buffer_dump : Buffer.t 27 | val proof_dump : Format.formatter ref 28 | val unsupported : unit -> 'a 29 | val unsupported_s : string -> 'a 30 | val pp_list : ('a -> 'b -> unit) -> 'a -> 'b list -> unit 31 | val string_of : (Format.formatter -> 'a -> 'b) -> 'a -> string 32 | val list_format : 33 | string -> 34 | (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a list -> unit 35 | val toString : (Format.formatter -> 'a -> unit) -> 'a -> string 36 | -------------------------------------------------------------------------------- /src/utils/dot.ml: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/utils/dot.ml 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | let escape_for_label s = 16 | Str.global_replace (Str.regexp "\\\\n") "\\l" (String.escaped s) 17 | 18 | -------------------------------------------------------------------------------- /src/utils/dot.mli: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/utils/dot.mli 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | (** Handling of graphviz (.dot) files. *) 16 | 17 | val escape_for_label : string -> string 18 | (** [escape_for_label s] is what should be put in a .dot file so that 19 | the user sees [s] when viewing the .dot file. *) 20 | -------------------------------------------------------------------------------- /src/utils/load.ml: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/utils/load.ml 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | (* File to read a logic file and its imports. *) 15 | 16 | open Debug 17 | open Format 18 | 19 | type 'a importoption = 20 | ImportEntry of string 21 | | NormalEntry of 'a 22 | 23 | 24 | let import_flatten_extra_rules dirs filename extra_rules fileparser lexer = 25 | let rec import_flatten_inner dirs filename acc already_included = 26 | let rel_dir = (Filename.dirname filename) in 27 | let filename = 28 | try 29 | System.find_file_from_dirs dirs filename 30 | with Not_found -> (failwith ("Cannot find file " ^ filename)) in 31 | if List.mem filename already_included then 32 | (if log log_phase then 33 | fprintf logf "@[<4>File %s@ already included.@." filename; 34 | (acc, already_included)) 35 | else ( 36 | let already_included = filename::already_included in 37 | if log log_phase then 38 | fprintf logf "@[<4>Parsing logic in@ %s.@." filename; 39 | let file_entry_list = System.parse_file fileparser lexer filename "logic" in 40 | if log log_phase then 41 | fprintf logf "@[Parsed %s.@." filename; 42 | List.fold_left 43 | (fun (acc,already_included) entry -> 44 | match entry with 45 | ImportEntry filen -> 46 | import_flatten_inner (rel_dir::dirs) filen acc already_included 47 | | NormalEntry ent -> 48 | (ent::acc, already_included) 49 | ) (acc,already_included) (extra_rules@file_entry_list) 50 | ) 51 | in 52 | fst (import_flatten_inner dirs filename [] []) 53 | 54 | let import_flatten dirs filename fileparser = 55 | import_flatten_extra_rules dirs filename [] fileparser 56 | -------------------------------------------------------------------------------- /src/utils/load.mli: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/utils/load.mli 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | type 'a importoption = ImportEntry of string | NormalEntry of 'a 15 | val import_flatten_extra_rules : 16 | string list -> 17 | string -> 18 | 'a importoption list -> 19 | ((Lexing.lexbuf -> 'b) -> Lexing.lexbuf -> 'a importoption list) -> 20 | (Lexing.lexbuf -> 'b) -> 'a list 21 | val import_flatten : 22 | string list -> 23 | string -> 24 | ((Lexing.lexbuf -> 'a) -> Lexing.lexbuf -> 'b importoption list) -> 25 | (Lexing.lexbuf -> 'a) -> 'b list 26 | -------------------------------------------------------------------------------- /src/utils/misc.ml: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/utils/misc.ml 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | open Backtrack 15 | 16 | let map_option f l = 17 | let f' acc x = match f x with 18 | | None -> acc 19 | | Some y -> y :: acc in 20 | List.rev (List.fold_left f' [] l) 21 | 22 | let map_lift_exists f l 23 | = 24 | List.fold_right 25 | (fun el rest-> 26 | match f el, rest with 27 | None,_ -> rest 28 | | Some el,Some rest -> Some (el::rest) 29 | | Some el, None -> Some [el]) l None 30 | 31 | let map_lift_forall f l 32 | = 33 | List.fold_right 34 | (fun el rest-> 35 | match f el, rest with 36 | None,_ -> None 37 | | _, None -> None 38 | | Some el,Some rest -> Some (el::rest)) l (Some []) 39 | 40 | 41 | type ('a,'b) sum = 42 | Inr of 'a 43 | | Inl of 'b 44 | 45 | let map_sum f l 46 | = 47 | List.fold_right 48 | (fun el (restl,restr) -> 49 | match f el with 50 | | Inl l -> (l::restl,restr) 51 | | Inr r -> (restl,r::restr)) l ([],[]) 52 | 53 | 54 | let remove_duplicates c l = 55 | let l = List.sort c l in 56 | snd ( 57 | List.fold_left 58 | (fun (complast,list) next -> 59 | if complast next = 0 then (complast,list) else (c next, next::list) 60 | ) ((fun _ -> -1),[]) l 61 | ) 62 | 63 | 64 | (* TODO(rgrig): Isn't intcmp x y = compare y x? *) 65 | let intcmp a b = 66 | if a raise Not_found 76 | | x :: xs -> try f x with _ -> map_and_find f xs 77 | 78 | let rec find_no_match_simp f l = 79 | let rec fnm_inner f l = 80 | match l with 81 | [] -> raise No_match 82 | | x::l -> try f x with No_match -> fnm_inner f l 83 | in fnm_inner f l 84 | 85 | 86 | 87 | let lift_pair f = 88 | fun (x,y) -> (f x, f y) 89 | 90 | let lift_option f = 91 | fun x -> match x with 92 | Some x -> f x 93 | | None -> None 94 | 95 | let rec add_index 96 | ( xs : 'a list ) 97 | ( i : int ) : ('a * int) list = 98 | match xs with | [] -> [] 99 | | y::ys -> ( (y,i) :: (add_index ys (i+1)) ) 100 | 101 | let memo2 f = 102 | let cache = Hashtbl.create 101 in 103 | fun x y -> 104 | try Hashtbl.find cache (x, y) 105 | with Not_found -> 106 | let r = f x y in 107 | (Hashtbl.add cache (x, y) r; r) 108 | 109 | let cross_product l1 l2 = 110 | let product l v2 = List.map (fun v1 -> (v1, v2)) l in 111 | List.concat (List.map (product l1) l2) 112 | -------------------------------------------------------------------------------- /src/utils/misc.mli: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/utils/misc.mli 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | (** Utilities that do not clearly fit in any other module. *) 15 | 16 | val map_option : ('a -> 'b option) -> 'a list -> 'b list 17 | type ('a, 'b) sum = Inr of 'a | Inl of 'b 18 | val remove_duplicates : ('a -> 'a -> int) -> 'a list -> 'a list 19 | val intcmp : 'a -> 'a -> int 20 | val intcmp2 : 'a * 'b -> 'a * 'b -> int 21 | 22 | val map_and_find : ('a -> 'b) -> 'a list -> 'b 23 | (** 24 | [map_and_find f as] returns the result of the first successful 25 | application of [f] to an element of [as], or raises [Not_found] if 26 | all applications are unsuccsessful. The elements of [as] are tried in 27 | order. An application is successful when it raises no exception. 28 | *) 29 | 30 | val find_no_match_simp : ('a -> 'b) -> 'a list -> 'b 31 | val lift_pair : ('a -> 'b) -> 'a * 'a -> 'b * 'b 32 | val add_index : 'a list -> int -> ('a * int) list 33 | 34 | val memo2 : ('a -> 'b -> 'c) -> ('a -> 'b -> 'c) 35 | (** [memo2 f] returns a memoized version of [f]. *) 36 | 37 | val cross_product : ('a list) -> ('b list) -> (('a * 'b) list) 38 | -------------------------------------------------------------------------------- /src/utils/multiset.ml: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/utils/multiset.ml 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | (* Search and remove structure *) 15 | (* Multiset that allows for iteration through the elements *) 16 | 17 | 18 | module MultisetImpl (A : Set.OrderedType) = 19 | struct 20 | type t = A.t 21 | type multiset = A.t list * A.t list 22 | 23 | (* TODO(rgrig): I don't understand the following comment. 24 | * Invariant all inner list must be non-empty 25 | That is, forall splittings 26 | forall xs,ys. t != xs @ [] :: ys 27 | *) 28 | 29 | exception Empty 30 | 31 | let rec revapp xs ys = 32 | match xs with 33 | [] -> ys 34 | | x::xs -> revapp xs (x::ys) 35 | 36 | let is_empty (x,y) : bool = 37 | match x,y with 38 | [],[] -> true 39 | | _,_ -> false 40 | 41 | let has_more ((x,y) : multiset) : bool = 42 | match x with 43 | [] -> false 44 | | _ -> true 45 | 46 | let next ((x,y) : multiset) : multiset= 47 | match x with 48 | [] -> raise Empty 49 | | (x::xs) -> (xs,x::y) 50 | 51 | let rec back ((xs,ys) : multiset) (n : int) : multiset= 52 | match n with 53 | 0 -> (xs,ys) 54 | | n -> 55 | begin 56 | match ys with 57 | [] -> raise Empty 58 | | (y::ys) -> back (y::xs,ys) (n-1) 59 | end 60 | 61 | let peek ((x,y) : multiset) : A.t = 62 | match x with 63 | [] -> raise Empty 64 | | (x::xs) -> x 65 | 66 | let remove ((x,y) : multiset) : A.t * multiset= 67 | match x with 68 | [] -> raise Empty 69 | | (x::xs) -> x,(xs,y) 70 | 71 | let lift_list (xs : A.t list) : multiset = 72 | List.sort compare xs, [] 73 | 74 | let restart (x,y) : multiset = 75 | revapp y x, [] 76 | 77 | let union a b = 78 | let a = restart a in 79 | let b = restart b in 80 | match a, b with 81 | (a,[]), (b,[]) -> List.merge compare a b, [] 82 | | _ -> assert false 83 | 84 | let empty = 85 | [],[] 86 | 87 | let iter f (x, y) = 88 | List.iter f (List.rev y); 89 | List.iter f x 90 | 91 | let fold f s (x, y) = 92 | let f' a b = f b a in 93 | List.fold_left f (List.fold_right f' y s) x 94 | 95 | let map_to_list a f = 96 | let a = restart a in 97 | let rec inner a rs = 98 | if has_more a then 99 | let x,a = remove a in 100 | inner a ((f x)::rs) 101 | else 102 | rs 103 | in inner a [] 104 | 105 | let fold_to_list a f b = 106 | let a = restart a in 107 | let rec inner a b = 108 | if has_more a then 109 | let x,a = remove a in 110 | let r = f x b in 111 | inner a r 112 | else 113 | b 114 | in inner a b 115 | 116 | let intersect set1 set2 = 117 | if is_empty set1 then 118 | empty,empty,set2 119 | else if is_empty set2 then 120 | empty,set1,empty 121 | else 122 | let set1 = restart set1 in 123 | let set2 = restart set2 in 124 | let rec f set1 set2 res = 125 | if has_more set1 && has_more set2 then 126 | let x1,nset1 = remove set1 in 127 | let x2,nset2 = remove set2 in 128 | if compare x1 x2 = 0 then 129 | f nset1 nset2 (x1::res) 130 | else if compare x1 x2 < 0 then 131 | f (next set1) set2 res 132 | else 133 | f set1 (next set2) res 134 | else 135 | (List.rev res,[]), restart set1, restart set2 136 | in 137 | f set1 set2 [] 138 | 139 | end 140 | -------------------------------------------------------------------------------- /src/utils/multiset.mli: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/utils/multiset.mli 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | (* Multiset that allows for iteration through the elements *) 16 | 17 | module MultisetImpl (A : Map.OrderedType) : 18 | sig 19 | type t = A.t 20 | type multiset 21 | 22 | 23 | (* Checks if the multiset is empty *) 24 | val is_empty : multiset -> bool 25 | (* The iterator has more elements *) 26 | val has_more : multiset -> bool 27 | (* Move to the next element *) 28 | val next : multiset -> multiset 29 | (* return the current element *) 30 | val peek : multiset -> t 31 | (* return the current element, and remove it from the set *) 32 | val remove : multiset -> t * multiset 33 | (* Restart search in multiset *) 34 | val restart : multiset -> multiset 35 | 36 | (** [MultisetImpl.iter f m] applies function [f] in turn to all the 37 | * elements of [m] in increasing order. *) 38 | val iter : (t -> unit) -> multiset -> unit 39 | 40 | val fold : ('a -> t -> 'a) -> 'a -> multiset -> 'a 41 | 42 | (* Convert a normal list to this kind of multiset *) 43 | val lift_list : t list -> multiset 44 | (* union of two multisets, restarts interator of new multiset *) 45 | val union : multiset -> multiset -> multiset 46 | val empty : multiset 47 | 48 | (* Computes intersection of two multisets, 49 | also returns remainders. 50 | Uses comparison function to improve efficiency *) 51 | val intersect : multiset -> multiset -> (multiset * multiset * multiset) 52 | 53 | val back : multiset -> int -> multiset 54 | 55 | val map_to_list : multiset -> (A.t -> 'b) -> 'b list 56 | 57 | (* fold_to_list ([x1; ...; xn], []) f a == f xn (f xn-1 (... (f x1 a) ...)) *) 58 | val fold_to_list : multiset -> (A.t -> 'a -> 'a) -> 'a -> 'a 59 | end 60 | 61 | -------------------------------------------------------------------------------- /src/utils/persistentarray.ml: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/utils/persistentarray.ml 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | (* This file contains an implementation of Persistent Array following: 15 | A Persistent Union-Find Data Structure 16 | Sylvain Conchon Jean-Christophe Filliatre 17 | Workshop on ML'07 18 | 19 | However, we have extended it to enable the array to be grown dynamically. 20 | 21 | *) 22 | 23 | (* grow makes all arrays grow, not just current one*) 24 | module type GrowablePersistentArray = sig 25 | type 'a t 26 | val set : 'a t -> int -> 'a -> 'a t 27 | val get : 'a t -> int -> 'a 28 | val create : (int -> 'a) -> 'a t 29 | val size : 'a t -> int 30 | val grow : 'a t -> int -> 'a t 31 | (* Do not use the array you pass in. *) 32 | val unsafe_create : 'a array -> (int -> 'a) -> 'a t 33 | end 34 | 35 | module GrowablePersistentImpl : GrowablePersistentArray = 36 | struct 37 | type 'a t = 'a data ref * int 38 | and 'a data = 39 | RealArray of 'a array * (int -> 'a) 40 | | Diff of int * 'a * 'a t 41 | 42 | (* Make array currently being accessed top *) 43 | let rec reroot (a,ir') = 44 | match !a with 45 | RealArray(_,_) -> () 46 | | Diff(i,x,(b,ir)) -> 47 | reroot (b,ir); 48 | match !b with 49 | Diff(_,_,_) -> 50 | (* reroot will make top thing the RealArray so not 51 | possible for it to be a Diff. *) 52 | assert false 53 | | RealArray(c,f) -> 54 | let oldi = Array.get c i in 55 | Array.set c i x; 56 | a := RealArray(c,f); 57 | b := Diff(i, oldi, (a,ir')) 58 | 59 | 60 | 61 | let create f = (ref (RealArray (Array.init 2 f, f)), 62 | 0) 63 | 64 | let unsafe_create a f = (ref (RealArray (a, f)), 65 | Array.length a) 66 | 67 | let rec get (a,ir) i = 68 | reroot (a,ir); 69 | match !a with 70 | RealArray (a,f) -> Array.get a i 71 | | Diff (j, x, a) -> if i=j then x else get a i 72 | 73 | let rec set (a,ir) i x = 74 | reroot (a,ir); 75 | match !a with 76 | RealArray (a',f) as n -> 77 | let old = Array.get a' i in 78 | if old <> x then 79 | begin 80 | Array.set a' i x; 81 | let na = ref n,ir in 82 | a := Diff(i,old,na); 83 | na 84 | end 85 | else 86 | (a,ir) 87 | | _ -> ref (Diff (i,x,(a,ir))), ir 88 | 89 | 90 | 91 | (* Helper functions for accessing the underlying array to allow it 92 | to be resized. *) 93 | let rec real_array ((a,ir) : 'a t) = 94 | match !a with 95 | RealArray(_,_) -> a 96 | | Diff(i,x,a) -> real_array a 97 | 98 | let real_size (a,ir) = 99 | let ra = real_array (a,ir) in 100 | match !ra with 101 | RealArray (a,f) -> Array.length a 102 | | Diff(_,_,_) -> assert false 103 | 104 | let size (a,ir) = ir 105 | 106 | (* Make underlying array twice as large *) 107 | let double (a,ir) = 108 | let ra = real_array (a,ir) in 109 | match !ra with 110 | RealArray (a,f) -> 111 | let n = Array.length a in 112 | ra := RealArray(Array.init (n*2) (fun i -> if i < n then a.(i) else f(i)),f) 113 | | Diff(_,_,_) -> assert false 114 | 115 | (* Extend array, possibly growing underlying array if necessary. *) 116 | let grow t n = 117 | if size t + n >= real_size t then 118 | double t; 119 | let (a,ir) = t in 120 | let size = ir in 121 | (a,size+n) 122 | 123 | end 124 | 125 | -------------------------------------------------------------------------------- /src/utils/persistentarray.mli: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/utils/persistentarray.mli 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | module type GrowablePersistentArray = 16 | sig 17 | type 'a t 18 | val set : 'a t -> int -> 'a -> 'a t 19 | val get : 'a t -> int -> 'a 20 | val create : (int -> 'a) -> 'a t 21 | val size : 'a t -> int 22 | val grow : 'a t -> int -> 'a t 23 | val unsafe_create : 'a array -> (int -> 'a) -> 'a t 24 | end 25 | module GrowablePersistentImpl : GrowablePersistentArray 26 | -------------------------------------------------------------------------------- /src/utils/printing.ml: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/utils/printing.ml 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | open Format 16 | 17 | (* TODO(rgrig): Shouldn't this keep track of the file path too? *) 18 | (* TODO(rgrig): Should probably be in a different file. *) 19 | type source_location = { 20 | begin_line : int; 21 | begin_column : int; 22 | end_line : int; 23 | end_column : int 24 | } 25 | 26 | let unknown_location = 27 | { begin_line = -1; begin_column = -1; end_line = -1; end_column = -1} 28 | 29 | 30 | (** Maps node identifiers (as used in symbolic execution) to locations. *) 31 | (* TODO(rgrig): I think [int] should be [node_id] or similar. *) 32 | let locations : (int, source_location) Hashtbl.t = 33 | Hashtbl.create 101 34 | 35 | (*DBG 36 | let dump_locations () = 37 | printf "@[<2>Locations table:"; 38 | Hashtbl.iter 39 | (fun k, {bl=begin_line;bc=begin_column;el=end_line;ec=end_column} -> 40 | printf "@\n%d -> %d:%d-%d:%d" k bl bc el ec) 41 | locations; 42 | printf "@." 43 | *) 44 | 45 | let add_location i = function 46 | | None -> () 47 | | Some l -> Hashtbl.add locations i l 48 | 49 | let find_location i = 50 | try Hashtbl.find locations i with Not_found -> unknown_location 51 | 52 | let pp_json_location l t c = 53 | if Config.eclipse_mode() then ( 54 | printf "@\njson {\"error_pos\": {"; 55 | List.iter (fun (k, v) -> printf "\"%s\": \"%d\"," k v) [ 56 | ("sline", l.begin_line); 57 | ("eline", l.end_line); 58 | ("spos", l.begin_column); 59 | ("epos", l.end_column)]; 60 | printf "},\"error_text\": \"%s\",\"counter_example\": \"%s\"}@\n" (String.escaped t) (String.escaped c)) 61 | 62 | let pp_json_location_opt = function 63 | | None -> pp_json_location unknown_location 64 | | Some l -> pp_json_location l 65 | 66 | let pp_json_node i = pp_json_location (find_location i) 67 | 68 | (* {{{ pretty printing of collections 69 | * See 70 | * http://rgrig.blogspot.com/2010/09/certain-type-of-pretty-printing-in.html 71 | * for a little background. *) 72 | 73 | type sep_wrapper = { 74 | separator : 'a. (formatter -> 'a -> unit) -> formatter -> bool -> 'a -> bool 75 | } 76 | let pp_sep sep_text = { 77 | separator = fun pp ppf first x -> 78 | if not first then fprintf ppf "@, %s " sep_text; pp ppf x; false 79 | } 80 | let pp_star = pp_sep "*" 81 | 82 | let pp_whole pp_element pp_separator = 83 | fun ppf x -> ignore (pp_element pp_separator ppf true x) 84 | 85 | (* {{{ printing for typical collection elements *) 86 | let pp_binary_op operator pp_operand ppf (l, r) = 87 | fprintf ppf "@[@[%a@]%s@[%a@]@]@," pp_operand l operator pp_operand r 88 | let pp_eq pp_operand = pp_binary_op "=" pp_operand 89 | let pp_neq pp_operand = pp_binary_op "!=" pp_operand 90 | let pp_disjunct pp_operand = pp_binary_op " || " pp_operand 91 | (* }}} *) 92 | (* }}} *) 93 | -------------------------------------------------------------------------------- /src/utils/printing.mli: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/utils/printing.mli 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | type source_location = { 16 | begin_line : int; 17 | begin_column : int; 18 | end_line : int; 19 | end_column : int; 20 | } 21 | val add_location : int -> source_location option -> unit 22 | val pp_json_location_opt : source_location option -> string -> string -> unit 23 | val pp_json_node : int -> string -> string -> unit 24 | type sep_wrapper = { 25 | separator : 26 | 'a. 27 | (Format.formatter -> 'a -> unit) -> 28 | Format.formatter -> bool -> 'a -> bool; 29 | } 30 | val pp_sep : string -> sep_wrapper 31 | val pp_star : sep_wrapper 32 | val pp_whole : ('a -> 'b -> bool -> 'c -> 'd) -> 'a -> 'b -> 'c -> unit 33 | val pp_eq : 34 | (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a * 'a -> unit 35 | val pp_neq : 36 | (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a * 'a -> unit 37 | val pp_disjunct : 38 | (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a * 'a -> unit 39 | -------------------------------------------------------------------------------- /src/utils/system.ml: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/utils/system.ml 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | open Debug 15 | open Corestar_std 16 | 17 | let java_path_delimiter = if Sys.os_type = "Windows" then ";" else ":" 18 | let java_path_delimiter_re = Str.regexp (java_path_delimiter ^ "+") 19 | 20 | let getenv variable = 21 | try Sys.getenv variable with Not_found -> "" 22 | 23 | let getenv_dirlist variable = 24 | Str.split java_path_delimiter_re (getenv variable) 25 | 26 | 27 | (* read a file into a string *) 28 | let string_of_file fname = 29 | let ichan = if fname = "-" then stdin else open_in fname 30 | and str = String.create 1024 31 | and buf = Buffer.create 1024 in 32 | let rec loop () = 33 | let len = input ichan str 0 1024 in 34 | Buffer.add_substring buf str 0 len; 35 | if len = 0 then Buffer.contents buf else loop () in 36 | let s = loop () in 37 | close_in ichan; 38 | s 39 | 40 | 41 | let parse_file pars lexe fname ftype = 42 | try 43 | if log log_phase then 44 | Printf.printf "Start parsing %s in %s...\n" ftype fname; 45 | let ichan = open_in fname in 46 | let ret = pars lexe (Lexing.from_channel ichan) in 47 | Parsing.clear_parser (); 48 | close_in ichan; 49 | if log log_phase then Printf.printf "Parsed %s!\n" fname; 50 | ret 51 | with Parsing.Parse_error -> Printf.printf "Failed to parse %s\n" fname; exit 1 52 | | Failure s -> Printf.printf "Failed to parse %s\n%s\n" fname s; exit 1 53 | 54 | (* 55 | Check if file exists in current directory, or in list of directories supplied. 56 | Returns full filename if found, 57 | If not raises Not_found 58 | *) 59 | let find_file_from_dirs dirs fname = 60 | if Sys.file_exists fname then fname 61 | else 62 | let f x = Filename.concat x fname in 63 | f (List.find (function d -> Sys.file_exists (f d)) dirs) 64 | 65 | let rec fs_postorder m f = 66 | if Sys.file_exists f then begin 67 | if Sys.is_directory f then begin 68 | let children = Array.map (Filename.concat f) (Sys.readdir f) in 69 | Array.iter (fs_postorder m) children 70 | end; 71 | m f 72 | end 73 | 74 | let fs_filter p f = 75 | let r = ref [] in 76 | fs_postorder (fun x -> if p x then r =:: x) f; !r 77 | 78 | let rm_rf f = 79 | fs_postorder 80 | (fun x -> if Sys.is_directory x then Unix.rmdir x else Unix.unlink x) f 81 | 82 | let rec mkdir_p dir = 83 | if Sys.file_exists dir then begin 84 | if not (Sys.is_directory dir) then 85 | raise (Unix.Unix_error (Unix.EEXIST, "mkdir_p", dir)) 86 | end else begin 87 | mkdir_p (Filename.dirname dir); 88 | Unix.mkdir dir 0o755 89 | end 90 | 91 | let is_executable_available fn = 92 | try 93 | let candidate = find_file_from_dirs (getenv_dirlist "PATH") fn in 94 | Unix.access candidate [Unix.X_OK; Unix.R_OK]; 95 | true 96 | with _ -> false 97 | 98 | let is_file ext fn = 99 | Sys.file_exists fn && not (Sys.is_directory fn) && 100 | StringH.ends_with (String.lowercase ext) (String.lowercase fn) 101 | 102 | let set_signal_handlers () = 103 | let old = Sys.signal Sys.sigpipe Sys.Signal_ignore in 104 | assert (old = Sys.Signal_default) 105 | 106 | (* TODO(rgrig): Thee should probably depend on the terminal. *) 107 | (* TODO(rgrig): Is there a (nice) ncurses ocaml inerface? *) 108 | let terminal_red = "\x1B[1;31m" 109 | let terminal_green = "\x1B[1;32m" 110 | let terminal_white = "\x1B[0m" 111 | 112 | -------------------------------------------------------------------------------- /src/utils/system.mli: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/utils/system.mli 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | (** The delimiter used in CLASSPATH, SOURCEPATH, ... by Java. *) 16 | val java_path_delimiter : string 17 | val java_path_delimiter_re : Str.regexp 18 | 19 | (** 20 | [getenv v] returns the value in the system environment of the variable 21 | [v], or the empty string if [v] is not set. 22 | *) 23 | val getenv : string -> string 24 | 25 | (** 26 | [getenv_dirlist v] assumes [v] is a something like PATH and splits its 27 | value (if set) into a list. This function does NOT process trailing '*', 28 | nor does it filter out stuff that is usually ignored by classpaths, see: 29 | http://download.oracle.com/javase/6/docs/technotes/tools/index.html#classpath 30 | Leading, trailing, and repeated delimiters ARE ignored, see 31 | http://bugs.sun.com/bugdatabase/view_bug.do?bug_id=4809833 32 | *) 33 | val getenv_dirlist : string -> string list 34 | 35 | (** [string_of_file f] returns the content of file [f] as a string *) 36 | val string_of_file : string -> string 37 | 38 | (** 39 | [parse_file parser lexer fname ftype] parses [fname] using the given 40 | [parser] and [lexer], prints some standard messages, and returns the 41 | result of the parser. ['a] is the token type, ['b] is the type of the 42 | parsing result. 43 | *) 44 | val parse_file : 45 | ((Lexing.lexbuf->'a) -> Lexing.lexbuf -> 'b) -> 46 | (Lexing.lexbuf->'a) -> 47 | string -> string -> 'b 48 | 49 | (** 50 | [find_file_from_dirs dirs f] tries to find file [f] (possibly a directory) 51 | in the current directory and then in [dirs]. Returns the first location 52 | of [f]. Raises [Not_found] if not found. The behavior is undefined 53 | if [f] is an absolute path. 54 | *) 55 | val find_file_from_dirs : string list -> string -> string 56 | 57 | (** 58 | [fs_postorder m f] runs [m f'] for all files [f'] reachable by descending 59 | directories from [f], and does so in postorder. (For the purposes of this 60 | description directories are files.) 61 | *) 62 | val fs_postorder : (string -> unit) -> string -> unit 63 | 64 | (** 65 | [fs_filter predicate directory] returns a list of paths under [directory] 66 | that satisfy [predicate]. 67 | *) 68 | val fs_filter : (string -> bool) -> string -> string list 69 | 70 | (** [rm_rf f] is the same as the shell command rm -rf f. *) 71 | val rm_rf : string -> unit 72 | 73 | (** [mkdir_p d] is the same as the shell command mkdir -p d. *) 74 | val mkdir_p : string -> unit 75 | 76 | (** 77 | [is_executable_available f] returns whether [f] is in the PATH, not a 78 | directory, and executable. 79 | *) 80 | val is_executable_available : string -> bool 81 | 82 | (** 83 | [is_ext_file ext f] says whether file [f] is a normal file with a name 84 | ending in [ext]. It is case insensitive. 85 | *) 86 | val is_file : string -> string -> bool 87 | 88 | (** Ignores signals that shouldn't stop corestar. *) 89 | val set_signal_handlers : unit -> unit 90 | 91 | val terminal_red : string 92 | val terminal_green : string 93 | val terminal_white : string 94 | -------------------------------------------------------------------------------- /src/utils/vars.ml: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/utils/vars.ml 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | open Format 16 | 17 | type var = 18 | | PVar of int * string 19 | | EVar of int * string 20 | | AnyVar of int * string 21 | 22 | let mk_pvar i s = PVar (i, s) 23 | let mk_evar i s = EVar (i, s) 24 | let mk_anyvar i s = AnyVar (i, s) 25 | 26 | let gensym = ref 0 27 | let fresh mk s = incr gensym; mk !gensym s 28 | let freshp_str = fresh mk_pvar 29 | let freshe_str = fresh mk_evar 30 | let fresha_str = fresh mk_anyvar 31 | let freshp () = freshp_str "v" 32 | let freshe () = freshe_str "v" 33 | let fresha () = fresha_str "v" 34 | 35 | module StrVarHash = 36 | Hashtbl.Make(struct 37 | type t = string 38 | let equal = (=) 39 | let hash = Hashtbl.hash 40 | end) 41 | 42 | let hashcons = StrVarHash.create 1000 43 | 44 | let concrete mk vn = 45 | try StrVarHash.find hashcons vn 46 | with Not_found -> 47 | let r = mk 0 vn in 48 | StrVarHash.add hashcons vn r; 49 | r 50 | 51 | let concretep_str = concrete mk_pvar 52 | let concretee_str = concrete mk_evar 53 | 54 | let freshen = function 55 | | PVar (_,v) -> freshp_str v 56 | | EVar (_,v) -> freshe_str v 57 | | AnyVar (_,v) -> fresha_str v 58 | 59 | let freshen_exists = function 60 | | PVar (_,v) 61 | | AnyVar (_,v) 62 | | EVar (_,v) -> freshe_str v 63 | 64 | 65 | 66 | let pp_var f = 67 | let p = function 0 -> "" | n -> sprintf "_%d" n in 68 | function 69 | | PVar (n,vn) -> fprintf f "%s%s" vn (p n) 70 | | EVar (n,vn) -> fprintf f "_%s%s" vn (p n) 71 | | AnyVar (n,vn) -> fprintf f "a_%s%s" vn (p n) 72 | 73 | let string_var = Debug.string_of pp_var 74 | -------------------------------------------------------------------------------- /src/utils/vars.mli: -------------------------------------------------------------------------------- 1 | (******************************************************** 2 | This file is part of coreStar 3 | src/utils/vars.mli 4 | Release 5 | $Release$ 6 | Version 7 | $Rev$ 8 | $Copyright$ 9 | 10 | coreStar is distributed under a BSD license, see, 11 | LICENSE.txt 12 | ********************************************************) 13 | 14 | 15 | type var = 16 | PVar of int * string 17 | | EVar of int * string 18 | | AnyVar of int * string 19 | val fresh : (int -> 'a -> 'b) -> 'a -> 'b 20 | val freshp_str : string -> var 21 | val freshe_str : string -> var 22 | val fresha_str : string -> var 23 | val freshp : unit -> var 24 | val freshe : unit -> var 25 | val fresha : unit -> var 26 | module StrVarHash : 27 | sig 28 | type key = string 29 | type 'a t 30 | val create : int -> 'a t 31 | val copy : 'a t -> 'a t 32 | val add : 'a t -> key -> 'a -> unit 33 | val remove : 'a t -> key -> unit 34 | val find : 'a t -> key -> 'a 35 | val find_all : 'a t -> key -> 'a list 36 | val mem : 'a t -> key -> bool 37 | val iter : (key -> 'a -> unit) -> 'a t -> unit 38 | val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b 39 | val length : 'a t -> int 40 | end 41 | val concretep_str : StrVarHash.key -> var 42 | val concretee_str : StrVarHash.key -> var 43 | val freshen : var -> var 44 | val freshen_exists : var -> var 45 | val pp_var : Format.formatter -> var -> unit 46 | val string_var : var -> string 47 | -------------------------------------------------------------------------------- /unit_tests/Makefile: -------------------------------------------------------------------------------- 1 | DIRS=$(wildcard *_tests) 2 | DIRS_TEST=$(addsuffix .test,$(DIRS)) 3 | DIRS_CLEAN=$(addsuffix .clean,$(DIRS)) 4 | 5 | SHELL=/bin/bash 6 | 7 | test: $(DIRS_TEST) 8 | clean: $(DIRS_CLEAN) 9 | 10 | $(DIRS_TEST): %.test: 11 | @echo -n "Testing $* " 12 | @$(MAKE) -s -C $* test 13 | @echo 14 | 15 | $(DIRS_CLEAN): %.clean: 16 | $(MAKE) -C $* clean 17 | 18 | .PHONY: test $(DIRS_TEST) clean $(DIRS_CLEAN) 19 | .SILENT: test 20 | -------------------------------------------------------------------------------- /unit_tests/prover_tests/Makefile: -------------------------------------------------------------------------------- 1 | TESTS=$(wildcard *_test) 2 | 3 | SHELL=/bin/bash 4 | 5 | test: $(TESTS) 6 | 7 | $(TESTS): %_test: 8 | @"${CORESTAR_HOME}/bin/test_logic" -f $*_test -l $*_logic > $*.out 2> $*.err || echo -e "\nFailed $* in $(CURDIR) (see $*.out and $*.err)" 9 | 10 | clean: 11 | rm -rf *.out *.err 12 | 13 | .PHONY: test clean $(TESTS) 14 | -------------------------------------------------------------------------------- /unit_tests/prover_tests/abduction_logic: -------------------------------------------------------------------------------- 1 | rule abduct_remove: 2 | | |- field(?x,?f,?t) -| 3 | if 4 | | |- -| field(?x,BAR,?t) 5 | -------------------------------------------------------------------------------- /unit_tests/prover_tests/abs_logic: -------------------------------------------------------------------------------- 1 | rule abs_list : 2 | | ls(?x,_y) * ls(_y,nil()) |- 3 | where 4 | _y notincontext 5 | if 6 | | ls(?x,nil()) |- 7 | -------------------------------------------------------------------------------- /unit_tests/prover_tests/abs_test: -------------------------------------------------------------------------------- 1 | Implication: 2 | ls(x,_y) * ls(_y,nil()) |- ls(x,nil()) 3 | ? True 4 | 5 | Implication: 6 | ls(z,_y) * ls(x,_y) * ls(_y,nil()) |- ls(x,nil()) * ls(z,_y) 7 | ? False 8 | 9 | Implication: 10 | ls(z,_y) * ls(x,_y) * ls(_y,nil()) |- ls(x,nil()) 11 | ? False 12 | 13 | Implication: 14 | _y!=x * ls(x,_y) * ls(_y,nil()) |- ls(x,nil()) 15 | ? True 16 | -------------------------------------------------------------------------------- /unit_tests/prover_tests/bitvect_logic: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/seplogic/corestar/a352b3dada6a399a1dae6546be36e3d8a56f9368/unit_tests/prover_tests/bitvect_logic -------------------------------------------------------------------------------- /unit_tests/prover_tests/bitvect_test: -------------------------------------------------------------------------------- 1 | Implication: 2 | x = bvadd.32 (bv_const("32", "1"), bv_const("32", "2"))|- 3 | x = bv_const("32", "3") 4 | ? True 5 | 6 | -------------------------------------------------------------------------------- /unit_tests/prover_tests/boolean_logic: -------------------------------------------------------------------------------- 1 | /********* 2 | * false and true rules 3 | *********/ 4 | rewrite false: false() = numeric_const("0") 5 | 6 | rewrite zero: zero() = numeric_const("0") 7 | 8 | rewrite true : true() = numeric_const("1") 9 | 10 | 11 | 12 | 13 | /********** 14 | * Injectivity of numeric_const 15 | **********/ 16 | rule numeric_eq_left : 17 | | numeric_const(?x) = numeric_const(?y) | |- | 18 | without 19 | ?x=?y 20 | if 21 | | ?x =?y | |- | 22 | 23 | rule numeric_eq_right : 24 | | | |- numeric_const(?x) = numeric_const(?y) | 25 | if 26 | | | |- ?x=?y| 27 | 28 | rule numeric_neq_left : 29 | | numeric_const(?x) != numeric_const(?y) | |- | 30 | if 31 | | ?x !=?y | |- | 32 | 33 | rule numeric_neq_right : 34 | | | |- numeric_const(?x) != numeric_const(?y) | 35 | if 36 | | | |- ?x!=?y| 37 | 38 | 39 | 40 | /*********************** 41 | * Should build this into the prover. 42 | **********************/ 43 | 44 | rule string_eq_1_0 : 45 | | "1" = "0" | |- | 46 | if 47 | 48 | rule string_eq_1_0 : 49 | | | |- "1" = "0" | 50 | if 51 | | | |- | False 52 | 53 | 54 | rule string_neq_1_0 : 55 | | "1" != "0" | |- | 56 | if 57 | | | |- | 58 | 59 | rule string_neq_1_0 : 60 | | | |- "1" != "0" | 61 | if 62 | | | |- | 63 | 64 | 65 | -------------------------------------------------------------------------------- /unit_tests/prover_tests/builtin_plus_logic: -------------------------------------------------------------------------------- 1 | /****************** 2 | * Some simple properties of addition 3 | ******************/ 4 | 5 | rule builtin_plus_inj_first : 6 | | | |- builtin_plus(?t,?g) = builtin_plus(?t,?h) | 7 | if 8 | | | |- ?g = ?h | 9 | 10 | rule builtin_plus_inj_second : 11 | | | |- builtin_plus(?g,?t) = builtin_plus(?h,?t) | 12 | if 13 | | | |- ?g = ?h | 14 | 15 | 16 | rewrite builtin_plus_assoc : 17 | builtin_plus(builtin_plus(?x,?y),?z) = builtin_plus(?x,builtin_plus(?y,?z)) 18 | 19 | 20 | rule bp : 21 | | | |- builtin_plus(?x,?x) = builtin_plus(?y,?y) | 22 | if 23 | | | |- ?x=?y | 24 | -------------------------------------------------------------------------------- /unit_tests/prover_tests/cons_logic: -------------------------------------------------------------------------------- 1 | constructor c1 2 | constructor c2 -------------------------------------------------------------------------------- /unit_tests/prover_tests/cons_test: -------------------------------------------------------------------------------- 1 | Implication : 2 | x != y |- c1(x) != c1(y) 3 | ? True 4 | 5 | Implication : 6 | c1(x) = c1(y) |- x = y 7 | ? True 8 | 9 | Implication : 10 | |- c1(x) != c2(x) 11 | ? True 12 | 13 | Implication : 14 | |- c1(x) != c3(x) 15 | ? False -------------------------------------------------------------------------------- /unit_tests/prover_tests/eq_logic: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/seplogic/corestar/a352b3dada6a399a1dae6546be36e3d8a56f9368/unit_tests/prover_tests/eq_logic -------------------------------------------------------------------------------- /unit_tests/prover_tests/eq_test: -------------------------------------------------------------------------------- 1 | Implication: 2 | |- "a" = "b" 3 | ? False 4 | 5 | Implication: 6 | "a" = "b" |- "a" = "b" 7 | ? True 8 | 9 | 10 | 11 | Implication: 12 | |- "a" = "a" 13 | ? True 14 | 15 | 16 | Implication: 17 | a != b 18 | * (a=b * c!=d || a!=b * c=d) 19 | * (c=d * x="5" || c!=d * x="6") 20 | |- x="5" 21 | ? True 22 | 23 | 24 | Implication: 25 | a != b 26 | * (c=d * x="5" || c!=d * x="6") 27 | * (a=b * c!=d || a!=b * c=d) 28 | |- x="5" 29 | ? True 30 | 31 | Implication: 32 | a = b 33 | * (a=b * c!=d || a!=b * c=d) 34 | * (c=d * x="5" || c!=d * x="6") 35 | |- x="6" 36 | ? True 37 | 38 | 39 | Implication: 40 | a = b 41 | * (c=d * x="5" || c!=d * x="6") 42 | * (a=b * c!=d || a!=b * c=d) 43 | |- x="6" 44 | ? True -------------------------------------------------------------------------------- /unit_tests/prover_tests/exists_logic: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/seplogic/corestar/a352b3dada6a399a1dae6546be36e3d8a56f9368/unit_tests/prover_tests/exists_logic -------------------------------------------------------------------------------- /unit_tests/prover_tests/exists_test: -------------------------------------------------------------------------------- 1 | Implication: 2 | !p(_a) |- _a = "3" 3 | ? False 4 | 5 | 6 | Implication: 7 | |- _a = "3" 8 | ? True 9 | 10 | -------------------------------------------------------------------------------- /unit_tests/prover_tests/field_basic_logic: -------------------------------------------------------------------------------- 1 | 2 | /************************************* 3 | * Simple subtraction rules 4 | *************************************/ 5 | 6 | /* 7 | If you have a field for the same object 8 | on both sides of an implication, add the 9 | field to the matched fields, and require 10 | that proof obligation that there values 11 | are the same. 12 | 13 | The "without" clause prevents the matching 14 | if we already know the fields have different 15 | values. 16 | */ 17 | /* 18 | rule field_remove1: 19 | | field(?x,?f,?y) |- field(?x,?f,?t) 20 | /*without 21 | ?y!=?t*/ 22 | if 23 | field(?x,?f,?y) | |- ?y=?t 24 | */ 25 | 26 | /************************************* 27 | * rules for contradictions 28 | *************************************/ 29 | 30 | /* 31 | If two fields for the same object with the 32 | same name exists in an assumption, then there 33 | is a contradiction and the proof is complete. 34 | */ 35 | /* 36 | rule field_field_contradiction1 : 37 | field(?x,?f,?y) * field(?x,?f,?z) | |- 38 | if 39 | */ 40 | /* 41 | If we have an assumption of a field for null 42 | then we have a contradiction. 43 | */ 44 | 45 | rule field_nil_contradiction : 46 | field(nil(),?f,?z) | |- 47 | if 48 | 49 | 50 | /* 51 | rule field_not_null : 52 | field(?x,?f,?y) | |- ?x!=nil() 53 | if 54 | | |- 55 | */ 56 | 57 | -------------------------------------------------------------------------------- /unit_tests/prover_tests/field_basic_test: -------------------------------------------------------------------------------- 1 | /* 2 | Implication: 3 | field(nil(),f,x) |- 4 | ? True 5 | 6 | Implication: 7 | |- field(nil(),f2,y) 8 | ? False 9 | 10 | 11 | Implication: 12 | field(nil(),f,x) |- field(nil(),f2,y) 13 | ? True 14 | 15 | 16 | Implication: 17 | field(x,f,x) |- field(nil(),f2,y) 18 | ? False 19 | 20 | Implication: 21 | field(x,f,x) |- field(x,f,y) 22 | ? False 23 | 24 | Implication: 25 | x=y * field(x,f,x) |- field(x,f,y) 26 | ? True 27 | */ 28 | 29 | Implication: 30 | field(x,f,x) * (x=y || x=nil()) |- field(x,f,y) 31 | ? True 32 | -------------------------------------------------------------------------------- /unit_tests/prover_tests/field_logic: -------------------------------------------------------------------------------- 1 | constructor nil 2 | 3 | /************************************* 4 | * Simple subtraction rules 5 | *************************************/ 6 | 7 | /* 8 | If you have a field for the same object 9 | on both sides of an implication, add the 10 | field to the matched fields, and require 11 | that proof obligation that there values 12 | are the same. 13 | 14 | The "without" clause prevents the matching 15 | if we already know the fields have different 16 | values. 17 | */ 18 | rule field_remove1: 19 | | field(?x,?f,?y) |- field(?x,?f,?t) 20 | without 21 | ?y!=?t 22 | if 23 | field(?x,?f,?y) | |- ?y=?t 24 | 25 | 26 | /************************************* 27 | * rules for contradictions 28 | *************************************/ 29 | 30 | /* 31 | If two fields for the same object with the 32 | same name exists in an assumption, then there 33 | is a contradiction and the proof is complete. 34 | */ 35 | rule field_field_contradiction1 : 36 | field(?x,?f,?y) * field(?x,?f,?z) | |- 37 | if 38 | 39 | /* 40 | If we have an assumption of a field for null 41 | then we have a contradiction. 42 | */ 43 | rule field_nil_contradiction : 44 | field(nil(),?f,?z) | |- 45 | if 46 | 47 | /************************************** 48 | * Rules for failed proofs 49 | **************************************/ 50 | /* 51 | /* 52 | If we need to prove that field exists for null 53 | then we are going to fail, unless we can find 54 | a contradiction. 55 | */ 56 | /* 57 | rule field_nil_failed : 58 | | |- field(nil(),?f,?z) 59 | if 60 | | |- field(nil(),?f,?z) * False 61 | */ 62 | 63 | /* 64 | If we need to match to fields which have 65 | distinct values, then we need to search for a 66 | contradiction (False). 67 | */ 68 | rule field_field_no_match : 69 | | ?y!=?t * field(?x,?f,?y) |- field(?x,?f,?t) 70 | if 71 | | ?y!=?t * field(?x,?f,?y) |- field(?x,?f,?t) * False 72 | */ 73 | 74 | 75 | rule field_not_null : 76 | field(?x,?f,?y) | |- ?x!=nil() 77 | if 78 | | |- 79 | 80 | 81 | 82 | rule field_field_not_eq : 83 | field(?x1,?f,?y) * field(?x2,?f,?z) | |- 84 | without 85 | ?x1 != ?x2 |- 86 | if 87 | | ?x1 != ?x2 |- 88 | -------------------------------------------------------------------------------- /unit_tests/prover_tests/field_test: -------------------------------------------------------------------------------- 1 | 2 | Implication: 3 | |- 4 | ? True 5 | 6 | 7 | Implication: 8 | field(nil(),f,x) |- field(nil(),f2,y) 9 | ? True 10 | 11 | Implication: 12 | field(x,f,x) |- field(nil(),f2,y) 13 | ? False 14 | 15 | Implication: 16 | field(x,f,x) |- field(x,f,y) 17 | ? False 18 | 19 | Implication: 20 | x=y * field(x,f,x) |- field(x,f,y) 21 | ? True 22 | 23 | Implication: 24 | field(x,f,x) * (x=y || x=nil()) |- field(x,f,y) 25 | ? True 26 | 27 | /* 28 | Inconsistency: 29 | field(x,f,y) * field(x,f,z) 30 | ? True 31 | 32 | Inconsistency: 33 | field(x,f,y) * field(x,f2,z) 34 | ? False 35 | 36 | Inconsistency: 37 | field(x,f,y) * field(y,f2,z) 38 | ? False 39 | */ 40 | 41 | 42 | Implication: 43 | field(x,f,y) |- x!=nil() * field(x,f,y) 44 | ? True 45 | 46 | Implication: 47 | ( x!=nil() || field(x,f,y)) |- x!=nil() * ( x!=nil() || field(x,f,y)) 48 | ? True 49 | 50 | Implication: 51 | y!=nil() * ( x!=nil() || x=y ) |- x!=nil() 52 | ? True 53 | 54 | Implication: 55 | ( x!=nil() || x=y * field(y,f,j) ) |- x!=nil() 56 | ? False 57 | 58 | 59 | Frame: 60 | field(y,f,j) * field(x,f,j) |- field(x,f,j) 61 | ? field(y,f,j) 62 | 63 | 64 | Frame: 65 | field(y,f,j) * field(x,f,j) * field(z,f,j) |- field(x,f,j) 66 | ? field(y,f,j) * field(z,f,j) 67 | 68 | Frame: 69 | field(y,f,j) * field(x,f,j) * field(z,f,j) |- field(x,f,j) 70 | ? field(z,f,j) * field(y,f,j) 71 | 72 | 73 | 74 | Frame: 75 | field(y,f,j) * field(x,f,j) * (x=y || field(z,f,j)) |- field(x,f,j) 76 | ? field(z,f,j) * field(y,f,j) 77 | 78 | -------------------------------------------------------------------------------- /unit_tests/prover_tests/listdatatype_logic: -------------------------------------------------------------------------------- 1 | /******************************************* 2 | * Definitions for datatype of list 3 | *******************************************/ 4 | 5 | 6 | rewrite cons_hd: 7 | hd(cons(?x,?y)) = ?x 8 | 9 | rewrite cons_tl: 10 | tl(cons(?x,?y)) = ?y 11 | 12 | rewrite app_nil: 13 | app(empty(), ?x) = ?x 14 | 15 | rewrite app_nil2: 16 | app(?x, empty()) = ?x 17 | 18 | 19 | 20 | /***************************** 21 | * Inequalities 22 | *****************************/ 23 | rule cons_nil_neq_right : 24 | | |- cons(?s,?t) != empty() 25 | if 26 | | |- 27 | 28 | rule cons_nil_neq_left : 29 | | cons(?s,?t) != empty() |- 30 | if 31 | | |- 32 | 33 | 34 | 35 | /****************************** 36 | * Contradictions 37 | ******************************/ 38 | rule cons_nil_eq_left : 39 | | cons(?s,?t) = empty() |- 40 | if 41 | 42 | 43 | rule cons_nil_eq_right : 44 | | |- cons(?s,?t) = empty() 45 | if 46 | | |- False 47 | 48 | 49 | 50 | /******************************* 51 | * Injective axioms 52 | *******************************/ 53 | rule cons_inj_right : 54 | | |- cons(?s,?g) = cons(?t,?h) 55 | if 56 | | |- ?g = ?h * ?s = ?t 57 | 58 | rule cons_inj_left : 59 | | cons(?s,?g) = cons(?t,?h) |- 60 | without 61 | ?g = ?h 62 | if 63 | | ?g = ?h * ?s = ?t |- 64 | 65 | rule cons_inj_left : 66 | | cons(?s,?g) = cons(?t,?h) |- 67 | without 68 | ?s = ?t 69 | if 70 | | ?g = ?h * ?s = ?t |- 71 | 72 | rule nil_inj_right : 73 | | |- empty() 74 | if 75 | | |- ?s=?t 76 | 77 | rule nil_inj_left : 78 | | empty() |- 79 | if 80 | | ?s=?t |- 81 | 82 | 83 | /******************************* 84 | * Injective axioms for neq 85 | *******************************/ 86 | 87 | rule nil_inj_neq_right : 88 | | |- empty() 89 | if 90 | | |- ?s!=?t 91 | 92 | rule nil_inj_neq_left : 93 | | empty() |- 94 | if 95 | | ?s!=?t |- 96 | 97 | rule cons_inj_neq_right : 98 | | |- cons(?s,?g) != cons(?t,?h) 99 | if 100 | | |- (?g != ?h || ?s != ?t ) 101 | 102 | rule cons_inj_neq_left : 103 | | cons(?s,?g) != cons(?t,?h) |- 104 | if 105 | | (?g != ?h || ?s != ?t ) |- 106 | 107 | 108 | rewrite len_cons * : 109 | len(cons(?x,?y)) = builtin_plus(numeric_const("1"), len(?y)) 110 | 111 | rewrite len_empty : 112 | len(empty()) = numeric_const("0") 113 | 114 | 115 | 116 | /*********************************** 117 | * Rules for simplifying app 118 | ***********************************/ 119 | 120 | rule app_is_emp_left : 121 | | app(?x,?y) = empty() |- 122 | without 123 | ?x = empty() 124 | if 125 | | ?x = empty() * ?y = empty() |- 126 | 127 | rule app_is_emp_right : 128 | | |- app(?x,?y) = empty() 129 | if 130 | | |- ?x = empty() * ?y = empty() 131 | 132 | rule app_neq_emp_left : 133 | | app(?x,?y) != empty() |- 134 | if 135 | | (?x != empty() || ?y != empty() ) |- 136 | 137 | 138 | rule app_neq_emp_right : 139 | | |- app(?x,?y) != empty() 140 | if 141 | | |- (?x != empty() || ?y != empty() ) 142 | -------------------------------------------------------------------------------- /unit_tests/prover_tests/listdatatype_test: -------------------------------------------------------------------------------- 1 | /* 2 | Implication: 3 | hd(tl(cons(a,cons(x,empty())))) = a | |- hd(app(empty(),cons(x,y))) = a | 4 | ? True 5 | 6 | Implication: 7 | cons(a,x) = x | |- tl(tl(x)) = x | 8 | ? True 9 | 10 | Implication: 11 | app(x,y) = empty() | |- x=empty() | 12 | ? True 13 | */ 14 | 15 | 16 | 17 | Implication: 18 | |- len(empty()) = numeric_const("0") 19 | ? True 20 | 21 | /* 22 | Implication: 23 | |- len(cons(_x,empty())) = builtin_plus(numeric_const("1"),numeric_const("0")) 24 | ? True 25 | 26 | Implication: 27 | |- len(cons(_x,empty())) = builtin_plus(numeric_const("1"),numeric_const("0")) * _x = "a" 28 | ? True 29 | */ 30 | /* 31 | Implication: 32 | | |- len(cons(_x,empty())) = builtin_plus(numeric_const("1"),numeric_const("0")) | 33 | ? True 34 | 35 | Implication: 36 | | |- len(cons(_x,empty())) = builtin_plus(numeric_const("1"),numeric_const("0")) * _x = "a" * _x ="b" | 37 | ? False 38 | 39 | 40 | Implication: 41 | builtin_plus(numeric_const("1"),numeric_const("0")) = x | |- len(cons(_x,empty())) = builtin_plus(numeric_const("1"),numeric_const("0")) * _x = "a" | 42 | ? True 43 | 44 | Implication: 45 | builtin_plus(numeric_const("1"),numeric_const("0")) = x | |- len(cons(_x,empty())) = builtin_plus(numeric_const("1"),numeric_const("0")) * _x = "a" * _x = "b" | 46 | ? False 47 | 48 | Implication: 49 | builtin_plus(numeric_const("1"),numeric_const("0")) = x | |- hd(cons(_x,empty())) = builtin_plus(numeric_const("1"),numeric_const("0")) | 50 | ? True 51 | 52 | Implication: 53 | builtin_plus(numeric_const("1"),numeric_const("0")) = x | |- hd(cons(_x,empty())) = builtin_plus(numeric_const("1"),numeric_const("0")) * _x = "b" | 54 | ? False 55 | */ -------------------------------------------------------------------------------- /unit_tests/prover_tests/plain_logic: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/seplogic/corestar/a352b3dada6a399a1dae6546be36e3d8a56f9368/unit_tests/prover_tests/plain_logic -------------------------------------------------------------------------------- /unit_tests/prover_tests/plain_test: -------------------------------------------------------------------------------- 1 | 2 | Implication: 3 | |- !p(a) 4 | ? False 5 | 6 | 7 | Implication: 8 | !p(a) |- !p(a) 9 | ? True 10 | 11 | Implication: 12 | !p(a) |- !p(b) * b=a 13 | ? False 14 | 15 | Implication: 16 | a=b * !p(a) |- !p(b) * b=a 17 | ? True 18 | 19 | Implication: 20 | a=b * (!p(a) || !p(a)) |- !p(a) 21 | ? True 22 | 23 | Implication: 24 | a=b * (!p(a) || !p(b)) |- !p(a) 25 | ? True 26 | 27 | Implication: 28 | !p(a) * !p(a) * !p(a) |- !p(a) 29 | ? True 30 | 31 | Implication: 32 | !p(a) * !p(a) |- !p(a) * !p(a) 33 | ? True 34 | 35 | Implication: 36 | !p(a) |- !p(a) * !p(a) * !p(a) 37 | ? True -------------------------------------------------------------------------------- /unit_tests/prover_tests/rewrites_logic: -------------------------------------------------------------------------------- 1 | rewrite foo : 2 | f(?x) = "1" 3 | 4 | 5 | rewrite baa1 : 6 | h(?x) = g(?x) 7 | 8 | rewrite baa2 : 9 | g(?x) = h(?x) 10 | 11 | 12 | rewrite foo2: 13 | y(?x) = y(y(?x)) 14 | 15 | 16 | rewrite cons_hd: 17 | hd(cons(?x,?y)) = ?x 18 | 19 | rewrite cons_tl: 20 | tl(cons(?x,?y)) = ?y 21 | 22 | rewrite app_nil: 23 | app(nil(), ?x) = ?x 24 | 25 | rewrite app_nil2: 26 | app(?x, nil()) = ?x 27 | -------------------------------------------------------------------------------- /unit_tests/prover_tests/rewrites_test: -------------------------------------------------------------------------------- 1 | Implication: 2 | |- f("1") = "1" 3 | ? True 4 | 5 | Implication: 6 | |- f("1") = f("2") 7 | ? True 8 | 9 | Implication: 10 | |- f("1") = f("2") * f("3") = f("4") * f("8") = f("7") * f("6") = f("5") 11 | ? True 12 | 13 | Implication: 14 | f("5") = "2" |- 15 | ? True 16 | 17 | Implication: 18 | g("5") = x * h("3") = x |- g("3") = h("5") 19 | ? True 20 | 21 | Implication: 22 | |- y("1") = y("2") 23 | ? False 24 | 25 | /* broken! 26 | Implication: 27 | hd(tl(cons(a,cons(x,nil())))) = a |- hd(app(nil(),cons(x,y))) = a 28 | ? True 29 | */ 30 | 31 | Implication: 32 | cons(a,x) = x |- tl(tl(x)) = x 33 | ? True 34 | 35 | 36 | 37 | /* 38 | Implication: 39 | |- app(_x,nil()) = y 40 | ? True 41 | */ 42 | 43 | Implication: 44 | |- _x = y 45 | ? True 46 | -------------------------------------------------------------------------------- /unit_tests/prover_tests/rz_plus4_logic: -------------------------------------------------------------------------------- 1 | rewrite rz_plus4: 2 | rz2(plus(?y,?z)) = plus(?y,?z) 3 | if 4 | ?y != numeric_const("0") 5 | * ?z != numeric_const("0") 6 | -------------------------------------------------------------------------------- /unit_tests/prover_tests/rz_plus4_test: -------------------------------------------------------------------------------- 1 | Implication: 2 | x!=numeric_const("0") * y != numeric_const("0") |- plus(x,y) = rz2(plus(x,y)) 3 | ? True -------------------------------------------------------------------------------- /unit_tests/prover_tests/smt_logic: -------------------------------------------------------------------------------- 1 | rule vapourise_RT: 2 | | |- testpred(?x,?y) 3 | where 4 | !LT(?x,?y) pureguard; 5 | !LT(?x,?y) pureguard; 6 | !LT(?x,?y) pureguard; 7 | !LT(?x,?y) pureguard; 8 | !LT(?x,?y) pureguard; 9 | !LT(?x,?y) pureguard; 10 | !LT(?x,?y) pureguard; 11 | !LT(?x,?y) pureguard; 12 | !LT(?x,?y) pureguard; 13 | !LT(?x,?y) pureguard 14 | if 15 | | |- 16 | 17 | -------------------------------------------------------------------------------- /unit_tests/prover_tests/smt_test: -------------------------------------------------------------------------------- 1 | Implication: 2 | (a + b) != (b + a) |- !p(d) 3 | ? True 4 | 5 | Implication: 6 | (a + b) = (c + a) |- b = c 7 | ? True 8 | 9 | Implication: 10 | (a < b) * (b < a) |- False 11 | ? True 12 | 13 | Implication: 14 | |- (a + b) = (b + a) 15 | ? True 16 | 17 | Implication: 18 | (a < b) * (b < c) |- (a < c) 19 | ? True 20 | 21 | Implication: 22 | |- builtin_mult(b,a) = builtin_mult(a, b) 23 | ? True 24 | 25 | Implication: 26 | |- (x + builtin_mult(k,x)) = builtin_mult((k + "1"), x) 27 | ? True 28 | 29 | Implication: 30 | |- ((x + x) + builtin_mult(k,x)) = builtin_mult((k + "2"), x) 31 | ? True 32 | 33 | Implication: 34 | i=(_i_7138+"1") |- i=(_i_3524+"1") 35 | ? True 36 | 37 | Implication: 38 | (_i_3524+"1")=_i_8098 * ("0"+"1")=_i_3524 * @parameter0:=M * 39 | i=(_i_8098+"1") * !LE(i, M) * !LE("0", M) * !LE("0", M) * !LT("0", M) 40 | |- i=_i_8098 * !LE(_i_3524, M) * !LT(_i_3524, M) 41 | ? False 42 | 43 | Implication: 44 | !LT(a,b) |- testpred(a,b) 45 | ? True 46 | -------------------------------------------------------------------------------- /unit_tests/prover_tests/spat2_logic: -------------------------------------------------------------------------------- 1 | rule empty_left: 2 | | empty() |- 3 | if 4 | | |- 5 | 6 | rule empty_right: 7 | | |- empty() 8 | if 9 | | |- -------------------------------------------------------------------------------- /unit_tests/prover_tests/spat2_test: -------------------------------------------------------------------------------- 1 | 2 | Implication: 3 | empty() |- 4 | ? True 5 | 6 | Implication: 7 | |- empty() 8 | ? True 9 | 10 | 11 | 12 | -------------------------------------------------------------------------------- /unit_tests/prover_tests/spat_logic: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/seplogic/corestar/a352b3dada6a399a1dae6546be36e3d8a56f9368/unit_tests/prover_tests/spat_logic -------------------------------------------------------------------------------- /unit_tests/prover_tests/spat_test: -------------------------------------------------------------------------------- 1 | 2 | Implication: 3 | |- p(a) 4 | ? False 5 | 6 | 7 | Implication: 8 | p(a) |- p(a) 9 | ? True 10 | 11 | Implication: 12 | p(a) |- p(b) * b=a 13 | ? False 14 | 15 | Implication: 16 | a=b * p(a) |- p(b) * b=a 17 | ? True 18 | 19 | Implication: 20 | a=b * (p(a) || p(a)) |- p(a) 21 | ? True 22 | 23 | Implication: 24 | a=b * (p(a) || p(b)) |- p(a) 25 | ? True 26 | 27 | Implication: 28 | p(a) * p(a) * p(a) |- p(a) 29 | ? False 30 | 31 | Implication: 32 | p(a) * p(a) |- p(a) * p(a) 33 | ? True 34 | 35 | Implication: 36 | p(a) |- p(a) * p(a) * p(a) 37 | ? False 38 | 39 | Implication: 40 | p(a,c) * p(b,c) |- p(b,c) 41 | ? False 42 | 43 | Implication: 44 | p(b,c) * p(a,c) |- p(b,c) 45 | ? False 46 | 47 | Implication: 48 | (x=y || y=z) * p(b,c) |- p(b,c) 49 | ? True 50 | 51 | Implication: 52 | (x=y || y=z) * p(a,c) * p(b,c) |- p(b,c) 53 | ? False 54 | 55 | -------------------------------------------------------------------------------- /unit_tests/prover_tests/weird_logic: -------------------------------------------------------------------------------- 1 | rule toto: 2 | | |- f(?x,?y) = numeric_const("1") 3 | without |- ?x = ?y 4 | if 5 | | |- ?x = ?y 6 | 7 | -------------------------------------------------------------------------------- /unit_tests/prover_tests/weird_test: -------------------------------------------------------------------------------- 1 | Implication: 2 | f(x,y) = numeric_const("1") |- 3 | ? True 4 | 5 | -------------------------------------------------------------------------------- /unit_tests/prover_tests/where_logic: -------------------------------------------------------------------------------- 1 | 2 | rule vapourise_P: 3 | | P(_x) |- 4 | where 5 | _x notincontext 6 | if 7 | | |- 8 | 9 | 10 | rule vapourise_QP: 11 | | P(_x) * Q(_x) |- 12 | where 13 | _x notincontext 14 | if 15 | | |- 16 | 17 | 18 | rule vapourise_R: 19 | | R(?x,_x) |- 20 | where 21 | _x notincontext 22 | if 23 | | |- 24 | 25 | rule vapourise_RQ: 26 | | R(?x,_x) * Q(_x) |- 27 | where 28 | _x notincontext 29 | if 30 | | |- 31 | 32 | rule vapourise_RR: 33 | | R(?x,_x) * R(_x,?y) |- 34 | where 35 | _x notincontext 36 | if 37 | | |- 38 | 39 | rule vapourise_RT: 40 | | R(?x,_x) * T(_x,nil()) |- 41 | where 42 | _x notincontext 43 | if 44 | | |- 45 | 46 | 47 | abstraction pto_pto: 48 | NodeLL(?x,_x) * NodeLL(_x,nil()) ~~> ls(?x,nil()) 49 | where 50 | _x notincontext; 51 | _x notin ?x 52 | 53 | 54 | -------------------------------------------------------------------------------- /unit_tests/prover_tests/where_test: -------------------------------------------------------------------------------- 1 | Implication: 2 | R(x,_x) |- 3 | ? True 4 | 5 | 6 | Implication: 7 | R(x,_x) * Q(_x) |- 8 | ? True 9 | 10 | Implication: 11 | R(x,_x) * R(_x,y) |- 12 | ? True 13 | 14 | Implication: 15 | R(x,_x) * T(_x,y) |- 16 | ? False 17 | 18 | Implication: 19 | R(x,_x) * T(_x,nil()) |- 20 | ? True 21 | 22 | 23 | Implication: 24 | P(_x) |- 25 | ? True 26 | 27 | Implication: 28 | P(_y) * P(_y) |- 29 | ? False 30 | 31 | Implication: 32 | P(_x) * P(_y) |- 33 | ? True 34 | 35 | Implication: 36 | P(_x) * P(_y) |- _x = _y 37 | ? False 38 | 39 | Implication: 40 | P(_x) |- _x = _y 41 | ? True 42 | 43 | Implication: 44 | _x = y * P(_x) |- 45 | ? False 46 | 47 | Implication: 48 | Q(_x) * P(_x) |- 49 | ? True 50 | 51 | Implication: 52 | Q(_x) * P(_x) |- 53 | ? True 54 | 55 | Implication: 56 | $r3=$r3 * r1=$r2 * r1=r1 * nil()=nil() * nil()=nil() 57 | * ""="" 58 | * ""="" * "NodeLL"="NodeLL" 59 | * r0=@this: * r0=r0 * "1"="1" * true()=numeric_const("1") * true()=true() 60 | * zero()=numeric_const("0") * zero()=false() * zero()=zero() * "0"="0" 61 | * ""="" 62 | * ""="" 63 | * NodeLL(_$r3_3040, nil()) * NodeLL($r3, _$r3_3040) * NodeLL(r1, $r3) 64 | |- NodeLL(r1,$r3) * ls($r3,nil()) 65 | ? True 66 | 67 | 68 | Implication: 69 | NodeLL(_$r3_3040, nil()) * NodeLL($r3, _$r3_3040) * NodeLL(r1, $r3) 70 | |- NodeLL(r1,$r3) * ls($r3,nil()) 71 | ? True 72 | 73 | 74 | Implication: 75 | NodeLL(_r33040, nil()) * NodeLL($r3, _r33040) 76 | |- ls($r3,nil()) 77 | ? True 78 | 79 | Implication: 80 | NodeLL(_y, nil()) * NodeLL($r3, _y) 81 | |- ls($r3,nil()) 82 | ? True 83 | 84 | Implication: 85 | NodeLL(_x, nil()) * NodeLL($r3, _x) 86 | |- ls($r3,nil()) 87 | ? True 88 | 89 | 90 | 91 | 92 | 93 | -------------------------------------------------------------------------------- /unit_tests/symb_tests/Makefile: -------------------------------------------------------------------------------- 1 | TESTS=$(wildcard *_test) 2 | 3 | SHELL=/bin/bash 4 | 5 | test: $(TESTS) 6 | 7 | $(TESTS): %_test: 8 | @"${CORESTAR_HOME}/bin/test_symb" -f $*_test -l $*_logic -a $*_abs > $*.out 2> $*.err || echo -e "\nFailed $* in $(CURDIR) (see $*.out and $*.err)" 9 | 10 | clean: 11 | rm -f *.dot *proof_file*txt *.err *.out 12 | 13 | .PHONY: test clean $(TESTS) 14 | -------------------------------------------------------------------------------- /unit_tests/symb_tests/test.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | for file in `ls *_test | sed "s/_test//"` 4 | do 5 | ( ulimit -t 5; "$CORESTAR_HOME/bin/test_symb" -f $file\_test -l $file\_logic -a $file\_abs ) 6 | done 7 | -------------------------------------------------------------------------------- /unit_tests/symb_tests/trivial_abs: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/seplogic/corestar/a352b3dada6a399a1dae6546be36e3d8a56f9368/unit_tests/symb_tests/trivial_abs -------------------------------------------------------------------------------- /unit_tests/symb_tests/trivial_logic: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/seplogic/corestar/a352b3dada6a399a1dae6546be36e3d8a56f9368/unit_tests/symb_tests/trivial_logic -------------------------------------------------------------------------------- /unit_tests/symb_tests/trivial_test: -------------------------------------------------------------------------------- 1 | SpecTest trivial1: 2 | {Garbage()}{Garbage()} ? True 3 | end; 4 | 5 | SpecTest trivial2: 6 | {"0"="1"}{Garbage()} ? False 7 | end; 8 | 9 | SpecTest trivial3: 10 | {Garbage()}{} ? False 11 | end; 12 | 13 | SpecTest trivial4: 14 | {Garbage()}{Garbage()} ? True 15 | assign x := {False}{}(); 16 | end; 17 | -------------------------------------------------------------------------------- /unit_tests/symb_tests/weird_abs: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/seplogic/corestar/a352b3dada6a399a1dae6546be36e3d8a56f9368/unit_tests/symb_tests/weird_abs -------------------------------------------------------------------------------- /unit_tests/symb_tests/weird_logic: -------------------------------------------------------------------------------- 1 | rule toto: 2 | | |- f(?x,?y) = numeric_const("1") 3 | without |- ?x = ?y 4 | if 5 | | |- ?x = ?y 6 | 7 | -------------------------------------------------------------------------------- /unit_tests/symb_tests/weird_test: -------------------------------------------------------------------------------- 1 | SpecTest trivial3: 2 | {f(x,y) = numeric_const("1")}{} ? True 3 | end; 4 | 5 | --------------------------------------------------------------------------------