├── tests ├── not.sh ├── command-not-found.cls ├── hello2.sh ├── not-exit-previous-false.sh ├── var-in-subshell.sh ├── function-not-found.cls ├── not.cls ├── false-for.sh ├── rm.sh ├── false-while.sh ├── for-false.sh ├── if-false-true.sh ├── no-output.sh ├── for-empty.sh ├── variables.sh ├── for.sh ├── if-false-true.cls ├── not-exit-previous-false.cls ├── pipe-var.sh ├── which.sh ├── args.sh ├── command-not-found.oracle ├── hello2.cls ├── runner │ ├── run_tests.ml │ ├── dune │ ├── common.ml │ ├── options.ml │ ├── metaFile.ml │ └── engine.ml ├── false-while.cls ├── stdout.sh ├── false-for.cls ├── grep-none.cls ├── for-empty.cls ├── for-false.cls ├── strings.sh ├── symbolic │ ├── while.sh │ ├── pipe.sh │ ├── error-failure.sh │ ├── partial-failure.sh │ ├── assign.sh │ ├── utility.sh │ ├── not.sh │ ├── failure.sh │ ├── foreach.sh │ └── subshell.sh ├── var-in-subshell.cls ├── str-subshell.sh ├── string-lists.sh ├── no-output.cls ├── variables.cls ├── fatal-in-function-call.cls ├── for-false.meta ├── for.cls ├── grep-none.meta ├── false-for.meta ├── false-while.meta ├── for-empty.meta ├── if-false-true.meta ├── pipe-ignore-first-behaviour.sh ├── dune ├── function-not-exit.meta ├── function-not-found.meta ├── update_alternatives.meta ├── fatal-in-function-call.meta ├── not-exit-previous-false.meta ├── function-intertwined.sh ├── function-not-exit.sh ├── no-output.meta ├── not.meta ├── function-not-return.sh ├── strings.cls ├── hello2.meta ├── var-in-subshell.meta ├── function-not-return.meta ├── if.meta ├── rm.meta ├── string-lists.cls ├── which.meta ├── pipe-ignore-first-behaviour.meta ├── pipe-var.cls ├── pipe-var.meta ├── pipe.sh ├── fatal-deep-under-if.meta ├── for.meta ├── variables.meta ├── command-not-found.meta ├── stdout.meta ├── test_empty.sh ├── case.meta ├── if.sh ├── which_combinatoric_explosion.meta ├── args.cls ├── args.meta ├── string-lists.meta ├── function-not-exit.cls ├── fatal-deep-under-if.cls ├── which_combinatoric_explosion.sh ├── function-not-return.cls ├── pipe.meta ├── str-subshell.meta ├── export.meta ├── strings.meta ├── if.cls ├── test_x.sh ├── pipe-ignore-first-behaviour.cls ├── stdout.cls ├── test_e.sh ├── case.sh ├── test_empty.meta ├── test_e.meta ├── export.sh ├── function-intertwined.meta ├── pipe.cls ├── shift.meta ├── test_d.meta ├── test_d.sh ├── test_f.meta ├── test_f.sh ├── test_connectives2.sh ├── function.sh ├── test_x.meta ├── test_connectives2.meta ├── test_n_z.sh ├── function.meta ├── shift.cls ├── function.cls ├── test_string_eq.sh ├── export.cls ├── test_n_z.meta ├── test_connectives.sh ├── case.cls ├── test_connectives.meta ├── test_string_eq.meta └── update_alternatives.sh ├── src ├── constraints │ ├── dune │ └── model │ │ ├── cmd.dat │ │ ├── doc │ │ ├── README.md │ │ ├── conclusion.tex │ │ ├── spec-POSIX.tex │ │ ├── synthesis.tex │ │ ├── Makefile │ │ ├── testing.tex │ │ ├── logic-FTL.tex │ │ ├── xperiments.tex │ │ ├── introduction.tex │ │ ├── abstract.tex │ │ ├── main.tex │ │ ├── packages.tex │ │ ├── constraints.tex │ │ ├── preliminaries.tex │ │ └── colis.bib │ │ ├── BUGS.md │ │ ├── dune │ │ ├── test │ │ ├── cmd.dat │ │ ├── Test_cmd.py │ │ └── sample_report.dat │ │ ├── CHANGES.md │ │ ├── mutate.ml │ │ ├── common.mli │ │ ├── README.md │ │ ├── convert.ml │ │ ├── common.ml │ │ ├── inode.ml │ │ ├── print.ml │ │ ├── engine.ml │ │ ├── file_system.ml │ │ └── phases.ml ├── language │ ├── dune │ ├── toColis.mli │ ├── driver.drv │ ├── embellisher.ml │ ├── syntaxHelpers.ml │ ├── colisLexer.mll │ ├── colisParser.mly │ ├── toColis.ml │ └── syntax.mlw ├── concrete │ ├── semantics │ │ └── why3shapes.gz │ ├── auxiliaries │ │ ├── why3shapes.gz │ │ └── why3session.xml │ ├── interpreter │ │ └── why3shapes.gz │ ├── pathnames.mli │ ├── env.mli │ ├── env.ml │ ├── pathnames.ml │ ├── driver.drv │ ├── auxiliaries.mlw │ └── utilities.ml ├── symbolic │ ├── collection │ │ ├── why3shapes.gz │ │ └── why3session.xml │ ├── symbolicInterpreter │ │ └── why3shapes.gz │ ├── utilities │ │ ├── rm.mli │ │ ├── touch.mli │ │ ├── updateMenus.mli │ │ ├── mkdir.mli │ │ ├── cp.mli │ │ ├── mv.mli │ │ ├── dpkgMaintscriptHelper.mli │ │ ├── updateMenus.ml │ │ ├── test.mli │ │ ├── which.mli │ │ ├── emacsPackage.mli │ │ ├── updateAlternatives.ml │ │ ├── basics.ml │ │ ├── colisInternalUnsafeTouch.ml │ │ ├── dpkg.ml │ │ ├── emacsPackage.ml │ │ ├── README.md │ │ ├── touch.ml │ │ ├── mkdir.ml │ │ ├── rm.ml │ │ └── which.ml │ ├── driver.drv │ ├── filesystemSpec.mli │ ├── collection.mlw │ └── filesystemSpec.ml ├── internals │ ├── dune │ ├── errors.ml │ ├── extList.ml │ ├── colis_internals.ml │ └── options.ml ├── dune └── colis.mli ├── dune-project ├── simple.fs ├── .gitignore ├── .travis.yml ├── examples └── loop-symbolic ├── Makefile ├── colis-language.opam ├── README.md ├── Dockerfile └── NOTES.org /tests/not.sh: -------------------------------------------------------------------------------- 1 | ! false 2 | echo here 3 | -------------------------------------------------------------------------------- /src/constraints/dune: -------------------------------------------------------------------------------- 1 | (include_subdirs no) 2 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.1) 2 | (using menhir 1.0) 3 | -------------------------------------------------------------------------------- /tests/command-not-found.cls: -------------------------------------------------------------------------------- 1 | begin 2 | foo 3 | end 4 | -------------------------------------------------------------------------------- /tests/hello2.sh: -------------------------------------------------------------------------------- 1 | x=lo 2 | x=hel$x' world' 3 | echo $x 4 | -------------------------------------------------------------------------------- /tests/not-exit-previous-false.sh: -------------------------------------------------------------------------------- 1 | ! { false; exit $?; } 2 | -------------------------------------------------------------------------------- /tests/var-in-subshell.sh: -------------------------------------------------------------------------------- 1 | x=A 2 | ( x=B ) 3 | echo $x 4 | -------------------------------------------------------------------------------- /src/constraints/model/cmd.dat: -------------------------------------------------------------------------------- 1 | test -e stty/gunzip/touch 2 | -------------------------------------------------------------------------------- /tests/function-not-found.cls: -------------------------------------------------------------------------------- 1 | begin 2 | call f 3 | end 4 | -------------------------------------------------------------------------------- /tests/not.cls: -------------------------------------------------------------------------------- 1 | begin 2 | not false; 3 | echo ['here'] 4 | end 5 | -------------------------------------------------------------------------------- /tests/false-for.sh: -------------------------------------------------------------------------------- 1 | ! true 2 | for x in; do false; done 3 | exit $? 4 | -------------------------------------------------------------------------------- /tests/rm.sh: -------------------------------------------------------------------------------- 1 | 2 | rm '/bin/sh' 3 | 4 | rm '/bin/colis' 5 | 6 | rm 7 | -------------------------------------------------------------------------------- /tests/false-while.sh: -------------------------------------------------------------------------------- 1 | ! true 2 | while false; do false; done 3 | exit $? 4 | -------------------------------------------------------------------------------- /tests/for-false.sh: -------------------------------------------------------------------------------- 1 | for x in 'x'; do 2 | ! true 3 | done 4 | exit $? 5 | -------------------------------------------------------------------------------- /tests/if-false-true.sh: -------------------------------------------------------------------------------- 1 | if false; then 2 | exit 1 3 | fi 4 | exit $? 5 | -------------------------------------------------------------------------------- /tests/no-output.sh: -------------------------------------------------------------------------------- 1 | x=A 2 | { x='B'; echo ignore; } >/dev/null 3 | echo $x 4 | -------------------------------------------------------------------------------- /tests/for-empty.sh: -------------------------------------------------------------------------------- 1 | ! true 2 | for x in ; do 3 | true 4 | done 5 | exit $? 6 | -------------------------------------------------------------------------------- /tests/variables.sh: -------------------------------------------------------------------------------- 1 | echo 'x='$x 2 | x=A 3 | echo 'x='$x 4 | x=B 5 | echo 'x='$x 6 | -------------------------------------------------------------------------------- /tests/for.sh: -------------------------------------------------------------------------------- 1 | x=a 2 | echo $x 3 | for x in b c; do 4 | echo $x 5 | done 6 | echo $x 7 | -------------------------------------------------------------------------------- /tests/if-false-true.cls: -------------------------------------------------------------------------------- 1 | begin 2 | if false then exit failure fi; 3 | exit previous 4 | end -------------------------------------------------------------------------------- /tests/not-exit-previous-false.cls: -------------------------------------------------------------------------------- 1 | begin 2 | not begin false; exit previous end 3 | end 4 | -------------------------------------------------------------------------------- /tests/pipe-var.sh: -------------------------------------------------------------------------------- 1 | x=A 2 | x=${x}B | { echo "X1: ${x}"; x=${x}C; } 3 | echo "X2: ${x}" 4 | -------------------------------------------------------------------------------- /tests/which.sh: -------------------------------------------------------------------------------- 1 | 2 | which '/bin/sh' 3 | 4 | which 'bin/colis' 5 | 6 | which 'ocaml' 7 | -------------------------------------------------------------------------------- /src/language/dune: -------------------------------------------------------------------------------- 1 | (ocamllex colisLexer) 2 | (menhir (flags --explain) (modules colisParser)) 3 | -------------------------------------------------------------------------------- /tests/args.sh: -------------------------------------------------------------------------------- 1 | f () { 2 | echo 1: $1 3 | echo 2: $2 4 | echo 3: $3 5 | } 6 | 7 | f "$@" 8 | -------------------------------------------------------------------------------- /tests/command-not-found.oracle: -------------------------------------------------------------------------------- 1 | RESULT: false 2 | STDOUT: 3 | > foo: command not found 4 | > 5 | -------------------------------------------------------------------------------- /tests/hello2.cls: -------------------------------------------------------------------------------- 1 | begin 2 | x := 'lo'; 3 | x := 'hel' x ' world'; 4 | echo [x] 5 | end 6 | -------------------------------------------------------------------------------- /tests/runner/run_tests.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Options.parse_cmd_line (); 3 | Engine.run_tests () 4 | -------------------------------------------------------------------------------- /src/language/toColis.mli: -------------------------------------------------------------------------------- 1 | 2 | 3 | val program : Format.formatter -> Syntax__Syntax.program -> unit 4 | -------------------------------------------------------------------------------- /tests/false-while.cls: -------------------------------------------------------------------------------- 1 | begin 2 | not true; 3 | while false do false done; 4 | exit previous 5 | end 6 | -------------------------------------------------------------------------------- /tests/stdout.sh: -------------------------------------------------------------------------------- 1 | ( echo A 2 | echo B 3 | echo -n C ) 4 | ( echo D 5 | echo -n E 6 | echo F ) 7 | -------------------------------------------------------------------------------- /tests/false-for.cls: -------------------------------------------------------------------------------- 1 | begin 2 | not true; 3 | for x in [] do false done; 4 | exit previous 5 | end 6 | -------------------------------------------------------------------------------- /tests/grep-none.cls: -------------------------------------------------------------------------------- 1 | begin 2 | pipe 3 | true 4 | into 5 | grep ['X'] 6 | endpipe 7 | end 8 | -------------------------------------------------------------------------------- /tests/for-empty.cls: -------------------------------------------------------------------------------- 1 | begin 2 | not true; 3 | for x in [] do 4 | true 5 | done; 6 | exit previous 7 | end 8 | -------------------------------------------------------------------------------- /tests/for-false.cls: -------------------------------------------------------------------------------- 1 | begin 2 | for x in ['x'] do 3 | not true 4 | done; 5 | exit previous 6 | end 7 | -------------------------------------------------------------------------------- /tests/strings.sh: -------------------------------------------------------------------------------- 1 | echo 'hello colis' 2 | echo 'hello''colis' 3 | echo 'hello' 'colis' 4 | echo 'hello' 'colis' 5 | -------------------------------------------------------------------------------- /tests/symbolic/while.sh: -------------------------------------------------------------------------------- 1 | p=/ 2 | while test "$p" != "/x/x/x/x/x" ; do 3 | p=$p/x 4 | mkdir $p 5 | done 6 | -------------------------------------------------------------------------------- /tests/var-in-subshell.cls: -------------------------------------------------------------------------------- 1 | begin 2 | x := 'A'; 3 | process x := 'B' endprocess; 4 | echo [x] 5 | end 6 | -------------------------------------------------------------------------------- /tests/str-subshell.sh: -------------------------------------------------------------------------------- 1 | x=$(echo; echo; echo a; echo; echo; echo b; echo; echo) 2 | echo X${x}X 3 | echo "X${x}X" 4 | -------------------------------------------------------------------------------- /tests/string-lists.sh: -------------------------------------------------------------------------------- 1 | ab='a b' 2 | c=' c' 3 | d=d 4 | for s in "$ab$c$d e" 'f g' h i; do 5 | echo $s 6 | done 7 | -------------------------------------------------------------------------------- /src/constraints/model/doc/README.md: -------------------------------------------------------------------------------- 1 | 2 | Documentation of the model generation and its applications. 3 | 4 | 5 | 6 | -------------------------------------------------------------------------------- /tests/no-output.cls: -------------------------------------------------------------------------------- 1 | begin 2 | x := 'A'; 3 | nooutput x := 'B'; echo ['ignore'] endnooutput; 4 | echo [x] 5 | end 6 | -------------------------------------------------------------------------------- /tests/variables.cls: -------------------------------------------------------------------------------- 1 | begin 2 | echo ['x=' x]; 3 | x := 'A'; 4 | echo ['x=' x]; 5 | x := 'B'; 6 | echo ['x=' x] 7 | end 8 | -------------------------------------------------------------------------------- /src/concrete/semantics/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/colis-anr/colis-language/HEAD/src/concrete/semantics/why3shapes.gz -------------------------------------------------------------------------------- /tests/fatal-in-function-call.cls: -------------------------------------------------------------------------------- 1 | function foo begin 2 | false ; 3 | echo ['foo'] 4 | end 5 | 6 | begin 7 | call foo 8 | end -------------------------------------------------------------------------------- /src/concrete/auxiliaries/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/colis-anr/colis-language/HEAD/src/concrete/auxiliaries/why3shapes.gz -------------------------------------------------------------------------------- /src/concrete/interpreter/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/colis-anr/colis-language/HEAD/src/concrete/interpreter/why3shapes.gz -------------------------------------------------------------------------------- /src/symbolic/collection/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/colis-anr/colis-language/HEAD/src/symbolic/collection/why3shapes.gz -------------------------------------------------------------------------------- /tests/for-false.meta: -------------------------------------------------------------------------------- 1 | input: 2 | arguments: [] 3 | stdin: "" 4 | output: 5 | stdout: "" 6 | stderr: "" 7 | return_code: 1 8 | -------------------------------------------------------------------------------- /tests/for.cls: -------------------------------------------------------------------------------- 1 | begin 2 | x := 'a'; 3 | echo [x]; 4 | for x in ['b'; 'c'] do 5 | echo [x] 6 | done; 7 | echo [x] 8 | end 9 | -------------------------------------------------------------------------------- /tests/grep-none.meta: -------------------------------------------------------------------------------- 1 | input: 2 | arguments: [] 3 | stdin: "" 4 | output: 5 | stdout: "" 6 | stderr: "" 7 | return_code: 1 8 | -------------------------------------------------------------------------------- /tests/false-for.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [] 4 | 5 | output: 6 | stdout: "" 7 | stderr: "" 8 | return_code: 0 9 | -------------------------------------------------------------------------------- /tests/false-while.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [] 4 | 5 | output: 6 | stdout: "" 7 | stderr: "" 8 | return_code: 0 9 | -------------------------------------------------------------------------------- /tests/for-empty.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [] 4 | 5 | output: 6 | stdout: "" 7 | stderr: "" 8 | return_code: 0 9 | -------------------------------------------------------------------------------- /tests/if-false-true.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [] 4 | 5 | output: 6 | stdout: "" 7 | stderr: "" 8 | return_code: 0 9 | -------------------------------------------------------------------------------- /tests/pipe-ignore-first-behaviour.sh: -------------------------------------------------------------------------------- 1 | f() { 2 | false | true 3 | return 0 | true 4 | exit 1 | true 5 | echo OK 6 | } 7 | f 8 | -------------------------------------------------------------------------------- /tests/dune: -------------------------------------------------------------------------------- 1 | (alias 2 | (name runtest) 3 | (action (run runner/run_tests.exe)) 4 | (deps 5 | (package colis-language) 6 | (source_tree .))) 7 | -------------------------------------------------------------------------------- /tests/function-not-exit.meta: -------------------------------------------------------------------------------- 1 | input: 2 | arguments: [] 3 | stdin: "" 4 | output: 5 | stdout: | 6 | 7 | stderr: "" 8 | return_code: 0 9 | -------------------------------------------------------------------------------- /tests/function-not-found.meta: -------------------------------------------------------------------------------- 1 | input: 2 | arguments: [] 3 | stdin: "" 4 | output: 5 | stdout: | 6 | 7 | stderr: "" 8 | return_code: 1 9 | -------------------------------------------------------------------------------- /tests/update_alternatives.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [] 4 | 5 | output: 6 | stdout: | 7 | stderr: "" 8 | return_code: 0 9 | -------------------------------------------------------------------------------- /simple.fs: -------------------------------------------------------------------------------- 1 | /bin/ 2 | /bin/sleep 3 | /sbin/ 4 | /usr/bin/ 5 | /usr/sbin/ 6 | /usr/local/lib/ 7 | /etc/ 8 | /usr/lib/ 9 | /var/lib/ 10 | /run/ 11 | -------------------------------------------------------------------------------- /src/symbolic/symbolicInterpreter/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/colis-anr/colis-language/HEAD/src/symbolic/symbolicInterpreter/why3shapes.gz -------------------------------------------------------------------------------- /tests/fatal-in-function-call.meta: -------------------------------------------------------------------------------- 1 | input: 2 | arguments: [] 3 | stdin: "" 4 | output: 5 | stdout: | 6 | 7 | stderr: "" 8 | return_code: 1 9 | -------------------------------------------------------------------------------- /tests/not-exit-previous-false.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [] 4 | 5 | output: 6 | stdout: "" 7 | stderr: "" 8 | return_code: 1 9 | -------------------------------------------------------------------------------- /src/symbolic/utilities/rm.mli: -------------------------------------------------------------------------------- 1 | open SymbolicUtility.ConstraintsCompatibility 2 | 3 | val name : string 4 | val interprete : utility_context -> utility 5 | -------------------------------------------------------------------------------- /src/symbolic/utilities/touch.mli: -------------------------------------------------------------------------------- 1 | open SymbolicUtility.ConstraintsCompatibility 2 | 3 | val name : string 4 | val interprete : utility_context -> utility 5 | -------------------------------------------------------------------------------- /tests/function-intertwined.sh: -------------------------------------------------------------------------------- 1 | ## Note: in the meta, the positions are broken, because of Morbig. 2 | 3 | true 4 | 5 | true () { 6 | echo b 7 | } 8 | -------------------------------------------------------------------------------- /tests/function-not-exit.sh: -------------------------------------------------------------------------------- 1 | f () { 2 | ! exit 0 3 | echo here 4 | } 5 | 6 | if f; then 7 | echo yes 8 | else 9 | echo no 10 | fi 11 | -------------------------------------------------------------------------------- /tests/no-output.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [] 4 | 5 | output: 6 | stdout: | 7 | B 8 | stderr: "" 9 | return_code: 0 10 | -------------------------------------------------------------------------------- /tests/not.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [] 4 | 5 | output: 6 | stdout: | 7 | here 8 | stderr: "" 9 | return_code: 0 10 | -------------------------------------------------------------------------------- /src/internals/dune: -------------------------------------------------------------------------------- 1 | (include_subdirs no) 2 | 3 | (library 4 | (name colis_internals) 5 | (public_name colis-language.internals) 6 | (libraries morsmall)) 7 | -------------------------------------------------------------------------------- /src/symbolic/utilities/updateMenus.mli: -------------------------------------------------------------------------------- 1 | open SymbolicUtility.ConstraintsCompatibility 2 | 3 | val name : string 4 | val interprete : utility_context -> utility 5 | -------------------------------------------------------------------------------- /tests/function-not-return.sh: -------------------------------------------------------------------------------- 1 | f () { 2 | ! return 0 3 | echo here 4 | } 5 | 6 | if f; then 7 | echo yes 8 | else 9 | echo no 10 | fi 11 | -------------------------------------------------------------------------------- /tests/strings.cls: -------------------------------------------------------------------------------- 1 | begin 2 | echo [split 'hello colis']; 3 | echo ['hello' 'colis']; 4 | echo [split 'hello'; 'colis']; 5 | echo ['hello'; 'colis'] 6 | end 7 | -------------------------------------------------------------------------------- /tests/hello2.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [] 4 | 5 | output: 6 | stdout: | 7 | hello world 8 | stderr: "" 9 | return_code: 0 10 | -------------------------------------------------------------------------------- /tests/var-in-subshell.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [] 4 | 5 | output: 6 | stdout: | 7 | A 8 | stderr: "" 9 | return_code: 0 10 | -------------------------------------------------------------------------------- /tests/function-not-return.meta: -------------------------------------------------------------------------------- 1 | input: 2 | arguments: [] 3 | stdin: "" 4 | output: 5 | stdout: | 6 | no 7 | 8 | stderr: "" 9 | return_code: 0 10 | -------------------------------------------------------------------------------- /tests/if.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [] 4 | 5 | output: 6 | stdout: | 7 | A 8 | C 9 | F 10 | stderr: "" 11 | return_code: 1 12 | -------------------------------------------------------------------------------- /tests/rm.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [] 4 | 5 | output: 6 | stdout: | 7 | rm: command not found 8 | stderr: "" 9 | return_code: 1 10 | -------------------------------------------------------------------------------- /tests/string-lists.cls: -------------------------------------------------------------------------------- 1 | begin 2 | ab := 'a b'; 3 | c := ' c'; 4 | d := 'd'; 5 | for s in [ ab c d ' e'; 'f g'; split 'h i'] do 6 | echo [s] 7 | done 8 | end 9 | -------------------------------------------------------------------------------- /src/symbolic/utilities/mkdir.mli: -------------------------------------------------------------------------------- 1 | (** Symbolic execution of mkdir *) 2 | open SymbolicUtility.Mixed 3 | 4 | val name : string 5 | val interprete : utility_context -> utility 6 | -------------------------------------------------------------------------------- /tests/which.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [] 4 | 5 | output: 6 | stdout: | 7 | which: command not found 8 | stderr: "" 9 | return_code: 1 10 | -------------------------------------------------------------------------------- /tests/pipe-ignore-first-behaviour.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [] 4 | 5 | output: 6 | stdout: | 7 | OK 8 | 9 | stderr: "" 10 | return_code: 0 11 | -------------------------------------------------------------------------------- /tests/pipe-var.cls: -------------------------------------------------------------------------------- 1 | begin 2 | x := 'A'; 3 | pipe 4 | x := x 'B' 5 | into begin 6 | echo ['X1: ' x]; 7 | x := x 'C' 8 | end endpipe; 9 | echo ['X2: ' x] 10 | end 11 | -------------------------------------------------------------------------------- /tests/pipe-var.meta: -------------------------------------------------------------------------------- 1 | input: 2 | arguments: [] 3 | stdin: "" 4 | output: 5 | stdout: | 6 | X1: A 7 | X2: A 8 | 9 | stderr: "" 10 | return_code: 0 11 | -------------------------------------------------------------------------------- /tests/pipe.sh: -------------------------------------------------------------------------------- 1 | echo hello 2 | { echo bonjour 3 | echo vert 4 | echo bonheur 5 | echo livre 6 | echo lovelace 7 | echo bon 8 | echo bonsoir 9 | } | grep bon 10 | -------------------------------------------------------------------------------- /tests/runner/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name run_tests) 3 | (libraries unix yaml ppx_protocol_conv_yaml) 4 | (preprocess (pps ppx_protocol_conv)) 5 | (flags (:standard -w -39))) 6 | -------------------------------------------------------------------------------- /tests/fatal-deep-under-if.meta: -------------------------------------------------------------------------------- 1 | input: 2 | arguments: [] 3 | stdin: "" 4 | output: 5 | stdout: | 6 | here 7 | yes 8 | 9 | stderr: "" 10 | return_code: 0 11 | -------------------------------------------------------------------------------- /tests/for.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [] 4 | 5 | output: 6 | stdout: | 7 | a 8 | b 9 | c 10 | c 11 | stderr: "" 12 | return_code: 0 13 | -------------------------------------------------------------------------------- /tests/variables.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [] 4 | 5 | output: 6 | stdout: | 7 | x= 8 | x=A 9 | x=B 10 | stderr: "" 11 | return_code: 0 12 | -------------------------------------------------------------------------------- /src/symbolic/utilities/cp.mli: -------------------------------------------------------------------------------- 1 | (** Symbolic execution of cp *) 2 | open SymbolicUtility.ConstraintsCompatibility 3 | 4 | val name : string 5 | val interprete : utility_context -> utility 6 | -------------------------------------------------------------------------------- /src/symbolic/utilities/mv.mli: -------------------------------------------------------------------------------- 1 | (** Symbolic execution of mv *) 2 | open SymbolicUtility.ConstraintsCompatibility 3 | 4 | val name : string 5 | val interprete : utility_context -> utility 6 | -------------------------------------------------------------------------------- /tests/command-not-found.meta: -------------------------------------------------------------------------------- 1 | input: 2 | arguments: [] 3 | stdin: "" 4 | output: 5 | stdout: | 6 | foo: command not found 7 | 8 | stderr: "" 9 | return_code: 1 10 | -------------------------------------------------------------------------------- /tests/stdout.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [] 4 | 5 | output: 6 | stdout: | 7 | A 8 | B 9 | CD 10 | EF 11 | stderr: "" 12 | return_code: 0 13 | -------------------------------------------------------------------------------- /tests/test_empty.sh: -------------------------------------------------------------------------------- 1 | 2 | if test ; then 3 | echo 'yes' 4 | else 5 | echo 'no' 6 | fi 7 | 8 | if test -e ; then 9 | echo 'yes' 10 | else 11 | echo 'no' 12 | fi 13 | -------------------------------------------------------------------------------- /src/constraints/model/doc/conclusion.tex: -------------------------------------------------------------------------------- 1 | %!TEX root = main.tex 2 | 3 | \section{Conclusion} 4 | \label{sec:conclusion} 5 | 6 | TODO: what are the results 7 | 8 | TODO: what are the future works -------------------------------------------------------------------------------- /tests/case.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [] 4 | 5 | output: 6 | stdout: | 7 | foo 8 | bar 9 | baz 10 | baz 11 | stderr: "" 12 | return_code: 0 13 | -------------------------------------------------------------------------------- /tests/if.sh: -------------------------------------------------------------------------------- 1 | if true; then echo 'A'; fi 2 | if false; then echo 'B'; fi 3 | if true; then echo 'C'; else echo 'D'; fi 4 | if false; then echo 'E'; else echo 'F'; fi 5 | if exit 1; then true; fi 6 | -------------------------------------------------------------------------------- /tests/symbolic/pipe.sh: -------------------------------------------------------------------------------- 1 | # if grep 1; then 2 | # echo yes 3 | # else 4 | # echo no 5 | # fi 6 | # grep 1 7 | # echo not here 8 | (echo abc1 9 | echo def 10 | echo ghi1)|grep 1 11 | -------------------------------------------------------------------------------- /tests/which_combinatoric_explosion.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [] 4 | 5 | output: 6 | stdout: | 7 | [: command not found 8 | stderr: "" 9 | return_code: 0 10 | -------------------------------------------------------------------------------- /tests/args.cls: -------------------------------------------------------------------------------- 1 | function f begin 2 | echo [ '1:'; split arg 1 ] ; 3 | echo [ '2:'; split arg 2 ] ; 4 | echo [ '3:'; split arg 3 ] 5 | end 6 | begin 7 | call f [ 'foo'; 'bar'; 'baz' ] 8 | end 9 | -------------------------------------------------------------------------------- /tests/args.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [foo, bar, baz] 4 | 5 | output: 6 | stdout: | 7 | 1: foo 8 | 2: bar 9 | 3: baz 10 | stderr: "" 11 | return_code: 0 12 | -------------------------------------------------------------------------------- /tests/string-lists.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [] 4 | 5 | output: 6 | stdout: | 7 | a b cd e 8 | f g 9 | h 10 | i 11 | stderr: "" 12 | return_code: 0 13 | -------------------------------------------------------------------------------- /tests/symbolic/error-failure.sh: -------------------------------------------------------------------------------- 1 | failure() { 2 | while true; do 3 | echo >/dev/null 4 | done 5 | } 6 | 7 | if mkdir x; then 8 | mkdir x 9 | else 10 | failure 11 | fi 12 | -------------------------------------------------------------------------------- /tests/symbolic/partial-failure.sh: -------------------------------------------------------------------------------- 1 | loop() { 2 | while true; do 3 | echo >/dev/null 4 | done 5 | } 6 | 7 | if mkdir "/x"; then 8 | echo "Ok" 9 | else 10 | loop 11 | fi 12 | -------------------------------------------------------------------------------- /tests/function-not-exit.cls: -------------------------------------------------------------------------------- 1 | function f begin 2 | not exit success; 3 | echo ['here'] 4 | end 5 | 6 | begin 7 | if call f then 8 | echo ['yes'] 9 | else 10 | echo ['no'] 11 | fi 12 | end -------------------------------------------------------------------------------- /tests/fatal-deep-under-if.cls: -------------------------------------------------------------------------------- 1 | 2 | function foo begin 3 | false ; 4 | echo ['here'] 5 | end 6 | 7 | begin 8 | if call foo then 9 | echo ['yes'] 10 | else 11 | echo ['no'] 12 | fi 13 | end -------------------------------------------------------------------------------- /tests/which_combinatoric_explosion.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | set -e 3 | # Automatically added by dh_installmenu 4 | if [ -x "`which update-menus 2>/dev/null`" ]; then update-menus ; fi 5 | # End automatically added section 6 | -------------------------------------------------------------------------------- /tests/function-not-return.cls: -------------------------------------------------------------------------------- 1 | function f begin 2 | not return success; 3 | echo ['here'] 4 | end 5 | 6 | begin 7 | if call f then 8 | echo ['yes'] 9 | else 10 | echo ['no'] 11 | fi 12 | end 13 | -------------------------------------------------------------------------------- /tests/pipe.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [] 4 | 5 | output: 6 | stdout: | 7 | hello 8 | bonjour 9 | bonheur 10 | bon 11 | bonsoir 12 | stderr: "" 13 | return_code: 0 14 | -------------------------------------------------------------------------------- /tests/str-subshell.meta: -------------------------------------------------------------------------------- 1 | input: 2 | arguments: [] 3 | stdin: "" 4 | output: 5 | stdout: | 6 | X a bX 7 | X 8 | 9 | a 10 | 11 | 12 | bX 13 | stderr: "" 14 | return_code: 0 15 | -------------------------------------------------------------------------------- /src/constraints/model/BUGS.md: -------------------------------------------------------------------------------- 1 | # BUGS 2 | ## Colis-language 3 | - [ ] symbolicUtilities.ml:multiple_times 4 | does not collect the correct constraint 5 | if one of the commands has an error 6 | 7 | - [ ] 8 | -------------------------------------------------------------------------------- /tests/export.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [] 4 | output: 5 | stdout: | 6 | 1 7 | 2 8 | 3 9 | COLIS_X=x 10 | 4 11 | 5 12 | COLIS_Y=y 13 | stderr: "" 14 | return_code: 0 -------------------------------------------------------------------------------- /tests/strings.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [] 4 | 5 | output: 6 | stdout: | 7 | hello colis 8 | hellocolis 9 | hello colis 10 | hello colis 11 | stderr: "" 12 | return_code: 0 13 | -------------------------------------------------------------------------------- /src/language/driver.drv: -------------------------------------------------------------------------------- 1 | module syntax.Identifier 2 | syntax type identifier "string" 3 | syntax val identifier_eq "String.equal %1 %2" 4 | syntax val identifier_to_string "%1" 5 | syntax val identifier_of_string "%1" 6 | end -------------------------------------------------------------------------------- /src/symbolic/utilities/dpkgMaintscriptHelper.mli: -------------------------------------------------------------------------------- 1 | (** Symbolic execution of dpkg-maintscript-helper *) 2 | open SymbolicUtility.ConstraintsCompatibility 3 | 4 | val name : string 5 | val interprete : utility_context -> utility 6 | -------------------------------------------------------------------------------- /tests/if.cls: -------------------------------------------------------------------------------- 1 | begin 2 | if true then echo ['A'] fi; 3 | if false then echo ['B'] fi; 4 | if true then echo ['C'] else echo ['D'] fi; 5 | if false then echo ['E'] else echo ['F'] fi; 6 | if exit failure then true fi 7 | end -------------------------------------------------------------------------------- /tests/symbolic/assign.sh: -------------------------------------------------------------------------------- 1 | x=a 2 | echo "1-$x" 3 | 4 | x=a$(echo b) 5 | echo "2-$x" 6 | 7 | if x=a$(false); then 8 | echo No 9 | else 10 | echo "3-$x" 11 | fi 12 | 13 | x=a$(false)$(true) 14 | echo "4-$x" 15 | 16 | -------------------------------------------------------------------------------- /src/symbolic/utilities/updateMenus.ml: -------------------------------------------------------------------------------- 1 | open SymbolicUtility.ConstraintsCompatibility 2 | 3 | let name = "update-menus" 4 | 5 | let interprete ctx = return true 6 | 7 | (* TODO model authorized options *) 8 | -------------------------------------------------------------------------------- /tests/test_x.sh: -------------------------------------------------------------------------------- 1 | 2 | for i in '/bin/ls' '/etc/passwd' ; do 3 | if test -x "$i" ; then 4 | echo "$i"' exists and is executable' 5 | else 6 | echo "$i"' does not exist or is not executable' 7 | fi 8 | done 9 | -------------------------------------------------------------------------------- /src/constraints/model/dune: -------------------------------------------------------------------------------- 1 | (include_subdirs unqualified) 2 | 3 | (executable 4 | (name engine) 5 | (public_name engine) 6 | (ocamlopt_flags "-dprofile") 7 | (ocamlc_flags "-g") 8 | (libraries colis-constraints colis-language colis)) 9 | -------------------------------------------------------------------------------- /tests/pipe-ignore-first-behaviour.cls: -------------------------------------------------------------------------------- 1 | function f begin 2 | pipe false into true endpipe; 3 | pipe exit success into true endpipe; 4 | pipe exit failure into true endpipe; 5 | echo ['OK'] 6 | end 7 | 8 | begin 9 | call f 10 | end 11 | -------------------------------------------------------------------------------- /tests/stdout.cls: -------------------------------------------------------------------------------- 1 | begin 2 | process begin 3 | echo ['A']; 4 | echo ['B']; 5 | echo ['-n'; 'C'] 6 | end endprocess; 7 | process 8 | echo ['D']; 9 | echo ['-n'; 'E']; 10 | echo ['F'] 11 | endprocess 12 | end 13 | -------------------------------------------------------------------------------- /tests/test_e.sh: -------------------------------------------------------------------------------- 1 | 2 | if test -e '/bin'; then 3 | echo '/bin exists' 4 | else 5 | echo '/bin does not exist' 6 | fi 7 | 8 | if [ -e '/home' ]; then 9 | echo '/home exists' 10 | else 11 | echo '/home does not exist' 12 | fi 13 | -------------------------------------------------------------------------------- /src/symbolic/utilities/test.mli: -------------------------------------------------------------------------------- 1 | open SymbolicUtility.ConstraintsCompatibility 2 | 3 | val name : string 4 | val interprete : utility_context -> utility 5 | 6 | module Bracket : sig 7 | val name : string 8 | val interprete : utility_context -> utility 9 | end 10 | -------------------------------------------------------------------------------- /src/symbolic/utilities/which.mli: -------------------------------------------------------------------------------- 1 | open SymbolicUtility.ConstraintsCompatibility 2 | 3 | val name : string 4 | val interprete : utility_context -> utility 5 | 6 | module Silent : sig 7 | val name : string 8 | val interprete : utility_context -> utility 9 | end 10 | -------------------------------------------------------------------------------- /tests/case.sh: -------------------------------------------------------------------------------- 1 | f () { 2 | case "$1" in 3 | upgrade|update) 4 | echo foo 5 | ;; 6 | 7 | (clean) 8 | echo bar 9 | ;; 10 | 11 | *) 12 | echo baz 13 | esac 14 | } 15 | 16 | f upgrade 17 | f "clean" 18 | f cleana 19 | f shproutz 20 | -------------------------------------------------------------------------------- /tests/test_empty.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [] 4 | 5 | output: 6 | stdout: | 7 | test: arguments different from . = . and . != . 8 | no 9 | test: arguments different from . = . and . != . 10 | no 11 | stderr: "" 12 | return_code: 0 13 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | ## Emacs specific 2 | *~ 3 | *# 4 | 5 | ## Dune specific 6 | .merlin 7 | /_build 8 | /*.install 9 | 10 | ## OPAM specific 11 | /_opam 12 | 13 | ## Project specific 14 | /src/why3 15 | /bin 16 | /doc 17 | 18 | ## Why3 19 | why3session.xml.bak 20 | why3shapes.gz.bak 21 | -------------------------------------------------------------------------------- /src/constraints/model/doc/spec-POSIX.tex: -------------------------------------------------------------------------------- 1 | %!TEX root = main.tex 2 | 3 | \section{Specification of POSIX utilities} 4 | \label{sec:spec} 5 | 6 | TODO: principles of specification 7 | 8 | TODO: notations $r$ and $r'$, maybe, etc. 9 | 10 | TODO: how are obtained in the coli-language -------------------------------------------------------------------------------- /tests/symbolic/utility.sh: -------------------------------------------------------------------------------- 1 | loop() { 2 | while 1; do 3 | echo >/dev/null 4 | done 5 | } 6 | 7 | if mkdir "/x"; then 8 | echo "Ok" 9 | else 10 | echo "Error" 11 | fi 12 | 13 | if test -e "/x"; then 14 | echo "Always" 15 | else 16 | loop 17 | fi 18 | -------------------------------------------------------------------------------- /tests/test_e.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [] 4 | 5 | output: 6 | stdout: | 7 | test: arguments different from . = . and . != . 8 | /bin does not exist 9 | [: command not found 10 | /home does not exist 11 | stderr: "" 12 | return_code: 0 13 | -------------------------------------------------------------------------------- /tests/export.sh: -------------------------------------------------------------------------------- 1 | echo 1 2 | env|grep COLIS_X || true 3 | COLIS_X=x 4 | echo 2 5 | env|grep COLIS_X || true 6 | export COLIS_X 7 | echo 3 8 | env|grep COLIS_X || true 9 | 10 | export COLIS_Y 11 | echo 4 12 | env|grep COLIS_Y || true 13 | COLIS_Y=y 14 | echo 5 15 | env|grep COLIS_Y || true 16 | -------------------------------------------------------------------------------- /tests/symbolic/not.sh: -------------------------------------------------------------------------------- 1 | ! false 2 | echo "1-Here" 3 | 4 | if ! false; then 5 | echo "2-Here" 6 | else 7 | echo "Not here" 8 | fi 9 | 10 | 11 | echo "End" 12 | 13 | loop() { 14 | while true; do 15 | echo > /dev/null 16 | done 17 | } 18 | (! loop) 19 | echo "Not here" 20 | -------------------------------------------------------------------------------- /src/constraints/model/doc/synthesis.tex: -------------------------------------------------------------------------------- 1 | %!TEX root = main.tex 2 | 3 | \section{Model synthesis for FTL} 4 | \label{sec:synthesis} 5 | 6 | TODO: algorithm overview 7 | 8 | TODO: building blocs 9 | 10 | TODO: abstract presentation 11 | 12 | TODO: correctness 13 | 14 | TODO: termination 15 | 16 | -------------------------------------------------------------------------------- /src/internals/errors.ml: -------------------------------------------------------------------------------- 1 | exception FileError of string 2 | exception ParseError of string * Lexing.position 3 | exception ConversionError of Morsmall.Location.position * string 4 | 5 | exception Unknown_behaviour of string * string 6 | 7 | exception CpuTimeLimitExceeded 8 | exception MemoryLimitExceeded 9 | -------------------------------------------------------------------------------- /tests/symbolic/failure.sh: -------------------------------------------------------------------------------- 1 | # a failure anyway in the program propagates 2 | failure () { 3 | while true; do 4 | echo > /dev/null 5 | done 6 | } 7 | f () { 8 | (failure) 9 | } 10 | echo "Not here" 11 | if s="$(f)"; then 12 | echo "Not here" 13 | else 14 | echo "Not here" 15 | fi 16 | -------------------------------------------------------------------------------- /tests/function-intertwined.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [] 4 | 5 | output: 6 | stdout: "" 7 | stderr: | 8 | File "./function-intertwined.sh", line 5, characters 5-14: Conversion error: unsupported feature: function definition after a use of the same name 9 | return_code: 6 10 | -------------------------------------------------------------------------------- /tests/pipe.cls: -------------------------------------------------------------------------------- 1 | begin 2 | echo ['hello']; 3 | pipe 4 | begin 5 | echo ['bonjour'] ; 6 | echo ['vert'] ; 7 | echo ['bonheur'] ; 8 | echo ['livre'] ; 9 | echo ['lovelace'] ; 10 | echo ['bon'] ; 11 | echo ['bonsoir'] 12 | end 13 | into 14 | grep ['bon'] 15 | endpipe 16 | end 17 | -------------------------------------------------------------------------------- /tests/shift.meta: -------------------------------------------------------------------------------- 1 | input: 2 | arguments: [A, B] 3 | stdin: "" 4 | output: 5 | stdout: | 6 | Here is ./shift.cls - A - B 7 | Here is ./shift.cls - B - 8 | This is f - X - Y - Z - W 9 | This is f - W - - - 10 | This is f - X - Y Z W - - 11 | 12 | stderr: "" 13 | return_code: 1 14 | -------------------------------------------------------------------------------- /tests/symbolic/foreach.sh: -------------------------------------------------------------------------------- 1 | for x in a$(false; echo x)$(true) b; do 2 | echo "1-$x" 3 | done 4 | echo "2-$x" 5 | 6 | echo "End" 7 | 8 | loop() { 9 | while true; do 10 | echo > /dev/null 11 | done 12 | } 13 | 14 | for x in a$(loop; echo x)$(true) b; do 15 | echo "$x" 16 | done 17 | echo "Not here" 18 | -------------------------------------------------------------------------------- /tests/test_d.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [] 4 | 5 | output: 6 | stdout: | 7 | test: arguments different from . = . and . != . 8 | /bin does not exist or is not a directory 9 | [: command not found 10 | /home does not exist or is not a directory 11 | stderr: "" 12 | return_code: 0 13 | -------------------------------------------------------------------------------- /tests/test_d.sh: -------------------------------------------------------------------------------- 1 | 2 | if test -d '/bin'; then 3 | echo '/bin exists and is a directory' 4 | else 5 | echo '/bin does not exist or is not a directory' 6 | fi 7 | 8 | if [ -d '/home' ]; then 9 | echo '/home exists and is a directory' 10 | else 11 | echo '/home does not exist or is not a directory' 12 | fi 13 | -------------------------------------------------------------------------------- /src/constraints/model/doc/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: build clean 2 | 3 | MAIN=main 4 | 5 | build: 6 | if which latexmk; then \ 7 | latexmk -pdf $(MAIN) ; \ 8 | else \ 9 | pdflatex $(MAIN) ; \ 10 | fi 11 | 12 | watch: 13 | latexmk -pdf -pvc $(MAIN) 14 | 15 | clean: 16 | if which latexmk; then \ 17 | latexmk -C ; \ 18 | fi 19 | -------------------------------------------------------------------------------- /src/internals/extList.ml: -------------------------------------------------------------------------------- 1 | let rec bd = function 2 | | [] -> failwith "bd" 3 | | [_] -> [] 4 | | h :: t -> h :: bd t 5 | 6 | let rec ft = function 7 | | [] -> failwith "ft" 8 | | [e] -> e 9 | | _ :: t -> ft t 10 | 11 | let rec ft_opt = function 12 | | [] -> None 13 | | [e] -> Some e 14 | | _ :: t -> ft_opt t 15 | -------------------------------------------------------------------------------- /tests/test_f.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [] 4 | 5 | output: 6 | stdout: | 7 | test: arguments different from . = . and . != . 8 | /bin does not exist or is not a regular file 9 | [: command not found 10 | /home does not exist or is not a regular file 11 | stderr: "" 12 | return_code: 0 13 | -------------------------------------------------------------------------------- /tests/test_f.sh: -------------------------------------------------------------------------------- 1 | 2 | if test -f '/bin'; then 3 | echo '/bin exists and is a regular file' 4 | else 5 | echo '/bin does not exist or is not a regular file' 6 | fi 7 | 8 | if [ -f '/home' ]; then 9 | echo '/home exists and is a regular file' 10 | else 11 | echo '/home does not exist or is not a regular file' 12 | fi 13 | -------------------------------------------------------------------------------- /tests/test_connectives2.sh: -------------------------------------------------------------------------------- 1 | 2 | if test ! -e '/bin'; then 3 | echo "true" 4 | else 5 | echo "false" 6 | fi 7 | 8 | if test -e '/bin' -a -e '/bin/sh'; then 9 | echo "true" 10 | else 11 | echo "false" 12 | fi 13 | 14 | if test -e '/bin' -o -e '/bin/sh'; then 15 | echo "true" 16 | else 17 | echo "false" 18 | fi 19 | -------------------------------------------------------------------------------- /tests/function.sh: -------------------------------------------------------------------------------- 1 | greet () { 2 | echo "Hello" "$1!" 3 | } 4 | 5 | twice () { 6 | echo Function: $0 7 | greet $1 8 | greet $2 9 | } 10 | 11 | butfirst () { 12 | shift 13 | echo Function: $0 14 | greet $1 15 | greet $2 16 | } 17 | 18 | # echo Program: $0 19 | twice 'colis' 'world' 20 | butfirst 'you' 'colis' 'world' 21 | -------------------------------------------------------------------------------- /tests/test_x.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [] 4 | 5 | output: 6 | stdout: | 7 | test: arguments different from . = . and . != . 8 | /bin/ls does not exist or is not executable 9 | test: arguments different from . = . and . != . 10 | /etc/passwd does not exist or is not executable 11 | stderr: "" 12 | return_code: 0 13 | -------------------------------------------------------------------------------- /tests/test_connectives2.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [] 4 | 5 | output: 6 | stdout: | 7 | test: arguments different from . = . and . != . 8 | false 9 | test: arguments different from . = . and . != . 10 | false 11 | test: arguments different from . = . and . != . 12 | false 13 | stderr: "" 14 | return_code: 0 15 | -------------------------------------------------------------------------------- /src/constraints/model/doc/testing.tex: -------------------------------------------------------------------------------- 1 | %!TEX root = main.tex 2 | 3 | \section{Testing POSIX commands} 4 | \label{sec:testing} 5 | 6 | TODO: generate paths and commands 7 | 8 | TODO: obtain specifications and apply model synthesis 9 | 10 | TODO: generate file system from model 11 | 12 | TODO: test file system using the model 13 | 14 | TODO: mutation of test cases 15 | 16 | -------------------------------------------------------------------------------- /tests/test_n_z.sh: -------------------------------------------------------------------------------- 1 | 2 | 3 | for s in '' 'a'; do 4 | if test -n "$s" ; then 5 | echo "string '$s' passes the -n test" 6 | else 7 | echo "string '$s' do not pass the -n test" 8 | fi 9 | if test -z "$s" ; then 10 | echo "string '$s' passes the -z test" 11 | else 12 | echo "string '$s' do not pass the -z test" 13 | fi 14 | done 15 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | services: 2 | - docker 3 | 4 | env: 5 | global: 6 | - TARGET=tester 7 | jobs: 8 | - TAG=4.10 TARGET=prover 9 | - TAG=4.09 10 | - TAG=4.08 11 | 12 | script: 13 | - docker build 14 | --build-arg "TAG=$TAG" 15 | --build-arg "SWITCH=$SWITCH" 16 | --tag colisanr/colis-language:$TRAVIS_BRANCH 17 | --target "$TARGET" 18 | . 19 | -------------------------------------------------------------------------------- /src/symbolic/utilities/emacsPackage.mli: -------------------------------------------------------------------------------- 1 | (** Symbolic execution of emacs-package-[install|remove] *) 2 | open SymbolicUtility.ConstraintsCompatibility 3 | 4 | module Install : sig 5 | val name : string 6 | val interprete : utility_context -> utility 7 | end 8 | 9 | module Remove : sig 10 | val name : string 11 | val interprete : utility_context -> utility 12 | end 13 | 14 | 15 | -------------------------------------------------------------------------------- /tests/function.meta: -------------------------------------------------------------------------------- 1 | input: 2 | arguments: [] 3 | stdin: "" 4 | output: 5 | # We cannot test $0 on the program level when comparing shell and colis scripts with different file extensions 6 | stdout: | 7 | Function: twice 8 | Hello colis! 9 | Hello world! 10 | Function: butfirst 11 | Hello colis! 12 | Hello world! 13 | 14 | stderr: "" 15 | return_code: 0 16 | -------------------------------------------------------------------------------- /src/constraints/model/doc/logic-FTL.tex: -------------------------------------------------------------------------------- 1 | %! TEX root = main.tex 2 | 3 | \section{Feature Tree Logic} 4 | \label{sec:FTL} 5 | 6 | TODO: model 7 | 8 | TODO: syntax 9 | 10 | TODO: semantics 11 | 12 | TODO: decision procedures (DP) for the quantifier free fragment (naïve and efficient), 13 | examples of rules used to set clashes 14 | 15 | TODO: properties of the formula obtained by applying DP for satisfiability 16 | -------------------------------------------------------------------------------- /src/constraints/model/doc/xperiments.tex: -------------------------------------------------------------------------------- 1 | %!TEX root = main.tex 2 | 3 | \section{Implementation and experimental results} 4 | \label{sec:exp} 5 | 6 | TODO: short description of implementation (modules, etc) 7 | 8 | TODO: DOCKER use for testing 9 | 10 | TODO: describe test suite 11 | 12 | TODO: report on results: specification fixes, code fixes 13 | 14 | TODO: what are the errors which are still reported and why 15 | 16 | -------------------------------------------------------------------------------- /tests/shift.cls: -------------------------------------------------------------------------------- 1 | function f begin 2 | echo ['This is'; arg 0; '-'; arg 1; '-'; arg 2; '-'; arg 3; '-'; arg 4]; 3 | shift 3; 4 | echo ['This is'; arg 0; '-'; arg 1; '-'; arg 2; '-'; arg 3; '-'; arg 4] 5 | end 6 | 7 | begin 8 | echo ['Here is'; arg 0; '-'; arg 1; '-'; arg 2]; 9 | shift; 10 | echo ['Here is'; arg 0; '-'; arg 1; '-'; arg 2]; 11 | s := 'Y Z W'; 12 | call f ['X'; split s]; 13 | call f ['X'; s] 14 | end 15 | -------------------------------------------------------------------------------- /src/internals/colis_internals.ml: -------------------------------------------------------------------------------- 1 | module Ext = struct 2 | module List = ExtList 3 | end 4 | 5 | module Errors = Errors 6 | module Options = Options 7 | 8 | let check_cpu_time_limit () = 9 | if Sys.time () >= !Options.cpu_time_limit then 10 | raise Errors.CpuTimeLimitExceeded 11 | 12 | let check_memory_limit () = 13 | if (Gc.quick_stat ()).Gc.heap_words >= !Options.memory_limit then 14 | raise Errors.MemoryLimitExceeded 15 | -------------------------------------------------------------------------------- /tests/symbolic/subshell.sh: -------------------------------------------------------------------------------- 1 | 2 | if (exit 5); then 3 | echo "Not here" 4 | else 5 | echo "1-Here" 6 | fi 7 | 8 | if (return 5); then 9 | echo "Not here" 10 | else 11 | echo "2-Here" 12 | fi 13 | 14 | (exit 0) 15 | echo "3-Here" 16 | 17 | failure () { 18 | while true; do 19 | echo > /dev/null 20 | done 21 | } 22 | 23 | echo "4-End" 24 | 25 | if (failure); then 26 | echo "Not here" 27 | else 28 | echo "Not here" 29 | fi 30 | echo "Not here" 31 | -------------------------------------------------------------------------------- /tests/function.cls: -------------------------------------------------------------------------------- 1 | function greet begin 2 | echo ['Hello'; arg 1 '!'] 3 | end 4 | 5 | function twice begin 6 | echo ['Function:'; arg 0]; 7 | call greet [arg 1]; 8 | call greet [arg 2] 9 | end 10 | 11 | function butfirst begin 12 | shift; 13 | echo ['Function:'; arg 0]; 14 | call greet [arg 1]; 15 | call greet [arg 2] 16 | end 17 | 18 | begin 19 | (* echo ['Program:'; arg 0]; *) 20 | call twice ['colis'; 'world']; 21 | call butfirst ['you'; 'colis'; 'world'] 22 | end 23 | -------------------------------------------------------------------------------- /tests/test_string_eq.sh: -------------------------------------------------------------------------------- 1 | 2 | 3 | for s in '' 'a' 'bc'; do 4 | for t in '' 'a' 'bc'; do 5 | if test "$s" = "$t" ; then 6 | echo "strings '$s' and '$t' pass the '=' test" 7 | else 8 | echo "strings '$s' and '$t' do not pass the '=' test" 9 | fi 10 | if test "$s" != "$t" ; then 11 | echo "strings '$s' and '$t' pass the '!=' test" 12 | else 13 | echo "strings '$s' and '$t' do not pass the '!=' test" 14 | fi 15 | done 16 | done 17 | -------------------------------------------------------------------------------- /tests/export.cls: -------------------------------------------------------------------------------- 1 | begin 2 | echo [ '1' ] ; 3 | if pipe env into grep [ 'COLIS_X' ] endpipe then true fi ; 4 | COLIS_X := 'x' ; 5 | echo [ '2' ] ; 6 | if pipe env into grep [ 'COLIS_X' ] endpipe then true fi ; 7 | export COLIS_X; 8 | echo [ '3' ] ; 9 | if pipe env into grep [ 'COLIS_X' ] endpipe then true fi ; 10 | export COLIS_Y; 11 | echo [ '4' ] ; 12 | if pipe env into grep [ 'COLIS_Y' ] endpipe then true fi ; 13 | COLIS_Y := 'y' ; 14 | echo [ '5' ] ; 15 | if pipe env into grep [ 'COLIS_Y' ] endpipe then true fi 16 | end -------------------------------------------------------------------------------- /tests/test_n_z.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [] 4 | 5 | output: 6 | stdout: | 7 | test: arguments different from . = . and . != . 8 | string '' do not pass the -n test 9 | test: arguments different from . = . and . != . 10 | string '' do not pass the -z test 11 | test: arguments different from . = . and . != . 12 | string 'a' do not pass the -n test 13 | test: arguments different from . = . and . != . 14 | string 'a' do not pass the -z test 15 | stderr: "" 16 | return_code: 0 17 | -------------------------------------------------------------------------------- /src/concrete/pathnames.mli: -------------------------------------------------------------------------------- 1 | (** operations on path names *) 2 | 3 | (** check whether the first symbol of the path name is the symbol '/' *) 4 | val starts_on_slash: string -> bool 5 | 6 | (** check whether the last symbol of the path name is the symbol '/' *) 7 | val ends_on_slash: string -> bool 8 | 9 | (** return the path name with any leading directory components removed *) 10 | val remove_dirs: string -> string 11 | 12 | (** [is_pathprefix s1 s2] checks whether [s1^"/"] is a prefix of [s2] *) 13 | val is_dir_prefix: string -> string -> bool 14 | -------------------------------------------------------------------------------- /src/symbolic/driver.drv: -------------------------------------------------------------------------------- 1 | module collection.Collection 2 | syntax type t "%1 list" 3 | syntax val mem "List.mem %1 %2" 4 | syntax val empty "[]" 5 | syntax val add "%1 :: %2" 6 | syntax val singleton "[%1]" 7 | syntax val map "List.map %1 %2" 8 | syntax val filter "List.filter %1 %2" 9 | syntax val partition "List.partition %1 %2" 10 | syntax val union "List.rev_append %1 %2" 11 | syntax val bind "List.concat (List.map %1 %2)" 12 | syntax val of_list "%1" 13 | syntax val to_list "%1" 14 | syntax val size "List.length %1" 15 | end 16 | -------------------------------------------------------------------------------- /src/language/embellisher.ml: -------------------------------------------------------------------------------- 1 | open Colis_internals.Ext 2 | open Syntax__Syntax 3 | 4 | let embellish colis = 5 | let visitor = object 6 | inherit [_] SyntaxHelpers.map as super 7 | 8 | method! visit_ICallUtility () name args = 9 | match name with 10 | (* Rewrite "[ ... ]" into "test ..." *) 11 | | "[" when List.ft_opt args = Some (SLiteral "]", DontSplit) -> 12 | super#visit_ICallUtility () "test" (List.bd args) 13 | 14 | | _ -> super#visit_ICallUtility () name args 15 | end in 16 | visitor#visit_program () colis 17 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (include_subdirs unqualified) 2 | 3 | (library 4 | (name colis) 5 | (public_name colis-language) 6 | (libraries 7 | colis-language.internals 8 | colis-constraints 9 | zarith str 10 | ppx_deriving_yojson.runtime 11 | visitors.runtime 12 | morsmall morsmall.utilities 13 | cmdliner 14 | batteries) 15 | (preprocess (pps visitors.ppx)) 16 | (modules :standard \ colis_cmd) 17 | (flags :standard -w -27 -w -49)) 18 | 19 | (executable 20 | (name colis_cmd) 21 | (public_name colis) 22 | (libraries colis-language) 23 | (modules colis_cmd)) 24 | -------------------------------------------------------------------------------- /src/symbolic/utilities/updateAlternatives.ml: -------------------------------------------------------------------------------- 1 | open SymbolicUtility.ConstraintsCompatibility 2 | 3 | let name = "update-alternatives" 4 | 5 | let interprete ctx = 6 | let name = "update-alternatives" in 7 | let rec aux = function 8 | | [] -> 9 | (* TODO: return error state *) 10 | error ~utility:name "no sub-command found" 11 | | "--quiet" :: rem-> 12 | fun st -> aux rem (print_utility_trace (name ^ ": ignored option --quiet") st) 13 | | arg :: _ -> 14 | unknown ~utility:name ("unsupported argument: " ^ arg) 15 | in 16 | aux ctx.args 17 | -------------------------------------------------------------------------------- /tests/test_connectives.sh: -------------------------------------------------------------------------------- 1 | 2 | for s in '' 'a' ; do 3 | if test ! -n "$s" ; then 4 | echo "test ! -n '$s': yes" 5 | else 6 | echo "test ! -n '$s': no" 7 | fi 8 | for t in '' 'b' ; do 9 | if test -n "$s" -a -n "$t" ; then 10 | echo "test -n '$s' -a -n '$t': yes" 11 | else 12 | echo "test -n '$s' -a -n '$t': no" 13 | fi 14 | if test -n "$s" -o -n "$t" ; then 15 | echo "test -n '$s' -o -n '$t': yes" 16 | else 17 | echo "test -n '$s' -o -n '$t': no" 18 | fi 19 | done 20 | done 21 | -------------------------------------------------------------------------------- /src/concrete/env.mli: -------------------------------------------------------------------------------- 1 | (** Identifier environments with default value. *) 2 | 3 | type 'a env 4 | val empty : 'a -> 'a env 5 | val get : 'a env -> string -> 'a 6 | val set : 'a env -> string -> 'a -> 'a env 7 | val filter : (string -> 'a -> bool) -> 'a env -> 'a env 8 | val map : ('a -> 'b) -> 'b -> 'a env -> 'b env 9 | val elements : 'a env -> (string * 'a) list 10 | 11 | module SMap : Map.S with type key = string 12 | 13 | (** Conversion to a normal map without default value *) 14 | val to_map : 'a env -> 'a SMap.t 15 | 16 | val filter_var_env : ('a -> bool) -> ('a -> 'b option) -> 'a env -> 'b SMap.t 17 | -------------------------------------------------------------------------------- /tests/runner/common.ml: -------------------------------------------------------------------------------- 1 | let (||>) f g x = f x |> g 2 | 3 | let (>>=) r f = 4 | match r with 5 | | Ok x -> f x 6 | | Error msg -> Error msg 7 | 8 | let escape_shell_argument = 9 | String.split_on_char '\'' 10 | ||> String.concat "'\\''" 11 | ||> fun s -> "'" ^ s ^ "'" 12 | 13 | let in_channel_to_string ic = 14 | let all = Buffer.create 8 in 15 | let bufsize = 1024 in 16 | let buf = Bytes.create bufsize in 17 | let rec aux () = 18 | match input ic buf 0 bufsize with 19 | | 0 -> () 20 | | n -> 21 | Buffer.add_subbytes all buf 0 n; 22 | aux () 23 | in 24 | aux (); 25 | Buffer.contents all 26 | -------------------------------------------------------------------------------- /tests/case.cls: -------------------------------------------------------------------------------- 1 | function f begin 2 | case_var := arg 1 ; 3 | if 4 | if 5 | if false then 6 | true 7 | else 8 | test [ case_var; '='; 'upgrade' ] 9 | fi 10 | then 11 | true 12 | else 13 | test [ case_var; '='; 'update' ] 14 | fi 15 | then 16 | echo [ 'foo' ] 17 | else 18 | if 19 | if false then 20 | true 21 | else 22 | test [ case_var; '='; 'clean' ] 23 | fi 24 | then 25 | echo [ 'bar' ] 26 | else 27 | echo [ 'baz' ] 28 | fi 29 | fi 30 | end 31 | 32 | begin 33 | call f [ 'upgrade' ] ; 34 | call f [ 'clean' ] ; 35 | call f [ 'cleana' ] ; 36 | call f [ 'shproutz' ] 37 | end 38 | -------------------------------------------------------------------------------- /src/constraints/model/doc/introduction.tex: -------------------------------------------------------------------------------- 1 | %! TEX root = main.tex 2 | 3 | \section{Introduction} 4 | 5 | %% Explain specification based testing 6 | Testing is a convenient technique when the code is not available or 7 | it is too complex to apply formal verification. To palliate its inherent 8 | incompleteness, testing may use formal specifications of the program under test. 9 | TODO 10 | 11 | 12 | TODO: Explain problem with specifications in Colis 13 | and their application to testing installation scripts 14 | 15 | 16 | TODO: Motivation of this work : specification based testing, 17 | but also specification fixing and model building from satisfiable formulas 18 | 19 | TODO: Contribution 20 | 21 | TODO: Overview of the repost -------------------------------------------------------------------------------- /src/symbolic/utilities/basics.ml: -------------------------------------------------------------------------------- 1 | open SymbolicUtility.ConstraintsCompatibility 2 | 3 | module True = struct 4 | let name = "true" 5 | 6 | let interprete : utility_context -> utility = 7 | fun _ -> return true 8 | end 9 | 10 | module Colon = struct 11 | include True 12 | let name = ":" 13 | end 14 | 15 | module False = struct 16 | let name = "false" 17 | 18 | let interprete : utility_context -> utility = 19 | fun _ -> return false 20 | end 21 | 22 | module Echo = struct 23 | let name = "echo" 24 | 25 | let interprete : utility_context -> utility = 26 | fun ctx sta -> 27 | let str = String.concat " " ctx.args in 28 | let sta = print_stdout ~newline:true str sta in 29 | [sta, Ok true] 30 | end 31 | -------------------------------------------------------------------------------- /tests/runner/options.ml: -------------------------------------------------------------------------------- 1 | let utility = ref "colis" 2 | let directory = ref Filename.current_dir_name 3 | let sh_only = ref false 4 | 5 | let speclist = 6 | [ "--utility", Arg.Set_string utility, "UTIL Set the utility to test (default: colis)"; 7 | "--directory", Arg.Set_string directory, "DIR Set the directory in which the tests can be found (default: .)" ; 8 | "--sh-only", Arg.Set sh_only, " Only test .sh files (default: false)" ] 9 | |> Arg.align 10 | 11 | let anon_fun _ = 12 | raise (Arg.Bad "no anonymous argument allowed") 13 | 14 | let usage_msg = 15 | Format.sprintf 16 | "Usage: %s [--utility UTIL] [--directory DIR]" 17 | Sys.argv.(0) 18 | 19 | let parse_cmd_line () = 20 | Arg.parse speclist anon_fun usage_msg 21 | -------------------------------------------------------------------------------- /examples/loop-symbolic: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # argument 1: a directory 4 | # runs the symbolic execution on each *.sh file in the directory, and 5 | # leaves in the same directory a report per file. 6 | 7 | outsuffix=colisout 8 | calldir=$PWD 9 | colis=$calldir/bin/colis 10 | cd ${1?directory argument missing} 11 | rm *.$outsuffix 12 | for f in *.sh; do 13 | outfile="$f"."$outsuffix" 14 | if file "$f" | grep -q "ELF"; then 15 | echo "skipped: ELF" > "$outfile" 16 | continue 17 | fi 18 | if head -1 "$f" | egrep -q "^#!/usr/bin/perl|^#!/bin/bash"; then 19 | echo "skipped: other script interpreter" > "$outfile" 20 | continue 21 | fi 22 | $colis --run-symbolic "$f" > "$outfile" 23 | exitcode=$? 24 | echo "\n* Exit code:" $exitcode >> "$outfile" 25 | done 26 | -------------------------------------------------------------------------------- /src/concrete/env.ml: -------------------------------------------------------------------------------- 1 | module SMap = Map.Make (String) 2 | 3 | type 'a env = {map: 'a SMap.t; default: 'a} 4 | 5 | let empty default = {map=SMap.empty; default} 6 | let get env id = try SMap.find id env.map with Not_found -> env.default 7 | let set env id value = {env with map=SMap.add id value env.map} 8 | let filter p env = {env with map=SMap.filter p env.map} 9 | let map f default env = {map=SMap.map f env.map; default} 10 | let elements env = SMap.fold (fun k v t -> (k, v) :: t) env.map [] 11 | let to_map env = env.map 12 | 13 | let filter_var_env (var_exported: 'a -> bool) (var_value: 'a -> 'b option) (env : 'a env) : 'b SMap.t = 14 | let open SMap in 15 | env.map |> 16 | filter (fun _ -> var_exported) |> 17 | map var_value |> 18 | filter (fun _ -> (<>) None) |> 19 | map (function Some x -> x | _ -> assert false) 20 | -------------------------------------------------------------------------------- /src/constraints/model/test/cmd.dat: -------------------------------------------------------------------------------- 1 | mkdir netcat/grep/zless/findmnt/bzip2/ 2 | cp mknod/chmod/sh/cat/lessfile/bzless/lowntfs-3g ../rbash/ 3 | mv bzegrep/zcmp/udevadm/dumpkeys/kbd_mode/chmod/busybox/chvt/ntfsfix/uncompress/ lsmod/../loadkeys/ 4 | test -e zdiff/gzexe/mkdir/which/./mkdir/../ 5 | mkdir rmdir/ping4/pidof/systemd-escape/ 6 | mv bzgrep/chacl/ ntfscmp/ 7 | test -f mount/cp/setfont/true/zgrep/chacl/efibootdump/mktem 8 | cp zgrep/grep/bzcat/nc.openbsd/dd/ed/getfacl ../bzegrep/../stty/ 9 | rm -r touch/false/hciconfig/ 10 | mkdir nc.openbsd/su/ 11 | test -e ntfscmp/bzdiff/sh.distrib/../domainname/nc/../setupcon/mountpoint/ntfsls 12 | test -d ntfscmp/ 13 | cp ss/stty/chvt/red/dnsdomainname/dir/plymouth zegrep/bzfgrep/less/chacl/systemd-escape/bzexe/ 14 | touch ntfscmp/less/open/znew 15 | touch static-sh/gunzip/ntfsusermap/fusermount/../hostname 16 | -------------------------------------------------------------------------------- /src/concrete/pathnames.ml: -------------------------------------------------------------------------------- 1 | let starts_on_slash s = String.length s > 0 && s.[0]='/' 2 | 3 | let ends_on_slash s = let n = String.length s in n > 0 && s.[n-1]='/' 4 | 5 | let remove_dirs s = 6 | try 7 | let last_slash_ind = String.rindex s '/' 8 | in String.sub s (last_slash_ind+1) ((String.length s)-last_slash_ind-1) 9 | with 10 | Not_found -> s 11 | 12 | let is_dir_prefix p1 p2 = 13 | (* check whether [p1^'/'] is a prefix of [p2] *) 14 | let rec forall_from_to lower upper pred = 15 | (* check [(pred lower) && .... && (pred upper)] *) 16 | if lower > upper then true 17 | else pred lower && forall_from_to (lower+1) upper pred 18 | in 19 | let n1 = String.length p1 20 | and n2 = String.length p2 21 | in 22 | if n1+1 >= n2 23 | then 24 | false 25 | else 26 | p2.[n1]='/' && forall_from_to 0 (n1-1) (function i -> p1.[i]=p2.[i]) 27 | 28 | -------------------------------------------------------------------------------- /src/constraints/model/doc/abstract.tex: -------------------------------------------------------------------------------- 1 | %! TEX root = main.tex 2 | 3 | \begin{abstract} 4 | This paper presents a specification based testing of POSIX utilities 5 | manipulating the file system, e.g., copy, moving or removing files and directories. 6 | The specification used in this work is the outcome of the Colis project, 7 | which proposed a formal specification of POSIX utilities using the 8 | Feature Tree Logic (FTL). 9 | To obtain test suites for a POSIX command, we propose an algorithm 10 | which synthesizes the model of the command's specification. 11 | The model is then used to create the input file system of the 12 | command under test and to check that the output file system 13 | conforms to the formal specification. 14 | We report on the application of this method to several POSIX commands. 15 | The main result we obtained is the improvement of the FTL specifications 16 | for dealing with special file system's paths. 17 | \end{abstract} -------------------------------------------------------------------------------- /src/constraints/model/doc/main.tex: -------------------------------------------------------------------------------- 1 | \documentclass{llncs} 2 | 3 | 4 | \input{packages} 5 | \input{constraints} 6 | 7 | %% Title 8 | \title{Testing POSIX Utilities using Feature Tree Logic} 9 | \author{Abhinandan Pal} 10 | \date{\today} 11 | 12 | \begin{document} 13 | 14 | \maketitle 15 | 16 | %% Summary of contributions 17 | \input{abstract} 18 | 19 | %% Introduction, motivation and overview 20 | \input{introduction} 21 | 22 | %% Presentation of FTL and its decision procedure 23 | \input{logic-FTL} 24 | 25 | %% Presentation of specifications for POSIX utilities 26 | \input{spec-POSIX} 27 | \input{preliminaries} 28 | 29 | %% Model synthesis from specs 30 | \input{synthesis} 31 | 32 | %% Testing specs 33 | \input{testing} 34 | 35 | %% eXperimental results 36 | \input{xperiments} 37 | 38 | %% Conclusion 39 | \input{conclusion} 40 | 41 | \bibliographystyle{alpha} 42 | \bibliography{colis} 43 | 44 | % temporary 45 | \setcounter{tocdepth}{3} 46 | {\small\tableofcontents} 47 | 48 | \end{document} 49 | -------------------------------------------------------------------------------- /tests/test_connectives.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [] 4 | 5 | output: 6 | stdout: | 7 | test: arguments different from . = . and . != . 8 | test ! -n '': no 9 | test: arguments different from . = . and . != . 10 | test -n '' -a -n '': no 11 | test: arguments different from . = . and . != . 12 | test -n '' -o -n '': no 13 | test: arguments different from . = . and . != . 14 | test -n '' -a -n 'b': no 15 | test: arguments different from . = . and . != . 16 | test -n '' -o -n 'b': no 17 | test: arguments different from . = . and . != . 18 | test ! -n 'a': no 19 | test: arguments different from . = . and . != . 20 | test -n 'a' -a -n '': no 21 | test: arguments different from . = . and . != . 22 | test -n 'a' -o -n '': no 23 | test: arguments different from . = . and . != . 24 | test -n 'a' -a -n 'b': no 25 | test: arguments different from . = . and . != . 26 | test -n 'a' -o -n 'b': no 27 | stderr: "" 28 | return_code: 0 29 | -------------------------------------------------------------------------------- /tests/test_string_eq.meta: -------------------------------------------------------------------------------- 1 | input: 2 | stdin: "" 3 | arguments: [] 4 | 5 | output: 6 | stdout: | 7 | strings '' and '' pass the '=' test 8 | strings '' and '' do not pass the '!=' test 9 | strings '' and 'a' do not pass the '=' test 10 | strings '' and 'a' pass the '!=' test 11 | strings '' and 'bc' do not pass the '=' test 12 | strings '' and 'bc' pass the '!=' test 13 | strings 'a' and '' do not pass the '=' test 14 | strings 'a' and '' pass the '!=' test 15 | strings 'a' and 'a' pass the '=' test 16 | strings 'a' and 'a' do not pass the '!=' test 17 | strings 'a' and 'bc' do not pass the '=' test 18 | strings 'a' and 'bc' pass the '!=' test 19 | strings 'bc' and '' do not pass the '=' test 20 | strings 'bc' and '' pass the '!=' test 21 | strings 'bc' and 'a' do not pass the '=' test 22 | strings 'bc' and 'a' pass the '!=' test 23 | strings 'bc' and 'bc' pass the '=' test 24 | strings 'bc' and 'bc' do not pass the '!=' test 25 | stderr: "" 26 | return_code: 0 27 | -------------------------------------------------------------------------------- /src/concrete/driver.drv: -------------------------------------------------------------------------------- 1 | module semantics.Env 2 | syntax type env "%1 Env.env" 3 | syntax val empty_env "Env.empty %1" 4 | syntax val ([]) "Env.get %1 %2" 5 | syntax val ([<-]) "Env.set %1 %2 %3" 6 | syntax type env0 "%1 Env.SMap.t" 7 | end 8 | 9 | module semantics.Buffers 10 | syntax val concat_lines "String.concat \"\n\" %1" 11 | syntax val split_on_default_ifs "Str.(split (regexp \"[ \t\n]+\") %1)" 12 | end 13 | 14 | module semantics.Path 15 | syntax type feature "Colis_constraints.Feat.t" 16 | syntax type normalized_path "Colis_constraints.Path.normal" 17 | syntax val default_cwd "[]" 18 | syntax val normalized_path_to_string "Colis_constraints.Path.normal_to_string %1" 19 | syntax val absolute_or_concat_relative "Colis_constraints.Path.(normalize ~cwd:%1 (from_string %2))" 20 | end 21 | 22 | module semantics.Context 23 | syntax val filter_var_env "Semantics__Context.(Env.filter_var_env (fun v -> v.exported) (fun v -> v.value) %1)" 24 | end 25 | 26 | module interpreter.Interpreter 27 | syntax val interp_utility "Utilities.interp_utility %1" 28 | end -------------------------------------------------------------------------------- /src/symbolic/utilities/colisInternalUnsafeTouch.ml: -------------------------------------------------------------------------------- 1 | open Format 2 | open Colis_constraints 3 | open SymbolicUtility.ConstraintsCompatibility 4 | 5 | let name = "colis_internal_unsafe_touch" 6 | 7 | let interp1 path_str = 8 | let p = Path.from_string path_str in 9 | let q = Path.check_normal p in 10 | specification_cases [ 11 | success_case 12 | ~descr:(asprintf "colis_internal_unsafe_touch: %a" Path.pp p) 13 | begin fun root root' -> 14 | (* FIXME: one could do better and drop the last maybe on the left. *) 15 | let rec aux x x' = function 16 | | [] -> 17 | reg x' 18 | | f :: q -> 19 | exists2 @@ fun y y' -> 20 | sim x (Feat.Set.singleton f) x' 21 | & maybe x f y & feat x' f y' 22 | & aux y y' q 23 | in 24 | aux root root' q 25 | end 26 | ] 27 | 28 | let interprete _ctx args : utility = 29 | multiple_times interp1 args 30 | 31 | let interprete ctx : utility = 32 | cmdliner_eval_utility ~utility:name Cmdliner.Term.(const interprete) ctx 33 | -------------------------------------------------------------------------------- /tests/update_alternatives.sh: -------------------------------------------------------------------------------- 1 | #! /bin/sh 2 | # prerm script for trn4 3 | # 4 | # see: dh_installdeb(1) 5 | 6 | set -e 7 | 8 | # summary of how this script can be called: 9 | # * `remove' 10 | # * `upgrade' 11 | # * `failed-upgrade' 12 | # * `remove' `in-favour' 13 | # * `deconfigure' `in-favour' 14 | # `removing' 15 | # 16 | # for details, see /usr/share/doc/packaging-manual/ 17 | 18 | case "$1" in 19 | remove|deconfigure) 20 | for x in Pnews Rnmail nntplist rn trn trn-artchk; do 21 | update-alternatives --quiet --remove $x /usr/lib/trn4/$x 22 | done 23 | ;; 24 | upgrade|failed-upgrade) 25 | ;; 26 | *) 27 | echo "prerm called with unknown argument \`$1'" >&2 28 | exit 0 29 | ;; 30 | esac 31 | 32 | # dh_installdeb will replace this with shell code automatically 33 | # generated by other debhelper scripts. 34 | 35 | 36 | 37 | exit 0 38 | -------------------------------------------------------------------------------- /src/constraints/model/CHANGES.md: -------------------------------------------------------------------------------- 1 | 2 | # CHANGES 3 | ## Colis-language 4 | - src/symbolic/utilities/cp.ml 5 | + fix application of cp2 multiple_times 6 | + fix case of source path ending by / for file and directory 7 | - src/symbolic/utilities/mkdir.ml 8 | + fix case of paths ending by multiple slashes by ignoring them 9 | + fix case of paths ending by /. or /.. by error cases 10 | - src/symbolic/utilities/mv.ml 11 | + fix case of source paths ending by slashes 12 | - src/symbolic/utilities/rm.ml 13 | + fix case of paths ending by multiple slashes by ignoring them 14 | + fix case of paths ending by /. or /.. by error cases 15 | - src/symbolic/utilities/test.ml 16 | + fix case of paths ending by multiple slashes by ignoring them 17 | + fix case of paths ending by /. or /.. by error case if not option -d 18 | - src/symbolic/utilities/touch.ml 19 | + fix case of paths ending by multiple slashes by ignoring them 20 | 21 | ## Colis-constraints 22 | - src/common/path.ml 23 | + nomralize : reverse the path generated 24 | + string_trailing_slashes : reverse string generated 25 | 26 | -------------------------------------------------------------------------------- /tests/runner/metaFile.ml: -------------------------------------------------------------------------------- 1 | open Common 2 | 3 | let yaml_of_string = Yaml.of_string_exn 4 | open Protocol_conv_yaml 5 | 6 | type input = 7 | { arguments : string list ; 8 | stdin : string } 9 | [@@deriving protocol ~driver:(module Yaml)] 10 | 11 | type output = 12 | { stdout : string ; 13 | stderr : string ; 14 | return_code : int } 15 | [@@deriving protocol ~driver:(module Yaml)] 16 | 17 | type t = 18 | { input : input ; 19 | output : output } 20 | [@@deriving protocol ~driver:(module Yaml)] 21 | 22 | let rec promote_null_to_empty_string = function 23 | | `Null -> `String "" 24 | | `Bool b -> `Bool b 25 | | `Float f -> `Float f 26 | | `String s -> `String s 27 | | `A vl -> `A (List.map promote_null_to_empty_string vl) 28 | | `O svl -> `O (List.map (fun (s, v) -> (s, promote_null_to_empty_string v)) svl) 29 | 30 | let load_from_file filename = 31 | try 32 | let ichan = open_in filename in 33 | let yaml = 34 | in_channel_to_string ichan 35 | |> yaml_of_string 36 | |> promote_null_to_empty_string 37 | |> of_yaml_exn 38 | in 39 | close_in ichan; 40 | yaml 41 | with 42 | Not_found -> failwith ("one required key could not be found: "^filename) 43 | -------------------------------------------------------------------------------- /src/symbolic/utilities/dpkg.ml: -------------------------------------------------------------------------------- 1 | open SymbolicUtility.ConstraintsCompatibility 2 | open Semantics__Result 3 | 4 | let name = "dpkg" 5 | 6 | let interprete ctx = 7 | let utility = "dpkg" in 8 | let aux = function 9 | | ["-L"; pkg_name] -> 10 | if Colis_internals.Options.get_package_name () = pkg_name then 11 | ( 12 | let str = 13 | Colis_internals.Options.get_contents () 14 | |> String.concat "\n" 15 | in 16 | fun sta -> 17 | let sta = print_stdout ~newline:true str sta in 18 | [sta, Ok true] 19 | ) 20 | else 21 | incomplete ~utility "-L about an other package" 22 | 23 | | "-L" :: _ -> 24 | error ~utility "option -L expects exactly one argument" 25 | | ["--compare-versions"; _v1; _op; _v2] -> 26 | incomplete ~utility "support for --compare-versions not yet implemented" 27 | | "--compare-versions" :: _ -> 28 | error ~utility "option --compare-versions expects exactly three arguments" 29 | | [] -> 30 | (* TODO: return error state *) 31 | error ~utility "no argument found" 32 | | arg :: _ -> 33 | unknown ~utility ("argument: " ^ arg) 34 | in 35 | aux ctx.args 36 | -------------------------------------------------------------------------------- /src/symbolic/filesystemSpec.mli: -------------------------------------------------------------------------------- 1 | (** Simple specification of filessytems (with a translation to feature constraints) *) 2 | type t 3 | 4 | (** Empty filesystem (i.e., only the root directory) *) 5 | val empty : t 6 | 7 | (** Add a directory to a FS spec at the given relative path to root, defined by a list of 8 | feature names. 9 | 10 | @raise Invalid_argument if any super-path is already specified as a file. *) 11 | val add_dir : string list -> t -> t 12 | 13 | (** Add a file to a FS spec at the given relative path to root. 14 | 15 | @raise Invalid_argument if any super-path of the parent is specified as a file or the 16 | path is already specified as a directory. *) 17 | val add_file : string list -> t -> t 18 | 19 | (** Adds files and directories from a channel. One line per entry, all lines start with 20 | '/' and directories end with '/' 21 | 22 | @raise Invalid_argument like functions [add_dir] and [add_file ]*) 23 | val add_channel : in_channel -> t -> t 24 | 25 | (** Compile the specification of a filesystem into a feature constraint at the given root 26 | variable.*) 27 | val compile_constraints : Colis_constraints.Var.t -> t -> Colis_constraints.t 28 | 29 | (** Print the FS spec as a tree *) 30 | val pp : Format.formatter -> t -> unit 31 | -------------------------------------------------------------------------------- /src/symbolic/collection/why3session.xml: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # Targets to replay proofs for the concrete interpreter 2 | replay-concrete-proofs=$(patsubst %, replay-concrete-proof-%, auxiliaries semantics interpreter) 3 | replay-symbolic-proofs=$(patsubst %, replay-symbolic-proof-%, collection symbolicInterpreter) 4 | 5 | .PHONY: build test doc clean install uninstall \ 6 | extract-why3 clean-why3 replay-proofs \ 7 | $(replay-concrete-proofs) $(replay-symbolic-proofs) 8 | 9 | build: extract-why3 10 | dune build @install 11 | ln -sf _build/install/default/bin . 12 | 13 | clean: clean-why3 14 | dune clean 15 | rm -f bin doc 16 | 17 | install: 18 | dune install 19 | 20 | uninstall: 21 | dune uninstall 22 | 23 | doc: build 24 | dune build @doc 25 | [ -e doc ] || ln -s _build/default/_doc/_html doc 26 | 27 | test: build 28 | dune runtest 29 | 30 | ## Extract Why3 to OCaml 31 | 32 | extract-why3: 33 | mkdir -p src/why3 34 | rm -f src/why3/* 35 | why3 extract --modular --recursive \ 36 | -D ocaml64 \ 37 | -D src/language/driver.drv \ 38 | -D src/concrete/driver.drv \ 39 | -D src/symbolic/driver.drv \ 40 | -L src/language \ 41 | -L src/concrete \ 42 | -L src/symbolic \ 43 | -o src/why3 \ 44 | interpreter.Interpreter \ 45 | symbolicInterpreter.Interpreter 46 | 47 | clean-why3: 48 | rm -rf src/why3 49 | 50 | ## Replay Why3 proofs 51 | 52 | replay-proofs: $(replay-concrete-proofs) $(replay-symbolic-proofs) 53 | 54 | $(replay-concrete-proofs): replay-concrete-proof-%: src/concrete/%.mlw src/concrete/%/why3session.xml 55 | why3 replay --use-steps --quiet \ 56 | -L src/language -L src/concrete \ 57 | src/concrete/$* 58 | 59 | $(replay-symbolic-proofs): replay-symbolic-proof-%: src/symbolic/%.mlw src/symbolic/%/why3session.xml 60 | why3 replay --use-steps --quiet \ 61 | -L src/language -L src/concrete -L src/symbolic \ 62 | src/symbolic/$* 63 | -------------------------------------------------------------------------------- /colis-language.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | 3 | name: "CoLiS-language" 4 | version: "0.1" 5 | 6 | synopsis: "Syntax, parsers and interpreters for the CoLiS language" 7 | description: """ 8 | Syntax, parsers and interpreters for the CoLiS language 9 | """ 10 | 11 | homepage: "https://github.com/colis-anr/colis-language" 12 | bug-reports: "https://github.com/colis-anr/colis-language/issues" 13 | 14 | authors: [ 15 | "Benedikt Becker " 17 | ] 18 | 19 | maintainer: "Nicolas Jeannerod " 20 | 21 | pin-depends: [ 22 | [ "morbig.dev" "git+https://github.com/colis-anr/morbig.git" ] 23 | [ "morsmall.dev" "git+https://github.com/colis-anr/morsmall.git" ] 24 | [ "colis-constraints.dev" "git+https://github.com/colis-anr/colis-constraints.git" ] 25 | [ "why3.dev" "git+https://gitlab.inria.fr/why3/why3.git#268e19920" ] # Will be 1.3 26 | ] 27 | 28 | depexts: [ 29 | # For the installation of the automatic provers, see Dockerfile 30 | ["wget" "autoconf" "automake"] { os-distribution = "ubuntu" 31 | | os-distribution = "debian" 32 | | os-distribution = "archlinux"} 33 | ] 34 | 35 | depends: [ 36 | "batteries" 37 | "camlzip" {(build | with-test) & = "1.07"} # Version fixed for alt-ergo 2.2.0 38 | "cmdliner" 39 | "colis-constraints" {= "dev"} 40 | "morbig" {= "dev"} 41 | "morsmall" {= "dev"} 42 | "ocaml" {build & >= "4.05"} 43 | "odoc" {with-doc} 44 | "ppx_deriving" {build} 45 | "ppx_protocol_conv_yaml" {with-test} 46 | "why3" {= "dev" & (build | with-test)} 47 | "yaml" {with-test & >= "1.0.0"} 48 | "zarith" 49 | ] 50 | 51 | build: [ 52 | [make] 53 | ] 54 | -------------------------------------------------------------------------------- /src/constraints/model/doc/packages.tex: -------------------------------------------------------------------------------- 1 | \usepackage[T1]{fontenc} 2 | \usepackage[utf8]{inputenc} 3 | 4 | \usepackage{xargs} 5 | \usepackage{stmaryrd} 6 | 7 | \usepackage{amsmath} 8 | \usepackage{amssymb} 9 | \usepackage{mathpartir} 10 | \usepackage{booktabs} 11 | \usepackage{bookmark} 12 | 13 | \usepackage{hyperref} 14 | \hypersetup{bookmarks,unicode,colorlinks=true, 15 | citecolor=blue, 16 | urlcolor=blue, 17 | linkcolor=blue} 18 | %final} 19 | 20 | %%%%%% To display ORCID Logo with link, Please add below definition and copy the ORCID_Color.eps in the manuscript package %%%%% 21 | 22 | \makeatletter 23 | \def\UrlFont{\color{blue}\rmfamily} 24 | \def\orcidID#1{\smash{\href{http://orcid.org/#1}{\protect\raisebox{-1.25pt}{\protect\includegraphics{orcid_color-eps-converted-to.pdf}}}}} 25 | \makeatother 26 | 27 | \usepackage{url} 28 | 29 | 30 | \usepackage[final]{graphicx} 31 | 32 | \usepackage{todonotes} %% FIXME: only for draft; or [obeyDraft] 33 | % \usepackage[disable]{todonotes} %% use [disable] to hide the notes 34 | 35 | \usepackage{tikz} 36 | \usetikzlibrary{positioning} 37 | \usetikzlibrary{shapes,arrows} 38 | 39 | \tikzstyle{tool} = [rectangle, rounded corners, draw, fill=red!10, 40 | text centered] 41 | \tikzstyle{line} = [draw, -triangle 45] 42 | \tikzstyle{elem} = [ellipse, draw, top color=green!5, bottom color=green!15, 43 | text centered, rounded corners] 44 | \tikzstyle{fcstate} = [rectangle, rounded corners, draw, text centered] 45 | 46 | \usepackage{syntax} 47 | 48 | \usepackage[final]{listings} 49 | \lstset{ 50 | basicstyle=\footnotesize\ttfamily, 51 | keywordstyle=\bf, 52 | showspaces=false, 53 | showstringspaces=false, 54 | } 55 | 56 | %\usepackage{paralist} 57 | 58 | \usepackage{wrapfig} 59 | \setlength{\intextsep}{1em} %% Length before and after wrapfigure in text. 60 | %\setlength{\belowcaptionskip}{-1eX} 61 | 62 | \usepackage[normalem]{ulem} 63 | -------------------------------------------------------------------------------- /src/constraints/model/mutate.ml: -------------------------------------------------------------------------------- 1 | open Common 2 | open Process_atom 3 | 4 | let get_reachable_from_v v = 5 | let v_reach = ref VSet.empty in 6 | v_reach := VSet.add v (!v_reach); 7 | let rec get_reach (v)= 8 | let ll = FMap.bindings ((find_node v).feat) in 9 | let rec helper ll = 10 | match ll with 11 | |[] -> () 12 | |(_,v2)::t ->v_reach := VSet.add v2 (!v_reach); 13 | get_reach (v2); 14 | helper t 15 | in helper ll 16 | in get_reach v;(!v_reach) 17 | 18 | let mutate (clau:clause) (num:int) (rootb)= 19 | let clau = ref clau in 20 | let v_reach = ref (get_reachable_from_v rootb) in 21 | let v_max_old = !v_max in 22 | let rec add_noise x safety = 23 | match (x,safety) with 24 | |(x,safety) when (x > num) || (safety>(num*10)) -> (!clau) 25 | |(x,safety) -> let v1 = !v_min + Random.int (!v_max - !v_min) in 26 | if (not (VSet.mem v1 !v_reach))then add_noise x (safety+1) 27 | else if ((v1<=v_max_old)&&(((find_node v1).fen_p) || ((find_node v1).kind = Reg))) then add_noise x (safety+1) 28 | else if((Random.int 10) < 8) then 29 | (v_max := !v_max + 1; 30 | let f_new = "GenFto"^(string_of_int !v_max) in 31 | v_all := VSet.add !v_max !v_all; 32 | v_reach := VSet.add !v_max !v_reach; 33 | var_map := VarMap.add !v_max (empty_node !v_max) (!var_map); 34 | clau := Pos(Feat(v1,f_new,!v_max)) :: (!clau); 35 | add_feat_to_node (Feat(v1,f_new,!v_max)); 36 | add_noise (x+1) (safety+1)) 37 | else 38 | (let f_new = "GenFAbs"^(string_of_int (Random.int !v_max)) in 39 | var_map := VarMap.add !v_max (empty_node !v_max) (!var_map); 40 | clau:= Pos(Abs(v1,f_new)) :: (!clau); 41 | add_abs_to_node (Abs(v1,f_new)); 42 | add_noise (x+1) (safety+1)) 43 | in add_noise 1 1 44 | -------------------------------------------------------------------------------- /src/internals/options.ml: -------------------------------------------------------------------------------- 1 | type unknown_behaviour = Exception | Incomplete | Error 2 | let unknown_behaviour = ref Exception 3 | let real_world = ref false 4 | let external_sources = ref "" 5 | let print_states_dir = ref "" 6 | 7 | let cpu_time_limit = ref infinity 8 | let memory_limit = ref max_int (* memory limit stored in words *) 9 | 10 | let set_memory_limit s = 11 | let l = String.length s in 12 | if l = 0 then 13 | (); 14 | let m = 15 | match s.[l-1] with 16 | | 'g' | 'G' -> 1073741824 17 | | 'm' | 'M' -> 1048576 18 | | 'k' | 'K' -> 1024 19 | | _ -> 1 20 | in 21 | let s = 22 | if m = 1 then 23 | s 24 | else 25 | String.sub s 0 (l - 1) 26 | in 27 | memory_limit := int_of_string s * m * 8 / Sys.word_size 28 | 29 | type 'a gs = 30 | { getter : unit -> 'a ; 31 | setter : 'a -> unit ; 32 | wither : 'b. 'a -> (unit -> 'b) -> 'b } 33 | 34 | let make_getters_setters str = 35 | let holder = ref None in 36 | let getter () = 37 | match !holder with 38 | | None -> raise (Arg.Bad (str ^ " has not been set yet")) 39 | | Some content -> content 40 | in 41 | let setter content = 42 | match !holder with 43 | | None -> holder := Some content 44 | | Some _ -> raise (Arg.Bad (str ^ " has already been set")) 45 | in 46 | let wither content f = 47 | let old = !holder in 48 | holder := Some content; 49 | let res = try Ok (f ()) with exn -> Error exn in 50 | holder := old; 51 | match res with Ok res -> res | Error exn -> raise exn 52 | in 53 | { getter ; setter ; wither } 54 | 55 | let (gs : string list gs) = make_getters_setters "Contents" 56 | let get_contents = gs.getter 57 | let set_contents = gs.setter 58 | let with_contents = gs.wither 59 | 60 | let (gs : string gs) = make_getters_setters "Package name" 61 | let get_package_name = gs.getter 62 | let set_package_name = gs.setter 63 | let with_package_name = gs.wither 64 | -------------------------------------------------------------------------------- /src/constraints/model/common.mli: -------------------------------------------------------------------------------- 1 | val cwd_s : string 2 | type feature = string 3 | 4 | val compare : feature -> feature -> int 5 | 6 | module type OrderedType = sig 7 | type t 8 | val compare : t -> t -> int 9 | end 10 | 11 | module Feat : OrderedType with type t = feature 12 | 13 | module FSet : Set.S with type elt = feature 14 | module FMap : Map.S with type key = feature 15 | 16 | 17 | type var = int 18 | val compare2 : var -> var -> int 19 | 20 | module Var: OrderedType with type t = var 21 | 22 | module VarMap : Map.S with type key = var 23 | module VSet : Set.S with type elt = var 24 | 25 | 26 | type kindt = Reg | Dir | Other | Unknown (*Unknown will be treated as Dir*) 27 | 28 | type node = { var_l: VSet.t; 29 | feat: var FMap.t; 30 | notfeat: (feature*var) list ; (*Not using Map as -x[f]y,-x[f]z can exists together*) 31 | equality: (FSet.t*var) list; 32 | sim: (FSet.t*var) list; 33 | fen_p: bool; 34 | fen : FSet.t; (*empty signifies no Fen specified so all allowed*) 35 | id : string; 36 | kind: kindt; 37 | } 38 | 39 | type atom = 40 | | Eq of var * var 41 | | Eqf of var * feature list * var 42 | | Feat of var * feature * var 43 | | Abs of var * feature 44 | | Fen of var * feature list 45 | | Sim of var * feature list * var 46 | | Kind of var * kindt 47 | | Maybe of var * feature * var (*Unimplemented*) 48 | 49 | type var_map_type = node VarMap.t 50 | 51 | type literal = 52 | |Pos of atom 53 | |Neg of atom 54 | 55 | type clause = literal list 56 | 57 | val var_map:var_map_type ref 58 | val fBigSet: FSet.t ref 59 | val paths: (string*feature*var) list ref 60 | val v_all: VSet.t ref 61 | val v_max: var ref 62 | val v_min: var ref 63 | val print_collect: string ref 64 | val file1 : string 65 | val out_f_l: out_channel 66 | 67 | val close_file: unit-> unit 68 | 69 | val list_remove : 'a -> 'a list -> 'a list 70 | 71 | val find_node: var -> node 72 | val empty_node: var -> node -------------------------------------------------------------------------------- /src/concrete/auxiliaries.mlw: -------------------------------------------------------------------------------- 1 | module OptionGet 2 | 3 | use option.Option 4 | 5 | let function option_get default opt = 6 | match opt with 7 | | Some x -> x 8 | | None -> default 9 | end 10 | end 11 | 12 | (** Used for proving the soundness of interpreting IForeach *) 13 | module TakeDrop 14 | use int.Int 15 | use list.List 16 | use list.Append 17 | use list.Length 18 | use list.Nth 19 | use list.NthNoOpt 20 | 21 | function drop (n: int) (l: list 'a) : list 'a = 22 | if n = 0 then 23 | l 24 | else 25 | match l with 26 | | Cons _ l' -> drop (n-1) l' 27 | | Nil -> Nil 28 | end 29 | 30 | lemma drop0: forall l: list 'a. drop 0 l = l 31 | 32 | lemma drop_all: forall l: list 'a, i. 33 | i >= length l -> drop i l = Nil 34 | 35 | lemma nth_drop: forall l[@induction]: list 'a, i. 36 | 0 <= i < length l -> 37 | drop i l = Cons (NthNoOpt.nth i l) (drop (i+1) l) 38 | 39 | function take (n: int) (l: list 'a) : list 'a = 40 | if n = 0 then 41 | Nil 42 | else 43 | match l with 44 | | Cons x l' -> Cons x (take (n-1) l') 45 | | Nil -> Nil 46 | end 47 | 48 | lemma take_0: forall l: list 'a. take 0 l = Nil 49 | 50 | lemma take_all: forall l[@induction]: list 'a, i. 51 | i >= length l -> take i l = l 52 | 53 | lemma take_drop: forall l[@induction] : list 'a, i. 54 | l = take i l ++ drop i l 55 | 56 | lemma take_nth_drop: forall l: list 'a, i. 57 | 0 <= i < length l -> 58 | l = take i l ++ Cons (NthNoOpt.nth i l) (drop (i+1) l) 59 | 60 | lemma take_nth: forall l: list 'a, i. 61 | 0 <= i < length l - 1 -> 62 | take (i+1) l = take i l ++ Cons (NthNoOpt.nth i l) Nil 63 | 64 | use option.Option 65 | 66 | lemma some_nth: forall l[@induction]: list 'a, i. 67 | 0 <= i < length l <-> 68 | Nth.nth i l <> None 69 | 70 | lemma nth_nth: forall l[@induction] i, x:'a. 71 | Nth.nth i l = Some x -> NthNoOpt.nth i l = x 72 | end -------------------------------------------------------------------------------- /src/constraints/model/test/Test_cmd.py: -------------------------------------------------------------------------------- 1 | import os 2 | import random 3 | commands = ['mkdir','touch','mv','cp','rm','test'] 4 | arg_no = [1, 1, 2, 2, 1, 1] 5 | is_file = [0, 1, 2, 2, 2, 2] 6 | options = [['', ''], ['', ''], ['', ''], ['', '-r '], ['', '-r '], ['-f ', '-d ', '-e ']] 7 | no_of_cmd = 15 8 | 9 | root = "/bin" 10 | dirs = [] 11 | 12 | def add_dir(link): 13 | if(len(dirs)>1000): 14 | return 15 | curr = os.listdir(link) 16 | for i in curr: 17 | try: 18 | if i not in dirs and len(i)<15: 19 | dirs.append(i) 20 | add_dir(link+"/"+i) 21 | except: 22 | pass 23 | 24 | add_dir(root) 25 | 26 | 27 | def gen_link(): 28 | link = "" 29 | rel = ['..', '.'] 30 | link_len = 1+int(random.random()*10) 31 | for i in range(link_len): 32 | curr = None 33 | if random.random()<0.1: 34 | curr = rel 35 | else: 36 | curr = dirs 37 | link += curr[int(len(curr) * random.random()) - 1] 38 | if not i == link_len - 1: 39 | link += "/" 40 | return link 41 | 42 | comms = "" 43 | for i in range(no_of_cmd): 44 | inx = int(random.random()*len(commands)) 45 | comms += commands[inx] 46 | will_be_file = False 47 | if is_file[inx]==2: 48 | will_be_file = random.random()<0.5 49 | elif is_file[inx] == 1: 50 | will_be_file = True 51 | link = gen_link() 52 | if not will_be_file: 53 | link += "/" 54 | if not commands[inx] == 'test': 55 | comms += " " + options[inx][not will_be_file] + link 56 | else: 57 | comms += " " + (options[inx][not will_be_file] if random.random()>0.5 else options[inx][2]) + link 58 | 59 | if will_be_file: 60 | while comms.endswith(".."): 61 | comms = comms[:-4] 62 | if arg_no[inx] == 2: 63 | comms += " "+gen_link()+"/" 64 | comms += "\n" 65 | 66 | file_info = open("cmd.dat", "w+") 67 | file_info.write(comms) 68 | file_info.flush() 69 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # The CoLiS language 2 | 3 | Syntax, parsers, and interpreters for the CoLiS language. 4 | 5 | ## Notes 6 | 7 | The file [NOTES.org](NOTES.org) documents discussion, statistics, decisions, and 8 | hypotheses about the design of the CoLiS language. Headings from the notes can be 9 | referenced in the source code to clarify the implentation using the format 10 | `NOTES[Heading name]`. 11 | 12 | 13 | ## Tests 14 | 15 | The tests are run using `make test`. This executes every CoLiS file 16 | (with extension `.cls`) and every Shell file (extension `.sh`) in the 17 | directory `tests/`. The behaviour of the execution, composed by the 18 | return code and the stdout, is compared with the behaviour given in an 19 | accompanying oracle file (`NAME.meta` for `NAME.cls` or `NAME.sh`). 20 | 21 | The oracle file is a Yaml-serialised file of the following format: 22 | 23 | ```yaml 24 | input: 25 | stdin: 26 | arguments: 27 | 28 | output: 29 | stdout: 30 | stderr: 31 | return_code: 32 | ``` 33 | 34 | ## Return Codes 35 | 36 | The tool uses different return codes for different kind of errors. 37 | 38 | | Code | Meaning 39 | |------|--------- 40 | | 0 | Concrete execution: Execution resulted in success 41 | | | Symbolic execution: Only success states found 42 | | 1 | Concrete execution: Execution resulted in error 43 | | | Symbolic execution: At least one error state found 44 | | 2 | Unhandled/unexpected OCaml exception 45 | | 3 | Error in command-line parsing 46 | | 4 | Error while reading input file 47 | | 5 | Error in parsing (Shell or CoLiS) 48 | | 6 | Error in conversion 49 | | 7 | Unsupported utility or argument (only with option --fail-on-unknown-utility) 50 | | 8 | *not used anymore* 51 | | 9 | Error in pretty-printing (Shell or CoLiS) 52 | | 10 | Symbolic execution: no error states found, but some execution were not covered by symbolic execution 53 | | 11 | Symbolic execution: CPU time limit exceeded 54 | | 12 | Symbolic execution: memory limit exceeded 55 | -------------------------------------------------------------------------------- /src/constraints/model/README.md: -------------------------------------------------------------------------------- 1 | 2 | Package for model generation and specification testing 3 | 4 | Documentation is available in 'doc/code.tex'. 5 | 6 | Experiments can be performed in a docker container using 7 | the follozing steps: 8 | 9 | 0. Install docker 10 | ''''''''''''''''' 11 | Use instructions from https://docs.docker.com/engine/install 12 | 13 | 1. Build the docker image 14 | ''''''''''''''''''''''''' 15 | In the directory colis-language.git, execute: 16 | 17 | sudo docker build -t [image-tag] . 18 | 19 | which uses 'Dockerfile' to create an image from colis-language repository 20 | based on 'ocaml/opam2:latest'. This may take a while. 21 | 22 | To remove an image, stop all the containers using this image (see below) 23 | and use the command : 24 | 25 | sudo docker images 26 | 27 | to list the existing images, and the command 28 | 29 | sudo docker rmi xxxx 30 | 31 | to remove the image of ID xxxx. 32 | 33 | 34 | 2. Run a docker container (from an image) 35 | ''''''''''''''''''''''''''''''''''''''''' 36 | Use the command 37 | 38 | sudo docker run -it [image-tag] 39 | 40 | to obtain a terminal runing the image created. 41 | To remove a comtainer, list all of them with 42 | 43 | sudo docker container ls -a 44 | 45 | and remove the ones with the id xxxx 46 | 47 | sudo docker container rm xxxx 48 | 49 | 50 | 3. Compile the test engine 51 | '''''''''''''''''''''''''' 52 | In the terminal corresponding to the container, go to the directory 53 | colis-language/src/constraints/model 54 | (called from now MDIR) 55 | 56 | cd colis-language/src/constraints/model 57 | 58 | Compile the engine using 59 | 60 | dune build engine.exe 61 | 62 | 4. Test one command 63 | ''''''''''''''''''' 64 | 65 | Create a file 'cmd.dat' where the commad is in the first line. 66 | 67 | Execute the test using 68 | 69 | dune exec ./engine.exe [if_mutate] [if_verbose] 70 | 71 | where the options are 72 | if_mutate 0 not to apply test mutation, by default 73 | if_verbose 1 print explanations, by default 74 | 75 | 76 | To test multiple commands, write each command on a line of file 'cmd.dat' 77 | 78 | -------------------------------------------------------------------------------- /src/constraints/model/convert.ml: -------------------------------------------------------------------------------- 1 | open Common 2 | 3 | let feat_to_string (x:Colis_constraints_common.Feat.t):string = (Colis_constraints_common.Feat.to_string x) 4 | 5 | let var_to_int (x:Colis_constraints_common.Var.t):int = 6 | let rec helper in_s out_s= 7 | if((String.length in_s) < 3) then 8 | int_of_string out_s 9 | else 10 | let ch = String.sub in_s 0 3 in 11 | let digit = 12 | (match ch with 13 | | "₀" -> "0" 14 | | "₁" -> "1" 15 | | "₂" -> "2" 16 | | "₃" -> "3" 17 | | "₄" -> "4" 18 | | "₅" -> "5" 19 | | "₆" -> "6" 20 | | "₇" -> "7" 21 | | "₈" -> "8" 22 | | "₉" -> "9" 23 | | _ -> assert false) in 24 | let in_s = String.sub in_s 3 ((String.length in_s) - 3) in 25 | helper in_s (out_s^digit) 26 | in 27 | (helper (Colis_constraints_common.Var.to_string x) "") 28 | 29 | let fset_to_fset (x:Colis_constraints_common.Feat.Set.t): string list = 30 | let lis = Colis_constraints_common.Feat.Set.elements x in 31 | let rec helper = function 32 | |[]-> [] 33 | |h::t -> (feat_to_string h)::helper t 34 | in (helper lis) 35 | 36 | let kind_to_kind (x:Colis_constraints_common.Kind.t): Common.kindt = 37 | match x with 38 | | Dir -> Dir 39 | | Reg -> Reg 40 | | Char | Sock | Pipe | Symlink | Block -> Other 41 | 42 | let atom_to_Atom (x: Colis_constraints_common.Atom.t): Common.atom = 43 | match x with 44 | | Eq(v1,v2) -> Eq(var_to_int v1,var_to_int v2) 45 | | Feat(v1,f,v2) -> Feat (var_to_int v1,feat_to_string f,var_to_int v2) 46 | | Abs(v1,f) -> Abs(var_to_int v1,feat_to_string f) 47 | | Maybe (v1,f,v2) -> Maybe (var_to_int v1,feat_to_string f,var_to_int v2) 48 | | Kind(v1,k) -> Kind(var_to_int v1,(kind_to_kind k)) 49 | | Fen(v1,f) -> Fen(var_to_int v1,fset_to_fset f) 50 | | Sim(v1,f,v2) -> Sim(var_to_int v1,fset_to_fset f,var_to_int v2) 51 | 52 | let rec clause_to_clause (x: Colis_constraints_common.Literal.t list): Common.literal list = 53 | match x with 54 | | [] -> [] 55 | | Pos a::t -> Pos (atom_to_Atom a):: clause_to_clause t 56 | | Neg a::t -> Neg (atom_to_Atom a):: clause_to_clause t 57 | 58 | -------------------------------------------------------------------------------- /src/constraints/model/doc/constraints.tex: -------------------------------------------------------------------------------- 1 | \newcommand{\features}{\mathcal{F}} 2 | 3 | \newcommand{\featuretrees}{\mathcal{FT}} 4 | \newcommand{\treemodel}{\featuretrees} 5 | 6 | %% Literals 7 | 8 | \newcommand{\Eq}[3][]{#2 \doteq_{#1} #3} 9 | \newcommand{\NEq}[3][]{#2 \not\doteq_{#1} #3} 10 | \newcommand{\Feat}[3]{#1[#2]#3} 11 | \newcommand{\NFeat}[3]{\lnot \Feat{#1}{#2}{#3}} 12 | \newcommand{\Abs}[2]{#1[#2]\!\uparrow} 13 | \newcommand{\NAbs}[2]{\lnot \Abs{#1}{#2}} 14 | \newcommand{\Maybe}[3]{#1[#2]#3?} 15 | \newcommand{\NMaybe}[3]{\lnot \Maybe{#1}{#2}{#3}} 16 | 17 | \newcommand{\Fen}[2]{#1[#2]} 18 | \newcommand{\NFen}[2]{\lnot \Fen{#1}{#2}} 19 | \newcommand{\Sim}[3]{#1 \mathrel{\sim_{#2}} #3} 20 | \newcommand{\NSim}[3]{#1 \not\sim_{#2} #3} 21 | 22 | \newcommand{\Kind}[2]{\texttt{#1}(#2)} 23 | \newcommand{\NKind}[2]{\lnot \Kind{#1}{#2}} 24 | \newcommand{\Reg}[1]{\Kind{reg}{#1}} 25 | \newcommand{\NReg}[1]{\lnot \Reg{#1}} 26 | \newcommand{\Dir}[1]{\Kind{dir}{#1}} 27 | \newcommand{\NDir}[1]{\lnot \Dir{#1}} 28 | 29 | \newcommand{\ruleName}[1]{\textsc{\scriptsize #1}} 30 | \newcommand{\transformsto}{\Rightarrow} 31 | \newcommand{\replace}[3]{#1\{#2\mapsto #3\}} 32 | 33 | % % logic 34 | % \newcommand{\False}{\bot} 35 | % \newcommand{\existsclose}[1]{\tilde\exists #1} 36 | % \newcommand{\forallclose}[1]{\tilde\forall #1} 37 | % \renewcommand{\implies}{\rightarrow} 38 | % \newcommand{\equivalent}{\leftrightarrow} 39 | % 40 | % \newcommand{\qqquad}{\quad\quad\quad} 41 | % \newcommand{\eq}{=} 42 | % 43 | % \newcommand{\vars}[1]{\mathcal{V}(#1)} 44 | \newcommand{\varso}{\mathcal{V}_o} 45 | % \newcommand{\feats}[1]{\mathcal{F}(#1)} 46 | % \newcommand{\card}{\texttt{card}} 47 | % 48 | % \newcommand{\modequiv}{\mathrel{\models\kern -1.5pt\mid}} 49 | % 50 | \newcommand{\dom}[1]{\texttt{dom}(#1)} 51 | % \renewcommand{\complement}[1]{#1^{c}} 52 | % \newcommand{\fathers}[2][]{\texttt{fathers}_{#1}(#2)} 53 | % 54 | % drawing trees 55 | \newenvironment{tree}[2][]% 56 | {\begin{tikzpicture}[baseline=(myroot.base),level distance=10mm,sibling distance=15mm,#1] \node (myroot) {#2}}% 57 | {;\end{tikzpicture}} 58 | % 59 | \newcommand{\featl}[1]{edge from parent node[left,draw=none] {\(#1\)}} 60 | \newcommand{\featr}[1]{edge from parent node[right,draw=none] {\(#1\)}} 61 | -------------------------------------------------------------------------------- /src/symbolic/utilities/emacsPackage.ml: -------------------------------------------------------------------------------- 1 | open Format 2 | open SymbolicUtility.ConstraintsCompatibility 3 | 4 | module Install = struct 5 | let name = "/usr/lib/emacsen-common/emacs-package-install" 6 | 7 | let interprete preInst _postInst ctx args = 8 | let pkgName = match args with 9 | | [pkg] -> pkg 10 | | _ -> assert false 11 | in 12 | let pkgFile = String.concat "/" ["/var/lib/emacsen-common/state/package"; 13 | pkgName] 14 | in 15 | if preInst then 16 | (if_then_else 17 | (call "test" ctx ["-e"; pkgFile]) 18 | (call "rm" ctx [pkgFile]) 19 | (specification_cases [ 20 | success_case 21 | ~descr:(asprintf "emacs-package-install --preinst '%s': not found" 22 | pkgFile) 23 | noop 24 | ] 25 | ) 26 | ) 27 | else (* --postInst is optional *) 28 | (call "touch" ctx [pkgFile]) 29 | 30 | 31 | let interprete ctx : utility = 32 | let preInst = Cmdliner.Arg.(value & flag & info ["--preinst"]) in 33 | let postInst = Cmdliner.Arg.(value & flag & info ["--postinst"]) in 34 | cmdliner_eval_utility 35 | ~utility:name 36 | Cmdliner.Term.(const interprete $ preInst $ postInst) 37 | ctx 38 | 39 | end 40 | 41 | module Remove = struct 42 | let name = "/usr/lib/emacsen-common/emacs-package-remove" 43 | 44 | let interprete preRm ctx args = 45 | let pkgName = match args with 46 | | [pkg] -> pkg 47 | | _ -> assert false 48 | in 49 | let pkgFile = String.concat "/" ["/usr/lib/emacsen-common/packages/install"; 50 | pkgName] 51 | in 52 | (if_then_else 53 | (call "test" ctx ["-e"; pkgFile]) 54 | (call "rm" ctx [pkgFile]) 55 | (specification_cases [ 56 | success_case 57 | ~descr:(asprintf "emacs-package-install --preinst '%s': not found" 58 | pkgFile) 59 | noop 60 | ] 61 | ) 62 | ) 63 | 64 | let interprete ctx : utility = 65 | let preRm = Cmdliner.Arg.(value & flag & info ["--prerm"]) in 66 | cmdliner_eval_utility 67 | ~utility:name 68 | Cmdliner.Term.(const interprete $ preRm) 69 | ctx 70 | 71 | end 72 | -------------------------------------------------------------------------------- /src/symbolic/utilities/README.md: -------------------------------------------------------------------------------- 1 | How to Add a Utility 2 | ==================== 3 | 4 | A utility is defined as a module of signature: 5 | 6 | ```ocaml 7 | val name : string 8 | val interprete : context -> utility 9 | ``` 10 | 11 | where: 12 | 13 | - `context` provides information about the arguments, the current 14 | working directory and the environment in which the utility is 15 | executed. 16 | 17 | - `type utility = state -> (state * bool) list` 18 | 19 | One common problem in writing utilities is to handle arguments. For 20 | utilities following the XBD Utility Syntax Guidelines (that is, most 21 | of the POSIX or GNU utilities), cmdliner proves to be a good arguments 22 | parser. 23 | 24 | Let us give a simple example definition of `mkdir`. We assume here 25 | that we have functions: 26 | 27 | ```ocaml 28 | val mkdir : cwd:Path.normal -> string -> utility 29 | val mkdir_parents : cwd:Path.normal -> string -> utility 30 | ``` 31 | 32 | that take the current working directory and a path and returns the 33 | corresponding utility definition. We will first wrap them in only one 34 | interpretation function 35 | 36 | ```ocaml 37 | let interprete parents ctx args = 38 | multiple_times 39 | (if parents then mkdir_parents else mkdir) 40 | ctx.cwd args 41 | 42 | val interprete : bool -> context -> string list -> utility 43 | ``` 44 | 45 | that assumes arguments parsing and takes first all the flags (as 46 | booleans) then the context and then the positional arguments as a list 47 | of strings. We then wrap that one in a function doing the actual 48 | parsing with cmdliner 49 | 50 | ```ocaml 51 | let interprete ctx = 52 | let parents = Cmdliner.Arg.(value & flag & info ["p"; "parents"]) in 53 | cmdliner_eval_utility 54 | ~utility:"mkdir" 55 | Cmdliner.Term.(cons interprete & parents) 56 | ctx 57 | 58 | val interprete : context -> utility 59 | ``` 60 | 61 | This function takes only the context. It first defines a cmdliner flag 62 | `parents` that can be either `-p` or `--parents` (one letter arguments 63 | take one dash and can be combined, longer arguments take two 64 | dashes). It then calls `cmdliner_eval_utility`, a wrapper around 65 | `Cmdliner.Term.eval` for utilities. This function requires the 66 | utility's name (mainly for its error messages), a cmdliner definition 67 | of the function and its flags and the context. 68 | -------------------------------------------------------------------------------- /src/symbolic/utilities/touch.ml: -------------------------------------------------------------------------------- 1 | open Format 2 | open Colis_constraints 3 | open SymbolicUtility.ConstraintsCompatibility 4 | 5 | let name = "touch" 6 | 7 | let interp_touch1 cwd path_str : utility = 8 | (* FIXME: we can merge two cases here (parent path does not resolve & parent 9 | path isn't a directory) *) 10 | let strip_path = Path.strip_trailing_slashes path_str in 11 | let p = Path.from_string strip_path in 12 | match Path.split_last p with 13 | | None -> (* `touch ''` *) 14 | specification_cases [ 15 | error_case ~descr:"cannot touch '': No such file or directory" noop 16 | ] 17 | | Some (_q, (Up | Here)) -> 18 | specification_cases [ 19 | success_case 20 | ~descr:(asprintf "touch %a: path resolves" Path.pp p) 21 | begin fun root root' -> 22 | exists @@ fun y -> 23 | resolve root cwd p y & 24 | eq root root' 25 | end; 26 | error_case 27 | ~descr:(asprintf "touch %a: path does not resolve" Path.pp p) 28 | begin fun root root' -> 29 | noresolve root cwd p & 30 | eq root root' 31 | end 32 | ] 33 | | Some (q, Down f) -> 34 | specification_cases [ 35 | success_case 36 | ~descr:(asprintf "touch %a: path resolves" Path.pp p) 37 | begin fun root root' -> 38 | exists @@ fun y -> 39 | resolve root cwd p y & 40 | eq root root' 41 | end; 42 | success_case 43 | ~descr:(asprintf "touch %a: create file" Path.pp p) 44 | begin fun root root' -> 45 | exists3 @@ fun x x' y' -> 46 | resolve root cwd q x & 47 | dir x & 48 | abs x f & 49 | similar root root' cwd q x x' & 50 | sim x (Feat.Set.singleton f) x' & 51 | dir x' & 52 | feat x' f y' & 53 | reg y' 54 | end; 55 | error_case 56 | ~descr:(asprintf "touch %a: parent path does not resolve or resolves to dir" Path.pp p) 57 | begin fun root root' -> 58 | exists @@ fun x -> 59 | maybe_resolve root cwd q x 60 | & ndir x 61 | & eq root root' 62 | end 63 | ] 64 | 65 | let interprete ctx args = 66 | multiple_times (interp_touch1 ctx.cwd) args 67 | 68 | let interprete ctx : utility = 69 | cmdliner_eval_utility 70 | ~utility:name 71 | Cmdliner.Term.(const interprete) 72 | ctx 73 | -------------------------------------------------------------------------------- /src/constraints/model/common.ml: -------------------------------------------------------------------------------- 1 | let cwd_s = "/tmp/InnerTR/Inner2TR/Inner3TR" 2 | type feature = string 3 | let compare = compare 4 | 5 | module type OrderedType = sig 6 | type t 7 | val compare : t -> t -> int 8 | end 9 | 10 | module Feat = struct 11 | type t = feature 12 | let compare = compare 13 | end 14 | 15 | module FSet = Set.Make(Feat) 16 | module FMap = Map.Make(Feat) 17 | 18 | 19 | type var = int 20 | let compare2 = compare 21 | 22 | 23 | module Var = struct 24 | type t = var 25 | let compare = compare2 26 | end 27 | 28 | module VarMap = Map.Make(Var) 29 | module VSet = Set.Make(Var) 30 | 31 | type kindt = Reg | Dir | Other | Unknown (*Unknown will be treated as Dir*) 32 | 33 | type node = { var_l: VSet.t; 34 | feat: var FMap.t; 35 | notfeat: (feature*var) list ; (*Not using Map as -x[f]y,-x[f]z can exists together*) 36 | equality: (FSet.t*var) list; 37 | sim: (FSet.t*var) list; 38 | fen_p: bool; 39 | fen : FSet.t; (*empty signifies no Fen specified so all allowed*) 40 | id : string; 41 | kind: kindt; 42 | } 43 | 44 | (* 45 | type fT = |Leaf 46 | |Node of (var * (fT FMap.t)) 47 | *) 48 | type atom = 49 | | Eq of var * var 50 | | Eqf of var * feature list * var 51 | | Feat of var * feature * var 52 | | Abs of var * feature 53 | | Fen of var * feature list 54 | | Sim of var * feature list * var 55 | | Kind of var * kindt 56 | | Maybe of var * feature * var (*Unimplemented*) 57 | 58 | type var_map_type = node VarMap.t 59 | 60 | type literal = 61 | |Pos of atom 62 | |Neg of atom 63 | 64 | type clause = literal list 65 | 66 | let (var_map:var_map_type ref) = ref VarMap.empty 67 | let fBigSet = ref FSet.empty 68 | let paths = ref [] 69 | let v_all = ref VSet.empty 70 | let v_max = ref 0 71 | let v_min = ref max_int 72 | let print_collect = ref "" 73 | let file1 = "print.dat" 74 | let out_f_l = open_out file1 75 | 76 | let close_file () = close_out out_f_l 77 | 78 | let rec list_remove ele = function 79 | |[] -> [] 80 | |h::t when (h=ele) -> list_remove ele t 81 | |h::t -> h::list_remove ele t 82 | 83 | let find_node v1 = 84 | let a = VarMap.find_opt v1 !var_map in 85 | match a with 86 | | None -> failwith ("Could not find Var"^(string_of_int v1)) 87 | | Some nod -> nod 88 | 89 | let empty_node v:node = {var_l = VSet.of_list [v];feat = FMap.empty;equality = [];notfeat=[];sim = [];fen = FSet.empty;fen_p=false;id = "";kind = Unknown} 90 | 91 | -------------------------------------------------------------------------------- /src/symbolic/collection.mlw: -------------------------------------------------------------------------------- 1 | module Collection 2 | 3 | use list.ListRich as L 4 | use set.Fset as S 5 | use int.Int 6 | 7 | type t 'a 8 | 9 | (** Membership is all we have to characterize a collection *) 10 | val predicate mem (x: 'a) (c: t 'a) 11 | 12 | predicate (==) (s1 s2: t 'a) = 13 | forall x: 'a. mem x s1 <-> mem x s2 14 | 15 | (* Can it be a lemma? Would require propositional extensionality? *) 16 | axiom extensionality: forall s1 s2: t 'a. s1 == s2 -> s1 = s2 17 | 18 | val function of_list (l: L.list 'a) : t 'a 19 | ensures { forall x. L.mem x l <-> mem x result } 20 | 21 | val function to_list (c: t 'a) : L.list 'a 22 | ensures { forall x. mem x c <-> L.mem x result } 23 | 24 | val constant size (_: t 'a) : int 25 | ensures { 0 <= result } 26 | 27 | val constant empty : t 'a 28 | ensures { forall x. not mem x result } 29 | ensures { size result = 0 } 30 | 31 | val function add (x: 'a) (c: t 'a) : t 'a 32 | ensures { mem x result } 33 | ensures { forall y. mem y c -> mem y result } 34 | ensures { forall y. mem y result -> x = y \/ mem y c } 35 | 36 | val function singleton (x: 'a) : t 'a 37 | ensures { mem x result } 38 | ensures { forall y. mem y result -> y = x } 39 | ensures { size result = 1 } 40 | 41 | val function map (f: 'a -> 'b) (c: t 'a) : t 'b 42 | ensures { forall x. mem x c -> mem (f x) result } 43 | ensures { forall y. mem y result -> exists x. mem x c /\ y = f x } 44 | 45 | val function filter (p: 'a -> bool) (c: t 'a) : t 'a 46 | ensures { forall x. mem x c -> p x -> mem x result } 47 | ensures { forall x. not p x -> not mem x result } 48 | ensures { forall x. mem x result -> p x /\ mem x c } 49 | 50 | val function partition (p: 'a -> bool) (c: t 'a) : (pos: t 'a, neg: t 'a) 51 | ensures { forall x. mem x c -> mem x pos \/ mem x neg } 52 | ensures { forall x. mem x pos -> p x /\ mem x c } 53 | ensures { forall x. mem x neg -> not p x /\ mem x c } 54 | 55 | val function union (c1 c2: t 'a) : t 'a 56 | ensures { forall x. mem x c1 -> mem x result } 57 | ensures { forall x. mem x c2 -> mem x result } 58 | ensures { forall x. mem x result -> mem x c1 \/ mem x c2 } 59 | 60 | lemma union_empty_left: forall c: t 'a. 61 | union empty c = c 62 | 63 | lemma union_empty_right: forall c: t 'a. 64 | union c empty = c 65 | 66 | lemma union_left: forall c1 c2: t 'a, x. 67 | mem x c1 -> mem x (union c1 c2) 68 | 69 | lemma union_right: forall c1 c2: t 'a, x. 70 | mem x c2 -> mem x (union c1 c2) 71 | 72 | val function bind (f: 'a -> t 'b) (c: t 'a) : t 'b 73 | ensures { forall x. mem x c -> forall y. mem y (f x) -> mem y result } 74 | ensures { forall y. mem y result -> exists x. mem x c /\ mem y (f x) } 75 | end -------------------------------------------------------------------------------- /src/language/syntaxHelpers.ml: -------------------------------------------------------------------------------- 1 | module Syntax = struct 2 | (* wrapped in a opened module not to polute the syntax helpers *) 3 | 4 | type split = Syntax__Syntax.split = 5 | | Split 6 | | DontSplit 7 | 8 | and string_expression = Syntax__Syntax.string_expression = 9 | | SLiteral of string 10 | | SVariable of string 11 | | SSubshell of instruction 12 | | SConcat of string_expression * string_expression 13 | | SArgument of (Syntax__Nat.nat [@opaque]) 14 | 15 | and list_expression = (* no extracted type *) 16 | (string_expression * split) list 17 | 18 | and function_definition = (* no extracted type *) 19 | string * instruction 20 | 21 | and return_code = Syntax__Syntax.return_code = 22 | | RSuccess 23 | | RFailure 24 | | RPrevious 25 | 26 | and instruction = Syntax__Syntax.instruction = 27 | | IAssignment of string * string_expression 28 | | ISequence of instruction * instruction 29 | | ISubshell of instruction 30 | | IIf of instruction * instruction * instruction 31 | | INot of instruction 32 | | IPipe of instruction * instruction 33 | | IWhile of instruction * instruction 34 | | INoOutput of instruction 35 | | IForeach of string * list_expression * instruction 36 | | ICallUtility of string * list_expression 37 | | ICallFunction of string * list_expression 38 | | IReturn of return_code 39 | | IExit of return_code 40 | | IShift of (Syntax__Nat.nat [@opaque]) option 41 | | IExport of string 42 | | ICd of string_expression 43 | 44 | and program = Syntax__Syntax.program = 45 | { function_definitions : function_definition list; 46 | instruction : instruction } 47 | 48 | [@@deriving 49 | visitors { variety = "map" }, 50 | visitors { variety = "reduce" } 51 | ] 52 | end 53 | open Syntax 54 | 55 | class virtual ['self] map = object 56 | inherit ['self] Syntax.map 57 | end 58 | class virtual ['self] reduce = object 59 | inherit ['self] Syntax.reduce 60 | end 61 | 62 | let sconcat_l = function 63 | | [] -> SLiteral "" 64 | | s :: ss -> List.fold_left (fun s1 s2 -> SConcat (s1, s2)) s ss 65 | 66 | let lliteral ?(split=false) lit = 67 | (SLiteral lit, if split then Split else DontSplit) 68 | 69 | let isequence_l = function 70 | | [] -> failwith "isequence_l" 71 | | i :: is -> List.fold_left (fun i1 i2 -> ISequence (i1, i2)) i is 72 | 73 | let icallutility name lexpr = ICallUtility(name, lexpr) 74 | 75 | let icolon = ICallUtility (":", []) 76 | let itrue = ICallUtility ("true", []) 77 | let ifalse = ICallUtility ("false", []) 78 | 79 | let ior (i1, i2) = IIf (i1, icolon, i2) 80 | let iand (i1, i2) = IIf (i1, i2, INot icolon) 81 | 82 | let program ?(function_definitions=[]) instruction = 83 | { function_definitions ; instruction } 84 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | ## ============================== [ Basis ] ================================= ## 2 | 3 | ARG TAG=latest 4 | ARG IMAGE=ocaml/opam2:$TAG 5 | 6 | FROM $IMAGE as basis 7 | 8 | ENV LANGUAGEDIR=/home/opam/colis-language 9 | ENV PROVERSDIR=/home/opam/provers 10 | 11 | ENV Z3="z3-4.8.7" 12 | ENV CVC4="cvc4-1.6" 13 | ENV ALTERGO="alt-ergo.2.3.0" 14 | 15 | ARG SWITCH= 16 | RUN [ -z "$SWITCH" ] || opam switch create "$SWITCH" 17 | 18 | WORKDIR /home/opam/opam-repository 19 | RUN git pull && opam update 20 | 21 | RUN sudo apt-get update 22 | 23 | ## ======================= [ Basis with dependencies ] ====================== ## 24 | 25 | FROM basis as basis-with-deps 26 | 27 | RUN sudo apt-get install -qq -yy curl autoconf automake 28 | RUN sudo apt-get install -qq -yy debianutils libgmp-dev m4 perl pkg-config zlib1g-dev 29 | 30 | WORKDIR "$LANGUAGEDIR" 31 | COPY colis-language.opam . 32 | RUN sudo chown -R opam . 33 | 34 | # Extract pin-depends from opam file and pin them 35 | RUN opam show . -f pin-depends: 2>/dev/null \ 36 | | tr -s '[]"' ' ' \ 37 | | xargs -n2 opam pin -n 38 | 39 | RUN opam install . --deps-only --with-test --with-doc 40 | 41 | ## ============================== [ Builder ] =============================== ## 42 | 43 | FROM basis-with-deps as builder 44 | 45 | COPY . . 46 | RUN sudo chown -R opam . 47 | 48 | RUN eval $(opam env) && make build 49 | 50 | ## =============================== [ Tester ] =============================== ## 51 | 52 | FROM builder as tester 53 | 54 | RUN eval $(opam env) && make doc && make test 55 | RUN eval $(opam env) && make install && make uninstall 56 | RUN eval $(opam env) && make clean 57 | 58 | ## ========================= [ Basis with provers ] ========================= ## 59 | 60 | FROM basis as basis-with-provers 61 | 62 | WORKDIR "$PROVERSDIR" 63 | RUN sudo chown -R opam . 64 | 65 | RUN opam depext -i "$ALTERGO" 66 | RUN eval $(opam env) && cp "$(which alt-ergo)" "$ALTERGO" 67 | 68 | RUN curl -sL -o "$CVC4" "http://cvc4.cs.stanford.edu/downloads/builds/x86_64-linux-opt/$CVC4-x86_64-linux-opt" 69 | RUN chmod +x "$CVC4" 70 | 71 | RUN curl -sL -o "$Z3.zip" "https://github.com/Z3Prover/z3/releases/download/$Z3/$Z3-x64-ubuntu-16.04.zip" 72 | RUN unzip -q "$Z3.zip" 73 | RUN cp "$Z3"-x64-ubuntu-16.04/bin/z3 "$Z3" 74 | 75 | ## =============================== [ Prover ] =============================== ## 76 | 77 | FROM builder as prover 78 | COPY --from=basis-with-provers "$PROVERSDIR" "$PROVERSDIR" 79 | 80 | RUN eval $(opam env) && why3 config --add-prover alt-ergo "$ALTERGO" "$PROVERSDIR"/"$ALTERGO" 81 | RUN eval $(opam env) && why3 config --add-prover cvc4 "$CVC4" "$PROVERSDIR"/"$CVC4" 82 | RUN eval $(opam env) && why3 config --add-prover z3 "$Z3" "$PROVERSDIR"/"$Z3" 83 | 84 | WORKDIR "$LANGUAGEDIR" 85 | RUN eval $(opam env) && make replay-proofs 86 | -------------------------------------------------------------------------------- /src/concrete/auxiliaries/why3session.xml: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | -------------------------------------------------------------------------------- /src/symbolic/utilities/mkdir.ml: -------------------------------------------------------------------------------- 1 | open Format 2 | open Colis_constraints 3 | open SymbolicUtility.Mixed 4 | 5 | let name = "mkdir" 6 | 7 | let interp_mkdir1 cwd path_str = 8 | let path = Path.strip_trailing_slashes path_str in 9 | let p = Path.from_string path in 10 | match Path.split_last p with 11 | | None -> 12 | specification_cases [ 13 | error_case ~descr:"mkdir: cannot create directory ''" noop 14 | ] 15 | | Some (q, (Here|Up)) -> 16 | specification_cases [ 17 | error_case 18 | ~descr:(asprintf "mkdir %a: target already exists" Path.pp q) 19 | (case_spec 20 | ~constraints:begin fun root root' -> 21 | exists @@ fun x -> 22 | resolve root cwd q x & 23 | dir x & 24 | eq root root' 25 | end ()); 26 | error_case 27 | ~descr:(asprintf "mkdir %a: path does not resolve" Path.pp q) 28 | (case_spec 29 | ~constraints:begin fun root root' -> 30 | exists @@ fun x -> 31 | maybe_resolve root cwd q x 32 | & ndir x 33 | & eq root root' 34 | end ()); 35 | ] 36 | | Some (q, Down f) -> 37 | specification_cases [ 38 | success_case 39 | ~descr:(asprintf "mkdir %a: create directory" Path.pp p) 40 | (case_spec 41 | ~transducers:() 42 | ~constraints:begin fun root root' -> 43 | exists3 @@ fun x x' y -> 44 | resolve root cwd q x & 45 | dir x & 46 | abs x f & 47 | similar root root' cwd q x x' & 48 | sim x (Feat.Set.singleton f) x' & 49 | dir x' & 50 | feat x' f y & 51 | dir y & 52 | fen y Feat.Set.empty 53 | end 54 | ()); 55 | error_case 56 | ~descr:(asprintf "mkdir %a: target already exists" Path.pp p) 57 | (case_spec 58 | ~constraints:begin fun root root' -> 59 | exists @@ fun x -> 60 | resolve root cwd q x & 61 | dir x & 62 | nabs x f & 63 | eq root root' 64 | end ()); 65 | error_case 66 | ~descr:(asprintf "mkdir %a: parent path is file or does not resolve" Path.pp p) 67 | (case_spec 68 | ~constraints:begin fun root root' -> 69 | exists @@ fun x -> 70 | maybe_resolve root cwd q x 71 | & ndir x 72 | & eq root root' 73 | end ()); 74 | ] 75 | 76 | let interprete parents ctx args : utility = 77 | if parents then incomplete ~utility:name "option -p" else 78 | multiple_times (interp_mkdir1 ctx.cwd) args 79 | 80 | let interprete ctx : utility = 81 | let parents = Cmdliner.Arg.(value & flag & info ["p"; "parents"]) in 82 | cmdliner_eval_utility 83 | ~utility:name 84 | Cmdliner.Term.(const interprete $ parents) 85 | ctx 86 | -------------------------------------------------------------------------------- /src/symbolic/filesystemSpec.ml: -------------------------------------------------------------------------------- 1 | open Format 2 | 3 | module SMap = Map.Make(String) 4 | 5 | type t = node SMap.t 6 | and node = Dir of t | File 7 | 8 | let empty : t = SMap.empty 9 | 10 | let rec add sofar typ path t = 11 | match path with 12 | | [] -> t 13 | | [name] -> 14 | if name = "." || name = ".." then 15 | ksprintf invalid_arg "FilesystemSpec.add: %s/%s" sofar name; 16 | begin match typ, SMap.find_opt name t with 17 | | _, None -> 18 | let n = match typ with `File -> File | `Dir -> Dir SMap.empty in 19 | SMap.add name n t 20 | | `Dir, Some (Dir _) -> t 21 | | `File, Some File -> t 22 | | `Dir, Some File -> ksprintf invalid_arg "FilesystemSpec.add: directory %s/%s is already a file" sofar name 23 | | `File, Some (Dir _) -> ksprintf invalid_arg "FilesystemSpec.add: file %s/%s is already a directory" sofar name 24 | end 25 | | name :: path' -> 26 | if name = "." || name = ".." then 27 | ksprintf invalid_arg "FilesystemSpec.add: %s/%s" sofar name; 28 | let t' = 29 | match SMap.find_opt name t with 30 | | None -> SMap.empty 31 | | Some (Dir t) -> t 32 | | Some File -> ksprintf invalid_arg "FilesystemSpec.add: directory %s/%s is already a file" sofar name 33 | in 34 | let t' = add (sofar^"/"^name) typ path' t' in 35 | SMap.add name (Dir t') t 36 | 37 | let add_file = add "" `File 38 | let add_dir = add "" `Dir 39 | 40 | let add_channel cin t = 41 | let t = ref t in 42 | try 43 | while true do 44 | let line = input_line cin in 45 | match String.split_on_char '/' line with 46 | | [] -> assert false 47 | | "" :: path -> (* Line starts with '/' *) 48 | t := begin match List.rev path with 49 | | [""] -> !t (* Empty line*) 50 | | "" :: path' -> (* Line ends with / *) 51 | add_dir (List.rev path') !t 52 | | path' -> (* Line does not end with '/' *) 53 | add_file (List.rev path') !t 54 | end 55 | | _ -> (* Line does not start with '/' *) 56 | ksprintf invalid_arg "FilesystemSpec.add_channel: line does not start with '/': %s" line 57 | done; 58 | assert false 59 | with End_of_file -> !t 60 | 61 | let rec compile_constraints root t = 62 | SMap.fold (fun name node -> Colis_constraints.and_ @@ compile_constraints_node root name node) t Colis_constraints.true_ 63 | 64 | and compile_constraints_node x name node = 65 | let open Colis_constraints in 66 | let f = Feat.from_string name in 67 | exists @@ fun y -> 68 | feat x f y & 69 | match node with 70 | | File -> ndir y 71 | | Dir t -> dir y & compile_constraints y t 72 | 73 | let rec pp fmt t = 74 | SMap.bindings t |> 75 | List.sort (fun (n1, _) (n2, _) -> String.compare n1 n2) |> 76 | List.iteri @@ fun ix (name, node) -> 77 | fprintf fmt "- @[%s%a@]" name pp_node node; 78 | if ix+1 <> SMap.cardinal t then 79 | pp_print_newline fmt () 80 | and pp_node fmt = function 81 | | File -> fprintf fmt "" 82 | | Dir t -> 83 | pp_print_char fmt '/'; 84 | if not (SMap.is_empty t) then 85 | fprintf fmt "@\n%a" pp t 86 | -------------------------------------------------------------------------------- /src/symbolic/utilities/rm.ml: -------------------------------------------------------------------------------- 1 | open Format 2 | open Colis_constraints 3 | open SymbolicUtility.ConstraintsCompatibility 4 | 5 | let name = "rm" 6 | 7 | let interp1 cwd arg : utility = 8 | let oq = Path.from_string arg in 9 | specification_cases @@ 10 | match Path.split_last oq with 11 | (* FIXME: Here, I reuse the same programming scheme as in mkdir. *) 12 | (* FIXME: Shouldn't we factorize it in a combinator? *) 13 | | None -> 14 | [error_case ~descr:"rm: invalid path ''" noop] 15 | | Some (_q, (Here|Up)) -> 16 | [error_case ~descr:"rm: cannot remove .. or ." noop] 17 | | Some (q, Down f) -> 18 | if String.equal "" (Colis_constraints_common.Feat.to_string f) 19 | then 20 | [error_case ~descr:"rm: cannot remove a directory" noop] 21 | else 22 | [success_case 23 | ~descr:(asprintf "rm %a: remove file" Path.pp oq) 24 | begin fun root root' -> 25 | exists3 @@ fun x x' y -> 26 | resolve root cwd oq y & ndir y 27 | & similar root root' cwd q x x' 28 | & sim x (Feat.Set.singleton f) x' 29 | & dir x' & abs x' f 30 | end; 31 | error_case 32 | ~descr:(asprintf "rm %a: target does not exist or is a directory" Path.pp oq) 33 | begin fun root root' -> 34 | exists @@ fun y -> 35 | maybe_resolve root cwd oq y 36 | & dir y 37 | & eq root root' 38 | end; 39 | ] 40 | 41 | let interp1_r cwd arg : utility = 42 | (* let oq = Path.from_string arg in *) 43 | let strip_arg = Path.strip_trailing_slashes arg in 44 | let oq = Path.from_string strip_arg in 45 | specification_cases @@ 46 | match Path.split_last oq with 47 | (* FIXME: Here, I reuse the same programming scheme as in mkdir. *) 48 | (* FIXME: Shouldn't we factorize it in a combinator? *) 49 | | None -> 50 | [error_case ~descr:"rm: invalid path ''" noop] 51 | | Some (_q, (Here|Up)) -> 52 | [error_case ~descr:"rm: cannot remove .. or ." noop] 53 | | Some (q, Down f) -> [ 54 | success_case 55 | ~descr:(asprintf "rm -r %a: remove file or directory" Path.pp oq) 56 | begin fun root root' -> 57 | exists3 @@ fun x x' y -> 58 | resolve root cwd oq y 59 | & similar root root' cwd q x x' 60 | & sim x (Feat.Set.singleton f) x' 61 | & dir x' & abs x' f 62 | end; 63 | error_case 64 | ~descr:(asprintf "rm -r %a: target does not exist" Path.pp oq) 65 | begin fun root root' -> 66 | noresolve root cwd oq & eq root root' 67 | end; 68 | ] 69 | 70 | let interprete recursive force ctx args = 71 | let rm = multiple_times ((if recursive then interp1_r else interp1) ctx.cwd) args in 72 | if force then uor rm (return true) else rm 73 | 74 | let interprete ctx : utility = 75 | let recursive = Cmdliner.Arg.(value & flag & info ["r"; "R"; "recursive"]) in 76 | let force = Cmdliner.Arg.(value & flag & info ["f"; "force"]) in 77 | cmdliner_eval_utility 78 | ~utility:name 79 | Cmdliner.Term.(const interprete $ recursive $ force) 80 | ctx 81 | -------------------------------------------------------------------------------- /src/language/colisLexer.mll: -------------------------------------------------------------------------------- 1 | (* File colis_lexer.mll *) 2 | { 3 | open ColisParser (* The type token is defined in colis_parser.mli *) 4 | exception LexerError of string 5 | 6 | let reserved_words = 7 | [ "arg", ARG ; 8 | "begin", BEGIN ; 9 | "call", CALL ; 10 | "do", DO ; 11 | "done", DONE ; 12 | "else", ELSE ; 13 | "embed", EMBED ; 14 | "end", END ; 15 | "endnooutput", ENDNOOUTPUT ; 16 | "endpipe", ENDPIPE ; 17 | "endprocess", ENDPROCESS ; 18 | "exit", EXIT ; 19 | "export", EXPORT ; 20 | "failure", FAILURE ; 21 | "function", FUNCTION ; 22 | "fi", FI ; 23 | "for", FOR ; 24 | "if", IF ; 25 | "in", IN ; 26 | "into", INTO ; 27 | "not", NOT ; 28 | "nooutput", NOOUTPUT ; 29 | "pipe", PIPE ; 30 | "previous", PREVIOUS ; 31 | "process", PROCESS ; 32 | "return", RETURN ; 33 | "shift", SHIFT ; 34 | "split", SPLIT ; 35 | "success", SUCCESS ; 36 | "then", THEN ; 37 | "while", WHILE ] 38 | 39 | let promote_reserved_words word = 40 | try List.assoc word reserved_words 41 | with Not_found -> IDENTIFIER word 42 | } 43 | 44 | let lalpha = ['a'-'z' '_'] 45 | let ualpha = ['A'-'Z'] 46 | let alpha = lalpha | ualpha 47 | let digit = ['0'-'9'] 48 | 49 | rule token = parse 50 | | eof { EOF } 51 | | "(*" { comment 1 lexbuf } 52 | | "*)" { raise (LexerError ("mismatched *)")) } 53 | | ":=" { ASSTRING } 54 | | "&&" { AND } 55 | | "||" { OR } 56 | | '{' { LBRACE } 57 | | '}' { RBRACE } 58 | | '(' { LPAREN } 59 | | ')' { RPAREN } 60 | | ';' { SEMICOLON } 61 | | '[' { LBRACKET } 62 | | ']' { RBRACKET } 63 | | '\'' { let b = Buffer.create 10 in string b lexbuf } 64 | | '\n' { Lexing.new_line lexbuf; token lexbuf } 65 | | (alpha (alpha | digit | '_')* as s) { promote_reserved_words s } 66 | | (digit+ as s) { NAT (Z.of_string s) } 67 | | ['\t' ' '] { token lexbuf } (* skip tab and blank*) 68 | | _ as c { raise (LexerError ("unknown character '" ^ String.make 1 c ^ "'")) } 69 | 70 | and string b = parse 71 | | eof { raise (LexerError "Unterminated string") } 72 | | '\'' { LITERAL (Buffer.contents b) } 73 | | [^'\\''\''] as c { Buffer.add_char b c ; string b lexbuf } 74 | | '\\' (_ as c) { Buffer.add_char b c ; string b lexbuf } 75 | 76 | and comment n = parse 77 | | eof { raise (LexerError "Unterminated comment") } 78 | | "(*" { comment (n+1) lexbuf } 79 | | "*)" { if n=1 then token lexbuf else comment (n-1) lexbuf } 80 | | _ { comment n lexbuf } 81 | -------------------------------------------------------------------------------- /tests/runner/engine.ml: -------------------------------------------------------------------------------- 1 | open Common 2 | 3 | let indent s = 4 | " > " ^ String.(concat "\n > " (split_on_char '\n' s)) 5 | 6 | let run_test filename : (unit, string) Result.result = 7 | 8 | (* Load .meta file *) 9 | 10 | begin 11 | try 12 | Ok (MetaFile.load_from_file 13 | (Filename.concat !Options.directory ((Filename.remove_extension filename) ^ ".meta"))) 14 | with Sys_error _ -> Error ("Meta file missing for `" ^ filename ^ "`") 15 | end 16 | >>= fun meta -> 17 | 18 | (* Build command line *) 19 | 20 | let cmdline = 21 | [ !Options.utility ] 22 | @ ["--unknown-behaviour"; "ERROR"] (* Compatibility with behaviour before PR #114. TODO Update tests and remove this line *) 23 | @ (if Filename.extension filename = ".cls" then ["--colis"] else []) 24 | @ [ Filename.concat !Options.directory filename ] 25 | @ meta.input.arguments 26 | |> List.map escape_shell_argument 27 | |> String.concat " " 28 | in 29 | 30 | (* Execute process *) 31 | 32 | let (stdout, stdin, stderr) = Unix.open_process_full cmdline (Unix.environment ()) in 33 | output_string stdin meta.input.stdin; 34 | let stdout_content = in_channel_to_string stdout in 35 | let stderr_content = in_channel_to_string stderr in 36 | let status = Unix.close_process_full (stdout, stdin, stderr) in 37 | 38 | (* Check stdout *) 39 | 40 | (if stdout_content = meta.output.stdout then 41 | Ok () 42 | else 43 | Error 44 | (Format.sprintf 45 | "wrong stdout\n expected:\n%s\n got:\n%s" 46 | (indent (String.escaped meta.output.stdout)) 47 | (indent (String.escaped stdout_content)))) 48 | 49 | (* Check stderr *) 50 | 51 | >>= fun () -> 52 | (if stderr_content = meta.output.stderr then 53 | Ok () 54 | else 55 | Error 56 | (Format.sprintf 57 | "wrong stderr\n expected:\n%s\n got:\n%s" 58 | (indent meta.output.stderr) 59 | (indent stderr_content))) 60 | 61 | (* Check return_code *) 62 | 63 | >>= fun () -> 64 | (match status with 65 | | Unix.WEXITED return_code -> 66 | if return_code = meta.output.return_code then 67 | Ok () 68 | else 69 | Error (Format.sprintf 70 | "wrong return code (expected %d, got %d)" 71 | meta.output.return_code return_code) 72 | | _ -> 73 | Error "execution stopped unexpectedly") 74 | 75 | let run_tests () = 76 | let results = 77 | (* scan directory *) 78 | Sys.readdir !Options.directory 79 | |> Array.to_list 80 | (* take all the .cls and .sh files *) 81 | |> List.filter (fun name -> Filename.check_suffix name ".cls" || Filename.check_suffix name ".sh") 82 | (* take only .sh files if --sh-only *) 83 | |> List.filter (fun name -> not (!Options.sh_only) || Filename.check_suffix name ".sh") 84 | (* run tests on them *) 85 | |> List.map (fun name -> (name, run_test name)) 86 | in 87 | List.iter (fun (name, result) -> 88 | match result with 89 | | Ok () -> () (*Format.printf "SUCCESS %s@." name*) 90 | | Error msg -> Format.printf "FAILURE %s: %s@." name msg) 91 | results; 92 | let (successes, failures) = 93 | List.partition (function (_, Ok _) -> true | (_, Error _) -> false) results 94 | in 95 | Format.printf "TESTS PASSED: %d / %d@." 96 | (List.length successes) 97 | (List.length results); 98 | exit (if failures = [] then 0 else 1) 99 | -------------------------------------------------------------------------------- /src/symbolic/utilities/which.ml: -------------------------------------------------------------------------------- 1 | open Format 2 | open Colis_constraints 3 | open SymbolicUtility.ConstraintsCompatibility 4 | open Semantics__Result 5 | open Semantics__Buffers 6 | 7 | module Silent = struct 8 | let name = "silent-which" 9 | 10 | let interprete _ctx = function 11 | | [p] -> 12 | specification_cases [ 13 | success_case 14 | ~descr:(asprintf "silent-which '%s': assuming command is found" p) 15 | noop 16 | ; 17 | error_case 18 | ~descr:(asprintf "silent-which '%s': assuming command is not found" p) 19 | noop 20 | ] 21 | | _ -> 22 | incomplete ~utility:"silent-which" "more than one argument" 23 | 24 | let interprete ctx : utility = 25 | cmdliner_eval_utility 26 | ~utility:name 27 | Cmdliner.Term.(const interprete) 28 | ctx 29 | end 30 | 31 | let name = "which" 32 | 33 | let interp_test_regular_and_x cwd path_str : utility = 34 | let p = Path.from_string path_str in 35 | specification_cases [ 36 | success_case 37 | ~descr:(asprintf "which '%a': path resolves to a regular executable (overapprox to -f)" Path.pp p) 38 | ~stdout:Stdout.(empty |> output (asprintf "%a" Path.pp p) |> newline) 39 | begin fun root root' -> 40 | exists @@ fun x -> 41 | resolve root cwd p x & reg x & (* no way to constraint "x" mode *) 42 | eq root root' 43 | end; 44 | error_case 45 | ~descr:(asprintf "which '%a': path does not resolve" Path.pp p) 46 | begin fun root root' -> 47 | noresolve root cwd p & 48 | eq root root' 49 | end; 50 | error_case 51 | ~descr:(asprintf "which '%a': path resolves but not to regular executable)" Path.pp p) 52 | begin fun root root' -> 53 | exists @@ fun x -> 54 | resolve root cwd p x & (* no way to constraint no "x" mode *) 55 | eq root root' 56 | end; 57 | ] 58 | 59 | 60 | let rec search_as_which_in_path cwd (path:string list) arg : utility = 61 | match path with 62 | | [] -> 63 | specification_cases [ 64 | error_case 65 | ~descr:(asprintf "which: `%s` not found in PATH" arg) 66 | noop 67 | ] 68 | | p :: rem -> 69 | let u1 = interp_test_regular_and_x cwd (p ^ "/" ^ arg) in 70 | let u2 = search_as_which_in_path cwd rem arg in 71 | fun st -> 72 | List.flatten 73 | (List.map 74 | (function (s1,Ok b1) as x -> if b1 then [x] else u2 s1 | (_,Incomplete) as x -> [x]) 75 | (u1 st)) 76 | 77 | let search_as_which cwd (path:string list) arg : utility = 78 | match Path.from_string arg with 79 | | Abs _ -> interp_test_regular_and_x cwd arg 80 | | Rel [] -> assert false 81 | | Rel [_] -> search_as_which_in_path cwd path arg 82 | | Rel r -> 83 | fun st -> 84 | let a = Path.concat cwd (Rel r) in 85 | interp_test_regular_and_x cwd ("/" ^ Path.rel_to_string a) st 86 | 87 | let interprete all ctx args : utility = 88 | if all then incomplete ~utility:name "option `-a`" else 89 | (* FIXME let path = String.split_on_char ':' (IdMap.find "PATH" ctx.env) in *) 90 | let path = [ "/usr/sbin" ; "/usr/bin" ; "/sbin" ; "/bin" (* ; "/usr/games" *) ] in 91 | let rec aux args = 92 | match args with 93 | | [] -> assert false 94 | | [a] -> search_as_which ctx.cwd path a 95 | | a :: rem -> 96 | uand (search_as_which ctx.cwd path a) (aux rem) (* FIXME: uand ??? *) 97 | in 98 | aux args 99 | 100 | let interprete ctx : utility = 101 | let all = Cmdliner.Arg.(value & flag & info ["a"; "all"]) in 102 | cmdliner_eval_utility 103 | ~utility:name 104 | Cmdliner.Term.(const interprete $ all) 105 | ctx 106 | -------------------------------------------------------------------------------- /src/constraints/model/doc/preliminaries.tex: -------------------------------------------------------------------------------- 1 | 2 | \section{Specifying POSIX Utilities in Feature Tree Logic} 3 | %% or "Preliminaries" 4 | 5 | \subsection{File Systems and their Models} 6 | 7 | \paragraph{POSIX file system} 8 | %--------- 9 | is defined by an i-node table, 10 | each entry of this table associates to the i-node a set of attributes, 11 | e.g., the type of file (ordinary, directory, link, etc.), 12 | the last modification time or 13 | a partial mapping from strings to i-nodes (directory content). 14 | 15 | We denote by $FS$ the infinite set of file systems. 16 | 17 | \paragraph{Feature trees} 18 | %--------- 19 | is a model of file systems based on labeled bounded-width forests. 20 | The labels of nodes represent attributes of a file (like its type) and 21 | labels of edges, called features, represent atomic names used for files. 22 | We denote by $F$ the set of features and by $D$ the set of node decorations. 23 | Then $FT \triangleq D \times (F \rightharpoonup FT)$ denotes the set of feature 24 | trees built with features in $F$ and decorations in $D$. 25 | Given an element $t=(d,\sigma)\in FT$, we denote 26 | by $\dot{t}$ the root of $t$, 27 | by $\hat{t}$ the decoration $d$ of the root and 28 | by $\vec{t}$ the mapping $\sigma$ at the root. 29 | 30 | Features trees are bounded width trees. 31 | A feature tree $t$ in $FT$ is also represented by the set of paths in the tree, 32 | denoted by $paths(t)$, where 33 | a path is an element of $(D\times F)^*D$ 34 | (i.e., a sequence whose elements are pairs of 35 | file decorations 36 | and features, 37 | ended by a decoration). 38 | 39 | \subsection{Feature Trees Logic} 40 | 41 | In \cite{jeannerod:hal-01807474} is defined a first order logic 42 | to capture properties of feature trees models. 43 | It contains the following atoms combined with classic FOL operators: 44 | \begin{itemize} 45 | \item $\Feat{x}{f}{y}$ for tree $x$ where the feature $f$ leads to the tree $y$; 46 | \item $\Abs{x}{f}$ for tree $x$ with no feature $f$ (in the root); 47 | \item $\Sim{x}{F}{y}$ for tree $x$ and $y$ having similar structure except 48 | for features in $F$ in the root; $\Sim{x}{\emptyset}{x}$ is valid (and represents \textit{true}); 49 | \item $\Fen{x}{F}$ for $x$ contains in the root features from $F$. 50 | \end{itemize} 51 | 52 | The satisfiability relation $\models$ is defined by 53 | $FT,\rho \models \varphi$ 54 | where 55 | $\rho$ is an interpretation of free variables in $\varphi$ over features trees in $FT$. 56 | 57 | Quantifier free FTL has a decidable satisfiability problem. 58 | The decision procedure proposed \cite{jeannerod:hal-01807474} 59 | proceeds by transforming the input formula to obtain an equi-satisfiable formula 60 | in disjunctive normal form, where literals are 61 | the one above plus $\NSim{x}{F}{y}$ and $\NFen{x}{F}$. 62 | 63 | 64 | The set of models of a satisfiable formula $\varphi$ in QF FTL 65 | does not have, in general, a minimal model with respect to $\prec$. 66 | This is due to the presence of literals like 67 | $\lnot (x\stackrel{.}{=}y)$ 68 | (i.e., $x$ denotes a tree which is not equivalent to the one denoted by $y$) 69 | or $\NFen{x}{\emptyset}$ (i.e., $x$ does not denote an empty directory). 70 | For example, the model generated for the last formula contains 71 | a fresh feature in the directory denoted by $x$; 72 | this feature may be different for each model built for this formula. 73 | Figure~\ref{fig:min-model} provides an example of a satisfiable formula 74 | which has two incomparable models. 75 | 76 | 77 | \begin{figure}[htbp] 78 | \begin{center} 79 | \begin{eqnarray} 80 | t_1 & ::= & x \stackrel{f}{\rightarrow} y \stackrel{f_1}{\rightarrow} z_1 \\ 81 | t_2 & ::= & x \stackrel{f}{\rightarrow} y \stackrel{f_2}{\rightarrow} z_2 82 | \end{eqnarray} 83 | \caption{Two incomparable (wrt $\prec$) models for 84 | the formula $\Feat{x}{f}{y} \land \NFen{y}{\emptyset}$} 85 | \label{fig:min-model} 86 | \end{center} 87 | \end{figure} 88 | 89 | 90 | -------------------------------------------------------------------------------- /src/constraints/model/test/sample_report.dat: -------------------------------------------------------------------------------- 1 | MUTATE: true ; VERBOSE: true 2 | 3 | ------------------------------------------------------------------------- 4 | CMD: test -e stty/gunzip/touch 5 | CMD_Mod: test -e ./tmp/InnerTR/Inner2TR/Inner3TR/stty/gunzip/touch 6 | No of Clauses : 2 7 | 8 | 9 | Clause 1 [RootB: 1 ;RootA: 2; isError: false] : 10 | Pos(Eq(10,3)) Pos(Eq(1,2)) Pos(Kind(9,Dir)) Pos(Feat(9,touch,10)) Pos(Kind(8,Dir)) Pos(Feat(8,gunzip,9)) Pos(Kind(7,Dir)) Pos(Feat(7,stty,8)) Pos(Kind(6,Dir)) Pos(Feat(6,Inner3TR,7)) Pos(Kind(5,Dir)) Pos(Feat(5,Inner2TR,6)) Pos(Kind(4,Dir)) Pos(Feat(4,InnerTR,5)) Pos(Kind(2,Dir)) Pos(Feat(2,tmp,4)) 11 | 12 | Mutant Clause : Pos(Feat(16,GenFto18,18)) Pos(Feat(14,GenFto17,17)) Pos(Abs(9,GenFAbs9)) Pos(Feat(5,GenFto16,16)) Pos(Abs(6,GenFAbs5)) Pos(Feat(4,GenFto15,15)) Pos(Feat(6,GenFto14,14)) Pos(Feat(8,GenFto13,13)) Pos(Feat(10,GenFto12,12)) Pos(Feat(1,GenFto11,11)) Pos(Eq(10,3)) Pos(Eq(1,2)) Pos(Kind(9,Dir)) Pos(Feat(9,touch,10)) Pos(Kind(8,Dir)) Pos(Feat(8,gunzip,9)) Pos(Kind(7,Dir)) Pos(Feat(7,stty,8)) Pos(Kind(6,Dir)) Pos(Feat(6,Inner3TR,7)) Pos(Kind(5,Dir)) Pos(Feat(5,Inner2TR,6)) Pos(Kind(4,Dir)) Pos(Feat(4,InnerTR,5)) Pos(Kind(2,Dir)) Pos(Feat(2,tmp,4)) 13 | 14 | mkdir -p ./tmp/InnerTR/Inner2TR/Inner3TR/stty/gunzip/touch/GenFto12 15 | mkdir -p ./tmp/InnerTR/Inner2TR/Inner3TR/stty/gunzip 16 | mkdir -p ./tmp/InnerTR/Inner2TR/Inner3TR/stty/GenFto13 17 | mkdir -p ./tmp/InnerTR/Inner2TR/GenFto14/GenFto17 18 | mkdir -p ./tmp/InnerTR/Inner2TR 19 | mkdir -p ./tmp/InnerTR/GenFto16/GenFto18 20 | mkdir -p ./tmp/GenFto15 21 | mkdir -p ./GenFto11 22 | test -e ./tmp/InnerTR/Inner2TR/Inner3TR/stty/gunzip/touch 23 | check : ./tmp/InnerTR/Inner2TR/Inner3TR/stty/gunzip/touch/GenFto12 24 | check : ./tmp/InnerTR/Inner2TR/Inner3TR/stty/gunzip check Abs : ./tmp/InnerTR/Inner2TR/Inner3TR/stty/gunzip/GenFAbs9 25 | check : ./tmp/InnerTR/Inner2TR/Inner3TR/stty/GenFto13 26 | check : ./tmp/InnerTR/Inner2TR/GenFto14/GenFto17 27 | check : ./tmp/InnerTR/Inner2TR check Abs : ./tmp/InnerTR/Inner2TR/GenFAbs5 28 | check : ./tmp/InnerTR/GenFto16/GenFto18 29 | check : ./tmp/GenFto15 30 | check : ./GenFto11 31 | ***PATH CHECK SUCCESS*** 32 | ID Dissolve Repot 33 | Equality(*) Dissolve Error: SIM(F) Dissolve Error: Equality(F) Dissolve Error: 34 | 35 | 36 | Clause 2 [RootB: 1 ;RootA: 11; isError: true] : 37 | Pos(Eq(1,11)) Pos(Maybe(16,gunzip,17)) Pos(Maybe(15,stty,16)) Pos(Maybe(14,Inner3TR,15)) Pos(Maybe(13,Inner2TR,14)) Pos(Maybe(12,InnerTR,13)) Pos(Abs(17,touch)) Pos(Maybe(11,tmp,12)) 38 | 39 | Mutant Clause : Pos(Feat(18,GenFto24,24)) Pos(Feat(15,GenFto23,23)) Pos(Abs(21,GenFAbs14)) Pos(Abs(1,GenFAbs10)) Pos(Feat(1,GenFto22,22)) Pos(Abs(20,GenFAbs15)) Pos(Feat(18,GenFto21,21)) Pos(Feat(1,GenFto20,20)) Pos(Feat(12,GenFto19,19)) Pos(Feat(13,GenFto18,18)) Pos(Eq(1,11)) Pos(Maybe(16,gunzip,17)) Pos(Maybe(15,stty,16)) Pos(Maybe(14,Inner3TR,15)) Pos(Maybe(13,Inner2TR,14)) Pos(Maybe(12,InnerTR,13)) Pos(Abs(17,touch)) Pos(Maybe(11,tmp,12)) 40 | 41 | mkdir -p ./tmp/InnerTR/Inner2TR/Inner3TR/stty/gunzip 42 | mkdir -p ./tmp/InnerTR/Inner2TR/Inner3TR/GenFto23 43 | mkdir -p ./tmp/InnerTR/GenFto18/GenFto24 44 | mkdir -p ./tmp/InnerTR/GenFto18/GenFto21 45 | mkdir -p ./tmp/GenFto19 46 | mkdir -p ./GenFto22 47 | mkdir -p ./GenFto20 48 | mkdir -p . 49 | test -e ./tmp/InnerTR/Inner2TR/Inner3TR/stty/gunzip/touch 50 | check : ./tmp/InnerTR/Inner2TR/Inner3TR/stty/gunzip check Abs : ./tmp/InnerTR/Inner2TR/Inner3TR/stty/gunzip/touch 51 | check : ./tmp/InnerTR/Inner2TR/Inner3TR/GenFto23 52 | check : ./tmp/InnerTR/GenFto18/GenFto24 53 | check : ./tmp/InnerTR/GenFto18/GenFto21 check Abs : ./tmp/InnerTR/GenFto18/GenFto21/GenFAbs14 54 | check : ./tmp/GenFto19 55 | check : ./GenFto22 56 | check : ./GenFto20 check Abs : ./GenFto20/GenFAbs15 57 | check : . check Abs : ./GenFAbs10 58 | ***PATH CHECK SUCCESS*** 59 | ID Dissolve Repot 60 | Equality(*) Dissolve Error: SIM(F) Dissolve Error: Equality(F) Dissolve Error: -------------------------------------------------------------------------------- /src/constraints/model/inode.ml: -------------------------------------------------------------------------------- 1 | open Common 2 | 3 | let get_id_feat_str path = 4 | (let tmp_file = Filename.temp_file "" ".txt" in 5 | let _ = Sys.command @@ "ls -i "^path^" >" ^ tmp_file in 6 | let chan = open_in tmp_file in 7 | let s = really_input_string chan (in_channel_length chan) in 8 | close_in chan; 9 | s) 10 | 11 | let get_id_map path = 12 | let s = get_id_feat_str path in 13 | let s = String.split_on_char '\n' s in 14 | let map = ref FMap.empty in 15 | let rec helper = function 16 | |[]-> !map 17 | |h::t when h <> ""-> let ll = String.split_on_char ' ' h in 18 | map := FMap.add (List.nth ll 1) (List.nth ll 0) !map; 19 | helper t 20 | |_::t -> helper t 21 | in helper s 22 | 23 | let add_id_node v id_i = 24 | let v_node = find_node v in 25 | let new_node = {v_node with id = id_i} in 26 | let rec helper vl = 27 | match vl with 28 | |[]-> () 29 | |v1::t -> var_map := (VarMap.add v1 new_node !var_map); 30 | helper t 31 | in 32 | (helper (VSet.elements new_node.var_l)) 33 | 34 | let set_same_id v1 v2 s= 35 | let v1_id = (find_node v1).id in 36 | let v2_id = (find_node v2).id in 37 | (match (v1_id,v2_id) with 38 | |("","")-> () 39 | |("",id2)-> add_id_node v1 id2 40 | |(id1,"")-> add_id_node v2 id1 41 | |(id1,id2) when id1 <> id2-> 42 | Printf.fprintf out_f_l "%s" ("\nDifferent ID of V"^(string_of_int v1)^" and V"^(string_of_int v2)^" on "^s); 43 | Format.printf "%s" ("\nDifferent ID of V"^(string_of_int v1)^" and V"^(string_of_int v2)^" on "^s);() 44 | | _ -> ()) 45 | 46 | let rec dissolve_id_sim (clau:clause) = 47 | match clau with 48 | |[] -> () 49 | |Pos Sim(v1,_,v2)::t -> set_same_id v1 v2 "SIM"; 50 | dissolve_id_sim t 51 | | _::t -> dissolve_id_sim t 52 | 53 | let rec dissolve_id_eqf (clau:clause) = 54 | match clau with 55 | |[] -> () 56 | |Pos Eqf(v1,_,v2)::t -> set_same_id v1 v2 "EQF"; 57 | dissolve_id_sim t 58 | | _::t -> dissolve_id_eqf t 59 | 60 | let rec set_id (v) (path)= 61 | let ll = FMap.bindings ((find_node v).feat) in 62 | if((ll=[])||(v=0)) then () 63 | else 64 | ( let id_map = get_id_map path in 65 | let rec helper ll = 66 | match ll with 67 | |[] -> () 68 | |(_,v2)::t when v2 = 0 -> helper t 69 | |(f2,v2)::t -> try( 70 | add_id_node v2 (FMap.find f2 id_map); 71 | set_id (v2) (path^"/"^f2) ; 72 | helper t) 73 | with Not_found-> Printf.fprintf out_f_l "Not_Found during check_id(%d,%s,%d)\n" v f2 v2; 74 | Format.printf "Not_Found during check_id(%d,%s,%d)\n" v f2 v2 75 | in helper ll) 76 | 77 | let rec check_id (v) (path)= 78 | let ll = FMap.bindings ((find_node v).feat) in 79 | if((ll=[])||(v=0)) then 80 | () 81 | else 82 | ( let id_map = get_id_map path in 83 | let rec helper ll = 84 | match ll with 85 | |[] -> () 86 | |(_,v2)::t when v2 = 0 -> helper t 87 | |(f2,v2)::t -> try( 88 | let v2_id = (find_node v2).id in 89 | if ((v2_id = (FMap.find f2 id_map))||(v2_id = "")) then 90 | (check_id (v2) (path^"/"^f2) ; 91 | helper t) 92 | else 93 | ( Printf.fprintf out_f_l "%s" ("ID Mismatch f: "^f2^" , v1: "^(string_of_int v)^" , v2: "^(string_of_int v2)^ ", v2_id(stored): "^v2_id^", v2_id(FS): "^(FMap.find f2 id_map)^"\n"); 94 | Format.printf "%s" ("ID Mismatch f: "^f2^" , v1: "^(string_of_int v)^" , v2: "^(string_of_int v2)^ ", v2_id(stored): "^v2_id^", v2_id(FS): "^(FMap.find f2 id_map)^"\n"); 95 | check_id (v2) (path^"/"^f2); 96 | helper t)) 97 | with Not_found-> Printf.fprintf out_f_l "Not_Found during check_id(%d,%s,%d)\n" v f2 v2; 98 | Format.printf "Not_Found during check_id(%d,%s,%d)\n" v f2 v2 99 | in helper ll) 100 | -------------------------------------------------------------------------------- /src/language/colisParser.mly: -------------------------------------------------------------------------------- 1 | /* File colis_parser.mly */ 2 | 3 | %{ 4 | 5 | open Syntax__Syntax 6 | 7 | let rec concat = function 8 | | [] -> assert false (* parsed as a non-empty list *) 9 | | [se] -> se 10 | | se :: ses -> SConcat (se, concat ses) 11 | 12 | %} 13 | 14 | 15 | %token SPLIT SUCCESS FAILURE PREVIOUS EXIT NOT IF THEN ELSE EXPORT FI FOR IN FUNCTION CALL 16 | %token DO DONE WHILE BEGIN END PROCESS ENDPROCESS PIPE ENDPIPE INTO NOOUTPUT ENDNOOUTPUT ASSTRING ARG SHIFT 17 | %token LPAREN RPAREN LBRACE RBRACE LBRACKET RBRACKET EMBED SEMICOLON EOF RETURN AND OR 18 | %token LITERAL 19 | %token IDENTIFIER 20 | %token NAT 21 | 22 | %left AND OR 23 | %nonassoc NOT 24 | 25 | %start program 26 | %type program 27 | %% 28 | program: 29 | list(function_definition) 30 | BEGIN seq END EOF { {function_definitions=$1; instruction=$3} } 31 | ; 32 | function_definition: 33 | FUNCTION IDENTIFIER BEGIN seq END { $2, $4 } 34 | ; 35 | instruction: 36 | | EXIT exit_code { IExit($2) } 37 | | RETURN exit_code { IReturn($2) } 38 | | SHIFT option(NAT) { IShift($2) } 39 | | EXPORT IDENTIFIER { IExport($2) } 40 | | IF instruction THEN seq ELSE seq FI { IIf ($2, $4, $6) } 41 | | IF instruction THEN seq FI { IIf ($2, $4, ICallUtility("true", [])) } 42 | | NOT instruction { INot ($2) } 43 | | FOR IDENTIFIER IN lexpr DO seq DONE { IForeach ($2, $4, $6) } 44 | | WHILE instruction DO seq DONE { IWhile ($2, $4) } 45 | | BEGIN seq END { $2 } 46 | | PROCESS seq ENDPROCESS { ISubshell ($2) } 47 | | PIPE pipe ENDPIPE { $2 } 48 | | NOOUTPUT seq ENDNOOUTPUT { INoOutput ($2) } 49 | | IDENTIFIER { ICallUtility ($1, []) } 50 | | IDENTIFIER lexpr { ICallUtility ($1, $2) } 51 | | CALL IDENTIFIER { ICallFunction ($2, []) } 52 | | CALL IDENTIFIER lexpr { ICallFunction ($2, $3) } 53 | | IDENTIFIER ASSTRING sexpr { IAssignment ($1, $3) } 54 | | instruction AND instruction { IIf ($1, $3, INot (ICallUtility("true", []))) } 55 | | instruction OR instruction { IIf ($1, ICallUtility("true", []), $3) } 56 | | LPAREN instruction RPAREN { $2 } 57 | ; 58 | exit_code: 59 | | SUCCESS { RSuccess } 60 | | FAILURE { RFailure } 61 | | PREVIOUS { RPrevious } 62 | ; 63 | pipe: 64 | | instruction INTO pipe { IPipe($1,$3) } 65 | | instruction { $1 } 66 | ; 67 | seq: 68 | | instruction SEMICOLON seq { ISequence($1,$3) } 69 | | instruction { $1 } 70 | ; 71 | sfrag: 72 | | LITERAL { SLiteral($1) } 73 | | IDENTIFIER { SVariable($1) } 74 | | EMBED delimited(LBRACE, instruction, RBRACE) { SSubshell($2) } 75 | | ARG NAT { SArgument($2) } 76 | ; 77 | sexpr: 78 | | nonempty_list(sfrag) { concat $1 } 79 | ; 80 | lfrag: 81 | | SPLIT sexpr { $2, Split } 82 | | sexpr { $1, DontSplit} 83 | ; 84 | lexpr: 85 | | delimited (LBRACKET, separated_list(SEMICOLON, lfrag), RBRACKET) { $1 } 86 | ; 87 | -------------------------------------------------------------------------------- /src/language/toColis.ml: -------------------------------------------------------------------------------- 1 | open Format 2 | 3 | let rec print_list_pre sep print fmt = function 4 | | [] -> () 5 | | x :: r -> sep fmt (); print fmt x; print_list_pre sep print fmt r 6 | 7 | let print_list sep print fmt = function 8 | | [] -> () 9 | | [x] -> print fmt x 10 | | x :: r -> print fmt x; print_list_pre sep print fmt r 11 | 12 | (* let comma fmt () = fprintf fmt ",@ " *) 13 | 14 | let semi fmt () = fprintf fmt ";@ " 15 | 16 | open Syntax__Syntax 17 | 18 | let rec string_expression (fmt:formatter) (e:string_expression) : unit = 19 | match e with 20 | | SLiteral s -> 21 | fprintf fmt "'%s'" s 22 | | SVariable s -> 23 | fprintf fmt "%s" s 24 | | SSubshell i -> 25 | fprintf fmt "@[embed {@ %a }@]" instruction i 26 | | SArgument n -> 27 | fprintf fmt "arg %a" Z.pp_print n 28 | | SConcat(e1,e2) -> 29 | fprintf fmt "@[%a@ %a@]" string_expression e1 string_expression e2 30 | 31 | and expr_split (fmt:formatter) (e,s) : unit = 32 | match s with 33 | | Split -> fprintf fmt "split %a" string_expression e 34 | | DontSplit -> fprintf fmt "%a" string_expression e 35 | 36 | and lexpr (fmt:formatter) (l: (string_expression * split) list) = 37 | fprintf fmt "@[[ %a ]@]" (print_list semi expr_split) l 38 | 39 | and instruction (fmt:formatter) (i:instruction) : unit = 40 | match i with 41 | | IAssignment(s,e) -> 42 | fprintf fmt "@[%s :=@ %a@]" s string_expression e 43 | | ISequence(i1,i2) -> 44 | fprintf fmt "@[begin@ %a ;@ %a@]@ end" sequence i1 sequence i2 45 | | ISubshell i -> 46 | fprintf fmt "@[process@ %a@]" instruction i 47 | | IIf(i1,ICallUtility(":", []),i2) -> 48 | fprintf fmt "@[(%a ||@ %a)@]" 49 | instruction i1 instruction i2 50 | | IIf(i1,i2,INot(ICallUtility(":", []))) -> 51 | fprintf fmt "@[(%a &&@ %a)@]" 52 | instruction i1 instruction i2 53 | | IIf(c,i1,ICallUtility(":", [])) -> 54 | fprintf fmt "@[@[if %a@]@ @[then %a@]@ fi@]" 55 | instruction c instruction i1 56 | | IIf(c,i1,i2) -> 57 | fprintf fmt "@[@[if %a@]@ @[then %a@]@ @[else %a@]@ fi@]" 58 | instruction c instruction i1 instruction i2 59 | | INot i1 -> 60 | fprintf fmt "@[not %a@]" instruction i1 61 | | IPipe(i1,i2) -> 62 | fprintf fmt "@[@[pipe@ %a@ into %a@]@ epip@]" instruction i1 pipe i2 63 | | IWhile(i1,i2) -> 64 | fprintf fmt "@[@[while %a@ do %a@]@ done@]" 65 | instruction i1 instruction i2 66 | | INoOutput i1 -> 67 | fprintf fmt "@[@[nooutput %a@]@]" instruction i1 68 | | IForeach(id,le,i1) -> 69 | fprintf fmt "@[@[for %s@ in %a@ do %a@]@ done@]" 70 | id lexpr le instruction i1 71 | | ICallUtility(s,[]) -> 72 | fprintf fmt "@[%s@]" s 73 | | ICallUtility(s,args) -> 74 | fprintf fmt "@[%s@ %a@]" s lexpr args 75 | | ICallFunction(s,[]) -> 76 | fprintf fmt "@[call %s@]" s 77 | | ICallFunction(s,args) -> 78 | fprintf fmt "@[call %s %a@]" s lexpr args 79 | | IExit c -> 80 | fprintf fmt "@[exit %a@]" exitcode c 81 | | IReturn c -> 82 | fprintf fmt "@[return@ %a@]" exitcode c 83 | | IShift bn -> 84 | let n = match bn with None -> "" | Some n -> " "^Z.to_string n in 85 | fprintf fmt "@[shift%s@]" n 86 | | IExport id -> 87 | fprintf fmt "@[export %s@]" id 88 | | ICd arg -> 89 | fprintf fmt "@[cd@ %a@]" string_expression arg 90 | 91 | and exitcode (fmt:formatter) (c:return_code) = 92 | match c with 93 | | RSuccess -> fprintf fmt "success" 94 | | RFailure -> fprintf fmt "failure" 95 | | RPrevious -> fprintf fmt "previous" 96 | 97 | and sequence (fmt:formatter) (i:instruction) : unit = 98 | match i with 99 | | ISequence(i1,i2) -> 100 | fprintf fmt "@[%a ;@ %a@]" sequence i1 sequence i2 101 | | _ -> instruction fmt i 102 | 103 | and pipe (fmt:formatter) (i:instruction) : unit = 104 | match i with 105 | | IPipe(i1,i2) -> 106 | fprintf fmt "@[%a into@ %a@]" instruction i1 pipe i2 107 | | _ -> instruction fmt i 108 | 109 | and function_definition fmt (n, i) = 110 | fprintf fmt "@[function %s %a@]@\n" n instruction i 111 | 112 | and program fmt p = 113 | List.iter (function_definition fmt) p.function_definitions; 114 | fprintf fmt "@[@[begin@ %a@]@ end@]" sequence p.instruction 115 | -------------------------------------------------------------------------------- /src/concrete/utilities.ml: -------------------------------------------------------------------------------- 1 | (** Concrete interpretation of selected shell builtins and some UNIX commands. 2 | 3 | For the shell builtins see subsections of http://pubs.opengroup.org/onlinepubs/9699919799/utilities/V3_chap04.html#tag_20 4 | *) 5 | 6 | open Colis_internals 7 | open Semantics__Result 8 | open Semantics__Buffers 9 | open Semantics__UtilityContext 10 | open Interpreter__Semantics 11 | 12 | type env = string Env.SMap.t 13 | 14 | let incomplete ~utility msg = fun sta -> 15 | let str = utility ^ ": " ^ msg in 16 | let stdout = Stdout.(sta.stdout |> output str |> newline) in 17 | {sta with stdout}, Incomplete 18 | 19 | let error ~utility msg = fun sta -> 20 | let str = utility ^ ": " ^ msg in 21 | let stdout = Stdout.(sta.stdout |> output str |> newline) in 22 | {sta with stdout}, Ok false 23 | 24 | let unknown ~utility msg = 25 | match !Options.unknown_behaviour with 26 | | Exception -> raise (Errors.Unknown_behaviour (utility, msg)) 27 | | Incomplete -> incomplete ~utility msg 28 | | Error -> error ~utility msg 29 | 30 | let test (sta : state) : string list -> (state * bool result) = function 31 | | [sa; "="; sb] -> 32 | (sta, Ok (sa = sb)) 33 | | [sa; "!="; sb] -> 34 | (sta, Ok (sa <> sb)) 35 | | _ -> 36 | unknown ~utility:"test" "arguments different from . = . and . != ." sta 37 | 38 | let dpkg_compare_versions args = 39 | Sys.command ("dpkg --compare-versions " ^ String.concat " " args ^ " >/dev/null 2>&1") = 0 40 | 41 | let dpkg_validate_thing subcmd arg = 42 | Sys.command ("dpkg " ^ subcmd ^ " " ^ arg ^ " >/dev/null 2>&1") = 0 43 | 44 | let interp_utility ({env; args; _}, id, sta) = 45 | match id with 46 | | "echo" -> 47 | let stdout = 48 | match args with 49 | | "-n" :: args -> 50 | let str = String.concat " " args in 51 | Stdout.(sta.stdout |> output str) 52 | | _ -> 53 | let str = String.concat " " args in 54 | Stdout.(sta.stdout |> output str |> newline) 55 | in 56 | {sta with stdout}, Ok true 57 | | ":" | "true" -> 58 | sta, Ok true 59 | | "false" -> 60 | sta, Ok false 61 | | "test" -> test sta args 62 | | "env" -> 63 | begin match args with 64 | | [] -> 65 | let format_line (var, value) = 66 | Format.sprintf "%s=%s" var value 67 | in 68 | let print_line sta line = 69 | {sta with stdout=Stdout.(sta.stdout |> output line |> newline)} 70 | in 71 | Env.SMap.bindings env |> 72 | List.map format_line |> 73 | List.fold_left print_line sta, Ok true 74 | | _arg :: _ -> 75 | incomplete ~utility:"env" "no arguments supported" sta 76 | end 77 | | "grep" -> (* Just for testing stdin/stdout handling *) 78 | begin match args with 79 | | [word] -> 80 | let stdout, result = 81 | let re = Str.regexp_string word in 82 | let f (stdout, res) line = 83 | try 84 | ignore (Str.search_forward re line 0); 85 | Stdout.(stdout |> output line |> newline), true 86 | with Not_found -> 87 | stdout, res 88 | in 89 | List.fold_left f (sta.stdout, false) sta.stdin 90 | in 91 | let sta' = {sta with stdout; stdin=Stdin.empty} in 92 | sta', Ok result 93 | | [] -> 94 | error ~utility:"grep" "missing argument" sta 95 | | _arg :: _ -> 96 | incomplete ~utility:"grep" "two or more arguments" sta 97 | end 98 | | "dpkg" -> 99 | begin match args with 100 | | (("--validate-pkgname" | "--validate-trigname" | 101 | "--validate-archname" | "--validate-version") as subcmd)::args-> 102 | if List.length args = 1 103 | then sta, Ok (dpkg_validate_thing subcmd (List.hd args)) 104 | else error ~utility:"dpkg" 105 | "--validate_thing needs excactly 1 argument" sta 106 | | "--compare-versions"::args -> 107 | if List.length args = 3 108 | then sta, Ok (dpkg_compare_versions args) 109 | else error ~utility:"dpkg" 110 | "--compare-versions needs excatly 3 arguments" sta 111 | | _ -> error ~utility:"dpkg" "unsupported arguments" sta 112 | end 113 | | _ -> 114 | unknown ~utility:id "command not found" sta 115 | 116 | let absolute_or_concat_relative (p: string list) (s: string) : string list = 117 | if String.equal s "" then 118 | p 119 | else 120 | let p' = 121 | String.split_on_char '/' s |> 122 | List.filter (fun s' -> not (String.equal s' "")) 123 | in 124 | if s.[0] = '/' then 125 | p' 126 | else 127 | p @ p' 128 | -------------------------------------------------------------------------------- /src/language/syntax.mlw: -------------------------------------------------------------------------------- 1 | 2 | (** Non-negative integers *) 3 | module Nat 4 | 5 | use int.Int 6 | 7 | type nat = { nat : int } 8 | invariant { nat >= 0 } 9 | 10 | let function mk_nat (i: int) 11 | requires { i >= 0 } 12 | ensures { result.nat = i } 13 | = { nat = i } 14 | end 15 | 16 | (** Identifiers of variables and functions *) 17 | module Identifier 18 | 19 | use string.String 20 | 21 | type identifier 22 | 23 | val function identifier_eq (v1 v2:identifier) : bool 24 | ensures { result <-> v1 = v2 } 25 | 26 | val function identifier_to_string identifier : string 27 | 28 | val function identifier_of_string string : identifier 29 | end 30 | 31 | (** Abstract syntax of the CoLiS language *) 32 | module Syntax 33 | 34 | use list.List 35 | use option.Option 36 | 37 | use string.String 38 | use export Nat 39 | use export Identifier 40 | 41 | (** Indicates if a string in a list expression should be split (on default IFS=`[ \t\n]`) *) 42 | type split = Split | DontSplit 43 | 44 | (** A `string_expression` evaluates to a `string` *) 45 | type string_expression = (** CoLiS | Shell *) 46 | | SLiteral string (** 'literal' | 'string' *) 47 | | SVariable identifier (** id | ${id} *) 48 | | SSubshell instruction (** embed instr | $(instruction) *) 49 | | SConcat string_expression string_expression (** expr expr | expression expression (without space) *) 50 | | SArgument nat (** arg N | $N *) 51 | 52 | (** A list_expression` evaluates to a `list string` *) 53 | with list_expression = (* [split? expr, ...] | "expr" OR expr *) 54 | list (string_expression, split) 55 | 56 | (* Allow $? only as return code, cf. NOTES[Exit] *) 57 | with return_code = (** CoLiS | Shell *) 58 | | RSuccess (** success | 0 *) 59 | | RFailure (** failure | 1-255 *) 60 | | RPrevious (** previous | $? *) 61 | 62 | (** TODO add utilities `true`, `false` to *Specification of UNIX commands* *) 63 | with instruction = (* CoLiS | Shell *) 64 | | IAssignment identifier string_expression (* id := sexpr | id=sexpr *) 65 | | ISequence instruction instruction (* instr; instr | instr; instr *) 66 | | ISubshell instruction (* process instr | ( instr ) *) 67 | | IIf instruction instruction instruction (* if instr then instr else instr | if instr; then instr; else instr *) 68 | | INot instruction (* not instr | ! instr (see NOTES[Conditionals])*) 69 | | IPipe instruction instruction (* pipe instr into instr epip | instr | instr *) 70 | | IWhile instruction instruction (* while instr do instr done | while instr; do instr; done *) 71 | | INoOutput instruction (* nooutput instr | instr > /dev/null *) 72 | | IForeach identifier list_expression instruction (* for x in lexpr do instr done | for x in words; do instr; done *) 73 | | ICallUtility identifier list_expression (* id lexpr? | words *) 74 | | ICallFunction identifier list_expression (* call id lexpr? | words *) 75 | | IReturn return_code (* return r | return r *) 76 | | IExit return_code (* exit r | exit r (see NOTES[Exit]) *) 77 | | IShift (option nat) (* shift n? | shift n? *) 78 | | IExport identifier (* export id | export id *) 79 | | ICd string_expression (* cd sexpr | cd word *) 80 | 81 | with function_definition = (identifier, instruction) (* function id instr; | function id instr *) 82 | 83 | with program = { 84 | function_definitions: list function_definition; 85 | instruction: instruction 86 | } 87 | end 88 | -------------------------------------------------------------------------------- /src/constraints/model/print.ml: -------------------------------------------------------------------------------- 1 | open Common 2 | 3 | let rec int_list_display = function 4 | |[] -> () 5 | |h::t -> Printf.fprintf out_f_l "%d, " h; 6 | Format.printf "%d, " h; 7 | int_list_display t 8 | 9 | let rec str_list_display = function 10 | |[] -> () 11 | |h::t -> Printf.fprintf out_f_l "%s, " h; 12 | Format.printf "%s, " h; 13 | str_list_display t 14 | 15 | let kind_to_str = function 16 | |Dir -> "Dir" 17 | |Reg -> "Reg" 18 | |Other -> "Other" 19 | |Unknown -> "Unknown" 20 | 21 | let node_display {var_l = var_l_ ;feat = feat_ ;notfeat = notfeat_; equality= equality_;sim= sim_;fen_p =fen_p_;fen = fen_;id=id_;kind = kind_} : unit = 22 | 23 | let feat_ = FMap.bindings feat_ in 24 | let var_display var_l_ = Format.printf "[" ; 25 | int_list_display (VSet.elements var_l_); 26 | Format.printf "]\t"; 27 | in 28 | 29 | let rec feat_display feat_ = 30 | match feat_ with 31 | |[] -> () 32 | |(f_1,v_1)::t -> Format.printf "[%s --> %d]\t" f_1 v_1; 33 | feat_display t 34 | in 35 | let rec notfeat_display notfeat_ = 36 | match notfeat_ with 37 | |[] -> () 38 | |(f_1,v_1)::t -> Format.printf "[%s --> %d]\t" f_1 v_1; 39 | notfeat_display t 40 | in 41 | 42 | let fen_ = FSet.elements fen_ in 43 | let rec fen_display fen_ = 44 | match fen_ with 45 | |[] -> () 46 | | h::t -> Format.printf "[%s]\t" h; 47 | fen_display t 48 | in 49 | 50 | let rec equality_display equality_ = 51 | match equality_ with 52 | |[] -> () 53 | |(f_1,v_1)::t -> Format.printf "[" ; 54 | str_list_display (FSet.elements f_1); 55 | Format.printf " --> %d]\t" v_1; 56 | equality_display t 57 | in 58 | 59 | let rec sim_display sim_ = 60 | match sim_ with 61 | |[] -> () 62 | |(f_1,v_1)::t -> Format.printf "[" ; 63 | str_list_display (FSet.elements f_1); 64 | Format.printf " --> %d]\t" v_1; 65 | sim_display t 66 | in 67 | 68 | Format.printf "Variable List:\n"; 69 | var_display var_l_; 70 | Format.printf "\nFeatures:\n"; 71 | feat_display feat_; 72 | Format.printf "\nNot-Features:\n"; 73 | notfeat_display notfeat_; 74 | Format.printf "\nFen Features(present: %b):\n" fen_p_; 75 | fen_display fen_; 76 | Format.printf "\nEquality:\n"; 77 | equality_display equality_; 78 | Format.printf "\nSimilarity:\n"; 79 | sim_display sim_; 80 | Format.printf "\nInode: %s \n" id_; 81 | Format.printf "\nKind: %s \n" (kind_to_str kind_) 82 | 83 | let var_map_display var_map = 84 | let var_map = VarMap.bindings var_map in 85 | let rec helper var_map = 86 | match var_map with 87 | |[] -> () 88 | |(v_1,n_1)::t -> Format.printf "\n\n\t\tNODE(VAR) : %d\n" v_1; 89 | node_display n_1; 90 | helper t 91 | in 92 | helper var_map 93 | 94 | let print_Atom (x:atom) y = 95 | match x with 96 | | Eq(v1,v2) -> Printf.fprintf out_f_l " %s(Eq(%d,%d)) " y v1 v2; 97 | Format.printf " %s(Eq(%d,%d)) " y v1 v2 98 | 99 | | Feat(v1,f,v2) -> Printf.fprintf out_f_l " %s(Feat(%d,%s,%d)) " y v1 f v2; 100 | Format.printf " %s(Feat(%d,%s,%d)) " y v1 f v2 101 | 102 | | Abs(v1,f) -> Printf.fprintf out_f_l " %s(Abs(%d,%s)) " y v1 f; 103 | Format.printf " %s(Abs(%d,%s)) " y v1 f 104 | 105 | | Kind(v1,k) -> Printf.fprintf out_f_l " %s(Kind(%d,%s)) " y v1 (kind_to_str k); 106 | Format.printf " %s(Kind(%d,%s)) " y v1 (kind_to_str k) 107 | 108 | | Fen(v1,f) ->Printf.fprintf out_f_l " %s(Fen(%d,[" y v1; 109 | Format.printf " %s(Fen(%d,[" y v1; 110 | (str_list_display f); 111 | Printf.fprintf out_f_l "])) "; 112 | Format.printf "])) " 113 | 114 | | Sim(v1,f,v2) -> Printf.fprintf out_f_l " %s(Sim(%d,[" y v1; 115 | Format.printf " %s(Sim(%d,[" y v1; 116 | (str_list_display f); 117 | Printf.fprintf out_f_l "],%d)) " v2; 118 | Format.printf "],%d)) " v2 119 | 120 | | Eqf(v1,f,v2) -> Printf.fprintf out_f_l " %s(Eqf(%d,[" y v1; 121 | Format.printf " %s(Eqf(%d,[" y v1; 122 | (str_list_display f); 123 | Printf.fprintf out_f_l "],%d)) " v2; 124 | Format.printf "],%d)) " v2 125 | 126 | | Maybe(v1,f,v2) -> Printf.fprintf out_f_l " %s(Maybe(%d,%s,%d)) " y v1 f v2; 127 | Format.printf " %s(Maybe(%d,%s,%d)) " y v1 f v2 128 | 129 | let rec print_clause (x:literal list) = 130 | match x with 131 | | [] -> Printf.fprintf out_f_l "\n\n";Format.printf "\n\n" 132 | | Pos a::t -> print_Atom a "Pos"; print_clause t 133 | | Neg a::t -> print_Atom a "Neg"; print_clause t 134 | -------------------------------------------------------------------------------- /src/colis.mli: -------------------------------------------------------------------------------- 1 | (** {2 CoLiS-Language} *) 2 | 3 | module Internals = Colis_internals 4 | module SymbolicUtility = SymbolicUtility 5 | 6 | (** The abstract syntax of CoLiS programs. *) 7 | type colis = Syntax__Syntax.program 8 | 9 | (** The CoLiS language *) 10 | module Language : sig 11 | module Nat = Syntax__Nat 12 | module Syntax = Syntax__Syntax 13 | module SyntaxHelpers = SyntaxHelpers 14 | module Parser = ColisParser 15 | module Lexer = ColisLexer 16 | module FromShell = FromShell 17 | 18 | (** {2 Printing} *) 19 | 20 | val print_colis : colis -> unit 21 | (** Prints a Colis program to stdout. *) 22 | 23 | val colis_to_string : colis -> string 24 | (** Prints a Colis program to a string. *) 25 | 26 | val colis_to_file : string -> colis -> unit 27 | (** Prints a Colis program to a file. *) 28 | 29 | val pp_print_colis : Format.formatter -> colis -> unit 30 | (** Generic pretty-printing function for Colis. *) 31 | 32 | (** {2 Parsing} *) 33 | 34 | val parse_colis_channel : ?filename:string -> in_channel -> colis 35 | (** Reads Colis syntax from a channel and returns the corresponding AST. 36 | 37 | @raise {!Errors.ParseError} *) 38 | 39 | val parse_colis_file : string -> colis 40 | (** Reads Colis syntax from a file and returns the corresponding AST. 41 | 42 | @raise {!Errors.ParseError} *) 43 | 44 | val parse_colis_string : string -> colis 45 | (** Reads Colis syntax from a string and returns the corresponding AST. 46 | 47 | @raise {!Errors.ParseError} *) 48 | 49 | val convert_shell_file : cmd_line_arguments:string list -> Morsmall.AST.program -> colis 50 | (** Converts the given Shell script to Colis and return the corresponding AST. 51 | 52 | @raise {!Errors.ConversionError} *) 53 | 54 | val parse_shell_file : cmd_line_arguments:string list -> string -> colis 55 | (** Reads Shell from a file, converts it to Colis and returns the 56 | corresponding AST. 57 | 58 | @raise {!Errors.ParseError} 59 | @raise {!Errors.ConversionError} *) 60 | 61 | val embellish_colis : colis -> colis 62 | 63 | end 64 | 65 | (** Modules shared between the different interpreters *) 66 | module Common : sig 67 | module Arguments = Semantics__Arguments 68 | module Behaviour = Semantics__Behaviour 69 | module Config = Semantics__Config 70 | module Context = Semantics__Context 71 | module Env = Semantics__Env 72 | module Input = Semantics__Input 73 | module InterpUtilitySpec = Semantics__InterpUtilitySpec 74 | module Path = Semantics__Path 75 | module Result = Semantics__Result 76 | module Stdin = Semantics__Buffers.Stdin 77 | module Stdout = Semantics__Buffers.Stdout 78 | end 79 | 80 | (** The concrete interpreter *) 81 | module Concrete : sig 82 | module Filesystem = Interpreter__Filesystem 83 | module Interpreter = Interpreter__Interpreter 84 | module State = Interpreter__State 85 | module Semantics = Interpreter__Semantics 86 | 87 | (** {2 Interpreting} *) 88 | 89 | val run : argument0:string -> ?arguments:(string list) -> ?vars:((string * string) list) -> colis -> unit 90 | (** Runs a Colis program. 91 | 92 | @param argument0 Value for argument zero (the interpreter or filename) 93 | @param arguments Other arguments 94 | *) 95 | end 96 | 97 | (** Specification of the initial filesystem *) 98 | module FilesystemSpec = FilesystemSpec 99 | 100 | module Constraints = Colis_constraints 101 | 102 | (** {1 The interpreters} *) 103 | 104 | type sym_config = { 105 | loop_limit: int; (** Maximum number of iterations of while loops in symbolic execution *) 106 | stack_size: int; (** Maximum height of the call stack in symbolic execution *) 107 | filesystem_spec : FilesystemSpec.t; (** Specification of the initial filesystem *) 108 | } 109 | 110 | (** The symbolic interpreter using constraints on the mixed backend of SymbolicUtility *) 111 | module SymbolicConstraints : sig 112 | open Constraints 113 | 114 | include module type of SymbolicUtility.Constraints 115 | 116 | (** Test if an utility is registerered in the mixed backend (the actual backend for this 117 | module) *) 118 | val is_registered : name:string -> bool 119 | 120 | (* Wrapper around [SymbolicUtility.Mixed.interp_program] (sic!) *) 121 | val interp_program : loop_limit:int -> stack_size:int -> argument0:string -> sym_state list -> Language.Syntax.program -> (state list * state list * state list) 122 | 123 | val run : config -> sym_config -> argument0:string -> ?arguments:(string list) -> ?vars:((string * string) list) -> colis -> unit 124 | 125 | val print_state : Format.formatter -> ?id:string -> state -> unit 126 | 127 | val print_states : initials:state list -> (state list * state list * state list) -> unit 128 | 129 | (** {3 For colis-batch} *) 130 | 131 | (** [compile_fs_spec root conj fs_spec] creates a disjunction that represents the conjunction [conj] with constraints representing the filesystem specified by [fs_spec] *) 132 | val add_fs_spec_to_clause : Var.t -> Clause.sat_conj -> FilesystemSpec.t -> Clause.sat_conj list 133 | 134 | (* Create a state corresponding to a conjunction *) 135 | val to_state : prune_init_state:bool -> root:Var.t -> Clause.sat_conj -> state 136 | 137 | (* Create a symbolic states by adding context to a stringe *) 138 | val to_symbolic_state : vars:(string * string) list -> arguments:string list -> state -> sym_state 139 | end 140 | 141 | (** The symbolic interpreter using transducers *) 142 | module SymbolicTransducers : sig 143 | type config = SymbolicUtility.Transducers.config 144 | val run : config -> sym_config -> argument0:string -> ?arguments:(string list) -> ?vars:((string * string) list) -> colis -> unit 145 | end 146 | -------------------------------------------------------------------------------- /src/constraints/model/engine.ml: -------------------------------------------------------------------------------- 1 | open Convert 2 | open Phases 3 | open File_system 4 | open Common 5 | open Print 6 | 7 | let _ = for i = 0 to Array.length Sys.argv - 1 do 8 | Printf.printf "[%i] %s\n" i Sys.argv.(i) 9 | done 10 | (*Arg 1 -> mutate ; Arg 2 -> verbose*) 11 | let (if_mutate,if_print_detail) = if(Array.length Sys.argv >= 3)then 12 | ((Sys.argv.(1) = "1"),(Sys.argv.(2) = "1")) 13 | else (false,true) 14 | let _ = Format.printf "\tMUTATE: %b ; VERBOSE: %b\n\n" if_mutate if_print_detail; 15 | Printf.fprintf out_f_l "\tMUTATE: %b ; VERBOSE: %b\n\n" if_mutate if_print_detail 16 | 17 | let cwd = Colis_constraints.Path.normalize (Colis_constraints.Path.from_string (cwd_s)) 18 | (* 19 | let cwd = [] (*apply cmd from root dir*) 20 | *) 21 | 22 | 23 | let () = 24 | List.iter Colis.SymbolicUtility.Mixed.register [ 25 | (module Colis__Basics.True) ; 26 | (module Colis__Basics.Colon) ; 27 | (module Colis__Basics.False) ; 28 | (module Colis__Basics.Echo) ; 29 | (module Colis__Cp) ; 30 | (module Colis__Rm) ; 31 | (module Colis__Touch) ; 32 | (module Colis__Mkdir) ; 33 | (module Colis__Mv) ; 34 | (module Colis__Test) ; 35 | (module Colis__Test.Bracket) ; 36 | ] 37 | 38 | let printStdout stdO = 39 | Printf.fprintf out_f_l "%s" (Colis__.Semantics__Buffers.Stdout.to_string stdO); 40 | Format.printf "%s" (Colis__.Semantics__Buffers.Stdout.to_string stdO) 41 | 42 | 43 | let rec run_model (res_l:(Colis.SymbolicUtility.Mixed.state * 44 | bool Colis__Semantics__Result.result) 45 | list) (print_b:bool) (num:int) (cmd_mod) (mutate:bool)= 46 | match res_l with 47 | | [] -> () 48 | | (state_,Ok x)::t -> 49 | let (out_fs:Colis__.SymbolicUtility.Mixed.filesystem) = state_.filesystem in 50 | printStdout state_.stdout ; 51 | let s_c = match out_fs with Constraints r -> r.clause | _ -> failwith "not a good fs" in 52 | let rootb = match out_fs with Constraints r -> r.root0 | _ -> failwith "not a good root0" in 53 | let roota = match out_fs with Constraints r -> r.root | _ -> failwith "not a good root" in 54 | let rootb = match rootb with | Some v -> v |None -> failwith "no root before" in 55 | let s_c = Colis_constraints_efficient.sat_conj_to_literals (s_c) in 56 | let s_c = List.of_seq s_c in 57 | let s_c = clause_to_clause s_c in 58 | let _ = if(print_b) then 59 | ( Printf.fprintf out_f_l "\n\n\n\tClause %d [RootB: %d ;RootA: %d; isError: %b] : \n"(num) (var_to_int rootb) (var_to_int roota) (not x); 60 | Format.printf "\n\n\n\tClause %d [RootB: %d ;RootA: %d; isError: %b] : \n"(num) (var_to_int rootb) (var_to_int roota) (not x); 61 | 62 | print_clause (s_c)) else (Printf.fprintf out_f_l "\n\n[MUTATION:%b]Clause %d: \n"(mutate)(num);Format.printf "\n\n[MUTATION:%b]Clause %d: \n"(mutate)(num)) in 63 | engine (s_c) ~m:mutate ~p:print_b ~rootb:(var_to_int rootb) ~roota:(var_to_int roota)(); 64 | test_files_1_2 (var_to_int rootb) (var_to_int roota) (s_c) (not x) (cmd_mod) (print_b); 65 | run_model t print_b (num+1) cmd_mod mutate 66 | | _::t -> Printf.fprintf out_f_l "\n\n\tClause %d : Incomplete\n"(num); 67 | Format.printf "\n\n\tClause %d : Incomplete\n"(num); 68 | run_model t print_b (num+1) cmd_mod mutate 69 | 70 | let isRel s = (let p = String.sub (String.trim(s)) 0 1 in not (p = "/")) 71 | let isOpt s = (let p = String.sub (String.trim(s)) 0 1 in ((p = "-")||(String.trim(s)="!"))) 72 | 73 | let split_cmd (cmd) = 74 | let sl = list_remove "" (String.split_on_char ' ' cmd) in 75 | let rec helper stl = 76 | match stl with 77 | |[]-> ([],[]) 78 | |h::t -> let h_mod = (if(not (isOpt h))then 79 | (if(isRel h) then "."^cwd_s^"/"^h 80 | else "./"^h) 81 | else h) in (*CHANGE HERE*) 82 | let (hl_1,hl_2) = helper t in 83 | (h::hl_1,h_mod::hl_2) 84 | in 85 | (List.hd sl,helper (List.tl sl)) 86 | 87 | let get_result (cmd) ?(m = false) ?(p = true) () = 88 | 89 | let (utility_context_:Colis__Semantics__UtilityContext.utility_context) = { 90 | cwd = cwd; 91 | env = Colis__.Env.SMap.empty; 92 | args = []; 93 | } in 94 | let (utility_name,(args,args_mod)) = split_cmd (cmd) in 95 | let cmd_mod = utility_name^" "^(String.concat " " args_mod) in 96 | let utility_ = Colis.SymbolicUtility.Mixed.call (utility_name) (utility_context_) (args) in 97 | let root_v = (Colis_constraints_common__Var.fresh ()) in 98 | let (initial_fs:Colis__.SymbolicUtility.Mixed.filesystem) = Constraints { 99 | root = root_v; 100 | clause = Colis_constraints_efficient.true_sat_conj; 101 | root0 = Some root_v; 102 | } in 103 | let (initial_state:Colis__.SymbolicUtility.Mixed.state) = { 104 | filesystem = initial_fs; 105 | stdin = []; 106 | stdout = Colis__.Semantics__Buffers.Stdout.empty; 107 | log = Colis__.Semantics__Buffers.Stdout.empty; 108 | } in 109 | let _ = Printf.fprintf out_f_l "\nCMD: %s" (cmd); 110 | Format.printf "\nCMD: %s" (cmd); 111 | Printf.fprintf out_f_l "\nCMD_Mod: %s" (cmd_mod); 112 | Format.printf "\nCMD_Mod: %s" (cmd_mod) in 113 | 114 | let result_list = try utility_ initial_state with 115 | e -> 116 | let msg = Printexc.to_string e in 117 | Printf.fprintf out_f_l "\nEXCEPTION: [%s]" msg; 118 | Format.printf "\nEXCEPTION: [%s]" msg; 119 | [initial_state,Incomplete] in 120 | 121 | let _ = Printf.fprintf out_f_l "\nNo of Clauses : %d" (List.length result_list); 122 | Format.printf "\nNo of Clauses : %d" (List.length result_list) in 123 | let _ = run_model result_list p 1 cmd_mod m in 124 | () 125 | 126 | let rec loop_cmd (cmd_l) ?(m = false) ?(p = true) ()= 127 | match cmd_l with 128 | |[] -> () 129 | |h::t -> Printf.fprintf out_f_l "-------------------------------------------------------------------------"; 130 | Format.printf "-------------------------------------------------------------------------"; 131 | get_result h ~m:m ~p:p (); 132 | loop_cmd t ~m:m ~p:p () 133 | 134 | let read_file filename = 135 | let lines = ref [] in 136 | let chan = open_in filename in 137 | try 138 | while true; do 139 | lines := input_line chan :: !lines 140 | done; !lines 141 | with End_of_file -> 142 | close_in chan; 143 | List.rev !lines ;; 144 | 145 | let cmd_file = "cmd.dat" 146 | (*m-> boolean specifying if mutuate; p->boolean specifying if print detail*) 147 | let _ = loop_cmd (read_file cmd_file) ~m:if_mutate ~p:if_print_detail () 148 | 149 | (*For single cmd (use for debugging) 150 | let cmd = "mkdir ./a/b" 151 | let _ = get_result cmd ~m:true ~p:true () 152 | *) 153 | -------------------------------------------------------------------------------- /src/constraints/model/doc/colis.bib: -------------------------------------------------------------------------------- 1 | @inproceedings{DBLP:conf/tacas/BeckerJMRST20, 2 | author = {Benedikt F. H. Becker and 3 | Nicolas Jeannerod and 4 | Claude March{\'{e}} and 5 | Yann R{\'{e}}gis{-}Gianas and 6 | Mihaela Sighireanu and 7 | Ralf Treinen}, 8 | editor = {Armin Biere and 9 | David Parker}, 10 | title = {Analysing installation scenarios of Debian packages}, 11 | booktitle = {Tools and Algorithms for the Construction and Analysis of Systems 12 | - 26th International Conference, {TACAS} 2020, Held as Part of the 13 | European Joint Conferences on Theory and Practice of Software, {ETAPS} 14 | 2020, Dublin, Ireland, April 25-30, 2020, Proceedings, Part {II}}, 15 | series = {Lecture Notes in Computer Science}, 16 | volume = {12079}, 17 | pages = {235--253}, 18 | publisher = {Springer}, 19 | year = {2020}, 20 | url = {https://doi.org/10.1007/978-3-030-45237-7\_14}, 21 | doi = {10.1007/978-3-030-45237-7\_14}, 22 | timestamp = {Wed, 12 Aug 2020 17:59:01 +0200}, 23 | biburl = {https://dblp.org/rec/conf/tacas/BeckerJMRST20.bib}, 24 | bibsource = {dblp computer science bibliography, https://dblp.org} 25 | } 26 | 27 | @inproceedings{becker:hal-02276257, 28 | TITLE = {{Ghost Code in Action: Automated Verification of a Symbolic Interpreter}}, 29 | AUTHOR = {Becker, Benedikt and March{\'e}, Claude}, 30 | URL = {https://hal.inria.fr/hal-02276257}, 31 | BOOKTITLE = {Verified Software: Tools, Techniques and Experiments}, 32 | EDITOR = {Supratik Chakraborty and Jorge A.Navas}, 33 | SERIES = {Lecture Notes in Computer Science}, 34 | YEAR = {2019}, 35 | PDF = {https://hal.inria.fr/hal-02276257/file/Ghost_Code_in_Action_Automated_Verification_of_a_Symbolic_Interpreter.pdf}, 36 | HAL_ID = {hal-02276257}, 37 | HAL_VERSION = {v1}, 38 | } 39 | 40 | @inproceedings{regisgianas:hal-01890044, 41 | TITLE = {{Morbig}: A Static Parser for {POSIX} Shell}, 42 | AUTHOR = {R{\'e}gis-Gianas, Yann and Jeannerod, Nicolas and Treinen, Ralf}, 43 | URL = {https://hal.archives-ouvertes.fr/hal-01890044}, 44 | BOOKTITLE = {ACM SIGPLAN International Conference on Software Language Engineering}, 45 | pages = {29--41}, 46 | editor = {David Pearce and Tanja Mayerhofer and Friedrich Steimann}, 47 | YEAR = {2018}, 48 | month = nov, 49 | address = "Boston, MA, USA", 50 | DOI = {10.1145/3276604.3276615}, 51 | KEYWORDS = {Parsing ; POSIX shell ; Functional programming}, 52 | PDF = {https://hal.archives-ouvertes.fr/hal-01890044/file/main.pdf}, 53 | HAL_ID = {hal-01890044}, 54 | HAL_VERSION = {v1}, 55 | } 56 | 57 | @inproceedings{jeannerod:hal-01807474, 58 | TITLE = {Deciding the First-Order Theory of an Algebra of Feature Trees with Updates}, 59 | AUTHOR = {Jeannerod, Nicolas and Treinen, Ralf}, 60 | URL = {https://hal.archives-ouvertes.fr/hal-01807474}, 61 | BOOKTITLE = {9th International Joint Conference on Automated Reasoning}, 62 | editor = {Didier Galmiche and Stephan Schulz and Roberto Sebastiani}, 63 | YEAR = {2018}, 64 | month = jul, 65 | pages = {439--454}, 66 | address = {Oxford, UK}, 67 | series = {Lecture Notes in Computer Science}, 68 | volume = {10900}, 69 | publisher = {Springer}, 70 | HAL_ID = {hal-01807474}, 71 | HAL_VERSION = {v1}, 72 | } 73 | 74 | @inproceedings{jeannerod:hal-01534747, 75 | TITLE = {{A Formally Verified Interpreter for a Shell-like Programming Language}}, 76 | AUTHOR = {Jeannerod, Nicolas and March{\'e}, Claude and Treinen, Ralf}, 77 | URL = {https://hal.archives-ouvertes.fr/hal-01534747}, 78 | BOOKTITLE = {9th Working Conference on Verified Software: Theories, Tools, and Experiments}, 79 | SERIES = {Lecture Notes in Computer Science}, 80 | VOLUME = {10712}, 81 | YEAR = {2017}, 82 | PDF = {https://hal.archives-ouvertes.fr/hal-01534747/file/jeannerod-marche-treinen-vstte17.pdf}, 83 | HAL_ID = {hal-01534747}, 84 | HAL_VERSION = {v1}, 85 | } 86 | 87 | @inproceedings{jeannerod:hal-01432034, 88 | TITLE = {Le coquillage dans le {CoLiS}-mateur}, 89 | AUTHOR = {Jeannerod, Nicolas}, 90 | URL = {https://hal.archives-ouvertes.fr/hal-01432034}, 91 | BOOKTITLE = {Vingt-huiti{\`e}me Journ{\'e}es Francophones des Langages Applicatifs}, 92 | YEAR = {2017}, 93 | PDF = {https://hal.archives-ouvertes.fr/hal-01432034/file/main.pdf}, 94 | HAL_ID = {hal-01432034}, 95 | HAL_VERSION = {v1}, 96 | } 97 | 98 | @techreport{jeannerod:hal-01513750, 99 | TITLE = {Having Fun With 31.521 Shell Scripts}, 100 | AUTHOR = {Jeannerod, Nicolas and R{\'e}gis-Gianas, Yann and Treinen, Ralf}, 101 | URL = {https://hal.archives-ouvertes.fr/hal-01513750}, 102 | YEAR = {2017}, 103 | INSTITUTION = {HAL Archives Ouvertes}, 104 | PDF = {https://hal.archives-ouvertes.fr/hal-01513750/file/main.pdf}, 105 | HAL_ID = {hal-01513750}, 106 | HAL_VERSION = {v1}, 107 | } 108 | 109 | @techreport{jeannerod19tr, 110 | TITLE = {Specification of {UNIX} Utilities}, 111 | AUTHOR = {Jeannerod, Nicolas and R{\'e}gis-Gianas, Yann and March{\'e}, Claude and Sighireanu, Mihaela and Treinen, Ralf}, 112 | URL = {https://hal.inria.fr/hal-02321691}, 113 | TYPE = {Technical Report}, 114 | INSTITUTION = {HAL Archives Ouvertes}, 115 | YEAR = 2019, 116 | MONTH = oct 117 | } 118 | 119 | 120 | @techreport{becker19tr, 121 | TITLE = {Revision 2 of {CoLiS} language: formal syntax, semantics, concrete and symbolic interpreters}, 122 | AUTHOR = {Becker, Benedikt and March{\'e}, Claude and Jeannerod, Nicolas and Treinen, Ralf}, 123 | URL = {https://hal.inria.fr/hal-02321743}, 124 | TYPE = {Technical Report}, 125 | INSTITUTION = {HAL Archives Ouvertes}, 126 | YEAR = 2019, 127 | MONTH = oct 128 | } 129 | 130 | 131 | @Article{bobot14sttt, 132 | doi = {10.1007/s10009-014-0314-5}, 133 | hal_id = {hal-00967132}, 134 | url = {http://hal.inria.fr/hal-00967132/en}, 135 | author = {Fran\c{c}ois Bobot and Jean-Christophe Filli\^atre and Claude March\'e and Andrei Paskevich}, 136 | title = {Let's Verify This with {Why3}}, 137 | journal = {International Journal on Software Tools for Technology Transfer (STTT)}, 138 | volume = 17, 139 | number = 6, 140 | pages = {709--727}, 141 | year = 2015, 142 | note = "See also \url{http://toccata.lri.fr/gallery/fm2012comp.en.html}", 143 | publisher = {Springer Berlin / Heidelberg}, 144 | x-type = {article}, 145 | x-support = {revue}, 146 | x-cle-support = {STTT}, 147 | x-international-audience = {yes}, 148 | x-editorial-board={yes} 149 | } 150 | 151 | @misc{github-colis, 152 | title = {The {CoLiS} toolchain}, 153 | author = {{The CoLiS project}}, 154 | howpublished = {\url{https://github.com/colis-anr}} 155 | } 156 | 157 | @misc{bench-colis, 158 | title = {The {CoLiS} bench}, 159 | author = {{The CoLiS project}}, 160 | howpublished = 161 | {\url{http://ginette.informatique.univ-paris-diderot.fr/~niols/colis-batch/}}} 162 | 163 | @misc{artifact, 164 | author = {{The CoLiS project}}, 165 | title = {{Artifact for Analysing installation scenarios of Debian Packages}}, 166 | month = feb, 167 | year = 2020, 168 | publisher = {Zenodo}, 169 | howpublished = {Zenodo Repository}, 170 | doi = {10.5281/zenodo.3678390} 171 | } 172 | -------------------------------------------------------------------------------- /src/constraints/model/file_system.ml: -------------------------------------------------------------------------------- 1 | open Common 2 | open Inode 3 | 4 | (* DEPRICATED 5 | let get_vBigSet () = 6 | let ll = VarMap.bindings !var_map in 7 | let rec helper ll = 8 | match ll with 9 | |[] -> [] 10 | |(v,_)::t -> v::(helper t) 11 | in helper ll 12 | 13 | let get_unreachable () = 14 | let vBigSet = ref (get_vBigSet ())in 15 | let ll = VarMap.bindings !var_map in 16 | let rec helper1 ll = 17 | match ll with 18 | |[] -> (list_remove 0 !vBigSet) 19 | |(_,v_node)::t -> let l = FMap.bindings (v_node.feat) in 20 | let rec helper2 l = 21 | match l with 22 | |[] -> helper1 t 23 | |(_,v2)::t2-> vBigSet := (list_remove v2 !vBigSet); 24 | helper2 t2 25 | in helper2 l 26 | in helper1 ll 27 | *) 28 | 29 | let rec get_path (v) (v_cycle) (path) (f)= 30 | let ll = FMap.bindings ((find_node v).feat) in 31 | if(List.mem v v_cycle)then failwith "Cycle Clash" 32 | else if((ll=[])||(v=0)) then 33 | paths := (path,f,v)::(!paths) 34 | else 35 | (let rec helper ll = 36 | match ll with 37 | |[] -> () 38 | |(f2,v2)::t when v2 = 0 -> 39 | get_path (v2) (v::v_cycle) (path) (f2); 40 | helper t 41 | |(f2,v2)::t -> if((find_node v2).kind = Reg) then 42 | (get_path (v2) (v::v_cycle) (path) (f2); 43 | helper t) 44 | else 45 | (get_path (v2) (v::v_cycle) (path^"/"^f2) (""); 46 | helper t) 47 | in helper ll) 48 | 49 | let rec mkdir_from_path path_list = 50 | match path_list with 51 | |[] -> () 52 | |(h,f,v)::t when ((v <> 0) && (f <> "")) -> 53 | let h1 = "mkdir -p "^h in 54 | let h2 = "touch "^(h^"/"^f) in 55 | print_collect := !print_collect^h1^"\n"^h2^"\n" ;ignore (Sys.command h1); 56 | ignore (Sys.command h2); 57 | mkdir_from_path t 58 | 59 | |(h,_,_)::t -> let h = "mkdir -p "^h in 60 | print_collect := !print_collect^h^"\n" ;ignore (Sys.command h); 61 | mkdir_from_path t 62 | 63 | let path_exists p = (Sys.command("test -e "^p)=0) 64 | let file_exists p = (Sys.command("test -f "^p)=0) 65 | 66 | let rec check_path path_list = 67 | match path_list with 68 | |[] -> true 69 | |(h,f,_)::t when f = "" -> 70 | print_collect := !print_collect^"check : "^h^"\n" ; 71 | if(path_exists h)then check_path t else false 72 | |(h,f,v)::t when v = 0-> 73 | let h2 = (h^"/"^f) in 74 | print_collect := !print_collect^"check : "^h^"\t" ; 75 | print_collect := !print_collect^"check Abs : "^h2^"\n" ; 76 | if((path_exists h) && (not (path_exists h2)))then 77 | check_path t else false 78 | |(h,f,_)::t -> print_collect := !print_collect^"check Reg : "^(h^"/"^f)^"\n" ; 79 | if(file_exists (h^"/"^f))then check_path t else false 80 | 81 | 82 | 83 | 84 | (*FOR PC USE BELOW*) 85 | (* 86 | let safe_dir = "/media/ap/New Volume/IIIT Kalyani/Internships/Feature Tree Logic/Reverse/ADifferentWay/Test region/InnerTR/Inner2TR/Inner3TR" 87 | let create_TR () = 88 | ignore (Sys.chdir safe_dir); 89 | ignore (Sys.command "mkdir ./TR"); 90 | Sys.chdir("./TR");() *) 91 | 92 | (*FOR DOCKER USE BELOW*) 93 | 94 | let safe_dir = cwd_s 95 | 96 | let create_TR () = 97 | ignore (Sys.command ("mkdir -p "^safe_dir)); 98 | ignore (Sys.chdir safe_dir); 99 | ignore (Sys.command ("mkdir -p ./TR"^safe_dir)); 100 | Sys.chdir("./TR");() 101 | 102 | let shell_script cmd = 103 | ignore (Sys.command ("mkdir -p ."^safe_dir)); 104 | print_collect := !print_collect^cmd^"\n" ; 105 | if(Sys.command cmd = 0)then true else false 106 | 107 | (* 108 | let shell_script cmd = 109 | print_collect := !print_collect^cmd^"\n" ; 110 | if(Sys.command cmd = 0)then true else false 111 | *) 112 | let clean_TR () = 113 | Sys.chdir(".."); 114 | ignore (Sys.command "rm -r ./TR/*"); 115 | Sys.chdir("./TR");() 116 | 117 | (*DEPRICATED:without ID check 118 | let test_files ()= 119 | let l = get_unreachable () in 120 | let rec helper l count = 121 | match l with 122 | |[root_after;root_before] -> 123 | if(count = 3) then failwith "Test Fail" 124 | else 125 | create_TR (); 126 | clean_TR (); 127 | paths:= []; 128 | get_path root_before [] "." ""; 129 | mkdir_from_path (!paths); 130 | shell_script (); 131 | paths:= []; 132 | get_path root_after [] "." ""; 133 | if(check_path (!paths)) then Format.printf "CHECK SUCCESS" 134 | else 135 | (Format.printf "Failure\n" ;(helper [root_before;root_after] (count+1))) 136 | 137 | |_ -> failwith "Not exactly 2 unreachable" 138 | in helper l 1*) 139 | 140 | let test_files_1_2 (root_before) (root_after) (clau) (is_error) (cmd) (print_b) = 141 | let _ = if(VarMap.find_opt root_before !var_map)=None 142 | then var_map := VarMap.add root_before (empty_node root_before) (!var_map) else () in 143 | let _ = if(VarMap.find_opt root_after !var_map)=None 144 | then var_map := VarMap.add root_after (empty_node root_after) (!var_map) else () in 145 | create_TR (); 146 | clean_TR (); 147 | paths:= []; 148 | get_path root_before [] "." ""; 149 | mkdir_from_path (!paths); 150 | set_id root_before "."; 151 | if(shell_script cmd <> is_error) then 152 | (paths:= []; 153 | get_path root_after [] "." ""; 154 | if(check_path (!paths)) then 155 | let _ = if(print_b) then (Printf.fprintf out_f_l "%s" (!print_collect);Format.printf "%s" (!print_collect) ) else () in 156 | print_collect := ""; 157 | (Printf.fprintf out_f_l "\t\t***PATH CHECK SUCCESS***\n"; 158 | Format.printf "\t\t***PATH CHECK SUCCESS***\n"; 159 | Printf.fprintf out_f_l "%s" "\t\t\tID Dissolve Repot\nEquality(*) Dissolve Error:\t"; 160 | Format.printf "%s" "\t\t\tID Dissolve Repot\nEquality(*) Dissolve Error:\t"; 161 | check_id root_after "."; 162 | 163 | Printf.fprintf out_f_l "%s" "SIM(F) Dissolve Error:\t"; 164 | Format.printf "%s" "SIM(F) Dissolve Error:\t"; 165 | dissolve_id_sim clau; 166 | check_id root_after "."; 167 | 168 | Printf.fprintf out_f_l "%s" "Equality(F) Dissolve Error:\t"; 169 | Format.printf "%s" "Equality(F) Dissolve Error:\t"; 170 | dissolve_id_eqf clau; 171 | check_id root_after "."; 172 | ) 173 | else 174 | (Printf.fprintf out_f_l "%s \t\t-----PATH CHECK FAILURE-----\n" (!print_collect); 175 | Format.printf "%s \t\t-----PATH CHECK FAILURE-----\n" (!print_collect)) ) 176 | 177 | else (Printf.fprintf out_f_l "%s %s" (!print_collect) (if(is_error)then "\nCMD does not give an error(But it should)\n" else "\nCMD gives an error\n"); 178 | Format.printf "%s %s" (!print_collect) (if(is_error)then "\nCMD does not give an error(But it should)\n" else "\nCMD gives an error\n")) 179 | -------------------------------------------------------------------------------- /src/constraints/model/phases.ml: -------------------------------------------------------------------------------- 1 | open Common 2 | open Process_atom 3 | open Mutate 4 | open Print 5 | 6 | let is_feature_in_cwd (cwd) (f)= 7 | let cwd_l = list_remove "" (String.split_on_char '/' cwd) in 8 | let rec helper = function 9 | |[] -> false 10 | |h::_ when (h=f) -> true 11 | |_::t -> helper t 12 | in 13 | helper cwd_l 14 | 15 | let dissolve_all () = 16 | let var_map_l = VarMap.bindings !var_map in 17 | let rec helper var_map_l = 18 | match var_map_l with 19 | |[] -> () 20 | |(_,n_1)::t -> disolve_node n_1 ; 21 | helper t 22 | in 23 | helper var_map_l 24 | 25 | let rec create_empty_var_map clause = 26 | match clause with 27 | |[] -> var_map := VarMap.add 0 (empty_node 0) (!var_map); (*Var 0 is used to respresent absent mapping*) 28 | () 29 | |Pos Feat(v1,f,v2)::t| Neg Feat(v1,f,v2)::t -> 30 | var_map := VarMap.add v1 (empty_node v1) (!var_map); 31 | var_map := VarMap.add v2 (empty_node v2) (!var_map); 32 | fBigSet := FSet.add f (!fBigSet); 33 | create_empty_var_map t 34 | 35 | |Pos Abs (v1,f)::t| Neg Abs (v1,f)::t -> 36 | var_map := VarMap.add v1 (empty_node v1) (!var_map); 37 | fBigSet := FSet.add f (!fBigSet); 38 | create_empty_var_map t 39 | 40 | |Pos Eqf (v1,fl,v2)::t| Neg Eqf (v1,fl,v2)::t -> 41 | var_map := VarMap.add v1 (empty_node v1) (!var_map); 42 | var_map := VarMap.add v2 (empty_node v2) (!var_map); 43 | fBigSet := FSet.union (FSet.of_list fl) (!fBigSet); 44 | create_empty_var_map t 45 | 46 | |Pos Eq(v1,v2)::t| Neg Eq(v1,v2)::t -> 47 | var_map := VarMap.add v1 (empty_node v1) (!var_map); 48 | var_map := VarMap.add v2 (empty_node v2) (!var_map); 49 | create_empty_var_map t 50 | 51 | |Pos Sim (v1,fl,v2)::t| Neg Sim (v1,fl,v2)::t-> 52 | var_map := VarMap.add v1 (empty_node v1) (!var_map); 53 | var_map := VarMap.add v2 (empty_node v2) (!var_map); 54 | fBigSet := FSet.union (FSet.of_list fl) (!fBigSet); 55 | create_empty_var_map t 56 | 57 | |Pos Fen(v1,fl)::t| Neg Fen(v1,fl)::t -> 58 | var_map := VarMap.add v1 (empty_node v1) (!var_map); 59 | fBigSet := FSet.union (FSet.of_list fl) (!fBigSet); 60 | create_empty_var_map t 61 | |Pos Kind(v1,_)::t| Neg Kind(v1,_)::t -> var_map := VarMap.add v1 (empty_node v1) (!var_map); 62 | create_empty_var_map t 63 | |Pos Maybe(v1,f,v2)::t| Neg Maybe(v1,f,v2)::t -> 64 | var_map := VarMap.add v1 (empty_node v1) (!var_map); 65 | var_map := VarMap.add v2 (empty_node v2) (!var_map); 66 | fBigSet := FSet.add f (!fBigSet); 67 | create_empty_var_map t 68 | 69 | let rec clause_phase_I (clau:clause) = 70 | match clau with 71 | |[] -> () 72 | |Pos Eqf(v1,fl,v2)::t -> add_equal_to_node (Eqf(v1,fl,v2)); 73 | clause_phase_I t 74 | |Pos Sim(v1,fl,v2)::t -> add_sim_to_node (Sim(v1,fl,v2)); 75 | clause_phase_I t 76 | |Pos Fen(v1,fl)::t -> add_fen_to_node (Fen(v1,fl)); 77 | clause_phase_I t 78 | |Pos Kind(v1,k)::t -> add_kind_to_node (Kind(v1,k)); 79 | clause_phase_I t 80 | |Neg Kind(v1,k)::t -> let k = if(k = Dir) then Reg else if(k= Reg) then Dir else Other in 81 | add_kind_to_node (Kind(v1,k)); 82 | clause_phase_I t 83 | | _ :: t -> clause_phase_I t 84 | 85 | let rec clause_phase_II (clau:clause) = 86 | match clau with 87 | |[] -> () 88 | |Pos Eq(v1,v2)::t -> let new_node = node_union (find_node v1) (find_node v2) in 89 | var_map := VarMap.add v1 new_node !var_map; 90 | var_map := VarMap.add v2 new_node !var_map; 91 | clause_phase_II t 92 | | _ :: t -> clause_phase_II t 93 | 94 | let rec clause_phase_III (clau:clause) = 95 | match clau with 96 | |[] -> () 97 | |Pos Feat(v1,f,v2)::t -> add_feat_to_node (Feat(v1,f,v2)); 98 | clause_phase_III t 99 | |Pos Abs (v1,f)::t -> add_abs_to_node (Abs(v1,f)); 100 | clause_phase_III t 101 | |Pos Maybe (v1,f,v2)::t -> (if(((Random.int 10) < 7) || (is_feature_in_cwd cwd_s f)) then 102 | add_feat_to_node (Feat(v1,f,v2)) 103 | else add_abs_to_node (Abs(v1,f))); 104 | clause_phase_III t 105 | | _ :: t -> clause_phase_III t 106 | 107 | let rec clause_phase_IV (clau:clause) = 108 | match clau with 109 | |[] -> () 110 | |Neg Feat(v1,f,v2)::t -> no_feat_abs_to_node (Feat(v1,f,v2)); 111 | clause_phase_IV t 112 | |Neg Abs (v1,f)::t -> no_feat_abs_to_node (Abs(v1,f)); 113 | clause_phase_IV t 114 | | _ :: t -> clause_phase_IV t 115 | 116 | let rec clause_phase_V (clau:clause) = 117 | match clau with 118 | |[] -> () 119 | |Neg Fen(v1,fl)::t -> not_Fen_transform (Fen(v1,fl)); 120 | clause_phase_V t 121 | |Neg Eqf(v1,fl,v2)::t -> if(v1=v2) then failwith "Clash: x =/=F x" 122 | else not_eq_sim_transform (Eqf(v1,fl,v2)); 123 | clause_phase_V t 124 | |Neg Eq(v1,v2)::t -> if(v1=v2) then failwith "Clash: x =/= x" 125 | else not_eq_sim_transform (Eqf(v1,FSet.elements !fBigSet,v2)); 126 | clause_phase_V t 127 | |Neg Sim(v1,fl,v2)::t -> if(v1=v2) then failwith "Clash: x ~/~F x" 128 | else not_eq_sim_transform (Sim(v1,fl,v2)); 129 | clause_phase_V t 130 | | _ :: t -> clause_phase_V t 131 | 132 | let set_v_max_all () = 133 | let rec helper vm_l = 134 | match vm_l with 135 | |[]-> () 136 | |(v,_)::t-> v_all := VSet.add v !v_all; 137 | v_max := if(!v_max < v)then v else !v_max; 138 | v_min := if((!v_min > v)&&(v<>0))then v else !v_min; 139 | helper t 140 | in 141 | helper (VarMap.bindings !var_map) 142 | 143 | let reintializ_ref roota rootb = 144 | var_map := VarMap.empty; 145 | fBigSet := FSet.empty; 146 | v_all := VSet.empty; 147 | v_max := 0; 148 | v_min := max_int; 149 | print_collect := ""; 150 | var_map := VarMap.add roota (empty_node roota) (!var_map); 151 | var_map := VarMap.add rootb (empty_node rootb) (!var_map) 152 | 153 | let engine (clau_1:clause) ?(m = false) ?(p = true) ?(m_v = 10) ?(rootb = 1) ?(roota = 1)() = 154 | reintializ_ref roota rootb; 155 | (*let clau_1 = (if (m) then (mutate clau_1 m_v rootb) else clau_1) in 156 | let _ = (if(m&&p)then (Format.printf "Mutant Clause :";print_clause clau_1) else ()) in*) 157 | 158 | create_empty_var_map clau_1; 159 | clause_phase_I clau_1; 160 | set_v_max_all (); 161 | clause_phase_II clau_1; 162 | clause_phase_III clau_1; 163 | clause_phase_IV clau_1; 164 | clause_phase_V clau_1; 165 | dissolve_all (); 166 | let clau_1 = (if (m) then (mutate clau_1 m_v rootb) else clau_1) in 167 | let _ = (if(m&&p)then (Printf.fprintf out_f_l "Mutant Clause :";Format.printf "Mutant Clause :";print_clause clau_1) else ()) in 168 | dissolve_all () 169 | (*var_map_display !var_map*) 170 | (*execute !mkdir*) 171 | 172 | 173 | 174 | 175 | (*engine clau_1 ~m:true ();;*) -------------------------------------------------------------------------------- /NOTES.org: -------------------------------------------------------------------------------- 1 | #+TITLE: Notes on the design of the CoLiS language 2 | #+OPTIONS: ^:nil 3 | * Syntax 4 | ** Functions 5 | - one cannot use a name and then define a function with that name 6 | ** Exit 7 | - CM: TODO ~exit $ret~ not representable? Add ~CVar var~ to ~return_code~? ~SExit sexpr~ 8 | instead with ~$?~ as expression? Stuck when sexpr not numerical/boolean? 9 | - NJ: ~exit $var~ is rather rare (33 times), ~return $var~ as well (17 times) 10 | - NJ/BB: ~SExit statement~? No ~$?~ needed, keep boolean values hidden, represent ~exit 0~ 11 | as ~SExit (SCall ["true"]~ 12 | - CM: Do no implement ~SExit statement~ because this contradicts Shell syntax too much 13 | - Summary 2018/11/26: No clear best solution, keep ~SExit (0|1|$?)~ for now 14 | ** Previous result 15 | - Syntax in Shell: ~$?~ 16 | - NJ: Yes, $? will be a small problem. Because it is an integer in Shell and will be a 17 | boolean in CoLiS, which means that we have to be a bit careful when it is used. 18 | - not in strings, only as argument for ~SExit~ 19 | ** Arguments list 20 | Syntax in Shell: ~$@~ 21 | - not required for now (no functions, no shift) 22 | - could be added by replacing Call name exprs with Call exprs and defining ~type exprs = 23 | list (sexpr, split) | $@~ (pseudocode) 24 | - but the callable will not be statically known any more 25 | ** Shell callees 26 | - special builtins :: operates on full environment 27 | - functions :: 28 | - naming ambiguity with special builtins is prohibited 29 | - built using special builtins 30 | - operates full environment 31 | - utitilies (builtins, on $PATH) :: 32 | - reads: stdin, arguments 33 | - writes: return code, stdout, stderr 34 | - does not read environment variables for the moment, this would require ~export~ flag 35 | on variables 36 | - no general access to environment (e.g., no change of variables) 37 | - no real difference between builtins and execs on $PATH, difference only for efficacy 38 | *** Shell callees in CoLiS 39 | - special builtins as syntactic constructs 40 | - only ~exit~ for now 41 | - ~set~: not for now 42 | - ~cd~: should be syntactic construct, not builtin like in Shell, rarely used, not for 43 | now 44 | - ~export~: NJ, not used? 45 | - ~source~: mostly absolute files in corpus, expand in AST while parsing 46 | - no functions 47 | - everything else interpreted as command 48 | - CoLiS stucks for unknown utilities, exception for interpreter 49 | ** Break/continue 50 | - around 100 scripts in the Debian corpus 51 | - leave out for now, can be easily added 52 | ** Stdin/stdout 53 | - stdin and stdout are string lists to simplify the specification of ~echo~ and ~read~ 54 | - stdout has invariant ~stdout <> []~ 55 | - empty stdout is singleton list 56 | - stdout: print by expanding the first line, newline conses an empty string 57 | - ~echo -n~ adds to last element, echo adds to last element, and appends "" 58 | #+begin_src ocaml 59 | let echo (n: bool) (line: string) (stdout: string list) : string list = 60 | match stdout with 61 | | [] -> assert false 62 | | h :: t -> 63 | let stdout = (h ^ line) :: t in 64 | if n then stdout else "" :: stdout 65 | #+end_src 66 | - the last line is lost when piping: 67 | #+begin_src sh 68 | (echo A; echo -n B) | while read x; do echo $x; done 69 | #+end_src 70 | 71 | #+RESULTS: 72 | : A 73 | - NO! This is due to ~read~, the last line is kept by indirection and embedded 74 | #+begin_src sh 75 | (echo A; echo -n B)|cat 76 | #+end_src 77 | 78 | #+RESULTS: 79 | | A | 80 | | B | 81 | 82 | #+begin_src sh 83 | x=$(echo A; echo -n B) 84 | echo $x 85 | #+end_src 86 | 87 | #+RESULTS: 88 | : A B 89 | 90 | ** Statement ~exit~ 91 | :PROPERTIES: 92 | :CUSTOM_ID: stmt_exit 93 | :END: 94 | *** CM: TODO ~exit $ret~ not representable? [2018-09-20 Thu] 95 | Add ~CVar var~ to ~return_code~? 96 | ~SExit sexpr~ instead with ~$?~ as expression? 97 | Stuck when sexpr not numerical/boolean? 98 | *** NJ: exit $ret is rather rare [2018-09-25 Tue] 99 | - 33 times in ~exit~, 100 | - 17 in ~return~ 101 | *** NJ/BB: ~SExit statement~? [2018-09-25 Tue] 102 | - No ~$?~ needed then 103 | - keep boolean values hidden 104 | - represent ~exit 0~ as ~SExit (SCall ["true"]~ 105 | *** CM: Do no implement `SExit statement` [2018-09-26 Wed] 106 | - because this contradicts Shell syntax too much 107 | *** Summary [2018-09-26 Wed] 108 | - No clear best solution 109 | - keep ~SExit (0|1|$?)~ for now 110 | ** Conditionals 111 | - dependencies (←) between commands: 112 | - ~if~ and ~not~ ← ~&&~ and ~||~ ← ~case~ 113 | - with matching only literals and anything ~*~ 114 | - only ~if~ and ~not~ for now 115 | - for now: Only ~if~ / ~not~, other can be emulated, and added if need be 116 | ** Redirections 117 | - simplify ~x >&2~ as statement ~IgnoreStdout x~ 118 | ** Strict 119 | - single flag indicating evaluation under condition for now 120 | - ~set -e/+e~ requires second flag 121 | #+begin_src sh 122 | dash -ec 'if set +e; then echo X; fi; false; echo A/$?'; echo --$?~ 123 | #+end_src 124 | 125 | #+RESULTS: 126 | | X | 127 | | A/1 | 128 | | --0~ | 129 | 130 | - To implement ~set -e/+e~, a second field indicating the global strict mode 131 | (~strict_mode~) has to be added in the state and added in this test as ~ctx.strict_mode 132 | && negb ctx.under_condition~ to account for the following example: 133 | ** Shift 134 | - used in only ~250 scripts, leave out for now, depends on functions 135 | ** Strings 136 | - Shells disagree if subshells in a string set previous result ~$?~: dash does not have 137 | the same behaviour as bash --posix in the following example. And the standard is not 138 | really clear in that regard. It only says "$? expands to the decimal exit status of the 139 | most recent pipeline (see Pipelines)." 140 | #+begin_src sh 141 | x=$(exit 123)$(echo A/$?)-$(echo B/$?) 142 | echo $x 143 | #+end_src 144 | *** Alternative AST for strings 145 | - Or concat as flat list of expressions in a separate type instead? 146 | - this would result in an equivalent but more canonical representation and no lemmas on 147 | associativity and transitivity of EConcat. 148 | - Decide when needed. 149 | #+begin_src ocaml 150 | (* evaluates to string *) 151 | type string_component = Literal string | Variable var | Subshell stmt 152 | 153 | (* evaluates to string *) 154 | type string_expression = Concat (list string_component) 155 | 156 | (* evaluates to string list, only in the context of call/for-loop *) 157 | type sexprs = list (string_expression, split) 158 | #+end_src 159 | ** String lists 160 | * Concrete semantics 161 | ** Macros in specification 162 | required for specification in CLS 163 | - procedures (simple) 164 | - lists (~rev~) 165 | - functions on strings to lists (~but_last~, ~prefixes~) 166 | proposition: specification in well-defined "Pseudo-CoLiS", implementation in OCaml 167 | 168 | ** TODO Evaluation relation 169 | TODO describe types input/context/state/output 170 | *** Evaluation env 171 | - currently only the variable environemnt 172 | - will contain function environment when we add functions 173 | ** Buffers 174 | - stdout in separate module 175 | - NJ: we just have to be sure that the buffer has enough information for the proof 176 | obligations to be easy. In particular, it could be nice to have an easy way to write 177 | ~exists s. stdout = (old stdout) ^ s and ...~. 178 | Maybe something like ~let s = cutprefix (old stdout) stdout~? 179 | ** Pipes semantics 180 | - ignores changes in the context ~ctx~ 181 | - does not set ~$?~ 182 | - ~false|x=X|cat; echo A/$?/$X|~ → ~A/0/~ 183 | ** Previous in for-loop 184 | ~dash~ and ~bash --posix~ disagree over the value of ~$?~ in the first iteration of a for-loop 185 | #+begin_src shell 186 | f() { 187 | return $1 188 | } 189 | f 123 190 | for x in 456; do 191 | echo X/$?/$x 192 | f $x; 193 | done 194 | echo Y/$? 195 | #+end_src 196 | ~dash~ prints ~X/0/456\nY/456~, and ~bash --posix~ prints ~X/123/456~Y/200~ 197 | ** Concrete interpreter type 198 | Different signatures of the concrete interpreter can be considered on a spectrum between a 199 | purely functional and an purely imperative design. 200 | 201 | The most functional design would directly correspond to the inductive definition of the 202 | semantics: 203 | 204 | #+begin_src why3 205 | val interp_stmt input context state statement : (state, context, output) 206 | #+end_src 207 | 208 | The most imperative design would use a mutable state object as argument together with the 209 | statement, and return or raise a boolean value according to the statement behaviour. 210 | 211 | #+begin_src why3 212 | type Exit bool 213 | type state = { 214 | arguments : array string; 215 | mutable under_condition : bool; 216 | mutable stdin : stdin; 217 | mutable stdout : stdout; 218 | mutable senv : senv; 219 | mutable result : bool; 220 | } 221 | val interp_stmt state statement : unit raises { Exit _ -> true } 222 | #+end_src 223 | 224 | The implementation as of [2018-10-01 Mon] follows the previous version of CoLiS by Nicolas 225 | and lies on the middle ground by using exceptions to indicate the program behaviour, an 226 | imperative stdout, but an immutable state and context. 227 | 228 | The implementation was changed to a fully imperative design as of [2018-10-02 Tue]. 229 | --------------------------------------------------------------------------------