why3-0.88.3/0000775000175100017510000000000013225666063013253 5ustar guillaumeguillaumewhy3-0.88.3/.merlin.in0000664000175100017510000000124513225666037015152 0ustar guillaumeguillaumeS src/util S src/core S src/driver S src/mlw S src/parser S src/transform S src/printer S src/whyml S src/session S src/tools S src/ide S src/coq-tactic S src/why3session S src/why3doc S src/jessie S src/trywhy3 S plugins/parser S plugins/printer S plugins/transform S plugins/tptp S plugins/python B src/util B src/core B src/driver B src/mlw B src/parser B src/transform B src/printer B src/whyml B src/session B src/tools B src/ide B src/coq-tactic B src/why3session B src/why3doc B src/jessie B src/trywhy3 B plugins/parser B plugins/printer B plugins/transform B plugins/tptp B plugins/python B lib/why3 PKG str unix num dynlink @ZIPLIB@ @LABLGTK2PKG@ @META_OCAMLGRAPH@ why3-0.88.3/share/0000775000175100017510000000000013225666037014356 5ustar guillaumeguillaumewhy3-0.88.3/share/why3session.dtd0000664000175100017510000000725413225666037017361 0ustar guillaumeguillaume why3-0.88.3/share/provers-detection-data.conf0000664000175100017510000003526513225666037021623 0ustar guillaumeguillaume[ATP alt-ergo] name = "Alt-Ergo" exec = "alt-ergo" exec = "alt-ergo-2.2.0" exec = "alt-ergo-1.30" exec = "alt-ergo-1.01" version_switch = "-version" version_regexp = "^\\([0-9.]+\\)$" version_ok = "2.0.0" version_old = "1.30" version_old = "1.01" command = "%e -timelimit %t %f" command_steps = "%e -steps-bound %S %f" driver = "alt_ergo" editor = "altgr-ergo" use_at_auto_level = 1 [ATP alt-ergo] name = "Alt-Ergo" exec = "alt-ergo" exec = "alt-ergo-0.99.1" exec = "alt-ergo-0.95.2" version_switch = "-version" version_regexp = "^\\([0-9.]+\\)$" version_old = "0.99.1" version_old = "0.95.2" command = "%e -no-rm-eq-existential -timelimit %t %f" command_steps = "%e -no-rm-eq-existential -steps-bound %S %f" driver = "alt_ergo" editor = "altgr-ergo" [ATP alt-ergo-prv] name = "Alt-Ergo" exec = "alt-ergo" exec = "alt-ergo-1.20.prv" exec = "alt-ergo-1.10.prv" exec = "alt-ergo-1.00.prv" version_switch = "-version" version_regexp = "^\\([0-9.]+\\(-dev\\|prv\\)?\\)$" version_old = "1.20.prv" version_old = "1.10.prv" version_old = "1.00.prv" command = "%e -timelimit %t %f" command_steps = "%e -steps-bound %S %f" driver = "alt_ergo" editor = "altgr-ergo" # CVC4 version 1.5 [ATP cvc4-15] name = "CVC4" exec = "cvc4" exec = "cvc4-1.5" version_switch = "--version" version_regexp = "This is CVC4 version \\([^ \n\r]+\\)" version_ok = "1.5" driver = "cvc4_15" # --random-seed=42 is not needed as soon as --random-freq=0.0 by default # to try: --inst-when=full-last-call command = "%e --tlimit-per=%t000 --lang=smt2 %f" command_steps = "%e --stats --rlimit=%S --lang=smt2 %f" use_at_auto_level = 1 # CVC4 version 1.4, using SMTLIB fixed-size bitvectors [ATP cvc4] name = "CVC4" exec = "cvc4" exec = "cvc4-1.4" version_switch = "--version" version_regexp = "This is CVC4 version \\([^ \n\r]+\\)" version_old = "1.4" driver = "cvc4_14" # --random-seed=42 is not needed as soon as --random-freq=0.0 by default # to try: --inst-when=full-last-call # --rlimit=%S : cvc4 1.4 DOES NOT accept -1 as argument # cvc4 1.4 does not print steps used in --stats anyway command = "%e --tlimit-per=%t000 --lang=smt2 %f" use_at_auto_level = 1 # CVC4 version 1.4, not using SMTLIB bitvectors [ATP cvc4] name = "CVC4" alternative = "noBV" exec = "cvc4" exec = "cvc4-1.4" version_switch = "--version" version_regexp = "This is CVC4 version \\([^ \n\r]+\\)" version_old = "1.4" driver = "cvc4" # --random-seed=42 is not needed as soon as --random-freq=0.0 by default # to try: --inst-when=full-last-call # --rlimit=%S : cvc4 1.4 DOES NOT accept -1 as argument # cvc4 1.4 does not print steps used in --stats anyway command = "%e --tlimit-per=%t000 --lang=smt2 %f" # CVC4 version 1.0 to 1.3 [ATP cvc4] name = "CVC4" exec = "cvc4" exec = "cvc4-1.3" exec = "cvc4-1.2" exec = "cvc4-1.1" exec = "cvc4-1.0" version_switch = "--version" version_regexp = "This is CVC4 version \\([^ \n\r]+\\)" version_old = "1.3" version_old = "1.2" version_old = "1.1" version_old = "1.0" driver = "cvc4" command = "%e --lang=smt2 %f" # Psyche version 2.x [ATP psyche] name = "Psyche" exec = "psyche" exec = "psyche-2.02" version_switch = "-version" version_regexp = "\\([^ \n\r]+\\)" version_ok = "2.0" driver = "psyche" command = "%e -gplugin dpll_wl %f" # CVC3 versions 2.4.x [ATP cvc3] name = "CVC3" exec = "cvc3" exec = "cvc3-2.4.1" exec = "cvc3-2.4" version_switch = "-version" version_regexp = "This is CVC3 version \\([^ \n]+\\)" version_ok = "2.4.1" version_old = "2.4" # the -timeout option is unreliable in CVC3 2.4.1 command = "%e -seed 42 %f" driver = "cvc3" # CVC3 versions 2.x [ATP cvc3] name = "CVC3" exec = "cvc3" exec = "cvc3-2.2" exec = "cvc3-2.1" version_switch = "-version" version_regexp = "This is CVC3 version \\([^ \n]+\\)" version_old = "2.2" version_old = "2.1" command = "%e -seed 42 -timeout %t %f" driver = "cvc3" [ATP yices] name = "Yices" exec = "yices" exec = "yices-1.0.38" version_switch = "--version" version_regexp = "\\([^ \n]+\\)" version_ok = "1.0.38" version_old = "^1\.0\.3[0-7]$" version_old = "^1\.0\.2[5-9]$" version_old = "^1\.0\.2[0-4]$" version_old = "^1\.0\.1\.*$" command = "%e" driver = "yices" [ATP yices-smt2] name = "Yices" exec = "yices-smt2" exec = "yices-smt2-2.3.0" version_switch = "--version" version_regexp = "^Yices \\([^ \n]+\\)$" version_ok = "2.3.0" command = "%e" driver = "yices-smt2" [ATP eprover] name = "Eprover" exec = "eprover" exec = "eprover-2.0" exec = "eprover-1.9.1" exec = "eprover-1.9" exec = "eprover-1.8" exec = "eprover-1.7" exec = "eprover-1.6" exec = "eprover-1.5" exec = "eprover-1.4" version_switch = "--version" version_regexp = "E \\([-0-9.]+\\) [^\n]+" version_ok = "2.0" version_old = "1.9.1-001" version_old = "1.9" version_old = "1.8-001" version_old = "1.7" version_old = "1.6" version_old = "1.5" version_old = "1.4" command = "%e -s -R -xAuto -tAuto --cpu-limit=%t --tstp-in %f" driver = "eprover" use_at_auto_level = 2 [ATP gappa] name = "Gappa" exec = "gappa" exec = "gappa-1.3.2" exec = "gappa-1.3.0" exec = "gappa-1.2.2" exec = "gappa-1.2.0" exec = "gappa-1.1.1" exec = "gappa-1.1.0" exec = "gappa-1.0.0" exec = "gappa-0.16.1" exec = "gappa-0.14.1" version_switch = "--version" version_regexp = "Gappa \\([^ \n]*\\)" version_ok = "^1\.[0-3]\..+$" version_old = "^0\.1[1-8]\..+$" command = "%e -Eprecision=70" driver = "gappa" [ATP mathsat] name = "MathSAT5" exec = "mathsat" exec = "mathsat-5.2.2" version_switch = "-version" version_regexp = "MathSAT5 version \\([^ \n]+\\)" version_ok = "5.2.2" command = "%e -input=smt2 -model -random_seed=80" driver = "mathsat" [ATP simplify] name = "Simplify" exec = "Simplify" exec = "simplify" exec = "Simplify-1.5.4" exec = "Simplify-1.5.5" version_switch = "-version" version_regexp = "Simplify version \\([^ \n,]+\\)" version_old = "1.5.5" version_old = "1.5.4" command = "%e %f" driver = "simplify" [ATP metis] name = "Metis" exec = "metis" version_switch = "-v" version_regexp = "metis \\([^ \n,]+\\)" version_ok = "2.3" command = "%e --time-limit %t %f" driver = "metis" [ATP metitarski] name = "MetiTarski" exec = "metit" exec = "metit-2.4" exec = "metit-2.2" version_switch = "-v" version_regexp = "MetiTarski \\([^ \n,]+\\)" version_ok = "2.4" version_old = "2.2" command = "%e --time %t %f" driver = "metitarski" [ATP polypaver] name = "PolyPaver" exec = "polypaver" exec = "polypaver-0.3" version_switch = "--version" version_regexp = "PolyPaver \\([0-9.]+\\) (c)" version_ok = "0.3" command = "%e -d 2 -m 10 --time=%t %f" driver = "polypaver" [ATP spass] name = "Spass" exec = "SPASS" exec = "SPASS-3.7" version_switch = " | grep 'SPASS V'" version_regexp = "SPASS V \\([^ \n\t]+\\)" version_ok = "3.7" command = "%e -TPTP -PGiven=0 -PProblem=0 -TimeLimit=%t %f" driver = "spass" use_at_auto_level = 2 [ATP spass] name = "Spass" exec = "SPASS" exec = "SPASS-3.8ds" version_switch = " | grep 'SPASS[^ \\n\\t]* V'" version_regexp = "SPASS[^ \n\t]* V \\([^ \n\t]+\\)" version_ok = "3.8ds" command = "%e -Isabelle=1 -PGiven=0 -TimeLimit=%t %f" driver = "spass_types" use_at_auto_level = 2 [ATP vampire] name = "Vampire" exec = "vampire" exec = "vampire-0.6" version_switch = "--version" version_regexp = "Vampire \\([0-9.]+\\)" command = "%e -t %t" driver = "vampire" version_ok = "0.6" [ATP princess] name = "Princess" exec = "princess" exec = "princess-2015-12-07" # version_switch = "-h" # version_regexp = "(CASC version \\([0-9-]+\\))" version_regexp = "(release \\([0-9-]+\\))" command = "%e -timeout=%t %f" driver = "princess" # version_ok = "2013-05-13" version_ok = "2015-12-07" [ATP beagle] name = "Beagle" exec = "beagle" exec = "beagle-0.4.1" # version_switch = "-h" version_regexp = "version \\([0-9.]+\\)" command = "%e %f" driver = "beagle" version_ok = "0.4.1" [ATP verit] name = "veriT" exec = "veriT" exec = "veriT-201410" version_switch = "--version" version_regexp = "version \\([^ \n\r]+\\)" command = "%e --disable-print-success %f" driver = "verit" version_ok = "201410" [ATP verit] name = "veriT" exec = "veriT" exec = "veriT-201310" version_switch = "--version" version_regexp = "version \\([^ \n\r]+\\)" command = "%e --disable-print-success --enable-simp \ --enable-unit-simp --enable-simp-sym --enable-unit-subst-simp --enable-bclause %f" driver = "verit" version_old = "201310" # Z3 >= 4.4.0, with BV support [ATP z3] name = "Z3" exec = "z3" exec = "z3-4.6.0" exec = "z3-4.5.0" exec = "z3-4.4.1" exec = "z3-4.4.0" version_switch = "-version" version_regexp = "Z3 version \\([^ \n\r]+\\)" version_ok = "4.6.0" version_ok = "4.5.0" version_old = "4.4.1" version_old = "4.4.0" driver = "z3_440" command = "%e -smt2 sat.random_seed=42 nlsat.randomize=false smt.random_seed=42 %f" command_steps = "%e -smt2 sat.random_seed=42 nlsat.randomize=false smt.random_seed=42 memory_max_alloc_count=%S %f" use_at_auto_level = 1 # Z3 >= 4.4.0, without BV support [ATP z3] name = "Z3" alternative = "noBV" exec = "z3" exec = "z3-4.6.0" exec = "z3-4.5.0" exec = "z3-4.4.1" exec = "z3-4.4.0" version_switch = "-version" version_regexp = "Z3 version \\([^ \n\r]+\\)" version_ok = "4.6.0" version_ok = "4.5.0" version_old = "4.4.1" version_old = "4.4.0" driver = "z3_432" command = "%e -smt2 sat.random_seed=42 nlsat.randomize=false smt.random_seed=42 %f" command_steps = "%e -smt2 sat.random_seed=42 nlsat.randomize=false smt.random_seed=42 memory_max_alloc_count=%S %f" # Z3 4.3.2 does not support option global option -rs anymore. # use settings given by "z3 -p" instead # Z3 4.3.2 supports Datatypes [ATP z3] name = "Z3" exec = "z3-4.3.2" version_switch = "-version" version_regexp = "Z3 version \\([^ \n\r]+\\)" version_ok = "4.3.2" driver = "z3_432" command = "%e -smt2 sat.random_seed=42 nlsat.randomize=false smt.random_seed=42 %f" command_steps = "%e -smt2 sat.random_seed=42 nlsat.randomize=false smt.random_seed=42 memory_max_alloc_count=%S %f" [ATP z3] name = "Z3" exec = "z3" exec = "z3-4.3.1" exec = "z3-4.3.0" exec = "z3-4.2" exec = "z3-4.1.2" exec = "z3-4.1.1" exec = "z3-4.0" version_switch = "-version" version_regexp = "Z3 version \\([^ \n\r]+\\)" version_old = "4.3.1" version_old = "4.3.0" version_old = "4.2" version_old = "4.1.2" version_old = "4.1.1" version_old = "4.0" driver = "z3" command = "%e -smt2 -rs:42 %f" [ATP z3] name = "Z3" exec = "z3" exec = "z3-3.2" exec = "z3-3.1" exec = "z3-3.0" version_switch = "-version" version_regexp = "Z3 version \\([^ \n\r]+\\)" version_old = "3.2" version_old = "3.1" version_old = "3.0" driver = "z3" # the -T is unreliable in Z3 3.2 command = "%e -smt2 -rs:42 %f" [ATP z3] name = "Z3" exec = "z3" exec = "z3-2.19" exec = "z3-2.18" exec = "z3-2.17" exec = "z3-2.16" version_switch = "-version" version_regexp = "Z3 version \\([^ \n\r]+\\)" version_old = "^2\.2.+$" version_old = "^2\.1[6-9]$" driver = "z3" command = "%e -smt2 -rs:42 \ PHASE_SELECTION=0 \ RESTART_STRATEGY=0 \ RESTART_FACTOR=1.5 \ QI_EAGER_THRESHOLD=100 \ ARITH_RANDOM_INITIAL_VALUE=true \ SORT_AND_OR=false \ CASE_SPLIT=3 \ DELAY_UNITS=true \ DELAY_UNITS_THRESHOLD=16 \ %f" #Other Parameters given by Nikolaj Bjorner #BV_REFLECT=true #arith? #MODEL_PARTIAL=true #MODEL_VALUE_COMPLETION=false #MODEL_HIDE_UNUSED_PARTITIONS=false #MODEL_V1=true #ASYNC_COMMANDS=false #NNF_SK_HACK=true [ATP z3] name = "Z3" exec = "z3" exec = "z3-2.2" exec = "z3-2.1" exec = "z3-1.3" version_switch = "-version" version_regexp = "Z3 version \\([^ \n\r]+\\)" version_old = "^2\.1[0-5]$" version_old = "^2\.[0-9]$" version_old = "1.3" command = "%e -smt %f" driver = "z3_smtv1" [ATP zenon] name = "Zenon" exec = "zenon" exec = "zenon-0.8.0" exec = "zenon-0.7.1" version_switch = "-v" version_regexp = "zenon version \\([^ \n\t]+\\)" version_ok = "0.8.0" version_ok = "0.7.1" command = "%e -p0 -itptp -max-size %mM -max-time %ts %f" driver = "zenon" [ATP zenon_modulo] name = "Zenon Modulo" exec = "zenon_modulo" version_switch = "-v" version_regexp = "zenon_modulo version \\([0-9.]+\\)" version_ok = "0.4.1" command = "%e -p0 -itptp -max-size %mM -max-time %ts %f" driver = "zenon_modulo" [ATP iprover] name = "iProver" exec = "iprover" exec = "iprover-0.8.1" version_switch = " | grep iProver" version_regexp = "iProver v\\([^ \n\t]+\\)" version_ok = "0.8.1" command = "%e --fof true --out_options none \ --time_out_virtual %t --clausifier /usr/bin/env --clausifier_options \ \"eprover --cnf --tstp-format \" %f" driver = "iprover" [ATP mathematica] name = "Mathematica" exec = "math" version_switch = "-run \"Exit[]\"" version_regexp = "Mathematica \\([0-9.]+\\)" version_ok = "9.0" version_ok = "8.0" version_ok = "7.0" command = "%e -noprompt" driver = "mathematica" # Coq 8.6: do not limit memory [ITP coq] name = "Coq" compile_time_support = true exec = "coqtop -batch" version_switch = "-v" version_regexp = "The Coq Proof Assistant, version \\([^ \n]+\\)" version_ok = "8.7.1" version_ok = "8.7.0" version_ok = "8.6.1" version_ok = "8.6" command = "%e -I %l/coq-tactic -R %l/coq-tactic Why3 -R %l/coq Why3 -l %f" driver = "coq" editor = "coqide" # Coq 8.5: do not limit memory [ITP coq] name = "Coq" compile_time_support = true exec = "coqtop -batch" version_switch = "-v" version_regexp = "The Coq Proof Assistant, version \\([^ \n]+\\)" version_ok = "8.5pl3" version_ok = "8.5pl2" version_ok = "8.5pl1" version_ok = "8.5" command = "%e -R %l/coq-tactic Why3 -R %l/coq Why3 -l %f" driver = "coq" editor = "coqide" [ITP coq] name = "Coq" compile_time_support = true exec = "coqtop -batch" version_switch = "-v" version_regexp = "The Coq Proof Assistant, version \\([^ \n]+\\)" version_ok = "^8\.4pl[1-6]$" version_ok = "8.4" command = "%e -R %l/coq-tactic Why3 -R %l/coq Why3 -l %f" driver = "coq" editor = "coqide" [ITP pvs] name = "PVS" compile_time_support = true exec = "pvs" version_switch = "-version" version_regexp = "PVS Version \\([^ \n]+\\)" version_ok = "6.0" version_bad = "^[0-5]\..+$" command = "%l/why3-call-pvs %l proveit -f %f" driver = "pvs" in_place = true editor = "pvs" [ITP isabelle] name = "Isabelle" exec = "isabelle" version_switch = "version" version_regexp = "Isabelle\\([0-9]+\\(-[0-9]+\\)?\\)" version_ok = "2016-1" version_bad = "2017" version_bad = "2016" command = "%e why3 -b %f" driver = "isabelle2016-1" in_place = true editor = "isabelle-jedit" [ITP isabelle] name = "Isabelle" exec = "isabelle" version_switch = "version" version_regexp = "Isabelle\\([0-9]+\\(-[0-9]+\\)?\\)" version_ok = "2017" version_bad = "2016-1" version_bad = "2016" command = "%e why3 -b %f" driver = "isabelle2017" in_place = true editor = "isabelle-jedit" [editor pvs] name = "PVS" command = "%l/why3-call-pvs %l pvs %f" [editor coqide] name = "CoqIDE" command = "coqide -I %l/coq-tactic -R %l/coq-tactic Why3 -R %l/coq Why3 %f" [editor proofgeneral-coq] name = "Emacs/ProofGeneral/Coq" command = "emacs --eval \"(setq coq-load-path '((\\\"%l/coq-tactic\\\" \\\"Why3\\\") \ (\\\"%l/coq\\\" \\\"Why3\\\")))\" %f" [editor isabelle-jedit] name = "Isabelle/jEdit" command = "isabelle why3 -i %f" [editor altgr-ergo] name = "AltGr-Ergo" command = "altgr-ergo %f" [shortcut shortcut1] name="Alt-Ergo" shortcut="altergo" why3-0.88.3/share/zsh/0000775000175100017510000000000013225666037015162 5ustar guillaumeguillaumewhy3-0.88.3/share/zsh/_why30000664000175100017510000001140013225666037016132 0ustar guillaumeguillaume#compdef whyml3 why3 ## ## zsh completion for why3 ## generated by ocompl ## ## ## ## typeset -A opt_args typeset -a last_theories local state line cmd ret=1 local last_file tmp last_theorie ## _arguments -s -S \ '(- *)'{-h,--help}'[Brief help message]' \ '-'"[Read the input file from stdin]"\ '*-T'"[ Select in the input file or in the library]::->theories"\ '*--theory'"[same as -T]::->theories"\ '*-G'"[ Select in the last selected theory]::->goals"\ '*--goal'"[same as -G]::->goals"\ '-C'"[ Read configuration from ]:Configuration File:_files -g '*.conf'"\ '--config'"[same as -C]:Configuration File:_files -g '*.conf'"\ "(-L --library -I)"'-L'"[ Add to the library search path]:Mlpost lib path:_files -/ "\ "(-L --library -I)"'--library'"[same as -L]:Mlpost lib path:_files -/ "\ "(-L --library -I)"'-I'"[same as -L (obsolete)]:Mlpost lib path (obsolete use -L):_files -/ "\ "(-D --driver -P -prover)"'-P'"[ Prove or print (with -o) the selected goals]::->provers"\ "(-D --driver -P -prover)"'--prover'"[same as -P]::->provers"\ '*-M'"[= Add a meta option to each tasks]:=:->metas"\ "(-F --format)"'-F'"[ Input format (default: \"why\")]::"\ "(-F --format)"'--format'"[same as -F]::"\ "(-t --timelimit)"'-t'"[ Set the prover\'s time limit (default=10, no limit=0)]::"\ "(-t --timelimit)"'--timelimit'"[same as -t]::"\ "(-m --memlimit)"'-m'"[ Set the prover\'s memory limit (default: no limit)]::"\ "(-m --memlimit)"'--memlimit'"[same as -m]::"\ "(-D --driver -P -prover)"'-D'"[ Specify a prover\'s driver (conflicts with -P)]:Prover\'s driver:_files -g '*.drv'"\ "(-D --driver -P -prover)"'--driver'"[same as -D]:Prover\'s driver:_files -g '*.drv'"\ "(-o --output)"'-o'"[ Print the selected goals to separate files in ]:directory output:_files -/ "\ "(-o --output)"'--output'"[same as -o]:directory output:_files -/ "\ '--print-theory'"[Print the selected theories]"\ '--print-namespace'"[Print the namespaces of selected theories]"\ '--list-transforms'"[List the registered transformations]"\ '--list-printers'"[List the registered printers]"\ '--list-provers'"[List the known provers]"\ '--list-formats'"[List the known input formats]"\ '--list-metas'"[List the known metas]"\ "(--type-only --parse-only -D --driver -P -prover -L --library -I -t --timelimit -m --memlimit)"'--parse-only'"[Stop after parsing]"\ "(--type-only --parse-only -D --driver -P -prover -L --library -I -t --timelimit -m --memlimit)"'--type-only'"[Stop after type checking]"\ '--debug'"[Set the debug flag]"\ '*-a'"[ Add a transformation to apply to the task]::->transforms"\ '*--apply-transform'"[same as -a]::->transforms"\ "*:The why3 file:->files"\ && return 0 cmd=$service last_file=$line[-1] tmp=$opt_args[-T] last_theories=(${(s<:>)tmp}) last_theory=$last_theories[-1] case $state in transforms) _message ""; compadd $($cmd --list-transforms | grep -e "^ "); return 0 ;; provers) _message ""; compadd $($cmd --list-provers | egrep -E "^ [a-z]"|cut -d' ' -f 3); return 0 ;; metas) _message ""; METAS="$($cmd --list-metas | egrep -E "^ [a-z]" | sed -e "s/^[ ]*//" -e "s/$/=/")"; METAS=(${(f)METAS}); compadd $METAS; return 0 ;; theories) tmp=$($cmd --print-namespace $last_file 2> /dev/null); if [[ $? = 0 ]]; then _message ""; compadd $(echo $tmp |grep "^[a-zA-Z]" | cut -d- -f 1); return 0 else _message ""; return 1 fi;; goals) tmp=$($cmd --print-namespace $last_file -T $last_theory 2> /dev/null); if [[ $? = 0 ]]; then _message ""; compadd $(echo $tmp |grep -e "-goal" | sed "s/[^-]*-goal //"); return 0 else _message ""; return 1 fi;; files) case $cmd in why3) _files -g '*.why'; return 0; ;; whyml3) _files -g '*.{why,mlw}'; return 0; ;; *) _message "absurd"; return 1; esac;; *) return 1 esac #_why3 "$@" why3-0.88.3/share/strategies.conf0000664000175100017510000000150113225666037017374 0ustar guillaumeguillaume[strategy] name = "Split" desc = "Split" shortcut = "s" code = "t split_goal_wp exit" [strategy] name = "Inline" desc = "Inline" shortcut = "i" code = "t inline_goal exit" [strategy] name = "Mini Blaster" desc = "A@ simple@ blaster" shortcut = "b" code = " start: c Alt-Ergo,0.95.2, 1 1000 c CVC4,1.4, 1 1000 t split_goal_wp start c Alt-Ergo,0.95.2, 10 4000 c CVC4,1.4, 10 4000" [strategy] name = "Mega Blaster" desc = "Mega@ Blaster@ of@ the@ death" code = " L0:c Alt-Ergo,0.95.2, 1 1000 c CVC4,1.4, 1 1000 t split_goal_wp L6 t introduce_premises L4 L4:t inline_goal L0 g L11 L6:c Alt-Ergo,0.95.2, 1 1000 c CVC4,1.4, 1 1000 t introduce_premises L9 L9:t inline_goal L0 t split_goal_wp L6 L11: c Alt-Ergo,0.95.2, 5 2000 c CVC4,1.4, 5 2000 c Alt-Ergo,0.95.2, 30 4000 c CVC4,1.4, 30 4000" why3-0.88.3/share/latex/0000775000175100017510000000000013225666037015473 5ustar guillaumeguillaumewhy3-0.88.3/share/latex/why3lang.sty0000664000175100017510000000253413225666037017774 0ustar guillaumeguillaume \RequirePackage{listings} \RequirePackage{amssymb} \lstdefinelanguage{why3} { basicstyle=\ttfamily,% morekeywords=[1]{abstract,absurd,any,assert,assume,axiom,by,% check,clone,coinductive,constant,diverges,do,done,downto,% else,end,ensures,exception,exists,export,for,forall,fun,% function,ghost,goal,if,import,in,inductive,invariant,lemma,% let,loop,match,meta,model,module,mutable,namespace,not,old,% predicate,private,raise,raises,reads,rec,requires,result,% returns,so,then,theory,to,try,type,use,val,variant,while,% with,writes},% string=[b]",% %keywordstyle=[1]{\color{red}},% morekeywords=[2]{true,false},% %keywordstyle=[2]{\color{blue}},% %otherkeywords={},% commentstyle=\itshape,% columns=[l]fullflexible,% sensitive=true,% morecomment=[s]{(*}{*)},% %breaks hevea %escapeinside={*?}{?*},% keepspaces=true,% %literate=% % {'a}{$\alpha$}{1}% % {'b}{$\beta$}{1}% % {<}{$<$}{1}% % {>}{$>$}{1}% % {<=}{$\le$}{1}% % {>=}{$\ge$}{1}% % {<>}{$\ne$}{1}% % {/\\}{$\land$}{1}% % {\\/}{ $\lor$ }{3}% % {\ or(}{ $\lor$(}{3}% % {not\ }{$\lnot$ }{2}% % {not(}{$\lnot$(}{2}% % {+->}{\texttt{+->}}{3}% % {+->}{$\mapsto$}{2}% % {-->}{\texttt{-\relax->}}{3}% % {-->}{$\longrightarrow$}{2}% % {->}{$\rightarrow$}{2}% % {<-}{$\leftarrow$}{2}% % {<->}{$\leftrightarrow$}{2}% } \lstnewenvironment{why3}{\lstset{language=why3}}{} \newcommand{\whyf}[1]{\lstinline[language=why3]{#1}} why3-0.88.3/share/vim/0000775000175100017510000000000013225666037015151 5ustar guillaumeguillaumewhy3-0.88.3/share/vim/ftdetect/0000775000175100017510000000000013225666037016753 5ustar guillaumeguillaumewhy3-0.88.3/share/vim/ftdetect/why3.vim0000664000175100017510000000006413225666037020362 0ustar guillaumeguillaumeau BufRead,BufNewFile *.why,*.mlw set filetype=why3 why3-0.88.3/share/vim/syntax/0000775000175100017510000000000013225666037016477 5ustar guillaumeguillaumewhy3-0.88.3/share/vim/syntax/why3.vim0000664000175100017510000002145613225666037020116 0ustar guillaumeguillaume" Vim syntax file " Language: Why3 " Filenames: *.why *.mlw " " Adapted from syntax file for Ocaml " For version 5.x: Clear all syntax items " For version 6.x: Quit when a syntax file was already loaded if version < 600 syntax clear elseif exists("b:current_syntax") && b:current_syntax == "why3" finish endif " Why3 is case sensitive. syn case match " " Script headers highlighted like comments " syn match whyComment "^#!.*" " lowercase identifier - the standard way to match syn match whyLCIdentifier /\<\(\l\|_\)\(\w\|'\)*\>/ syn match whyKeyChar "|" " Errors syn match whyBraceErr "}" syn match whyBrackErr "\]" syn match whyParenErr ")" syn match whyCommentErr "\(^\|[^(]\)\*)" syn match whyCountErr "\" syn match whyCountErr "\" syn match whyDoErr "\" syn match whyDoneErr "\" syn match whyThenErr "\" syn match whyTheoryErr "\" syn match whyModuleErr "\" syn match whyEndErr "\" " Some convenient clusters syn cluster whyAllErrs contains=whyBraceErr,whyBrackErr,whyParenErr,whyCommentErr,whyCountErr,whyDoErr,whyDoneErr,whyEndErr,whyThenErr,whyTheoryErr,whyModuleErr syn cluster whyContained contains=whyTodo,whyImport,whyExport,whyTheoryContents,whyModuleContents,whyNamespaceContents,whyModuleKeyword " ,whyPreDef,whyModParam,whyModParam1,whyPreMPRestr,whyMPRestr,whyMPRestr1,whyMPRestr2,whyMPRestr3,whyModRHS,whyFuncWith,whyFuncStruct,whyModTypeRestr,whyModTRWith,whyWith,whyWithRest,whyModType,whyFullMod,whyVal " Enclosing delimiters syn region whyEncl transparent matchgroup=whyKeyword start="(" matchgroup=whyKeyword end=")" contains=ALLBUT,@whyContained,whyParenErr syn region whyEncl transparent matchgroup=whyKeyword start="{" matchgroup=whyKeyword end="}" contains=ALLBUT,@whyContained,whyBraceErr syn region whyEncl transparent matchgroup=whyKeyword start="\[" matchgroup=whyKeyword end="\]" contains=ALLBUT,@whyContained,whyBrackErr " Comments syn region whyComment start="(\*\([^)]\|$\)" end="\(^\|[^(]\)\*)" contains=whyComment,whyTodo syn keyword whyTodo contained TODO FIXME XXX NOTE " Blocks " FIXME? match and try should detect the absence of "with" ? syn region whyEnd matchgroup=whyKeyword start="\" matchgroup=whyKeyword end="\" contains=ALLBUT,@whyContained,whyEndErr syn region whyEnd matchgroup=whyKeyword start="\" matchgroup=whyKeyword end="\" contains=ALLBUT,@whyContained,whyEndErr syn region whyEnd matchgroup=whyKeyword start="\" matchgroup=whyKeyword end="\" contains=ALLBUT,@whyContained,whyEndErr syn region whyEnd matchgroup=whyKeyword start="\" matchgroup=whyKeyword end="\" contains=ALLBUT,@whyContained,whyEndErr syn region whyEnd matchgroup=whyKeyword start="\" matchgroup=whyKeyword end="\" contains=ALLBUT,@whyContained,whyEndErr syn region whyNone matchgroup=whyKeyword start="\" matchgroup=whyKeyword end="\<\(to\|downto\)\>" contains=ALLBUT,@whyContained,whyCountErr syn region whyDo matchgroup=whyKeyword start="\" matchgroup=whyKeyword end="\" contains=ALLBUT,@whyContained,whyDoneErr syn region whyNone matchgroup=whyKeyword start="\" matchgroup=whyKeyword end="\" contains=ALLBUT,@whyContained,whyThenErr " Theories and modules syn region whyTheory matchgroup=whyKeyword start="\" matchgroup=whyModSpec end="\<\u\(\w\|'\)*\>" contains=@whyAllErrs,whyComment skipwhite skipempty nextgroup=whyTheoryContents syn region whyModule matchgroup=whyKeyword start="\" matchgroup=whyModSpec end="\<\u\(\w\|'\)*\>" contains=@whyAllErrs,whyComment skipwhite skipempty nextgroup=whyModuleContents syn region whyNamespace matchgroup=whyKeyword start="\" matchgroup=whyModSpec end="\<\u\(\w\|'\)*\>" contains=@whyAllErrs,whyComment,whyImport skipwhite skipempty nextgroup=whyNamespaceContents syn region whyTheoryContents start="^" start="."me=e-1 matchgroup=whyModSpec end="\" contained contains=ALLBUT,@whyContained,whyEndErr,whyTheory,whyModule syn region whyModuleContents start="^" start="."me=e-1 matchgroup=whyModSpec end="\" contained contains=ALLBUT,@whyContained,whyEndErr,whyTheory,whyModule syn region whyNamespaceContents start="^" start="."me=e-1 matchgroup=whyModSpec end="\" contained contains=ALLBUT,@whyContained,whyEndErr,whyTheory,whyModule syn region whyNone matchgroup=whyKeyword start="\<\(use\|clone\)\>" matchgroup=whyModSpec end="\<\(\w\+\.\)*\u\(\w\|'\)*\>" contains=@whyAllErrs,whyComment,whyString,whyImport,whyExport,whyModuleKeyword syn keyword whyExport contained export syn keyword whyImport contained import syn keyword whyModuleKeyword contained module syn region whyNone matchgroup=whyKeyword start="\<\(axiom\|lemma\|goal\|prop\)\>" matchgroup=whyNone end="\<\w\(\w\|'\)*\>" contains=@whyAllErrs,whyComment syn keyword whyKeyword as by constant syn keyword whyKeyword else epsilon exists syn keyword whyKeyword forall function syn keyword whyKeyword if in inductive coinductive syn keyword whyKeyword let meta syn keyword whyKeyword not predicate so syn keyword whyKeyword then type with syn keyword whyKeyword any syn keyword whyKeyword exception fun ghost syn keyword whyKeyword model mutable private syn keyword whyKeyword raise rec val while syn keyword whyBoolean true false syn keyword whyType bool int list map option real syn keyword whyType array ref unit syn keyword whySpec absurd assert assume check diverges ensures invariant syn keyword whySpec raises reads requires returns variant writes syn match whyConstructor "(\s*)" syn match whyConstructor "\u\(\w\|'\)*\>" syn match whyModPath "\u\(\w\|'\)*\."he=e-1 syn region whyString start=+"+ skip=+\\\\\|\\"+ end=+"+ syn match whyOperator "->" syn match whyOperator "<->\?" syn match whyOperator "/\\" syn match whyOperator "\\[/!?]\?" syn match whyOperator "&&" syn match whyOperator "<>" syn match whyKeyChar "|" syn match whyKeyChar ";" " FIXME? is this too inefficient? syn match whyOperator "[^<>~=:+*/%$&@^.|#!?]=[^<>~=:+*/%$&@^.|#!?]"ms=s+1,me=e-1 syn match whyOperator "^=[^<>~=:+*/%$&@^.|#!?]"me=e-1 syn match whyOperator "[^<>~=:+*/%$&@^.|#!?]=$"ms=s+1 syn match whyAnyVar "\<_\>" syn match whyNumber "\<-\=\d\(_\|\d\)*\>" syn match whyNumber "\<-\=0[x|X]\(\x\|_\)\+\>" syn match whyNumber "\<-\=0[o|O]\(\o\|_\)\+\>" syn match whyNumber "\<-\=0[b|B]\([01]\|_\)\+\>" syn match whyFloat "\<-\=\d\+[eE][-+]\=\d\+\>" syn match whyFloat "\<-\=\d\+\.\d*\([eE][-+]\=\d\+\)\=\>" syn match whyFloat "\<-\=0[x|X]\x\+\.\?\x*[pP][-+]\=\d\+\>" " Synchronization syn sync minlines=50 syn sync maxlines=500 syn sync match whyDoSync grouphere whyDo "\" syn sync match whyDoSync groupthere whyDo "\" syn sync match whyEndSync grouphere whyEnd "\<\(begin\|abstract\|match\|loop\|try\)\>" syn sync match whyEndSync groupthere whyEnd "\" syn sync match whyTheorySync grouphere whyTheory "\" syn sync match whyTheorySync groupthere whyTheory "\" syn sync match whyModuleSync grouphere whyModule "\" syn sync match whyModuleSync groupthere whyModule "\" syn sync match whyNamespaceSync grouphere whyNamespace "\" syn sync match whyNamespaceSync groupthere whyNamespace "\" " Define the default highlighting. " For version 5.7 and earlier: only when not done already " For version 5.8 and later: only when an item doesn't have highlighting yet if version >= 508 || !exists("did_why_syntax_inits") if version < 508 let did_why_syntax_inits = 1 command -nargs=+ HiLink hi link else command -nargs=+ HiLink hi def link endif HiLink whyBraceErr Error HiLink whyBrackErr Error HiLink whyParenErr Error HiLink whyCommentErr Error HiLink whyCountErr Error HiLink whyDoErr Error HiLink whyDoneErr Error HiLink whyEndErr Error HiLink whyThenErr Error HiLink whyTheoryErr Error HiLink whyModuleErr Error HiLink whyComment Comment HiLink whyModPath Include HiLink whyModSpec Include HiLink whyImport Keyword HiLink whyExport Keyword HiLink whyModuleKeyword Keyword HiLink whyConstructor Constant HiLink whyKeyword Keyword HiLink whyKeyChar Keyword HiLink whyAnyVar Keyword HiLink whyOperator Keyword HiLink whySpec Identifier HiLink whyNumber Number HiLink whyFloat Float HiLink whyString String HiLink whyBoolean Boolean HiLink whyType Type HiLink whyTodo Todo HiLink whyEncl Keyword delcommand HiLink endif let b:current_syntax = "why3" " vim: ts=8 why3-0.88.3/share/emacs/0000775000175100017510000000000013225666037015446 5ustar guillaumeguillaumewhy3-0.88.3/share/emacs/why3.el0000664000175100017510000001516713225666037016674 0ustar guillaumeguillaume ;; why3.el - GNU Emacs mode for Why3 (defvar why3-mode-hook nil) (defvar why3-mode-map nil "Keymap for Why3 major mode") (if why3-mode-map nil (setq why3-mode-map (make-keymap)) ;; (define-key why3-mode-map "\C-c\C-c" 'why3-generate-obligations) **) ;; (define-key why3-mode-map "\C-c\C-a" 'why3-find-alternate-file) **) ;; (define-key why3-mode-map "\C-c\C-v" 'why3-viewer) **) (define-key why3-mode-map [(control return)] 'font-lock-fontify-buffer)) (setq auto-mode-alist (append '(("\\.\\(why\\|mlw\\)" . why3-mode)) auto-mode-alist)) ;; font-lock (defun why3-regexp-opt (l) (regexp-opt l 'words)) (defconst why3-font-lock-keywords-1 (list ;; Note: comment font-lock is guaranteed by suitable syntax entries '("(\\*\\([^*)]\\([^*]\\|\\*[^)]\\)*\\)?\\*)" . font-lock-comment-face) ; '("{}\\|{[^|]\\([^}]*\\)}" . font-lock-type-face) `(,(why3-regexp-opt '("invariant" "variant" "diverges" "requires" "ensures" "returns" "raises" "reads" "writes" "assert" "assume" "check")) . font-lock-type-face) `(,(why3-regexp-opt '("use" "clone" "namespace" "import" "export" "coinductive" "inductive" "external" "constant" "function" "predicate" "val" "exception" "axiom" "lemma" "goal" "type" "mutable" "model" "abstract" "private" "any" "match" "let" "rec" "in" "if" "then" "else" "begin" "end" "while" "for" "to" "downto" "do" "done" "loop" "absurd" "ghost" "raise" "try" "with" "theory" "uses" "module" "converter" "fun" "by" "so" "meta")) . font-lock-keyword-face) ) "Minimal highlighting for Why3 mode") (defvar why3-font-lock-keywords why3-font-lock-keywords-1 "Default highlighting for Why3 mode") (defvar why3-indent 2 "How many spaces to indent in why3 mode.") (make-variable-buffer-local 'why3-indent) ;; syntax (defvar why3-mode-syntax-table nil "Syntax table for why3-mode") (defun why3-create-syntax-table () (if why3-mode-syntax-table () (setq why3-mode-syntax-table (make-syntax-table)) (set-syntax-table why3-mode-syntax-table) (modify-syntax-entry ?' "w" why3-mode-syntax-table) (modify-syntax-entry ?_ "w" why3-mode-syntax-table) ; comments (modify-syntax-entry ?\( ". 1" why3-mode-syntax-table) (modify-syntax-entry ?\) ". 4" why3-mode-syntax-table) (modify-syntax-entry ?* ". 23" why3-mode-syntax-table) )) ;indentation ;http://www.emacswiki.org/emacs/ModeTutorial (defun why3-indent-line () "Indent current line as why3 logic" (interactive) (save-excursion (beginning-of-line) ;(debug) (if (bobp) ; Check for rule 1 (indent-line-to 0) (let ((not-indented t) cur-indent) (if (looking-at "^[ \t]*end") ; Check for rule 2 (progn (save-excursion (forward-line -1) (setq cur-indent (- (current-indentation) why3-indent))) (if (< cur-indent 0) (setq cur-indent 0))) (progn (if (looking-at "^[ \t]*\\(logic\\|type\\|prop\\)") ; check for clone (progn (save-excursion (forward-line -1) (if (looking-at "^[ \t]*\\(logic\\|type\\|prop\\).*,[ \t]*$") (progn (setq cur-indent (current-indentation)) (setq not-indented nil)) (if (looking-at "^[ \t]*clone.*with ") (progn (setq cur-indent (+ (current-indentation) why3-indent)) (setq not-indented nil) )))))) ;For the definition its very badly done... (if (looking-at "^[ \t]*$") ;; (save-excursion ;; (forward-line -1) ;; (setq cur-indent (current-indentation)) ;; (setq not-indented nil)) (progn (setq cur-indent 0) (setq not-indented nil)) (if (not (looking-at "^[ \t]*(\*.*")) (if (not (looking-at "^[ \t]*\\(logic\\|type\\|axiom\\|goal\\|lemma\\|inductive\\|use\\|theory\\|clone\\)")) (save-excursion (condition-case nil (save-excursion (backward-up-list) (setq cur-indent (+ (current-column) 1)) (setq not-indented nil)) (error (forward-line -1) (if (looking-at "^[ \t]*\\(logic\\|type\\|axiom\\|goal\\|lemma\\|inductive\\)") (setq cur-indent (+ (current-indentation) why3-indent)) (setq cur-indent (current-indentation))) (setq not-indented nil))))))) ;For inside theory or namespace (save-excursion (while not-indented (forward-line -1) (if (looking-at "^[ \t]*end") ; Check for rule 3 (progn (setq cur-indent (current-indentation)) (setq not-indented nil)) ; Check for rule 4 (if (looking-at "^[ \t]*\\(theory\\|namespace\\)") (progn (setq cur-indent (+ (current-indentation) why3-indent)) (setq not-indented nil)) (if (bobp) ; Check for rule 5 (setq not-indented nil))))))) (if cur-indent (indent-line-to cur-indent) (indent-line-to 0))))))) ; compile will propose "why3 ide file" if no Makefile is present (add-hook 'why3-mode-hook (lambda () (unless (file-exists-p "Makefile") (set (make-local-variable 'compile-command) (let ((file (file-name-nondirectory buffer-file-name))) (format "why3 ide %s" file)))))) (add-hook 'why3-mode-hook (lambda () (modify-syntax-entry ?_ "w"))) ;; setting the mode (defun why3-mode () "Major mode for editing Why3 programs. \\{why3-mode-map}" (interactive) (kill-all-local-variables) (why3-create-syntax-table) ; hilight (make-local-variable 'font-lock-defaults) (setq font-lock-defaults '(why3-font-lock-keywords)) ; indentation ;(make-local-variable 'indent-line-function) ;(setq indent-line-function 'why3-indent-line) ; OCaml style comments for comment-region, comment-dwim, etc. (set (make-local-variable 'comment-start) "(*") (set (make-local-variable 'comment-end) "*)") ; menu ; providing the mode (setq major-mode 'why3-mode) (setq mode-name "Why3") (use-local-map why3-mode-map) (font-lock-mode 1) ; (why3-menu) (run-hooks 'why3-mode-hook)) (provide 'why3) why3-0.88.3/share/lang/0000775000175100017510000000000013225666037015277 5ustar guillaumeguillaumewhy3-0.88.3/share/lang/why3.lang0000664000175100017510000001751513225666037017045 0ustar guillaumeguillaume text/x-why3 *.mlw;*.why (* *)
<#en>The content of the current buffer will be lost <#fr>Le contenu actuel du programme sera perdu
why3-0.88.3/src/trywhy3/style.css0000664000175100017510000000727213225666037017356 0ustar guillaumeguillaume@import url(fontawesome/fontawesome.css); /* fontawesome */ [class*="fontawesome-"]:before { font-family: 'FontAwesome', sans-serif; } body { padding:0; margin:0; font-family: sans-serif; } /* CSS MENU BAR */ .menu-bar { margin:0; z-index:10; font-size:2vh; padding:0; } .menu-bar:after { content:""; display:table; clear:both; } .menu-bar ul { padding:0; margin:0; list-style: none; position: relative; background-image: linear-gradient(to bottom, #eee, #ccc); height:3vh; z-index:10; box-sizing:border-box; } /* Positioning the navigation items inline */ .menu-bar ul li { margin: 0; padding:0; display:inline-block; float: left; height:100%; box-sizing:border-box; } /* Styling the links */ .menu-bar > ul > li > a { display:block; padding:0pt 1em; color:#444; text-decoration:none; border-radius: 5pt 5pt 0pt 0pt; border-style:solid; border-width:1pt; border-color:transparent; height:100%; box-sizing:border-box; margin:0; } /* Background color change on Hover */ .menu-bar > ul > li > a:hover { background-image: linear-gradient(to bottom, #eee, #bbb); border-color: #aaa; box-sizing:border-box; } .menu-bar > ul > li > ul { /* display:none;*/ height:0; overflow:hidden; box-sizing:border-box; } .menu-bar > ul > li:hover > ul { height:auto; background-color:#ddd; box-shadow:0pt 0pt 5pt #444; } .menu-bar > ul > li > ul > li { float:none; display:list-item; position: relative; } .menu-bar > ul > li > ul > li > a { display:block; padding:1pt 2pt 1pt 2pt; color:#444; text-decoration:none; border-radius: 1pt; border-style:solid; border-width:1pt; border-color:transparent; box-sizing:border-box; } .menu-bar > ul > li > ul > li > a:hover { border-color:#cce; background-image: linear-gradient(to bottom, #abe, #68b); } /* Hidden file selector */ #file-selector { position:absolute; left:0; top:0; width:0; height:0; z-index:-1; } #editor-panel { position:relative; display:block; box-sizing: border-box; padding:0; margin:0; height:97vh; } #console { position:relative; display:inline-block; box-sizing: border-box; /* font-size: large; */ /* font-family: monospace; */ /* white-space: pre-wrap; */ width:49%; height:100%; /* background: #444; */ margin:0 0 0 0; padding:0 0 0 0; vertical-align:top; } #console ul { list-style-type: none; padding: 0.5em; /*margin: 0.5em; */ } #console ul ul { list-style-type: disc; padding: 0.5em; /*margin: 0.5em;*/ } #console ul ul ul { list-style-type: none; padding: 0.5em; /*margin: 0.5em; */ } #editor { position:relative; font-size: large; box-sizing: border-box; display:inline-block; width:49%; height:100%; margin:0 0 0 0; padding:0 0 0 0; z-index:0; vertical-align:top; } /* Confirmation dialog */ .btn { width:100%; z-index:1; margin:0 0 4pt 0; box-sizing:border-box; } #confirm-dialog { z-index:20; display:none; position:absolute; margin: 0 auto; padding: 2pt 0; width:50%; left:25%; right:25%; top:20%; border-radius:5pt; background: #eee; text-align:center; } #background-shadow { display:none; background-color: rgba(0,0,0,0.8); position:absolute; width:100%; height:100%; top: 0; left:0; z-index:15; } #confirm-dialog .btn { width:40%; } #header { height: 30vh; } .menu-bar { height: 5vh; } #editor-panel { height: 65vh; } #console { overflow: auto; }why3-0.88.3/src/trywhy3/gen_index.sh0000775000175100017510000000047213225666037017776 0ustar guillaumeguillaume#!/bin/sh for i in $* do EXT="" case "$i" in *.mlw) EXT=".mlw" ;; *.why) EXT=".why" ;; *) echo "Warning: unknown extension for file $i" >&2; continue ;; esac B=$(basename "$i" "$EXT" | tr _ ' ' | sed -e 's/\b\(.\)/\u\1/g'); echo "$B" echo "$i" done why3-0.88.3/src/trywhy3/trywhy3.html0000664000175100017510000001625713225666037020026 0ustar guillaumeguillaume Try Why3
Task list
Task view
  • Split and prove
  • Prove (default)
  • Prove (100 steps)
  • Prove (1000 steps)
  • Prove (5000 steps)
  • Clean
Preferences
  • Number of threads for Alt-Ergo
  • Number of steps for Alt-Ergo
About TryWhy3

TryWhy3 is a Javascript based version of the Why3 Verification Platform

© 2010-2017, Inria - CNRS - Paris-Sud University
This software is distributed under the terms of the GNU Lesser General Public License version 2.1, with the special exception on linking described in the file LICENSE.

TryWhy3 relies on the following excellent open source software and resources:

why3-0.88.3/src/printer/0000775000175100017510000000000013225666037015526 5ustar guillaumeguillaumewhy3-0.88.3/src/printer/yices.ml0000664000175100017510000002602713225666037017203 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** SMT v1 printer with some extensions *) open Format open Pp open Ident open Ty open Term open Decl open Printer let ident_printer = let bls = (*["and";" benchmark";" distinct";"exists";"false";"flet";"forall"; "if then else";"iff";"implies";"ite";"let";"logic";"not";"or"; "sat";"theory";"true";"unknown";"unsat";"xor"; "assumption";"axioms";"definition";"extensions";"formula"; "funs";"extrafuns";"extrasorts";"extrapreds";"language"; "notes";"preds";"sorts";"status";"theory";"Int";"Real";"Bool"; "Array";"U";"select";"store"]*) (* smtlib2 V2 p71 *) [(* General: *) "!";"_"; "as"; "DECIMAL"; "exists"; "forall"; "let"; "NUMERAL"; "par"; "STRING"; "if"; "ite"; (* Command names: *) "define"; "define-type";"exit";"get-assertions";"get-assignment"; "get-info"; "get-option"; "get-proof"; "get-unsat-core"; "get-value"; "pop"; "push"; "set-logic"; "set-info"; "set-option"; (* for security *) "bool";"unsat";"sat";"true";"false"; "true";"check";"assert";"TYPE";"SUBTYPE"; "scalar";"select";"update";"int";"real";"nat"; "subtype";"subrange";"mk-bv"; "bv-concat";"bv-extract";"bv-shift-right0";"div";"mod";"bitvector"; "lambda"; ] in let san = sanitizer char_to_alpha char_to_alnumus in create_ident_printer bls ~sanitizer:san let print_ident fmt id = fprintf fmt "%s" (id_unique ident_printer id) type info = { info_syn : syntax_map; complex_type : ty Mty.t ref; urg_output : string list ref; } (** type *) let complex_type = Wty.memoize 3 (fun ty -> let s = Pp.string_of_wnl Pretty.print_ty ty in create_tysymbol (id_fresh s) [] NoDef) let rec print_type info fmt ty = match ty.ty_node with | Tyvar _ -> unsupported "cvc3: you must encode the polymorphism" | Tyapp (ts, l) -> begin match query_syntax info.info_syn ts.ts_name, l with | Some s, _ -> syntax_arguments s (print_type info) fmt l | None, [] -> fprintf fmt "%a" print_ident ts.ts_name | None, _ -> begin match Mty.find_opt ty !(info.complex_type) with | Some ty -> print_type info fmt ty | None -> let ts = complex_type ty in let cty = ty_app ts [] in let us = Pp.sprintf "(define-type %a)@\n@\n" print_ident ts.ts_name in info.complex_type := Mty.add ty cty !(info.complex_type); info.urg_output := us :: !(info.urg_output); print_type info fmt cty end end let print_type info fmt ty = try print_type info fmt ty with Unsupported s -> raise (UnsupportedType (ty,s)) let print_type_value info fmt = function | None -> fprintf fmt "bool" | Some ty -> print_type info fmt ty (** var *) let forget_var v = forget_id ident_printer v.vs_name let print_var fmt {vs_name = id} = let n = id_unique ident_printer id in fprintf fmt "%s" n let print_typed_var info fmt vs = fprintf fmt "%a::%a" print_var vs (print_type info) vs.vs_ty let print_var_list info fmt vsl = print_list space (print_typed_var info) fmt vsl (** expr *) let rec print_term info fmt t = match t.t_node with | Tconst c -> let number_format = { Number.long_int_support = true; Number.extra_leading_zeros_support = true; Number.dec_int_support = Number.Number_default; Number.hex_int_support = Number.Number_unsupported; Number.oct_int_support = Number.Number_unsupported; Number.bin_int_support = Number.Number_unsupported; Number.def_int_support = Number.Number_unsupported; Number.dec_real_support = Number.Number_unsupported; Number.hex_real_support = Number.Number_unsupported; Number.frac_real_support = Number.Number_custom (Number.PrintFracReal ("%s", "(* %s %s)", "(/ %s %s)")); Number.def_real_support = Number.Number_unsupported; } in Number.print number_format fmt c | Tvar v -> print_var fmt v | Tapp (ls, tl) -> begin match query_syntax info.info_syn ls.ls_name with | Some s -> syntax_arguments_typed s (print_term info) (print_type info) t fmt tl | None -> begin match tl with | [] -> fprintf fmt "%a" print_ident ls.ls_name | _ -> fprintf fmt "@,(%a %a)" print_ident ls.ls_name (print_list space (print_term info)) tl end end | Tlet (t1, tb) -> let v, t2 = t_open_bound tb in fprintf fmt "@[(let ((%a %a)) %a)@]" print_var v (print_term info) t1 (print_term info) t2; forget_var v | Tif (f1,t1,t2) -> fprintf fmt "@[(if %a@ %a@ %a)@]" (print_fmla info) f1 (print_term info) t1 (print_term info) t2 | Tcase _ -> unsupportedTerm t "yices: you must eliminate match" | Teps _ -> unsupportedTerm t "yices: you must eliminate epsilon" | Tquant _ | Tbinop _ | Tnot _ | Ttrue | Tfalse -> raise (TermExpected t) and print_fmla info fmt f = match f.t_node with | Tapp ({ ls_name = id }, []) -> print_ident fmt id | Tapp (ls, tl) -> begin match query_syntax info.info_syn ls.ls_name with | Some s -> syntax_arguments_typed s (print_term info) (print_type info) f fmt tl | None -> begin match tl with | [] -> fprintf fmt "%a" print_ident ls.ls_name | _ -> fprintf fmt "(%a %a)" print_ident ls.ls_name (print_list space (print_term info)) tl end end | Tquant (q, fq) -> let q = match q with Tforall -> "forall" | Texists -> "exists" in let vl, _tl, f = t_open_quant fq in (* TODO trigger dépend des capacités du prover : 2 printers? smtwithtriggers/smtstrict *) fprintf fmt "@[(%s@ (%a)@ %a)@]" q (print_var_list info) vl (print_fmla info) f; List.iter forget_var vl | Tbinop (Tand, f1, f2) -> fprintf fmt "@[(and %a@ %a)@]" (print_fmla info) f1 (print_fmla info) f2 | Tbinop (Tor, f1, f2) -> fprintf fmt "@[(or %a@ %a)@]" (print_fmla info) f1 (print_fmla info) f2 | Tbinop (Timplies, f1, f2) -> fprintf fmt "@[(=> %a@ %a)@]" (print_fmla info) f1 (print_fmla info) f2 | Tbinop (Tiff, f1, f2) -> fprintf fmt "@[(and (=> %a@ %a) (=> %a@ %a))@]" (print_fmla info) f1 (print_fmla info) f2 (print_fmla info) f2 (print_fmla info) f1 | Tnot f -> fprintf fmt "@[(not@ %a)@]" (print_fmla info) f | Ttrue -> fprintf fmt "true" | Tfalse -> fprintf fmt "false" | Tif (f1, f2, f3) -> fprintf fmt "@[(if %a@ %a@ %a)@]" (print_fmla info) f1 (print_fmla info) f2 (print_fmla info) f3 | Tlet (t1, tb) -> let v, f2 = t_open_bound tb in fprintf fmt "@[(let ((%a %a)) %a)@]" print_var v (print_term info) t1 (print_fmla info) f2; forget_var v | Tcase _ -> unsupportedTerm f "yices: you must eliminate match" | Tvar _ | Tconst _ | Teps _ -> raise (FmlaExpected f) (* and print_expr info fmt = TermTF.t_select (print_term info fmt) (print_fmla info fmt) (** I don't know how to print trigger for yices *) and print_triggers info fmt = function | [] -> () | a::l -> fprintf fmt "PATTERN (%a):@ %a" (print_list space (print_expr info)) a (print_triggers info) l let print_logic_binder info fmt v = fprintf fmt "%a: %a" print_ident v.vs_name (print_type info) v.vs_ty *) let print_type_decl info fmt ts = if ts.ts_args = [] && not (is_alias_type_def ts.ts_def) then if not (Mid.mem ts.ts_name info.info_syn) then fprintf fmt "(define-type %a)@\n@\n" print_ident ts.ts_name let print_data_decl _info fmt = function | ts, csl (* monomorphic enumeration *) when ts.ts_args = [] && List.for_all (fun (_,l) -> l = []) csl -> let print_cs fmt (ls,_) = print_ident fmt ls.ls_name in fprintf fmt "@[(define-type %a@ (scalar %a))@]@\n@\n" print_ident ts.ts_name (print_list space print_cs) csl | _, _ -> unsupported "yices: algebraic types are not supported" let print_data_decl info fmt (ts, _ as d) = if not (Mid.mem ts.ts_name info.info_syn) then print_data_decl info fmt d let print_param_decl info fmt ls = match ls.ls_args with | [] -> fprintf fmt "@[(define %a::%a)@]@\n@\n" print_ident ls.ls_name (print_type_value info) ls.ls_value | _ -> fprintf fmt "@[(define %a::(-> %a %a))@]@\n@\n" print_ident ls.ls_name (print_list space (print_type info)) ls.ls_args (print_type_value info) ls.ls_value let print_param_decl info fmt ls = if not (Mid.mem ls.ls_name info.info_syn) then print_param_decl info fmt ls let print_decl info fmt d = match d.d_node with | Dtype ts -> print_type_decl info fmt ts | Ddata dl -> print_list nothing (print_data_decl info) fmt dl | Dparam ls -> print_param_decl info fmt ls | Dlogic _ -> unsupportedDecl d "yices: function and predicate definitions are not supported" | Dind _ -> unsupportedDecl d "yices: inductive definitions are not supported" | Dprop (Paxiom, pr, _) when Mid.mem pr.pr_name info.info_syn -> () | Dprop (Paxiom, pr, f) -> fprintf fmt "@[;; %s@\n(assert@ %a);@]@\n@\n" pr.pr_name.id_string (print_fmla info) f | Dprop (Pgoal, pr, f) -> fprintf fmt "@[(assert@\n"; fprintf fmt "@[;; %a@]@\n" print_ident pr.pr_name; (match pr.pr_name.id_loc with | Some loc -> fprintf fmt " @[;; %a@]@\n" Loc.gen_report_position loc | None -> ()); fprintf fmt " @[(not %a)@])@]@\n(check)@\n" (print_fmla info) f | Dprop ((Plemma|Pskip), _, _) -> assert false let print_decls = let print_decl (sm,ct) fmt d = let info = {info_syn = sm; complex_type = ref ct; urg_output = ref []} in try print_decl info fmt d; (sm, !(info.complex_type)), !(info.urg_output) with Unsupported s -> raise (UnsupportedDecl (d,s)) in let print_decl = Printer.sprint_decl print_decl in let print_decl task acc = print_decl task.Task.task_decl acc in Discriminate.on_syntax_map (fun sm -> Trans.fold print_decl ((sm,Mty.empty),[])) let print_task args ?old:_ fmt task = (* In trans-based p-printing [forget_all] is a no-no *) (* forget_all ident_printer; *) print_prelude fmt args.prelude; print_th_prelude task fmt args.th_prelude; let rec print = function | x :: r -> print r; Pp.string fmt x | [] -> () in print (snd (Trans.apply print_decls task)); pp_print_flush fmt () let () = register_printer "yices" print_task ~desc:"Printer@ for@ the@ Yices@ theorem@ prover version 1." why3-0.88.3/src/printer/gappa.ml0000664000175100017510000004451713225666037017163 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** Gappa printer *) open Format open Pp open Printer open Ident open Term open Decl open Theory open Task let syntactic_transform transf = Trans.on_meta meta_syntax_logic (fun metas -> let symbols = List.fold_left (fun acc meta_arg -> match meta_arg with | [MAls ls; MAstr _; MAint _] -> Sls.add ls acc | _ -> assert false) Sls.empty metas in transf (fun ls -> Sls.mem ls symbols)) let () = Trans.register_transform "abstract_unknown_lsymbols" (syntactic_transform Abstraction.abstraction) ~desc:"Abstract@ applications@ of@ non-built-in@ symbols@ with@ \ constants.@ Used@ by@ the@ Gappa@ pretty-printer."; Trans.register_transform "simplify_unknown_lsymbols" (syntactic_transform (fun check_ls -> Trans.goal (fun pr f -> [create_prop_decl Pgoal pr (Simplify_formula.fmla_cond_subst (fun t1 t2 -> match t1.t_node with | Tconst _ -> false | Tapp(_,[]) -> begin match t2.t_node with | Tconst _ | Tapp(_,[]) -> true | _ -> false end | Tapp(ls,_) -> not (check_ls ls) | _ -> true) f) ]))) ~desc:"Same@ as@ simplify_trivial_quantification_in_goal,@ but@ instead@ \ of@ substituting@ quantified@ variables,@ substitute@ applications@ \ of@ non-built-in@ symbols.@ Used@ by@ the@ Gappa@ pretty-printer." (* patterns (TODO: add a parser and generalize it out of Gappa) *) type pattern = | PatHole of int | PatApp of Env.pathname * string * string list * pattern list let incremental_pat_match env holes = let rec aux p t = match p, t.t_node with | PatHole i, _ -> begin match holes.(i) with | None -> holes.(i) <- Some t | Some t' -> if not (t_equal t t') then raise Not_found end | PatApp (sp,ss,sl,pl), Tapp (ls,tl) -> if List.length pl <> List.length tl then raise Not_found; let th = Env.read_theory env sp ss in let s = ns_find_ls th.th_export sl in if not (ls_equal s ls) then raise Not_found; List.iter2 aux pl tl | _, _ -> raise Not_found in aux let pat_match env nb_holes p t = let holes = Array.make nb_holes None in incremental_pat_match env holes p t; Array.map (function None -> raise Not_found | Some t -> t) holes (* Gappa pre-compilation *) type info = { info_env : Env.env; info_symbols : Sid.t; info_ops_of_rel : (string * string * string) Mls.t; info_syn : syntax_map; } let int_minus = ref ps_equ let real_minus = ref ps_equ (** lsymbol, ""/"not ", op, rev_op *) let arith_meta = register_meta "gappa arith" [MTlsymbol;MTstring;MTstring;MTstring] ~desc:"Specify@ how@ to@ pretty-print@ arithmetic@ \ operations@ in@ the@ Gappa@ format:@\n \ @[\ @[- first@ argument:@ the@ symbol@]@\n\ @[- second@ argument:@ the@ prefix@ to@ put@ before@ the@ term@]@\n\ @[- third@ argument:@ the@ operator@ to@ print@]@\n\ @[- fourth@ argument:@ the@ inverse@ operator@]\ @]" let find_th env file th = let theory = Env.read_theory env [file] th in fun id -> Theory.ns_find_ls theory.Theory.th_export [id] let get_info env task = (* unary minus for constants *) int_minus := find_th env "int" "Int" "prefix -"; real_minus := find_th env "real" "Real" "prefix -"; (* handling of inequalities *) let ops = on_meta arith_meta (fun acc meta_arg -> match meta_arg with | [MAls ls; MAstr s; MAstr op; MAstr rev_op] -> Mls.add ls (s,op,rev_op) acc | _ -> assert false) Mls.empty task in (* sets of known symbols *) let syn = get_syntax_map task in let symb = Mid.map (Util.const ()) syn in let symb = Mls.fold (fun ls _ acc -> Sid.add ls.ls_name acc) ops symb in let symb = Sid.add ps_equ.ls_name symb in { info_env = env; info_symbols = symb; info_ops_of_rel = ops; info_syn = syn; } (* Gappa printing *) let ident_printer = let bls = [ "sqrt"; "fma"; "float"; "fixed"; "int"; "homogen80x"; "homogen80x_init"; "float80x"; "add_rel"; "sub_rel"; "mul_rel"; "fma_rel"; ] in let san = sanitizer char_to_alpha char_to_alnumus in create_ident_printer bls ~sanitizer:san let print_ident fmt id = fprintf fmt "%s" (id_unique ident_printer id) let number_format = { Number.long_int_support = true; Number.extra_leading_zeros_support = true; Number.dec_int_support = Number.Number_default; Number.hex_int_support = Number.Number_default; Number.oct_int_support = Number.Number_unsupported; Number.bin_int_support = Number.Number_unsupported; Number.def_int_support = Number.Number_unsupported; Number.dec_real_support = Number.Number_default; Number.hex_real_support = Number.Number_default; Number.frac_real_support = Number.Number_unsupported; Number.def_real_support = Number.Number_unsupported; } type constant = Enum of term * int | Value of term | Varying let rec constant_value defs t = match t.t_node with | Tconst c -> fprintf str_formatter "%a" (Number.print number_format) c; flush_str_formatter () | Tapp (ls, [{ t_node = Tconst c}]) when ls_equal ls !int_minus || ls_equal ls !real_minus -> fprintf str_formatter "-%a" (Number.print number_format) c; flush_str_formatter () | Tapp (ls, []) -> begin match Hid.find defs ls.ls_name with | Enum (_,i) -> Printf.sprintf "%d" i | Value c -> constant_value defs c | Varying -> raise Not_found end | _ -> raise Not_found (* terms *) let rec print_term info defs fmt t = let term = print_term info defs in try match t.t_node with | Tapp ( { ls_name = id }, [] ) -> begin match query_syntax info.info_syn id with | Some s -> syntax_arguments s term fmt [] | None -> fprintf fmt "%s" (constant_value defs t) end | _ -> fprintf fmt "%s" (constant_value defs t) with Not_found -> match t.t_node with | Tconst _ -> assert false | Tvar { vs_name = id } -> print_ident fmt id | Tapp ( { ls_name = id }, [] ) -> print_ident fmt id | Tapp (ls, tl) -> begin match query_syntax info.info_syn ls.ls_name with | Some s -> syntax_arguments s term fmt tl | None -> unsupportedTerm t ("gappa: function '" ^ ls.ls_name.id_string ^ "' is not supported") end | Tlet _ -> unsupportedTerm t "gappa: you must eliminate let in term" | Tif _ -> unsupportedTerm t "gappa: you must eliminate if_then_else" | Tcase _ -> unsupportedTerm t "gappa: you must eliminate match" | Teps _ -> unsupportedTerm t "gappa : you must eliminate epsilon" | Tquant _ | Tbinop _ | Tnot _ | Ttrue | Tfalse -> raise (TermExpected t) (* predicates *) let rel_error_pat = PatApp (["real"], "Real", ["infix <="], [ PatApp (["real"], "Abs", ["abs"], [ PatApp (["real"], "Real", ["infix -"], [ PatHole 0; PatHole 1])]); PatApp (["real"], "Real", ["infix *"], [ PatHole 2; PatApp (["real"], "Abs", ["abs"], [ PatHole 1])])]) let rec print_fmla info defs fmt f = let term = print_term info defs in let fmla = print_fmla info defs in match f.t_node with | Tapp ({ ls_name = id }, []) -> begin match query_syntax info.info_syn id with | Some s -> syntax_arguments s term fmt [] | None -> fprintf fmt "%a in [1,1]" print_ident id end | Tapp (ls, [t1;t2]) when ls_equal ls ps_equ -> (* TODO: distinguish between type of t1 and t2 the following is OK only for real of integer *) begin try let c1 = constant_value defs t1 in fprintf fmt "%a in [%s,%s]" term t2 c1 c1 with Not_found -> try let c2 = constant_value defs t2 in fprintf fmt "%a in [%s,%s]" term t1 c2 c2 with Not_found -> fprintf fmt "%a - %a in [0,0]" term t1 term t2 end | Tapp (ls, [t1;t2]) when Mls.mem ls info.info_ops_of_rel -> let s,op,rev_op = try Mls.find ls info.info_ops_of_rel with Not_found -> assert false in begin try let t = pat_match info.info_env 3 rel_error_pat f in let c = constant_value defs t.(2) in fprintf fmt "|%a -/ %a| <= %s" term t.(0) term t.(1) c with Not_found -> try let c1 = constant_value defs t1 in fprintf fmt "%s%a %s %s" s term t2 rev_op c1 with Not_found -> try let c2 = constant_value defs t2 in fprintf fmt "%s%a %s %s" s term t1 op c2 with Not_found -> fprintf fmt "%s%a - %a %s 0" s term t1 term t2 op end | Tapp (ls, tl) -> begin match query_syntax info.info_syn ls.ls_name with | Some s -> syntax_arguments s term fmt tl | None -> unsupportedTerm f ("gappa: predicate '" ^ ls.ls_name.id_string ^ "' is not supported") end | Tquant (_q, _fq) -> unsupportedTerm f "gappa: quantifiers are not supported" | Tbinop (Tand, f1, f2) -> fprintf fmt "(%a /\\@ %a)" fmla f1 fmla f2 | Tbinop (Tor, f1, f2) -> fprintf fmt "(%a \\/@ %a)" fmla f1 fmla f2 | Tbinop (Timplies, f1, f2) -> fprintf fmt "(%a ->@ %a)" fmla f1 fmla f2 | Tbinop (Tiff, f1, f2) -> fprintf fmt "((%a ->@ %a) /\\@ (%a ->@ %a))" fmla f1 fmla f2 fmla f2 fmla f1 | Tnot f -> fprintf fmt "not %a" fmla f | Ttrue -> fprintf fmt "(0 in [0,0])" | Tfalse -> fprintf fmt "(1 in [0,0])" | Tif (_f1, _f2, _f3) -> unsupportedTerm f "gappa: you must eliminate if in formula" | Tlet _ -> unsupportedTerm f "gappa: you must eliminate let in formula" | Tcase _ -> unsupportedTerm f "gappa: you must eliminate match" | Tvar _ | Tconst _ | Teps _ -> raise (FmlaExpected f) let get_constant defs t = let rec follow neg_ls t = match t.t_node with | Tconst _ -> begin match neg_ls with | Some ls -> Value (t_app_infer ls [t]) | None -> Value t end | Tapp (ls, [t]) when ls_equal ls !int_minus || ls_equal ls !real_minus -> follow (match neg_ls with None -> Some ls | Some _ -> None) t | Tapp (ls, []) -> begin match Hid.find defs ls.ls_name with | Value t -> follow neg_ls t | Enum _ as e -> e | Varying -> Varying | exception Not_found -> Varying end | _ -> Varying in follow None t let rec simpl_fmla defs truths f = match f.t_node with | Tapp (ls, []) -> begin try if Hid.find truths ls.ls_name then t_true else t_false with Not_found -> f end | Tapp (ls, [{ t_node = Tapp (t1, []) }; t2]) when ls_equal ls ps_equ && t_equal t2 t_bool_true -> begin try if Hid.find truths t1.ls_name then t_true else t_false with Not_found -> f end | Tapp (ls, [t1; t2]) when ls_equal ls ps_equ -> begin match get_constant defs t1, get_constant defs t2 with | Enum (_, i1), Enum (_, i2) -> if i1 = i2 then t_true else t_false | _, _ -> f end | Tbinop _ | Tnot _ -> t_map_simp (simpl_fmla defs truths) f | _ -> f exception AlreadyDefined exception Contradiction let split_hyp defs truths pr acc f = let rec split acc pos f = match f.t_node with | Tbinop (Tand, f1, f2) when pos -> split (split acc true f1) true f2 | Tbinop (Tor, f1, f2) when not pos -> split (split acc false f1) false f2 | Tbinop (Timplies, f1, f2) when not pos -> split (split acc true f1) false f2 | Tapp (ls,[]) -> let () = try if Hid.find truths ls.ls_name <> pos then raise Contradiction with Not_found -> Hid.add truths ls.ls_name pos in acc | Tapp (ls, [{ t_node = Tapp (t1, []) }; t2]) when ls_equal ls ps_equ && t_equal t2 t_bool_true -> let () = try if Hid.find truths t1.ls_name <> pos then raise Contradiction with Not_found -> Hid.add truths t1.ls_name pos in acc | Ttrue -> if pos then acc else raise Contradiction | Tfalse -> if pos then raise Contradiction else acc | Tnot f -> split acc (not pos) f | Tapp (ls, [t1; t2]) when pos && ls_equal ls ps_equ -> begin let try_equality t c = match t.t_node with | Tapp (ls,[]) -> Hid.add defs ls.ls_name c; acc | _ -> (pr,f)::acc in match get_constant defs t1, get_constant defs t2 with | Enum (_, i1), Enum (_, i2) -> if i1 = i2 then acc else raise Contradiction | (Enum _ as c1), Varying -> try_equality t2 c1 | Varying, (Enum _ as c2) -> try_equality t1 c2 | _, _ -> (pr,f)::acc end | _ -> if pos then (pr,f)::acc else (pr, t_not f)::acc in split acc true f let prepare defs ints truths acc d = match d.d_node with | Dtype _ -> acc | Ddata dl -> List.iter (fun (_, dl) -> let _ = List.fold_left (fun idx (cs,cl) -> match cl with | [] -> Hid.replace defs cs.ls_name (Enum (t_app_infer cs [], idx)); idx + 1 | _ -> idx ) 0 dl in ()) dl; acc | Dparam ({ ls_args = []; ls_value = Some ty; } as ls) when Ty.ty_equal ty Ty.ty_int -> ints := ls::!ints; acc | Dparam _ | Dlogic _ -> acc | Dind _ -> unsupportedDecl d "please remove inductive definitions before calling gappa printer" | Dprop (Paxiom, pr, f) -> split_hyp defs truths pr acc (simpl_fmla defs truths f) | Dprop (Pgoal, pr, f) -> split_hyp defs truths pr acc (simpl_fmla defs truths (t_not f)) | Dprop ((Plemma|Pskip), _, _) -> unsupportedDecl d "gappa: lemmas are not supported" let filter_hyp defs (eqs, hyps) ((pr, f) as hyp) = match f.t_node with | Tapp(ls,[t1;t2]) when ls_equal ls ps_equ -> begin let try_equality t1 t2 = let l = match t1.t_node with | Tapp (l,[]) -> l | _ -> raise AlreadyDefined in if Hid.mem defs l.ls_name then raise AlreadyDefined; if t_s_any (fun _ -> false) (fun ls -> ls_equal ls l) t2 then raise AlreadyDefined; let c = get_constant defs t2 in Hid.add defs l.ls_name c; match c with | Varying -> t_s_fold (fun _ _ -> ()) (fun _ ls -> if not (Hid.mem defs ls.ls_name) then Hid.add defs ls.ls_name Varying) () t2; ((pr,t1,t2)::eqs, hyps) | _ -> (eqs, hyps) in try try_equality t1 t2 with AlreadyDefined -> try try_equality t2 t1 with AlreadyDefined -> (eqs, hyp::hyps) end | _ -> (eqs, hyp::hyps) let find_used_equations eqs hyps = let used = Hid.create 17 in let mark_used f = t_s_fold (fun _ _ -> ()) (fun _ ls -> Hid.replace used ls.ls_name ()) () f in List.iter (fun (_,f) -> mark_used f) hyps; List.fold_left (fun acc ((_, v, t) as eq) -> let v = match v.t_node with Tapp (l,[]) -> l.ls_name | _ -> assert false in if Hid.mem used v then begin mark_used t; eq :: acc end else acc ) [] eqs let rec find_used_bools known acc f = match f.t_node with | Tapp(ls,[]) -> if Hid.mem known ls.ls_name then acc else (Hid.add known ls.ls_name (); ls.ls_name :: acc) | Tbinop (_, f1, f2) -> find_used_bools known (find_used_bools known acc f2) f1 | Tnot f -> find_used_bools known acc f | _ -> acc let print_equation info defs fmt (pr,t1,t2) = fprintf fmt "# equation '%a'@\n" print_ident pr.pr_name; fprintf fmt "%a = %a ;@\n" (print_term info defs) t1 (print_term info defs) t2 let print_bool fmt ls = fprintf fmt "(%a in [0,0] \\/ %a in [1,1]) ->@\n" print_ident ls print_ident ls let print_bool2 fmt ls = fprintf fmt "%a in (0.5)" print_ident ls let print_hyp info defs fmt (pr,f) = fprintf fmt "# hypothesis '%a'@\n" print_ident pr.pr_name; fprintf fmt "%a ->@\n" (print_fmla info defs) f let print_ints fmt ls = fprintf fmt "@FIX(%a,0) ->@\n" print_ident ls.ls_name let print_task args ?old:_ fmt task = forget_all ident_printer; let info = get_info args.env task in print_prelude fmt args.prelude; print_th_prelude task fmt args.th_prelude; try let defs = Hid.create 17 in let ints = ref [] in (* get hypotheses and simplify them *) let hyps = let truths = Hid.create 17 in let rec iter old_nb hyps = let hyps = List.fold_left (fun acc (pr,f) -> split_hyp defs truths pr acc (simpl_fmla defs truths f)) [] hyps in let hyps = List.rev hyps in let nb = Hid.length truths in if nb > old_nb then iter nb hyps else hyps in let hyps = List.fold_left (prepare defs ints truths) [] (Task.task_decls task) in iter (Hid.length truths) (List.rev hyps) in (* extract equations and keep the needed ones *) let (eqs, hyps) = List.fold_left (filter_hyp defs) ([],[]) hyps in let hyps = List.rev hyps in let eqs = find_used_equations eqs hyps in (* find needed booleans *) let bools = let bools = Hid.create 17 in List.fold_left (fun acc (_,f) -> find_used_bools bools acc f) [] hyps in (* print equalities *) List.iter (print_equation info defs fmt) eqs; (* print formula *) match List.rev hyps with | [] -> fprintf fmt "{ 1 in [0,0] }@\n" | (_,goal) :: hyps -> fprintf fmt "@[{ %a%a%a%a }@]@\n%a" (print_list nothing print_bool) bools (print_list nothing print_ints) (!ints) (print_list nothing (print_hyp info defs)) hyps (print_fmla info defs) (t_not_simp goal) (print_list_delim ~start:(fun fmt () -> fprintf fmt "$ ") ~stop:(fun fmt () -> fprintf fmt ";@\n") ~sep:comma print_bool2) bools with Contradiction -> fprintf fmt "{ 0 in [0,0] }@\n" let () = register_printer "gappa" print_task ~desc:"Printer@ for@ the@ Gappa@ theorem@ prover@ specialized@ in@ \ floating@ point@ reasoning." why3-0.88.3/src/printer/alt_ergo.mli0000664000175100017510000000130713225666037020026 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) why3-0.88.3/src/printer/mathematica.ml0000664000175100017510000004530313225666037020342 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** Mathematica printer *) open Format open Pp open Printer open Ident open Ty open Term open Decl open Theory open Task (* patterns (TODO: add a parser and generalize it out of Mathematica) *) type pattern = | PatHole of int | PatApp of Env.pathname * string * string list * pattern list let incremental_pat_match env holes = let rec aux p t = match p, t.t_node with | PatHole i, _ -> begin match holes.(i) with | None -> holes.(i) <- Some t | Some t' -> if not (t_equal t t') then raise Not_found end | PatApp (sp,ss,sl,pl), Tapp (ls,tl) -> if List.length pl <> List.length tl then raise Not_found; let th = Env.read_theory env sp ss in let s = ns_find_ls th.th_export sl in if not (ls_equal s ls) then raise Not_found; List.iter2 aux pl tl | _, _ -> raise Not_found in aux let pat_match env nb_holes p t = let holes = Array.make nb_holes None in incremental_pat_match env holes p t; Array.map (function None -> raise Not_found | Some t -> t) holes (* Mathematica pre-compilation *) type info = { info_env : Env.env; info_symbols : Sid.t; info_ops_of_rel : (string * string * string) Mls.t; info_syn : syntax_map; (*mutable info_vars : vsymbol list;*) } let int_minus = ref ps_equ let real_minus = ref ps_equ (** lsymbol, ""/"not ", op, rev_op *) let arith_meta = register_meta "math arith" [MTlsymbol;MTstring;MTstring;MTstring] ~desc:"Specify@ how@ to@ pretty-print@ arithmetic@ \ operations@ in@ the@ Mathematica@ format:@\n \ @[\ @[- first@ argument:@ the@ symbol@]@\n\ @[- second@ argument:@ the@ prefix@ to@ put@ before@ the@ term@]@\n\ @[- third@ argument:@ the@ operator@ to@ print@]@\n\ @[- fourth@ argument:@ the@ inverse@ operator@]\ @]" let find_th env file th = let theory = Env.read_theory env [file] th in fun id -> Theory.ns_find_ls theory.Theory.th_export [id] let get_info env task = (* unary minus for constants *) int_minus := find_th env "int" "Int" "prefix -"; real_minus := find_th env "real" "Real" "prefix -"; (* handling of inequalities *) let ops = on_meta arith_meta (fun acc meta_arg -> match meta_arg with | [MAls ls; MAstr s; MAstr op; MAstr rev_op] -> Mls.add ls (s,op,rev_op) acc | _ -> assert false) Mls.empty task in (* sets of known symbols *) let syn = get_syntax_map task in let symb = Mid.map (Util.const ()) syn in let symb = Mls.fold (fun ls _ acc -> Sid.add ls.ls_name acc) ops symb in let symb = Sid.add ps_equ.ls_name symb in { info_env = env; info_symbols = symb; info_ops_of_rel = ops; info_syn = syn; (*info_vars = [];*) } (* Mathematica printing *) let ident_printer = let bls = [] in (* TODO *) let san = sanitizer char_to_lalpha char_to_alnum in create_ident_printer bls ~sanitizer:san let print_ident fmt id = fprintf fmt "%s" (id_unique ident_printer id) let print_const fmt c = let number_format = { Number.long_int_support = true; Number.extra_leading_zeros_support = true; Number.dec_int_support = Number.Number_default; Number.hex_int_support = Number.Number_default; Number.oct_int_support = Number.Number_unsupported; Number.bin_int_support = Number.Number_unsupported; Number.def_int_support = Number.Number_unsupported; Number.dec_real_support = Number.Number_unsupported; Number.hex_real_support = Number.Number_unsupported; Number.frac_real_support = Number.Number_custom (Number.PrintFracReal ("%s", "(%s/%s)", "(%s/%s)")); Number.def_real_support = Number.Number_unsupported; } in (Number.print number_format) fmt c let constant_value = fun t -> match t.t_node with | Tconst c -> fprintf str_formatter "%a" print_const c; flush_str_formatter () | Tapp(ls, [{ t_node = Tconst c}]) when ls_equal ls !int_minus || ls_equal ls !real_minus -> fprintf str_formatter "-%a" print_const c; flush_str_formatter () | _ -> raise Not_found let rel_error_pat = PatApp (["real"], "Real", ["infix <="], [ PatApp (["real"], "Abs", ["abs"], [ PatApp (["real"], "Real", ["infix -"], [ PatHole 0; PatHole 1])]); PatApp (["real"], "Real", ["infix *"], [ PatHole 2; PatApp (["real"], "Abs", ["abs"], [ PatHole 1])])]) (* terms *) let rec print_term info fmt t = let term = print_term info in let fmla = print_fmla info in match t.t_node with | Tconst c -> (*Pretty.print_const fmt c*) print_const fmt c | Tvar { vs_name = id } -> print_ident fmt id | Tapp ( { ls_name = id } ,[] ) -> begin match query_syntax info.info_syn id with | Some s -> syntax_arguments s term fmt [] | None -> print_ident fmt id end | Tapp ( { ls_name = id } ,[t] ) when try String.sub id.id_string 0 6 = "index_" with Invalid_argument _ -> false -> fprintf fmt "%a" term t | Tapp (ls, tl) -> begin match query_syntax info.info_syn ls.ls_name with | Some s -> syntax_arguments s term fmt tl (*| None -> unsupportedTerm t ("math: function '" ^ ls.ls_name.id_string ^ "' is not supported")*) | None -> begin match tl with | [] -> fprintf fmt "%a" print_ident ls.ls_name | _ -> fprintf fmt "%a[%a]" print_ident ls.ls_name (print_list comma term) tl end end | Tif (f, t1, t2) -> fprintf fmt "If[%a,@ %a,@ %a]" fmla f term t1 term t2 (*| Tif _ -> unsupportedTerm t "math: you must eliminate if_then_else"*) | Tlet _ -> unsupportedTerm t "math: you must eliminate let in term" | Tcase _ -> unsupportedTerm t "math: you must eliminate match" (*| Tcase (t,bl) -> print_case print_term info fmt t bl*) | Teps _ -> unsupportedTerm t "math: you must eliminate epsilon" | Tquant _ | Tbinop _ | Tnot _ | Ttrue | Tfalse -> raise (TermExpected t) (* predicates *) (*let rec*) and print_fmla info fmt f = let term = print_term info in let fmla = print_fmla info in match f.t_node with | Tapp ({ ls_name = id }, []) -> begin match query_syntax info.info_syn id with | Some s -> syntax_arguments s term fmt [] | None -> fprintf fmt "%a == 0" print_ident id end | Tapp (ls, [t1;t2]) when ls_equal ls ps_equ -> (* TODO: distinguish between type of t1 and t2 the following is OK only for real or integer *) begin try let c1 = constant_value t1 in fprintf fmt "%a == %s" term t2 c1 with Not_found -> try let c2 = constant_value t2 in fprintf fmt "%a == %s" term t1 c2 with Not_found -> fprintf fmt "%a - %a == 0" term t1 term t2 end | Tapp (ls, [t1;t2]) when Mls.mem ls info.info_ops_of_rel -> let s,op,rev_op = try Mls.find ls info.info_ops_of_rel with Not_found -> assert false in begin try let t = pat_match info.info_env 3 rel_error_pat f in let c = constant_value t.(2) in fprintf fmt "|%a -/ %a| <= %s" term t.(0) term t.(1) c with Not_found -> try let c1 = constant_value t1 in fprintf fmt "%s%a %s %s" s term t2 rev_op c1 with Not_found -> try let c2 = constant_value t2 in fprintf fmt "%s%a %s %s" s term t1 op c2 with Not_found -> fprintf fmt "%s%a - %a %s 0" s term t1 term t2 op end | Tapp (ls, tl) -> begin match query_syntax info.info_syn ls.ls_name with | Some s -> syntax_arguments s term fmt tl | None -> (*unsupportedTerm f ("math: predicate '" ^ ls.ls_name.id_string ^ "' is not supported")*) begin match tl with | [] -> fprintf fmt "%a" print_ident ls.ls_name | _ -> fprintf fmt "%a[%a]" print_ident ls.ls_name (print_list comma (print_term info)) tl end end (*| Tquant _ -> unsupportedTerm f "math: quantifiers are not supported"*) (*| Tquant (Tforall, fq) -> let vl, _tl, f = t_open_quant fq in info.info_vars <- List.append info.info_vars vl; fprintf fmt "%a" fmla f*) | Tquant (Tforall, fq) -> let vl, _tl, f = t_open_quant fq in let var fmt v = (* TODO: type check v.vs_ty *) print_ident fmt v.vs_name in fprintf fmt "ForAll[{%a}, %a]" (print_list comma var) vl fmla f | Tquant (Texists, fq) -> let vl, _tl, f = t_open_quant fq in let var fmt v = (* TODO: type check v.vs_ty *) print_ident fmt v.vs_name in fprintf fmt "Exists[{%a}, %a]" (print_list comma var) vl fmla f | Tbinop (Tand, f1, f2) -> fprintf fmt "(%a &&@ %a)" fmla f1 fmla f2 | Tbinop (Tor, f1, f2) -> fprintf fmt "(%a ||@ %a)" fmla f1 fmla f2 | Tbinop (Timplies, f1, f2) -> fprintf fmt "Implies[%a,@ %a]" fmla f1 fmla f2 | Tbinop (Tiff, f1, f2) -> fprintf fmt "Equivalent[%a,@ %a]" fmla f1 fmla f2 | Tnot f -> fprintf fmt "Not[%a]" fmla f | Ttrue -> fprintf fmt "True" | Tfalse -> fprintf fmt "False" | Tif (f1, f2, f3) -> fprintf fmt "If[%a,@ %a,@ %a]" fmla f1 fmla f2 fmla f3 | Tlet _ -> unsupportedTerm f "math: you must eliminate let in formula" | Tcase _ -> unsupportedTerm f "math: you must eliminate match" (*| Tcase (t,bl) -> print_case print_fmla info fmt t bl*) | Tvar _ | Tconst _ | Teps _ -> raise (FmlaExpected f) exception AlreadyDefined (* TODO *) let is_number = function | Tyapp (ts, _) -> ts.ts_name.id_string = "int" || ts.ts_name.id_string = "real" | _ -> false let filter_logic info ((params,funs,preds,types) as acc) (ls,ld) = if (not (Mid.mem ls.ls_name info.info_symbols)) then match ls.ls_args, ls.ls_value with | _, Some _ty (*when is_number ty.ty_node*) -> (* functions *) (params,(ls,ld)::funs,preds,types) | _, None -> (* predicates *) (params,funs,(ls,ld)::preds,types) (*| _, _, None -> (* funs/preds without definitions *) (*unsupported "math: funs/preds without definitions"*) acc *) else acc let rec filter_hyp info params defs eqs hyps pr f = match f.t_node with | Tapp(ls,[t1;t2]) when ls == ps_equ -> (* parameter definition *) let try_equality t1 t2 = match t1.t_node with | Tapp(l,[]) -> if Hid.mem defs l.ls_name then raise AlreadyDefined; Hid.add defs l.ls_name (); t_s_fold (fun _ _ -> ()) (fun _ ls -> Hid.replace defs ls.ls_name ()) () t2; (* filters out the defined parameter *) let params = List.filter (fun p -> p.ls_name <> l.ls_name) params in (params, (pr,t1,t2)::eqs, hyps) | _ -> raise AlreadyDefined in begin try try_equality t1 t2 with AlreadyDefined -> try try_equality t2 t1 with AlreadyDefined -> (params, eqs, (pr,f)::hyps) end | Tbinop (Tand, f1, f2) -> let (params,eqs,hyps) = filter_hyp info params defs eqs hyps pr f2 in filter_hyp info params defs eqs hyps pr f1 | Tapp(_,[]) -> (* Discard (abstracted) predicate variables. While Mathematica would handle them, it is usually just noise from Mathematica's point of view and better delegated to a SAT solver. *) (params,eqs,hyps) | Ttrue -> (params,eqs,hyps) | _ -> (params, eqs, (pr,f)::hyps) type filter_goal = | Goal_good of Decl.prsymbol * term | Goal_bad of string | Goal_none let filter_goal pr f = match f.t_node with | Tapp(ps,[]) -> Goal_bad ("symbol " ^ ps.ls_name.Ident.id_string ^ " unknown") (* todo: filter more goals *) | _ -> Goal_good(pr,f) let prepare info defs ((params,funs,preds,eqs,hyps,goal,types) as acc) d = match d.d_node with (*| Dtype [ts, Talgebraic csl] -> (params,funs,preds,eqs,hyps,goal,(ts,csl)::types)*) (*| Dtype [ts, Tabstract] -> printf "abst type: %a@\n" print_ident ts.ts_name; if Mid.mem ts.ts_name types then acc else let types = Mid.add (ts.ts_name,[]) types in (params,funs,preds,eqs,hyps,goal,types)*) | Dtype _ -> acc | Dparam ls -> begin match ls.ls_args, ls.ls_value with | [], Some ty -> if is_number ty.ty_node then (* params *) (ls::params,funs,preds,eqs,hyps,goal,types) else acc | _ -> acc end | Dlogic dl -> (* TODO *) let (params,funs,preds,types) = List.fold_left (filter_logic info) (params,funs,preds,types) dl in (params,funs,preds,eqs,hyps,goal,types) | Dprop (Paxiom, pr, f) -> let (params,eqs,hyps) = filter_hyp info params defs eqs hyps pr f in (params,funs,preds,eqs,hyps,goal,types) | Dprop (Pgoal, pr, f) -> begin match goal with | Goal_none -> let goal = filter_goal pr f in (params,funs,preds,eqs,hyps,goal,types) | _ -> assert false end | Dind _ -> unsupportedDecl d "please remove inductive definitions before calling Mathematica printer" | Dprop ((Plemma|Pskip), _, _) -> unsupportedDecl d "math: lemmas are not supported" | _ -> acc let print_equation info fmt (pr,t1,t2) = (* TODO *) fprintf fmt "(* equation '%a'*)@\n" print_ident pr.pr_name; fprintf fmt "%a = %a;@\n" (print_term info) t1 (print_term info) t2 let print_logic_binder _info fmt v = fprintf fmt "%a_" print_ident v.vs_name let print_fun_def info fmt (ls,ld) = let vl,e = open_ls_defn ld in fprintf fmt "(* function '%a' *)@\n" print_ident ls.ls_name; fprintf fmt "@[%a[%a] :=@ %a;@]@\n@\n" print_ident ls.ls_name (print_list comma (print_logic_binder info)) vl (print_term info) e let print_pred_def info fmt (ls,ld) = let vl,e = open_ls_defn ld in fprintf fmt "(* predicate '%a'*)@\n" print_ident ls.ls_name; fprintf fmt "@[%a[%a] :=@ %a;@]@\n" print_ident ls.ls_name (print_list comma (print_logic_binder info)) vl (print_fmla info) e; (*if String.sub ls.ls_name.id_string 0 8 = "index_c_" then fprintf fmt "@[%a[];@]@\n" print_ident ls.ls_name;*) fprintf fmt "@\n" let print_type_def _info fmt (ts,csl) = fprintf fmt "(* algebraic type %a*)@\n" print_ident ts.ts_name; let alen = List.length csl in let print_def fmt () = if alen >= 1 then begin fprintf fmt "x = 1"; for i = 2 to alen do fprintf fmt " || x = %d" i done end else () in fprintf fmt "Is%a[x_] := %a;@\n" print_ident ts.ts_name print_def (); let print_args fmt () = for i = 1 to alen do fprintf fmt ", v%d" i done in let rec print_case fmt n = if n > 1 then fprintf fmt "If[x == %d, v%d, %a]" n n print_case (n-1) else fprintf fmt "If[x == 1, v1, 0]" in fprintf fmt "Match%a[x_%a] := %a;@\n" print_ident ts.ts_name print_args () print_case alen let print_hyp info fmt (pr,f) = fprintf fmt "(* hypothesis '%a' *)@\n" print_ident pr.pr_name; fprintf fmt "%a \\[Implies]@\n" (print_fmla info) f let is_integer = function | Tyapp (ts, _) -> ts.ts_name.id_string = "int" | _ -> false let print_dom _info fmt lsymbol = match lsymbol.ls_value with (* TODO: algebraic types *) | Some ty when is_integer ty.ty_node -> fprintf fmt "Element[%a,Integers] &&@\n" print_ident lsymbol.ls_name (*unsupportedType ty "math: integers are not supported"*) | _ -> () let print_param _info fmt lsymbol = fprintf fmt "%a" print_ident lsymbol.ls_name let print_var info fmt vsymbol = (*fprintf fmt "%a" print_ident vsymbol.vs_name*) begin match query_syntax info.info_syn vsymbol.vs_name with | Some s -> syntax_arguments s (print_term info) fmt [] | None -> print_ident fmt vsymbol.vs_name end let print_goal info fmt g = match g with | Goal_good(pr,f) -> fprintf fmt "(* goal '%a' *)@\n" print_ident pr.pr_name; fprintf fmt "%a@\n" (print_fmla info) f | Goal_bad msg -> fprintf fmt "(* unsupported kind of goal: %s *)@\n" msg; fprintf fmt "False@\n" | Goal_none -> fprintf fmt "(* no goal at all ?? *)@\n"; fprintf fmt "False@\n" let print_task args ?old:_ fmt task = forget_all ident_printer; let info = get_info args.env task in print_prelude fmt (List.append args.prelude ["$MaxExtraPrecision = 256;\ ClearAll[vcWhy,varsWhy,resWhy];"]); print_th_prelude task fmt args.th_prelude; let params,funs,preds,eqs,hyps,goal,types = List.fold_left (prepare info (Hid.create 17)) ([],[],[],[],[],Goal_none,[]) (Task.task_decls task) in List.iter (print_equation info fmt) (List.rev eqs); List.iter (print_fun_def info fmt) (List.rev funs); List.iter (print_pred_def info fmt) (List.rev preds); List.iter (print_type_def info fmt) (List.rev types); fprintf fmt "@[vcWhy = %a(%a%a);@]@\n" (print_list nothing (print_hyp info)) (List.rev hyps) (*"@[vcWhy = (@\n%a%a@,);@]@\n" *) (print_list nothing (print_dom info)) params (print_goal info) goal; (*fprintf fmt "@[varsWhy = {%a%s@ %a};@]@\n" *) fprintf fmt "@[varsWhy = {%a};@]@\n" (print_list simple_comma (print_param info)) params; (*(if List.length params = 0 then "" else ",") (print_list simple_comma (print_var info)) info.info_vars;*) fprintf fmt "@[resWhy = FullSimplify[vcWhy];@]@\n"; fprintf fmt "@[If[resWhy, Print[True], Print[False],@,"; fprintf fmt "resWhy = FindInstance[Not[resWhy],varsWhy,Reals];@,"; fprintf fmt "@[If[Head[resWhy]==List&&Length[resWhy]==0,@,"; fprintf fmt "Print[True],@,"; fprintf fmt "resWhy = Reduce[vcWhy,varsWhy,Reals];@,"; fprintf fmt "If[resWhy, Print[True], Print[False], Print[resWhy]] ]@] ];@]" (*fprintf fmt "@[Quit[];@]@\n"*) (* print_decls ?old info fmt (Task.task_decls task) *) let () = register_printer "mathematica" print_task ~desc:"Printer@ for@ the@ Mathematica@ specialized@ in@ computational@ algebla." (* Local Variables: compile-command: "unset LANG; make -C ../.. byte" End: *) why3-0.88.3/src/printer/simplify.mli0000664000175100017510000000130713225666037020066 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) why3-0.88.3/src/printer/cvc3.mli0000664000175100017510000000130713225666037017070 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) why3-0.88.3/src/printer/gappa.mli0000664000175100017510000000130713225666037017322 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) why3-0.88.3/src/printer/isabelle.ml0000664000175100017510000004276113225666037017652 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** Isabelle printer main author: Stefan Berghofer *) open Format open Pp open Ident open Ty open Term open Decl open Printer (** Utilities *) let attrib s pr fmt v = fprintf fmt " %s=\"%a\"" s pr v let attribs s pr pr' fmt (att, r) = fprintf fmt "%a%a" (attrib s pr) att pr' r let empty_elem s pr fmt att = fprintf fmt "<%s%a/>" s pr att let elem s pr pr' fmt (att, x) = fprintf fmt "<%s%a>%a" s pr att pr' x s let elem' s pr fmt x = elem s nothing pr fmt ((), x) let elems s pr pr' fmt ((att, xs) as p) = match xs with | [] -> empty_elem s pr fmt att | _ -> elem s pr (print_list nothing pr') fmt p let elems' s pr fmt xs = elems s nothing pr fmt ((), xs) let pair pr pr' fmt (x, y) = fprintf fmt "%a%a" pr x pr' y let opt_string_of_bool b = if b then Some "true" else None (* identifiers *) let black_list = ["o"; "O"] let isanitize = sanitizer' char_to_alpha char_to_alnumus char_to_alnum let fresh_printer () = create_ident_printer black_list ~sanitizer:isanitize let iprinter = fresh_printer () let forget_ids () = forget_all iprinter let string_of_id id = isanitize id.id_string (* type variables *) let tvprinter = fresh_printer () let forget_tvs () = forget_all tvprinter let print_tv fmt tv = let n = id_unique tvprinter tv.tv_name in fprintf fmt "%s" n (* logic variables *) let print_vs fmt vs = let n = id_unique iprinter vs.vs_name in fprintf fmt "%s" n let forget_var vs = forget_id iprinter vs.vs_name (* info *) type info = { info_syn : syntax_map; symbol_printers : (string * ident_printer) Mid.t; realization : bool; theories : string Mid.t; } let print_id fmt id = string fmt (id_unique iprinter id) let print_altname_path info fmt id = attribs "altname" html_string (print_option (attrib "path" string)) fmt (id.id_string, Mid.find_opt id info.theories) let print_id_attr info fmt id = attribs "name" print_id (print_altname_path info) fmt (id, id) let print_ts info fmt ts = print_id_attr info fmt ts.ts_name let print_ls info fmt ls = print_id_attr info fmt ls.ls_name let print_pr info fmt pr = print_id_attr info fmt pr.pr_name let print_id_real info fmt id = try let path, ipr = Mid.find id info.symbol_printers in attribs "name" string (attrib "path" string) fmt (id_unique ipr id, path) with Not_found -> attribs "name" print_id (attrib "local" string) fmt (id, "true") let print_ts_real info fmt ts = print_id_real info fmt ts.ts_name (** Types *) let rec print_ty info fmt ty = match ty.ty_node with | Tyvar v -> empty_elem "tvar" (attrib "name" print_tv) fmt v | Tyapp (ts, tl) when is_ts_tuple ts -> elems' "prodt" (print_ty info) fmt tl | Tyapp (ts, tl) -> begin match query_syntax info.info_syn ts.ts_name with | Some s -> syntax_arguments s (print_ty info) fmt tl | None -> elems "type" (print_ts_real info) (print_ty info) fmt (ts, tl) end let print_fun_type info fmt (tys, opty) = match opty with | None -> elems' "pred" (print_ty info) fmt tys | Some ty -> (match tys with | [] -> print_ty info fmt ty | _ -> elems' "fun" (print_ty info) fmt (tys @ [ty])) (** Patterns, terms, and formulas *) let print_ls_type info fmt ls = print_fun_type info fmt (ls.ls_args, ls.ls_value) let print_ls_real info defs fmt (ls, ty) = if Sls.mem ls defs then elem "var" (attrib "name" print_id) (print_fun_type info) fmt (ls.ls_name, ty) else elem "const" (print_id_real info) (print_fun_type info) fmt (ls.ls_name, ty) let print_app pr pr' fmt ((h, xs) as p) = match xs with | [] -> pr fmt h | _ -> elem' "app" (pair pr (print_list nothing pr')) fmt p let print_var info fmt v = elem "var" (attrib "name" print_vs) (print_ty info) fmt (v, v.vs_ty) let print_const = empty_elem "const" (attrib "name" string) let print_abs info pr fmt (v, t) = elem "abs" (attrib "name" print_vs) (pair (print_ty info) pr) fmt (v, (v.vs_ty, t)); forget_var v let p_type p = p.pat_ty let rec split_por p = match p.pat_node with | Pwild -> [pat_wild p.pat_ty] | Pvar v -> [pat_var v] | Pas _ -> assert false | Por (p1, p2) -> split_por p1 @ split_por p2 | Papp (cs, pl) -> List.map (fun zs -> pat_app cs zs p.pat_ty) (List.fold_right (fun xs xss -> List.concat (List.map (fun x -> List.map (fun ys -> x :: ys) xss) xs)) (List.map split_por pl) [[]]) let rec print_pat info fmt p = match p.pat_node with | Pwild -> print_const fmt "Pure.dummy_pattern" | Pvar v -> print_var info fmt v | Pas _ -> assert false | Por _ -> assert false | Papp (cs, pl) when is_fs_tuple cs -> elems' "prod" (print_pat info) fmt pl | Papp (cs, pl) -> begin match query_syntax info.info_syn cs.ls_name with | Some s -> gen_syntax_arguments_typed p_type (fun _ -> [||]) s (print_pat info) (print_ty info) p fmt pl | _ -> print_app (print_ls_real info Sls.empty) (print_pat info) fmt ((cs, (List.map p_type pl, Some (p.pat_ty))), pl) end let binop_name = function | Tand -> "HOL.conj" | Tor -> "HOL.disj" | Timplies -> "HOL.implies" | Tiff -> "HOL.eq" let rec print_term info defs fmt t = match t.t_node with | Tvar v -> print_var info fmt v | Tconst c -> let number_format = { Number.long_int_support = true; Number.extra_leading_zeros_support = true; Number.dec_int_support = Number.Number_default; Number.hex_int_support = Number.Number_unsupported; Number.oct_int_support = Number.Number_unsupported; Number.bin_int_support = Number.Number_unsupported; Number.def_int_support = Number.Number_unsupported; Number.dec_real_support = Number.Number_unsupported; Number.hex_real_support = Number.Number_unsupported; Number.frac_real_support = Number.Number_custom (Number.PrintFracReal ("", "\ \ \ \ ", "\ \ \ \ ")); Number.def_real_support = Number.Number_unsupported; } in begin match c with | Number.ConstInt _ -> fprintf fmt "%a" (Number.print number_format) c (print_ty info) (t_type t) | _ -> Number.print number_format fmt c end | Tif (f, t1, t2) -> print_app print_const (print_term info defs) fmt ("HOL.If", [f; t1; t2]) | Tlet (t1, tb) -> elem' "app" (pair print_const (pair (print_term info defs) (print_abs info (print_term info defs)))) fmt ("HOL.Let", (t1, t_open_bound tb)) | Tcase (t, bl) -> elem' "case" (pair (print_term info defs) (print_list nothing (print_branch info defs))) fmt (t, bl) | Teps fb -> elem' "app" (pair print_const (print_abs info (print_term info defs))) fmt ("Hilbert_Choice.Eps", t_open_bound fb) | Tapp (fs, pl) when is_fs_tuple fs -> elems' "prod" (print_term info defs) fmt pl | Tapp (fs, tl) -> begin match query_syntax info.info_syn fs.ls_name with | Some s -> syntax_arguments_typed s (print_term info defs) (print_ty info) t fmt tl | _ -> print_app (print_ls_real info defs) (print_term info defs) fmt ((fs, (List.map t_type tl, t.t_ty)), tl) end | Tquant (q, fq) -> let vl, _tl, f = t_open_quant fq in print_quant info defs (match q with Tforall -> "HOL.All" | Texists -> "HOL.Ex") fmt (vl, f) | Ttrue -> print_const fmt "HOL.True" | Tfalse -> print_const fmt "HOL.False" | Tbinop (b, f1, f2) -> print_app print_const (print_term info defs) fmt (binop_name b, [f1; f2]) | Tnot f -> print_app print_const (print_term info defs) fmt ("HOL.Not", [f]) and print_quant info defs s fmt (vl, f) = match vl with | [] -> print_term info defs fmt f | v :: vl' -> elem' "app" (pair print_const (print_abs info (print_quant info defs s))) fmt (s, (v, (vl', f))) and print_branch info defs fmt br = let p, t = t_open_branch br in print_list nothing (elem' "pat" (pair (print_pat info) (print_term info defs))) fmt (List.map (fun q -> (q, t)) (split_por p)); Svs.iter forget_var p.pat_vars let rec dest_conj t = match t.t_node with | Tbinop (Tand, f1, f2) -> dest_conj f1 @ dest_conj f2 | _ -> [t] let rec dest_rule vl fl t = match t.t_node with | Tquant (Tforall, fq) -> let vl', _tl, f = t_open_quant fq in dest_rule (vl @ vl') fl f | Tbinop (Timplies, f1, f2) -> dest_rule vl (fl @ dest_conj f1) f2 | _ -> (vl, fl, t) let rec dest_forall vl t = match t.t_node with | Tquant (Tforall, fq) -> let vl', _tl, f = t_open_quant fq in dest_forall (vl @ vl') f | _ -> (vl, t) (** Declarations *) let print_constr info fmt (cs, pjl) = elems "constr" (print_ls info) (elem "carg" (print_option (print_ls info)) (print_ty info)) fmt (cs, List.combine pjl cs.ls_args) let print_tparams = elems' "params" (empty_elem "param" (attrib "name" print_tv)) let print_data_decl info fmt (ts, csl) = elem "datatype" (print_ts info) (pair print_tparams (elems' "constrs" (print_constr info))) fmt (ts, (ts.ts_args, csl)); forget_tvs () let print_data_decls info fmt tl = let tl = List.filter (fun (ts, _) -> not (is_ts_tuple ts || Mid.mem ts.ts_name info.info_syn)) tl in if tl <> [] then begin elems' "datatypes" (print_data_decl info) fmt tl end let print_statement s pr id info fmt f = let vl, prems, concl = dest_rule [] [] f in elem s pr (pair (elems' "prems" (print_term info Sls.empty)) (elems' "concls" (print_term info Sls.empty))) fmt (id, (prems, dest_conj concl)); List.iter forget_var vl; forget_tvs () let print_equivalence_lemma info fmt (ls, ld) = let name = Ident.string_unique iprinter ((id_unique iprinter ls.ls_name) ^ "_def") in print_statement "lemma" (attrib "name" string) name info fmt (ls_defn_axiom ld) let print_fun_eqn s info defs fmt (ls, ld) = let vl, t = dest_forall [] (ls_defn_axiom ld) in elem s (print_altname_path info) (print_term info defs) fmt (ls.ls_name, t); List.iter forget_var vl let print_logic_decl info fmt ((ls, _) as d) = print_fun_eqn "definition" info (Sls.add ls Sls.empty) fmt d; forget_tvs () let print_logic_decl info fmt d = (* During realization the definition of a "builtin" symbol is printed and an equivalence lemma with associated Isabelle function is requested *) if not (Mid.mem (fst d).ls_name info.info_syn) then print_logic_decl info fmt d else if info.realization then print_equivalence_lemma info fmt d let print_recursive_decl info fmt dl = let dl_syn, dl_no_syn = List.partition (fun (ls, _) -> info.realization && (Mid.mem ls.ls_name info.info_syn)) dl in let defs = List.fold_left (fun acc (ls, _) -> Sls.add ls acc) Sls.empty dl_no_syn in if dl_no_syn <> [] then begin elems' "function" (print_fun_eqn "eqn" info defs) fmt dl_no_syn; forget_tvs () end; List.iter (print_equivalence_lemma info fmt) dl_syn let print_ind info defs fmt (pr, f) = let vl, fl, g = dest_rule [] [] f in elem "rule" (print_pr info) (pair (elems' "prems" (print_term info defs)) (print_term info defs)) fmt (pr, (fl, g)); List.iter forget_var vl let print_ind_decl info defs fmt (ps, bl) = elem "pred" (print_ls info) (pair (print_ls_type info) (print_list nothing (print_ind info defs))) fmt (ps, (ps, bl)) let print_coind fmt s = match s with | Ind -> () | Coind -> attrib "coind" string fmt "true" let print_ind_decls info s fmt tl = let tl_syn, tl_no_syn = List.partition (fun (ps, _) -> info.realization && (Mid.mem ps.ls_name info.info_syn)) tl in let defs = List.fold_left (fun acc (ps, _) -> Sls.add ps acc) Sls.empty tl_no_syn in if tl_no_syn <> [] then begin elems "inductive" print_coind (print_ind_decl info defs) fmt (s, tl_no_syn); forget_tvs () end; List.iter (fun (_, rls) -> List.iter (fun (pr, f) -> print_statement "lemma" (print_pr info) pr info fmt f) rls) tl_syn let print_type_decl info fmt ts = if not (Mid.mem ts.ts_name info.info_syn || is_ts_tuple ts) then let def = match ts.ts_def with Alias ty -> Some ty | _ -> None in (elem "typedecl" (print_ts info) (pair print_tparams (print_option (print_ty info))) fmt (ts, (ts.ts_args, def)); forget_tvs ()) let print_param_decl info fmt ls = if not (Mid.mem ls.ls_name info.info_syn) then (elem "param" (print_ls info) (print_ls_type info) fmt (ls, ls); forget_tvs ()) let print_prop_decl info fmt (k, pr, f) = let stt = match k with | Paxiom when info.realization -> "lemma" | Paxiom -> "axiom" | Plemma -> "lemma" | Pgoal -> "lemma" | Pskip -> assert false (* impossible *) in print_statement stt (print_pr info) pr info fmt f let print_decl info fmt d = match d.d_node with | Dtype ts -> print_type_decl info fmt ts | Ddata tl -> print_data_decls info fmt tl | Dparam ls -> print_param_decl info fmt ls | Dlogic [s,_ as ld] when not (Sid.mem s.ls_name d.d_syms) -> print_logic_decl info fmt ld | Dlogic ll -> print_recursive_decl info fmt ll | Dind (s, il) -> print_ind_decls info s fmt il | Dprop (_, pr, _) when not info.realization && Mid.mem pr.pr_name info.info_syn -> () | Dprop pr -> print_prop_decl info fmt pr let print_decls info fmt dl = print_list nothing (print_decl info) fmt dl let make_thname th = String.concat "." (th.Theory.th_path @ [string_of_id th.Theory.th_name]) let print_task printer_args realize fmt task = forget_ids (); (* find theories that are both used and realized from metas *) let realized_theories = Task.on_meta meta_realized_theory (fun mid args -> match args with | [Theory.MAstr s1; Theory.MAstr _] -> let f,id = let l = Strings.rev_split '.' s1 in List.rev (List.tl l), List.hd l in let th = Env.read_theory printer_args.env f id in Mid.add th.Theory.th_name (th, s1) mid | _ -> assert false ) Mid.empty task in (* two cases: task is clone T with [] or task is a real goal *) let rec upd_realized_theories = function | Some { Task.task_decl = { Theory.td_node = Theory.Decl { Decl.d_node = Decl.Dprop (Decl.Pgoal, pr, _) }}} -> string_of_id pr.pr_name, realized_theories | Some { Task.task_decl = { Theory.td_node = Theory.Clone (th,_) }} -> Sid.iter (fun id -> ignore (id_unique iprinter id)) th.Theory.th_local; let id = th.Theory.th_name in String.concat "." (th.Theory.th_path @ [string_of_id id]), Mid.remove id realized_theories | Some { Task.task_decl = { Theory.td_node = Theory.Meta _ }; Task.task_prev = task } -> upd_realized_theories task | _ -> assert false in let thname, realized_theories = upd_realized_theories task in (* make names as stable as possible by first printing all identifiers *) let realized_theories' = Mid.map fst realized_theories in let realized_symbols = Task.used_symbols realized_theories' in let local_decls = Task.local_decls task realized_symbols in let symbol_printers = let printers = Mid.map (fun th -> let pr = fresh_printer () in Sid.iter (fun id -> ignore (id_unique pr id)) th.Theory.th_local; pr) realized_theories' in Mid.map (fun th -> (snd (Mid.find th.Theory.th_name realized_theories), Mid.find th.Theory.th_name printers)) realized_symbols in let info = { info_syn = get_syntax_map task; symbol_printers = symbol_printers; realization = realize; theories = Mid.map make_thname (Task.used_symbols (Task.used_theories task)); } in elem "theory" (attribs "name" string (print_option (attrib "realize" string))) (pair (elems' "realized" (empty_elem "require" (attrib "name" (fun fmt (th, _) -> string fmt (make_thname th))))) (print_decls info)) fmt ((thname, opt_string_of_bool realize), (Mid.values realized_theories, local_decls)) let print_task_full args ?old:_ fmt task = print_task args false fmt task let print_task_real args ?old:_ fmt task = print_task args true fmt task let () = register_printer "isabelle" print_task_full ~desc:"Printer@ for@ the@ Isabelle@ proof@ assistant@ \ (without@ realization@ capabilities)." let () = register_printer "isabelle-realize" print_task_real ~desc:"Printer@ for@ the@ Isabelle@ proof@ assistant@ \ (with@ realization@ capabilities)." why3-0.88.3/src/printer/smtv1.ml0000664000175100017510000002313613225666037017137 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** SMT v1 printer with some extensions *) open Format open Pp open Ident open Ty open Term open Decl open Printer let ident_printer = let bls = ["and";"benchmark";"distinct";"exists";"false";"flet";"forall"; "if then else";"iff";"implies";"ite";"let";"logic";"not";"or"; "sat";"theory";"true";"unknown";"unsat";"xor"; "assumption";"axioms";"definition";"extensions";"formula"; "funs";"extrafuns";"extrasorts";"extrapreds";"language"; "notes";"preds";"sorts";"status";"theory";"Int";"Real";"Bool"; "Array";"U";"select";"store"] in let san = sanitizer char_to_alpha char_to_alnumus in create_ident_printer bls ~sanitizer:san let print_ident fmt id = fprintf fmt "%s" (id_unique ident_printer id) let forget_var v = forget_id ident_printer v.vs_name let print_var fmt {vs_name = id} = let sanitize n = "?" ^ n in let n = id_unique ident_printer ~sanitizer:sanitize id in fprintf fmt "%s" n type info = { info_syn : syntax_map; complex_type : ty Mty.t ref; urg_output : string list ref; } let complex_type = Wty.memoize 3 (fun ty -> let s = Pp.string_of_wnl Pretty.print_ty ty in create_tysymbol (id_fresh s) [] NoDef) let rec print_type info fmt ty = match ty.ty_node with | Tyvar _ -> unsupported "smtv1: you must encode the polymorphism" | Tyapp (ts, l) -> begin match query_syntax info.info_syn ts.ts_name, l with | Some s, _ -> syntax_arguments s (print_type info) fmt l | None, [] -> fprintf fmt "%a" print_ident ts.ts_name | None, _ -> begin match Mty.find_opt ty !(info.complex_type) with | Some ty -> print_type info fmt ty | None -> let ts = complex_type ty in let cty = ty_app ts [] in let us = Pp.sprintf ":extrasorts (%a)@\n@\n" print_ident ts.ts_name in info.complex_type := Mty.add ty cty !(info.complex_type); info.urg_output := us :: !(info.urg_output); print_type info fmt cty end end let print_type info fmt ty = try print_type info fmt ty with Unsupported s -> raise (UnsupportedType (ty,s)) let rec print_term info fmt t = match t.t_node with | Tconst c -> let number_format = { Number.long_int_support = true; Number.extra_leading_zeros_support = false; Number.dec_int_support = Number.Number_default; Number.hex_int_support = Number.Number_unsupported; Number.oct_int_support = Number.Number_unsupported; Number.bin_int_support = Number.Number_unsupported; Number.def_int_support = Number.Number_unsupported; Number.dec_real_support = Number.Number_unsupported; Number.hex_real_support = Number.Number_unsupported; Number.frac_real_support = Number.Number_custom (Number.PrintFracReal ("%s.0", "(* %s.0 %s.0)", "(/ %s.0 %s.0)")); Number.def_real_support = Number.Number_unsupported; } in Number.print number_format fmt c | Tvar v -> print_var fmt v | Tapp (ls, tl) -> begin match query_syntax info.info_syn ls.ls_name with | Some s -> syntax_arguments s (print_term info) fmt tl | None -> begin match tl with (* for cvc3 wich doesn't accept (toto ) *) | [] -> fprintf fmt "@[%a@]" print_ident ls.ls_name | _ -> fprintf fmt "@[(%a@ %a)@]" print_ident ls.ls_name (print_list space (print_term info)) tl end end | Tlet (t1, tb) -> let v, t2 = t_open_bound tb in fprintf fmt "@[(let (%a %a)@ %a)@]" print_var v (print_term info) t1 (print_term info) t2; forget_var v | Tif (f1,t1,t2) -> fprintf fmt "@[(ite %a@ %a@ %a)@]" (print_fmla info) f1 (print_term info) t1 (print_term info) t2 | Tcase _ -> unsupportedTerm t "smtv1 : you must eliminate match" | Teps _ -> unsupportedTerm t "smtv1 : you must eliminate epsilon" | Tquant _ | Tbinop _ | Tnot _ | Ttrue | Tfalse -> raise (TermExpected t) and print_fmla info fmt f = match f.t_node with | Tapp ({ ls_name = id }, []) -> print_ident fmt id | Tapp (ls, tl) -> begin match query_syntax info.info_syn ls.ls_name with | Some s -> syntax_arguments s (print_term info) fmt tl | None -> begin match tl with (* for cvc3 wich doesn't accept (toto ) *) | [] -> fprintf fmt "%a" print_ident ls.ls_name | _ -> fprintf fmt "(%a@ %a)" print_ident ls.ls_name (print_list space (print_term info)) tl end end | Tquant (q, fq) -> let q = match q with Tforall -> "forall" | Texists -> "exists" in let vl, _tl, f = t_open_quant fq in (* TODO trigger dépend des capacités du prover : 2 printers? smtwithtriggers/smtstrict *) let rec forall fmt = function | [] -> print_fmla info fmt f | v::l -> fprintf fmt "@[(%s (%a %a)@ %a)@]" q print_var v (print_type info) v.vs_ty forall l in forall fmt vl; List.iter forget_var vl | Tbinop (Tand, f1, f2) -> fprintf fmt "@[(and@ %a@ %a)@]" (print_fmla info) f1 (print_fmla info) f2 | Tbinop (Tor, f1, f2) -> fprintf fmt "@[(or@ %a@ %a)@]" (print_fmla info) f1 (print_fmla info) f2 | Tbinop (Timplies, f1, f2) -> fprintf fmt "@[(implies@ %a@ %a)@]" (print_fmla info) f1 (print_fmla info) f2 | Tbinop (Tiff, f1, f2) -> fprintf fmt "@[(iff@ %a@ %a)@]" (print_fmla info) f1 (print_fmla info) f2 | Tnot f -> fprintf fmt "@[(not@ %a)@]" (print_fmla info) f | Ttrue -> fprintf fmt "true" | Tfalse -> fprintf fmt "false" | Tif (f1, f2, f3) -> fprintf fmt "@[(if_then_else %a@ %a@ %a)@]" (print_fmla info) f1 (print_fmla info) f2 (print_fmla info) f3 | Tlet (t1, tb) -> let v, f2 = t_open_bound tb in fprintf fmt "@[(let (%a %a)@ %a)@]" print_var v (print_term info) t1 (print_fmla info) f2; forget_var v | Tcase _ -> unsupportedTerm f "smtv1 : you must eliminate match" | Tvar _ | Tconst _ | Teps _ -> raise (FmlaExpected f) (* and _print_expr info fmt = TermTF.t_select (print_term info fmt) (print_fmla info fmt) and _print_triggers info fmt tl = print_list comma (_print_expr info) fmt tl let _print_logic_binder info fmt v = fprintf fmt "%a: %a" print_ident v.vs_name (print_type info) v.vs_ty *) let print_type_decl info fmt ts = if ts.ts_args = [] && not (is_alias_type_def ts.ts_def) then if not (Mid.mem ts.ts_name info.info_syn) then fprintf fmt ":extrasorts (%a)@\n@\n" print_ident ts.ts_name let print_param_decl info fmt ls = match ls.ls_value with | None -> fprintf fmt "@[:extrapreds ((%a %a))@]@\n@\n" print_ident ls.ls_name (print_list space (print_type info)) ls.ls_args | Some value -> fprintf fmt "@[:extrafuns ((%a %a %a))@]@\n@\n" print_ident ls.ls_name (print_list space (print_type info)) ls.ls_args (print_type info) value let print_param_decl info fmt ls = if not (Mid.mem ls.ls_name info.info_syn) then print_param_decl info fmt ls let print_decl info fmt d = match d.d_node with | Dtype ts -> print_type_decl info fmt ts | Ddata _ -> unsupportedDecl d "smtv1 : algebraic types are not supported" | Dparam ls -> print_param_decl info fmt ls | Dlogic _ -> unsupportedDecl d "smtv1 : predicate and function definitions are not supported" | Dind _ -> unsupportedDecl d "smtv1 : inductive definitions are not supported" | Dprop (Paxiom, pr, _) when Mid.mem pr.pr_name info.info_syn -> () | Dprop (Paxiom, pr, f) -> fprintf fmt "@[;; %s@\n:assumption@ %a@]@\n@\n" pr.pr_name.id_string (print_fmla info) f | Dprop (Pgoal, pr, f) -> fprintf fmt "@[:formula@\n"; fprintf fmt "@[;; %a@]@\n" print_ident pr.pr_name; (match pr.pr_name.id_loc with | Some loc -> fprintf fmt " @[;; %a@]@\n" Loc.gen_report_position loc | None -> ()); fprintf fmt " @[(not@ %a)@]@\n" (print_fmla info) f | Dprop ((Plemma|Pskip), _, _) -> assert false let print_decls = let print_decl (sm,ct) fmt d = let info = {info_syn = sm; complex_type = ref ct; urg_output = ref []} in try print_decl info fmt d; (sm, !(info.complex_type)), !(info.urg_output) with Unsupported s -> raise (UnsupportedDecl (d,s)) in let print_decl = Printer.sprint_decl print_decl in let print_decl task acc = print_decl task.Task.task_decl acc in Discriminate.on_syntax_map (fun sm -> Trans.fold print_decl ((sm,Mty.empty),[])) let print_task args ?old:_ fmt task = (* In trans-based p-printing [forget_all] is a no-no *) (* forget_all ident_printer; *) fprintf fmt "(benchmark why3@\n"; fprintf fmt " :status unknown@\n"; print_prelude fmt args.prelude; print_th_prelude task fmt args.th_prelude; let rec print = function | x :: r -> print r; Pp.string fmt x | [] -> () in print (snd (Trans.apply print_decls task)); fprintf fmt ")@." let () = register_printer "smtv1" print_task ~desc:"Printer@ for@ the@ SMTlib@ version@ 1@ format." why3-0.88.3/src/printer/smtv2.ml0000664000175100017510000005131613225666037017141 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** SMT v2 printer with some extensions *) open Format open Pp open Ident open Ty open Term open Decl open Printer open Cntexmp_printer let debug = Debug.register_info_flag "smtv2_printer" ~desc:"Print@ debugging@ messages@ about@ printing@ \ the@ input@ of@ smtv2." (** SMTLIB tokens taken from CVC4: src/parser/smt2/{Smt2.g,smt2.cpp} *) let ident_printer () = let bls = [(* Base SMT-LIB commands, see page 43 *) "assert"; "check-sat"; "check-sat-assuming"; "declare-const"; "declare-datatype"; "declare-datatypes"; "declare-fun"; "declare-sort"; "define-fun"; "define-fun-rec"; "define-funs-rec"; "define-sort"; "echo"; "exit"; "get-assignment"; "get-assertions"; "get-info"; "get-model"; "get-option"; "get-proof"; "get-unsat-assumptions"; "get-unsat-core"; "get-value"; "pop"; "push"; "reset"; "reset-assertions"; "set-info"; "set-logic"; "set-option"; (* Base SMT-LIB tokens, see page 22*) "BINARY"; "DECIMAL"; "HEXADECIMAL"; "NUMERAL"; "STRING"; "_"; "!"; "as"; "let"; "exists"; "forall"; "match"; "par"; (* extended commands *) "assert-rewrite"; "assert-reduction"; "assert-propagation"; "declare-sorts"; "declare-funs"; "declare-preds"; "define"; "simplify"; (* operators, including theory symbols *) "ite"; "and"; "distinct"; "is_int"; "not"; "or"; "select"; "store"; "to_int"; "to_real"; "xor"; "div"; "mod"; "concat"; "bvnot"; "bvand"; "bvor"; "bvneg"; "bvadd"; "bvmul"; "bvudiv"; "bvurem"; "bvshl"; "bvlshr"; "bvult"; "bvnand"; "bvnor"; "bvxor"; "bvcomp"; "bvsub"; "bvsdiv"; "bvsrem"; "bvsmod"; "bvashr"; "bvule"; "bvugt"; "bvuge"; "bvslt"; "bvsle"; "bvsgt"; "bvsge"; "rotate_left"; "rotate_right"; "bvredor"; "bvredand"; "sin"; "cos"; "tan"; "asin"; "acos"; "atan"; "pi"; (* the new floating point theory - updated to the 2014-05-27 standard *) "FloatingPoint"; "fp"; "Float16"; "Float32"; "Float64"; "Float128"; "RoundingMode"; "roundNearestTiesToEven"; "RNE"; "roundNearestTiesToAway"; "RNA"; "roundTowardPositive"; "RTP"; "roundTowardNegative"; "RTN"; "roundTowardZero"; "RTZ"; "NaN"; "+oo"; "-oo"; "+zero"; "-zero"; "fp.abs"; "fp.neg"; "fp.add"; "fp.sub"; "fp.mul"; "fp.div"; "fp.fma"; "fp.sqrt"; "fp.rem"; "fp.roundToIntegral"; "fp.min"; "fp.max"; "fp.leq"; "fp.lt"; "fp.geq"; "fp.gt"; "fp.eq"; "fp.isNormal"; "fp.isSubnormal"; "fp.isZero"; "fp.isInfinite"; "fp.isNaN"; "fp.isNegative"; "fp.isPositive"; "to_fp"; "to_fp_unsigned"; "fp.to_ubv"; "fp.to_sbv"; "fp.to_real"; (* the new proposed string theory *) "String"; "str.++"; "str.len"; "str.substr"; "str.contains"; "str.at"; "str.indexof"; "str.prefixof"; "str.suffixof"; "int.to.str"; "str.to.int"; "u16.to.str"; "str.to.u16"; "u32.to.str"; "str.to.u32"; "str.in.re"; "str.to.re"; "re.++"; "re.union"; "re.inter"; "re.*"; "re.+"; "re.opt"; "re.range"; "re.loop"; (* the new proposed set theory *) "union"; "intersection"; "setminus"; "subset"; "member"; "singleton"; "insert"; (* built-in sorts *) "Bool"; "Int"; "Real"; "BitVec"; "Array"; (* Other stuff that Why3 seems to need *) "unsat"; "sat"; "true"; "false"; "const"; "abs"; "BitVec"; "extract"; "bv2nat"; "nat2bv"; (* From Z3 *) "map"; "bv"; "default"; "difference"; ] in let san = sanitizer char_to_alpha char_to_alnumus in create_ident_printer bls ~sanitizer:san type info = { info_syn : syntax_map; info_converters : converter_map; info_rliteral : syntax_map; mutable info_model : S.t; mutable info_in_goal : bool; info_vc_term : vc_term_info; info_printer : ident_printer; } let debug_print_term message t = let form = Debug.get_debug_formatter () in begin Debug.dprintf debug message; if Debug.test_flag debug then Pretty.print_term form t; Debug.dprintf debug "@."; end let print_ident info fmt id = fprintf fmt "%s" (id_unique info.info_printer id) (** type *) let rec print_type info fmt ty = match ty.ty_node with | Tyvar _ -> unsupported "smt : you must encode the polymorphism" | Tyapp (ts, l) -> begin match query_syntax info.info_syn ts.ts_name, l with | Some s, _ -> syntax_arguments s (print_type info) fmt l | None, [] -> fprintf fmt "%a" (print_ident info) ts.ts_name | None, _ -> fprintf fmt "(%a %a)" (print_ident info) ts.ts_name (print_list space (print_type info)) l end let print_type info fmt ty = try print_type info fmt ty with Unsupported s -> raise (UnsupportedType (ty,s)) let print_type_value info fmt = function | None -> fprintf fmt "Bool" | Some ty -> print_type info fmt ty (** var *) let forget_var info v = forget_id info.info_printer v.vs_name let print_var info fmt {vs_name = id} = let n = id_unique info.info_printer id in fprintf fmt "%s" n let print_typed_var info fmt vs = fprintf fmt "(%a %a)" (print_var info) vs (print_type info) vs.vs_ty let print_var_list info fmt vsl = print_list space (print_typed_var info) fmt vsl let model_projected_label = Ident.create_label "model_projected" let collect_model_ls info ls = if ls.ls_args = [] && (Slab.mem model_label ls.ls_name.id_label || Slab.mem model_projected_label ls.ls_name.id_label) then let t = t_app ls [] ls.ls_value in info.info_model <- add_model_element (t_label ?loc:ls.ls_name.id_loc ls.ls_name.id_label t) info.info_model let number_format = { Number.long_int_support = true; Number.extra_leading_zeros_support = false; Number.dec_int_support = Number.Number_default; Number.hex_int_support = Number.Number_unsupported; Number.oct_int_support = Number.Number_unsupported; Number.bin_int_support = Number.Number_unsupported; Number.def_int_support = Number.Number_unsupported; Number.dec_real_support = Number.Number_unsupported; Number.hex_real_support = Number.Number_unsupported; Number.frac_real_support = Number.Number_custom (Number.PrintFracReal ("%s.0", "(* %s.0 %s.0)", "(/ %s.0 %s.0)")); Number.def_real_support = Number.Number_unsupported; } (** expr *) let rec print_term info fmt t = debug_print_term "Printing term: " t; if Slab.mem model_label t.t_label then info.info_model <- add_model_element t info.info_model; check_enter_vc_term t info.info_in_goal info.info_vc_term; let () = match t.t_node with | Tconst c -> let ts = match t.t_ty with | Some { ty_node = Tyapp (ts, []) } -> ts | _ -> assert false (* impossible *) in (* look for syntax literal ts in driver *) begin match query_syntax info.info_rliteral ts.ts_name, c with | Some st, Number.ConstInt c -> syntax_range_literal st fmt c | Some st, Number.ConstReal c -> let fp = match ts.ts_def with | Float fp -> fp | _ -> assert false in syntax_float_literal st fp fmt c | None, _ -> Number.print number_format fmt c (* TODO/FIXME: we must assert here that the type is either ty_int or ty_real, otherwise it makes no sense to print the literal. Do we ensure that preserved literal types are exactly those that have a dedicated syntax? *) end | Tvar v -> print_var info fmt v | Tapp (ls, tl) -> (* let's check if a converter applies *) begin try match tl with | [ { t_node = Tconst _} ] -> begin match query_converter info.info_converters ls with | None -> raise Exit | Some s -> syntax_arguments s (print_term info) fmt tl end | _ -> raise Exit with Exit -> (* non converter applies, then ... *) match query_syntax info.info_syn ls.ls_name with | Some s -> syntax_arguments_typed s (print_term info) (print_type info) t fmt tl | None -> begin match tl with (* for cvc3 wich doesn't accept (toto ) *) | [] -> let vc_term_info = info.info_vc_term in if vc_term_info.vc_inside then begin match vc_term_info.vc_loc with | None -> () | Some loc -> let labels = match vc_term_info.vc_func_name with | None -> ls.ls_name.id_label | Some _ -> model_trace_for_postcondition ~labels:ls.ls_name.id_label info.info_vc_term in let _t_check_pos = t_label ~loc labels t in (* TODO: temporarily disable collecting variables inside the term triggering VC *) (*info.info_model <- add_model_element t_check_pos info.info_model;*) () end; fprintf fmt "@[%a@]" (print_ident info) ls.ls_name | _ -> fprintf fmt "@[(%a@ %a)@]" (print_ident info) ls.ls_name (print_list space (print_term info)) tl end end | Tlet (t1, tb) -> let v, t2 = t_open_bound tb in fprintf fmt "@[(let ((%a %a))@ %a)@]" (print_var info) v (print_term info) t1 (print_term info) t2; forget_var info v | Tif (f1,t1,t2) -> fprintf fmt "@[(ite %a@ %a@ %a)@]" (print_fmla info) f1 (print_term info) t1 (print_term info) t2 | Tcase(t, bl) -> let ty = t_type t in begin match ty.ty_node with | Tyapp (ts,_) when ts_equal ts ts_bool -> print_boolean_branches info t print_term fmt bl | _ -> match t.t_node with | Tvar v -> print_branches info v print_term fmt bl | _ -> let subject = create_vsymbol (id_fresh "subject") (t_type t) in fprintf fmt "@[(let ((%a @[%a@]))@ %a)@]" (print_var info) subject (print_term info) t (print_branches info subject print_term) bl; forget_var info subject end | Teps _ -> unsupportedTerm t "smtv2: you must eliminate epsilon" | Tquant _ | Tbinop _ | Tnot _ | Ttrue | Tfalse -> raise (TermExpected t) in check_exit_vc_term t info.info_in_goal info.info_vc_term; and print_fmla info fmt f = debug_print_term "Printing formula: " f; if Slab.mem model_label f.t_label then info.info_model <- add_model_element f info.info_model; check_enter_vc_term f info.info_in_goal info.info_vc_term; let () = match f.t_node with | Tapp ({ ls_name = id }, []) -> print_ident info fmt id | Tapp (ls, tl) -> begin match query_syntax info.info_syn ls.ls_name with | Some s -> syntax_arguments_typed s (print_term info) (print_type info) f fmt tl | None -> begin match tl with (* for cvc3 wich doesn't accept (toto ) *) | [] -> print_ident info fmt ls.ls_name | _ -> fprintf fmt "(%a@ %a)" (print_ident info) ls.ls_name (print_list space (print_term info)) tl end end | Tquant (q, fq) -> let q = match q with Tforall -> "forall" | Texists -> "exists" in let vl, tl, f = t_open_quant fq in (* TODO trigger dépend des capacités du prover : 2 printers? smtwithtriggers/smtstrict *) if tl = [] then fprintf fmt "@[(%s@ (%a)@ %a)@]" q (print_var_list info) vl (print_fmla info) f else fprintf fmt "@[(%s@ (%a)@ (! %a %a))@]" q (print_var_list info) vl (print_fmla info) f (print_triggers info) tl; List.iter (forget_var info) vl | Tbinop (Tand, f1, f2) -> fprintf fmt "@[(and@ %a@ %a)@]" (print_fmla info) f1 (print_fmla info) f2 | Tbinop (Tor, f1, f2) -> fprintf fmt "@[(or@ %a@ %a)@]" (print_fmla info) f1 (print_fmla info) f2 | Tbinop (Timplies, f1, f2) -> fprintf fmt "@[(=>@ %a@ %a)@]" (print_fmla info) f1 (print_fmla info) f2 | Tbinop (Tiff, f1, f2) -> fprintf fmt "@[(=@ %a@ %a)@]" (print_fmla info) f1 (print_fmla info) f2 | Tnot f -> fprintf fmt "@[(not@ %a)@]" (print_fmla info) f | Ttrue -> fprintf fmt "true" | Tfalse -> fprintf fmt "false" | Tif (f1, f2, f3) -> fprintf fmt "@[(ite %a@ %a@ %a)@]" (print_fmla info) f1 (print_fmla info) f2 (print_fmla info) f3 | Tlet (t1, tb) -> let v, f2 = t_open_bound tb in fprintf fmt "@[(let ((%a %a))@ %a)@]" (print_var info) v (print_term info) t1 (print_fmla info) f2; forget_var info v | Tcase(t, bl) -> let ty = t_type t in begin match ty.ty_node with | Tyapp (ts,_) when ts_equal ts ts_bool -> print_boolean_branches info t print_fmla fmt bl | _ -> match t.t_node with | Tvar v -> print_branches info v print_fmla fmt bl | _ -> let subject = create_vsymbol (id_fresh "subject") (t_type t) in fprintf fmt "@[(let ((%a @[%a@]))@ %a)@]" (print_var info) subject (print_term info) t (print_branches info subject print_fmla) bl; forget_var info subject end | Tvar _ | Tconst _ | Teps _ -> raise (FmlaExpected f) in check_exit_vc_term f info.info_in_goal info.info_vc_term and print_boolean_branches info subject pr fmt bl = let error () = unsupportedTerm subject "smtv2: bad pattern-matching on Boolean (compile_match missing?)" in match bl with | [br1 ; br2] -> let (p1,t1) = t_open_branch br1 in let (_p2,t2) = t_open_branch br2 in begin match p1.pat_node with | Papp(cs,_) -> let csname = if ls_equal cs fs_bool_true then "true" else "false" in fprintf fmt "@[(ite (= %a %s) %a %a)@]" (print_term info) subject csname (pr info) t1 (pr info) t2 | _ -> error () end | _ -> error () and print_branches info subject pr fmt bl = match bl with | [] -> assert false | br::bl -> let (p,t) = t_open_branch br in let error () = unsupportedPattern p "smtv2: you must compile nested pattern-matching" in match p.pat_node with | Pwild -> pr info fmt t | Papp (cs,args) -> let args = List.map (function | {pat_node = Pvar v} -> v | _ -> error ()) args in if bl = [] then print_branch info subject pr fmt (cs,args,t) else fprintf fmt "@[(ite (is-%a %a) %a %a)@]" (print_ident info) cs.ls_name (print_var info) subject (print_branch info subject pr) (cs,args,t) (print_branches info subject pr) bl | _ -> error () and print_branch info subject pr fmt (cs,vars,t) = if vars = [] then pr info fmt t else let tvs = t_freevars Mvs.empty t in if List.for_all (fun v -> not (Mvs.mem v tvs)) vars then pr info fmt t else let i = ref 0 in let pr_proj fmt v = incr i; if Mvs.mem v tvs then fprintf fmt "(%a (%a_proj_%d %a))" (print_var info) v (print_ident info) cs.ls_name !i (print_var info) subject in fprintf fmt "@[(let (%a) %a)@]" (print_list space pr_proj) vars (pr info) t and print_expr info fmt = TermTF.t_select (print_term info fmt) (print_fmla info fmt) and print_trigger info fmt e = fprintf fmt "%a" (print_expr info) e and print_triggers info fmt = function | [] -> () | a::l -> fprintf fmt ":pattern (%a) %a" (print_list space (print_trigger info)) a (print_triggers info) l let print_type_decl info fmt ts = if is_alias_type_def ts.ts_def then () else if Mid.mem ts.ts_name info.info_syn then () else fprintf fmt "(declare-sort %a %i)@\n@\n" (print_ident info) ts.ts_name (List.length ts.ts_args) let print_param_decl info fmt ls = if Mid.mem ls.ls_name info.info_syn then () else fprintf fmt "@[(declare-fun %a (%a) %a)@]@\n@\n" (print_ident info) ls.ls_name (print_list space (print_type info)) ls.ls_args (print_type_value info) ls.ls_value let print_logic_decl info fmt (ls,def) = if Mid.mem ls.ls_name info.info_syn then () else begin collect_model_ls info ls; let vsl,expr = Decl.open_ls_defn def in fprintf fmt "@[(define-fun %a (%a) %a %a)@]@\n@\n" (print_ident info) ls.ls_name (print_var_list info) vsl (print_type_value info) ls.ls_value (print_expr info) expr; List.iter (forget_var info) vsl end let print_info_model cntexample fmt info = (* Prints the content of info.info_model *) let info_model = info.info_model in if not (S.is_empty info_model) && cntexample then begin fprintf fmt "@[(get-model "; let model_map = S.fold (fun f acc -> fprintf str_formatter "%a" (print_fmla info) f; let s = flush_str_formatter () in Stdlib.Mstr.add s f acc) info_model Stdlib.Mstr.empty in fprintf fmt ")@]@\n"; (* Printing model has modification of info.info_model as undesirable side-effect. Revert it back. *) info.info_model <- info_model; model_map end else Stdlib.Mstr.empty let print_prop_decl vc_loc cntexample args info fmt k pr f = match k with | Paxiom -> fprintf fmt "@[;; %s@\n(assert@ %a)@]@\n@\n" pr.pr_name.id_string (* FIXME? collisions *) (print_fmla info) f | Pgoal -> fprintf fmt "@[(assert@\n"; fprintf fmt "@[;; %a@]@\n" (print_ident info) pr.pr_name; (match pr.pr_name.id_loc with | None -> () | Some loc -> fprintf fmt " @[;; %a@]@\n" Loc.gen_report_position loc); info.info_in_goal <- true; fprintf fmt " @[(not@ %a))@]@\n" (print_fmla info) f; info.info_in_goal <- false; (*if cntexample then fprintf fmt "@[(push)@]@\n"; (* z3 specific stuff *)*) fprintf fmt "@[(check-sat)@]@\n"; let model_list = print_info_model cntexample fmt info in args.printer_mapping <- { lsymbol_m = args.printer_mapping.lsymbol_m; vc_term_loc = vc_loc; queried_terms = model_list; } | Plemma| Pskip -> assert false let print_constructor_decl info fmt (ls,args) = match args with | [] -> fprintf fmt "(%a)" (print_ident info) ls.ls_name | _ -> fprintf fmt "@[(%a@ " (print_ident info) ls.ls_name; let _ = List.fold_left2 (fun i ty pr -> begin match pr with | Some pr -> fprintf fmt "(%a" (print_ident info) pr.ls_name | None -> fprintf fmt "(%a_proj_%d" (print_ident info) ls.ls_name i end; fprintf fmt " %a)" (print_type info) ty; succ i) 1 ls.ls_args args in fprintf fmt ")@]" let print_data_decl info fmt (ts,cl) = fprintf fmt "@[(%a@ %a)@]" (print_ident info) ts.ts_name (print_list space (print_constructor_decl info)) cl let print_decl vc_loc cntexample args info fmt d = match d.d_node with | Dtype ts -> print_type_decl info fmt ts | Ddata [(ts,_)] when query_syntax info.info_syn ts.ts_name <> None -> () | Ddata dl -> fprintf fmt "@[(declare-datatypes ()@ (%a))@]@\n" (print_list space (print_data_decl info)) dl | Dparam ls -> collect_model_ls info ls; print_param_decl info fmt ls | Dlogic dl -> print_list nothing (print_logic_decl info) fmt dl | Dind _ -> unsupportedDecl d "smtv2: inductive definitions are not supported" | Dprop (k,pr,f) -> if Mid.mem pr.pr_name info.info_syn then () else print_prop_decl vc_loc cntexample args info fmt k pr f let set_produce_models fmt cntexample = if cntexample then fprintf fmt "(set-option :produce-models true)@\n" let print_task args ?old:_ fmt task = let cntexample = Prepare_for_counterexmp.get_counterexmp task in let vc_loc = Intro_vc_vars_counterexmp.get_location_of_vc task in let vc_info = {vc_inside = false; vc_loc = None; vc_func_name = None} in let info = { info_syn = Discriminate.get_syntax_map task; info_converters = Printer.get_converter_map task; info_rliteral = Printer.get_rliteral_map task; info_model = S.empty; info_in_goal = false; info_vc_term = vc_info; info_printer = ident_printer () } in print_prelude fmt args.prelude; set_produce_models fmt cntexample; print_th_prelude task fmt args.th_prelude; let rec print_decls = function | Some t -> print_decls t.Task.task_prev; begin match t.Task.task_decl.Theory.td_node with | Theory.Decl d -> begin try print_decl vc_loc cntexample args info fmt d with Unsupported s -> raise (UnsupportedDecl (d,s)) end | _ -> () end | None -> () in print_decls task; pp_print_flush fmt () let () = register_printer "smtv2" print_task ~desc:"Printer@ for@ the@ SMTlib@ version@ 2@ format." why3-0.88.3/src/printer/cvc3.ml0000664000175100017510000002527613225666037016732 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** SMT v1 printer with some extensions *) open Format open Pp open Ident open Ty open Term open Decl open Printer let ident_printer = let bls = (*["and";" benchmark";" distinct";"exists";"false";"flet";"forall"; "if then else";"iff";"implies";"ite";"let";"logic";"not";"or"; "sat";"theory";"true";"unknown";"unsat";"xor"; "assumption";"axioms";"definition";"extensions";"formula"; "funs";"extrafuns";"extrasorts";"extrapreds";"language"; "notes";"preds";"sorts";"status";"theory";"Int";"Real";"Bool"; "Array";"U";"select";"store"]*) (* smtlib2 V2 p71 *) [(* General: *) "!";"_"; "as"; "DECIMAL"; "exists"; "forall"; "let"; "NUMERAL"; "par"; "STRING"; (* Command names: *) "assert";"check-sat"; "declare-sort";"declare-fun";"define-sort"; "define-fun";"exit";"get-assertions";"get-assignment"; "get-info"; "get-option"; "get-proof"; "get-unsat-core"; "get-value"; "pop"; "push"; "set-logic"; "set-info"; "set-option"; (* for security *) "BOOLEAN";"unsat";"sat";"TRUE";"FALSE"; "TRUE";"CHECK";"QUERY";"ASSERT";"TYPE";"SUBTYPE"] in let san = sanitizer char_to_alpha char_to_alnumus in create_ident_printer bls ~sanitizer:san let print_ident fmt id = fprintf fmt "%s" (id_unique ident_printer id) type info = { info_syn : syntax_map; complex_type : ty Mty.t ref; urg_output : string list ref; } (** type *) let complex_type = Wty.memoize 3 (fun ty -> let s = Pp.string_of_wnl Pretty.print_ty ty in create_tysymbol (id_fresh s) [] NoDef) let rec print_type info fmt ty = match ty.ty_node with | Tyvar _ -> unsupported "cvc3: you must encode the polymorphism" | Tyapp (ts, l) -> begin match query_syntax info.info_syn ts.ts_name, l with | Some s, _ -> syntax_arguments s (print_type info) fmt l | None, [] -> fprintf fmt "%a" print_ident ts.ts_name | None, _ -> begin match Mty.find_opt ty !(info.complex_type) with | Some ty -> print_type info fmt ty | None -> let ts = complex_type ty in let cty = ty_app ts [] in let us = Pp.sprintf "%a: TYPE;@\n@\n" print_ident ts.ts_name in info.complex_type := Mty.add ty cty !(info.complex_type); info.urg_output := us :: !(info.urg_output); print_type info fmt cty end end let print_type info fmt ty = try print_type info fmt ty with Unsupported s -> raise (UnsupportedType (ty,s)) let print_type_value info fmt = function | None -> fprintf fmt "BOOLEAN" | Some ty -> print_type info fmt ty (** var *) let forget_var v = forget_id ident_printer v.vs_name let print_var fmt {vs_name = id} = let n = id_unique ident_printer id in fprintf fmt "%s" n let print_typed_var info fmt vs = fprintf fmt "%a : %a" print_var vs (print_type info) vs.vs_ty let print_var_list info fmt vsl = print_list comma (print_typed_var info) fmt vsl (** expr *) let rec print_term info fmt t = match t.t_node with | Tconst c -> let number_format = { Number.long_int_support = true; Number.extra_leading_zeros_support = true; Number.dec_int_support = Number.Number_default; Number.hex_int_support = Number.Number_unsupported; Number.oct_int_support = Number.Number_unsupported; Number.bin_int_support = Number.Number_unsupported; Number.def_int_support = Number.Number_unsupported; Number.dec_real_support = Number.Number_unsupported; Number.hex_real_support = Number.Number_unsupported; Number.frac_real_support = Number.Number_custom (Number.PrintFracReal ("%s", "(%s * %s)", "(%s / %s)")); Number.def_real_support = Number.Number_unsupported; } in Number.print number_format fmt c | Tvar v -> print_var fmt v | Tapp (ls, tl) -> begin match query_syntax info.info_syn ls.ls_name with | Some s -> syntax_arguments_typed s (print_term info) (print_type info) t fmt tl | None -> begin match tl with (* for cvc3 wich doesn't accept (toto ) *) | [] -> fprintf fmt "%a" print_ident ls.ls_name | _ -> fprintf fmt "@,%a(%a)" print_ident ls.ls_name (print_list comma (print_term info)) tl end end | Tlet (t1, tb) -> let v, t2 = t_open_bound tb in fprintf fmt "@[(LET %a =@ %a IN@ %a)@]" print_var v (print_term info) t1 (print_term info) t2; forget_var v | Tif (f1,t1,t2) -> fprintf fmt "@[(IF %a@ THEN %a@ ELSE %a ENDIF)@]" (print_fmla info) f1 (print_term info) t1 (print_term info) t2 | Tcase _ -> unsupportedTerm t "cvc3 : you must eliminate match" | Teps _ -> unsupportedTerm t "cvc3 : you must eliminate epsilon" | Tquant _ | Tbinop _ | Tnot _ | Ttrue | Tfalse -> raise (TermExpected t) and print_fmla info fmt f = match f.t_node with | Tapp ({ ls_name = id }, []) -> print_ident fmt id | Tapp (ls, tl) -> begin match query_syntax info.info_syn ls.ls_name with | Some s -> syntax_arguments_typed s (print_term info) (print_type info) f fmt tl | None -> begin match tl with | [] -> fprintf fmt "%a" print_ident ls.ls_name | _ -> fprintf fmt "(%a(%a))" print_ident ls.ls_name (print_list comma (print_term info)) tl end end | Tquant (q, fq) -> let q = match q with Tforall -> "FORALL" | Texists -> "EXISTS" in let vl, tl, f = t_open_quant fq in (* TODO trigger dépend des capacités du prover : 2 printers? smtwithtriggers/smtstrict *) if tl = [] then fprintf fmt "@[(%s@ (%a):@ %a)@]" q (print_var_list info) vl (print_fmla info) f else fprintf fmt "@[(%s@ (%a):%a@ %a)@]" q (print_var_list info) vl (print_triggers info) tl (print_fmla info) f; List.iter forget_var vl | Tbinop (Tand, f1, f2) -> fprintf fmt "@[(%a@ AND %a)@]" (print_fmla info) f1 (print_fmla info) f2 | Tbinop (Tor, f1, f2) -> fprintf fmt "@[(%a@ OR %a)@]" (print_fmla info) f1 (print_fmla info) f2 | Tbinop (Timplies, f1, f2) -> fprintf fmt "@[(%a@ => %a)@]" (print_fmla info) f1 (print_fmla info) f2 | Tbinop (Tiff, f1, f2) -> fprintf fmt "@[(%a@ <=> %a)@]" (print_fmla info) f1 (print_fmla info) f2 | Tnot f -> fprintf fmt "@[(NOT@ %a)@]" (print_fmla info) f | Ttrue -> fprintf fmt "TRUE" | Tfalse -> fprintf fmt "FALSE" | Tif (f1, f2, f3) -> fprintf fmt "@[(IF %a@ THEN %a@ ELSE %a ENDIF)@]" (print_fmla info) f1 (print_fmla info) f2 (print_fmla info) f3 | Tlet (t1, tb) -> let v, f2 = t_open_bound tb in fprintf fmt "@[(LET %a =@ %a IN@ %a)@]" print_var v (print_term info) t1 (print_fmla info) f2; forget_var v | Tcase _ -> unsupportedTerm f "cvc3 : you must eliminate match" | Tvar _ | Tconst _ | Teps _ -> raise (FmlaExpected f) and print_expr info fmt = TermTF.t_select (print_term info fmt) (print_fmla info fmt) and print_triggers info fmt = function | [] -> () | a::l -> fprintf fmt "PATTERN (%a):@ %a" (print_list comma (print_expr info)) a (print_triggers info) l let print_type_decl info fmt ts = if ts.ts_args = [] && not (is_alias_type_def ts.ts_def) then if not (Mid.mem ts.ts_name info.info_syn) then fprintf fmt "%a : TYPE;@\n@\n" print_ident ts.ts_name let print_lsargs info fmt = function | [] -> () | l -> fprintf fmt "(%a) -> " (print_list comma (print_type info)) l let print_param_decl info fmt ls = fprintf fmt "@[%a: %a%a;@]@\n@\n" print_ident ls.ls_name (print_lsargs info) ls.ls_args (print_type_value info) ls.ls_value let print_param_decl info fmt ls = if not (Mid.mem ls.ls_name info.info_syn) then print_param_decl info fmt ls let print_logic_decl info fmt (ls,def) = let vsl,expr = Decl.open_ls_defn def in fprintf fmt "@[%a: %a%a = LAMBDA (%a): %a;@]@\n@\n" print_ident ls.ls_name (print_lsargs info) ls.ls_args (print_type_value info) ls.ls_value (print_var_list info) vsl (print_expr info) expr; List.iter forget_var vsl let print_logic_decl info fmt d = if not (Mid.mem (fst d).ls_name info.info_syn) then print_logic_decl info fmt d let print_decl info fmt d = match d.d_node with | Dtype ts -> print_type_decl info fmt ts | Ddata _ -> unsupportedDecl d "cvc3 : algebraic type are not supported" | Dparam ls -> print_param_decl info fmt ls | Dlogic dl -> print_list nothing (print_logic_decl info) fmt dl | Dind _ -> unsupportedDecl d "cvc3 : inductive definition are not supported" | Dprop (Paxiom, pr, _) when Mid.mem pr.pr_name info.info_syn -> () | Dprop (Paxiom, pr, f) -> fprintf fmt "@[%% %s@\nASSERT@ %a;@]@\n@\n" pr.pr_name.id_string (print_fmla info) f | Dprop (Pgoal, pr, f) -> fprintf fmt "@[QUERY@\n"; fprintf fmt "@[%% %a@]@\n" print_ident pr.pr_name; (match pr.pr_name.id_loc with | Some loc -> fprintf fmt " @[%% %a@]@\n" Loc.gen_report_position loc | None -> ()); fprintf fmt " @[%a;@]@]@\n" (print_fmla info) f | Dprop ((Plemma|Pskip), _, _) -> assert false let print_decls = let print_decl (sm,ct) fmt d = let info = {info_syn = sm; complex_type = ref ct; urg_output = ref []} in try print_decl info fmt d; (sm, !(info.complex_type)), !(info.urg_output) with Unsupported s -> raise (UnsupportedDecl (d,s)) in let print_decl = Printer.sprint_decl print_decl in let print_decl task acc = print_decl task.Task.task_decl acc in Discriminate.on_syntax_map (fun sm -> Trans.fold print_decl ((sm,Mty.empty),[])) let print_task args ?old:_ fmt task = (* In trans-based p-printing [forget_all] is a no-no *) (* forget_all ident_printer; *) print_prelude fmt args.prelude; print_th_prelude task fmt args.th_prelude; let rec print = function | x :: r -> print r; Pp.string fmt x | [] -> () in print (snd (Trans.apply print_decls task)); pp_print_flush fmt () let () = register_printer "cvc3" print_task ~desc:"Printer@ for@ the@ CVC3@ theorem@ prover." why3-0.88.3/src/printer/coq.ml0000664000175100017510000011033313225666037016643 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** Coq printer *) open Format open Pp open Ident open Ty open Term open Decl open Printer let black_list = [ "at"; "cofix"; "exists2"; "fix"; "IF"; "left"; "mod"; "Prop"; "return"; "right"; "Set"; "Type"; "using"; "where"; ] (* wrong: ' not allowed as first character in Coq identifiers let char_to_alpha c = match c with | '\'' -> String.make 1 c | _ -> Ident.char_to_alpha c *) let char_to_alnumus c = match c with | '\'' -> String.make 1 c | _ -> Ident.char_to_alnumus c let fresh_printer () = let isanitize = sanitizer char_to_alpha char_to_alnumus in create_ident_printer black_list ~sanitizer:isanitize let iprinter = fresh_printer () let forget_all () = forget_all iprinter let tv_set = ref Sid.empty (* info *) type info = { info_syn : syntax_map; symbol_printers : (string * ident_printer) Mid.t; realization : bool; ssreflect: bool; } (* type variables *) let print_tv info ~whytypes fmt tv = let n = id_unique iprinter tv.tv_name in fprintf fmt "%s" n; if whytypes && not info.ssreflect then fprintf fmt " %s_WT" n let print_tv_binder info ~whytypes ~implicit fmt tv = tv_set := Sid.add tv.tv_name !tv_set; let n = id_unique iprinter tv.tv_name in if info.ssreflect then fprintf fmt "{%s: why3Type}" n else begin if implicit then fprintf fmt "{%s:Type}" n else fprintf fmt "(%s:Type)" n; if whytypes then fprintf fmt " {%s_WT:WhyType %s}" n n end let print_tv_binders info ~whytypes ~implicit fmt stv = Stv.iter (fprintf fmt "@ %a" (print_tv_binder info ~whytypes ~implicit)) stv let print_tv_binders_list info ~whytypes ~implicit fmt ltv = List.iter (fprintf fmt "@ %a" (print_tv_binder info ~whytypes ~implicit)) ltv let print_params info ~whytypes fmt stv = if Stv.is_empty stv then () else fprintf fmt "forall%a,@ " (print_tv_binders info ~whytypes ~implicit:true) stv let print_params_list info ~whytypes fmt ltv = match ltv with | [] -> () | _ -> fprintf fmt "forall%a,@ " (print_tv_binders_list info ~whytypes ~implicit:false) ltv let forget_tvs () = Sid.iter (forget_id iprinter) !tv_set; tv_set := Sid.empty (* logic variables *) let print_vs fmt vs = let n = id_unique iprinter vs.vs_name in fprintf fmt "%s" n let forget_var vs = forget_id iprinter vs.vs_name let print_ts fmt ts = fprintf fmt "%s" (id_unique iprinter ts.ts_name) let print_ls fmt ls = fprintf fmt "%s" (id_unique iprinter ls.ls_name) let print_pr fmt pr = fprintf fmt "%s" (id_unique iprinter pr.pr_name) let ls_ty_vars ls = let ty_vars_args = List.fold_left Ty.ty_freevars Stv.empty ls.ls_args in let ty_vars_value = Opt.fold Ty.ty_freevars Stv.empty ls.ls_value in (ty_vars_args, ty_vars_value, Stv.union ty_vars_args ty_vars_value) (* unused printing function let print_path = print_list (constant_string ".") string *) let print_id fmt id = string fmt (id_unique iprinter id) let print_id_real info fmt id = try let path,ipr = Mid.find id info.symbol_printers in fprintf fmt "%s.%s" path (id_unique ipr id) with Not_found -> print_id fmt id let print_ls_real info fmt ls = print_id_real info fmt ls.ls_name let print_ts_real info fmt ts = print_id_real info fmt ts.ts_name (* unused printing function let print_pr_real info fmt pr = print_id_real info fmt pr.pr_name *) (** Types *) let print_ts_tv info fmt ts = match ts.ts_args with | [] -> fprintf fmt "%a" print_ts ts | _ -> fprintf fmt "(%a %a)" print_ts ts (print_list space (print_tv info ~whytypes:false)) ts.ts_args let rec print_ty info fmt ty = begin match ty.ty_node with | Tyvar v -> print_tv info ~whytypes:false fmt v | Tyapp (ts, tl) when is_ts_tuple ts -> begin match tl with | [] -> fprintf fmt "unit" | [ty] -> print_ty info fmt ty | _ -> fprintf fmt "(%a)%%type" (print_list star (print_ty info)) tl end | Tyapp (ts, [l;r]) when ts_equal ts ts_func -> fprintf fmt "(%a ->@ %a)" (print_ty info) l (print_ty info) r | Tyapp (ts, tl) -> begin match query_syntax info.info_syn ts.ts_name with | Some s -> syntax_arguments s (print_ty info) fmt tl | None -> begin match tl with | [] -> (print_ts_real info) fmt ts | l -> fprintf fmt "(%a@ %a)" (print_ts_real info) ts (print_list space (print_ty info)) l end end end (* can the type of a value be derived from the type of the arguments? *) let unambig_fs fs = let rec lookup v ty = match ty.ty_node with | Tyvar u when tv_equal u v -> true | _ -> ty_any (lookup v) ty in let lookup v = List.exists (lookup v) fs.ls_args in let rec inspect ty = match ty.ty_node with | Tyvar u when not (lookup u) -> false | _ -> ty_all inspect ty in inspect (Opt.get fs.ls_value) (** Patterns, terms, and formulas *) (* unused let lparen_l fmt () = fprintf fmt "@ (" *) let lparen_r fmt () = fprintf fmt "(@," (* unused let print_paren_l fmt x = print_list_delim ~start:lparen_l ~stop:rparen ~sep:comma fmt x *) let print_paren_r fmt x = print_list_delim ~start:lparen_r ~stop:rparen ~sep:comma fmt x let arrow fmt () = fprintf fmt " ->@ " let print_arrow_list fmt x = print_list_suf arrow fmt x let rec print_pat info fmt p = match p.pat_node with | Pwild -> fprintf fmt "_" | Pvar v -> print_vs fmt v | Pas (p,v) -> fprintf fmt "(%a as %a)" (print_pat info) p print_vs v | Por (p,q) -> fprintf fmt "(%a|%a)" (print_pat info) p (print_pat info) q | Papp (cs,pl) when is_fs_tuple cs -> fprintf fmt "%a" (print_paren_r (print_pat info)) pl | Papp (cs,pl) -> begin match query_syntax info.info_syn cs.ls_name with | Some s -> syntax_arguments s (print_pat info) fmt pl | _ when pl = [] -> (print_ls_real info) fmt cs | _ -> fprintf fmt "(%a %a)" (print_ls_real info) cs (print_list space (print_pat info)) pl end let print_vsty_nopar info fmt v = fprintf fmt "%a:%a" print_vs v (print_ty info) v.vs_ty let print_vsty info fmt v = fprintf fmt "(%a)" (print_vsty_nopar info) v let print_binop fmt = function | Tand -> fprintf fmt "/\\" | Tor -> fprintf fmt "\\/" | Timplies -> fprintf fmt "->" | Tiff -> fprintf fmt "<->" (* unused let print_label fmt (l,_) = fprintf fmt "(*%s*)" l *) let protect_on x s = if x then "(" ^^ s ^^ ")" else s let rec print_term info fmt t = print_lrterm false false info fmt t and print_fmla info fmt f = print_lrfmla false false info fmt f and print_opl_term info fmt t = print_lrterm true false info fmt t and print_opl_fmla info fmt f = print_lrfmla true false info fmt f and print_opr_term info fmt t = print_lrterm false true info fmt t and print_opr_fmla info fmt f = print_lrfmla false true info fmt f and print_lrterm opl opr info fmt t = match t.t_label with | _ -> print_tnode opl opr info fmt t (* | [] -> print_tnode opl opr info fmt t | ll -> fprintf fmt "(%a %a)" (print_list space print_label) ll (print_tnode false false info) t *) and print_lrfmla opl opr info fmt f = match f.t_label with | _ -> print_fnode opl opr info fmt f (* | [] -> print_fnode opl opr info fmt f | ll -> fprintf fmt "(%a %a)" (print_list space print_label) ll (print_fnode false false info) f *) and print_tnode _opl opr info fmt t = match t.t_node with | Tvar v -> print_vs fmt v | Tconst c -> let number_format = { Number.long_int_support = true; Number.extra_leading_zeros_support = true; Number.dec_int_support = if info.ssreflect then Number.Number_custom "%s%%:Z" else Number.Number_custom "%s%%Z"; Number.hex_int_support = Number.Number_unsupported; Number.oct_int_support = Number.Number_unsupported; Number.bin_int_support = Number.Number_unsupported; Number.def_int_support = Number.Number_unsupported; Number.dec_real_support = Number.Number_unsupported; Number.hex_real_support = Number.Number_unsupported; Number.frac_real_support = Number.Number_custom (Number.PrintFracReal ("%s%%R", "(%s * %s)%%R", "(%s / %s)%%R")); Number.def_real_support = Number.Number_unsupported; } in Number.print number_format fmt c | Tif (f,t1,t2) -> fprintf fmt (protect_on opr "if %a@ then %a@ else %a") (print_fmla info) f (print_term info) t1 (print_opl_term info) t2 | Tlet (t1,tb) -> let v,t2 = t_open_bound tb in fprintf fmt (protect_on opr "let %a :=@ %a in@ %a") print_vs v (print_term info) t1 (print_opl_term info) t2; forget_var v | Tcase (t,bl) -> fprintf fmt "match %a with@\n@[%a@]@\nend" (print_term info) t (print_list newline (print_tbranch info)) bl | Teps fb -> let vl,_,t0 = t_open_lambda t in if vl = [] then begin let v,f = t_open_bound fb in fprintf fmt (protect_on opr "epsilon %a.@ %a") (print_vsty info) v (print_opl_fmla info) f; forget_var v end else begin if t0.t_ty = None then unsupportedTerm t "Coq: Prop-typed lambdas are not supported"; fprintf fmt (protect_on opr "fun %a =>@ %a") (print_list space (print_vsty info)) vl (print_opl_term info) t0; List.iter forget_var vl end | Tapp (fs,[]) when is_fs_tuple fs -> fprintf fmt "tt" | Tapp (fs,pl) when is_fs_tuple fs -> fprintf fmt "%a" (print_paren_r (print_term info)) pl | Tapp (fs,[l;r]) when ls_equal fs fs_func_app -> fprintf fmt "(%a@ %a)" (print_opr_term info) l (print_opr_term info) r | Tapp (fs, tl) -> begin match query_syntax info.info_syn fs.ls_name with | Some s -> syntax_arguments s (print_opr_term info) fmt tl | _ -> if unambig_fs fs then if tl = [] then fprintf fmt "%a" (print_ls_real info) fs else fprintf fmt "(%a %a)" (print_ls_real info) fs (print_list space (print_opr_term info)) tl else fprintf fmt "(%a %a: %a)" (print_ls_real info) fs (print_list space (print_opr_term info)) tl (print_ty info) (t_type t) end | Tquant _ | Tbinop _ | Tnot _ | Ttrue | Tfalse -> raise (TermExpected t) and print_fnode opl opr info fmt f = match f.t_node with | Tquant (Tforall,fq) -> let vl,_tl,f = t_open_quant fq in fprintf fmt (protect_on opr "forall %a,@ %a") (print_list space (print_vsty info)) vl (* (print_tl info) tl *) (print_fmla info) f; List.iter forget_var vl | Tquant (Texists,fq) -> let vl,_tl,f = t_open_quant fq in let rec aux fmt vl = match vl with | [] -> print_fmla info fmt f | v::vr -> fprintf fmt (protect_on opr "exists %a,@ %a") (print_vsty_nopar info) v aux vr in aux fmt vl; List.iter forget_var vl | Ttrue -> fprintf fmt "True" | Tfalse -> fprintf fmt "False" | Tbinop (b,f1,f2) -> fprintf fmt (protect_on (opl || opr) "%a %a@ %a") (print_opr_fmla info) f1 print_binop b (print_opl_fmla info) f2 | Tnot f -> fprintf fmt (protect_on opr "~ %a") (print_opl_fmla info) f | Tlet (t,f) -> let v,f = t_open_bound f in fprintf fmt (protect_on opr "let %a :=@ %a in@ %a") print_vs v (print_term info) t (print_opl_fmla info) f; forget_var v | Tcase (t,bl) -> fprintf fmt "match %a with@\n@[%a@]@\nend" (print_term info) t (print_list newline (print_fbranch info)) bl | Tif (f1,f2,f3) -> fprintf fmt (protect_on opr "if %a@ then %a@ else %a") (print_fmla info) f1 (print_fmla info) f2 (print_opl_fmla info) f3 | Tapp (ps, tl) -> begin match query_syntax info.info_syn ps.ls_name with | Some s -> syntax_arguments s (print_opr_term info) fmt tl | _ -> fprintf fmt "(%a%a)" (print_ls_real info) ps (print_list_pre space (print_opr_term info)) tl end | Tvar _ | Tconst _ | Teps _ -> raise (FmlaExpected f) and print_tbranch info fmt br = let p,t = t_open_branch br in fprintf fmt "@[| %a =>@ %a@]" (print_pat info) p (print_term info) t; Svs.iter forget_var p.pat_vars and print_fbranch info fmt br = let p,f = t_open_branch br in fprintf fmt "@[| %a =>@ %a@]" (print_pat info) p (print_fmla info) f; Svs.iter forget_var p.pat_vars let print_expr info fmt = TermTF.t_select (print_term info fmt) (print_fmla info fmt) (** Declarations *) let print_constr info ts fmt (cs,_) = fprintf fmt "@[| %a : %a%a%a@]" print_ls cs (print_arrow_list (print_ty info)) cs.ls_args print_ts ts (print_list_pre space (print_tv info ~whytypes:false)) ts.ts_args (* copy of old user scripts *) type content_type = Notation | (*Gallina |*) Vernacular type statement = | Info of string (* name *) | Axiom of string (* name *) | Query of string * content_type * string (* name and content *) | Other of string (* content *) exception StringValue of string let read_generated_name = let def = Str.regexp "\\(Definition\\|Fixpoint\\|Inductive\\|CoInductive\\)[ ]+\\([^ :(.]+\\)" in fun ch -> try while true do let s = input_line ch in if Str.string_match def s 0 then raise (StringValue (Str.matched_group 2 s)) done; assert false with StringValue name -> name (** no nested comment *) let read_comment = let start_comment = Str.regexp "(\\*[ ]+\\([^ :]+\\)" in let end_comment = Str.regexp ".*\\*)" in fun ch -> let line = ref "" in (* look for "( * name" *) let name = try while true do let s = input_line ch in if Str.string_match start_comment s 0 then begin line := s; raise (StringValue (Str.matched_group 1 s)) end done; assert false with StringValue name -> name in (* look for end of comment *) while not (Str.string_match end_comment (!line) 0) do line := input_line ch done; name let read_until re s i ch = if not (Str.string_match re s i) then while not (Str.string_match re (input_line ch) 0) do () done let read_until_or_eof re s i ch = try read_until re s i ch with | End_of_file -> () let read_old_proof = let def = Str.regexp "\\(Definition\\|Notation\\|Lemma\\|Theorem\\|Variable\\|Hypothesis\\)[ ]+\\([^ :(.]+\\)" in let def_end = Str.regexp ".*[.]$" in let old_intros = Str.regexp "^ *([*] Why3 intros " in let old_end = Str.regexp ".*[*])" in let qed = Str.regexp "\\(Qed\\|Defined\\|Save\\|Admitted\\)[.]" in fun ch -> try let start = ref (pos_in ch) in let s = input_line ch in if not (Str.string_match def s 0) then raise (StringValue s); let kind = Str.matched_group 1 s in let name = Str.matched_group 2 s in read_until def_end s (Str.match_end ()) ch; match kind with | "Variable" | "Hypothesis" -> Axiom name | _ -> let k = if kind = "Notation" then Notation else begin start := pos_in ch; let s = input_line ch in if Str.string_match old_intros s 0 then begin read_until old_end s (Str.match_end ()) ch; start := pos_in ch; read_until_or_eof qed (input_line ch) 0 ch end else read_until_or_eof qed s 0 ch; Vernacular end in let len = pos_in ch - !start in let s = Bytes.create len in seek_in ch !start; really_input ch s 0 len; Query (name, k, Bytes.unsafe_to_string s) with StringValue s -> Other s (* Load old-style proofs where users were confined to a few sections. *) let read_deprecated_script ch in_context = let sc = ref [] in let context = ref in_context in try while true do let pos = pos_in ch in let s = input_line ch in if !context then if s = "(* DO NOT EDIT BELOW *)" then context := false else sc := Other s :: !sc else if s <> "" then begin seek_in ch pos; sc := read_old_proof ch :: Other "" :: !sc; raise End_of_file end done; assert false with | End_of_file -> !sc let read_old_script = let axm = Str.regexp "\\(Axiom\\|Parameter\\)[ ]+\\([^ :(.]+\\)" in let prelude = Str.regexp "(\\* This file is generated by Why3.*\\*)" in fun ch -> let skip_to_empty = ref false in let last_empty_line = ref 0 in let sc = ref [] in try while true do let s = input_line ch in if s = "" then last_empty_line := pos_in ch; if !skip_to_empty then (if s = "" then skip_to_empty := false) else if s = "(* Why3 comment *)" then (let name = read_comment ch in sc := Info name :: !sc; skip_to_empty := true) else if s = "(* Why3 assumption *)" then (let name = read_generated_name ch in sc := Axiom name :: !sc; skip_to_empty := true) else if Str.string_match axm s 0 then (let name = Str.matched_group 2 s in sc := Axiom name :: !sc; skip_to_empty := true) else if s = "(* Why3 goal *)" then (sc := read_old_proof ch :: !sc; skip_to_empty := true) else if Str.string_match prelude s 0 then (sc := Info "Why3 prelude" :: !sc; skip_to_empty := true) else if s = "(* YOU MAY EDIT THE CONTEXT BELOW *)" then (sc := read_deprecated_script ch true; raise End_of_file) else if s = "(* YOU MAY EDIT THE PROOF BELOW *)" then (seek_in ch !last_empty_line; sc := read_deprecated_script ch false; raise End_of_file) else sc := Other s :: !sc done; assert false with | End_of_file -> let rec rmv = function | Other "" :: t -> rmv t | l -> l in List.rev (rmv !sc) (* Output all the Other entries of the script that occur before the location of name. Modify the script by removing the name entry and all these outputs. Return the user content. *) let output_till_statement fmt script name = let print i = let rec aux acc = function | h :: l when h == i -> let l = match l with | Other "" :: l -> l | _ -> l in script := List.rev_append acc l | Other o :: l -> fprintf fmt "%s@\n" o; aux acc l | h :: l -> aux (h :: acc) l | [] -> assert false in aux [] !script in let rec find = function | Info n as o :: _ when n = name -> print o; Some o | Axiom n as o :: _ when n = name -> print o; Some o | Query (n,_,_) as o :: _ when n = name -> print o; Some o | [] -> None | _ :: t -> find t in find !script let output_remaining fmt script = List.iter (function | Info _ | Axiom _ -> () | Query (n,_,c) -> fprintf fmt "(* Unused content named %s@\n%s *)@\n" n c | Other c -> fprintf fmt "%s@\n" c) script let rec intros_hyp n fmt f = match f.t_node with | Tbinop(Tand,f1,f2) -> fprintf fmt "("; let (m,vsl1) = intros_hyp n fmt f1 in fprintf fmt ","; let (k,vsl2) = intros_hyp m fmt f2 in fprintf fmt ")"; (k,vsl1@vsl2) | Tquant(Texists,fq) -> let vsl,_trl,f = t_open_quant fq in let rec aux n vsl = match vsl with | [] -> intros_hyp n fmt f | v::l -> fprintf fmt "(%a," print_vs v; let m = aux n l in fprintf fmt ")"; m in aux n vsl | _ -> fprintf fmt "h%d" n; (n+1,[]) let rec do_intros n fmt fmla = match fmla.t_node with | Tlet(_,fb) -> let vs,f = t_open_bound fb in fprintf fmt "@ %a" print_vs vs; do_intros n fmt f; forget_var vs | Tquant(Tforall,fq) -> let vsl,_trl,f = t_open_quant fq in List.iter (fun v -> fprintf fmt "@ %a" print_vs v) vsl; do_intros n fmt f; List.iter forget_var vsl | Tbinop(Timplies, f1, f2) -> fprintf fmt "@ "; let m,vsl = intros_hyp n fmt f1 in do_intros m fmt f2; List.iter forget_var vsl | _ -> () let intros_params fmt params = Stv.iter (fun tv -> let n = id_unique iprinter tv.tv_name in fprintf fmt "@ %s %s_WT" n n) params let need_intros params fmla = not (Stv.is_empty params) || match fmla.t_node with | Tlet _ | Tquant(Tforall,_) | Tbinop(Timplies, _, _) -> true | _ -> false let intros fmt params fmla = fprintf fmt "@[intros%a%a.@]" intros_params params (do_intros 1) fmla let print_empty_proof fmt def = match def with | Some (params,fmla) -> if need_intros params fmla then intros fmt params fmla; fprintf fmt "@\n@\n"; fprintf fmt "Qed.@\n" | None -> fprintf fmt "@\n"; fprintf fmt "Defined.@\n" let print_previous_proof def info fmt previous = match previous with | None -> print_empty_proof fmt def | Some (Query (_,Vernacular,c)) -> begin match def with | Some (p, f) when not info.realization && need_intros p f -> fprintf fmt "@[(* Why3 %a *)@]@\n" (fun fmt f -> intros fmt p f) f | _ -> () end; fprintf fmt "%s" c | Some (Query (_,Notation,_)) | Some (Axiom _) | Some (Other _) | Some (Info _) -> assert false let print_type_decl ~prev info fmt ts = if is_ts_tuple ts then () else match ts.ts_def with | NoDef | Range _ | Float _ -> if info.realization then match prev with | Some (Query (_,Notation,c)) -> fprintf fmt "(* Why3 goal *)@\n%s@\n" c | Some (Axiom _) -> fprintf fmt "(* Why3 goal *)@\n@[Variable %a : %aType.@]@\n@[Hypothesis %a_WhyType : %aWhyType %a.@]@\nExisting Instance %a_WhyType.@\n@\n" print_ts ts (print_params_list info ~whytypes:false) ts.ts_args print_ts ts (print_params_list info ~whytypes:true) ts.ts_args (print_ts_tv info) ts print_ts ts | _ -> fprintf fmt "(* Why3 goal *)@\n@[Definition %a : %aType.@]@\n%a@\n" print_ts ts (print_params_list info ~whytypes:false) ts.ts_args (print_previous_proof None info) prev else begin fprintf fmt "@[Axiom %a : %aType.@]@\n" print_ts ts (print_params_list info ~whytypes:false) ts.ts_args; if not info.ssreflect then begin fprintf fmt "@[Parameter %a_WhyType : %aWhyType %a.@]@\n" print_ts ts (print_params_list info ~whytypes:true) ts.ts_args (print_ts_tv info) ts; fprintf fmt "Existing Instance %a_WhyType.@\n" print_ts ts end; fprintf fmt "@\n" end | Alias ty -> fprintf fmt "(* Why3 assumption *)@\n@[Definition %a%a :=@ %a.@]@\n@\n" print_ts ts (print_list_pre space (print_tv_binder info ~whytypes:false ~implicit:false)) ts.ts_args (print_ty info) ty let print_type_decl ~prev info fmt ts = if not (Mid.mem ts.ts_name info.info_syn) then (print_type_decl ~prev info fmt ts; forget_tvs ()) let print_data_decl ~first info fmt ts csl = let name = id_unique iprinter ts.ts_name in if first then fprintf fmt "(* Why3 assumption *)@\n@[Inductive" else fprintf fmt "@\nwith"; fprintf fmt " %s%a :=@\n@[%a@]" name (print_list_pre space (print_tv_binder info ~whytypes:false ~implicit:false)) ts.ts_args (print_list newline (print_constr info ts)) csl; name let print_data_whytype_and_implicits info fmt (name,ts,csl) = if not info.ssreflect then fprintf fmt "@[Axiom %s_WhyType : %aWhyType %a.@]@\nExisting Instance %s_WhyType.@\n" name (print_params_list info ~whytypes:true) ts.ts_args (print_ts_tv info) ts name; List.iter (fun (cs,_) -> let _, _, all_ty_params = ls_ty_vars cs in if not (Stv.is_empty all_ty_params) then let print fmt tv = fprintf fmt "[%a]" (print_tv info ~whytypes:false) tv in fprintf fmt "@[Implicit Arguments %a@ [%a].@]@\n" print_ls cs (print_list space print) ts.ts_args) csl; fprintf fmt "@\n" let print_data_decls info fmt tl = let none,d = List.fold_left (fun ((first,l) as acc) (ts,csl) -> if is_ts_tuple ts || Mid.mem ts.ts_name info.info_syn then acc else let name = print_data_decl info ~first fmt ts csl in forget_tvs (); (false,(name,ts,csl)::l)) (true,[]) tl in if none then () else begin fprintf fmt ".@]@\n"; List.iter (print_data_whytype_and_implicits info fmt) d end let print_ls_type info fmt = function | None -> fprintf fmt "Prop" | Some ty -> print_ty info fmt ty let print_param_decl ~prev info fmt ls = let _, _, all_ty_params = ls_ty_vars ls in if info.realization then match prev with | Some (Query (_,Notation,c)) -> fprintf fmt "(* Why3 goal *)@\n%s@\n" c | Some (Axiom _) -> fprintf fmt "(* Why3 goal *)@\n@[Variable %a: %a%a%a.@]@\n@\n" print_ls ls (print_params info ~whytypes:true) all_ty_params (print_arrow_list (print_ty info)) ls.ls_args (print_ls_type info) ls.ls_value | (* Some Info *) _ when Mid.mem ls.ls_name info.info_syn -> let vl = List.map (fun ty -> create_vsymbol (id_fresh "x") ty) ls.ls_args in let e = Term.t_app ls (List.map Term.t_var vl) ls.ls_value in fprintf fmt "(* Why3 comment *)@\n\ (* %a is replaced with %a by the coq driver *)@\n@\n" print_ls ls (print_expr info) e; List.iter forget_var vl | _ -> fprintf fmt "(* Why3 goal *)@\n@[Definition %a: %a%a%a.@]@\n%a@\n" print_ls ls (print_params info ~whytypes:true) all_ty_params (print_arrow_list (print_ty info)) ls.ls_args (print_ls_type info) ls.ls_value (print_previous_proof None info) prev else fprintf fmt "@[Parameter %a: %a%a%a.@]@\n@\n" print_ls ls (print_params info ~whytypes:true) all_ty_params (print_arrow_list (print_ty info)) ls.ls_args (print_ls_type info) ls.ls_value let print_param_decl ~prev info fmt ls = if info.realization || not (Mid.mem ls.ls_name info.info_syn) then (print_param_decl ~prev info fmt ls; forget_tvs ()) let print_logic_decl info fmt (ls,ld) = let _, _, all_ty_params = ls_ty_vars ls in let vl,e = open_ls_defn ld in fprintf fmt "(* Why3 assumption *)@\n@[Definition %a%a%a: %a :=@ %a.@]@\n" print_ls ls (print_tv_binders info ~whytypes:true ~implicit:true) all_ty_params (print_list_pre space (print_vsty info)) vl (print_ls_type info) ls.ls_value (print_expr info) e; List.iter forget_var vl; fprintf fmt "@\n" let print_equivalence_lemma ~prev info fmt name (ls,ld) = let _, _, all_ty_params = ls_ty_vars ls in let def_formula = ls_defn_axiom ld in fprintf fmt "(* Why3 goal *)@\n@[Lemma %s :@ %a%a.@]@\n" name (print_params info ~whytypes:true) all_ty_params (print_expr info) def_formula; fprintf fmt "%a@\n" (print_previous_proof (Some (all_ty_params,def_formula)) info) prev let print_equivalence_lemma ~old info fmt ((ls,_) as d) = if info.realization && (Mid.mem ls.ls_name info.info_syn) then let name = Ident.string_unique iprinter ((id_unique iprinter ls.ls_name)^"_def") in let prev = output_till_statement fmt old name in (print_equivalence_lemma ~prev info fmt name d; forget_tvs ()) let print_logic_decl ~old info fmt d = (* During realization the definition of a "builtin" symbol is printed and an equivalence lemma with associated coq function is requested *) if not (Mid.mem (fst d).ls_name info.info_syn) then (print_logic_decl info fmt d; forget_tvs ()) else if info.realization then print_equivalence_lemma ~old info fmt d let print_recursive_decl info fmt (ls,ld) = let _, _, all_ty_params = ls_ty_vars ls in let i = match Decl.ls_defn_decrease ld with | [i] -> i | _ -> assert false in let vl,e = open_ls_defn ld in fprintf fmt "%a%a%a {struct %a}: %a :=@ %a@]" print_ls ls (print_tv_binders info ~whytypes:true ~implicit:true) all_ty_params (print_list_pre space (print_vsty info)) vl print_vs (List.nth vl i) (print_ls_type info) ls.ls_value (print_expr info) e; List.iter forget_var vl let print_recursive_decl ~old info fmt dl = let dl_syn, dl_no_syn = List.partition (fun (ls,_) -> info.realization && (Mid.mem ls.ls_name info.info_syn)) dl in if dl_no_syn <> [] then begin fprintf fmt "(* Why3 assumption *)@\n"; print_list_delim ~start:(fun fmt () -> fprintf fmt "@[Fixpoint ") ~stop:(fun fmt () -> fprintf fmt ".@]@\n") ~sep:(fun fmt () -> fprintf fmt "@]@\n@[with ") (fun fmt d -> print_recursive_decl info fmt d; forget_tvs ()) fmt dl_no_syn; fprintf fmt "@\n"; end; List.iter (print_equivalence_lemma ~old info fmt) dl_syn let print_ind info fmt (pr,f) = fprintf fmt "@[| %a : %a@]" print_pr pr (print_fmla info) f let print_ind_decl info fmt ps bl = let _, _, all_ty_params = ls_ty_vars ps in fprintf fmt " %a%a: %aProp :=@ @[%a@]" print_ls ps (print_tv_binders info ~whytypes:true ~implicit:true) all_ty_params (print_arrow_list (print_ty info)) ps.ls_args (print_list newline (print_ind info)) bl let print_ind_decls info s fmt tl = let none = List.fold_left (fun first (ps,bl) -> if Mid.mem ps.ls_name info.info_syn then first else begin if first then fprintf fmt "(* Why3 assumption *)@\n@[%s" (match s with Ind -> "Inductive" | Coind -> "CoInductive") else fprintf fmt "@\nwith"; print_ind_decl info fmt ps bl; forget_tvs (); false end) true tl in if not none then fprintf fmt ".@]@\n@\n" let print_prop_decl ~prev info fmt (k,pr,f) = ignore prev; let params = t_ty_freevars Stv.empty f in let stt = match k with | Paxiom when info.realization -> "Lemma" | Paxiom -> "" | Plemma -> "Lemma" | Pgoal -> "Theorem" | Pskip -> assert false (* impossible *) in if stt <> "" then match prev with | Some (Axiom _) when stt = "Lemma" -> fprintf fmt "(* Why3 goal *)@\n@[Hypothesis %a : %a%a.@]@\n@\n" print_pr pr (print_params info ~whytypes:true) params (print_fmla info) f | _ -> fprintf fmt "(* Why3 goal *)@\n@[%s %a : %a%a.@]@\n%a@\n" stt print_pr pr (print_params info ~whytypes:true) params (print_fmla info) f (print_previous_proof (Some (params,f)) info) prev else fprintf fmt "@[Axiom %a : %a%a.@]@\n@\n" print_pr pr (print_params info ~whytypes:true) params (print_fmla info) f; forget_tvs () let print_decl ~old info fmt d = let name = match d.d_node with | Dtype ts | Ddata ((ts, _)::_) -> id_unique iprinter ts.ts_name | Dparam ls | Dlogic ((ls,_)::_) | Dind (_, (ls,_)::_) -> id_unique iprinter ls.ls_name | Dprop (_,pr,_) -> id_unique iprinter pr.pr_name | Ddata [] | Dlogic [] | Dind (_, []) -> assert false in let prev = output_till_statement fmt old name in match d.d_node with | Dtype ts -> print_type_decl ~prev info fmt ts | Ddata tl -> print_data_decls info fmt tl | Dparam ls -> print_param_decl ~prev info fmt ls | Dlogic [s,_ as ld] when not (Sid.mem s.ls_name d.d_syms) -> print_logic_decl ~old info fmt ld | Dlogic ll -> print_recursive_decl ~old info fmt ll | Dind (s, il) -> print_ind_decls info s fmt il | Dprop (_,pr,_) when not info.realization && Mid.mem pr.pr_name info.info_syn -> () | Dprop pr -> print_prop_decl ~prev info fmt pr let print_decls ~old info fmt dl = fprintf fmt "@\n@[%a@]" (print_list nothing (print_decl ~old info)) dl let print_task printer_args ~realize ~ssreflect ?old fmt task = (* eprintf "Task:%a@.@." Pretty.print_task task; *) forget_all (); (* find theories that are both used and realized from metas *) let realized_theories = Task.on_meta meta_realized_theory (fun mid args -> match args with | [Theory.MAstr s1; Theory.MAstr s2] -> (* TODO: do not split string; in fact, do not even use a string argument *) let f,id = let l = Strings.rev_split '.' s1 in List.rev (List.tl l), List.hd l in let th = Env.read_theory printer_args.env f id in Mid.add th.Theory.th_name (th, if s2 = "" then s1 else s2) mid | _ -> assert false ) Mid.empty task in (* 2 cases: goal is clone T with [] or goal is a real goal *) let rec upd_realized_theories = function | Some { Task.task_decl = { Theory.td_node = Theory.Decl { Decl.d_node = Decl.Dprop (Decl.Pgoal, _, _) }}} -> realized_theories | Some { Task.task_decl = { Theory.td_node = Theory.Clone (th,_) }} -> Sid.iter (fun id -> ignore (id_unique iprinter id)) th.Theory.th_local; Mid.remove th.Theory.th_name realized_theories | Some { Task.task_decl = { Theory.td_node = Theory.Meta _ }; Task.task_prev = task } -> upd_realized_theories task | _ -> assert false in let realized_theories = upd_realized_theories task in let realized_theories' = Mid.map fst realized_theories in let realized_symbols = Task.used_symbols realized_theories' in let local_decls = Task.local_decls task realized_symbols in (* eprintf "local_decls:%i@." (List.length local_decls); *) (* associate a special printer to each symbol in a realized theory *) let symbol_printers = let printers = Mid.map (fun th -> let pr = fresh_printer () in Sid.iter (fun id -> ignore (id_unique pr id)) th.Theory.th_local; pr ) realized_theories' in Mid.map (fun th -> (snd (Mid.find th.Theory.th_name realized_theories), Mid.find th.Theory.th_name printers) ) realized_symbols in let info = { info_syn = get_syntax_map task; symbol_printers = symbol_printers; realization = realize; ssreflect = ssreflect; } in let old = ref (match old with | None -> [] | Some ch -> read_old_script ch) in ignore (output_till_statement fmt old "Why3 prelude"); print_prelude fmt printer_args.prelude; print_th_prelude task fmt printer_args.th_prelude; Mid.iter (fun _ (_, s) -> fprintf fmt "Require %s.@\n" s) realized_theories; print_decls ~old info fmt local_decls; output_remaining fmt !old let print_task_full args ?old fmt task = print_task args ~realize:false ~ssreflect:false ?old fmt task let print_task_real args ?old fmt task = print_task args ~realize:true ~ssreflect:false ?old fmt task let () = register_printer "coq" print_task_full ~desc:"Printer@ for@ the@ Coq@ proof@ assistant@ \ (without@ realization@ capabilities)." let () = register_printer "coq-realize" print_task_real ~desc:"Printer@ for@ the@ Coq@ proof@ assistant@ \ (with@ realization@ capabilities)." let print_task_full_ssr args ?old fmt task = print_task args ~realize:false ~ssreflect:true ?old fmt task let () = register_printer "coq-ssr" print_task_full_ssr ~desc:"Printer@ for@ the@ Coq@ proof@ assistant,@ ssreflect@ extension\ (without@ realization@ capabilities)." (* specific printer for realization of theories *) (* OBSOLETE open Theory let print_tdecl ~old info fmt d = match d.td_node with | Decl d -> print_decl ~old info fmt d | Use t -> fprintf fmt "Require %s.@\n@\n" (id_unique iprinter t.th_name) | Meta _ -> assert false (* TODO ? *) | Clone _ -> assert false (* TODO *) let print_tdecls ~old info fmt dl = fprintf fmt "@[%a@\n@]" (print_list nothing (print_tdecl ~old info)) dl let print_theory _env pr thpr ?old fmt th = forget_all (); print_prelude fmt pr; print_prelude_for_theory th fmt thpr; let info = { info_syn = (Mid.empty : string Ident.Mid.t) (* get_syntax_map_of_theory th*); realization = true; } in let old = match old with | None -> None | Some ch -> Some(ref NoWhere,ch) in print_tdecls ~old info fmt th.th_decls; produce_remaining_contexts_and_proofs ~old fmt *) (* Local Variables: compile-command: "unset LANG; make -C ../.. " End: *) why3-0.88.3/src/printer/why3printer.mli0000664000175100017510000000130713225666037020530 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) why3-0.88.3/src/printer/smtv2.mli0000664000175100017510000000130713225666037017305 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) why3-0.88.3/src/printer/coq.mli0000664000175100017510000000155013225666037017014 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (* OBSOLETE val print_theory : Env.env -> Printer.prelude -> Printer.prelude_map -> ?old:Pervasives.in_channel -> Format.formatter -> Theory.theory -> unit *) why3-0.88.3/src/printer/simplify.ml0000664000175100017510000001467213225666037017726 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** Simplify printer *) open Format open Pp open Ident open Term open Decl open Printer let ident_printer = let bls = ["select";"store"] in let san = sanitizer char_to_alpha char_to_alnumus in create_ident_printer bls ~sanitizer:san let print_ident fmt id = fprintf fmt "%s" (id_unique ident_printer id) let forget_var v = forget_id ident_printer v.vs_name let print_var fmt {vs_name = id} = print_ident fmt id type info = { info_syn : syntax_map; } let rec print_term info fmt t = match t.t_node with | Tconst c -> let number_format = { Number.long_int_support = false; Number.extra_leading_zeros_support = true; Number.dec_int_support = Number.Number_default; Number.hex_int_support = Number.Number_unsupported; Number.oct_int_support = Number.Number_unsupported; Number.bin_int_support = Number.Number_unsupported; Number.def_int_support = Number.Number_custom "constant_too_large_%s"; Number.dec_real_support = Number.Number_unsupported; Number.hex_real_support = Number.Number_unsupported; Number.frac_real_support = Number.Number_unsupported; Number.def_real_support = Number.Number_custom "real_constant_%s"; } in Number.print number_format fmt c | Tvar v -> print_var fmt v | Tapp (ls, tl) -> begin match query_syntax info.info_syn ls.ls_name with | Some s -> syntax_arguments s (print_term info) fmt tl | None -> begin match tl with (* for cvc3 wich doesn't accept (toto ) *) | [] -> fprintf fmt "@[%a@]" print_ident ls.ls_name | _ -> fprintf fmt "@[(%a@ %a)@]" print_ident ls.ls_name (print_list space (print_term info)) tl end end | Tlet _ -> unsupportedTerm t "simplify: you must eliminate let" | Tif _ -> unsupportedTerm t "simplify: you must eliminate if" | Tcase _ -> unsupportedTerm t "simplify: you must eliminate match" | Teps _ -> unsupportedTerm t "simplify: you must eliminate epsilon" | Tquant _ | Tbinop _ | Tnot _ | Ttrue | Tfalse -> raise (TermExpected t) and print_fmla info fmt f = match f.t_node with | Tapp ({ ls_name = id }, []) -> print_ident fmt id | Tapp (ls, tl) -> begin match query_syntax info.info_syn ls.ls_name with | Some s -> syntax_arguments s (print_term info) fmt tl | None -> fprintf fmt "(EQ (%a@ %a) |@@true|)" print_ident ls.ls_name (print_list space (print_term info)) tl end | Tquant (q, fq) -> let q = match q with Tforall -> "FORALL" | Texists -> "EXISTS" in let vl, tl, f = t_open_quant fq in fprintf fmt "@[(%s (%a)%a@ %a)@]" q (print_list space print_var) vl (print_triggers info) tl (print_fmla info) f; List.iter forget_var vl | Tbinop (Tand, f1, f2) -> fprintf fmt "@[(AND@ %a@ %a)@]" (print_fmla info) f1 (print_fmla info) f2 | Tbinop (Tor, f1, f2) -> fprintf fmt "@[(OR@ %a@ %a)@]" (print_fmla info) f1 (print_fmla info) f2 | Tbinop (Timplies, f1, f2) -> fprintf fmt "@[(IMPLIES@ %a@ %a)@]" (print_fmla info) f1 (print_fmla info) f2 | Tbinop (Tiff, f1, f2) -> fprintf fmt "@[(IFF@ %a@ %a)@]" (print_fmla info) f1 (print_fmla info) f2 | Tnot f -> fprintf fmt "@[(NOT@ %a)@]" (print_fmla info) f | Ttrue -> fprintf fmt "TRUE" | Tfalse -> fprintf fmt "FALSE" | Tif _ -> unsupportedTerm f "simplify : you must eliminate if" | Tlet _ -> unsupportedTerm f "simplify : you must eliminate let" | Tcase _ -> unsupportedTerm f "simplify : you must eliminate match" | Tvar _ | Tconst _ | Teps _ -> raise (FmlaExpected f) and print_expr info fmt = TermTF.t_select (print_term info fmt) (print_fmla info fmt) and print_trigger info fmt = function | [] -> () | [{t_node=Tvar _} as t] -> fprintf fmt "(MPAT %a)" (print_term info) t | [t] -> print_expr info fmt t | tl -> fprintf fmt "(MPAT %a)" (print_list space (print_expr info)) tl and print_triggers info fmt = function | [] -> () | tl -> fprintf fmt "@ (PATS %a)" (print_list space (print_trigger info)) tl let print_decl info fmt d = match d.d_node with | Dtype _ | Dparam _ -> () | Ddata _ -> unsupportedDecl d "Algebraic datatypes are not supported" | Dlogic _ -> unsupportedDecl d "Predicate and function definition aren't supported" | Dind _ -> unsupportedDecl d "simplify : inductive definition are not supported" | Dprop (Paxiom, pr, _) when Mid.mem pr.pr_name info.info_syn -> () | Dprop (Paxiom, pr, f) -> fprintf fmt "@[(BG_PUSH@\n ;; axiom %s@\n @[%a@])@]@\n@\n" pr.pr_name.id_string (print_fmla info) f | Dprop (Pgoal, pr, f) -> fprintf fmt "@[;; %a@]@\n" print_ident pr.pr_name; (match pr.pr_name.id_loc with | Some loc -> fprintf fmt " @[;; %a@]@\n" Loc.gen_report_position loc | None -> ()); fprintf fmt "@[%a@]@\n" (print_fmla info) f | Dprop ((Plemma|Pskip), _, _) -> assert false let print_decls = let print_decl sm fmt d = try print_decl {info_syn = sm} fmt d; sm, [] with Unsupported s -> raise (UnsupportedDecl (d,s)) in let print_decl = Printer.sprint_decl print_decl in let print_decl task acc = print_decl task.Task.task_decl acc in Discriminate.on_syntax_map (fun sm -> Trans.fold print_decl (sm,[])) let print_task args ?old:_ fmt task = (* In trans-based p-printing [forget_all] is a no-no *) (* forget_all ident_printer; *) print_prelude fmt args.prelude; print_th_prelude task fmt args.th_prelude; let rec print = function | x :: r -> print r; Pp.string fmt x | [] -> () in print (snd (Trans.apply print_decls task)); pp_print_flush fmt () let () = register_printer "simplify" print_task ~desc:"Printer@ for@ the@ Simplify@ theorem@ prover." why3-0.88.3/src/printer/cntexmp_printer.mli0000664000175100017510000000371013225666037021453 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Term (* Information about the term that triggers VC. *) type vc_term_info = { mutable vc_inside : bool; (* true if the term that triggers VC is currently processed *) mutable vc_loc : Loc.position option; (* the position of the term that triggers VC *) mutable vc_func_name : string option; (* the name of the function for that VC was made. None if VC is not generated for postcondition or precondition) *) } module TermCmp : sig type t = term val before: Loc.position option -> Loc.position option -> bool val compare: term -> term -> int end module S : Set.S with type elt = term and type t = Set.Make(TermCmp).t val model_trace_regexp: Str.regexp val label_starts_with: Str.regexp -> Ident.label -> bool val get_label: unit Ident.Mlab.t -> Str.regexp -> Ident.label val print_label: Format.formatter -> Ident.label -> unit val model_label: Ident.label val model_vc_term_label: Ident.label val add_model_element: Term.term -> S.t -> S.t val add_old: string -> string val model_trace_for_postcondition: labels: unit Ident.Mlab.t -> vc_term_info -> unit Ident.Mlab.t val get_fun_name: string -> string val check_enter_vc_term: Term.term -> bool -> vc_term_info -> unit val check_exit_vc_term: Term.term -> bool -> vc_term_info -> unit why3-0.88.3/src/printer/alt_ergo.ml0000664000175100017510000004262013225666037017660 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** Alt-ergo printer *) open Format open Pp open Ident open Ty open Term open Decl open Printer open Cntexmp_printer let meta_ac = Theory.register_meta "AC" [Theory.MTlsymbol] ~desc:"Specify@ that@ a@ symbol@ is@ associative@ and@ commutative." let meta_printer_option = Theory.register_meta "printer_option" [Theory.MTstring] ~desc:"Pass@ additional@ parameters@ to@ the@ pretty-printer." let meta_invalid_trigger = Theory.register_meta "invalid trigger" [Theory.MTlsymbol] ~desc:"Specify@ that@ a@ symbol@ is@ not@ allowed@ in@ a@ trigger." type info = { info_syn : syntax_map; info_ac : Sls.t; info_show_labels : bool; info_type_casts : bool; info_csm : lsymbol list Mls.t; info_pjs : Sls.t; info_axs : Spr.t; info_inv_trig : Sls.t; info_printer : ident_printer; mutable info_model: S.t; info_vc_term: vc_term_info; mutable info_in_goal: bool; } let ident_printer () = let bls = [ "abs_int"; "abs_real"; "ac"; "and"; "array"; "as"; "axiom"; "bitv"; "bool"; "check"; "cut"; "distinct"; "else"; "exists"; "false"; "float"; "float32"; "float32d"; "float64"; "float64d"; "forall"; "fpa_rounding_mode"; "function"; "goal"; "if"; "in"; "include"; "int"; "int_ceil"; "int_floor"; "integer_log2"; "integer_round"; "is_theory_constant"; "inversion"; "let"; "linear_dependency"; "logic"; "max_int"; "max_real"; "min_int"; "min_real"; "not"; "not_theory_constant"; "or"; "parameter"; "predicate"; "pow_real_int"; "pow_real_real"; "prop"; "real"; "real_of_int"; "rewriting"; "select"; "sqrt_real"; "sqrt_real_default"; "sqrt_real_excess"; "store"; "then"; "true"; "type"; "unit"; "void"; "with"; "Aw"; "Down"; "Od"; "NearestTiesToAway"; "NearestTiesToEven"; "Nd"; "No"; "Nu"; "Nz"; "ToZero"; "Up"; ] in let san = sanitizer char_to_alpha char_to_alnumus in create_ident_printer bls ~sanitizer:san let print_ident info fmt id = fprintf fmt "%s" (id_unique info.info_printer id) let print_ident_label info fmt id = if info.info_show_labels then fprintf fmt "%s %a" (id_unique info.info_printer id) (print_list space print_label) (Slab.elements id.id_label) else print_ident info fmt id let forget_var info v = forget_id info.info_printer v.vs_name let collect_model_ls info ls = if ls.ls_args = [] && Slab.mem model_label ls.ls_name.id_label then let t = t_app ls [] ls.ls_value in info.info_model <- add_model_element (t_label ?loc:ls.ls_name.id_loc ls.ls_name.id_label t) info.info_model (* let tv_printer = let san = sanitizer char_to_lalpha char_to_alnumus in create_ident_printer [] ~sanitizer:san let print_tvsymbol fmt tv = fprintf fmt "'%s" (id_unique tv_printer tv.tv_name) let forget_tvs () = forget_all tv_printer *) (* work around a "duplicate type variable" bug of Alt-Ergo 0.94 *) let print_tvsymbol, forget_tvs = let htv = Hid.create 5 in (fun info fmt tv -> Hid.replace htv tv.tv_name (); fprintf fmt "'%s" (id_unique info.info_printer tv.tv_name)), (fun info -> Hid.iter (fun id _ -> forget_id info.info_printer id) htv; Hid.clear htv) let rec print_type info fmt ty = match ty.ty_node with | Tyvar id -> print_tvsymbol info fmt id | Tyapp (ts, tl) -> begin match query_syntax info.info_syn ts.ts_name with | Some s -> syntax_arguments s (print_type info) fmt tl | None -> fprintf fmt "%a%a" (print_tyapp info) tl (print_ident info) ts.ts_name end and print_tyapp info fmt = function | [] -> () | [ty] -> fprintf fmt "%a " (print_type info) ty | tl -> fprintf fmt "(%a) " (print_list comma (print_type info)) tl (* can the type of a value be derived from the type of the arguments? *) let unambig_fs fs = let rec lookup v ty = match ty.ty_node with | Tyvar u when tv_equal u v -> true | _ -> ty_any (lookup v) ty in let lookup v = List.exists (lookup v) fs.ls_args in let rec inspect ty = match ty.ty_node with | Tyvar u when not (lookup u) -> false | _ -> ty_all inspect ty in inspect (Opt.get fs.ls_value) let rec print_term info fmt t = if Slab.mem model_label t.t_label then info.info_model <- add_model_element t info.info_model; check_enter_vc_term t info.info_in_goal info.info_vc_term; let () = match t.t_node with | Tconst c -> let number_format = { Number.long_int_support = true; Number.extra_leading_zeros_support = true; Number.dec_int_support = Number.Number_default; Number.hex_int_support = Number.Number_unsupported; Number.oct_int_support = Number.Number_unsupported; Number.bin_int_support = Number.Number_unsupported; Number.def_int_support = Number.Number_unsupported; Number.dec_real_support = Number.Number_default; Number.hex_real_support = Number.Number_default; Number.frac_real_support = Number.Number_unsupported; Number.def_real_support = Number.Number_unsupported; } in Number.print number_format fmt c | Tvar { vs_name = id } -> print_ident info fmt id | Tapp (ls, tl) -> begin (match query_syntax info.info_syn ls.ls_name with | Some s -> syntax_arguments s (print_term info) fmt tl | None -> begin if (tl = []) then begin let vc_term_info = info.info_vc_term in if vc_term_info.vc_inside then begin match vc_term_info.vc_loc with | None -> () | Some loc -> let labels = match vc_term_info.vc_func_name with | None -> ls.ls_name.id_label | Some _ -> model_trace_for_postcondition ~labels:ls.ls_name.id_label info.info_vc_term in let _t_check_pos = t_label ~loc labels t in (* TODO: temporarily disable collecting variables inside the term triggering VC *) (*info.info_model <- add_model_element t_check_pos info.info_model;*) () end end; end; if (Mls.mem ls info.info_csm) then begin let print_field fmt ({ls_name = id},t) = fprintf fmt "%a =@ %a" (print_ident info) id (print_term info) t in fprintf fmt "{@ %a@ }" (print_list semi print_field) (List.combine (Mls.find ls info.info_csm) tl) end else if (Sls.mem ls info.info_pjs) then begin fprintf fmt "%a.%a" (print_tapp info) tl (print_ident info) ls.ls_name end else if (unambig_fs ls || not info.info_type_casts) then begin fprintf fmt "%a%a" (print_ident info) ls.ls_name (print_tapp info) tl end else begin fprintf fmt "(%a%a : %a)" (print_ident info) ls.ls_name (print_tapp info) tl (print_type info) (t_type t) end ) end | Tlet _ -> unsupportedTerm t "alt-ergo : you must eliminate let in term" | Tif _ -> unsupportedTerm t "alt-ergo : you must eliminate if_then_else" | Tcase _ -> unsupportedTerm t "alt-ergo : you must eliminate match" | Teps _ -> unsupportedTerm t "alt-ergo : you must eliminate epsilon" | Tquant _ | Tbinop _ | Tnot _ | Ttrue | Tfalse -> raise (TermExpected t) in check_exit_vc_term t info.info_in_goal info.info_vc_term; and print_tapp info fmt = function | [] -> () | tl -> fprintf fmt "(%a)" (print_list comma (print_term info)) tl let rec print_fmla info fmt f = if Slab.mem model_label f.t_label then info.info_model <- add_model_element f info.info_model; check_enter_vc_term f info.info_in_goal info.info_vc_term; let () = if info.info_show_labels then match Slab.elements f.t_label with | [] -> print_fmla_node info fmt f | l -> fprintf fmt "(%a : %a)" (print_list colon print_label) l (print_fmla_node info) f else print_fmla_node info fmt f in check_exit_vc_term f info.info_in_goal info.info_vc_term and print_fmla_node info fmt f = match f.t_node with | Tapp ({ ls_name = id }, []) -> print_ident info fmt id | Tapp (ls, tl) -> begin match query_syntax info.info_syn ls.ls_name with | Some s -> syntax_arguments s (print_term info) fmt tl | None -> fprintf fmt "%a(%a)" (print_ident info) ls.ls_name (print_list comma (print_term info)) tl end | Tquant (q, fq) -> let vl, tl, f = t_open_quant fq in let q, tl = match q with | Tforall -> "forall", tl | Texists -> "exists", [] (* Alt-ergo has no triggers for exists *) in let forall fmt v = fprintf fmt "%s %a:%a" q (print_ident_label info) v.vs_name (print_type info) v.vs_ty in fprintf fmt "@[(%a%a.@ %a)@]" (print_list dot forall) vl (print_triggers info) tl (print_fmla info) f; List.iter (forget_var info) vl | Tbinop (Tand, f1, f2) -> fprintf fmt "(%a and@ %a)" (print_fmla info) f1 (print_fmla info) f2 | Tbinop (Tor, f1, f2) -> fprintf fmt "(%a or@ %a)" (print_fmla info) f1 (print_fmla info) f2 | Tbinop (Timplies, f1, f2) -> fprintf fmt "(%a ->@ %a)" (print_fmla info) f1 (print_fmla info) f2 | Tbinop (Tiff, f1, f2) -> fprintf fmt "(%a <->@ %a)" (print_fmla info) f1 (print_fmla info) f2 | Tnot f -> fprintf fmt "(not %a)" (print_fmla info) f | Ttrue -> fprintf fmt "true" | Tfalse -> fprintf fmt "false" | Tif (f1, f2, f3) -> fprintf fmt "((%a and@ %a)@ or@ (not@ %a and@ %a))" (print_fmla info) f1 (print_fmla info) f2 (print_fmla info) f1 (print_fmla info) f3 | Tlet _ -> unsupportedTerm f "alt-ergo: you must eliminate let in formula" | Tcase _ -> unsupportedTerm f "alt-ergo: you must eliminate match" | Tvar _ | Tconst _ | Teps _ -> raise (FmlaExpected f) and print_expr info fmt = TermTF.t_select (print_term info fmt) (print_fmla info fmt) and print_triggers info fmt tl = let filter = function | { t_ty = Some _ } -> true | { t_node = Tapp (ps,_) } -> not (Sls.mem ps info.info_inv_trig) | _ -> false in let tl = List.map (List.filter filter) tl in let tl = List.filter (function [] -> false | _::_ -> true) tl in if tl = [] then () else fprintf fmt "@ [%a]" (print_list alt (print_list comma (print_expr info))) tl let print_logic_binder info fmt v = fprintf fmt "%a: %a" (print_ident info) v.vs_name (print_type info) v.vs_ty let print_type_decl info fmt ts = match ts.ts_args with | [] -> fprintf fmt "type %a" (print_ident info) ts.ts_name | [tv] -> fprintf fmt "type %a %a" (print_tvsymbol info) tv (print_ident info) ts.ts_name | tl -> fprintf fmt "type (%a) %a" (print_list comma (print_tvsymbol info)) tl (print_ident info) ts.ts_name let print_enum_decl info fmt ts csl = let print_cs fmt (ls,_) = print_ident info fmt ls.ls_name in fprintf fmt "@[type %a =@ %a@]@\n@\n" (print_ident info) ts.ts_name (print_list alt2 print_cs) csl let print_ty_decl info fmt ts = if is_alias_type_def ts.ts_def then () else if Mid.mem ts.ts_name info.info_syn then () else (fprintf fmt "%a@\n@\n" (print_type_decl info) ts; forget_tvs info) let print_data_decl info fmt = function | ts, csl (* monomorphic enumeration *) when ts.ts_args = [] && List.for_all (fun (_,l) -> l = []) csl -> print_enum_decl info fmt ts csl | ts, [cs,_] (* non-recursive records *) when Mls.mem cs info.info_csm -> let pjl = Mls.find cs info.info_csm in let print_field fmt ls = fprintf fmt "%a@ :@ %a" (print_ident info) ls.ls_name (print_type info) (Opt.get ls.ls_value) in fprintf fmt "%a@ =@ {@ %a@ }@\n@\n" (print_type_decl info) ts (print_list semi print_field) pjl | _, _ -> unsupported "alt-ergo : algebraic datatype are not supported" let print_data_decl info fmt ((ts, _csl) as p) = if Mid.mem ts.ts_name info.info_syn then () else print_data_decl info fmt p let print_param_decl info fmt ls = let sac = if Sls.mem ls info.info_ac then "ac " else "" in fprintf fmt "@[logic %s%a : %a%s%a@]@\n@\n" sac (print_ident info) ls.ls_name (print_list comma (print_type info)) ls.ls_args (if ls.ls_args = [] then "" else " -> ") (print_option_or_default "prop" (print_type info)) ls.ls_value let print_param_decl info fmt ls = if Mid.mem ls.ls_name info.info_syn || Sls.mem ls info.info_pjs then () else (print_param_decl info fmt ls; forget_tvs info) let print_logic_decl info fmt ls ld = collect_model_ls info ls; let vl,e = open_ls_defn ld in begin match e.t_ty with | Some _ -> (* TODO AC? *) fprintf fmt "@[function %a(%a) : %a =@ %a@]@\n@\n" (print_ident info) ls.ls_name (print_list comma (print_logic_binder info)) vl (print_type info) (Opt.get ls.ls_value) (print_term info) e | None -> fprintf fmt "@[predicate %a(%a) =@ %a@]@\n@\n" (print_ident info) ls.ls_name (print_list comma (print_logic_binder info)) vl (print_fmla info) e end; List.iter (forget_var info) vl let print_logic_decl info fmt (ls,ld) = if Mid.mem ls.ls_name info.info_syn || Sls.mem ls info.info_pjs then () else (print_logic_decl info fmt ls ld; forget_tvs info) let print_info_model cntexample info = (* Prints the content of info.info_model *) let info_model = info.info_model in if not (S.is_empty info_model) && cntexample then begin let model_map = S.fold (fun f acc -> fprintf str_formatter "%a" (print_fmla info) f; let s = flush_str_formatter () in Stdlib.Mstr.add s f acc) info_model Stdlib.Mstr.empty in (); (* Printing model has modification of info.info_model as undesirable side-effect. Revert it back. *) info.info_model <- info_model; model_map end else Stdlib.Mstr.empty let print_prop_decl vc_loc cntexample args info fmt k pr f = match k with | Paxiom -> fprintf fmt "@[axiom %a :@ %a@]@\n@\n" (print_ident info) pr.pr_name (print_fmla info) f | Pgoal -> let model_list = print_info_model cntexample info in args.printer_mapping <- { lsymbol_m = args.printer_mapping.lsymbol_m; vc_term_loc = vc_loc; queried_terms = model_list; }; fprintf fmt "@[goal %a :@ %a@]@\n" (print_ident info) pr.pr_name (print_fmla info) f | Plemma| Pskip -> assert false let print_prop_decl vc_loc cntexample args info fmt k pr f = if Mid.mem pr.pr_name info.info_syn || Spr.mem pr info.info_axs then () else (print_prop_decl vc_loc cntexample args info fmt k pr f; forget_tvs info) let print_decl vc_loc cntexample args info fmt d = match d.d_node with | Dtype ts -> print_ty_decl info fmt ts | Ddata dl -> print_list nothing (print_data_decl info) fmt dl | Dparam ls -> collect_model_ls info ls; print_param_decl info fmt ls | Dlogic dl -> print_list nothing (print_logic_decl info) fmt dl | Dind _ -> unsupportedDecl d "alt-ergo: inductive definitions are not supported" | Dprop (k,pr,f) -> print_prop_decl vc_loc cntexample args info fmt k pr f let add_projection (csm,pjs,axs) = function | [Theory.MAls ls; Theory.MAls cs; Theory.MAint ind; Theory.MApr pr] -> let csm = try Array.set (Mls.find cs csm) ind ls; csm with Not_found -> Mls.add cs (Array.make (List.length cs.ls_args) ls) csm in csm, Sls.add ls pjs, Spr.add pr axs | _ -> assert false let check_options ((show,cast) as acc) = function | [Theory.MAstr "show_labels"] -> true, cast | [Theory.MAstr "no_type_cast"] -> show, false | [Theory.MAstr _] -> acc | _ -> assert false let print_task args ?old:_ fmt task = let csm,pjs,axs = Task.on_meta Eliminate_algebraic.meta_proj add_projection (Mls.empty,Sls.empty,Spr.empty) task in let inv_trig = Task.on_tagged_ls meta_invalid_trigger task in let show,cast = Task.on_meta meta_printer_option check_options (false,true) task in let cntexample = Prepare_for_counterexmp.get_counterexmp task in let vc_loc = Intro_vc_vars_counterexmp.get_location_of_vc task in let vc_info = {vc_inside = false; vc_loc = None; vc_func_name = None} in let info = { info_syn = Discriminate.get_syntax_map task; info_ac = Task.on_tagged_ls meta_ac task; info_show_labels = show; info_type_casts = cast; info_csm = Mls.map Array.to_list csm; info_pjs = pjs; info_axs = axs; info_inv_trig = Sls.add ps_equ inv_trig; info_printer = ident_printer (); info_model = S.empty; info_vc_term = vc_info; info_in_goal = false;} in print_prelude fmt args.prelude; print_th_prelude task fmt args.th_prelude; let rec print_decls = function | Some t -> print_decls t.Task.task_prev; begin match t.Task.task_decl.Theory.td_node with | Theory.Decl d -> begin try print_decl vc_loc cntexample args info fmt d with Unsupported s -> raise (UnsupportedDecl (d,s)) end | _ -> () end | None -> () in print_decls task; pp_print_flush fmt () let () = register_printer "alt-ergo" print_task ~desc:"Printer for the Alt-Ergo theorem prover." why3-0.88.3/src/printer/cntexmp_printer.ml0000664000175100017510000001404013225666037021300 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Format open Ident open Term (* Information about the term that triggers VC. *) type vc_term_info = { mutable vc_inside : bool; (* true if the term that triggers VC is currently processed *) mutable vc_loc : Loc.position option; (* the position of the term that triggers VC *) mutable vc_func_name : string option; (* the name of the function for that VC was made. None if VC is not generated for postcondition or precondition) *) } module TermCmp = struct type t = term let before loc1 loc2 = (* Return true if loc1 is strictly before loc2 *) match loc1 with | None -> false | Some loc1 -> match loc2 with | None -> false | Some loc2 -> let (_, line1, col1, _) = Loc.get loc1 in let (_, line2, col2, _) = Loc.get loc2 in if line1 <> line2 then if line1 < line2 then true else false else if col1 < col2 then true else false let compare a b = if (a.t_loc = b.t_loc) && (a.t_label = b.t_label) then 0 else (* Order the terms accoridng to their source code locations *) if before a.t_loc b.t_loc then 1 else -1 end module S = Set.Make(TermCmp) let model_trace_regexp = Str.regexp "model_trace:" (* The term labeled with "model_trace:name" will be in counter-example with name "name" *) let label_starts_with regexp l = try ignore(Str.search_forward regexp l.lab_string 0); true with Not_found -> false let get_label labels regexp = Slab.choose (Slab.filter (label_starts_with regexp) labels) let print_label fmt l = fprintf fmt "\"%s\"" l.lab_string let model_label = Ident.create_label "model" (* This label identifies terms that should be in counter-example. *) let model_vc_term_label = Ident.create_label "model_vc" (* This label identifies the term that triggers the VC. *) let add_model_element (el: term) info_model = (** Add element el (term) to info_model. If an element with the same hash (the same set of labels + the same location) as the element el already exists in info_model, replace it with el. The reason is that we do not want to display two model elements with the same name in the same location and usually it is better to display the last one. Note that two model elements can have the same name and location if why is used as an intemediate language and the locations are locations in the source language. Then, more why constructs (terms) can represent a single construct in the source language and more terms have thus the same model name and location. This happens, e.g., if why code is generated from SPARK. There, the first iteration of while cycle is unrolled in some cases. If the task contains both a term representing a variable in the first iteration of unrolled loop and a term representing the variable in the subsequent loop iterations, only the latter is relevant for the counterexample and it is the one that comes after the former one (and that is why we always keep the last term). *) let info_model = S.remove el info_model in S.add el info_model let add_old lab_str = try let pos = Str.search_forward (Str.regexp "@") lab_str 0 in let after = String.sub lab_str pos ((String.length lab_str)-pos) in if after = "@init" then (String.sub lab_str 0 pos) ^ "@old" else lab_str with Not_found -> lab_str ^ "@old" let model_trace_for_postcondition ~labels (info: vc_term_info) = (* Modifies the model_trace label of a term in the postcondition: - if term corresponds to the initial value of a function parameter, model_trace label will have postfix @old - if term corresponds to the return value of a function, add model_trace label in a form function_name@result *) try let trace_label = get_label labels model_trace_regexp in let lab_str = add_old trace_label.lab_string in if lab_str = trace_label.lab_string then labels else let other_labels = Slab.remove trace_label labels in Slab.add (Ident.create_label lab_str) other_labels with Not_found -> (* no model_trace label => the term represents the return value *) Slab.add (Ident.create_label ("model_trace:" ^ (Opt.get_def "" info.vc_func_name) ^ "@result")) labels let get_fun_name name = let splitted = Strings.bounded_split ':' name 2 in match splitted with | _::[second] -> second | _ -> "" let check_enter_vc_term t in_goal vc_term_info = (* Check whether the term that triggers VC is entered. If it is entered, extract the location of the term and if the VC is postcondition or precondition of a function, extract the name of the corresponding function. *) if in_goal && Slab.mem model_vc_term_label t.t_label then begin vc_term_info.vc_inside <- true; vc_term_info.vc_loc <- t.t_loc; try (* Label "model_func" => the VC is postcondition or precondition *) (* Extract the function name from "model_func" label *) let fun_label = get_label t.t_label (Str.regexp "model_func") in vc_term_info.vc_func_name <- Some (get_fun_name fun_label.lab_string); with Not_found -> (* No label "model_func" => the VC is not postcondition or precondition *) () end let check_exit_vc_term t in_goal info = (* Check whether the term triggering VC is exited. *) if in_goal && Slab.mem model_vc_term_label t.t_label then begin info.vc_inside <- false; end why3-0.88.3/src/printer/pvs.ml0000664000175100017510000007602613225666037016703 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** PVS printer *) (* QUESTIONS FOR THE PVS TEAM -------------------------- * tuples (there are native tuples in Why3) - in Why3, we have 0-tuples as well, i.e. a type "()" with a single value also written "()" currently, I'm using tuple0: DATATYPE BEGIN Tuple0: Tuple0? END tuple0 - it looks like PVS does not allow me to perform pattern-matching (CASES) on tuples i.e something like CASES x1 OF (x2, x3): ... ENDCASES so I'm doing that instead: LET x2 = x1`1, x3 = x1`2 IN ... better: LET (x2, x3) = x1 IN ... TODO ---- * driver - maps: const * use proveit (same path as PVS) to replay a proof *) open Format open Pp open Ident open Ty open Term open Decl open Printer let black_list = [ "and"; "conjecture"; "fact"; "let"; "table"; "andthen"; "containing"; "false"; "library"; "then"; "array"; "conversion"; "forall"; "macro"; "theorem"; "assuming"; "conversion+"; "formula"; "measure"; "theory"; "assumption"; "conversion-"; "from"; "nonempty"; "type"; "true"; "auto"; "rewrite"; "corollary"; "function"; "not"; "type"; "auto"; "rewrite+";" datatype"; "has"; "type"; "o"; "type+"; "auto"; "rewrite-"; "else"; "if"; "obligation"; "var"; "axiom"; "elsif"; "iff"; "of"; "when"; "begin"; "end"; "implies"; "or"; "where"; "but"; "endassuming"; "importing"; "orelse"; "with"; "by"; "endcases"; "in"; "postulate"; "xor"; "cases"; "endcond"; "inductive"; "proposition"; "challenge"; "endif"; "judgement"; "recursive"; "claim"; "endtable"; "lambda"; "sublemma"; "closure"; "exists"; "law"; "subtypes"; "cond"; "exporting"; "lemma"; "subtype"; "of"; (* PVS prelude *) "boolean"; "bool"; "pred"; "setof"; "exists1"; "list"; "length"; "member"; "nth"; "append"; "reverse"; "domain"; "range"; "graph"; "preserves"; "inverts"; "transpose"; "restrict"; "extend"; "identity"; "eq"; "epsilon"; "set"; "member"; "emptyset"; "nonempty_set"; "fullset"; "union"; "intersection"; "complement"; "difference"; "symmetric_difference"; "every"; "some"; "singleton"; "add"; "remove"; "choose"; "the"; "singleton_elt"; "rest"; "setofsets"; "powerset"; "rinverse"; "rcomplement"; "runion"; "rintersection"; "image"; "preimage"; "postcondition"; "converse"; "number"; "number_field"; "numfield"; "nonzero_number"; "nznum"; "real"; "nonzero_real"; "nzreal"; "nonneg_real"; "nonpos_real"; "posreal"; "negreal"; "nnreal"; "npreal"; "rational"; "rat"; "nonzero_rational"; "nzrat"; "nonneg_rat"; "nonpos_rat"; "posrat"; "negrat"; "nnrat"; "nprat"; "integer"; "int"; "nonzero_integer"; "nzint"; "nonneg_int"; "nonpos_int"; "posint"; "negint"; "nnint"; "npint"; "subrange"; "even_int"; "odd_int"; "naturalnumber"; "nat"; "upto"; "below"; "succ"; "pred"; "min"; "max"; "sgn"; "abs"; "mod"; "divides"; "rem"; "ndiv"; "upfrom"; "above"; "even"; ] let fresh_printer () = let isanitize = sanitizer char_to_lalpha char_to_lalnumus in create_ident_printer black_list ~sanitizer:isanitize let iprinter = let isanitize = sanitizer char_to_lalpha char_to_lalnumus in create_ident_printer black_list ~sanitizer:isanitize let forget_all () = forget_all iprinter let tv_set = ref Sid.empty let thprinter = let isanitize = sanitizer char_to_alpha char_to_alnumus in create_ident_printer black_list ~sanitizer:isanitize (* type variables *) let print_tv fmt tv = let n = id_unique iprinter tv.tv_name in fprintf fmt "%s" n let print_tv_binder fmt tv = tv_set := Sid.add tv.tv_name !tv_set; let n = id_unique iprinter tv.tv_name in fprintf fmt "%s:TYPE+" n let print_params_list fmt = function | [] -> () | tvl -> fprintf fmt "[%a]" (print_list comma print_tv_binder) tvl let print_params fmt stv = print_params_list fmt (Stv.elements stv) let forget_tvs () = Sid.iter (forget_id iprinter) !tv_set; tv_set := Sid.empty (* logic variables *) let print_vs fmt vs = let n = id_unique iprinter vs.vs_name in fprintf fmt "%s" n let forget_var vs = forget_id iprinter vs.vs_name let print_ts fmt ts = fprintf fmt "%s" (id_unique iprinter ts.ts_name) let print_ls fmt ls = fprintf fmt "%s" (id_unique iprinter ls.ls_name) let print_pr fmt pr = fprintf fmt "%s" (id_unique iprinter pr.pr_name) let print_name fmt id = fprintf fmt "%% Why3 %s@\n" (id_unique iprinter id) let get_th_name id = let s = id_unique thprinter id in Ident.forget_all thprinter; s (* info *) type info = { info_syn : syntax_map; symbol_printers : (string * Theory.theory * ident_printer) Mid.t; realization : bool; } let print_path = print_list (constant_string ".") string let print_id fmt id = string fmt (id_unique iprinter id) let print_id_real info fmt id = try let path, th, ipr = Mid.find id info.symbol_printers in let th = get_th_name th.Theory.th_name in let id = id_unique ipr id in if path = "" then fprintf fmt "%s.%s" th id else fprintf fmt "%s@@%s.%s" path th id with Not_found -> print_id fmt id let print_ls_real info fmt ls = print_id_real info fmt ls.ls_name let print_ts_real info fmt ts = print_id_real info fmt ts.ts_name let print_pr_real info fmt pr = print_id_real info fmt pr.pr_name (** Types *) let rec print_ty info fmt ty = match ty.ty_node with | Tyvar v -> print_tv fmt v | Tyapp (ts, tl) when is_ts_tuple ts -> begin match tl with | [] -> fprintf fmt "[]" | [ty] -> print_ty info fmt ty | _ -> fprintf fmt "[%a]" (print_list comma (print_ty info)) tl end | Tyapp (ts, tl) -> begin match query_syntax info.info_syn ts.ts_name with | Some s -> syntax_arguments s (print_ty info) fmt tl | None -> begin match tl with | [] -> (print_ts_real info) fmt ts | l -> fprintf fmt "%a[%a]" (print_ts_real info) ts (print_list comma (print_ty info)) l end end (* can the type of a value be derived from the type of the arguments? *) let unambig_fs fs = let rec lookup v ty = match ty.ty_node with | Tyvar u when tv_equal u v -> true | _ -> ty_any (lookup v) ty in let lookup v = List.exists (lookup v) fs.ls_args in let rec inspect ty = match ty.ty_node with | Tyvar u when not (lookup u) -> false | _ -> ty_all inspect ty in inspect (Opt.get fs.ls_value) (** Patterns, terms, and formulas *) let lparen_l fmt () = fprintf fmt "@ (" let lparen_r fmt () = fprintf fmt "(@," let print_paren_l fmt x = print_list_delim ~start:lparen_l ~stop:rparen ~sep:comma fmt x let print_paren_r fmt x = print_list_delim ~start:lparen_r ~stop:rparen ~sep:comma fmt x let arrow fmt () = fprintf fmt "@ -> " let print_arrow_list fmt x = print_list arrow fmt x let print_space_list fmt x = print_list space fmt x let print_comma_list fmt x = print_list comma fmt x let print_or_list fmt x = print_list (fun fmt () -> fprintf fmt " OR@\n") fmt x let comma_newline fmt () = fprintf fmt ",@\n" let rec print_pat info fmt p = match p.pat_node with | Pvar v -> print_vs fmt v | Papp (cs, _) when is_fs_tuple cs -> assert false (* is handled earlier in print_term/fmla *) | Papp (cs, pl) -> begin match query_syntax info.info_syn cs.ls_name with | Some s -> syntax_arguments s (print_pat info) fmt pl | _ when pl = [] -> (print_ls_real info) fmt cs | _ -> fprintf fmt "%a(%a)" (print_ls_real info) cs (print_list comma (print_pat info)) pl end | Pas _ | Por _ -> assert false (* compile_match must have taken care of that *) | Pwild -> assert false (* is handled in print_branches *) let print_vsty_nopar info fmt v = fprintf fmt "%a:%a" print_vs v (print_ty info) v.vs_ty let print_vsty info fmt v = fprintf fmt "(%a)" (print_vsty_nopar info) v let is_tuple0_ty = function | Some { ty_node = Tyapp (ts, _) } -> ts_equal ts (ts_tuple 0) | Some _ | None -> false let is_tuple_ty = function | Some { ty_node = Tyapp (ts, _) } -> is_ts_tuple ts | Some _ | None -> false let print_binop fmt = function | Tand -> fprintf fmt "AND" | Tor -> fprintf fmt "OR" | Timplies -> fprintf fmt "=>" | Tiff -> fprintf fmt "<=>" (* TODO: labels are lost, but we could print them as "% label \n", it would result in an ugly output, though *) let print_label _fmt (_l,_) = () (*fprintf fmt "(*%s*)" l*) let protect_on x s = if x then "(" ^^ s ^^ ")" else s let rec print_term info fmt t = print_lrterm false false info fmt t and print_fmla info fmt f = print_lrfmla false false info fmt f and print_opl_term info fmt t = print_lrterm true false info fmt t and print_opl_fmla info fmt f = print_lrfmla true false info fmt f and print_opr_term info fmt t = print_lrterm false true info fmt t and print_opr_fmla info fmt f = print_lrfmla false true info fmt f and print_lrterm opl opr info fmt t = match t.t_label with | _ -> print_tnode opl opr info fmt t and print_lrfmla opl opr info fmt f = match f.t_label with | _ -> print_fnode opl opr info fmt f and print_tnode opl opr info fmt t = match t.t_node with | Tvar v -> print_vs fmt v | Tconst c -> let number_format = { Number.long_int_support = true; Number.extra_leading_zeros_support = true; Number.dec_int_support = Number.Number_custom "%s"; Number.hex_int_support = Number.Number_unsupported; Number.oct_int_support = Number.Number_unsupported; Number.bin_int_support = Number.Number_unsupported; Number.def_int_support = Number.Number_unsupported; Number.dec_real_support = Number.Number_unsupported; Number.hex_real_support = Number.Number_unsupported; Number.frac_real_support = Number.Number_custom (Number.PrintFracReal ("%s", "(%s * %s)", "(%s / %s)")); Number.def_real_support = Number.Number_unsupported; } in Number.print number_format fmt c | Tif (f, t1, t2) -> fprintf fmt "IF %a@ THEN %a@ ELSE %a ENDIF" (print_fmla info) f (print_term info) t1 (print_opl_term info) t2 | Tlet (t1, tb) -> let v,t2 = t_open_bound tb in fprintf fmt (protect_on opr "LET %a =@ %a IN@ %a") print_vs v (print_opl_term info) t1 (print_opl_term info) t2; forget_var v | Tcase (t, [b]) when is_tuple0_ty t.t_ty -> let _,t = t_open_branch b in print_term info fmt t | Tcase (t, [b]) when is_tuple_ty t.t_ty -> let p,t1 = t_open_branch b in fprintf fmt "@[LET %a IN@ %a@]" (print_tuple_pat info t) p (print_term info) t1; Svs.iter forget_var p.pat_vars | Tcase (t, bl) -> fprintf fmt "CASES %a OF@\n@[%a@]@\nENDCASES" (print_term info) t (print_branches print_term info) bl | Teps fb -> let v,f = t_open_bound fb in fprintf fmt (protect_on opr "epsilon(LAMBDA (%a):@ %a)") (print_vsty_nopar info) v (print_opl_fmla info) f; forget_var v | Tapp (fs, []) when is_fs_tuple fs -> fprintf fmt "()" | Tapp (fs, pl) when is_fs_tuple fs -> fprintf fmt "%a" (print_paren_r (print_term info)) pl | Tapp (fs, tl) -> begin match query_syntax info.info_syn fs.ls_name with | Some s -> syntax_arguments_typed s (print_term info) (print_ty info) t fmt tl | _ -> let no_cast = unambig_fs fs in begin match tl with | [] when no_cast -> fprintf fmt "%a" (print_ls_real info) fs | [] -> fprintf fmt "(%a :: %a)" (print_ls_real info) fs (print_ty info) (t_type t) | _ when no_cast -> fprintf fmt "%a(%a)" (print_ls_real info) fs (print_comma_list (print_term info)) tl |_ -> fprintf fmt (protect_on opl "(%a(%a) :: %a)") (print_ls_real info) fs (print_comma_list (print_term info)) tl (print_ty info) (t_type t) end end | Tquant _ | Tbinop _ | Tnot _ | Ttrue | Tfalse -> raise (TermExpected t) and print_fnode opl opr info fmt f = match f.t_node with | Tquant (Tforall, fq) -> let vl,_tl,f = t_open_quant fq in fprintf fmt (protect_on opr "FORALL (%a):@ %a") (print_comma_list (print_vsty_nopar info)) vl (* (print_tl info) tl *) (print_fmla info) f; List.iter forget_var vl | Tquant (Texists,fq) -> let vl,_tl,f = t_open_quant fq in let rec aux fmt vl = match vl with | [] -> print_fmla info fmt f | v :: vr -> fprintf fmt (protect_on opr "EXISTS (%a):@ %a") (print_vsty_nopar info) v aux vr in aux fmt vl; List.iter forget_var vl | Ttrue -> fprintf fmt "TRUE" | Tfalse -> fprintf fmt "FALSE" | Tbinop (b, f1, f2) -> fprintf fmt (protect_on (opl || opr) "%a %a@ %a") (print_opr_fmla info) f1 print_binop b (print_opl_fmla info) f2 | Tnot f -> fprintf fmt (protect_on opr "NOT %a") (print_opl_fmla info) f | Tlet (t, f) -> let v,f = t_open_bound f in fprintf fmt (protect_on opr "LET %a =@ %a IN@ %a") print_vs v (print_opl_term info) t (print_opl_fmla info) f; forget_var v | Tcase (t, [b]) when is_tuple0_ty t.t_ty -> let _,f = t_open_branch b in print_fmla info fmt f | Tcase (t, [b]) when is_tuple_ty t.t_ty -> let p,f = t_open_branch b in fprintf fmt "@[LET %a IN@ %a@]" (print_tuple_pat info t) p (print_fmla info) f; Svs.iter forget_var p.pat_vars | Tcase (t, bl) -> fprintf fmt "CASES %a OF@\n@[%a@]@\nENDCASES" (print_term info) t (print_branches print_fmla info) bl | Tif (f1, f2, f3) -> fprintf fmt (protect_on opr "IF %a@ THEN %a@ ELSE %a ENDIF") (print_fmla info) f1 (print_fmla info) f2 (print_opl_fmla info) f3 | Tapp (ps, tl) -> begin match query_syntax info.info_syn ps.ls_name with | Some s -> syntax_arguments s (print_term info) fmt tl | None when tl = [] -> fprintf fmt "%a" (print_ls_real info) ps | None -> fprintf fmt "%a(%a)" (print_ls_real info) ps (print_comma_list (print_term info)) tl end | Tvar _ | Tconst _ | Teps _ -> raise (FmlaExpected f) and print_tuple_pat info t fmt p = let unvar p = match p.pat_node with | Pvar vs -> vs | _ -> assert false (*TODO?*) in let l = match p.pat_node with | Papp (_, pl) -> List.map unvar pl | _ -> assert false in let i = ref 0 in let print fmt vs = incr i; fprintf fmt "%a = %a`%d" (print_vsty_nopar info) vs (print_term info) t !i in print_comma_list print fmt l and print_branch print info fmt br = let p,t = t_open_branch br in fprintf fmt "@[ %a:@ %a@]" (print_pat info) p (print info) t; Svs.iter forget_var p.pat_vars and print_branches ?(first=true) print info fmt = function | [] -> () | br :: bl -> let p, t = t_open_branch br in begin match p.pat_node with | Pwild -> assert (bl = []); if not first then fprintf fmt "@\n"; fprintf fmt "@[ELSE@ %a@]" (print info) t | _ -> if not first then fprintf fmt ",@\n"; fprintf fmt "@[ %a:@ %a@]" (print_pat info) p (print info) t; Svs.iter forget_var p.pat_vars; print_branches ~first:false print info fmt bl end let print_expr info fmt = TermTF.t_select (print_term info fmt) (print_fmla info fmt) (** Declarations *) let print_constr info _ts fmt (cs,_) = match cs.ls_args with | [] -> fprintf fmt "@[%a: %a?@]" print_ls cs print_ls cs | l -> let sid = ref Sid.empty in let print fmt ty = let n = id_register (id_fresh "x") in sid := Sid.add n !sid; fprintf fmt "%s:%a" (id_unique iprinter n) (print_ty info) ty in fprintf fmt "@[%a(%a): %a?@]" print_ls cs (print_comma_list print) l print_ls cs; Sid.iter (forget_id iprinter) !sid let ls_ty_vars ls = let ty_vars_args = List.fold_left Ty.ty_freevars Stv.empty ls.ls_args in let ty_vars_value = Opt.fold Ty.ty_freevars Stv.empty ls.ls_value in (ty_vars_args, ty_vars_value, Stv.union ty_vars_args ty_vars_value) (* copy of old user scripts *) let clean_line s = let n = String.length s in if n >= 2 && s.[0] = ' ' && s.[1] = ' ' then String.sub s 2 (n - 2) else s type contents = string list type chunk = | Edition of string * contents (* name contents *) | Other of contents (* contents *) let re_blank = Str.regexp "[ ]*$" let re_why3 = Str.regexp "% Why3 \\([^ ]+\\)" (* Reads an old version of the file, as a list of chunks. Each chunk is either identified as a Why3 symbol (Edition) or as something else (Other). Note: the very last chunk is purposely ignored, as it is "END th" *) let read_old_script ch = let chunks = ref [] in let contents = ref [] in let read_line () = let s = input_line ch in clean_line s in (* skip first lines, until we find a blank line *) begin try while true do let s = read_line () in if Str.string_match re_blank s 0 then raise Exit done with End_of_file | Exit -> () end; (* then read chunks *) let rec read ?name () = let s = read_line () in if s = "" then begin new_chunk ?name (); read () end else if Str.string_match re_why3 s 0 then begin new_chunk ?name (); let name = Str.matched_group 1 s in read ~name () end else begin contents := s :: !contents; read ?name () end and new_chunk ?name () = let s = List.rev !contents in contents := []; match s, name with | ([] | [""]), _ -> () | _, None -> chunks := Other s :: !chunks | _, Some n -> chunks := Edition (n, s) :: !chunks in try read () with End_of_file -> List.rev !chunks (* DEBUG let read_old_script ch = let cl = read_old_script ch in let dump = function | Edition (n, s) -> eprintf "/edited %s = @[%a@]" n (print_list newline pp_print_string) s | Other _s -> eprintf "/other" in List.iter dump cl; eprintf "@."; cl *) let print_contents fmt c = print_list newline pp_print_string fmt c (* Output all the Other entries of the script that occur before the location of name. Modify the script by removing the name entry and all these outputs. Return the user content, if any. *) let output_till_statement fmt script name = let print i = let rec aux acc = function | h :: l when h == i -> let l = match l with Other [""] :: l -> l | _ -> l in script := List.rev_append acc l | Other o :: l -> fprintf fmt "%a@\n@\n" print_contents o; aux acc l | h :: l -> aux (h :: acc) l | [] -> assert false in aux [] !script in let rec find = function | Edition (n,_) as o :: _ when n = name -> print o; Some o | [] -> None | _ :: t -> find t in find !script let print_contents_in_comment fmt c = let print fmt s = if s = "" || s.[0] <> '%' then fprintf fmt "%% "; fprintf fmt "%s" s in print_list newline print fmt c let output_remaining fmt cl = let print fmt = function | Edition (n, c) -> fprintf fmt "%% Obsolete chunk %s@\n%a@\n" n print_contents_in_comment c | Other c -> fprintf fmt "%a@\n" print_contents_in_comment c in print_list newline print fmt cl (* Extracts and prints a definition from a user-edited chunk, if any; otherwise, prints nothing *) let print_user_def fmt c = let rec scan_string _stack i s = let n = String.length s in if i = n then None else match s.[i] with | '=' -> Some (String.sub s i (n - i)) | _ -> scan_string _stack (i+1) s in let rec scan_chunck _stack = function | [] -> () | s :: c -> begin match scan_string _stack 0 s with | Some s -> fprintf fmt " %s" s; print_contents fmt c | None -> scan_chunck _stack c end in scan_chunck [] c let realization fmt info = function | Some (Edition (_, c)) when info.realization -> print_user_def fmt c | _ -> () let print_type_decl ~prev info fmt ts = ignore (prev); if not (is_ts_tuple ts) then begin print_name fmt ts.ts_name; match ts.ts_def with | NoDef | Range _ | Float _ -> fprintf fmt "@[%a%a: TYPE+" print_ts ts print_params_list ts.ts_args; realization fmt info prev; fprintf fmt "@]@\n@\n" | Alias ty -> fprintf fmt "@[%a%a: TYPE+ =@ %a@]@\n@\n" print_ts ts print_params_list ts.ts_args (print_ty info) ty end let print_type_decl ~prev info fmt ts = if not (Mid.mem ts.ts_name info.info_syn) then begin print_type_decl ~prev info fmt ts; forget_tvs () end let print_data_decl info fmt (ts,csl) = if not (is_ts_tuple ts) then begin print_name fmt ts.ts_name; fprintf fmt "@[%a%a: DATATYPE@\n@[BEGIN@\n%a@]@\nEND %a@]@\n@\n" print_ts ts print_params_list ts.ts_args (print_list newline (print_constr info ts)) csl print_ts ts end let print_data_decl info fmt d = if not (Mid.mem (fst d).ts_name info.info_syn) then begin print_data_decl info fmt d; forget_tvs () end let print_ls_type info fmt = function | None -> fprintf fmt "bool" | Some ty -> print_ty info fmt ty let create_argument ty = create_vsymbol (id_fresh "x") ty let print_arguments info fmt = function | [] -> () | vl -> fprintf fmt "(%a)" (print_comma_list (print_vsty_nopar info)) vl let re_macro = Str.regexp "\\bMACRO\\b" let has_macro s = try let _ = Str.search_forward re_macro s 0 in true with Not_found -> false let is_macro info fmt = function | Some (Edition (_, c)) when info.realization && List.exists has_macro c -> fprintf fmt "MACRO " | _ -> () let print_param_decl ~prev info fmt ls = ignore prev; let _, _, all_ty_params = ls_ty_vars ls in let vl = List.map create_argument ls.ls_args in print_name fmt ls.ls_name; fprintf fmt "@[%a%a%a: %a%a" print_ls ls print_params all_ty_params (print_arguments info) vl (is_macro info) prev (print_ls_type info) ls.ls_value; realization fmt info prev; List.iter forget_var vl; fprintf fmt "@]@\n@\n" let print_param_decl ~prev info fmt ls = if not (Mid.mem ls.ls_name info.info_syn) then begin print_param_decl ~prev info fmt ls; forget_tvs () end let print_logic_decl ~prev info fmt (ls,ld) = ignore prev; let _, _, all_ty_params = ls_ty_vars ls in let vl,e = open_ls_defn ld in print_name fmt ls.ls_name; fprintf fmt "@[%a%a%a: %a =@ %a@]@\n@\n" print_ls ls print_params all_ty_params (print_arguments info) vl (print_ls_type info) ls.ls_value (print_expr info) e; List.iter forget_var vl let print_logic_decl ~prev info fmt d = if not (Mid.mem (fst d).ls_name info.info_syn) then begin print_logic_decl ~prev info fmt d; forget_tvs () end let print_recursive_decl info fmt (ls,ld) = let _, _, all_ty_params = ls_ty_vars ls in let i = match Decl.ls_defn_decrease ld with | [i] -> i | _ -> assert false in let vl,e = open_ls_defn ld in print_name fmt ls.ls_name; fprintf fmt "@[%a%a%a: RECURSIVE %a =@ %a@\n" print_ls ls print_params all_ty_params (print_arguments info) vl (print_ls_type info) ls.ls_value (print_expr info) e; fprintf fmt "MEASURE %a BY <<@\n@]@\n" print_vs (List.nth vl i); List.iter forget_var vl let print_recursive_decl info fmt d = if not (Mid.mem (fst d).ls_name info.info_syn) then begin print_recursive_decl info fmt d; forget_tvs () end let print_ind info fmt (pr,f) = fprintf fmt "@[%% %a:@\n(%a)@]" print_pr pr (print_fmla info) f let print_ind_decl info fmt (ps,al) = let _, _, all_ty_params = ls_ty_vars ps in let vl = List.map (create_vsymbol (id_fresh "z")) ps.ls_args in let tl = List.map t_var vl in let dj = Lists.map_join_left (Eliminate_inductive.exi tl) t_or al in print_name fmt ps.ls_name; fprintf fmt "@[%a%a%a: INDUCTIVE bool =@ @[%a@]@]@\n" print_ls ps print_params all_ty_params (print_arguments info) vl (print_fmla info) dj; fprintf fmt "@\n" let print_ind_decl info fmt d = if not (Mid.mem (fst d).ls_name info.info_syn) then begin print_ind_decl info fmt d; forget_tvs () end let re_lemma = Str.regexp "\\(\\bLEMMA\\b\\|\\bTHEOREM\\b\\)" let rec find_lemma = function | [] -> "AXIOM" | s :: sl -> (try let _ = Str.search_forward re_lemma s 0 in Str.matched_group 1 s with Not_found -> find_lemma sl) let axiom_or_lemma = function | Some (Edition (_, c)) -> find_lemma c | _ -> "AXIOM" let print_prop_decl ~prev info fmt (k,pr,f) = ignore (prev); let params = t_ty_freevars Stv.empty f in let kind = match k with | Paxiom when info.realization -> "LEMMA" (* axiom_or_lemma prev *) | Paxiom -> "AXIOM" | Plemma -> "LEMMA" | Pgoal -> "THEOREM" | Pskip -> assert false (* impossible *) in print_name fmt pr.pr_name; fprintf fmt "@[%a%a: %s %a@]@\n@\n" print_pr pr print_params params kind (print_fmla info) f; forget_tvs () let print_decl ~old info fmt d = let name = match d.d_node with | Dtype ts | Ddata ((ts, _) :: _) -> id_unique iprinter ts.ts_name | Dparam ls | Dlogic ((ls, _) :: _) | Dind (_, (ls,_) :: _) -> id_unique iprinter ls.ls_name | Dprop (_, pr, _) -> id_unique iprinter pr.pr_name | Ddata [] | Dlogic [] | Dind (_, []) -> assert false in let prev = output_till_statement fmt old name in match d.d_node with | Dtype ts -> print_type_decl ~prev info fmt ts | Ddata tl -> print_list nothing (print_data_decl info) fmt tl | Dparam ls -> print_param_decl ~prev info fmt ls | Dlogic [s, _ as ld] when not (Sid.mem s.ls_name d.d_syms) -> print_logic_decl ~prev info fmt ld | Dlogic [d] -> print_recursive_decl info fmt d | Dlogic _ -> unsupportedDecl d "PVS does not support mutually recursive definitions" | Dind (Ind, il) -> print_list nothing (print_ind_decl info) fmt il | Dind (Coind, _) -> unsupportedDecl d "PVS: coinductive definitions are not supported" | Dprop (_, pr, _) when Mid.mem pr.pr_name info.info_syn -> () | Dprop pr -> print_prop_decl ~prev info fmt pr let print_decls ~old info fmt dl = fprintf fmt "@[%a@]" (print_list nothing (print_decl ~old info)) dl let init_printer th = let isanitize = sanitizer char_to_alpha char_to_alnumus in let pr = create_ident_printer black_list ~sanitizer:isanitize in Sid.iter (fun id -> ignore (id_unique pr id)) th.Theory.th_local; pr let print_task printer_args realize ?old fmt task = forget_all (); print_prelude fmt printer_args.prelude; print_th_prelude task fmt printer_args.th_prelude; (* find theories that are both used and realized from metas *) let realized_theories = Task.on_meta meta_realized_theory (fun mid args -> match args with | [Theory.MAstr s1; Theory.MAstr s2] -> let f,id = let l = Strings.rev_split '.' s1 in List.rev (List.tl l), List.hd l in let th = Env.read_theory printer_args.env f id in Mid.add th.Theory.th_name (th, (f, if s2 = "" then String.concat "." f else s2)) mid | _ -> assert false ) Mid.empty task in (* two cases: task is clone T with [] or task is a real goal *) let rec upd_realized_theories = function | Some { Task.task_decl = { Theory.td_node = Theory.Decl { Decl.d_node = Decl.Dprop (Decl.Pgoal, pr, _) }}} -> get_th_name pr.pr_name, [], realized_theories | Some { Task.task_decl = { Theory.td_node = Theory.Clone (th,_) }} -> Sid.iter (fun id -> ignore (id_unique iprinter id)) th.Theory.th_local; let id = th.Theory.th_name in get_th_name id, th.Theory.th_path, Mid.remove id realized_theories | Some { Task.task_decl = { Theory.td_node = Theory.Meta _ }; Task.task_prev = task } -> upd_realized_theories task | _ -> assert false in let thname, thpath, realized_theories = upd_realized_theories task in (* make names as stable as possible by first printing all identifiers *) let realized_theories' = Mid.map fst realized_theories in let realized_symbols = Task.used_symbols realized_theories' in let local_decls = Task.local_decls task realized_symbols in let symbol_printers = let printers = Mid.map (fun th -> let pr = fresh_printer () in Sid.iter (fun id -> ignore (id_unique pr id)) th.Theory.th_local; pr) realized_theories' in Mid.map (fun th -> let _, (p, s) = Mid.find th.Theory.th_name realized_theories in let s = if p = thpath then "" else s in (s, th, Mid.find th.Theory.th_name printers)) realized_symbols in let info = { info_syn = get_syntax_map task; symbol_printers = symbol_printers; realization = realize; } in (* (\* build IMPORTING declarations *\) *) (* let libraries = Hashtbl.create 17 in (\* path -> library name *\) *) (* let importing = Hashtbl.create 17 in (\* library name -> theory name *\) *) (* let add _ (th, (path, _)) = *) (* if not (Hashtbl.mem libraries path) then begin *) (* let libname = String.concat "_" ("why3" :: path) in *) (* Hashtbl.add libraries path libname *) (* end; *) (* let libname = Hashtbl.find libraries path in *) (* Hashtbl.add importing libname th.Theory.th_name.id_string *) (* in *) (* Mid.iter add realized_theories; *) (* finally, read the old file, if any, and generate the new one *) let old = ref (match old with | None -> [] | Some ch -> read_old_script ch) in fprintf fmt "@[%s: THEORY@\n@[BEGIN@\n" thname; Mid.iter (fun _ (th, (path, _)) -> let lib = if path = thpath then "" else String.concat "." path ^ "@" in fprintf fmt "IMPORTING %s%s@\n" lib (get_th_name th.Theory.th_name)) realized_theories; fprintf fmt "%% do not edit above this line@\n"; fprintf fmt "%% surround new declarations you insert below with blank lines@\n@\n"; print_decls ~old info fmt local_decls; output_remaining fmt !old; fprintf fmt "@]@\nEND %s@\n@]" thname let print_task_full args ?old fmt task = print_task args false ?old fmt task let print_task_real args ?old fmt task = print_task args true ?old fmt task let () = register_printer "pvs" print_task_full ~desc:"Printer@ for@ the@ PVS@ proof@ assistant@ \ (without@ realization@ capabilities)." let () = register_printer "pvs-realize" print_task_real ~desc:"Printer@ for@ the@ PVS@ proof@ assistant@ \ (with@ realization@ capabilities)." (* Local Variables: compile-command: "unset LANG; make -C ../.. " End: *) why3-0.88.3/src/printer/smtv1.mli0000664000175100017510000000130713225666037017304 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) why3-0.88.3/src/printer/why3printer.ml0000664000175100017510000003411413225666037020361 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** Why3 printer *) open Format open Pp open Ident open Ty open Term open Decl open Printer open Theory let iprinter,aprinter,tprinter,pprinter = let bl = ["theory"; "type"; "function"; "predicate"; "inductive"; "axiom"; "lemma"; "goal"; "use"; "clone"; "prop"; "meta"; "namespace"; "import"; "export"; "end"; "forall"; "exists"; "not"; "true"; "false"; "if"; "then"; "else"; "let"; "in"; "match"; "with"; "as"; "epsilon" ] in let isanitize = sanitizer char_to_alpha char_to_alnumus in let lsanitize = sanitizer char_to_lalpha char_to_alnumus in create_ident_printer bl ~sanitizer:isanitize, create_ident_printer bl ~sanitizer:lsanitize, create_ident_printer bl ~sanitizer:lsanitize, create_ident_printer bl ~sanitizer:isanitize let forget_tvs () = forget_all aprinter let _forget_all () = forget_all iprinter; forget_all aprinter; forget_all tprinter; forget_all pprinter (* type variables always start with a quote *) let print_tv fmt tv = fprintf fmt "'%s" (id_unique aprinter tv.tv_name) (* logic variables always start with a lower case letter *) let print_vs fmt vs = let sanitizer = Strings.uncapitalize in fprintf fmt "%s" (id_unique iprinter ~sanitizer vs.vs_name) let forget_var vs = forget_id iprinter vs.vs_name (* theory names always start with an upper case letter *) let print_th fmt th = let sanitizer = Strings.capitalize in fprintf fmt "%s" (id_unique iprinter ~sanitizer th.th_name) let print_ts fmt ts = fprintf fmt "%s" (id_unique tprinter ts.ts_name) let print_ls fmt ls = fprintf fmt "%s" (id_unique iprinter ls.ls_name) let print_cs fmt ls = let sanitizer = Strings.capitalize in fprintf fmt "%s" (id_unique iprinter ~sanitizer ls.ls_name) let print_pr fmt pr = fprintf fmt "%s" (id_unique pprinter pr.pr_name) (* info *) type info = { info_syn : syntax_map } let info = ref { info_syn = Mid.empty } let query_syntax id = query_syntax !info.info_syn id let query_remove id = Mid.mem id !info.info_syn (** Types *) let protect_on x s = if x then "(" ^^ s ^^ ")" else s let rec print_ty_node inn fmt ty = match ty.ty_node with | Tyvar v -> print_tv fmt v | Tyapp (ts, tl) -> begin match query_syntax ts.ts_name with | Some s -> syntax_arguments s (print_ty_node false) fmt tl | None -> begin match tl with | [] -> print_ts fmt ts | tl -> fprintf fmt (protect_on inn "%a@ %a") print_ts ts (print_list space (print_ty_node true)) tl end end let print_ty = print_ty_node false (* can the type of a value be derived from the type of the arguments? *) let unambig_fs fs = let rec lookup v ty = match ty.ty_node with | Tyvar u when tv_equal u v -> true | _ -> ty_any (lookup v) ty in let lookup v = List.exists (lookup v) fs.ls_args in let rec inspect ty = match ty.ty_node with | Tyvar u when not (lookup u) -> false | _ -> ty_all inspect ty in Opt.fold (fun _ -> inspect) true fs.ls_value (** Patterns, terms, and formulas *) let rec print_pat_node pri fmt p = match p.pat_node with | Pwild -> fprintf fmt "_" | Pvar v -> print_vs fmt v | Pas (p, v) -> fprintf fmt (protect_on (pri > 1) "%a as %a") (print_pat_node 1) p print_vs v | Por (p, q) -> fprintf fmt (protect_on (pri > 0) "%a | %a") (print_pat_node 0) p (print_pat_node 0) q | Papp (cs, pl) -> begin match query_syntax cs.ls_name with | Some s -> syntax_arguments s (print_pat_node 0) fmt pl | None -> begin match pl with | [] -> print_cs fmt cs | pl -> fprintf fmt (protect_on (pri > 1) "%a@ %a") print_cs cs (print_list space (print_pat_node 2)) pl end end let print_pat = print_pat_node 0 let print_vsty fmt v = fprintf fmt "%a:@,%a" print_vs v print_ty v.vs_ty let print_quant = Pretty.print_quant let print_binop = Pretty.print_binop let prio_binop = function | Tand -> 3 | Tor -> 2 | Timplies -> 1 | Tiff -> 1 let print_label = Pretty.print_label let print_labels = print_iter1 Slab.iter space print_label let print_ident_labels fmt id = if not (Slab.is_empty id.id_label) then fprintf fmt "@ %a" print_labels id.id_label let rec print_term fmt t = print_lterm 0 fmt t and print_lterm pri fmt t = if Slab.is_empty t.t_label then print_tnode pri fmt t else fprintf fmt (protect_on (pri > 0) "%a %a") print_labels t.t_label (print_tnode 0) t and print_app pri fs fmt tl = match query_syntax fs.ls_name with | Some s -> syntax_arguments s print_term fmt tl | None -> begin match tl with | [] -> print_ls fmt fs | tl -> fprintf fmt (protect_on (pri > 5) "%a@ %a") print_ls fs (print_list space (print_lterm 6)) tl end and print_tnode pri fmt t = match t.t_node with | Tvar v -> print_vs fmt v | Tconst c -> Number.print_constant fmt c | Tapp (fs, tl) when unambig_fs fs -> print_app pri fs fmt tl | Tapp (fs, tl) -> fprintf fmt (protect_on (pri > 0) "%a:%a") (print_app 5 fs) tl print_ty (t_type t) | Tif (f,t1,t2) -> fprintf fmt (protect_on (pri > 0) "if @[%a@] then %a@ else %a") print_term f print_term t1 print_term t2 | Tlet (t1,tb) -> let v,t2 = t_open_bound tb in fprintf fmt (protect_on (pri > 0) "let %a = @[%a@] in@ %a") print_vs v (print_lterm 4) t1 print_term t2; forget_var v | Tcase (t1,bl) -> fprintf fmt "match @[%a@] with@\n@[%a@]@\nend" print_term t1 (print_list newline print_tbranch) bl | Teps fb -> let vl,tl,e = t_open_lambda t in if vl = [] then begin let v,f = t_open_bound fb in fprintf fmt (protect_on (pri > 0) "epsilon %a.@ %a") print_vsty v print_term f; forget_var v end else begin fprintf fmt (protect_on (pri > 0) "\\ %a%a.@ %a") (print_list comma print_vsty) vl print_tl tl print_term e; List.iter forget_var vl end | Tquant (q,fq) -> let vl,tl,f = t_open_quant fq in fprintf fmt (protect_on (pri > 0) "%a %a%a.@ %a") print_quant q (print_list comma print_vsty) vl print_tl tl print_term f; List.iter forget_var vl | Ttrue -> fprintf fmt "true" | Tfalse -> fprintf fmt "false" | Tbinop (b,f1,f2) -> let asym = Slab.mem Term.asym_label f1.t_label in let p = prio_binop b in fprintf fmt (protect_on (pri > p) "%a %a@ %a") (print_lterm (p + 1)) f1 (print_binop ~asym) b (print_lterm p) f2 | Tnot f -> fprintf fmt (protect_on (pri > 4) "not %a") (print_lterm 4) f and print_tbranch fmt br = let p,t = t_open_branch br in fprintf fmt "@[| %a ->@ %a@]" print_pat p print_term t; Svs.iter forget_var p.pat_vars and print_tl fmt tl = if tl = [] then () else fprintf fmt "@ [%a]" (print_list alt (print_list comma print_term)) tl (** Declarations *) let print_tv_arg fmt tv = fprintf fmt "@ %a" print_tv tv let print_ty_arg fmt ty = fprintf fmt "@ %a" (print_ty_node true) ty let print_vs_arg fmt vs = fprintf fmt "@ (%a)" print_vsty vs let print_constr fmt (cs,pjl) = let add_pj pj ty pjl = (pj,ty)::pjl in let print_pj fmt (pj,ty) = match pj with | Some ls -> fprintf fmt "@ (%a:@,%a)" print_ls ls print_ty ty | None -> print_ty_arg fmt ty in fprintf fmt "@[| %a%a%a@]" print_cs cs print_ident_labels cs.ls_name (print_list nothing print_pj) (List.fold_right2 add_pj pjl cs.ls_args []) let print_type_decl fmt ts = match ts.ts_def with | NoDef -> fprintf fmt "@[type %a%a%a@]@\n@\n" print_ts ts print_ident_labels ts.ts_name (print_list nothing print_tv_arg) ts.ts_args | Alias ty -> fprintf fmt "@[type %a%a%a =@ %a@]@\n@\n" print_ts ts print_ident_labels ts.ts_name (print_list nothing print_tv_arg) ts.ts_args print_ty ty | Range _ir -> (* TODO *) fprintf fmt "@[type %a%a%a =@ @]@\n@\n" print_ts ts print_ident_labels ts.ts_name (print_list nothing print_tv_arg) ts.ts_args | Float _fp -> (* TODO *) fprintf fmt "@[type %a%a%a =@ @]@\n@\n" print_ts ts print_ident_labels ts.ts_name (print_list nothing print_tv_arg) ts.ts_args let print_type_decl fmt ts = if not (query_remove ts.ts_name) then (print_type_decl fmt ts; forget_tvs ()) let print_data_decl fst fmt (ts,csl) = fprintf fmt "@[%s %a%a%a =@\n@[%a@]@]@\n@\n" (if fst then "type" else "with") print_ts ts print_ident_labels ts.ts_name (print_list nothing print_tv_arg) ts.ts_args (print_list newline print_constr) csl let print_data_decl first fmt d = if not (query_remove (fst d).ts_name) then (print_data_decl first fmt d; forget_tvs ()) let print_ls_type fmt = fprintf fmt " :@ %a" print_ty let ls_kind ls = if ls.ls_value = None then "predicate" else "function" let print_param_decl fmt ls = fprintf fmt "@[%s %a%a%a%a@]@\n@\n" (ls_kind ls) print_ls ls print_ident_labels ls.ls_name (print_list nothing print_ty_arg) ls.ls_args (print_option print_ls_type) ls.ls_value let print_param_decl fmt ls = if not (query_remove ls.ls_name) then (print_param_decl fmt ls; forget_tvs ()) let print_logic_decl fst fmt (ls,ld) = let vl,e = open_ls_defn ld in fprintf fmt "@[%s %a%a%a%a =@ %a@]@\n@\n" (if fst then ls_kind ls else "with") print_ls ls print_ident_labels ls.ls_name (print_list nothing print_vs_arg) vl (print_option print_ls_type) ls.ls_value print_term e; List.iter forget_var vl let print_logic_decl first fmt d = if not (query_remove (fst d).ls_name) then (print_logic_decl first fmt d; forget_tvs ()) let print_ind fmt (pr,f) = fprintf fmt "@[| %a%a :@ %a@]" print_pr pr print_ident_labels pr.pr_name print_term f let ind_sign = function | Ind -> "inductive" | Coind -> "coinductive" let print_ind_decl s fst fmt (ps,bl) = fprintf fmt "@[%s %a%a%a =@ @[%a@]@]@\n@\n" (if fst then ind_sign s else "with") print_ls ps print_ident_labels ps.ls_name (print_list nothing print_ty_arg) ps.ls_args (print_list newline print_ind) bl let print_ind_decl s first fmt d = if not (query_remove (fst d).ls_name) then (print_ind_decl s first fmt d; forget_tvs ()) let print_pkind = Pretty.print_pkind let print_prop_decl fmt (k,pr,f) = fprintf fmt "@[%a %a%a : %a@]@\n@\n" print_pkind k print_pr pr print_ident_labels pr.pr_name print_term f let print_prop_decl fmt (k,pr,f) = match k with | Paxiom when query_remove pr.pr_name -> () | _ -> print_prop_decl fmt (k,pr,f); forget_tvs () let print_list_next sep print fmt = function | [] -> () | [x] -> print true fmt x | x :: r -> print true fmt x; sep fmt (); print_list sep (print false) fmt r let print_decl fmt d = match d.d_node with | Dtype ts -> print_type_decl fmt ts | Ddata tl -> print_list_next nothing print_data_decl fmt tl | Dparam ls -> print_param_decl fmt ls | Dlogic ll -> print_list_next nothing print_logic_decl fmt ll | Dind (s, il) -> print_list_next nothing (print_ind_decl s) fmt il | Dprop p -> print_prop_decl fmt p let print_inst_ts fmt (ts1,ts2) = fprintf fmt "type %a = %a" print_ts ts1 print_ts ts2 let print_inst_ls fmt (ls1,ls2) = fprintf fmt "%s %a = %a" (ls_kind ls1) print_ls ls1 print_ls ls2 let print_inst_pr fmt (pr1,pr2) = fprintf fmt "prop %a = %a" print_pr pr1 print_pr pr2 let print_meta_arg fmt = function | MAty ty -> fprintf fmt "type %a" print_ty ty; forget_tvs () | MAts ts -> fprintf fmt "type %a" print_ts ts | MAls ls -> fprintf fmt "%s %a" (ls_kind ls) print_ls ls | MApr pr -> fprintf fmt "prop %a" print_pr pr | MAstr s -> fprintf fmt "\"%s\"" s | MAint i -> fprintf fmt "%d" i let print_qt fmt th = if th.th_path = [] then print_th fmt th else fprintf fmt "%a.%a" (print_list (constant_string ".") string) th.th_path print_th th let print_tdecl fmt td = match td.td_node with | Decl d -> print_decl fmt d | Use th -> fprintf fmt "@[(* use %a *)@]@\n@\n" print_qt th | Clone (th,sm) when is_empty_sm sm -> fprintf fmt "@[(* use %a *)@]@\n@\n" print_qt th | Clone (th,sm) -> let tm = Mts.fold (fun x y a -> (x,y)::a) sm.sm_ts [] in let lm = Mls.fold (fun x y a -> (x,y)::a) sm.sm_ls [] in let pm = Mpr.fold (fun x y a -> (x,y)::a) sm.sm_pr [] in fprintf fmt "@[(* clone %a with %a,@ %a,@ %a *)@]@\n@\n" print_qt th (print_list comma print_inst_ts) tm (print_list comma print_inst_ls) lm (print_list comma print_inst_pr) pm | Meta (m,al) -> fprintf fmt "@[(* meta %s %a *)@]@\n@\n" m.meta_name (print_list comma print_meta_arg) al let print_tdecls = let print_tdecl sm fmt td = info := {info_syn = sm}; print_tdecl fmt td; sm, [] in let print_tdecl = Printer.sprint_tdecl print_tdecl in let print_tdecl task acc = print_tdecl task.Task.task_decl acc in Discriminate.on_syntax_map (fun sm -> Trans.fold print_tdecl (sm,[])) let print_task args ?old:_ fmt task = (* In trans-based p-printing [forget_all] IST STRENG VERBOTEN *) (* forget_all (); *) print_prelude fmt args.prelude; fprintf fmt "theory Task@\n"; print_th_prelude task fmt args.th_prelude; let rec print = function | x :: r -> print r; Pp.string fmt x | [] -> () in print (snd (Trans.apply print_tdecls task)); fprintf fmt "end@." let () = register_printer "why3" print_task ~desc:"Printer@ for@ the@ logical@ format@ of@ Why3.@ Used@ for@ debugging." why3-0.88.3/src/util/0000775000175100017510000000000013225666037015020 5ustar guillaumeguillaumewhy3-0.88.3/src/util/pqueue.mli0000664000175100017510000000250113225666037017025 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (* Priority queue *) module Make(X: Set.OrderedType) : sig type t type elt = X.t val create: dummy:elt -> t (** [dummy] will never be returned *) val is_empty: t -> bool val add: t -> elt -> unit (* inserts a new element *) exception Empty val get_min: t -> elt (* returns the minimal element (does not remove it) raises [Empty] if the queue is empty *) val remove_min: t -> unit (* removes the minimal element raises [Empty] if the queue is empty *) val extract_min: t -> elt (* removes and returns the minimal element raises [Empty] if the queue is empty *) end why3-0.88.3/src/util/extmap.ml0000664000175100017510000005330213225666037016653 0ustar guillaumeguillaume(***********************************************************************) (* *) (* Objective Caml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* This file originates from the OCaml v 3.12 Standard Library. Since then it has been adapted to OCaml 4.04 Standard Library. It was extended and modified for the needs of the Why3 project. It is distributed under the terms of its initial license, which is provided in the file OCAML-LICENSE. *) module type S = sig type key type +'a t val empty: 'a t val is_empty: 'a t -> bool val mem: key -> 'a t -> bool val add: key -> 'a -> 'a t -> 'a t val singleton: key -> 'a -> 'a t val remove: key -> 'a t -> 'a t val merge: (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t val union: (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val iter: (key -> 'a -> unit) -> 'a t -> unit val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val for_all: (key -> 'a -> bool) -> 'a t -> bool val exists: (key -> 'a -> bool) -> 'a t -> bool val filter: (key -> 'a -> bool) -> 'a t -> 'a t val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t val cardinal: 'a t -> int val bindings: 'a t -> (key * 'a) list val min_binding: 'a t -> (key * 'a) val max_binding: 'a t -> (key * 'a) val choose: 'a t -> (key * 'a) val split: key -> 'a t -> 'a t * 'a option * 'a t val find: key -> 'a t -> 'a val map: ('a -> 'b) -> 'a t -> 'b t val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t (** Added into why stdlib version *) val change : ('a option -> 'a option) -> key -> 'a t -> 'a t val inter : (key -> 'a -> 'b -> 'c option) -> 'a t -> 'b t -> 'c t val diff : (key -> 'a -> 'b -> 'a option) -> 'a t -> 'b t -> 'a t val submap : (key -> 'a -> 'b -> bool) -> 'a t -> 'b t -> bool val disjoint : (key -> 'a -> 'b -> bool) -> 'a t -> 'b t -> bool val set_union : 'a t -> 'a t -> 'a t val set_inter : 'a t -> 'b t -> 'a t val set_diff : 'a t -> 'b t -> 'a t val set_submap : 'a t -> 'b t -> bool val set_disjoint : 'a t -> 'b t -> bool val set_compare : 'a t -> 'b t -> int val set_equal : 'a t -> 'b t -> bool val find_def : 'a -> key -> 'a t -> 'a val find_opt : key -> 'a t -> 'a option val find_exn : exn -> key -> 'a t -> 'a val map_filter: ('a -> 'b option) -> 'a t -> 'b t val mapi_filter: (key -> 'a -> 'b option) -> 'a t -> 'b t val mapi_fold: (key -> 'a -> 'acc -> 'acc * 'b) -> 'a t -> 'acc -> 'acc * 'b t val mapi_filter_fold: (key -> 'a -> 'acc -> 'acc * 'b option) -> 'a t -> 'acc -> 'acc * 'b t val fold_left : ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b val fold2_inter: (key -> 'a -> 'b -> 'c -> 'c) -> 'a t -> 'b t -> 'c -> 'c val fold2_union: (key -> 'a option -> 'b option -> 'c -> 'c) -> 'a t -> 'b t -> 'c -> 'c val translate : (key -> key) -> 'a t -> 'a t val add_new : exn -> key -> 'a -> 'a t -> 'a t val replace : exn -> key -> 'a -> 'a t -> 'a t val keys: 'a t -> key list val values: 'a t -> 'a list val of_list : (key * 'a) list -> 'a t val domain : 'a t -> unit t val subdomain : (key -> 'a -> bool) -> 'a t -> unit t val is_num_elt : int -> 'a t -> bool type 'a enumeration val val_enum : 'a enumeration -> (key * 'a) option val start_enum : 'a t -> 'a enumeration val next_enum : 'a enumeration -> 'a enumeration val start_ge_enum : key -> 'a t -> 'a enumeration val next_ge_enum : key -> 'a enumeration -> 'a enumeration end module type OrderedType = Map.OrderedType module Make(Ord: OrderedType) = struct type key = Ord.t type 'a t = Empty | Node of 'a t * key * 'a * 'a t * int let height = function Empty -> 0 | Node(_,_,_,_,h) -> h let create l x d r = let hl = height l and hr = height r in Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) let singleton x d = Node(Empty, x, d, Empty, 1) let bal l x d r = let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in if hl > hr + 2 then begin match l with Empty -> invalid_arg "Map.bal" | Node(ll, lv, ld, lr, _) -> if height ll >= height lr then create ll lv ld (create lr x d r) else begin match lr with Empty -> invalid_arg "Map.bal" | Node(lrl, lrv, lrd, lrr, _)-> create (create ll lv ld lrl) lrv lrd (create lrr x d r) end end else if hr > hl + 2 then begin match r with Empty -> invalid_arg "Map.bal" | Node(rl, rv, rd, rr, _) -> if height rr >= height rl then create (create l x d rl) rv rd rr else begin match rl with Empty -> invalid_arg "Map.bal" | Node(rll, rlv, rld, rlr, _) -> create (create l x d rll) rlv rld (create rlr rv rd rr) end end else Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) let empty = Empty let is_empty = function Empty -> true | _ -> false let rec add x data = function Empty -> Node(Empty, x, data, Empty, 1) | Node(l, v, d, r, h) as m -> let c = Ord.compare x v in if c = 0 then if d == data then m else Node(l, x, data, r, h) else if c < 0 then let ll = add x data l in if l == ll then m else bal ll v d r else let rr = add x data r in if r == rr then m else bal l v d rr let rec find x = function Empty -> raise Not_found | Node(l, v, d, r, _) -> let c = Ord.compare x v in if c = 0 then d else find x (if c < 0 then l else r) let rec mem x = function Empty -> false | Node(l, v, _, r, _) -> let c = Ord.compare x v in c = 0 || mem x (if c < 0 then l else r) let rec min_binding = function Empty -> raise Not_found | Node(Empty, x, d, _, _) -> (x, d) | Node(l, _, _, _, _) -> min_binding l let rec max_binding = function Empty -> raise Not_found | Node(_, x, d, Empty, _) -> (x, d) | Node(_, _, _, r, _) -> max_binding r let rec remove_min_binding = function Empty -> invalid_arg "Map.remove_min_elt" | Node(Empty, _, _, r, _) -> r | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r let merge t1 t2 = match (t1, t2) with (Empty, t) -> t | (t, Empty) -> t | (_, _) -> let (x, d) = min_binding t2 in bal t1 x d (remove_min_binding t2) let merge_bal = merge let rec remove x = function Empty -> Empty | (Node(l, v, d, r, _) as t) -> let c = Ord.compare x v in if c = 0 then merge l r else if c < 0 then let ll = remove x l in if l == ll then t else bal ll v d r else let rr = remove x r in if r == rr then t else bal l v d rr let rec iter f = function Empty -> () | Node(l, v, d, r, _) -> iter f l; f v d; iter f r let rec map f = function Empty -> Empty | Node(l, v, d, r, h) -> let l' = map f l in let d' = f d in let r' = map f r in Node(l', v, d', r', h) let rec mapi f = function Empty -> Empty | Node(l, v, d, r, h) -> let l' = mapi f l in let d' = f v d in let r' = mapi f r in Node(l', v, d', r', h) let rec fold f m accu = match m with Empty -> accu | Node(l, v, d, r, _) -> fold f r (f v d (fold f l accu)) let rec for_all p = function Empty -> true | Node(l, v, d, r, _) -> p v d && for_all p l && for_all p r let rec exists p = function Empty -> false | Node(l, v, d, r, _) -> p v d || exists p l || exists p r (* Beware: those two functions assume that the added k is *strictly* smaller (or bigger) than all the present keys in the tree; it does not test for equality with the current min (or max) key. Indeed, they are only used during the "join" operation which respects this precondition. *) let rec add_min_binding k v = function | Empty -> singleton k v | Node (l, x, d, r, _) -> bal (add_min_binding k v l) x d r let rec add_max_binding k v = function | Empty -> singleton k v | Node (l, x, d, r, _) -> bal l x d (add_max_binding k v r) (* Same as create and bal, but no assumptions are made on the relative heights of l and r. *) let rec join l v d r = match (l, r) with (Empty, _) -> add_min_binding v d r | (_, Empty) -> add_max_binding v d l | (Node(ll, lv, ld, lr, lh), Node(rl, rv, rd, rr, rh)) -> if lh > rh + 2 then bal ll lv ld (join lr v d r) else if rh > lh + 2 then bal (join l v d rl) rv rd rr else create l v d r (* Merge two trees l and r into one. All elements of l must precede the elements of r. No assumption on the heights of l and r. *) let concat t1 t2 = match (t1, t2) with (Empty, t) -> t | (t, Empty) -> t | (_, _) -> let (x, d) = min_binding t2 in join t1 x d (remove_min_binding t2) let concat_or_join t1 v d t2 = match d with | Some d -> join t1 v d t2 | None -> concat t1 t2 let rec split x = function Empty -> (Empty, None, Empty) | Node(l, v, d, r, _) -> let c = Ord.compare x v in if c = 0 then (l, Some d, r) else if c < 0 then let (ll, pres, rl) = split x l in (ll, pres, join rl v d r) else let (lr, pres, rr) = split x r in (join l v d lr, pres, rr) let rec merge f s1 s2 = match (s1, s2) with (Empty, Empty) -> Empty | (Node (l1, v1, d1, r1, h1), _) when h1 >= height s2 -> let (l2, d2, r2) = split v1 s2 in concat_or_join (merge f l1 l2) v1 (f v1 (Some d1) d2) (merge f r1 r2) | (_, Node (l2, v2, d2, r2, _)) -> let (l1, d1, r1) = split v2 s1 in concat_or_join (merge f l1 l2) v2 (f v2 d1 (Some d2)) (merge f r1 r2) | _ -> assert false let rec union f s1 s2 = match (s1, s2) with | (Empty, s) | (s, Empty) -> s | (Node (l1, v1, d1, r1, h1), Node (l2, v2, d2, r2, h2)) -> if h1 >= h2 then let (l2, d2, r2) = split v1 s2 in let l = union f l1 l2 and r = union f r1 r2 in match d2 with | None -> join l v1 d1 r | Some d2 -> concat_or_join l v1 (f v1 d1 d2) r else let (l1, d1, r1) = split v2 s1 in let l = union f l1 l2 and r = union f r1 r2 in match d1 with | None -> join l v2 d2 r | Some d1 -> concat_or_join l v2 (f v2 d1 d2) r let rec filter p = function Empty -> Empty | Node(l, v, d, r, _) as t -> (* call [p] in the expected left-to-right order *) let l' = filter p l in let pvd = p v d in let r' = filter p r in if pvd then if l==l' && r==r' then t else join l' v d r' else concat l' r' let rec partition p = function Empty -> (Empty, Empty) | Node(l, v, d, r, _) -> (* call [p] in the expected left-to-right order *) let (lt, lf) = partition p l in let pvd = p v d in let (rt, rf) = partition p r in if pvd then (join lt v d rt, concat lf rf) else (concat lt rt, join lf v d rf) type 'a enumeration = End | More of key * 'a * 'a t * 'a enumeration let rec cons_enum m e = match m with Empty -> e | Node(l, v, d, r, _) -> cons_enum l (More(v, d, r, e)) let compare cmp m1 m2 = let rec compare_aux e1 e2 = match (e1, e2) with (End, End) -> 0 | (End, _) -> -1 | (_, End) -> 1 | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) -> let c = Ord.compare v1 v2 in if c <> 0 then c else let c = cmp d1 d2 in if c <> 0 then c else compare_aux (cons_enum r1 e1) (cons_enum r2 e2) in compare_aux (cons_enum m1 End) (cons_enum m2 End) let equal cmp m1 m2 = let rec equal_aux e1 e2 = match (e1, e2) with (End, End) -> true | (End, _) -> false | (_, End) -> false | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) -> Ord.compare v1 v2 = 0 && cmp d1 d2 && equal_aux (cons_enum r1 e1) (cons_enum r2 e2) in equal_aux (cons_enum m1 End) (cons_enum m2 End) let rec cardinal = function Empty -> 0 | Node(l, _, _, r, _) -> cardinal l + 1 + cardinal r let rec keys_aux accu = function Empty -> accu | Node(l, v, _, r, _) -> keys_aux (v :: keys_aux accu r) l let keys s = keys_aux [] s let rec bindings_aux accu = function Empty -> accu | Node(l, v, d, r, _) -> bindings_aux ((v, d) :: bindings_aux accu r) l let bindings s = bindings_aux [] s let rec values_aux accu = function Empty -> accu | Node(l, _, v, r, _) -> values_aux (v :: values_aux accu r) l let values s = values_aux [] s let choose = min_binding (** Added into why stdlib version *) let rec change f x = function | Empty -> begin match f None with | None -> Empty | Some d -> Node(Empty, x, d, Empty, 1) end | Node(l, v, d, r, h) -> let c = Ord.compare x v in if c = 0 then (* concat or bal *) match f (Some d) with | None -> merge_bal l r | Some d -> Node(l, x, d, r, h) else if c < 0 then bal (change f x l) v d r else bal l v d (change f x r) let rec inter f s1 s2 = match (s1, s2) with | (Empty, _) | (_, Empty) -> Empty | (Node(l1, v1, d1, r1, _), t2) -> match split v1 t2 with (l2, None, r2) -> concat (inter f l1 l2) (inter f r1 r2) | (l2, Some d2, r2) -> concat_or_join (inter f l1 l2) v1 (f v1 d1 d2) (inter f r1 r2) let rec diff f s1 s2 = match (s1, s2) with (Empty, _t2) -> Empty | (t1, Empty) -> t1 | (Node(l1, v1, d1, r1, _), t2) -> match split v1 t2 with | (l2, None, r2) -> join (diff f l1 l2) v1 d1 (diff f r1 r2) | (l2, Some d2, r2) -> concat_or_join (diff f l1 l2) v1 (f v1 d1 d2) (diff f r1 r2) let rec submap pr s1 s2 = match (s1, s2) with | Empty, _ -> true | _, Empty -> false | Node (l1, v1, d1, r1, _), (Node (l2, v2, d2, r2, _) as t2) -> let c = Ord.compare v1 v2 in if c = 0 then pr v1 d1 d2 && submap pr l1 l2 && submap pr r1 r2 else if c < 0 then submap pr (Node (l1, v1, d1, Empty, 0)) l2 && submap pr r1 t2 else submap pr (Node (Empty, v1, d1, r1, 0)) r2 && submap pr l1 t2 let rec disjoint pr s1 s2 = match (s1, s2) with | Empty, _ -> true | _, Empty -> true | Node (l1, v1, d1, r1, _), (Node (l2, v2, d2, r2, _) as t2) -> let c = Ord.compare v1 v2 in if c = 0 then pr v1 d1 d2 && disjoint pr l1 l2 && disjoint pr r1 r2 else if c < 0 then disjoint pr (Node (l1, v1, d1, Empty, 0)) l2 && disjoint pr r1 t2 else disjoint pr (Node (Empty, v1, d1, r1, 0)) r2 && disjoint pr l1 t2 let set_union m1 m2 = union (fun _ x _ -> Some x) m1 m2 let set_inter m1 m2 = inter (fun _ x _ -> Some x) m1 m2 let set_diff m1 m2 = diff (fun _ _ _ -> None) m1 m2 let set_submap m1 m2 = submap (fun _ _ _ -> true) m1 m2 let set_disjoint m1 m2 = disjoint (fun _ _ _ -> false) m1 m2 let set_compare m1 m2 = compare (fun _ _ -> 0) m1 m2 let set_equal m1 m2 = equal (fun _ _ -> true) m1 m2 let rec find_def def x = function Empty -> def | Node(l, v, d, r, _) -> let c = Ord.compare x v in if c = 0 then d else find_def def x (if c < 0 then l else r) let rec find_opt x = function Empty -> None | Node(l, v, d, r, _) -> let c = Ord.compare x v in if c = 0 then Some d else find_opt x (if c < 0 then l else r) let rec find_exn exn x = function Empty -> raise exn | Node(l, v, d, r, _) -> let c = Ord.compare x v in if c = 0 then d else find_exn exn x (if c < 0 then l else r) let rec map_filter f = function Empty -> Empty | Node(l, v, d, r, _h) -> concat_or_join (map_filter f l) v (f d) (map_filter f r) let rec mapi_filter f = function Empty -> Empty | Node(l, v, d, r, _h) -> concat_or_join (mapi_filter f l) v (f v d) (mapi_filter f r) let rec mapi_fold f m acc = match m with Empty -> acc, Empty | Node(l, v, d, r, h) -> let acc,l' = mapi_fold f l acc in let acc,d' = f v d acc in let acc,r' = mapi_fold f r acc in acc,Node(l', v, d', r', h) let fold2_inter f m1 m2 acc = let rec aux acc e1_0 e2_0 = match (e1_0, e2_0) with (End, End) -> acc | (End, _) -> acc | (_, End) -> acc | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) -> let c = Ord.compare v1 v2 in if c = 0 then aux (f v1 d1 d2 acc) (cons_enum r1 e1) (cons_enum r2 e2) else if c < 0 then aux acc (cons_enum r1 e1) e2_0 else aux acc e1_0 (cons_enum r2 e2) in aux acc (cons_enum m1 End) (cons_enum m2 End) let fold2_union f m1 m2 acc = let rec aux acc e1_0 e2_0 = match (e1_0, e2_0) with (End, End) -> acc | (End, More(v2, d2, r2, e2)) -> aux (f v2 None (Some d2) acc) End (cons_enum r2 e2) | (More(v1, d1, r1, e1), End) -> aux (f v1 (Some d1) None acc) (cons_enum r1 e1) End | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) -> let c = Ord.compare v1 v2 in if c = 0 then aux (f v1 (Some d1) (Some d2) acc) (cons_enum r1 e1) (cons_enum r2 e2) else if c < 0 then aux (f v1 (Some d1) None acc) (cons_enum r1 e1) e2_0 else aux (f v2 None (Some d2) acc) e1_0 (cons_enum r2 e2) in aux acc (cons_enum m1 End) (cons_enum m2 End) let translate f m = let rec aux last = function | Empty -> Empty,last | Node(l, v, d, r, h) -> let l,last = aux last l in let v = f v in begin match last with | None -> () | Some last -> if Ord.compare last v >= 0 then invalid_arg "Map.translate : given function incorrect" end; let r,last = aux (Some v) r in Node(l,v,d,r,h),last in let m,_ = aux None m in m let rec mapi_filter_fold f m acc = match m with Empty -> acc, Empty | Node(l, v, d, r, _h) -> let acc,l' = mapi_filter_fold f l acc in let acc,d' = f v d acc in let acc,r' = mapi_filter_fold f r acc in acc, concat_or_join l' v d' r' let add_new e x v m = change (function | Some _ -> raise e | None -> Some v) x m let replace e x v m = change (function | Some _ -> Some v | None -> raise e) x m let is_num_elt n m = try fold (fun _ _ n -> if n < 0 then raise Exit else n-1) m n = 0 with Exit -> false let start_enum s = cons_enum s End let val_enum = function | End -> None | More (v,d,_,_) -> Some (v,d) let next_enum = function | End -> End | More(_,_,r,e) -> cons_enum r e let rec cons_ge_enum k m e = match m with Empty -> e | Node(l, v, d, r, _) -> let c = Ord.compare k v in if c = 0 then More(v,d,r,e) else if c < 0 then cons_ge_enum k l (More(v, d, r, e)) else (* c > 0 *) cons_ge_enum k r e let start_ge_enum k m = cons_ge_enum k m End let rec next_ge_enum k r0 = function | End -> start_ge_enum k r0 | More(v,_,r,e) as e0 -> let c = Ord.compare k v in if c = 0 then e0 else if c < 0 then cons_ge_enum k r0 e0 else (* c > 0 *) next_ge_enum k r e let next_ge_enum k e = next_ge_enum k Empty e let rec fold_left f accu m = match m with Empty -> accu | Node(l, v, d, r, _) -> fold_left f (f (fold_left f accu l) v d) r let of_list l = List.fold_left (fun acc (k,d) -> add k d acc) empty l let domain m = map ignore m let subdomain pr m = mapi_filter (fun k v -> if pr k v then Some () else None) m end why3-0.88.3/src/util/pqueue.ml0000664000175100017510000000570113225666037016661 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (* Resizable arrays *) module RA = struct type 'a t = { default: 'a; mutable size: int; mutable data: 'a array } let length a = a.size let make n d = { default = d; size = n; data = Array.make n d } let get a i = if i < 0 || i >= a.size then invalid_arg "RA.get"; a.data.(i) let set a i v = if i < 0 || i >= a.size then invalid_arg "RA.set"; a.data.(i) <- v let resize a s = if s <= a.size then begin Array.fill a.data s (a.size - s) a.default end else begin let n = Array.length a.data in if s > n then begin let n' = max (2 * n) s in let a' = Array.make n' a.default in Array.blit a.data 0 a' 0 a.size; a.data <- a' end end; a.size <- s end (* Priority queue *) (* The heap is encoded into a resizable array, where elements are stored from [0] to [length - 1]. From an element stored at [i], the left (resp. right) subtree, if any, is rooted at [2*i+1] (resp. [2*i+2]). *) module Make(X: Set.OrderedType) = struct type elt = X.t type t = elt RA.t let create ~dummy = RA.make 0 dummy let is_empty h = RA.length h = 0 (* dead code let clear h = RA.resize h 0 *) let rec move_up h x i = if i = 0 then RA.set h i x else let fi = (i - 1) / 2 in let y = RA.get h fi in if X.compare y x > 0 then begin RA.set h i y; move_up h x fi end else RA.set h i x let add h x = let n = RA.length h in RA.resize h (n + 1); move_up h x n exception Empty let get_min h = if RA.length h = 0 then raise Empty; RA.get h 0 let min h l r = if X.compare (RA.get h r) (RA.get h l) < 0 then r else l let smallest_node h x i = let l = 2 * i + 1 in let n = RA.length h in if l >= n then i else let r = l + 1 in let j = if r < n then min h l r else l in if X.compare (RA.get h j) x < 0 then j else i let rec move_down h x i = let j = smallest_node h x i in if j = i then RA.set h i x else begin RA.set h i (RA.get h j); move_down h x j end let remove_min h = let n = RA.length h - 1 in if n < 0 then raise Empty; let x = RA.get h n in RA.resize h n; if n > 0 then move_down h x 0 let extract_min h = if RA.length h = 0 then raise Empty; let x = RA.get h 0 in remove_min h; x end why3-0.88.3/src/util/exthtbl.mli0000664000175100017510000000462613225666037017205 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** Association tables over hashable types *) val hash : 'a -> int (** the same as Hashtbl.hash *) module type S = sig include Hashtbl.S val find_def : 'a t -> 'a -> key -> 'a (** return the first binding or the given value if none found *) val find_opt : 'a t -> key -> 'a option (** return the first binding or None if none found *) val find_exn : 'a t -> exn -> key -> 'a (** return the first binding or raise the given exception if none found *) val map : (key -> 'a -> 'b) -> 'a t -> 'b t (** a shortcut less efficient than possible *) val memo : int -> (key -> 'a) -> key -> 'a (** convenience function, memoize a function *) val is_empty : 'a t -> bool (** test if the hashtbl is empty *) end module type Private = sig (** Private Hashtbl *) type 'a t type key val find : 'a t -> key -> 'a (** Same as {!Hashtbl.find} *) val find_def : 'a t -> 'a -> key -> 'a (** return the first binding or the given value if none found *) val find_opt : 'a t -> key -> 'a option (** return the first binding or None if none found *) val find_exn : 'a t -> exn -> key -> 'a (** return the first binding or raise the given exception if none found *) val map : (key -> 'a -> 'b) -> 'a t -> 'b t (** a shortcut less efficient than possible *) val iter : (key -> 'a -> unit) -> 'a t -> unit (** Same as {!Hashtbl.iter} *) val fold : (key -> 'a -> 'acc -> 'acc) -> 'a t -> 'acc -> 'acc (** Same as {!Hashtbl.fold} *) val mem : 'a t -> key -> bool (** Same as {!Hashtbl.mem} *) val length : 'a t -> int (** Same as {!Hashtbl.length} *) val is_empty : 'a t -> bool (** test if the hashtbl is empty *) end module Make (X:Hashtbl.HashedType) : S with type key = X.t why3-0.88.3/src/util/json.ml0000664000175100017510000000442613225666037016331 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) let string fmt s = let b = Buffer.create (2 * String.length s) in Buffer.add_char b '"'; for i = 0 to String.length s -1 do match s.[i] with | '"' -> Buffer.add_string b "\\\"" | '\\' -> Buffer.add_string b "\\\\" | c -> Buffer.add_char b c done; Buffer.add_char b '"'; Format.fprintf fmt "%s" (Buffer.contents b) let int fmt d = Format.fprintf fmt "%d" d let bool fmt b = Format.fprintf fmt "%b" b let float fmt f = Format.fprintf fmt "%f" f (* TODO check that you can print a floating point number like this in JSON *) let print_json_field key value_pr fmt value = Format.fprintf fmt "%a : %a " string key value_pr value let list pr fmt l = if l = [] then Format.fprintf fmt "[]" else Pp.print_list_delim ~start:Pp.lsquare ~stop:Pp.rsquare ~sep:Pp.comma pr fmt l let print_map_binding key_to_str value_pr fmt binding = let (key, value) = binding in print_json_field (key_to_str key) value_pr fmt value let map_bindings key_to_str value_pr fmt map_bindings = if map_bindings = [] then Format.fprintf fmt "{}" else Pp.print_list_delim ~start:Pp.lbrace ~stop:Pp.rbrace ~sep:Pp.comma (print_map_binding key_to_str value_pr) fmt map_bindings type json = | Int of int | Float of float | Bool of bool | String of string | List of json list | Record of json Stdlib.Mstr.t let rec print_json fmt j = match j with | Int i -> int fmt i | Float f -> float fmt f | Bool b -> bool fmt b | String s -> string fmt s | List l -> list print_json fmt l | Record r -> map_bindings (fun x -> x) print_json fmt (Stdlib.Mstr.bindings r) why3-0.88.3/src/util/strings.ml0000664000175100017510000000502513225666037017045 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) let capitalize = String.capitalize let uncapitalize = String.uncapitalize let rev_split c s = let rec aux acc i = try let j = String.index_from s i c in aux (String.sub s i (j-i) :: acc) (j + 1) with Not_found -> (String.sub s i (String.length s - i))::acc | Invalid_argument _ -> ""::acc in aux [] 0 let split c s = List.rev (rev_split c s) let rev_bounded_split c s n = let rec aux acc i n = let get_rest_of_s i = (String.sub s i (String.length s - i)) in if n = 1 then get_rest_of_s i :: acc else try let j = String.index_from s i c in aux (String.sub s i (j-i) :: acc) (j+1) (n-1) with Not_found -> get_rest_of_s i :: acc | Invalid_argument _ -> ""::acc in aux [] 0 n let bounded_split c s n = List.rev (rev_bounded_split c s n) let rec join sep l = match l with | [] -> "" | [x] -> x | x :: rest -> x ^ sep ^ join sep rest let ends_with s suf = let rec aux s suf suflen offset i = i >= suflen || (s.[i + offset] = suf.[i] && aux s suf suflen offset (i+1)) in let slen = String.length s in let suflen = String.length suf in slen >= suflen && aux s suf suflen (slen - suflen) 0 let pad_right c s i = let sl = String.length s in if sl < i then let p = Bytes.create i in Bytes.blit_string s 0 p 0 sl; Bytes.fill p sl (i-sl) c; Bytes.unsafe_to_string p else if sl > i then String.sub s 0 i else s let has_prefix pref s = let l = String.length pref in if String.length s < l then false else try for i = 0 to l - 1 do if s.[i] <> pref.[i] then raise Exit done; true with Exit -> false let remove_prefix pref s = let l = String.length pref in if String.length s < l then raise Not_found else for i = 0 to l - 1 do if s.[i] <> pref.[i] then raise Not_found done; String.sub s l (String.length s - l) why3-0.88.3/src/util/pp.mli0000664000175100017510000001363313225666037016150 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (*i $Id: pp.mli,v 1.22 2009-10-19 11:55:33 bobot Exp $ i*) open Format val print_option : (formatter -> 'a -> unit) -> formatter -> 'a option -> unit val print_option_or_default : string -> (formatter -> 'a -> unit) -> formatter -> 'a option -> unit val print_list_pre : (formatter -> unit -> unit) -> (formatter -> 'a -> unit) -> formatter -> 'a list -> unit val print_list_suf : (formatter -> unit -> unit) -> (formatter -> 'a -> unit) -> formatter -> 'a list -> unit val print_list : (formatter -> unit -> unit) -> (formatter -> 'a -> unit) -> formatter -> 'a list -> unit val print_list_or_default : string -> (formatter -> unit -> unit) -> (formatter -> 'a -> unit) -> formatter -> 'a list -> unit val print_list_par : (Format.formatter -> unit -> 'a) -> (Format.formatter -> 'b -> unit) -> Format.formatter -> 'b list -> unit val print_list_delim : start:(Format.formatter -> unit -> unit) -> stop:(Format.formatter -> unit -> unit) -> sep:(Format.formatter -> unit -> unit) -> (Format.formatter -> 'b -> unit) -> Format.formatter -> 'b list -> unit val print_pair_delim : (Format.formatter -> unit -> unit) -> (Format.formatter -> unit -> unit) -> (Format.formatter -> unit -> unit) -> (Format.formatter -> 'a -> unit) -> (Format.formatter -> 'b -> unit) -> Format.formatter -> 'a * 'b -> unit val print_pair : (Format.formatter -> 'a -> unit) -> (Format.formatter -> 'b -> unit) -> Format.formatter -> 'a * 'b -> unit val print_iter1 : (('a -> unit) -> 'b -> unit) -> (Format.formatter -> unit -> unit) -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'b -> unit val print_iter2: (('a -> 'b -> unit) -> 'c -> unit) -> (Format.formatter -> unit -> unit) -> (Format.formatter -> unit -> unit) -> (Format.formatter -> 'a -> unit) -> (Format.formatter -> 'b -> unit) -> Format.formatter -> 'c -> unit (** [print_iter2 iter sep1 sep2 print1 print2 fmt t] iter iterator on [t : 'c] print1 k sep2 () print2 v sep1 () print1 sep2 () ... *) val print_iter22: (('a -> 'b -> unit) -> 'c -> unit) -> (Format.formatter -> unit -> unit) -> (Format.formatter -> 'a -> 'b -> unit) -> Format.formatter -> 'c -> unit (** [print_iter22 iter sep print fmt t] iter iterator on [t : 'c] print k v sep () print k v sep () ... *) (** formatted: string which is formatted "@ " allow to cut the line if too long *) type formatted = (unit, unit, unit, unit, unit, unit) format6 val empty_formatted : formatted val space : formatter -> unit -> unit val alt : formatter -> unit -> unit val alt2 : formatter -> unit -> unit val newline : formatter -> unit -> unit val newline2 : formatter -> unit -> unit val dot : formatter -> unit -> unit val comma : formatter -> unit -> unit val star : formatter -> unit -> unit val simple_comma : formatter -> unit -> unit val semi : formatter -> unit -> unit val colon : formatter -> unit -> unit val underscore : formatter -> unit -> unit val equal : formatter -> unit -> unit val arrow : formatter -> unit -> unit val lbrace : formatter -> unit -> unit val rbrace : formatter -> unit -> unit val lsquare : formatter -> unit -> unit val rsquare : formatter -> unit -> unit val lparen : formatter -> unit -> unit val rparen : formatter -> unit -> unit val lchevron : formatter -> unit -> unit val rchevron : formatter -> unit -> unit val nothing : formatter -> 'a -> unit val string : formatter -> string -> unit val float : formatter -> float -> unit val int : formatter -> int -> unit val constant_string : string -> formatter -> unit -> unit val formatted : formatter -> formatted -> unit val constant_formatted : formatted -> formatter -> unit -> unit val print0 : formatter -> unit -> unit val hov : int -> (formatter -> 'a -> unit) -> formatter -> 'a -> unit val indent : int -> (formatter -> 'a -> unit) -> formatter -> 'a -> unit (** add the indentation at the first line *) val add_flush : (formatter -> 'a -> unit) -> formatter -> 'a -> unit val asd : (formatter -> 'a -> unit) -> (formatter -> 'a -> unit) (** add string delimiter " " *) val open_formatter : ?margin:int -> out_channel -> formatter val close_formatter : formatter -> unit val open_file_and_formatter : ?margin:int -> string -> out_channel * formatter val close_file_and_formatter : out_channel * formatter -> unit val print_in_file_no_close : ?margin:int -> (Format.formatter -> unit) -> string -> out_channel val print_in_file : ?margin:int -> (Format.formatter -> unit) -> string -> unit val print_list_opt : (formatter -> unit -> unit) -> (formatter -> 'a -> bool) -> formatter -> 'a list -> bool val string_of : ?max_boxes:int -> (Format.formatter -> 'a -> unit) -> 'a -> string val string_of_wnl : (Format.formatter -> 'a -> unit) -> 'a -> string (** same as {!string_of} but without newline *) val wnl : Format.formatter -> unit val sprintf : ('b, formatter, unit, string) Pervasives.format4 -> 'b val sprintf_wnl : ('b, formatter, unit, string) Pervasives.format4 -> 'b val html_char : Format.formatter -> char -> unit val html_string : Format.formatter -> string -> unit (** formats the string by escaping special HTML characters quote, double quote, <, > and & *) module Ansi : sig val set_column : Format.formatter -> int -> unit end type formatter = Format.formatter why3-0.88.3/src/util/number.mli0000664000175100017510000001047513225666037017022 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Format (** Construction *) exception InvalidConstantLiteral of int * string type integer_constant = private | IConstDec of string | IConstHex of string | IConstOct of string | IConstBin of string type real_constant = private | RConstDec of string * string * string option (* int / frac / exp *) | RConstHex of string * string * string option type constant = | ConstInt of integer_constant | ConstReal of real_constant val int_const_dec : string -> integer_constant val int_const_hex : string -> integer_constant val int_const_oct : string -> integer_constant val int_const_bin : string -> integer_constant (** these four functions construct integer constant terms from some string [s] of digits in the corresponding base. Exception InvalidConstantLiteral(base,s) is raised if [s] contains invalid characters for the given base. *) val compute_int : integer_constant -> BigInt.t val real_const_dec : string -> string -> string option -> real_constant val real_const_hex : string -> string -> string option -> real_constant (** Pretty-printing *) val print_integer_constant : formatter -> integer_constant -> unit val print_real_constant : formatter -> real_constant -> unit val print_constant : formatter -> constant -> unit (** Pretty-printing with conversion *) type integer_format = (string -> unit, Format.formatter, unit) format type real_format = (string -> string -> string -> unit, Format.formatter, unit) format type part_real_format = (string -> string -> unit, Format.formatter, unit) format type dec_real_format = | PrintDecReal of part_real_format * real_format type frac_real_format = | PrintFracReal of integer_format * part_real_format * part_real_format type 'a number_support_kind = | Number_unsupported | Number_default | Number_custom of 'a type integer_support_kind = integer_format number_support_kind type number_support = { long_int_support : bool; extra_leading_zeros_support : bool; dec_int_support : integer_support_kind; hex_int_support : integer_support_kind; oct_int_support : integer_support_kind; bin_int_support : integer_support_kind; def_int_support : integer_support_kind; dec_real_support : dec_real_format number_support_kind; hex_real_support : real_format number_support_kind; frac_real_support : frac_real_format number_support_kind; def_real_support : integer_support_kind; } val print : number_support -> formatter -> constant -> unit val print_in_base : int -> int option -> formatter -> BigInt.t -> unit (** [print_in_base radix digits fmt i] prints the value of [i] in base [radix]. If digits is not [None] adds leading 0s to have [digits] characters. *) (** Range checking *) type int_range = { ir_lower : BigInt.t; ir_upper : BigInt.t; } exception OutOfRange of integer_constant val check_range : integer_constant -> int_range -> unit (** [check_range c ir] checks that [c] is in the range described by [ir], and raises [OutOfRange c] if not. *) (** Float checking *) type float_format = { fp_exponent_digits : int; fp_significand_digits : int; (* counting the hidden bit *) } exception NonRepresentableFloat of real_constant val compute_float : real_constant -> float_format -> BigInt.t * BigInt.t (** [compute_float c fp] checks that [c] is a float literal representable in the format [fp]. Returns a pair [e,s] with [s] the significand (without the hidden bit), and [e] the biased exponent. Raises [NonRepresentableFloat c] exception otherwise. *) val check_float : real_constant -> float_format -> unit (** [check_float c fp] is the same as [compute_float c fp] but does not return any value. *) why3-0.88.3/src/util/loc.mli0000664000175100017510000000447113225666037016306 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Format (* Lexing locations *) val current_offset : int ref val reloc : Lexing.position -> Lexing.position val set_file : string -> Lexing.lexbuf -> unit val transfer_loc : Lexing.lexbuf -> Lexing.lexbuf -> unit (* locations in files *) type position val extract : Lexing.position * Lexing.position -> position val join : position -> position -> position val dummy_position : position val user_position : string -> int -> int -> int -> position val get : position -> string * int * int * int val compare : position -> position -> int val equal : position -> position -> bool val hash : position -> int val gen_report_position : formatter -> position -> unit val report_position : formatter -> position -> unit (* located exceptions *) exception Located of position * exn val try1: ?loc:position -> ('a -> 'b) -> ('a -> 'b) val try2: ?loc:position -> ('a -> 'b -> 'c) -> ('a -> 'b -> 'c) val try3: ?loc:position -> ('a -> 'b -> 'c -> 'd) -> ('a -> 'b -> 'c -> 'd) val try4: ?loc:position -> ('a -> 'b -> 'c -> 'd -> 'e) -> ('a -> 'b -> 'c -> 'd -> 'e) val try5: ?loc:position -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f) val try6: ?loc:position -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) val try7: ?loc:position -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h) val error: ?loc:position -> exn -> 'a (* messages *) exception Message of string val errorm: ?loc:position -> ('a, Format.formatter, unit, 'b) format4 -> 'a val with_location: (Lexing.lexbuf -> 'a) -> (Lexing.lexbuf -> 'a) why3-0.88.3/src/util/plugin.ml0000664000175100017510000000434313225666037016654 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) type plugin = string let debug = Debug.register_info_flag "load_plugin" ~desc:"Print@ debugging@ messages@ about@ plugin@ loading." exception Plugin_Not_Found of plugin * string list let loadfile f = Debug.dprintf debug "Plugin loaded : %s@." f; Dynlink.loadfile_private f let add_extension p = if Dynlink.is_native then p^".cmxs" else p^".cmo" let load ?dirs p = let p = add_extension p in let f = match dirs with | None -> p | Some ld -> let rec find = function | [] -> raise (Plugin_Not_Found (p,ld)) | d::ld -> let f = Filename.concat d p in if Sys.file_exists f then f else find ld in find ld in loadfile f type plu = (* not a plugin extension *) | Plubad (* good plugin extension *) | Plugood (* good plugin extension but fail to load *) | Plufail of exn (* good plugin extension but not tested *) | Pluother let check_plugin f = let cmxs = Filename.check_suffix f ".cmxs" in let cmo = Filename.check_suffix f ".cmo" in if not cmxs && not cmo then Plubad else if (if Dynlink.is_native then cmxs else cmo) then try loadfile f; Plugood with exn -> Plufail exn else Pluother let () = Exn_printer.register (fun fmt exn -> match exn with | Plugin_Not_Found (pl,sl) -> Format.fprintf fmt "The plugin %s can't be found in the directories %a" pl (Pp.print_list Pp.space Pp.string) sl | Dynlink.Error (error) -> Format.fprintf fmt "Dynlink error : %s" (Dynlink.error_message error) | _ -> raise exn) why3-0.88.3/src/util/util.ml0000664000175100017510000000420713225666037016332 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (* useful combinators *) let const f _ = f let const2 f _ _ = f let const3 f _ _ _ = f let flip f x y = f y x (* useful iterator on int *) let rec foldi f acc min max = if min > max then acc else foldi f (f acc min) (succ min) max let mapi f = foldi (fun acc i -> f i::acc) [] (* useful iterator on float *) let rec iterf f min max step = if min > max then () else (f min; iterf f (min+.step) max step) (* boolean fold accumulators *) exception FoldSkip let all_fn pr = (fun _ x -> pr x || raise FoldSkip) let any_fn pr = (fun _ x -> pr x && raise FoldSkip) let all2_fn pr = (fun _ x y -> pr x y || raise FoldSkip) let any2_fn pr = (fun _ x y -> pr x y && raise FoldSkip) type ('z,'a,'c) fold = ('z -> 'a -> 'z) -> 'z -> 'c -> 'z let all fold pr x = try fold (all_fn pr) true x with FoldSkip -> false let any fold pr x = try fold (any_fn pr) false x with FoldSkip -> true type ('z,'a,'b,'c,'d) fold2 = ('z -> 'a -> 'b -> 'z) -> 'z -> 'c -> 'd -> 'z let all2 fold pr x y = try fold (all2_fn pr) true x y with FoldSkip -> false let any2 fold pr x y = try fold (any2_fn pr) false x y with FoldSkip -> true type ('z,'a,'b,'c) foldd = ('z -> 'a -> 'z) -> ('z -> 'b -> 'z) -> 'z -> 'c -> 'z let alld fold pr1 pr2 x = try fold (all_fn pr1) (all_fn pr2) true x with FoldSkip -> false let anyd fold pr1 pr2 x = try fold (any_fn pr1) (any_fn pr2) false x with FoldSkip -> true (* constant boolean function *) let ttrue _ = true let ffalse _ = false why3-0.88.3/src/util/hashcons.ml0000664000175100017510000000362013225666037017161 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (*s Hash tables for hash-consing. (Some code is borrowed from the ocaml standard library, which is copyright 1996 INRIA.) *) module type HashedType = sig type t val equal : t -> t -> bool val hash : t -> int val tag : int -> t -> t end module type S = sig type t val hashcons : t -> t val unique : t -> t val iter : (t -> unit) -> unit val stats : unit -> int * int * int * int * int * int end module Make(H : HashedType) : (S with type t = H.t) = struct type t = H.t module WH = Weak.Make (H) let next_tag = ref 0 let htable = WH.create 5003 let hashcons d = let d = H.tag !next_tag d in let o = WH.merge htable d in if o == d then incr next_tag; o let unique d = let d = H.tag !next_tag d in incr next_tag; d let iter f = WH.iter f htable let stats () = WH.stats htable end let combine acc n = acc * 65599 + n let combine2 acc n1 n2 = combine (combine acc n1) n2 let combine3 acc n1 n2 n3 = combine (combine2 acc n1 n2) n3 let combine_list f acc l = List.fold_left (fun acc x -> combine acc (f x)) acc l let combine_option h = function None -> -1 | Some s -> h s let combine_pair h1 h2 (a1,a2) = combine (h1 a1) (h2 a2) why3-0.88.3/src/util/weakhtbl.mli0000664000175100017510000000403213225666037017323 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** Hashtables with weak key used for memoization *) type tag val dummy_tag : tag val create_tag : int -> tag val tag_equal : tag -> tag -> bool val tag_hash : tag -> int module type S = sig type key type 'a t val create : int -> 'a t (* create a hashtbl with weak keys *) val clear : 'a t -> unit val copy : 'a t -> 'a t val find : 'a t -> key -> 'a (* find the value bound to a key. Raises Not_found if there is no binding *) val mem : 'a t -> key -> bool (* test if a key is bound *) val set : 'a t -> key -> 'a -> unit (* bind the key _once_ with the given value *) val remove : 'a t -> key -> unit (* remove the value *) val iter : (key -> 'a -> unit) -> 'a t -> unit val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val iterk : (key -> unit) -> 'a t -> unit val foldk : (key -> 'b -> 'b) -> 'a t -> 'b -> 'b val length : 'a t -> int val memoize : int -> (key -> 'a) -> (key -> 'a) (* create a memoizing function *) val memoize_rec : int -> ((key -> 'a) -> (key -> 'a)) -> (key -> 'a) (* create a memoizing recursive function *) val memoize_option : int -> (key option -> 'a) -> (key option -> 'a) (* memoizing functions on option types *) end module type Weakey = sig type t val tag : t -> tag end module Make (S : Weakey) : S with type key = S.t why3-0.88.3/src/util/bigInt.mli0000664000175100017510000000401113225666037016733 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) type t val compare : t -> t -> int (** constants *) val zero : t val one : t val of_int : int -> t (** basic operations *) val succ : t -> t val pred : t -> t val add_int : int -> t -> t val mul_int : int -> t -> t val add : t -> t -> t val sub : t -> t -> t val mul : t -> t -> t val minus : t -> t val sign : t -> int (** comparisons *) val eq : t -> t -> bool val lt : t -> t -> bool val gt : t -> t -> bool val le : t -> t -> bool val ge : t -> t -> bool (** Division and modulo operators with the convention that modulo is always non-negative. It implies that division rounds down when divisor is positive, and rounds up when divisor is negative. *) val euclidean_div_mod : t -> t -> t * t val euclidean_div : t -> t -> t val euclidean_mod : t -> t -> t (** "computer" division, i.e division rounds towards zero, and thus [mod x y] has the same sign as x *) val computer_div_mod : t -> t -> t * t val computer_div : t -> t -> t val computer_mod : t -> t -> t (** min, max, abs *) val min : t -> t -> t val max : t -> t -> t val abs : t -> t (** number of digits *) val num_digits : t -> int (** power of small integers. Second arg must be non-negative *) val pow_int_pos : int -> int -> t val pow_int_pos_bigint : int -> t -> t (** conversions *) val of_string : string -> t val to_string : t -> string val to_int : t -> int why3-0.88.3/src/util/plugin.mli0000664000175100017510000000273313225666037017026 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) type plugin = string exception Plugin_Not_Found of plugin * string list val debug : Debug.flag (** debug flag for the plugin mechanism (option "--debug load_plugin") If set [load_plugin] prints on stderr exactly which plugin are loaded. *) val load : ?dirs:string list -> plugin -> unit (* [load_plugin ~dir plugin] looks in the directories [dir] for the plugin named [plugin]. It add the extension .cmo or .cmxs to the filename according to the compilation used for the main program *) type plu = (* not a plugin extension *) | Plubad (* good plugin extension *) | Plugood (* good plugin extension but fail to load *) | Plufail of exn (* good plugin extension but not tested ( other kind of compilation ) *) | Pluother val check_plugin : plugin -> plu why3-0.88.3/src/util/opt.mli0000664000175100017510000000303013225666037016321 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** Useful option combinators *) val inhabited : 'a option -> bool val get : 'a option -> 'a val get_exn : exn -> 'a option -> 'a val get_def : 'a -> 'a option -> 'a val map : ('a -> 'b) -> 'a option -> 'b option val iter : ('a -> unit) -> 'a option -> unit val apply : 'b -> ('a -> 'b) option -> 'a -> 'b val apply2 : 'c -> ('a -> 'b -> 'c) option -> 'a -> 'b -> 'c val fold : ('b -> 'a -> 'b) -> 'b -> 'a option -> 'b (** [fold f d o] returns [d] if [o] is [None], and [f d x] if [o] is [Some x] *) val fold_right : ('a -> 'b -> 'b) -> 'a option -> 'b -> 'b val map2 : ('a -> 'b -> 'c) -> 'a option -> 'b option -> 'c option val equal : ('a -> 'b -> bool) -> 'a option -> 'b option -> bool val compare : ('a -> 'b -> int) -> 'a option -> 'b option -> int val map_fold : ('a -> 'b -> 'a * 'b) -> 'a -> 'b option -> 'a * 'b option why3-0.88.3/src/util/strings.mli0000664000175100017510000000413613225666037017220 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** {1 Additional Useful Functions on Character Strings} *) (** {2 Wrappers for deprecated string functions of OCaml stdlib} *) val capitalize : string -> string val uncapitalize : string -> string (** {2 Other useful functions on strings} *) val rev_split : char -> string -> string list val split : char -> string -> string list (** [split c s] splits [s] into substrings, taking as delimiter the character [c], and returns the list of substrings. An occurrence of the delimiter at the beginning or at the end of the string is ignored. *) val bounded_split : char -> string -> int -> string list (** [bounded_split c s n] do the same as [split c s] but splits into [n] substring at most. The concatenation of returned substrings is equal to the string s.*) val join : string -> string list -> string (** [join sep l] joins all the strings in [l] together, in the same order, separating them by [sep] *) val ends_with : string -> string -> bool (** test if a string ends with another *) val pad_right : char -> string -> int -> string (** chop or pad the given string on the right up to the given length *) val has_prefix : string -> string -> bool (** [has_prefix pref s] returns true if s [s] starts with prefix [pref] *) val remove_prefix : string -> string -> string (** [remove_prefix pref s] removes the prefix [pref] from [s]. Raises [Not_found] if [s] does not start with [pref] *) why3-0.88.3/src/util/util.mli0000664000175100017510000000523213225666037016502 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** Useful functions *) val const : 'a -> 'b -> 'a val const2 : 'a -> 'b -> 'c -> 'a val const3 : 'a -> 'b -> 'c -> 'd -> 'a val flip : ('a -> 'b -> 'c) -> 'b -> 'a -> 'c val foldi : ('a -> int -> 'a) -> 'a -> int -> int -> 'a val mapi : (int -> 'a) -> int -> int -> 'a list val iterf : (float -> unit) -> float -> float -> float -> unit (** [iterf f min max step] *) (** Convert fold-like functions into [for_all] and [exists] functions. Predicates passed to [all], [all2], and [alld] may raise FoldSkip to signalize [false]. Predicates passed to [any], [any2], and [anyd] may raise FoldSkip to signalize [true]. *) exception FoldSkip val all_fn : ('a -> bool) -> 'z -> 'a -> bool (** [all_fn pr z a] return true if [pr a] is true, otherwise raise FoldSkip *) val any_fn : ('a -> bool) -> 'z -> 'a -> bool (** [any_fn pr z a] return false if [pr a] is false, otherwise raise FoldSkip *) val all2_fn : ('a -> 'b -> bool) -> 'z -> 'a -> 'b -> bool (** [all2_fn pr z a b] return true if [pr a b] is true, otherwise raise FoldSkip *) val any2_fn : ('a -> 'b -> bool) -> 'z -> 'a -> 'b -> bool (** [any2_fn pr z a b] return false if [pr a b] is false, otherwise raise FoldSkip *) type ('z,'a,'c) fold = ('z -> 'a -> 'z) -> 'z -> 'c -> 'z val all : (bool,'a,'c) fold -> ('a -> bool) -> 'c -> bool val any : (bool,'a,'c) fold -> ('a -> bool) -> 'c -> bool type ('z,'a,'b,'c,'d) fold2 = ('z -> 'a -> 'b -> 'z) -> 'z -> 'c -> 'd -> 'z val all2 : (bool,'a,'b,'c,'d) fold2 -> ('a -> 'b -> bool) -> 'c -> 'd -> bool val any2 : (bool,'a,'b,'c,'d) fold2 -> ('a -> 'b -> bool) -> 'c -> 'd -> bool type ('z,'a,'b,'c) foldd = ('z -> 'a -> 'z) -> ('z -> 'b -> 'z) -> 'z -> 'c -> 'z val alld : (bool,'a,'b,'c) foldd -> ('a -> bool) -> ('b -> bool) -> 'c -> bool val anyd : (bool,'a,'b,'c) foldd -> ('a -> bool) -> ('b -> bool) -> 'c -> bool val ffalse : 'a -> bool (** [ffalse] constant function [false] *) val ttrue : 'a -> bool (** [ttrue] constant function [true] *) why3-0.88.3/src/util/print_tree.mli0000664000175100017510000000351713225666037017704 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (*s This module provides a generic ASCII pretty-printing function for trees, in a way similar to what the Unix command pstree does: bash-+-emacs-+-emacsserver | `-ispell |-pstree `-xdvi.bin *) (*s A tree structure is given as an abstract type [t] together with a decomposition function [decomp] returning the label of the node and the list of the children trees. Leaves are nodes with no child (i.e. an empty list). *) module type Tree = sig type t val decomp : t -> string * t list end (*s The functor [Make] takes a tree structure [T] as argument and provides a single function [print: formatter -> T.t -> unit] to print a tree on a given formatter. *) module Make (T : Tree) : sig val print : Format.formatter -> T.t -> unit end (** With type variable *) module type PTree = sig type 'a t val decomp : 'a t -> string * 'a t list end (*s The functor [Make] takes a tree structure [T] as argument and provides a single function [print: formatter -> T.t -> unit] to print a tree on a given formatter. *) module PMake (T : PTree) : sig val print : Format.formatter -> 'a T.t -> unit end why3-0.88.3/src/util/extset.mli0000664000175100017510000001453513225666037017047 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** Sets over ordered types *) (** Input signature of the functor {!Extset.Make}. *) module type OrderedType = Set.OrderedType (** Output signature of the functor {!Extset.Make}. *) module type S = sig module M : Extmap.S (** The module of association tables over [elt]. *) type elt = M.key (** The type of set elements. *) type t = unit M.t (** The type of sets of type [elt]. *) val empty: t (** The empty set. *) val is_empty: t -> bool (** Test whether a set is empty or not. *) val mem: elt -> t -> bool (** [mem x s] returns [true] if [s] contains [x], and [false] otherwise. *) val add: elt -> t -> t (** [add x s] returns a set containing the same elements as [s], plus [x]. *) val singleton: elt -> t (** [singleton x] returns the one-element set that contains [x]. *) val remove: elt -> t -> t (** [remove x s] returns a set containing the same elements as [s], except for [x]. *) val merge: (elt -> bool -> bool -> bool) -> t -> t -> t (** [merge f s1 s2] computes a set whose elts is a subset of elts of [s1] and of [s2]. The presence of each such element is determined with the function [f]. *) val compare: t -> t -> int (** Total ordering between sets. *) val equal: t -> t -> bool (** [equal s1 s2] tests whether the sets [s1] and [s2] are equal. *) val subset: t -> t -> bool (** [subset s1 s2] tests whether the set [s1] is a subset of [s2]. *) val disjoint: t -> t -> bool (** [disjoint s1 s2] tests whether the sets [s1] and [s2] are disjoint. *) val iter: (elt -> unit) -> t -> unit (** [iter f s] applies [f] to all elements of [s]. The elements are passed to [f] in increasing order with respect to the ordering over the type of the elts. *) val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a (** [fold f s a] computes [(f eN ... (f e1 a)...)], where [e1 ... eN] are the element of [s] in increasing order. *) val for_all: (elt -> bool) -> t -> bool (** [for_all p s] checks if all the elements of [s] satisfy the predicate [p]. *) val exists: (elt -> bool) -> t -> bool (** [exists p s] checks if at least one element of [s] satisfies the predicate [p]. *) val filter: (elt -> bool) -> t -> t (** [filter p s] returns the set with all the elements of [s] that satisfy predicate [p]. *) val partition: (elt -> bool) -> t -> t * t (** [partition p s] returns a pair of sets [(s1, s2)], where [s1] contains all the elements of [s] that satisfy the predicate [p], and [s2] is the map with all the elements of [s] that do not satisfy [p]. *) val cardinal: t -> int (** Return the number of elements in a set. *) val elements: t -> elt list (** Return the list of all elements of the given set. The returned list is sorted in increasing order. *) val min_elt: t -> elt (** Return the smallest element of the given set or raise [Not_found] if the set is empty. *) val max_elt: t -> elt (** Return the largest element of the given set or raise [Not_found] if the set is empty. *) val choose: t -> elt (** Return one element of the given set, or raise [Not_found] if the set is empty. Which element is chosen is unspecified, but equal elements will be chosen for equal sets. *) val split: elt -> t -> t * bool * t (** [split x s] returns a triple [(l, mem, r)], where [l] is the set with all the elements of [s] that are strictly less than [x]; [r] is the set with all the elements of [s] that are strictly greater than [x]; [mem] is [true] if [x] belongs to [s] and [false] otherwise. *) val change : (bool -> bool) -> elt -> t -> t (** [change f x s] returns a set containing the same elements as [s], except [x] which is added to [s] if [f (mem x s)] returns [true] and removed otherwise. *) val union : t -> t -> t (** [union f s1 s2] computes the union of two sets *) val inter : t -> t -> t (** [inter f s1 s2] computes the intersection of two sets *) val diff : t -> t -> t (** [diff f s1 s2] computes the difference of two sets *) val fold_left : ('b -> elt -> 'b) -> 'b -> t -> 'b (** same as {!fold} but in the order of {!List.fold_left} *) val fold2_inter : (elt -> 'a -> 'a) -> t -> t -> 'a -> 'a (** [fold2_inter f s1 s2 a] computes [(f eN ... (f e1 a) ...)], where [e1 ... eN] are the elements of [inter s1 s2] in increasing order. *) val fold2_union : (elt -> 'a -> 'a) -> t -> t -> 'a -> 'a (** [fold2_union f s1 s2 a] computes [(f eN ... (f e1 a) ...)], where [e1 ... eN] are the elements of [union s1 s2] in increasing order. *) val translate : (elt -> elt) -> t -> t (** [translate f s] translates the elements in the set [s] by the function [f]. [f] must be strictly monotone on the elements of [s]. Otherwise it raises invalid_arg *) val add_new : exn -> elt -> t -> t (** [add_new e x s] adds [x] to [s] if [s] does not contain [x], and raises [e] otherwise. *) val is_num_elt : int -> t -> bool (** check if the map has the given number of elements *) val of_list: elt list -> t (** construct a set from a list of elements *) end module MakeOfMap (M : Extmap.S) : S with module M = M (** Functor building an implementation of the set structure given a totally ordered type. *) module Make (Ord : OrderedType) : S with type M.key = Ord.t (** Functor building an implementation of the set structure given a totally ordered type. *) why3-0.88.3/src/util/rc.mll0000664000175100017510000002741513225666037016143 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) { open Lexing open Format open Stdlib let get_home_dir () = try Sys.getenv "HOME" with Not_found -> (* try windows env var *) try Sys.getenv "USERPROFILE" with Not_found -> "" type rc_value = | RCint of int | RCbool of bool | RCfloat of float | RCstring of string | RCident of string (* Error handling *) (* exception SyntaxError *) exception ExtraParameters of string exception MissingParameters of string (* exception UnknownSection of string *) exception UnknownField of string (* exception MissingSection of string *) exception MissingField of string exception DuplicateSection of string exception DuplicateField of string * rc_value * rc_value exception StringExpected of string * rc_value (* dead code exception IdentExpected of string * rc_value *) exception IntExpected of string * rc_value exception BoolExpected of string * rc_value (* dead code let error ?loc e = match loc with | None -> raise e | Some loc -> raise (Loc.Located (loc, e)) *) (* conf files *) let escape_string s = let n = ref 0 in for i = 0 to String.length s - 1 do n := !n + (match String.unsafe_get s i with | '"' | '\\' | '\n' | '\r' | '\t' -> 2 | _ -> 1) done; if !n = String.length s then s else begin let s' = Bytes.create !n in n := 0; for i = 0 to String.length s - 1 do let c = String.unsafe_get s i in begin match c with | ('"' | '\\' | '\n' | '\r' | '\t') -> Bytes.set s' !n '\\'; incr n | _ -> () end; Bytes.set s' !n (match c with '\n' -> 'n' | '\r' -> 'r' | '\t' -> 't' | _ -> c); incr n done; Bytes.unsafe_to_string s' end let print_rc_value fmt = function | RCint i -> fprintf fmt "%d" i | RCbool b -> fprintf fmt "%B" b | RCfloat f -> fprintf fmt "%f" f | RCstring s -> fprintf fmt "\"%s\"" (escape_string s) | RCident s -> fprintf fmt "%s" s let () = Exn_printer.register (fun fmt e -> match e with (* | SyntaxError -> *) (* fprintf fmt "syntax error" *) | ExtraParameters s -> fprintf fmt "section '%s': header too long" s | MissingParameters s -> fprintf fmt "section '%s': header too short" s (* | UnknownSection s -> *) (* fprintf fmt "unknown section '%s'" s *) | UnknownField s -> fprintf fmt "unknown field '%s'" s (* | MissingSection s -> *) (* fprintf fmt "section '%s' is missing" s *) | MissingField s -> fprintf fmt "field '%s' is missing" s | DuplicateSection s -> fprintf fmt "section '%s' is already given" s | DuplicateField (s,u,v) -> fprintf fmt "cannot set field '%s' to %a, as it is already set to %a" s print_rc_value v print_rc_value u | StringExpected (s,v) -> fprintf fmt "cannot set field '%s' to %a: a string is expected" s print_rc_value v (* dead code | IdentExpected (s,v) -> fprintf fmt "cannot set field '%s' to %a: an identifier is expected" s print_rc_value v *) | IntExpected (s,v) -> fprintf fmt "cannot set field '%s' to %a: an integer is expected" s print_rc_value v | e -> raise e) type section = rc_value list Mstr.t type family = (string * section) list type simple_family = section list type ofamily = (string option * section) list type t = ofamily Mstr.t let empty = Mstr.empty let empty_section = Mstr.empty let make_t tl = let add_key acc (key,value) = let l = Mstr.find_def [] key acc in Mstr.add key (value::l) acc in let add_section t (args,sectionl) = let sname,arg = match args with | [] -> assert false | [sname] -> sname,None | [sname;arg] -> sname,Some arg | sname::_ -> raise (ExtraParameters sname) in let m = List.fold_left add_key empty_section sectionl in let m = Mstr.map List.rev m in let l = Mstr.find_def [] sname t in Mstr.add sname ((arg,m)::l) t in List.fold_left add_section empty tl let get_section t sname = try let l = Mstr.find sname t in match l with | [None,v] -> Some v | [Some _,_] -> raise (ExtraParameters sname) | _ -> raise (DuplicateSection sname) with Not_found -> None let get_family t sname = try let l = Mstr.find sname t in let get (arg,section) = (match arg with None -> raise (MissingParameters sname) | Some v -> v, section) in List.map get l with Not_found -> [] let get_simple_family t sname = try let l = Mstr.find sname t in let get (arg,section) = (match arg with Some _ -> raise (ExtraParameters sname) | None -> section) in List.map get l with Not_found -> [] let set_section t sname section = Mstr.add sname [None,section] t let set_family t sname sections = if sections = [] then Mstr.remove sname t else let set (arg,section) = (Some arg,section) in Mstr.add sname (List.map set sections) t let set_simple_family t sname sections = if sections = [] then Mstr.remove sname t else let set section = (None,section) in Mstr.add sname (List.map set sections) t let get_value read section key = let l = Mstr.find key section in match l with | [] -> assert false | [v] -> read key v | v1::v2::_ -> raise (DuplicateField (key,v1,v2)) let get_value read ?default section key = try get_value read section key with Not_found -> match default with | None -> raise (MissingField key) | Some v -> v let get_valueo read section key = try Some (get_value read section key) with MissingField _ -> None let get_valuel read ?default section key = try let l = Mstr.find key section in List.map (read key) l with Not_found -> match default with | None -> raise (MissingField key) | Some v -> v let set_value write ?default section key value = let actually_write = match default with | None -> true | Some default -> default <> value in if actually_write then Mstr.add key [write value] section else section let set_valuel write ?default section key valuel = if valuel = [] then Mstr.remove key section else let actually_write = match default with | None -> true | Some default -> default <> valuel in if actually_write then Mstr.add key (List.map write valuel) section else Mstr.remove key section let rint k = function | RCint n -> n | v -> raise (IntExpected (k,v)) let wint i = RCint i let rbool k = function | RCbool b -> b | v -> raise (BoolExpected (k,v)) let wbool b = RCbool b let rstring k = function | RCident s | RCstring s -> s | v -> raise (StringExpected (k,v)) let wstring s = RCstring s let get_int = get_value rint let get_intl = get_valuel rint let get_into = get_valueo rint let set_int = set_value wint let set_intl = set_valuel wint let get_bool = get_value rbool let get_booll = get_valuel rbool let get_boolo = get_valueo rbool let set_bool = set_value wbool let set_booll = set_valuel wbool let get_string = get_value rstring let get_stringl = get_valuel rstring let get_stringo = get_valueo rstring let set_string = set_value wstring let set_stringl = set_valuel wstring let check_exhaustive section keyl = let test k _ = if Sstr.mem k keyl then () else raise (UnknownField k) in Mstr.iter test section let buf = Buffer.create 17 let current_rec = ref [] let current_list = ref [] let current = ref [] let push_field key value = current_list := (key,value) :: !current_list let push_record () = if !current_list <> [] then current := (!current_rec,List.rev !current_list) :: !current; current_rec := []; current_list := [] exception SyntaxError of string let syntax_error s = raise (SyntaxError s) } let space = [' ' '\t' '\r' '\n']+ let digit = ['0'-'9'] let letter = ['a'-'z' 'A'-'Z'] let ident = (letter | '_') (letter | digit | '_' | '-' | '+' | '.') * let sign = '-' | '+' let integer = sign? digit+ let mantissa = ['e''E'] sign? digit+ let real = sign? digit* '.' digit* mantissa? let escape = ['\\''"''n''t''r'] rule record = parse | space { record lexbuf } | '#' [^'\n']* ('\n' | eof) { record lexbuf } | '[' (ident as key) space* { header [key] lexbuf } | eof { push_record () } | (ident as key) space* '=' space* { value key lexbuf } | _ as c { syntax_error ("invalid keyval pair starting with " ^ String.make 1 c) } and header keylist = parse | (ident as key) space* { header (key::keylist) lexbuf } | ']' { push_record (); current_rec := List.rev keylist; record lexbuf } | eof { syntax_error "unterminated header" } | _ as c { syntax_error ("invalid header starting with " ^ String.make 1 c) } and value key = parse | integer as i { push_field key (RCint (int_of_string i)); record lexbuf } | real as r { push_field key (RCfloat (float_of_string r)); record lexbuf } | '"' { Buffer.clear buf; string_val key lexbuf } | "true" { push_field key (RCbool true); record lexbuf } | "false" { push_field key (RCbool false); record lexbuf } | ident as id { push_field key (RCident (*kind_of_ident*) id); record lexbuf } | eof { syntax_error "unterminated keyval pair" } | _ as c { syntax_error ("invalid value starting with " ^ String.make 1 c) } and string_val key = parse | '"' { push_field key (RCstring (Buffer.contents buf)); record lexbuf } | [^ '\\' '"'] as c { Buffer.add_char buf c; string_val key lexbuf } | '\\' (['\\' '"' 'n' 'r' 't'] as c) { Buffer.add_char buf (match c with 'n' -> '\n' | 'r' -> '\r' | 't' -> '\t' | _ -> c); string_val key lexbuf } | '\\' '\n' { string_val key lexbuf } | '\\' (_ as c) { Buffer.add_char buf '\\'; Buffer.add_char buf c; string_val key lexbuf } | eof { syntax_error "unterminated string" } { let from_channel cin = current := []; record (from_channel cin); make_t !current exception CannotOpen of string * string exception SyntaxErrorFile of string * string let from_file f = let c = try open_in f with Sys_error s -> raise (CannotOpen (f, s)) in try let r = from_channel c in close_in c; r with | SyntaxError s -> close_in c; raise (SyntaxErrorFile (f, s)) | e -> close_in c; raise e let () = Exn_printer.register (fun fmt e -> match e with | CannotOpen (_, s) -> Format.fprintf fmt "system error: `%s'" s | SyntaxErrorFile (f, s) -> Format.fprintf fmt "syntax error in %s: %s" f s | _ -> raise e) let to_formatter fmt t = let print_kv k fmt v = fprintf fmt "%s = %a" k print_rc_value v in let print_kvl fmt k vl = Pp.print_list Pp.newline (print_kv k) fmt vl in let print_section sname fmt (h,l) = fprintf fmt "[%s%a]@\n%a" sname (Pp.print_option (fun fmt -> fprintf fmt " %s")) h (Pp.print_iter22 Mstr.iter Pp.newline print_kvl) l in let print_sectionl fmt sname l = Pp.print_list Pp.newline2 (print_section sname) fmt l in let print_t fmt t = Pp.print_iter22 Mstr.iter Pp.newline2 print_sectionl fmt t in print_t fmt t; pp_print_newline fmt () let to_channel cout t = to_formatter (formatter_of_out_channel cout) t let to_file s t = let out = open_out s in to_channel out t; close_out out } why3-0.88.3/src/util/exn_printer.ml0000664000175100017510000000243013225666037017706 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) type exn_printer = Format.formatter -> exn -> unit let exn_printers = (Stack.create () : (Format.formatter -> exn -> unit) Stack.t) let register exn_printer = Stack.push exn_printer exn_printers let () = let all_exn_printer fmt exn = Format.fprintf fmt "anomaly: %s" (Printexc.to_string exn) in register all_exn_printer exception Exit_loop let exn_printer fmt exn = let test f = try Format.fprintf fmt "@[%a@]" f exn; raise Exit_loop with | Exit_loop -> raise Exit_loop | _ -> () in try Stack.iter test exn_printers with Exit_loop -> () why3-0.88.3/src/util/json.mli0000664000175100017510000000442713225666037016503 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (* use the simple printer functions to quickly print some JSON *) val string : Format.formatter -> string -> unit (* print json string, that is add '"' to the front and back, and escape '"' and '\' in the string *) val int : Format.formatter -> int -> unit (* print an integer *) val bool : Format.formatter -> bool -> unit (* print an boolean *) val float : Format.formatter -> float -> unit (* print an floating point number *) val list : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a list -> unit (* provided a printer for elements, print a json list of these elements. In the case of the empty list, print the json empty list [] *) val map_bindings : ('a -> string) -> (Format.formatter -> 'b -> unit) -> Format.formatter -> ('a * 'b) list -> unit (* arguments: * a mapping from keys to strings; * a printer of values * the formatter * a list of key,value pairs action: print the list of key-value pairs as a json record, if the list is empty, print the empty record *) val print_json_field : string -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit (* given a field name, a value and a printer for the value, print a json mapping (field assignment). Do not print anything else. *) (* for more complex applications it may be convenient to build a an explicit JSON object. Use this type for that and the print_json function to print it *) type json = | Int of int | Float of float | Bool of bool | String of string | List of json list | Record of json Stdlib.Mstr.t val print_json : Format.formatter -> json -> unit why3-0.88.3/src/util/print_tree.ml0000664000175100017510000000576413225666037017541 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (*s Tree structures. *) module type Tree = sig type t val decomp : t -> string * t list end (*s Pretty-print functor. *) module Make(T : Tree) = struct open Format (* [print_node] prints one node and [print_sons] its children. [pref] is the prefix to output at the beginning of line and [start] is the branching drawing (["+-"] the first time, and then ["|-"]). *) let print fmt t = let rec print_node pref t = let (s, sons) = T.decomp t in pp_print_string fmt s; if sons <> [] then let w = String.length s in let pref' = pref ^ String.make (w + 1) ' ' in match sons with | [t'] -> pp_print_string fmt "---"; print_node (pref' ^ " ") t' | _ -> pp_print_string fmt "-"; print_sons pref' "+-" sons and print_sons pref start = function | [] -> assert false | [s] -> pp_print_string fmt "`-"; print_node (pref ^ " ") s | s :: sons -> pp_print_string fmt start; print_node (pref ^ "| ") s; pp_force_newline fmt (); pp_print_string fmt pref; print_sons pref "|-" sons in print_node "" t end (*s Tree structures. *) module type PTree = sig type 'a t val decomp : 'a t -> string * 'a t list end (*s Pretty-print functor. *) module PMake(T : PTree) = struct open Format (* [print_node] prints one node and [print_sons] its children. [pref] is the prefix to output at the beginning of line and [start] is the branching drawing (["+-"] the first time, and then ["|-"]). *) let print fmt t = let rec print_node pref t = let (s, sons) = T.decomp t in pp_print_string fmt s; if sons <> [] then let w = String.length s in let pref' = pref ^ String.make (w + 1) ' ' in match sons with | [t'] -> pp_print_string fmt "---"; print_node (pref' ^ " ") t' | _ -> pp_print_string fmt "-"; print_sons pref' "+-" sons and print_sons pref start = function | [] -> assert false | [s] -> pp_print_string fmt "`-"; print_node (pref ^ " ") s | s :: sons -> pp_print_string fmt start; print_node (pref ^ "| ") s; pp_force_newline fmt (); pp_print_string fmt pref; print_sons pref "|-" sons in print_node "" t end why3-0.88.3/src/util/cmdline.mli0000664000175100017510000000163513225666037017143 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) exception BadEscape of string * char exception UnfinishedEscape of string exception UnclosedQuote of string exception UnclosedDQuote of string exception EmptyCommandLine val cmdline_split : string -> string list why3-0.88.3/src/util/exthtbl.ml0000664000175100017510000000400713225666037017025 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) module type S = sig include Hashtbl.S val find_def : 'a t -> 'a -> key -> 'a val find_opt : 'a t -> key -> 'a option val find_exn : 'a t -> exn -> key -> 'a val map : (key -> 'a -> 'b) -> 'a t -> 'b t val memo : int -> (key -> 'a) -> key -> 'a val is_empty : 'a t -> bool end module type Private = sig type 'a t type key val find : 'a t -> key -> 'a val find_def : 'a t -> 'a -> key -> 'a val find_opt : 'a t -> key -> 'a option val find_exn : 'a t -> exn -> key -> 'a val map : (key -> 'a -> 'b) -> 'a t -> 'b t val iter : (key -> 'a -> unit) -> 'a t -> unit val fold : (key -> 'a -> 'acc -> 'acc) -> 'a t -> 'acc -> 'acc val mem : 'a t -> key -> bool val length : 'a t -> int val is_empty : 'a t -> bool end let hash = Hashtbl.hash module Make (X:Hashtbl.HashedType) : S with type key = X.t = struct module M = Hashtbl.Make(X) include M let memo size f = let h = create size in fun x -> try find h x with Not_found -> let y = f x in add h x y; y let find_def h d k = try find h k with Not_found -> d let find_exn h e k = try find h k with Not_found -> raise e let find_opt h k = try Some (find h k) with Not_found -> None let map f h = let h' = create (length h) in iter (fun k x -> add h' k (f k x)) h; h' let is_empty h = length h = 0 end why3-0.88.3/src/util/bigInt.ml0000664000175100017510000000373713225666037016600 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Big_int type t = big_int let compare = compare_big_int let zero = zero_big_int let one = unit_big_int let of_int = big_int_of_int let succ = succ_big_int let pred = pred_big_int let add_int = add_int_big_int let mul_int = mult_int_big_int let add = add_big_int let sub = sub_big_int let mul = mult_big_int let minus = minus_big_int let sign = sign_big_int let eq = eq_big_int let lt = lt_big_int let gt = gt_big_int let le = le_big_int let ge = ge_big_int let euclidean_div_mod x y = if sign y = 0 then zero, zero else quomod_big_int x y let euclidean_div x y = fst (euclidean_div_mod x y) let euclidean_mod x y = snd (euclidean_div_mod x y) let computer_div_mod x y = let (q,r) as qr = euclidean_div_mod x y in (* when y <> 0, we have x = q*y + r with 0 <= r < |y| *) if sign x >= 0 || sign r = 0 then qr else if sign y < 0 then (pred q, add r y) else (succ q, sub r y) let computer_div x y = fst (computer_div_mod x y) let computer_mod x y = snd (computer_div_mod x y) let min = min_big_int let max = max_big_int let abs = abs_big_int let num_digits = num_digits_big_int let pow_int_pos = power_int_positive_int let pow_int_pos_bigint = power_int_positive_big_int let to_string = string_of_big_int let of_string = big_int_of_string let to_int = int_of_big_int why3-0.88.3/src/util/hashcons.mli0000664000175100017510000000525313225666037017336 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** Hash tables for hash consing Hash consing tables are using weak pointers, so that values that are no more referenced from anywhere else can be erased by the GC. Look in src/core/term.ml for usage examples. *) (** Values to be hash-consed must implement signature [HashedType] below. Type [t] is the type of values to be hash-consed. The user must provide an equality and a hash function over type [t], as well as a function [tag] to build a new value of type [t] from an old one and a unique integer tag. *) module type HashedType = sig type t val equal : t -> t -> bool val hash : t -> int val tag : int -> t -> t end module type S = sig type t val hashcons : t -> t (** [hashcons n] hash-cons value [n] i.e. returns any existing value in the table equal to [n], if any; otherwise, creates a new value with function [tag], stores it in the table and returns it. *) val unique : t -> t (** [unique n] registers the new value [n] without hash-consing. This should be used in case where the value is guaranteed to be unique, i.e. not equal to any other value, old or future. Unique values are not visited by [iter]. *) val iter : (t -> unit) -> unit (** [iter f] iterates [f] over all elements of the table. *) val stats : unit -> int * int * int * int * int * int (** Return statistics on the table. The numbers are, in order: table length, number of entries, sum of bucket lengths, smallest bucket length, median bucket length, biggest bucket length. *) end module Make(H : HashedType) : (S with type t = H.t) (* helpers *) val combine : int -> int -> int val combine2 : int -> int -> int -> int val combine3 : int -> int -> int -> int -> int val combine_list : ('a -> int) -> int -> 'a list -> int val combine_option : ('a -> int) -> 'a option -> int val combine_pair : ('a -> int) -> ('b -> int) -> 'a * 'b -> int why3-0.88.3/src/util/sysutil.ml0000664000175100017510000001341213225666037017067 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) let backup_file f = if Sys.file_exists f then begin let fb = f ^ ".bak" in if Sys.file_exists fb then Sys.remove fb; Sys.rename f fb end let channel_contents_fmt cin fmt = let buff = Bytes.create 1024 in let n = ref 0 in while n := input cin buff 0 1024; !n <> 0 do Format.pp_print_string fmt (if !n = 1024 then Bytes.unsafe_to_string buff else Bytes.sub_string buff 0 !n) done let channel_contents_buf cin = let buf = Buffer.create 1024 in let buff = Bytes.create 1024 in let n = ref 0 in while n := input cin buff 0 1024; !n <> 0 do Buffer.add_subbytes buf buff 0 !n done; buf let channel_contents cin = Buffer.contents (channel_contents_buf cin) let rec fold_channel f acc cin = try fold_channel f (f acc (input_line cin)) cin with End_of_file -> acc let file_contents_fmt f fmt = try let cin = open_in f in channel_contents_fmt cin fmt; close_in cin with _ -> invalid_arg (Printf.sprintf "(cannot open %s)" f) let file_contents_buf f = try let cin = open_in f in let buf = channel_contents_buf cin in close_in cin; buf with _ -> invalid_arg (Printf.sprintf "(cannot open %s)" f) let file_contents f = Buffer.contents (file_contents_buf f) let open_temp_file ?(debug=false) filesuffix usefile = let file,cout = Filename.open_temp_file "why" filesuffix in try let res = usefile file cout in if not debug then Sys.remove file; close_out cout; res with | e -> if not debug then Sys.remove file; close_out cout; raise e let copy_file from to_ = let cin = open_in from in let cout = open_out to_ in let buff = Bytes.create 1024 in let n = ref 0 in while n := input cin buff 0 1024; !n <> 0 do output cout buff 0 !n done; close_out cout; close_in cin let rec copy_dir from to_ = if not (Sys.file_exists to_) then Unix.mkdir to_ 0o755; let files = Sys.readdir from in let copy fname = let src = Filename.concat from fname in let dst = Filename.concat to_ fname in if Sys.is_directory src then copy_dir src dst else copy_file src dst in Array.iter copy files (* return the absolute path of a given file name. this code has been designed to be architecture-independant so be very careful if you modify this *) let path_of_file f = let rec aux acc f = (* Format.printf "aux %s@." f; let _ = read_line () in *) let d = Filename.dirname f in if d = Filename.current_dir_name then (* f is relative to the current dir *) let b = Filename.basename f in aux (b::acc) (Sys.getcwd ()) else if f=d then (* we are at the root *) acc else let b = Filename.basename f in if f=b then b::acc else aux (b::acc) d in aux [] f (* return the file name of an absolute path *) let rec file_of_path l = match l with | [] -> "" | [x] -> x | x::l -> Filename.concat x (file_of_path l) (* let test x = (Filename.dirname x, Filename.basename x) let _ = test "file" let _ = test "/file" let _ = test "/" let _ = test "f1/f2" let _ = test "/f1/f2" let p1 = path_of_file "/bin/bash" let p1 = path_of_file "../src/f.why" *) (* let normalize_filename f = let rec aux af acc = match af, acc with | x::rf, _ -> if x = Filename.current_dir_name then aux rf acc else if x = Filename.parent_dir_name then (match acc with | _::racc -> aux rf racc | [] -> (* do not treat currently cases like "../../../a/b/c/d", that cannot occur if [f] is a full path *) failwith "cannot normalize filename") else aux rf (x::acc) | [], _ -> acc in file_of_path (List.rev (aux (path_of_file f) [])) *) let relativize_filename base f = let rec aux ab af = match ab,af with | x::rb, y::rf when x=y -> aux rb rf | _ -> let rec aux2 acc p = match p with | [] -> acc | x::rb -> (if x = Filename.current_dir_name then aux2 acc rb else if x = Filename.parent_dir_name then failwith "cannot relativize filename" else aux2 (Filename.parent_dir_name::acc) rb) in aux2 af ab in file_of_path (aux (path_of_file base) (path_of_file f)) let absolutize_filename dirname f = if Filename.is_relative f then Filename.concat dirname f else f (* let p1 = relativize_filename "/bin/bash" "src/f.why" let p1 = relativize_filename "test" "/home/cmarche/recherche/why3/src/ide/f.why" *) let uniquify file = (* Uniquify the filename if it exists on disk *) let i = try String.rindex file '.' with _ -> String.length file in let name = String.sub file 0 i in let ext = String.sub file i (String.length file - i) in let i = ref 1 in while Sys.file_exists (name ^ "_" ^ (string_of_int !i) ^ ext) do incr i done; let file = name ^ "_" ^ (string_of_int !i) ^ ext in file why3-0.88.3/src/util/warning.mli0000664000175100017510000000202713225666037017171 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) val emit: ?loc:Loc.position -> ('b, Format.formatter, unit, unit) format4 -> 'b (* The default behavior is to emit warning on standard error, with position on a first line (if any) and message on a second line. This can be changed using the following function. *) val set_hook: (?loc:Loc.position -> string -> unit) -> unit why3-0.88.3/src/util/lexlib.mll0000664000175100017510000000624413225666037017013 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) { open Format open Lexing (* lexical errors *) exception UnterminatedComment exception UnterminatedString let () = Exn_printer.register (fun fmt e -> match e with | UnterminatedComment -> fprintf fmt "unterminated comment" | UnterminatedString -> fprintf fmt "unterminated string" | _ -> raise e) let newline lexbuf = let pos = lexbuf.lex_curr_p in lexbuf.lex_curr_p <- { pos with pos_lnum = pos.pos_lnum + 1; pos_bol = pos.pos_cnum } let string_start_loc = ref Loc.dummy_position let string_buf = Buffer.create 1024 let comment_start_loc = ref Loc.dummy_position let char_for_backslash = function | 'n' -> '\n' | 't' -> '\t' | c -> c } let newline = '\n' rule comment = parse | "(*)" { comment lexbuf } | "*)" { () } | "(*" { comment lexbuf; comment lexbuf } | newline { newline lexbuf; comment lexbuf } | eof { raise (Loc.Located (!comment_start_loc, UnterminatedComment)) } | _ { comment lexbuf } and string = parse | "\"" { let s = Buffer.contents string_buf in Buffer.clear string_buf; s } | "\\" (_ as c) { if c = '\n' then newline lexbuf; Buffer.add_char string_buf (char_for_backslash c); string lexbuf } | newline { newline lexbuf; Buffer.add_char string_buf '\n'; string lexbuf } | eof { raise (Loc.Located (!string_start_loc, UnterminatedString)) } | _ as c { Buffer.add_char string_buf c; string lexbuf } { let loc lb = Loc.extract (lexeme_start_p lb, lexeme_end_p lb) let comment lexbuf = comment_start_loc := loc lexbuf; comment lexbuf let string lexbuf = string_start_loc := loc lexbuf; string lexbuf let update_loc lexbuf file line chars = let pos = lexbuf.lex_curr_p in let new_file = match file with None -> pos.pos_fname | Some s -> s in lexbuf.lex_curr_p <- { pos with pos_fname = new_file; pos_lnum = line; pos_bol = pos.pos_cnum - chars; } let remove_leading_plus s = let n = String.length s in if n > 0 && s.[0] = '+' then String.sub s 1 (n-1) else s let remove_underscores s = if String.contains s '_' then begin let count = let nb = ref 0 in String.iter (fun c -> if c = '_' then incr nb) s; !nb in let t = Bytes.create (String.length s - count) in let i = ref 0 in String.iter (fun c -> if c <> '_' then (Bytes.set t !i c; incr i)) s; Bytes.unsafe_to_string t end else s } why3-0.88.3/src/util/cmdline.ml0000664000175100017510000000630513225666037016771 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) exception BadEscape of string * char exception UnfinishedEscape of string exception UnclosedQuote of string exception UnclosedDQuote of string exception EmptyCommandLine let is_blank = function | ' ' | '\t' | '\n' | '\r' -> true | _ -> false let escape s c = match c with | 't' -> '\t' | 'n' -> '\n' | 'r' -> '\r' | '\'' | '"' | '\\' | ' ' -> c | _ -> raise (BadEscape (s,c)) type fsm_state = | Normal | Blank | Quote | DQuote | Escape | QEscape | DQEscape let cmdline_split s = let argv = ref [] in let cur_arg = Queue.create () in let cstate = ref Blank in let normal = function | '\'' -> cstate := Quote | '"' -> cstate := DQuote | '\\' -> cstate := Escape | c when is_blank c -> let n = Queue.length cur_arg in let s = String.init n (fun _ -> Queue.take cur_arg) in argv := s :: !argv; cstate := Blank | c -> Queue.add c cur_arg in let blank = function | '\'' -> cstate := Quote | '"' -> cstate := DQuote | '\\' -> cstate := Escape | c when is_blank c -> () | c -> Queue.add c cur_arg; cstate := Normal in let quote = function | '\'' -> cstate := Normal | '\\' -> cstate := QEscape | c -> Queue.add c cur_arg in let dquote = function | '"' -> cstate := Normal | '\\' -> cstate := DQEscape | c -> Queue.add c cur_arg in let fsm c = match !cstate with | Normal -> normal c | Blank -> blank c | Quote -> quote c | DQuote -> dquote c | Escape -> Queue.add (escape s c) cur_arg; cstate := Normal | QEscape -> Queue.add (escape s c) cur_arg; cstate := Quote | DQEscape -> Queue.add (escape s c) cur_arg; cstate := DQuote in String.iter fsm s; fsm ' '; match !cstate with | Normal -> assert false | Blank -> if !argv = [] then raise EmptyCommandLine else List.rev !argv | Quote -> raise (UnclosedQuote s) | DQuote -> raise (UnclosedDQuote s) | Escape | QEscape | DQEscape -> raise (UnfinishedEscape s) let () = Exn_printer.register (fun fmt e -> match e with | BadEscape (s,c) -> Format.fprintf fmt "bad escape sequence '\\%c' in string: %s" c s | UnfinishedEscape s -> Format.fprintf fmt "unfinished escape sequence in string: %s" s | UnclosedQuote s -> Format.fprintf fmt "unclosed quote in string: %s" s | UnclosedDQuote s -> Format.fprintf fmt "unclosed double quote in string: %s" s | EmptyCommandLine -> Format.fprintf fmt "empty command line" | _ -> raise e) why3-0.88.3/src/util/exn_printer.mli0000664000175100017510000000220713225666037020061 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) type exn_printer = Format.formatter -> exn -> unit (* an [exn_printer] is a formatter of exception which prints on the given formatter a message for the user if it knows the given exception. Otherwise it raises the exception *) val register : exn_printer -> unit (* Register a formatter of exception *) val exn_printer : exn_printer (* [exn_printer fmt exn] prints exception [exn] using all previously registered printers and returns *) why3-0.88.3/src/util/extset.ml0000664000175100017510000000711113225666037016666 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) module type S = sig module M : Extmap.S type elt = M.key type t = unit M.t val empty: t val is_empty: t -> bool val mem: elt -> t -> bool val add: elt -> t -> t val singleton: elt -> t val remove: elt -> t -> t val merge: (elt -> bool -> bool -> bool) -> t -> t -> t val compare: t -> t -> int val equal: t -> t -> bool val subset: t -> t -> bool val disjoint: t -> t -> bool val iter: (elt -> unit) -> t -> unit val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a val for_all: (elt -> bool) -> t -> bool val exists: (elt -> bool) -> t -> bool val filter: (elt -> bool) -> t -> t val partition: (elt -> bool) -> t -> t * t val cardinal: t -> int val elements: t -> elt list val min_elt: t -> elt val max_elt: t -> elt val choose: t -> elt val split: elt -> t -> t * bool * t val change : (bool -> bool) -> elt -> t -> t val union : t -> t -> t val inter : t -> t -> t val diff : t -> t -> t val fold_left : ('b -> elt -> 'b) -> 'b -> t -> 'b val fold2_inter : (elt -> 'a -> 'a) -> t -> t -> 'a -> 'a val fold2_union : (elt -> 'a -> 'a) -> t -> t -> 'a -> 'a val translate : (elt -> elt) -> t -> t val add_new : exn -> elt -> t -> t val is_num_elt : int -> t -> bool val of_list : elt list -> t end module MakeOfMap (M: Extmap.S) = struct module M = M type elt = M.key type t = unit M.t let is_true b = if b then Some () else None let empty = M.empty let is_empty = M.is_empty let mem = M.mem let add e s = M.add e () s let singleton e = M.singleton e () let remove = M.remove let merge f s t = M.merge (fun e a b -> is_true (f e (a <> None) (b <> None))) s t let compare = M.set_compare let equal = M.set_equal let subset = M.set_submap let disjoint = M.set_disjoint let iter f s = M.iter (fun e _ -> f e) s let fold f s acc = M.fold (fun e _ -> f e) s acc let for_all f s = M.for_all (fun e _ -> f e) s let exists f s = M.exists (fun e _ -> f e) s let filter f s = M.filter (fun e _ -> f e) s let partition f s = M.partition (fun e _ -> f e) s let cardinal = M.cardinal let elements = M.keys let min_elt t = fst (M.min_binding t) let max_elt t = fst (M.max_binding t) let choose t = fst (M.choose t) let split e t = let l,m,r = M.split e t in l,(m <> None),r let change f x s = M.change (fun a -> is_true (f (a <> None))) x s let union = M.set_union let inter = M.set_inter let diff = M.set_diff let fold_left f acc s = M.fold_left (fun acc k () -> f acc k) acc s let fold2_inter f s t acc = M.fold2_inter (fun k _ _ acc -> f k acc) s t acc let fold2_union f s t acc = M.fold2_union (fun k _ _ acc -> f k acc) s t acc let translate = M.translate let add_new e x s = M.add_new e x () s let is_num_elt n m = M.is_num_elt n m let of_list l = List.fold_left (fun acc a -> add a acc) empty l end module type OrderedType = Set.OrderedType module Make(Ord: OrderedType) = MakeOfMap(Extmap.Make(Ord)) why3-0.88.3/src/util/warning.ml0000664000175100017510000000207213225666037017020 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Format let default_hook ?loc s = Opt.iter (Loc.report_position err_formatter) loc; eprintf "warning: %s@." s let hook = ref default_hook let set_hook = (:=) hook let emit ?loc p = let b = Buffer.create 100 in let fmt = formatter_of_buffer b in let handle fmt = Format.pp_print_flush fmt (); !hook ?loc (Buffer.contents b) in kfprintf handle fmt p why3-0.88.3/src/util/debug.mli0000664000175100017510000000630213225666037016612 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** Debug flag handling *) type flag val register_flag : desc:Pp.formatted -> string -> flag (** register a new flag. It is allowed to register twice the same flag *) val register_info_flag : desc:Pp.formatted -> string -> flag (** register a new info flag. It is allowed to register twice the same flag. Info flags are set by --debug-all and must not change the behaviour. *) val list_flags : unit -> (string * flag * bool * Pp.formatted) list (** list the known flags *) val lookup_flag : string -> flag (** get the flag *) val is_info_flag : string -> bool (** test if the flag is an info flag *) val flag_desc : string -> Pp.formatted (** get the description of the flag *) (** Modify the state of a flag *) val set_flag : flag -> unit val unset_flag : flag -> unit val toggle_flag : flag -> unit (** Return the state of the flag *) val test_flag : flag -> bool val test_noflag : flag -> bool val set_debug_formatter : Format.formatter -> unit (** Set the formatter used when printing debug material *) val get_debug_formatter : unit -> Format.formatter (** Get the formatter used when printing debug material *) val dprintf : flag -> ('a, Format.formatter, unit) format -> 'a (** Print only if the flag is set *) val stack_trace : flag (** stack_trace flag *) (** Command line arguments *) module Args : sig type spec = (Arg.key * Arg.spec * Arg.doc) val desc_debug_list : spec (** Option for printing the list of debug flags *) val option_list : unit -> bool (** Print the list of flags if requested (in this case return [true]). You should run this function after the plugins have been loaded. *) val desc_debug_all : spec (** Option for setting all info flags *) val desc_debug : spec (** Option for specifying a debug flag to set *) val desc_shortcut : string -> Arg.key -> Arg.doc -> spec (** Option for setting a specific flag *) val set_flags_selected : unit -> unit (** Set the flags selected by debug_all, debug or a shortcut. You should run this function after the plugins have been loaded. *) end val stats: flag type 'a stat module Stats: sig (** Stats *) val register: print:(Format.formatter -> 'a -> unit) -> name:string -> init:'a -> 'a stat val mod0: 'a stat -> ('a -> 'a) -> unit val mod1: 'a stat -> ('a -> 'b -> 'a) -> 'b -> unit val mod2: 'a stat -> ('a -> 'b -> 'c -> 'a) -> 'b -> 'c -> unit val register_int: name:string -> init:int -> int stat val incr: int stat -> unit val decr: int stat -> unit val print: unit -> unit end why3-0.88.3/src/util/rc.mli0000664000175100017510000001745613225666037016144 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** Rc file management *) (** {2 Exception} *) type rc_value = | RCint of int | RCbool of bool | RCfloat of float | RCstring of string | RCident of string (* exception SyntaxError *) exception ExtraParameters of string (** [ExtraParameters name] One section of name [name] has two many parameters : more than one if [name] is a family, more than none if [name] is a section *) exception MissingParameters of string (** [MissingParameters name] One section of a family [name] has no parameters *) (* exception UnknownSection of string *) exception UnknownField of string (** [UnknownField key] The key [key] appeared in a section but is not expected there *) (* exception MissingSection of string *) exception MissingField of string (** [MissingField key] The field [key] is required but not given *) exception DuplicateSection of string (** [DuplicateSection name] section [name] appears more than once *) exception DuplicateField of string * rc_value * rc_value (** [DuplicateField key] key [key] appears more than once *) exception StringExpected of string * rc_value (** [StringExpected key value] string expected *) (* exception IdentExpected of string * rc_value *) (* (\** [IdentExpected key value] string expected *\) *) exception IntExpected of string * rc_value (** [IntExpected key value] int expected *) exception BoolExpected of string * rc_value (** [BoolExpected key value] bool expected *) (** {2 RC API} *) type t (** Rc parsed file *) type section (** Section in rc file *) type family = (string * section) list (** A family in rc files *) type simple_family = section list (** A family w/o arguments in rc files*) val empty : t (** An empty Rc *) val empty_section : section (** An empty section *) val get_section : t -> string -> section option (** [get_section rc name] @return None if the section is not in the rc file @raise DuplicateSection if multiple section has the name [name] @raise ExtraParameters if [name] is a family in [rc] instead of a section *) val get_family : t -> string -> family (** [get_family rc name] return all the sections of the family [name] in [rc] @raise MissingParameters if [name] also corresponds to a section in [rc] *) val get_simple_family : t -> string -> simple_family (** [get_simple_family rc name] return all the sections of the simple family [name] in [rc] @raise ExtraParameters if [name] also corresponds to family in [rc] *) val set_section : t -> string -> section -> t (** [set_section rc name section] add a section [section] with name [name] in [rc]. Remove former section [name] if present in [rc] *) val set_family : t -> string -> family -> t (** [set_family rc name family] add all the section in [family] using the associated [string] as argument of the family [name] in [rc]. Remove all the former sections of family [name] if present in [rc]. *) val set_simple_family : t -> string -> simple_family -> t (** [set_simple_family rc name family] add all the section in [family] using the associated [string] as argument of the family [name] in [rc]. Remove all the former sections of family [name] if present in [rc]. *) val get_int : ?default:int -> section -> string -> int (** [get_int ~default section key] one key to one value @raise Bad_value_type if the value associated to [key] is not of type [int] @raise Key_not_found if default is not given and no value is associated to [key] @raise Multiple_value if the key appears multiple time. *) val get_into : section -> string -> int option val get_intl : ?default:int list -> section -> string -> int list (** [get_intl ~default section key] one key to many value @raise Bad_value_type if the value associated to [key] is not of type [int] @raise MissingField if default is not given and no values are associated to [key] *) val set_int : ?default:int -> section -> string -> int -> section (** [set_int ?default section key value] add the association [key] to [value] in the section if value is not default. Remove all former associations with this [key] *) val set_intl : ?default:int list -> section -> string -> int list -> section (** [set_int ?default section key lvalue] add the associations [key] to all the [lvalue] in the section if value is not default. Remove all former associations with this [key] *) val get_bool : ?default:bool -> section -> string -> bool (** Same as {!get_int} but on bool *) val get_booll : ?default:bool list -> section -> string -> bool list (** Same as {!get_intl} but on bool *) val get_boolo : section -> string -> bool option val set_bool : ?default:bool -> section -> string -> bool -> section (** Same as {!set_int} but on bool *) val set_booll : ?default:bool list -> section -> string -> bool list -> section (** Same as {!set_intl} but on bool *) val get_string : ?default:string -> section -> string -> string (** Same as {!get_int} but on string *) val get_stringl : ?default:string list -> section -> string -> string list (** Same as {!get_intl} but on string *) val get_stringo : section -> string -> string option val set_string : ?default:string -> section -> string -> string -> section (** Same as {!set_int} but on string *) val set_stringl : ?default:string list -> section -> string -> string list -> section (** Same as {!set_intl} but on string *) (* val ident : ?default:string -> section -> string -> string *) (* (\** raise Bad_value_type *) (* raise Key_not_found *) (* raise Multiple_value *) (* *\) *) (* val identl : ?default:string list -> section -> string -> string list *) (* (\** raise Bad_value_type *) (* raise Key_not_found *\) *) (* val set_ident : section -> string -> string -> section *) (* (\** raise Yet_defined_key *) (* raise Bad_value_type *) (* *\) *) (* val set_identl : section -> string -> string list -> section *) (* (\** raise Yet_defined_key *) (* raise Bad_value_type *) (* *\) *) val check_exhaustive : section -> Stdlib.Sstr.t -> unit (** [check_exhaustive section keys] check that only the keys in [keys] appear inside the section [section] @raise UnknownField if it is not the case *) exception CannotOpen of string * string exception SyntaxErrorFile of string * string val from_channel : in_channel -> t (** [from_channel cin] returns the Rc of the input channel [cin] @raise SyntaxErrorFile in case of incorrect syntax @raise ExtraParameters if a section header has more than one argument *) val from_file : string -> t (** [from_file filename] returns the Rc of the file [filename] @raise CannotOpen if [filename] does not exist @raise SyntaxErrorFile in case of incorrect syntax @raise ExtraParameters if a section header has more than one argument *) val to_formatter : Format.formatter -> t -> unit (** [to_formatter fmt rc] writes the Rc [rc] to the formatter [fmt] *) val to_channel : out_channel -> t -> unit (** [to_channel cout rc] writes the Rc [rc] to the output channel [out] *) val to_file : string -> t -> unit (** [to_file filename rc] writes the Rc [rc] to the file [filename] *) val get_home_dir : unit -> string (** [get_home_dir ()] returns the home dir of the user *) why3-0.88.3/src/util/stdlib.ml0000664000175100017510000000531213225666037016634 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (* Set, Map, Hashtbl on ints and strings *) module Int = struct type t = int let compare (x : int) y = Pervasives.compare x y let equal (x : int) y = x = y let hash (x : int) = x end module Mint = Extmap.Make(Int) module Sint = Extset.MakeOfMap(Mint) module Hint = Exthtbl.Make(Int) module Mstr = Extmap.Make(String) module Sstr = Extset.MakeOfMap(Mstr) module Hstr = Exthtbl.Make(struct type t = String.t let hash = (Hashtbl.hash : string -> int) let equal = ((=) : string -> string -> bool) end) module Float = struct type t = float let compare (x : float) y = Pervasives.compare x y let equal (x : float) y = x = y let hash (x : float) = Exthtbl.hash x end module Mfloat = Extmap.Make(Float) module Sfloat = Extset.MakeOfMap(Mfloat) module Hfloat = Exthtbl.Make(Float) (* Set, Map, Hashtbl on structures with a unique tag *) module type TaggedType = sig type t val tag : t -> int end module type OrderedHashedType = sig type t val hash : t -> int val equal : t -> t -> bool val compare : t -> t -> int end module OrderedHashed (X : TaggedType) = struct type t = X.t let hash = X.tag let equal ts1 ts2 = X.tag ts1 == X.tag ts2 let compare ts1 ts2 = Pervasives.compare (X.tag ts1) (X.tag ts2) end module OrderedHashedList (X : TaggedType) = struct type t = X.t list let hash = Hashcons.combine_list X.tag 3 let equ_ts ts1 ts2 = X.tag ts1 == X.tag ts2 let equal = Lists.equal equ_ts let cmp_ts ts1 ts2 = Pervasives.compare (X.tag ts1) (X.tag ts2) let compare = Lists.compare cmp_ts end module MakeMSH (X : TaggedType) = struct module T = OrderedHashed(X) module M = Extmap.Make(T) module S = Extset.MakeOfMap(M) module H = Exthtbl.Make(T) end module MakeTagged (X : Weakhtbl.Weakey) = struct type t = X.t let tag t = Weakhtbl.tag_hash (X.tag t) end module MakeMSHW (X : Weakhtbl.Weakey) = struct module T = OrderedHashed(MakeTagged(X)) module M = Extmap.Make(T) module S = Extset.MakeOfMap(M) module H = Exthtbl.Make(T) module W = Weakhtbl.Make(X) end why3-0.88.3/src/util/number.ml0000664000175100017510000003557513225666037016661 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Format (** Construction *) type integer_constant = | IConstDec of string | IConstHex of string | IConstOct of string | IConstBin of string type real_constant = | RConstDec of string * string * string option (* int / frac / exp *) | RConstHex of string * string * string option type constant = | ConstInt of integer_constant | ConstReal of real_constant exception InvalidConstantLiteral of int * string let invalid_constant_literal n s = raise (InvalidConstantLiteral(n,s)) let check_integer_literal n f s = let l = String.length s in if l = 0 then invalid_constant_literal n s; for i = 0 to l-1 do if not (f s.[i]) then invalid_constant_literal n s; done let is_hex = function '0'..'9' | 'A'..'F' | 'a'..'f' -> true | _ -> false let is_dec = function '0'..'9' -> true | _ -> false let is_oct = function '0'..'7' -> true | _ -> false let is_bin = function '0'..'1' -> true | _ -> false let int_const_dec s = check_integer_literal 10 is_dec s; IConstDec s let int_const_hex s = check_integer_literal 16 is_hex s; IConstHex s let int_const_oct s = check_integer_literal 8 is_oct s; IConstOct s let int_const_bin s = check_integer_literal 2 is_bin s; IConstBin s let check_exp e = let e = if e.[0] = '-' then String.sub e 1 (String.length e - 1) else e in check_integer_literal 10 is_dec e let real_const_dec i f e = if i <> "" then check_integer_literal 10 is_dec i; if f <> "" then check_integer_literal 10 is_dec f; Opt.iter check_exp e; RConstDec (i,f,e) let real_const_hex i f e = if i <> "" then check_integer_literal 16 is_hex i; if f <> "" then check_integer_literal 16 is_hex f; Opt.iter check_exp e; RConstHex (i,f,e) let compute_any radix s = let n = String.length s in let rec compute acc i = if i = n then acc else begin let v = match s.[i] with | '0'..'9' as c -> Char.code c - Char.code '0' | 'A'..'Z' as c -> 10 + Char.code c - Char.code 'A' | 'a'..'z' as c -> 10 + Char.code c - Char.code 'a' | _ -> assert false in assert (v < radix); compute (BigInt.add_int v (BigInt.mul_int radix acc)) (i + 1) end in (compute BigInt.zero 0) (** Printing *) let compute_int c = match c with | IConstDec s -> compute_any 10 s | IConstHex s -> compute_any 16 s | IConstOct s -> compute_any 8 s | IConstBin s -> compute_any 2 s let any_to_dec radix s = BigInt.to_string (compute_any radix s) let power2 n = BigInt.to_string (BigInt.pow_int_pos 2 n) type integer_format = (string -> unit, Format.formatter, unit) format type real_format = (string -> string -> string -> unit, Format.formatter, unit) format type part_real_format = (string -> string -> unit, Format.formatter, unit) format type dec_real_format = | PrintDecReal of part_real_format * real_format type frac_real_format = | PrintFracReal of integer_format * part_real_format * part_real_format type 'a number_support_kind = | Number_unsupported | Number_default | Number_custom of 'a type integer_support_kind = integer_format number_support_kind type number_support = { long_int_support : bool; extra_leading_zeros_support : bool; dec_int_support : integer_support_kind; hex_int_support : integer_support_kind; oct_int_support : integer_support_kind; bin_int_support : integer_support_kind; def_int_support : integer_support_kind; dec_real_support : dec_real_format number_support_kind; hex_real_support : real_format number_support_kind; frac_real_support : frac_real_format number_support_kind; def_real_support : integer_support_kind; } let check_support support default do_it try_next v = match support with | Number_unsupported -> try_next v | Number_default -> do_it (Opt.get default) v | Number_custom f -> do_it f v let force_support support do_it v = match support with | Number_unsupported -> assert false | Number_default -> assert false | Number_custom f -> do_it f v let simplify_max_int = BigInt.of_string "2147483646" let remove_minus e = if e.[0] = '-' then begin let e = Bytes.of_string e in Bytes.set e 0 'm'; Bytes.unsafe_to_string e end else e let print_dec_int support fmt i = let fallback i = force_support support.def_int_support (fprintf fmt) i in if not support.long_int_support && (BigInt.compare (BigInt.of_string i) simplify_max_int > 0) then fallback i else check_support support.dec_int_support (Some "%s") (fprintf fmt) fallback i let print_hex_int support fmt = check_support support.hex_int_support (Some "0x%s") (fun s i -> assert support.long_int_support; fprintf fmt s i) (fun i -> print_dec_int support fmt (any_to_dec 16 i)) let print_oct_int support fmt = check_support support.oct_int_support (Some "0o%s") (fun s i -> assert support.long_int_support; fprintf fmt s i) (fun i -> print_dec_int support fmt (any_to_dec 8 i)) let print_bin_int support fmt = check_support support.bin_int_support (Some "0b%s") (fun s i -> assert support.long_int_support; fprintf fmt s i) (fun i -> print_dec_int support fmt (any_to_dec 2 i)) let remove_leading_zeros support s = if support.extra_leading_zeros_support then s else let len = String.length s in let rec aux i = if i+1 < len && s.[i] = '0' then aux (i+1) else i in let i = aux 0 in String.sub s i (len - i) let print_dec_real support fmt = check_support support.dec_real_support (Some (PrintDecReal ("%s.%s", "%s.%se%s"))) (fun (PrintDecReal (noexp,full)) i f e -> match e with | None -> fprintf fmt noexp (remove_leading_zeros support i) (if f = "" then "0" else f) | Some e -> fprintf fmt full (remove_leading_zeros support i) (if f = "" then "0" else f) (remove_leading_zeros support e)) (check_support support.frac_real_support None (fun (PrintFracReal (exp_zero, exp_pos, exp_neg)) i f e -> let f = if f = "0" then "" else f in let e = Opt.fold (fun _ -> int_of_string) 0 e in let e = e - String.length f in if e = 0 then fprintf fmt exp_zero (remove_leading_zeros support (i ^ f)) else if e > 0 then fprintf fmt exp_pos (remove_leading_zeros support (i ^ f)) ("1" ^ String.make e '0') else fprintf fmt exp_neg (remove_leading_zeros support (i ^ f)) ("1" ^ String.make (-e) '0')) (force_support support.def_real_support (fun def i f e -> fprintf fmt def (sprintf "%s_%s_e%s" i f (match e with None -> "0" | Some e -> remove_minus e))) )) let print_hex_real support fmt = check_support support.hex_real_support (Some "0x%s.%sp%s") (fun s i f e -> fprintf fmt s i (if f = "" then "0" else f) (Opt.get_def "0" e)) (* TODO: add support for decay to decimal floats *) (check_support support.frac_real_support None (fun (PrintFracReal (exp_zero, exp_pos, exp_neg)) i f e -> let f = if f = "0" then "" else f in let dec = any_to_dec 16 (i ^ f) in let e = Opt.fold (fun _ -> int_of_string) 0 e in let e = e - 4 * String.length f in if e = 0 then fprintf fmt exp_zero dec else if e > 0 then fprintf fmt exp_pos dec (power2 e) else fprintf fmt exp_neg dec (power2 (-e))) (force_support support.def_real_support (fun def i f e -> fprintf fmt def (sprintf "0x%s_%s_p%s" i f (match e with None -> "0" | Some e -> remove_minus e))) )) let print support fmt = function | ConstInt (IConstDec i) -> print_dec_int support fmt i | ConstInt (IConstHex i) -> print_hex_int support fmt i | ConstInt (IConstOct i) -> print_oct_int support fmt i | ConstInt (IConstBin i) -> print_bin_int support fmt i | ConstReal (RConstDec (i, f, e)) -> print_dec_real support fmt i f e | ConstReal (RConstHex (i, f, e)) -> print_hex_real support fmt i f e let char_of_int i = if i < 10 then Char.chr (i + Char.code '0') else Char.chr (i + Char.code 'A' - 10) open BigInt let print_zeros fmt n = for _i = 0 to n - 1 do pp_print_char fmt '0' done let rec print_in_base_aux radix digits fmt i = if lt i radix then begin begin match digits with | Some n -> print_zeros fmt (n - 1) | None -> () end; fprintf fmt "%c" (char_of_int (to_int i)) end else let d,m = computer_div_mod i radix in let digits = Opt.map ((+) (-1)) digits in print_in_base_aux radix digits fmt d; fprintf fmt "%c" (char_of_int (to_int m)) let print_in_base radix digits fmt i = print_in_base_aux (of_int radix) digits fmt i (** Range checks *) type int_range = { ir_lower : BigInt.t; ir_upper : BigInt.t; } exception OutOfRange of integer_constant let check_range c {ir_lower = lo; ir_upper = hi} = let cval = compute_int c in if BigInt.lt cval lo || BigInt.gt cval hi then raise (OutOfRange c) (** Float checks *) type float_format = { fp_exponent_digits : int; fp_significand_digits : int; (* counting the hidden bit *) } exception NonRepresentableFloat of real_constant let debug_float = Debug.register_info_flag "float" ~desc:"Avoid@ catching@ exceptions@ in@ order@ to@ get@ \ float@ literal@ checks@ messages." let float_parser c = let exp_parser e = match e.[0] with | '-' -> minus (compute_any 10 (String.sub e 1 (String.length e - 1))) | _ -> compute_any 10 e in (* get the value s and e such that c = s * 2 ^ e *) let s, e = match c with (* c = a.b * 10 ^ e *) | RConstDec (a,b,e) -> let b_length = String.length b in let s = ref (compute_any 10 (a ^ b)) in let e = sub (match e with | None -> Debug.dprintf debug_float "c = %s.%s" a b; zero | Some e -> Debug.dprintf debug_float "c = %s.%se%s" a b e; exp_parser e) (of_int b_length) in (* transform c = s * 10 ^ i into c = s' * 2 ^ i' *) let s = if lt e zero then begin let efive = pow_int_pos_bigint 5 (minus e) in let dv, rem = euclidean_div_mod !s efive in if not (eq rem zero) then begin raise (NonRepresentableFloat c); end else dv end else mul !s (pow_int_pos_bigint 5 e) in Debug.dprintf debug_float " = %s * 2 ^ %s" (to_string s) (to_string e); ref s, ref e (* c = a.b * 2 ^ e *) | RConstHex (a,b,e) -> let b_length = String.length b in ref (compute_any 16 (a ^ b)), ref (sub (match e with | None -> Debug.dprintf debug_float "c = %s.%s" a b; zero | Some e -> Debug.dprintf debug_float "c = %s.%sp%s" a b e; exp_parser e) (of_int (b_length * 4))) in s, e let compute_float c fp = let eb = BigInt.of_int fp.fp_exponent_digits in let sb = BigInt.of_int fp.fp_significand_digits in (* 2 ^ (sb - 1) min representable normalized significand*) let smin = pow_int_pos_bigint 2 (sub sb one) in (* (2 ^ sb) - 1 max representable normalized significand*) let smax = sub (pow_int_pos_bigint 2 sb) one in (* 2 ^ (eb - 1) exponent of the infinities *) let emax = pow_int_pos_bigint 2 (sub eb one) in (* 1 - emax exponent of the denormalized *) let eden = sub one emax in (* 3 - emax - sb smallest denormalized' exponent *) let emin = sub (add (of_int 2) eden) sb in (* get [s] and [e] such that "c = s * 2 ^ e" *) let s, e = float_parser c in (* if s = 0 stop now *) if eq !s zero then zero, zero else begin (* if s is too big or e is too small, try to remove trailing zeros in s and incr e *) while gt !s smax || lt !e emin do let new_s, rem = euclidean_div_mod !s (of_int 2) in if not (eq rem zero) then begin Debug.dprintf debug_float "Too many digits in significand."; raise (NonRepresentableFloat c); end else begin s := new_s; e := succ !e end done; (* if s is too small and e is too big, add trailing zeros in s and decr e *) while lt !s smin && gt !e emin do s := mul_int 2 !s; e := pred !e done; Debug.dprintf debug_float " = %s * 2 ^ %s@." (to_string !s) (to_string !e); if lt !s smin then begin (* denormal case *) Debug.dprintf debug_float "final: c = 0.[%s] * 2 ^ ([0] - bias + 1); bias=%s, i.e, 0[%a][%a]@." (to_string !s) (to_string (sub emax one)) (print_in_base 2 (Some (to_int eb))) zero (print_in_base 2 (Some (to_int (sub sb one)))) !s; zero, !s end else begin (* normal case *) (* normalize the exponent *) let fe = add !e (sub sb one) in (* now that s and e are in shape, check that e is not too big *) if ge fe emax then begin Debug.dprintf debug_float "Exponent too big."; raise (NonRepresentableFloat c) end; (* add the exponent bia to e *) let fe = add fe (sub emax one) in let fs = sub !s smin in Debug.dprintf debug_float "final: c = 1.[%s] * 2 ^ ([%s] - bias); bias=%s, i.e, 0[%a][%a]@." (to_string fs) (to_string fe) (to_string (sub emax one)) (print_in_base 2 (Some (to_int eb))) fe (print_in_base 2 (Some (to_int (sub sb one)))) fs; assert (le zero fs && lt fs (pow_int_pos_bigint 2 (sub sb one)) && le zero fe && lt fe (sub (pow_int_pos_bigint 2 eb) one)); fe, fs end end let check_float c fp = ignore (compute_float c fp) let print_integer_constant fmt = function | IConstDec s -> fprintf fmt "%s" s | IConstHex s -> fprintf fmt "0x%s" s | IConstOct s -> fprintf fmt "0o%s" s | IConstBin s -> fprintf fmt "0b%s" s let print_real_constant fmt = function | RConstDec (i,f,None) -> fprintf fmt "%s.%s" i f | RConstDec (i,f,Some e) -> fprintf fmt "%s.%se%s" i f e | RConstHex (i,f,Some e) -> fprintf fmt "0x%s.%sp%s" i f e | RConstHex (i,f,None) -> fprintf fmt "0x%s.%s" i f let print_constant fmt = function | ConstInt c -> print_integer_constant fmt c | ConstReal c -> print_real_constant fmt c let () = Exn_printer.register (fun fmt exn -> match exn with | InvalidConstantLiteral (n,s) -> fprintf fmt "Invalid integer literal in base %d: '%s'" n s | NonRepresentableFloat c -> fprintf fmt "Invalid floating point literal: '%a'" print_real_constant c | OutOfRange c -> fprintf fmt "Integer literal %a is out of range" print_integer_constant c | _ -> raise exn) why3-0.88.3/src/util/weakhtbl.ml0000664000175100017510000001377213225666037017165 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) module ProdConsume : sig type 'a t val create : unit -> 'a t val add : 'a -> 'a t -> unit val iter_remove : ('a -> unit) -> 'a t -> unit end = struct (* One thing can produce, one thing can consume concurrently *) type 'a cell = | Empty | Cons of 'a * 'a list and 'a list = 'a cell ref let rec iter f = function | Empty -> () | Cons (x,l) -> f x; iter f !l (* a reference on a mutable singly linked list *) type 'a t = 'a list ref let create () = ref (ref (Empty)) let add x t = t := ref (Cons(x,!t)) let iter_remove f t = if !(!t) = Empty then () else let r = !t in (* atomic one cell of the list *) let l = !r in (* the content of the cell *) r := Empty; (* Work even if there are some production, just not anymore the head *) iter f l end module type S = sig type key type 'a t val create : int -> 'a t (* create a hashtbl with weak keys *) val clear : 'a t -> unit val copy : 'a t -> 'a t val find : 'a t -> key -> 'a (* find the value bound to a key. Raises Not_found if there is no binding *) val mem : 'a t -> key -> bool (* test if a key is bound *) val set : 'a t -> key -> 'a -> unit (* bind the key _once_ with the given value *) val remove : 'a t -> key -> unit (* remove the value *) val iter : (key -> 'a -> unit) -> 'a t -> unit val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val iterk : (key -> unit) -> 'a t -> unit val foldk : (key -> 'b -> 'b) -> 'a t -> 'b -> 'b val length : 'a t -> int val memoize : int -> (key -> 'a) -> (key -> 'a) (* create a memoizing function *) val memoize_rec : int -> ((key -> 'a) -> (key -> 'a)) -> (key -> 'a) (* create a memoizing recursive function *) val memoize_option : int -> (key option -> 'a) -> (key option -> 'a) (* memoizing functions on option types *) end let new_tbl_tag = let c = ref (-1) in fun () -> (incr c; !c) type tag = { tag_map : ((int,Obj.t) Hashtbl.t) Lazy.t; tag_tag : int; } let create_tag tag = { tag_map = lazy (Hashtbl.create 3); tag_tag = tag; } let dummy_tag = { tag_map = lazy (failwith "dummy tag"); tag_tag = -1; } let tag_equal : tag -> tag -> bool = (==) let tag_hash k = assert (k != dummy_tag); k.tag_tag module type Weakey = sig type t val tag : t -> tag end module Make (S : Weakey) = struct type key = S.t module H = Weak.Make (struct type t = S.t let hash k = (S.tag k).tag_tag let equal k1 k2 = S.tag k1 == S.tag k2 end) type 'a t = { tbl_set : H.t; tbl_tag : int; } let tag_map k = Lazy.force (S.tag k).tag_map let find (t : 'a t) k : 'a = Obj.obj (Hashtbl.find (tag_map k) t.tbl_tag) let mem t k = Hashtbl.mem (tag_map k) t.tbl_tag let set (t : 'a t) k (v : 'a) = Hashtbl.replace (tag_map k) t.tbl_tag (Obj.repr v); ignore (H.merge t.tbl_set k) let remove t k = Hashtbl.remove (tag_map k) t.tbl_tag; H.remove t.tbl_set k let iterk fn t = H.iter fn t.tbl_set let foldk fn t = H.fold fn t.tbl_set let iter fn t = H.iter (fun k -> fn k (find t k)) t.tbl_set let fold fn t = H.fold (fun k -> fn k (find t k)) t.tbl_set (** This table is just a hack to keep alive the weak hashset : Indeed that circunvent a strange behavior/bug of weak hashset, when a weak hashset is garbage collected it will not anymore remove the dead elements from it. So during finalize or if the hashset is keep alive, we can acces invalid pointer... So to summarize we keep alive the weak hashset until we don't need them anymore. *) let gen_table = Hashtbl.create 5 let tbl_final_aux t = iterk (fun k -> Hashtbl.remove (tag_map k) t.tbl_tag) t let tbl_final t = tbl_final_aux t; (** We don't need anymore the weak hashset, we can release it *) Hashtbl.remove gen_table t.tbl_tag (** All the hashweak that can be collected. When a hashweak is garbage collected we need to remove its tag from the key hashtable. Since finalisation can be triggered at anytime even when the key hashtable are in an inconsistent state, we need to delay the actual removing until it can be done safely. t_collected contains the delayed hashweak *) let t_collected = ProdConsume.create () (** Do really the removing *) let collect () = ProdConsume.iter_remove tbl_final t_collected let create n = let t = { tbl_set = H.create n; tbl_tag = new_tbl_tag () } in Hashtbl.add gen_table t.tbl_tag t.tbl_set; Gc.finalise (fun t -> ProdConsume.add t t_collected) t; t let find x y = collect (); find x y let set x y z = collect (); set x y z let clear t = collect (); tbl_final_aux t; H.clear t.tbl_set let length t = H.count t.tbl_set let copy t = collect (); let t' = create (length t) in iter (set t') t; t' let memoize n fn = let h = create n in fun e -> try find h e with Not_found -> let v = fn e in set h e v; v let memoize_rec n fn = let h = create n in let rec f e = try find h e with Not_found -> let v = fn f e in set h e v; v in f let memoize_option n fn = let v = lazy (fn None) in let fn e = fn (Some e) in let fn = memoize n fn in function | Some e -> fn e | None -> Lazy.force v end why3-0.88.3/src/util/sysutil.mli0000664000175100017510000000572013225666037017243 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (* create a backup copy of a file if it exists *) val backup_file : string -> unit (* return the content of an in-channel *) val channel_contents : in_channel -> string (* return the content of an in_channel in a buffer *) val channel_contents_buf : in_channel -> Buffer.t (* put the content of an in_channel in a formatter *) val channel_contents_fmt : in_channel -> Format.formatter -> unit (* fold on the line of a file *) val fold_channel : ('a -> string -> 'a) -> 'a -> in_channel -> 'a (* return the content of a file *) val file_contents : string -> string (* return the content of a file in a buffer *) val file_contents_buf : string -> Buffer.t (* put the content of a file in a formatter *) val file_contents_fmt : string -> Format.formatter -> unit val open_temp_file : ?debug:bool -> (* don't remove the file *) string -> (string -> out_channel -> 'a) -> 'a (* open_temp_file suffix usefile Create a temporary file with suffix suffix, and call usefile on this file (filename and open_out). usefile can close the file *) val copy_file : string -> string -> unit (** [copy_file from to] copy the file from [from] to [to] *) val copy_dir : string -> string -> unit (** [copy_dir from to] copy the directory recursively from [from] to [to], currently the directory must contains only directories and common files *) val path_of_file : string -> string list (** [path_of_file filename] return the absolute path of [filename] *) (* unused ? val normalize_filename : string -> string *) (** [normalize_filename filename] removes from [filename] occurrences of "." and ".." that denote respectively the current directory and parent directory, whenever possible *) val relativize_filename : string -> string -> string (** [relativize_filename base filename] relativize the filename [filename] according to [base]. [base] should not contain occurrences of "." and "..", which can be removed by calling first [normalize_filename]. *) val absolutize_filename : string -> string -> string (** [absolutize_filename base filename] absolutize the filename [filename] according to [base] *) val uniquify : string -> string (** find filename that doesn't exists based on the given filename. Be careful the file can be taken after the return of this function. *) why3-0.88.3/src/util/lists.mli0000664000175100017510000000606113225666037016664 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** Useful list combinators *) val rev_map_fold_left : ('acc -> 'a -> 'acc * 'b) -> 'acc -> 'a list -> 'acc * 'b list val map_fold_left : ('acc -> 'a -> 'acc * 'b) -> 'acc -> 'a list -> 'acc * 'b list val map_fold_right : ('a -> 'acc -> 'b * 'acc) -> 'a list -> 'acc -> 'b list * 'acc val equal : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool val compare : ('a -> 'a -> int) -> 'a list -> 'a list -> int val cons : ('a -> 'b) -> 'b list -> 'a -> 'b list val map_join_left : ('a -> 'b) -> ('b -> 'b -> 'b) -> 'a list -> 'b val apply : ('a -> 'b list) -> 'a list -> 'b list (** [apply f [a1;..;an]] returns (f a1)@...@(f an) *) val fold_product : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a (** [fold_product f acc l1 l2] apply the function [f] with the accumulator [acc] on all the pair of elements of [l1] and [l2] tail-recursive *) val fold_product_l : ('a -> 'b list -> 'a) -> 'a -> 'b list list -> 'a (** generalisation of {! Lists.fold_product}; not tail-recursive *) val flatten_rev : 'a list list -> 'a list val part : ('a -> 'a -> int) -> 'a list -> 'a list list (** [part cmp l] returns the list of the congruence classes with respect to [cmp]. They are returned in reverse order *) val first : ('a -> 'b option) -> 'a list -> 'b (** [first f l] returns the first result of the application of [f] to an element of [l] which doesn't return [None]. [raise Not_found] if all the element of [l] return [None] *) val find_nth : ('a -> bool) -> 'a list -> int (** [find_nth p l] returns the index of the first element that satifies the predicate [p]. [raise Not_found] if no element of [l] verify the predicate *) val first_nth : ('a -> 'b option) -> 'a list -> int * 'b (** The combinaison of {!list_first} and {!list_find_nth}. *) val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list val iteri : (int -> 'a -> unit) -> 'a list -> unit val fold_lefti : ('a -> int -> 'b -> 'a) -> 'a -> 'b list -> 'a (** similar to List.map, List.iter and List.fold_left, but with element index passed as extra argument (in 0..len-1) *) val prefix : int -> 'a list -> 'a list (** the first n elements of a list *) val chop : int -> 'a list -> 'a list (** removes the first n elements of a list; raises Invalid_argument if the list is not long enough *) val chop_last : 'a list -> 'a list * 'a (** removes (and returns) the last element of a list *) why3-0.88.3/src/util/pp.ml0000664000175100017510000001467713225666037016010 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (*i $Id: pp.ml,v 1.22 2009-10-19 11:55:33 bobot Exp $ i*) (*s Pretty-print library *) open Format let print_option f fmt = function | None -> () | Some x -> f fmt x let print_option_or_default default f fmt = function | None -> fprintf fmt "%s" default | Some x -> f fmt x let rec print_list_pre sep print fmt = function | [] -> () | x :: r -> sep fmt (); print fmt x; print_list_pre sep print fmt r let rec print_list_suf sep print fmt = function | [] -> () | x :: r -> print fmt x; sep fmt (); print_list_suf sep print fmt r let print_list sep print fmt = function | [] -> () | [x] -> print fmt x | x :: r -> print fmt x; print_list_pre sep print fmt r let print_list_or_default default sep print fmt = function | [] -> fprintf fmt "%s" default | l -> print_list sep print fmt l let print_list_par sep pr fmt l = print_list sep (fun fmt x -> fprintf fmt "(%a)" pr x) fmt l let print_list_delim ~start ~stop ~sep pr fmt = function | [] -> () | l -> fprintf fmt "%a%a%a" start () (print_list sep pr) l stop () let print_iter1 iter sep print fmt l = let first = ref true in iter (fun x -> if !first then first := false else sep fmt (); print fmt x ) l let print_iter2 iter sep1 sep2 print1 print2 fmt l = let first = ref true in iter (fun x y -> if !first then first := false else sep1 fmt (); print1 fmt x;sep2 fmt (); print2 fmt y) l let print_iter22 iter sep print fmt l = let first = ref true in iter (fun x y -> if !first then first := false else sep fmt (); print fmt x y) l let print_pair_delim start sep stop pr1 pr2 fmt (a,b) = fprintf fmt "%a%a%a%a%a" start () pr1 a sep () pr2 b stop () type formatted = (unit, unit, unit, unit, unit, unit) format6 let empty_formatted : formatted = "" let dot fmt () = fprintf fmt ".@ " let comma fmt () = fprintf fmt ",@ " let star fmt () = fprintf fmt "*@ " let simple_comma fmt () = fprintf fmt ", " let underscore fmt () = fprintf fmt "_" let semi fmt () = fprintf fmt ";@ " let colon fmt () = fprintf fmt ":@ " let space fmt () = fprintf fmt "@ " let alt fmt () = fprintf fmt "|@ " let alt2 fmt () = fprintf fmt "@ | " let equal fmt () = fprintf fmt "@ =@ " let newline fmt () = fprintf fmt "@\n" let newline2 fmt () = fprintf fmt "@\n@\n" let arrow fmt () = fprintf fmt "@ -> " let lbrace fmt () = fprintf fmt "{" let rbrace fmt () = fprintf fmt "}" let lsquare fmt () = fprintf fmt "[" let rsquare fmt () = fprintf fmt "]" let lparen fmt () = fprintf fmt "(" let rparen fmt () = fprintf fmt ")" let lchevron fmt () = fprintf fmt "<" let rchevron fmt () = fprintf fmt ">" let nothing _fmt _ = () let string = pp_print_string let float = pp_print_float let int = pp_print_int let constant_string s fmt () = string fmt s let formatted fmt x = Format.fprintf fmt "%( %)" x let constant_formatted f fmt () = formatted fmt f let print0 fmt () = pp_print_string fmt "\000" let add_flush sep fmt x = sep fmt x; pp_print_flush fmt () let asd f fmt x = fprintf fmt "\"%a\"" f x let print_pair pr1 = print_pair_delim lparen comma rparen pr1 let hov n f fmt x = pp_open_hovbox fmt n; f fmt x; pp_close_box fmt () let indent n f fmt x = for _i = 0 to n do pp_print_char fmt ' ' done; hov 0 f fmt x let open_formatter ?(margin=78) cout = let fmt = formatter_of_out_channel cout in pp_set_margin fmt margin; pp_open_box fmt 0; fmt let close_formatter fmt = pp_close_box fmt (); pp_print_flush fmt () let open_file_and_formatter ?(margin=78) f = let cout = open_out f in let fmt = open_formatter ~margin cout in cout,fmt let close_file_and_formatter (cout,fmt) = close_formatter fmt; close_out cout let print_in_file_no_close ?(margin=78) p f = let cout,fmt = open_file_and_formatter ~margin f in p fmt; close_formatter fmt; cout let print_in_file ?(margin=78) p f = let cout = print_in_file_no_close ~margin p f in close_out cout (* With optional separation *) let rec print_list_opt sep print fmt = function | [] -> false | [x] -> print fmt x | x :: r -> let notempty1 = print fmt x in if notempty1 then sep fmt (); let notempty2 = print_list_opt sep print fmt r in notempty1 || notempty2 let string_of ?max_boxes p x = let b = Buffer.create 100 in let fmt = formatter_of_buffer b in Opt.iter (fun x -> Format.pp_set_ellipsis_text fmt "..."; Format.pp_set_max_boxes fmt x) max_boxes; fprintf fmt "%a@?" p x; Buffer.contents b let wnl fmt = (* let out,flush,_newline,spaces = pp_get_all_formatter_output_functions fmt () in pp_set_all_formatter_output_functions fmt ~out ~flush ~newline:(fun () -> spaces 1) ~spaces *) let o = pp_get_formatter_out_functions fmt () in pp_set_formatter_out_functions fmt { o with out_newline = (fun () -> o.out_spaces 1) } let string_of_wnl p x = let b = Buffer.create 100 in let fmt = formatter_of_buffer b in wnl fmt; fprintf fmt "%a@?" p x; Buffer.contents b let sprintf p = let b = Buffer.create 100 in let fmt = formatter_of_buffer b in kfprintf (fun fmt -> Format.pp_print_flush fmt (); Buffer.contents b) fmt p let sprintf_wnl p = let b = Buffer.create 100 in let fmt = formatter_of_buffer b in wnl fmt; kfprintf (fun fmt -> Format.pp_print_flush fmt (); Buffer.contents b) fmt p let html_char fmt c = match c with | '\"' -> pp_print_string fmt """ | '\'' -> pp_print_string fmt "'" | '<' -> pp_print_string fmt "<" | '>' -> pp_print_string fmt ">" | '&' -> pp_print_string fmt "&" | c -> pp_print_char fmt c let html_string fmt s = for i=0 to String.length s - 1 do html_char fmt (String.get s i) done module Ansi = struct let set_column fmt n = fprintf fmt "\027[%iG" n end type formatter = Format.formatter why3-0.88.3/src/util/extmap.mli0000664000175100017510000003201613225666037017023 0ustar guillaumeguillaume(***********************************************************************) (* *) (* Objective Caml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* This file originates from the OCaml v 3.12 Standard Library. It was extended and modified for the needs of the Why3 project. It is distributed under the terms of its initial license, which is provided in the file OCAML-LICENSE. *) (** Association tables over ordered types This module implements applicative association tables, also known as finite maps or dictionaries, given a total ordering function over the keys. All operations over maps are purely applicative (no side-effects). The implementation uses balanced binary trees, and therefore searching and insertion take time logarithmic in the size of the map. *) (** Input signature of the functor {!Extmap.Make}. *) module type OrderedType = Map.OrderedType (** Output signature of the functor {!Extmap.Make}. *) module type S = sig type key (** The type of the map keys. *) type (+'a) t (** The type of maps from type [key] to type ['a]. *) val empty: 'a t (** The empty map. *) val is_empty: 'a t -> bool (** Test whether a map is empty or not. *) val mem: key -> 'a t -> bool (** [mem x m] returns [true] if [m] contains a binding for [x], and [false] otherwise. *) val add: key -> 'a -> 'a t -> 'a t (** [add x y m] returns a map containing the same bindings as [m], plus a binding of [x] to [y]. If [x] was already bound in [m], its previous binding disappears. *) val singleton: key -> 'a -> 'a t (** [singleton x y] returns the one-element map that contains a binding [y] for [x]. *) val remove: key -> 'a t -> 'a t (** [remove x m] returns a map containing the same bindings as [m], except for [x] which is unbound in the returned map. *) val merge: (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t (** [merge f m1 m2] computes a map whose keys is a subset of keys of [m1] and of [m2]. The presence of each such binding, and the corresponding value, is determined with the function [f]. *) val union : (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t (** [union f m1 m2] computes a map whose keys is a subset of keys of [m1] and of [m2]. If a binding is present in [m1] (resp. [m2]) and not in [m2] (resp. [m1]) the same binding is present in the result. The function [f] is called only in ambiguous cases. *) val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int (** Total ordering between maps. The first argument is a total ordering used to compare data associated with equal keys in the two maps. *) val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal, that is, contain equal keys and associate them with equal data. [cmp] is the equality predicate used to compare the data associated with the keys. *) val iter: (key -> 'a -> unit) -> 'a t -> unit (** [iter f m] applies [f] to all bindings in map [m]. [f] receives the key as first argument, and the associated value as second argument. The bindings are passed to [f] in increasing order with respect to the ordering over the type of the keys. *) val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], where [k1 ... kN] are the keys of all bindings in [m] (in increasing order), and [d1 ... dN] are the associated data. *) val for_all: (key -> 'a -> bool) -> 'a t -> bool (** [for_all p m] checks if all the bindings of the map satisfy the predicate [p]. *) val exists: (key -> 'a -> bool) -> 'a t -> bool (** [exists p m] checks if at least one binding of the map satisfy the predicate [p]. *) val filter: (key -> 'a -> bool) -> 'a t -> 'a t (** [filter p m] returns the map with all the bindings in [m] that satisfy predicate [p]. *) val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t (** [partition p m] returns a pair of maps [(m1, m2)], where [m1] contains all the bindings of [s] that satisfy the predicate [p], and [m2] is the map with all the bindings of [s] that do not satisfy [p]. *) val cardinal: 'a t -> int (** Return the number of bindings of a map. *) val bindings: 'a t -> (key * 'a) list (** Return the list of all bindings of the given map. The returned list is sorted in increasing order with respect to the ordering [Ord.compare], where [Ord] is the argument given to {!Extmap.Make}. *) val min_binding: 'a t -> (key * 'a) (** Return the smallest binding of the given map (with respect to the [Ord.compare] ordering), or raise [Not_found] if the map is empty. *) val max_binding: 'a t -> (key * 'a) (** Same as {!Extmap.S.min_binding}, but returns the largest binding of the given map. *) val choose: 'a t -> (key * 'a) (** Return one binding of the given map, or raise [Not_found] if the map is empty. Which binding is chosen is unspecified, but equal bindings will be chosen for equal maps. *) val split: key -> 'a t -> 'a t * 'a option * 'a t (** [split x m] returns a triple [(l, data, r)], where [l] is the map with all the bindings of [m] whose key is strictly less than [x]; [r] is the map with all the bindings of [m] whose key is strictly greater than [x]; [data] is [None] if [m] contains no binding for [x], or [Some v] if [m] binds [v] to [x]. *) val find: key -> 'a t -> 'a (** [find x m] returns the current binding of [x] in [m], or raises [Not_found] if no such binding exists. *) val map: ('a -> 'b) -> 'a t -> 'b t (** [map f m] returns a map with same domain as [m], where the associated value [a] of all bindings of [m] has been replaced by the result of the application of [f] to [a]. The bindings are passed to [f] in increasing order with respect to the ordering over the type of the keys. *) val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t (** Same as {!Extmap.S.map}, but the function receives as arguments both the key and the associated value for each binding of the map. *) (** @Added in Why3 *) val change : ('a option -> 'a option) -> key -> 'a t -> 'a t (** [change f x m] returns a map containing the same bindings as [m], except the binding of [x] in [m] is changed from [y] to [f (Some y)] if [m] contains a binding of [x], otherwise the binding of [x] becomes [f None]. [change f x m] corresponds to a more efficient way to do [match (try f (Some (find x m)) with Not_found -> f None) with | None -> m | Some v -> add x v] *) val inter : (key -> 'a -> 'b -> 'c option) -> 'a t -> 'b t -> 'c t (** [inter f m1 m2] computes a map whose keys is a subset of the intersection of keys of [m1] and of [m2]. *) val diff : (key -> 'a -> 'b -> 'a option) -> 'a t -> 'b t -> 'a t (** [diff f m1 m2] computes a map whose keys is a subset of keys of [m1]. [f] is applied on key which belongs to [m1] and [m2] if [f] returns [None] the binding is removed from [m1], otherwise [Some d1] is returned, the key binds to [d1] in [m1] *) val submap : (key -> 'a -> 'b -> bool) -> 'a t -> 'b t -> bool (** [submap pr m1 m2] verifies that all the keys in m1 are in m2 and that for each such binding pr is verified. *) val disjoint : (key -> 'a -> 'b -> bool) -> 'a t -> 'b t -> bool (** [disjoint pr m1 m2] verifies that for every common key in m1 and m2, pr is verified. *) val set_union : 'a t -> 'a t -> 'a t (** [set_union = union (fun _ x _ -> Some x)] *) val set_inter : 'a t -> 'b t -> 'a t (** [set_inter = inter (fun _ x _ -> Some x)] *) val set_diff : 'a t -> 'b t -> 'a t (** [set_diff = diff (fun _ _ _ -> None)] *) val set_submap : 'a t -> 'b t -> bool (** [set_submap = submap (fun _ _ _ -> true)] *) val set_disjoint : 'a t -> 'b t -> bool (** [set_disjoint = disjoint (fun _ _ _ -> false)] *) val set_compare : 'a t -> 'b t -> int (** [set_compare = compare (fun _ _ -> 0)] *) val set_equal : 'a t -> 'b t -> bool (** [set_equal = equal (fun _ _ -> true)] *) val find_def : 'a -> key -> 'a t -> 'a (** [find_def x d m] returns the current binding of [x] in [m], or return [d] if no such binding exists. *) val find_opt : key -> 'a t -> 'a option (** [find_opt x m] returns the [Some] of the current binding of [x] in [m], or return [None] if no such binding exists. *) val find_exn : exn -> key -> 'a t -> 'a (** [find_exn exn x d m] returns the current binding of [x] in [m], or raise [exn] if no such binding exists. *) val map_filter: ('a -> 'b option) -> 'a t -> 'b t (** Same as {!Extmap.S.map}, but may remove bindings. *) val mapi_filter: (key -> 'a -> 'b option) -> 'a t -> 'b t (** Same as {!Extmap.S.mapi}, but may remove bindings. *) val mapi_fold: (key -> 'a -> 'acc -> 'acc * 'b) -> 'a t -> 'acc -> 'acc * 'b t (** fold and map at the same time *) val mapi_filter_fold: (key -> 'a -> 'acc -> 'acc * 'b option) -> 'a t -> 'acc -> 'acc * 'b t (** Same as {!Extmap.S.mapi_fold}, but may remove bindings. *) val fold_left: ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b (** same as {!fold} but in the order of {!List.fold_left} *) val fold2_inter: (key -> 'a -> 'b -> 'c -> 'c) -> 'a t -> 'b t -> 'c -> 'c (** fold the common keys of two map at the same time *) val fold2_union: (key -> 'a option -> 'b option -> 'c -> 'c) -> 'a t -> 'b t -> 'c -> 'c (** fold the keys which appear in one of the two maps *) val translate : (key -> key) -> 'a t -> 'a t (** [translate f m] translates the keys in the map [m] by the function [f]. [f] must be strictly monotone on the key of [m]. Otherwise it raises invalid_arg *) val add_new : exn -> key -> 'a -> 'a t -> 'a t (** [add_new e x v m] binds [x] to [v] in [m] if [x] is not bound, and raises [e] otherwise. *) val replace : exn -> key -> 'a -> 'a t -> 'a t (** [replace e x v m] binds [x] to [v] in [m] if [x] is already bound, and raises [e] otherwise. *) val keys: 'a t -> key list (** Return the list of all keys of the given map. The returned list is sorted in increasing order with respect to the ordering [Ord.compare], where [Ord] is the argument given to {!Extmap.Make}. *) val values: 'a t -> 'a list (** Return the list of all values of the given map. The returned list is sorted in increasing order with respect to the ordering [Ord.compare] of the keys, where [Ord] is the argument given to {!Extmap.Make}. *) val of_list: (key * 'a) list -> 'a t (** construct a map from a pair of bindings *) val domain : 'a t -> unit t (** [domain m] returns the set of keys of binding [m] *) val subdomain : (key -> 'a -> bool) -> 'a t -> unit t (** [subdomain pr m] returns the set of keys of bindings in [m] that satisfy predicate [pr] *) val is_num_elt : int -> 'a t -> bool (** check if the map has the given number of elements *) type 'a enumeration (** enumeration: zipper style *) val val_enum : 'a enumeration -> (key * 'a) option (** get the current key value pair of the enumeration, return None if the enumeration reach the end *) val start_enum : 'a t -> 'a enumeration (** start the enumeration of the given map *) val next_enum : 'a enumeration -> 'a enumeration (** get the next step of the enumeration *) val start_ge_enum : key -> 'a t -> 'a enumeration (** start the enumeration of the given map at the first key which is greater or equal than the given one *) val next_ge_enum : key -> 'a enumeration -> 'a enumeration (** get the next (or same) step of the enumeration which key is greater or equal to the given key *) end module Make (Ord : OrderedType) : S with type key = Ord.t (** Functor building an implementation of the map structure given a totally ordered type. *) why3-0.88.3/src/util/loc.ml0000664000175100017510000000771013225666037016134 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (* type lexing_loc = Lexing.position * Lexing.position *) open Lexing let current_offset = ref 0 let reloc p = { p with pos_cnum = p.pos_cnum + !current_offset } let set_file file lb = lb.Lexing.lex_curr_p <- { lb.Lexing.lex_curr_p with Lexing.pos_fname = file } let transfer_loc lb_from lb_to = lb_to.lex_start_p <- lb_from.lex_start_p; lb_to.lex_curr_p <- lb_from.lex_curr_p (*s Error locations. *) (* dead code let finally ff f x = let y = try f x with e -> ff (); raise e in ff (); y *) open Format (*s Line number *) (* let report_line fmt l = fprintf fmt "%s:%d:" l.pos_fname l.pos_lnum *) type position = string * int * int * int let user_position fname lnum cnum1 cnum2 = (fname,lnum,cnum1,cnum2) let get loc = loc let dummy_position = ("",0,0,0) let join (f1,l1,b1,e1) (f2,_,b2,e2) = assert (f1 = f2); (f1,l1,b1,e1+e2-b2) let extract (b,e) = let f = b.pos_fname in let l = b.pos_lnum in let fc = b.pos_cnum - b.pos_bol in let lc = e.pos_cnum - b.pos_bol in (f,l,fc,lc) let compare = Pervasives.compare let equal = Pervasives.(=) let hash = Hashtbl.hash let gen_report_position fmt (f,l,b,e) = fprintf fmt "File \"%s\", line %d, characters %d-%d" f l b e let report_position fmt = fprintf fmt "%a:@\n" gen_report_position (* located exceptions *) exception Located of position * exn let error ?loc e = match loc with | Some loc -> raise (Located (loc, e)) | None -> raise e let try1 ?loc f x = if Debug.test_flag Debug.stack_trace then f x else try f x with Located _ as e -> raise e | e -> error ?loc e let try2 ?loc f x y = if Debug.test_flag Debug.stack_trace then f x y else try f x y with Located _ as e -> raise e | e -> error ?loc e let try3 ?loc f x y z = if Debug.test_flag Debug.stack_trace then f x y z else try f x y z with Located _ as e -> raise e | e -> error ?loc e let try4 ?loc f x y z t = if Debug.test_flag Debug.stack_trace then f x y z t else try f x y z t with Located _ as e -> raise e | e -> error ?loc e let try5 ?loc f x y z t u = if Debug.test_flag Debug.stack_trace then f x y z t u else try f x y z t u with Located _ as e -> raise e | e -> error ?loc e let try6 ?loc f x y z t u v = if Debug.test_flag Debug.stack_trace then f x y z t u v else try f x y z t u v with Located _ as e -> raise e | e -> error ?loc e let try7 ?loc f x y z t u v w = if Debug.test_flag Debug.stack_trace then f x y z t u v w else try f x y z t u v w with Located _ as e -> raise e | e -> error ?loc e (* located messages *) exception Message of string let errorm ?loc f = let buf = Buffer.create 512 in let fmt = Format.formatter_of_buffer buf in Format.kfprintf (fun _ -> Format.pp_print_flush fmt (); let s = Buffer.contents buf in Buffer.clear buf; error ?loc (Message s)) fmt ("@[" ^^ f ^^ "@]") let () = Exn_printer.register (fun fmt exn -> match exn with | Located (loc,e) -> fprintf fmt "%a%a" report_position loc Exn_printer.exn_printer e | Message s -> fprintf fmt "%s" s | _ -> raise exn) let loc lb = extract (Lexing.lexeme_start_p lb, Lexing.lexeme_end_p lb) let with_location f lb = if Debug.test_flag Debug.stack_trace then f lb else try f lb with | Located _ as e -> raise e | e -> raise (Located (loc lb, e)) why3-0.88.3/src/util/lexlib.mli0000664000175100017510000000201213225666037016775 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** common functions to be used in lexers/parsers *) val newline : Lexing.lexbuf -> unit val comment : Lexing.lexbuf -> unit val string : Lexing.lexbuf -> string val update_loc : Lexing.lexbuf -> string option -> int -> int -> unit val remove_leading_plus : string -> string val remove_underscores : string -> string why3-0.88.3/src/util/stdlib.mli0000664000175100017510000000374113225666037017011 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** Specific instances of Set, Map, Hashtbl on int, string, float, and tagged types *) module Mint : Extmap.S with type key = int module Sint : Extset.S with module M = Mint module Hint : Exthtbl.S with type key = int module Mstr : Extmap.S with type key = string module Sstr : Extset.S with module M = Mstr module Hstr : Exthtbl.S with type key = string module Mfloat : Extmap.S with type key = float module Sfloat : Extset.S with module M = Mfloat module Hfloat : Exthtbl.S with type key = float (* Set, Map, Hashtbl on structures with a unique tag *) module type TaggedType = sig type t val tag : t -> int end module type OrderedHashedType = sig type t val hash : t -> int val equal : t -> t -> bool val compare : t -> t -> int end module OrderedHashed (X : TaggedType) : OrderedHashedType with type t = X.t module OrderedHashedList (X : TaggedType) : OrderedHashedType with type t = X.t list module MakeMSH (X : TaggedType) : sig module M : Extmap.S with type key = X.t module S : Extset.S with module M = M module H : Exthtbl.S with type key = X.t end module MakeMSHW (X : Weakhtbl.Weakey) : sig module M : Extmap.S with type key = X.t module S : Extset.S with module M = M module H : Exthtbl.S with type key = X.t module W : Weakhtbl.S with type key = X.t end why3-0.88.3/src/util/debug.ml0000664000175100017510000001431213225666037016441 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) let formatter = ref Format.err_formatter exception UnknownFlag of string type flag = bool ref let flag_table = Hashtbl.create 17 let fst3 (flag,_,_) = flag let snd3 (_,info,_) = info let thd3 (_,_,desc) = desc let gen_register_flag (desc : Pp.formatted) s info = try fst3 (Hashtbl.find flag_table s) with Not_found -> let flag = ref false in Hashtbl.replace flag_table s (flag,info,desc); flag let register_info_flag ~desc s = gen_register_flag desc s true let register_flag ~desc s = gen_register_flag desc s false let list_flags () = Hashtbl.fold (fun s (v,_,desc) acc -> (s,v,!v,desc)::acc) flag_table [] let lookup_flag s = try fst3 (Hashtbl.find flag_table s) with Not_found -> raise (UnknownFlag s) let is_info_flag s = try snd3 (Hashtbl.find flag_table s) with Not_found -> raise (UnknownFlag s) let flag_desc s = try thd3 (Hashtbl.find flag_table s) with Not_found -> raise (UnknownFlag s) let test_flag s = !s let test_noflag s = not !s let set_flag s = s := true let unset_flag s = s := false let toggle_flag s = s := not !s let () = Exn_printer.register (fun fmt e -> match e with | UnknownFlag s -> Format.fprintf fmt "unknown debug flag `%s'@." s | _ -> raise e) let stack_trace = register_info_flag "stack_trace" ~desc:"Avoid@ catching@ exceptions@ in@ order@ to@ get@ the@ stack@ trace." let timestamp = register_info_flag "timestamp" ~desc:"Print@ a@ timestamp@ before@ debugging@ messages." let time_start = Unix.gettimeofday () let set_debug_formatter f = (** enable the usual behavior of stderr: flush at every new line *) let o = Format.pp_get_formatter_out_functions f () in Format.pp_set_formatter_out_functions f { o with Format.out_newline = (fun () -> o.Format.out_newline (); o.Format.out_flush ()) }; formatter := f let get_debug_formatter () = !formatter let () = set_debug_formatter Format.err_formatter let dprintf flag s = if !flag then begin if !timestamp then Format.fprintf !formatter "<%f>" (Unix.gettimeofday () -. time_start); Format.fprintf !formatter s end else Format.ifprintf !formatter s (*** Command-line arguments ****) module Args = struct type spec = (Arg.key * Arg.spec * Arg.doc) let desc_debug_list, option_list = let opt_list_flags = ref false in let desc = "--list-debug-flags", Arg.Set opt_list_flags, " list known debug flags" in let list () = if !opt_list_flags then begin let list = Hashtbl.fold (fun s (_,info,desc) acc -> (s,info,desc)::acc) flag_table [] in let print fmt (p,info,desc) = Format.fprintf fmt "@[%s%s@\n @[%a@]@]" p (if info then " *" else "") Pp.formatted desc in Format.printf "@[Known debug flags \ (`*' marks the flags selected by --debug-all):@\n%a@]@." (Pp.print_list Pp.newline print) (List.sort Pervasives.compare list); end; !opt_list_flags in desc,list let opt_list_flags = Queue.create () let add_flag s = Queue.add s opt_list_flags let desc_shortcut flag option desc = let set_flag () = add_flag flag in let desc = Pp.sprintf "%s (same as --debug %s)" desc flag in (option, Arg.Unit set_flag, desc) let desc_debug = ("--debug", Arg.String add_flag, " set a debug flag") let opt_debug_all = ref false let desc_debug_all = let desc_debug = Pp.sprintf " set all debug flags that do not change Why3 behaviour" in ("--debug-all", Arg.Set opt_debug_all, desc_debug) let set_flags_selected () = if !opt_debug_all then List.iter (fun (s,f,_,_) -> if is_info_flag s then set_flag f) (list_flags ()); Queue.iter (fun flag -> let flag = lookup_flag flag in set_flag flag) opt_list_flags; if test_flag stack_trace then Printexc.record_backtrace true end (** Stats *) let stats = register_info_flag "stats" ~desc:"Compute and print statistics." type 'a stat = { mutable value:'a; printer: Format.formatter -> 'a -> unit; name : string; } module Stats = struct let max_name_size = ref 0 let registered_stats : (Format.formatter -> unit) list ref = ref [] let rec print_nb_char fmt = function | n when n <= 0 -> () | n -> Format.pp_print_char fmt ' '; print_nb_char fmt (n-1) let print_stat fmt stat = Format.fprintf fmt "@[%s%a: %a@]" stat.name print_nb_char (!max_name_size - String.length stat.name) stat.printer stat.value let print () = dprintf stats "@[%a@]@\n" (Pp.print_list Pp.newline (fun fmt f -> f fmt)) !registered_stats let () = at_exit (fun () -> print (); Format.pp_print_flush !formatter ()) (** SIGXCPU cpu time limit reached *) let _ = (** TODO? have a possible callback for printing different message*) Sys.signal Sys.sigint (Sys.Signal_handle (fun _ -> exit 2)) let register ~print ~name ~init = let s = {name = name; printer = print; value = init} in max_name_size := max !max_name_size (String.length name); registered_stats := (fun fmt -> print_stat fmt s)::!registered_stats; s let mod0 stat f = if test_flag stats then stat.value <- f stat.value let mod1 stat f x = if test_flag stats then stat.value <- f stat.value x let mod2 stat f x y = if test_flag stats then stat.value <- f stat.value x y let register_int ~name ~init = register ~print:Format.pp_print_int ~name ~init let incr r = if test_flag stats then r.value <- r.value + 1 let decr r = if test_flag stats then r.value <- r.value - 1 end why3-0.88.3/src/util/lists.ml0000664000175100017510000000712313225666037016513 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (* useful list combinators *) let rev_map_fold_left f acc l = let acc, rev = List.fold_left (fun (acc, rev) e -> let acc, e = f acc e in acc, e :: rev) (acc, []) l in acc, rev let map_fold_left f acc l = let acc, rev = rev_map_fold_left f acc l in acc, List.rev rev let map_fold_right f l acc = List.fold_right (fun e (l, acc) -> let e, acc = f e acc in e :: l, acc) l ([], acc) let equal pr l1 l2 = try List.for_all2 pr l1 l2 with Invalid_argument _ -> false let rec compare cmp l1 l2 = match l1,l2 with | [], [] -> 0 | [], _ -> -1 | _, [] -> 1 | a1::l1, a2::l2 -> let c = cmp a1 a2 in if c = 0 then compare cmp l1 l2 else c let map_join_left map join = function | x :: xl -> List.fold_left (fun acc x -> join acc (map x)) (map x) xl | _ -> invalid_arg "List.Lists.map_join_left" let apply f l = List.rev (List.fold_left (fun acc x -> List.rev_append (f x) acc) [] l) let cons f acc x = (f x)::acc let fold_product f acc l1 l2 = List.fold_left (fun acc e1 -> List.fold_left (fun acc e2 -> f acc e1 e2) acc l2) acc l1 let fold_product_l f acc ll = let ll = List.rev ll in let rec aux acc le = function | [] -> f acc le | l::ll -> List.fold_left (fun acc e -> aux acc (e::le) ll) acc l in aux acc [] ll let flatten_rev fl = List.fold_left (fun acc l -> List.rev_append l acc) [] fl let part cmp l = let l = List.stable_sort cmp l in match l with | [] -> [] | e::l -> let rec aux acc curr last = function | [] -> ((last::curr)::acc) | a::l when cmp last a = 0 -> aux acc (last::curr) a l | a::l -> aux ((last::curr)::acc) [] a l in aux [] [] e l let rec first f = function | [] -> raise Not_found | a::l -> match f a with | None -> first f l | Some r -> r let find_nth p l = let rec aux p n = function | [] -> raise Not_found | a::l -> if p a then n else aux p (n+1) l in aux p 0 l let first_nth f l = let rec aux f n = function | [] -> raise Not_found | a::l -> match f a with | None -> aux f (n+1) l | Some r -> n,r in aux f 0 l let iteri f l = let rec iter i = function | [] -> () | x :: l -> f i x; iter (i + 1) l in iter 0 l let mapi f l = let rec map i = function | [] -> [] | x :: l -> let v = f i x in v :: map (i + 1) l in map 0 l let fold_lefti f acc l = let rec fold_left acc i = function | [] -> acc | a :: l -> fold_left (f acc i a) (i + 1) l in fold_left acc 0 l let rec prefix n l = if n = 0 then [] else if n < 0 || l = [] then invalid_arg "Util.chop" else List.hd l :: prefix (n - 1) (List.tl l) let rec chop n l = if n = 0 then l else if n < 0 || l = [] then invalid_arg "Util.chop" else chop (n - 1) (List.tl l) let rec chop_last = function | [] -> invalid_arg "Util.chop_last" | [r] -> [], r | x :: s -> let s, r = chop_last s in x :: s, r why3-0.88.3/src/util/opt.ml0000664000175100017510000000341413225666037016156 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (* useful option combinators *) let inhabited = function None -> false | Some _ -> true let get = function None -> invalid_arg "Opt.get" | Some x -> x let get_exn exn = function None -> raise exn | Some x -> x let get_def d = function None -> d | Some x -> x let map f = function None -> None | Some x -> Some (f x) let apply d f x = match f with None -> d | Some f -> f x let apply2 d f x y = match f with None -> d | Some f -> f x y let fold f d = function None -> d | Some x -> f d x let fold_right f o d = match o with None -> d | Some x -> f x d let iter f = function None -> () | Some x -> f x let map2 f x y = match x,y with | None, None -> None | Some x, Some y -> Some (f x y) | _ -> invalid_arg "Opt.map2" let equal eq a b = match a,b with | None, None -> true | None, _ | _, None -> false | Some x, Some y -> eq x y let compare cmp a b = match a,b with | None, None -> 0 | None, Some _ -> -1 | Some _, None -> 1 | Some x, Some y -> cmp x y let map_fold f acc x = match x with | None -> acc, None | Some x -> let acc, x = f acc x in acc, Some x why3-0.88.3/src/transform/0000775000175100017510000000000013225666037016056 5ustar guillaumeguillaumewhy3-0.88.3/src/transform/eliminate_literal.mli0000664000175100017510000000134713225666037022251 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) val meta_keep_lit : Theory.meta why3-0.88.3/src/transform/filter_trigger.ml0000664000175100017510000000524413225666037021425 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Term let make_rt_rf keep = let rec rt t = TermTF.t_map rt rf t and rf f = let f = TermTF.t_map rt rf f in match f.t_node with | Tquant (Tforall,fq) -> let vsl,trl,f2 = t_open_quant fq in let one_false = ref false in let keep x = let b = keep x in if b then b else (one_false := true; b) in let trl = List.filter (List.for_all keep) trl in if not (!one_false) then f else t_forall_close vsl trl f2 | _ -> f in rt,rf let keep_no_trigger _ = false let remove_triggers = let rt,rf = make_rt_rf keep_no_trigger in Trans.rewriteTF rt rf None let () = Trans.register_transform "remove_triggers" remove_triggers ~desc:"Remove@ all@ triggers@ from@ quantifiers." let keep_no_predicate e = e.t_ty <> None let filter_trigger_no_predicate = let rt,rf = make_rt_rf keep_no_predicate in Trans.rewriteTF rt rf None let () = Trans.register_transform "filter_trigger_no_predicate" filter_trigger_no_predicate ~desc:"Remove@ all@ formula@ triggers@ from@ quantifiers." let keep_no_fmla = function | { t_ty = Some _ } -> true | { t_node = Tapp (ps,_) } -> not (ls_equal ps ps_equ) | _ -> false let filter_trigger = let rt,rf = make_rt_rf keep_no_fmla in Trans.rewriteTF rt rf None let () = Trans.register_transform "filter_trigger" filter_trigger ~desc:"Remove@ all@ complex@ formula@ triggers@ \ (anything@ but@ predicate@ applications)." let keep_no_builtin rem_ls = function | { t_ty = Some _ } -> true | { t_node = Tapp (ps,_) } -> not (Sls.mem ps rem_ls) | _ -> false let filter_trigger_builtin = Trans.on_tagged_ls Printer.meta_syntax_logic (fun rem_ls -> let rt,rf = make_rt_rf (keep_no_builtin rem_ls) in Trans.rewriteTF rt rf None) let () = Trans.register_transform "filter_trigger_builtin" filter_trigger_builtin ~desc:"Remove@ all@ complex@ or@ interpreted@ formula@ triggers@ \ (anything@ but@ non-built-in@ predicate@ applications)." why3-0.88.3/src/transform/lift_epsilon.ml0000664000175100017510000000601313225666037021077 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Close_epsilon open Term open Theory open Task type lift_kind = (* | Goal (* prove the existence of a witness *) *) | Implied (* require the existence of a witness in an axiom *) | Implicit (* do not require a witness *) let lift kind = let rec term acc t = match t.t_node with | Teps fb -> let fv = Mvs.keys (t_vars t) in let x, f = t_open_bound fb in let acc, f = form acc f in let tys = List.map (fun x -> x.vs_ty) fv in let xs = Ident.id_derive "epsilon" x.vs_name in let xl = create_fsymbol xs tys x.vs_ty in let acc = add_decl acc (Decl.create_param_decl xl) in let axs = Decl.create_prsymbol (Ident.id_derive ("epsilon_def") x.vs_name) in let xlapp = t_app xl (List.map t_var fv) t.t_ty in let f = match kind with (* assume that lambdas always exist *) | Implied when not (is_lambda t) -> t_forall_close_merge fv (t_implies (t_exists_close [x] [] f) (t_subst_single x xlapp f)) | _ -> t_subst_single x xlapp f in let acc = add_decl acc (Decl.create_prop_decl Decl.Paxiom axs f) in acc, xlapp | _ -> TermTF.t_map_fold term form acc t and form acc f = TermTF.t_map_fold term form acc f in fun th acc -> let th = th.task_decl in match th.td_node with | Decl d -> let acc, d = Decl.DeclTF.decl_map_fold term form acc d in add_decl acc d | _ -> add_tdecl acc th let lift_epsilon kind = Trans.fold (lift kind) None let meta_epsilon = Theory.register_meta_excl "lift_epsilon" [MTstring] ~desc:"Specify@ whether@ the@ existence@ of@ a@ witness@ for@ the@ \ formula@ under@ epsilon@ is@ assumed:@; \ @[\ - @[implicit:@ implicitly@ assume@ existence@]@\n\ - @[implied:@ @ do@ not@ assume@ the@ existence@ \ of@ a@ witness.@]\ @]" let lift_epsilon = Trans.on_meta_excl meta_epsilon (fun alo -> let kind = match alo with | Some [MAstr "implicit"] -> Implicit | Some [MAstr "implied"] | None -> Implied | _ -> failwith "lift_epsilon accepts only 'implicit' and 'implied'" in lift_epsilon kind) let () = Trans.register_transform "lift_epsilon" lift_epsilon ~desc:"Move@ epsilon-terms@ into@ separate@ function@ definitions." why3-0.88.3/src/transform/simplify_array.mli0000664000175100017510000000130713225666037021614 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) why3-0.88.3/src/transform/intro_projections_counterexmp.ml0000664000175100017510000002327413225666037024623 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Ident open Term open Decl open Theory open Ty let model_trace_regexp = Str.regexp "model_trace:" (* The term labeled with "model_trace:name" will be in counterexample with name "name" *) let label_starts_with regexp l = try ignore(Str.search_forward regexp l.lab_string 0); true with Not_found -> false let string_starts_with regexp l = try ignore(Str.search_forward regexp l 0); true with Not_found -> false let get_label labels regexp = Slab.choose (Slab.filter (label_starts_with regexp) labels) let is_proj_for_array_attr proj_name = let b = try string_starts_with (Str.regexp "'First\\|'Last\\|\\.") proj_name with Not_found -> false in b (* (* Debugging functions *) let debug = Debug.register_info_flag "intro_projections_counterexmp" ~desc:"Print@ debugging@ messages@ about@ introducing@ projections@ for@ counterexamples." vlet rec debug_print_terms terms = match terms with | [] -> () | term::tail -> Pretty.print_term Format.str_formatter term; debug_print_terms tail let debug_decl decl = Pretty.print_decl Format.str_formatter decl; let s = Format.flush_str_formatter () in Debug.dprintf debug "Declaration %s @." s *) (* Label for terms that should be in counterexample *) let model_label = Ident.create_label "model" (* Label for terms that should be projected in counterexample *) let model_proj_label = Ident.create_label "model_projected" (* Meta to tag projection functions *) let meta_projection = Theory.register_meta "model_projection" [Theory.MTlsymbol] ~desc:"Declares@ the@ projection." let intro_const_equal_to_term ~term ~id_new ~axiom_name = (* See documentation of the function in file intro_projections_counterexmp.mli. *) (* Create declaration of new constant *) (*let lab_new = Slab.add model_label labels in*) let ls_new_constant = Term.create_lsymbol id_new [] term.t_ty in let decl_new_constant = Decl.create_param_decl ls_new_constant in let t_new_constant = Term.t_app ls_new_constant [] term.t_ty in (* Create declaration of the axiom about the constant: t_new_constant = t_rhs *) let id_axiom = Decl.create_prsymbol (Ident.id_fresh axiom_name) in let fla_axiom = Term.t_equ t_new_constant term in let decl_axiom = Decl.create_prop_decl Decl.Paxiom id_axiom fla_axiom in (* Return the declaration of new constant and the axiom *) decl_new_constant::decl_axiom::[] let introduce_constant ls t_rhs proj_name = (* We only allow projections to apply if they produce an element with a new model trace. In practice, we forbid proj_name that are not record (".") or array attributes like First and Last *) if is_proj_for_array_attr proj_name then (* introduce new constant c and axiom stating c = t_rhs *) let const_label = Slab.add model_label ls.ls_name.id_label in let const_label = append_to_model_element_name ~labels:const_label ~to_append:proj_name in let const_loc = Opt.get ls.ls_name.id_loc in let const_name = ls.ls_name.id_string^"_proj_constant_"^proj_name in let axiom_name = ls.ls_name.id_string^"_proj_axiom_"^proj_name in let id_new = Ident.id_user ~label:const_label const_name const_loc in intro_const_equal_to_term ~term:t_rhs ~id_new:id_new ~axiom_name:axiom_name else [] let get_record_field_suffix projection = try get_model_element_name ~labels:projection.ls_name.id_label with Not_found -> "" (* Find the projections corresponding to some type if it exists *) let get_list_projs t map_projs = match t.t_ty with | None -> [] | Some ty -> let pfs = try Ty.Mty.find ty map_projs with | Not_found -> [] in pfs let rec projections_for_term ls term proj_name applied_projs env map_projs = (* Return declarations for projections of the term. Parameter proj_name is the name of the projection Parameter applied_proj_f is a set of projection functions already applied to the term *) match (Opt.get term.t_ty).ty_node with | Tyapp (ts, [_t_from; _t_to]) when ts.ts_name.id_string = "map" -> begin let pfs = get_list_projs term map_projs in match pfs with | [] -> (* There is no projection function for the term -> the projection consists of definition of constant c and axiom c = p *) introduce_constant ls term proj_name | _ -> List.fold_left (fun ldecls proj_function -> let rhs = Term.t_app_infer proj_function [(Term.t_app_infer ls [])] in let l = introduce_constant ls rhs proj_name in ldecls @ l ) [] pfs end | _ -> (* Non-map case *) (* Find all projection functions for the term *) let pfs = get_list_projs term map_projs in match pfs with | [] -> (* There is no projection function for the term -> the projection consists of definition of constant c and axiom c = p *) introduce_constant ls term proj_name | pfs -> (* Collect declarations for projections f of the form f = pf_n .. pf_1 where pf_1 is an element of pfs *) List.fold_left (fun l pf_1 -> if Term.Sls.mem pf_1 applied_projs then (* Do not apply the same projection twice *) l @ introduce_constant ls term proj_name else let t_applied = Term.t_app pf_1 [term] pf_1.ls_value in let proj_name = proj_name^(get_record_field_suffix pf_1) in let applied_projs = Term.Sls.add pf_1 applied_projs in (* Return declarations for projections of t_applied = pf_1 term *) let t_applied_projs = projections_for_term ls t_applied proj_name applied_projs env map_projs in l @ t_applied_projs ) [] pfs let intro_proj_for_ls env map_projs ls_projected = (* Returns list of declarations for projection of ls_projected if it has a label "model_projected", otherwise returns []. There can be more projections for ls_projected. For each projection f the declarations include: - declaration of new constant with labels of ls_projected, label "model", and label "model_trace:proj_name" where proj_name is the name of the projection - declaration of axiom saying that the new constant is equal to ls_projected projected by its projection The projection is composed from projection functions stored in map_projs. @param map_projs maps types to projection function for these types @param ls_projected the label symbol that should be projected *) if not (Slab.mem model_proj_label ls_projected.ls_name.id_label) then (* ls_projected has not a label "model_projected" *) [] else match ls_projected.ls_value with | None -> [] | Some _ -> (* Create term from ls_projected *) let t_projected = Term.t_app ls_projected [] ls_projected.ls_value in projections_for_term ls_projected t_projected "" Term.Sls.empty env map_projs let introduce_projs env map_projs decl = match decl.d_node with | Dparam ls_projected -> (* Create declarations for a projections of ls_projected *) let projection_decls = intro_proj_for_ls env map_projs ls_projected in projection_decls | _ -> [] let introduce_projs env map_projs decl = match decl with | Decl d -> introduce_projs env map_projs d | _ -> [] let build_projections_map projs = (* Build map from types (Ty.ty) to projections (Term.lsymbol). The type t maps to the projection function f if f has a single argument of the type t. *) let build_map ls_proj proj_map = match ls_proj.ls_args with | [ty_proj_arg] -> let projs_for_ty = try Ty.Mty.find ty_proj_arg proj_map with Not_found -> [] in let projs_for_ty = ls_proj :: projs_for_ty in Ty.Mty.add ty_proj_arg projs_for_ty proj_map | _ -> assert false in Sls.fold build_map projs Ty.Mty.empty (* TODO we want to be able to write this. It seems not possible with Trans and more efficient than the version we have below. let meta_transform2 f : Task.task -> Task.task = fun task -> Trans.apply (Trans.fold (fun d t -> Trans.apply (Trans.add_decls (f d)) t) task) task *) (* [meta_transform2 f t] Generate new declarations by applying f to each declaration of t and then append these declarations to t *) let meta_transform2 f : Task.task Trans.trans = let list_decl = Trans.fold (fun d l -> l @ (f d)) [] in Trans.bind list_decl (fun x -> Trans.add_decls x) let encapsulate env projs : Task.task Trans.trans = let map_projs = build_projections_map projs in meta_transform2 (fun d -> introduce_projs env map_projs d.Task.task_decl.td_node) let intro_projections_counterexmp env = Trans.on_tagged_ls meta_projection (encapsulate env) let () = Trans.register_env_transform "intro_projections_counterexmp" intro_projections_counterexmp ~desc:"For@ each@ declared@ abstract@ function@ and@ predicate@ p@ with@ label@ model_projected@ \ and@ projectin@ f@ for@ p@ creates@ declaration@ of@ new@ constant@ c@ with@ label@ model@ and@ an@ axiom@ \ c = f p." (* Local Variables: compile-command: "unset LANG; make -C ../.. byte" End: *) why3-0.88.3/src/transform/intro_vc_vars_counterexmp.ml0000664000175100017510000003263013225666037023723 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Decl open Ty open Term open Ident open Intro_projections_counterexmp (** For see intro_vc_vars_counterexmp.mli for detailed description of this transformation. *) let meta_vc_location = Theory.register_meta_excl "vc_location" [Theory.MTstring] ~desc:"Location@ of@ the@ term@ that@ triggers@ vc@ in@ the@ form@ file:line:col." let model_label = Ident.create_label "model" (* Identifies terms that should be in counterexample and should not be projected. *) let model_projected_label = Ident.create_label "model_projected" (* Identifies terms that should be in counterexample and should be projected. *) let model_vc_label = Ident.create_label "model_vc" (* Identifies the term that triggers the VC. *) let model_vc_post_label = Ident.create_label "model_vc_post" (* Identifies the postcondition that triggers the VC. *) (* Information about the term that triggers VC. *) type vc_term_info = { vc_inside : bool; (* true if the term that triggers VC is currently processed *) vc_loc : Loc.position option; (* the position of the term that triggers VC *) vc_pre_or_post : bool; (* true if VC was generated for precondition or postcondition *) } let is_model_vc_label l = l = model_vc_label || l = model_vc_post_label let check_enter_vc_term t info vc_loc = (* Check whether the term that triggers VC is entered. If it is entered, extract the location of the term and if the VC is postcondition or precondition of a function, extract the name of the corresponding function. *) if Slab.exists is_model_vc_label t.t_label then begin vc_loc := t.t_loc; { vc_inside = true; vc_loc = t.t_loc; vc_pre_or_post = Slab.mem model_vc_post_label t.t_label} end else info let add_old lab_str = try let pos = Str.search_forward (Str.regexp "@") lab_str 0 in let after = String.sub lab_str pos ((String.length lab_str)-pos) in if after = "@init" then (String.sub lab_str 0 pos) ^ "@old" else lab_str with Not_found -> lab_str ^ "@old" let model_trace_for_postcondition ~labels = (* Modifies the model_trace label of a term in the postcondition: - if term corresponds to the initial value of a function parameter, model_trace label will have postfix @old Returns labels with model_trace label modified if there exist model_trace label in labels, labels otherwise. *) try let trace_label = get_label labels model_trace_regexp in let lab_str = add_old trace_label.lab_string in if lab_str = trace_label.lab_string then labels else let other_labels = Slab.remove trace_label labels in Slab.add (Ident.create_label lab_str) other_labels with Not_found -> labels let is_counterexample_label l = l = model_label || l = model_projected_label (* Preid table necessary to avoid duplication of *_vc_constant *) module Hprid = Exthtbl.Make (struct type t = preid let equal x y = x.pre_name = y.pre_name && Slab.equal x.pre_label y.pre_label let hash p = Exthtbl.hash p end) (* Used to generate duplicate vc_constant and axioms for counterex generation. This function is always called when the term is in negative position or under a positive term that is not introducible. This means it never change the goal. @param info used to know if the current term is under a vc_label @param vc_loc is the location of the vc_label (returned value) @param vc_map is a container for generated vc_constant id (used to avoid duplication) @param vc_var contains the variables we can safely use as CE (ie: we introduced these) @param t: current subterm of the goal @return list of declarations added by do_intro *) let rec do_intro info vc_loc vc_map vc_var t = let info = check_enter_vc_term t info vc_loc in let do_intro = do_intro info vc_loc vc_map vc_var in (* Do the necessary machinery to add a printable counterexample when encountered (variable or function without arguments) *) let new_counter_example_variable ls info = if info.vc_inside then begin match info.vc_loc with | None -> [] | Some loc -> (* variable inside the term T that triggers VC. If the variable should be in counterexample, introduce new constant in location loc with all labels necessary for collecting it for counterexample and make it equal to the variable *) if Slab.exists is_counterexample_label ls.id_label then let const_label = if info.vc_pre_or_post then model_trace_for_postcondition ~labels:ls.id_label else ls.id_label in let const_name = ls.id_string^"_vc_constant" in let axiom_name = ls.id_string^"_vc_axiom" in (* Create a new id here to check the couple name, location. *) let id_new = Ident.id_user ~label:const_label const_name loc in (* The following check is used to avoid duplication of *_vc_constant_n. We keep track of the preids that have already been duplicated in vc_map. Note that we need to do it before these preid are casted to lsymbol (by Term.create_lsymbol) because those integrates a unique hash that would make identical preid different lsymbol *) if (Hprid.mem vc_map id_new) then [] else begin Hprid.add vc_map id_new true; intro_const_equal_to_term ~term:t ~id_new:id_new ~axiom_name end else [] end else [] in match t.t_node with | Tapp (ls, tl) -> begin match tl with | [] -> new_counter_example_variable ls.ls_name info | _ -> List.fold_left (fun defs term -> List.append defs (do_intro term)) [] tl end | Tvar v -> if (Hvs.mem vc_var v) then new_counter_example_variable v.vs_name info else [] | Tbinop (_, f1, f2) -> List.append (do_intro f1) (do_intro f2) | Tquant (_, fq) -> let _, _, f = t_open_quant fq in do_intro f | Tlet (t, tb) -> let _, f = t_open_bound tb in List.append (do_intro t) (do_intro f) | Tnot f -> do_intro f | Tif (f1, f2, f3) -> List.append (List.append (do_intro f1) (do_intro f2)) (do_intro f3) | Tcase (t, _) -> do_intro t (* todo: handle the second argument of Tcase *) | Tconst _ -> [] | Ttrue -> [] | Tfalse -> [] | Teps _ -> [] (* Meant to remove foralls in positive positions (not necessarily in top position). vc_var is the set of variables we already introduced. *) let rec remove_positive_foralls vc_var f = match f.t_node with | Tbinop (Timplies,f1,f2) -> let (decl, fres) = remove_positive_foralls vc_var f2 in (decl, t_implies f1 fres) (* | Tbinop (Tor, f1, f2) -> let (decl1, fres1) = remove_positive_foralls vc_var f1 in let (decl2, fres2) = remove_positive_foralls vc_var f2 in (decl1 @ decl2, t_or fres1 fres2)*) | Tbinop (Tand, f1, f2) -> let (decl1, fres1) = remove_positive_foralls vc_var f1 in let (decl2, fres2) = remove_positive_foralls vc_var f2 in (decl1 @ decl2, t_and fres1 fres2) | Tquant (Tforall, fq) -> let vsl,_trl,f_t = t_open_quant fq in let intro_var subst vs = let ls = create_lsymbol (id_clone vs.vs_name) [] (Some vs.vs_ty) in Hvs.add vc_var vs true; Mvs.add vs (fs_app ls [] vs.vs_ty) subst, create_param_decl ls in let subst, dl = Lists.map_fold_left intro_var Mvs.empty vsl in let f = t_label_copy f (t_subst subst f_t) in let decl, goal = remove_positive_foralls vc_var f in (dl @ decl, goal) | _ -> ([], f) (* Introduces foralls, lets, and implications at the head of the goal. When under a vc_label, it can make calls to do_intros which creates new declarations for counterexample generation. When no more intros are possible, it calls remove_positive_foralls which do an experimental introduction of foralls even under another constructs (example: H /\ forall i. P(i) yields (i, H /\ P(i)). Note that it seems difficult and "unsafe" to merge these two functions It is adapted from transform/introduce.ml. (we mainly added do_intros calls and removed split optimizations. @param info used to know if the current term is under a vc_label @param vc_loc is the location of the vc_label (returned value) @param vc_map is a container for generated vc_constant id (used to avoid duplication) @param vc_var current set of variables we introduced @param f current goal @return pair of the declarations introduced and the modified goal. *) let rec intros info vc_loc vc_map vc_var f = let info = check_enter_vc_term f info vc_loc in let intros = intros info vc_loc vc_map vc_var in match f.t_node with | Tbinop (Timplies,f1,f2) -> let f2 = t_label_copy f f2 in let l = if info.vc_inside then do_intro info vc_loc vc_map vc_var f1 else [] in let id = create_prsymbol (id_fresh "H") in let d = create_prop_decl Paxiom id f1 in let decl, goal = intros f2 in (d :: l @ decl, goal) | Tquant (Tforall,fq) -> let vsl,_trl,f_t = t_open_quant fq in let intro_var subst vs = let ls = create_lsymbol (id_clone vs.vs_name) [] (Some vs.vs_ty) in Hvs.add vc_var vs true; Mvs.add vs (fs_app ls [] vs.vs_ty) subst, create_param_decl ls in let subst, dl = Lists.map_fold_left intro_var Mvs.empty vsl in (* if vs is a symbol that is tagged with a model or model_projected label, we have to allow it to be printed but it wont be available after its substitution *) (* preserve labels and location of f *) let f = t_label_copy f (t_subst subst f_t) in let decl, goal = intros f in (dl @ decl, goal) | Tlet (t,fb) -> let vs,f = t_open_bound fb in let ls = create_lsymbol (id_clone vs.vs_name) [] (Some vs.vs_ty) in let f = t_subst_single vs (fs_app ls [] vs.vs_ty) f in let d = create_logic_decl [make_ls_defn ls [] t] in (* If we are not inside a vc we don't want left side of let otherwise we might want it *) let decl, goal = intros f in if info.vc_inside then let l = do_intro info vc_loc vc_map vc_var t in (d :: l @ decl, goal) else (d :: decl, goal) | _ -> let (dl, goal) = remove_positive_foralls vc_var f in if info.vc_inside then let l = do_intro info vc_loc vc_map vc_var f in (l @ dl, goal) else (dl,goal) let do_intro_vc_vars_counterexmp info vc_loc pr t = (* TODO initial guess on number of counter-examples to print *) let vc_map = Hprid.create 100 in let vc_var = Hvs.create 100 in let tvs = t_ty_freevars Stv.empty t in let mk_ts tv () = create_tysymbol (id_clone tv.tv_name) [] NoDef in let tvm = Mtv.mapi mk_ts tvs in let decls = Mtv.map create_ty_decl tvm in let subst = Mtv.map (fun ts -> ty_app ts []) tvm in let (defs_intros, t) = intros info vc_loc vc_map vc_var (t_ty_subst subst Mvs.empty t) in let defs_do_intro = do_intro info vc_loc vc_map vc_var t in Mtv.values decls @ defs_intros @ defs_do_intro @ [(create_prop_decl Pgoal pr t)] let intro_vc_vars_counterexmp2 task = let info = { vc_inside = false; vc_loc = None; vc_pre_or_post = false; } in let vc_loc = ref None in (* Do introduction and find location of term triggering VC *) let do_intro_trans = Trans.goal (do_intro_vc_vars_counterexmp info vc_loc) in let task = (Trans.apply do_intro_trans) task in (* Pass meta with location of the term triggering VC to printer *) let vc_loc_meta = Theory.lookup_meta "vc_location" in let g,task = Task.task_separate_goal task in let pos_str = match !vc_loc with | None -> "" | Some loc -> let (file, line, col1, col2) = Loc.get loc in file ^ ":" ^ (string_of_int line) ^ ":" ^ (string_of_int col1) ^ ":" ^ (string_of_int col2) in let task = Task.add_meta task vc_loc_meta [Theory.MAstr pos_str] in Task.add_tdecl task g let intro_vc_vars_counterexmp = Trans.store intro_vc_vars_counterexmp2 let () = Trans.register_transform "intro_vc_vars_counterexmp" intro_vc_vars_counterexmp ~desc:"Introduce." let get_location_of_vc task = let meta_args = Task.on_meta_excl meta_vc_location task in match meta_args with | Some [Theory.MAstr loc_str] -> (* There may be colons in the file name. We still split on the colon, look at the last three elements, and put the remaining ones back together to form the file name. We may lose colons at the beginning or end of the filename, but even on windows that's not allowed. *) let split = Strings.rev_split ':' loc_str in let loc = match split with | col2 :: col1 :: line :: ((_ :: _) as rest) -> let line = int_of_string line in let col1 = int_of_string col1 in let col2 = int_of_string col2 in let filename = Strings.join ":" (List.rev rest) in Some (Loc.user_position filename line col1 col2) | _ -> None in loc | _ -> None why3-0.88.3/src/transform/encoding_guards_full.ml0000664000175100017510000002603313225666037022571 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** transformation from polymorphic logic to many-sorted logic *) open Stdlib open Ident open Ty open Term open Decl open Task open Libencoding (* complete dead module code (** module with printing functions *) module Debug = struct let print_mtv vprinter fmter m = Mtv.iter (fun key value -> Format.fprintf fmter "@[%a@] -> @[%a@]@." Pretty.print_tv key vprinter value) m (** utility to print a list of items *) let rec print_list printer fmter = function | [] -> Format.fprintf fmter "" | e::es -> if es = [] then Format.fprintf fmter "@[%a@] %a" printer e (print_list printer) es else Format.fprintf fmter "@[%a@], %a" printer e (print_list printer) es let debug x = Format.eprintf "%s@." x end *) (** {2 module to separate utilities from important functions} *) module Lib = struct (* function symbol selecting ty_type from ty_type^n *) let ls_selects_of_ts = Wts.memoize 63 (fun ts -> let create_select _ = let preid = id_fresh ("select_"^ts.ts_name.id_string) in create_fsymbol preid [ty_type] ty_type in List.rev_map create_select ts.ts_args) let ls_int_of_ty = create_fsymbol (id_fresh "int_of_ty") [ty_type] ty_int (** definition of the previous selecting functions *) let ls_selects_def_of_ts acc ts = let ls = ls_of_ts ts in let vars = List.rev_map (fun _ -> create_vsymbol (id_fresh "x") ty_type) ts.ts_args in let tvars = List.map t_var vars in (* type to int *) let id = id_hash ts.ts_name in let acc = let t = fs_app ls tvars ty_type in let f = t_equ (fs_app ls_int_of_ty [t] ty_int) (t_nat_const id) in let f = t_forall_close vars [[t]] f in let prsymbol = create_prsymbol (id_clone ts.ts_name) in create_prop_decl Paxiom prsymbol f :: acc in (* select *) let ls_selects = ls_selects_of_ts ts in let fmlas = List.rev_map2 (fun ls_select value -> let t = fs_app ls tvars ty_type in let t = fs_app ls_select [t] ty_type in let f = t_equ t value in let f = t_forall_close vars [[t]] f in f) ls_selects tvars in let create_props ls_select fmla = let prsymbol = create_prsymbol (id_clone ls_select.ls_name) in create_prop_decl Paxiom prsymbol fmla in let props = List.fold_left2 (fun acc x y -> create_props x y::acc) acc ls_selects fmlas in let add acc fs = create_param_decl fs :: acc in List.fold_left add props ls_selects (* convert a type declaration to a list of lsymbol declarations *) let lsdecl_of_ts_select ts = let defs = ls_selects_def_of_ts [] ts in create_param_decl (ls_of_ts ts) :: defs end module Transform = struct (** type_of *) let fs_type = let alpha = ty_var (create_tvsymbol (id_fresh "a")) in create_fsymbol (id_fresh "type_of") [alpha] ty_type let app_type t = fs_app fs_type [t] ty_type (** rewrite a closed formula modulo its free typevars using selection functions *) let rec extract_tvar acc t ty = match ty.ty_node with | Tyvar tvar when Mtv.mem tvar acc -> acc | Tyvar tvar -> Mtv.add tvar t acc | Tyapp (ts,tyl) -> let fold acc ls_select ty = extract_tvar acc (fs_app ls_select [t] ty_type) ty in List.fold_left2 fold acc (Lib.ls_selects_of_ts ts) tyl let type_close_select tvs ts fn f = let fold acc t = extract_tvar acc (app_type t) (t_type t) in let tvm = List.fold_left fold Mtv.empty ts in let tvs = Mtv.set_diff tvs tvm in let get_vs tv = create_vsymbol (id_clone tv.tv_name) ty_type in let tvm' = Mtv.mapi (fun v () -> get_vs v) tvs in let vl = Mtv.values tvm' in let tvm' = Mtv.map t_var tvm' in let tvm = Mtv.union (fun _ _ _ -> assert false) tvm tvm' in t_forall_close_simp vl [] (fn tvm f) let type_variable_only_in_value lsymbol = let tvar_val = ty_freevars Stv.empty (Opt.get lsymbol.ls_value) in let tvar_arg = List.fold_left ty_freevars Stv.empty lsymbol.ls_args in Stv.diff tvar_val tvar_arg (** creates a new logic symbol, with a different type if the given symbol was polymorphic *) let findL = Wls.memoize 63 (fun lsymbol -> if lsymbol.ls_value = None then lsymbol else let new_ty = type_variable_only_in_value lsymbol in (* as many t as type vars *) if Stv.is_empty new_ty then lsymbol (* same type *) else let add _ acc = ty_type :: acc in let args = Stv.fold add new_ty lsymbol.ls_args in (* creates a new lsymbol with the same name but a different type *) Term.create_lsymbol (id_clone lsymbol.ls_name) args lsymbol.ls_value) (* {1 transformations} *) (** todo use callback for this one *) let rec f_open_all_quant q f = match f.t_node with | Tquant (q', f) when q' = q -> let vl, tr, f = t_open_quant f in begin match tr with | [] -> let vl', tr, f = f_open_all_quant q f in vl@vl', tr, f | _ -> vl, tr, f end | _ -> [], [], f (** translation of terms *) let rec term_transform kept varM t = match t.t_node with (* first case : predicate are not translated *) | Tapp(p,terms) when t.t_ty = None -> let terms = List.map (term_transform kept varM) terms in ps_app (findL p) terms | Tapp(f,terms) -> let terms = args_transform kept varM f terms (t_type t) in t_app (findL f) terms t.t_ty | Tquant(q,_) -> let vsl,trl,fmla = f_open_all_quant q t in let fmla = term_transform kept varM fmla in let fmla2 = guard q kept varM fmla vsl in (* TODO : how to modify the triggers? *) let trl = tr_map (term_transform kept varM) trl in t_quant q (t_close_quant vsl trl fmla2) | _ -> (* default case : traverse *) t_map (term_transform kept varM) t and guard q kept varM fmla vsl = let aux fmla vs = if Libencoding.is_protected_vs kept vs then fmla else let g = t_equ (app_type (t_var vs)) (term_of_ty varM vs.vs_ty) in match q with | Tforall -> t_implies g fmla | Texists -> t_and g fmla in List.fold_left aux fmla vsl and args_transform kept varM lsymbol args ty = (* Debug.print_list Pretty.print_ty Format.std_formatter type_vars; *) let tv_to_ty = ty_match Mtv.empty (Opt.get lsymbol.ls_value) ty in let new_ty = type_variable_only_in_value lsymbol in let tv_to_ty = Mtv.set_inter tv_to_ty new_ty in (* Debug.print_mtv Pretty.print_ty Format.err_formatter tv_to_ty; *) let args = List.map (term_transform kept varM) args in (* fresh args to be added at the beginning of the list of arguments *) let add _ ty acc = term_of_ty varM ty :: acc in Mtv.fold add tv_to_ty args let f_type_close_select kept f' = let tvs = t_ty_freevars Stv.empty f' in let trans fn acc f = match f.t_node with | Tquant(Tforall as q,_) -> (* Exists same thing? *) let vsl,trl,fmla = f_open_all_quant q f in let add acc vs = (t_var vs)::acc in let acc = List.fold_left add acc vsl in let fn varM f = let fmla2 = guard q kept varM f vsl in (* TODO : how to modify the triggers? *) let trl = tr_map (term_transform kept varM) trl in fn varM (t_quant q (t_close_quant vsl trl fmla2)) in let fn varM f = fn varM (term_transform kept varM f) in type_close_select tvs acc fn fmla | _ -> let fn varM f = fn varM (term_transform kept varM f) in type_close_select tvs acc fn f in trans (fun _ f -> f) [] f' let logic_guard kept acc lsymbol = match lsymbol.ls_value with | None -> acc | Some _ when Libencoding.is_protected_ls kept lsymbol -> acc | Some ty_val -> let v_id = if Libencoding.is_protecting_id lsymbol.ls_name then id_fresh "x" else Libencoding.id_unprotected "j" in let varl = List.map (create_vsymbol v_id) lsymbol.ls_args in let trans varM () = let terms = List.map t_var varl in let terms = args_transform kept varM lsymbol terms ty_val in let fmla = t_equ (app_type (fs_app (findL lsymbol) terms ty_val)) (term_of_ty varM ty_val) in let guard fmla vs = if Libencoding.is_protected_vs kept vs then fmla else let g = t_equ (app_type (t_var vs)) (term_of_ty varM vs.vs_ty) in t_implies g fmla in let fmla = List.fold_left guard fmla varl in t_forall_close_simp varl [] fmla in let stv = ls_ty_freevars lsymbol in let tl = List.rev_map (t_var) varl in let fmla = type_close_select stv tl trans () in Decl.create_prop_decl Paxiom (create_prsymbol (id_clone lsymbol.ls_name)) fmla::acc let param_transform kept ls = Decl.create_param_decl (findL ls) :: logic_guard kept [] ls let logic_transform kept d = function | [ls,ld] when not (Sid.mem ls.ls_name d.d_syms) -> let f = f_type_close_select kept (ls_defn_axiom ld) in Libencoding.defn_or_axiom (findL ls) f @ logic_guard kept [] ls | _ -> Printer.unsupportedDecl d "Recursively-defined symbols are not supported, run eliminate_recursion" (** transform an inductive declaration *) let ind_transform kept s idl = let iconv (pr,f) = pr, f_type_close_select kept f in let conv (ls,il) = findL ls, List.map iconv il in [Decl.create_ind_decl s (List.map conv idl)] (** transforms a proposition into another (mostly a substitution) *) let prop_transform kept (prop_kind, prop_name, f) = let quantified_fmla = f_type_close_select kept f in [Decl.create_prop_decl prop_kind prop_name quantified_fmla] end (** {2 main part} *) let decl kept d = match d.d_node with | Dtype { ts_def = Alias _ } -> [] | Dtype ts -> d :: Lib.lsdecl_of_ts_select ts | Ddata _ -> Printer.unsupportedDecl d "Algebraic types are not supported, run eliminate_algebraic" | Dparam ls -> Transform.param_transform kept ls | Dlogic ldl -> Transform.logic_transform kept d ldl | Dind (s, idl) -> Transform.ind_transform kept s idl | Dprop prop -> Transform.prop_transform kept prop let empty_th = let task = use_export None Theory.builtin_theory in let task = Task.add_decl task d_ts_type in let task = Task.add_param_decl task Lib.ls_int_of_ty in let task = Task.add_param_decl task Transform.fs_type in task let guard = Trans.on_tagged_ty Libencoding.meta_kept (fun kept -> Trans.decl (decl kept) empty_th) let () = Hstr.replace Encoding.ft_enco_poly "guards_full" (fun _ -> Trans.compose guard Libencoding.monomorphise_task) why3-0.88.3/src/transform/instantiate_predicate.ml0000664000175100017510000001016313225666037022754 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Decl open Term open Ty let instantiate_prop expr args values = let add mt x = ty_match mt x.vs_ty (t_type (Mvs.find x values)) in let mt = List.fold_left add Mtv.empty args in t_ty_subst mt values expr exception Mismatch let rec find_instantiation mv trigger expr = match trigger.t_node, expr.t_node with | Tvar v, _ -> begin match Mvs.find v mv with | w -> if t_equal w expr then mv else raise Mismatch | exception Not_found -> Mvs.add v expr mv end | Tapp (ts,ta), Tapp (es,ea) when ls_equal ts es -> assert (List.length ta = List.length ea); List.fold_left2 find_instantiation mv ta ea | _, _ -> raise Mismatch (** [trans spr task_hd ((lpr, past), task)] looks in [task_hd] for terms that can instantiate axioms of [lpr] and does so in [task]; [lpr] is progressively filled with the axioms of [spr] as they are encountered; [past] contains terms for which axioms have already been instantiated, so that they are not duplicated *) let trans spr task_hd (((lpr, past), task) as current) = let rec scan_term ((past, task) as current) t = let current = if t.t_ty = None && match t.t_node with Tapp _ -> false | _ -> true then current else if Sterm.mem t past then current else List.fold_right (fun (quant, triggers, e) task -> let add vs current = try let ax = instantiate_prop e quant vs in let (past, task) = scan_term current ax in let pr = create_prsymbol (Ident.id_fresh "auto_instance") in (past, Task.add_decl task (create_prop_decl Paxiom pr ax)) with TypeMismatch _ | Not_found -> current in match triggers, quant with | [], [q] -> if t.t_ty = None then task else add (Mvs.singleton q t) task | [], _ -> task | _, _ -> List.fold_left (fun task tr -> match tr with | [tr] -> begin try add (find_instantiation Mvs.empty tr t) task with Mismatch -> task end | _ -> task ) task triggers ) lpr (Sterm.add t past, task) in match t.t_node with | Tapp _ | Tbinop _ | Tnot _ -> t_fold scan_term current t | _ -> current in let (current, task) = match task_hd.Task.task_decl.Theory.td_node with | Theory.Decl { d_node = Dprop (_,pr,expr) } -> let (past, task) = scan_term (past, task) expr in let lpr = if not (Spr.mem pr spr) then lpr else match expr.t_node with | Tquant (Tforall,q_expr) -> t_open_quant q_expr :: lpr | _ -> lpr in ((lpr, past), task) | _ -> current in (current, Task.add_tdecl task task_hd.Task.task_decl) let meta = Theory.register_meta "instantiate : auto" [Theory.MTprsymbol] ~desc:"Mark@ proposition@ that@ should@ be@ automatically@ instantiated@ \ by@ the@ 'instantiate_predicate'@ transformation." (** all the symbols (unary predicates) that have the "instantiate : auto" meta are marked for instantiation by the above transformation *) let () = Trans.register_transform "instantiate_predicate" (Trans.on_tagged_pr meta (fun spr -> Trans.fold_map (trans spr) ([], Sterm.empty) None)) ~desc:"Instantiate@ proposition@ marked@ by@ 'instantiate : auto'.@ \ Used@ for@ Gappa." why3-0.88.3/src/transform/encoding_sort.ml0000664000175100017510000001315213225666037021247 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Ident open Ty open Term open Decl open Theory open Task type tenv = { specials : tysymbol Hty.t; trans_lsymbol : lsymbol Hls.t } let init_tenv = { specials = Hty.create 17; trans_lsymbol = Hls.create 17 } (* Convert type *) let conv_ts tenv undefined name ty = let ts = try Hty.find tenv.specials ty with Not_found -> let ts = create_tysymbol (id_clone name) [] NoDef in Hty.add tenv.specials ty ts; ts in Hts.replace undefined ts (); ts let conv_ty tenv undefined ty = match ty.ty_node with | Tyapp (_,[]) -> ty | Tyapp (ts,_) -> let ts = conv_ts tenv undefined ts.ts_name ty in ty_app ts [] | _ -> Printer.unsupportedType ty "type variable must be encoded" (* Convert a variable *) let conv_vs tenv ud vs = let ty = conv_ty tenv ud vs.vs_ty in if ty_equal ty vs.vs_ty then vs else create_vsymbol (id_clone vs.vs_name) ty (* Convert a logic symbol to the encoded one *) let conv_ls tenv ud ls = if ls_equal ls ps_equ then ls else try Hls.find tenv.trans_lsymbol ls with Not_found -> let ty_res = Opt.map (conv_ty tenv ud) ls.ls_value in let ty_arg = List.map (conv_ty tenv ud) ls.ls_args in let ls' = if Opt.equal ty_equal ty_res ls.ls_value && List.for_all2 ty_equal ty_arg ls.ls_args then ls else create_lsymbol (id_clone ls.ls_name) ty_arg ty_res in Hls.add tenv.trans_lsymbol ls ls'; ls' let rec rewrite_term tenv ud vm t = let fnT = rewrite_term tenv ud in let fnF = rewrite_fmla tenv ud in match t.t_node with | Tconst _ -> t | Tvar x -> Mvs.find x vm | Tapp (fs,tl) -> let fs = conv_ls tenv ud fs in let tl = List.map (fnT vm) tl in fs_app fs tl (Opt.get fs.ls_value) | Tif (f, t1, t2) -> t_if (fnF vm f) (fnT vm t1) (fnT vm t2) | Tlet (t1, b) -> let u,t2,close = t_open_bound_cb b in let u' = conv_vs tenv ud u in let t1' = fnT vm t1 in let t2' = fnT (Mvs.add u (t_var u') vm) t2 in t_let t1' (close u' t2') | Tcase _ | Teps _ -> Printer.unsupportedTerm t "unsupported term" | Tquant _ | Tbinop _ | Tnot _ | Ttrue | Tfalse -> raise (TermExpected t) and rewrite_fmla tenv ud vm f = let fnT = rewrite_term tenv ud in let fnF = rewrite_fmla tenv ud in match f.t_node with | Tapp (ps,tl) when ls_equal ps ps_equ -> ps_app ps (List.map (fnT vm) tl) | Tapp (ps,tl) -> let ps = conv_ls tenv ud ps in let tl = List.map (fnT vm) tl in ps_app ps tl | Tquant (q,b) -> let vl, tl, f1, close = t_open_quant_cb b in let add m v = let v' = conv_vs tenv ud v in Mvs.add v (t_var v') m, v' in let vm', vl' = Lists.map_fold_left add vm vl in let tl' = TermTF.tr_map (fnT vm') (fnF vm') tl in let f1' = fnF vm' f1 in t_quant q (close vl' tl' f1') | Tlet (t1, b) -> let u,f1,close = t_open_bound_cb b in let u' = conv_vs tenv ud u in let t1' = fnT vm t1 in let f1' = fnF (Mvs.add u (t_var u') vm) f1 in t_let t1' (close u' f1') | Tcase _ -> Printer.unsupportedTerm f "unsupported formula" | _ -> TermTF.t_map (fnT vm) (fnF vm) f let decl_ud ud task = let add ts () task = add_ty_decl task ts in Hts.fold add ud task let fold tenv taskpre task = let fnT = rewrite_term tenv in let fnF = rewrite_fmla tenv in match taskpre.task_decl.td_node with | Decl d -> begin match d.d_node with | Dtype { ts_def = Alias _ } | Dtype { ts_args = _::_ } -> task | Dtype ts -> add_ty_decl task ts | Ddata _ -> Printer.unsupportedDecl d "use eliminate_algebraic" | Dparam ls -> let ud = Hts.create 3 in let ls = conv_ls tenv ud ls in add_param_decl (decl_ud ud task) ls | Dlogic _ -> Printer.unsupportedDecl d "use eliminate_definition" | Dind _ -> Printer.unsupportedDecl d "use eliminate_inductive" | Dprop _ -> let ud = Hts.create 3 in decl_ud ud (add_decl task (DeclTF.decl_map (fnT ud Mvs.empty) (fnF ud Mvs.empty) d)) end | Meta(meta,ml) -> begin try let ud = Hts.create 3 in let map = function | MAty ty -> MAty (conv_ty tenv ud ty) | MAts {ts_name = name; ts_args = []; ts_def = Alias ty} -> MAts (conv_ts tenv ud name ty) | MAts {ts_args = []} as x -> x | MAts _ -> raise Exit | MAls ls -> MAls (conv_ls tenv ud ls) | MApr _ -> raise Exit | MAstr _ as s -> s | MAint _ as i -> i in let arg = List.map map ml in add_meta (decl_ud ud task) meta arg with | Printer.UnsupportedType _ | Exit -> add_tdecl task taskpre.task_decl end | _ -> add_tdecl task taskpre.task_decl let t = let tenv = init_tenv in Trans.fold (fold tenv) None let () = Trans.register_transform "encoding_sort" t ~desc:"Replace@ every@ closed@ type@ by@ a@ separate@ type@ constant." why3-0.88.3/src/transform/eliminate_let.ml0000664000175100017510000000320713225666037021225 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Term (* eliminate let *) let rec elim_t func pred map t = match t.t_node with | Tvar vs -> (try Mvs.find vs map with Not_found -> t) | Tlet (t1,tb) when (if t.t_ty = None then pred else func) -> let vs,t2 = t_open_bound tb in let t1 = elim_t func pred map t1 in elim_t func pred (Mvs.add vs t1 map) t2 | _ -> t_map (elim_t func pred map) t let eliminate_let_term = Trans.rewrite (elim_t true false Mvs.empty) None let eliminate_let_fmla = Trans.rewrite (elim_t false true Mvs.empty) None let eliminate_let = Trans.rewrite (elim_t true true Mvs.empty) None let () = Trans.register_transform "eliminate_let_term" eliminate_let_term ~desc:"Eliminate@ let-expressions@ in@ terms."; Trans.register_transform "eliminate_let_fmla" eliminate_let_fmla ~desc:"Eliminate@ let-expressions@ in@ formulas."; Trans.register_transform "eliminate_let" eliminate_let ~desc:"Eliminate@ all@ let-expressions."; why3-0.88.3/src/transform/simplify_formula.ml0000664000175100017510000002056713225666037022003 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Ident open Term open Decl let labset = Slab.of_list [keep_on_simp_label;asym_label] let rec fmla_simpl f = let f = if Slab.disjoint f.t_label labset then f else t_label ?loc:f.t_loc (Slab.diff f.t_label labset) f in TermTF.t_map_simp t_fmla_simpl fmla_simpl f and t_fmla_simpl t = TermTF.t_map t_fmla_simpl fmla_simpl t let decl_l d = match d.d_node with | Dprop (k,pr,f) -> let f = fmla_simpl f in begin match f.t_node, k with | Ttrue, Paxiom -> [[]] | Tfalse, Paxiom -> [] | Ttrue, Pgoal -> [] | _ -> [[create_prop_decl k pr f]] end | _ -> [[DeclTF.decl_map t_fmla_simpl fmla_simpl d]] let simplify_formula = Trans.rewriteTF t_fmla_simpl fmla_simpl None let simplify_formula_and_task = Trans.decl_l decl_l None let () = Trans.register_transform "simplify_formula" simplify_formula ~desc:"Simplify@ the@ formulas@ using@ propositional@ simplifications." let () = Trans.register_transform_l "simplify_formula_and_task" simplify_formula_and_task ~desc:"Same as simplify_formula, but also@ \ remove@ axioms@ and@ goals@ that@ become@ trivial." (** remove_trivial_quantification Original version in the alt-ergo prover by Sylvain Conchon *) (** transform \exists x. x == y /\ F into F[y/x] *) (** transform \forall x. x <> y \/ F into F[y/x] *) (** test if the freevariable of a term are included in a given set *) let t_boundvars_in fvars t = try t_v_fold (fun () u -> if Svs.mem u fvars then raise Exit) () t; false with Exit -> true exception Subst_found of term let rec fmla_find_subst boundvars var sign f = let fnF = fmla_find_subst boundvars var in let test ls vs t tv = sign && ls_equal ls ps_equ && vs_equal vs var && not (t_equal t tv) && not (t_boundvars_in boundvars t) in match f.t_node with | Tapp (ls,[{t_node=Tvar vs} as tv;t]) when test ls vs t tv -> raise (Subst_found t) | Tapp (ls,[t;{t_node=Tvar vs} as tv]) when test ls vs t tv -> raise (Subst_found t) | Tbinop (Tor, f1, f2) when not sign -> (fnF sign f1); (fnF sign f2) | Tbinop (Tand, f1, f2) when sign -> (fnF sign f1); (fnF sign f2) | Tbinop (Timplies, f1, f2) when not sign -> (fnF (not sign) f1); (fnF sign f2) | Tnot f1 -> fnF (not sign) f1 | Tquant (_,fb) -> let vsl,trl,f' = t_open_quant fb in if trl = [] then let boundvars = List.fold_left (fun s v -> Svs.add v s) boundvars vsl in fmla_find_subst boundvars var sign f' | Tlet (_,fb) -> let vs,f' = t_open_bound fb in let boundvars = Svs.add vs boundvars in fmla_find_subst boundvars var sign f' | Tbinop (_, _, _) | Tif ( _, _, _) | Tcase (_, _) | Tapp _ | Tfalse | Ttrue -> () | Tvar _ | Tconst _ | Teps _ -> raise (FmlaExpected f) (* Simplify out equalities that could be selected. *) let rec equ_simp f = t_label_copy f (match f.t_node with | Tbinop (op, f1, f2) -> begin match op, equ_simp f1, equ_simp f2 with | Tor, { t_node = Tfalse }, f | Tor, f, { t_node = Tfalse } | Tand, { t_node = Ttrue }, f | Tand, f, { t_node = Ttrue } | Timplies, { t_node = Ttrue }, f -> f | op, f1, f2 -> t_binary op f1 f2 end | Tapp (p,[f1;f2]) when ls_equal p ps_equ -> t_equ_simp (equ_simp f1) (equ_simp f2) | _ -> t_map equ_simp f) let rec fmla_quant sign f = function | [] -> [], f | vs::l -> let vsl, f = fmla_quant sign f l in try fmla_find_subst (Svs.singleton vs) vs sign f; vs::vsl, f with Subst_found t -> let f = t_subst_single vs t f in vsl, equ_simp f let rec fmla_remove_quant f = match f.t_node with | Tquant (k,fb) -> let vsl,trl,f',close = t_open_quant_cb fb in if trl <> [] then f else let sign = match k with | Tforall -> false | Texists -> true in let vsl, f' = fmla_quant sign f' vsl in let f' = fmla_remove_quant f' in t_quant k (close vsl [] f') | _ -> Term.t_map fmla_remove_quant f (*let fmla_remove_quant f = Format.eprintf "@[%a =>|@\n" Pretty.print_fmla f; let f = fmla_remove_quant f in Format.eprintf "|=>%a@]@.@." Pretty.print_fmla f; Pretty.forget_all (); f *) let simplify_trivial_quantification = Trans.rewrite fmla_remove_quant None let () = Trans.register_transform "simplify_trivial_quantification" simplify_trivial_quantification ~desc:"@[Simplify@ trivial@ quantifications:@]@\n \ @[\ - @[transform \\exists x. x == y /\\ F@ into F[y/x],@]@\n\ - @[transform \\forall x. x <> y \\/ F@ into F[y/x].@]@]" let simplify_trivial_quantification_in_goal = Trans.goal (fun pr f -> [create_prop_decl Pgoal pr (fmla_remove_quant f)]) let () = Trans.register_transform "simplify_trivial_quantification_in_goal" simplify_trivial_quantification_in_goal ~desc:"Same@ as@ simplify_trivial_quantification, but@ only@ in@ goals." (** linearize all the subformulas with the given connector (conj/disj); the returned array also contains the sign of each subformula *) let fmla_flatten conj f = let terms = ref [] in let rec aux sign f = match f.t_node with | Tnot f -> aux (not sign) f | Tbinop (Tor, f1, f2) when sign <> conj -> aux sign f2; aux sign f1 | Tbinop (Tand, f1, f2) when sign = conj -> aux sign f2; aux sign f1 | Tbinop (Timplies, f1, f2) when sign <> conj -> aux sign f2; aux (not sign) f1 | _ -> terms := (f, sign)::!terms in aux true f; Array.of_list !terms (** recreate the structure of a given formula with linearized subformulas *) let fmla_unflatten conj f formulas = let i = ref 0 in let rec aux sign f = t_label_copy f (match f.t_node with | Tnot f -> t_not (aux (not sign) f) | Tbinop (Tor, f1, f2) when sign <> conj -> let f1' = aux sign f1 in t_or f1' (aux sign f2) | Tbinop (Tand, f1, f2) when sign = conj -> let f1' = aux sign f1 in t_and f1' (aux sign f2) | Tbinop (Timplies, f1, f2) when sign <> conj -> let f1' = aux (not sign) f1 in t_implies f1' (aux sign f2) | _ -> let (t, s) = formulas.(!i) in assert (sign = s); incr i; t) in aux true f (** substitute all the terms that appear as a side of an equality/disequality and that match the given filter equal terms can be substituted in all the terms of surrounding conjunctions, while disequal terms can be substituted in all the terms of surrounding disjunctions substitutions are not exported outside quantifiers (even if their free variables are untouched), so the transformation is possibly incomplete (but still correct) on formulas that have inner quantifiers *) let fmla_cond_subst filter f = let rec aux f = match f.t_node with | Tbinop (o, _, _) when o <> Tiff -> let conj = match o with Tand -> true | Tor | Timplies -> false | Tiff -> assert false in let subf = fmla_flatten conj f in let subl = Array.length subf in for i = 0 to subl - 1 do let (f, s) = subf.(i) in subf.(i) <- (aux f, s); done; for i = 0 to subl - 1 do let do_subst t1 t2 = for j = 0 to subl - 1 do if j <> i then let (f, s) = subf.(j) in subf.(j) <- (t_replace t1 t2 f, s); done in let (f, s) = subf.(i) in match f.t_node with | Tapp (ls,[t1;t2]) when ls_equal ls ps_equ && s = conj -> if filter t1 t2 then do_subst t1 t2 else if filter t2 t1 then do_subst t2 t1 | _ -> () done; fmla_unflatten conj f subf | _ -> t_map aux f in aux f why3-0.88.3/src/transform/filter_trigger.mli0000664000175100017510000000130713225666037021572 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) why3-0.88.3/src/transform/eval_match.ml0000664000175100017510000002024213225666037020513 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Ident open Ty open Term open Decl type inline = known_map -> lsymbol -> ty list -> ty option -> bool let unfold def tl ty = let vl, e = open_ls_defn def in let add (mt,mv) x y = ty_match mt x.vs_ty (t_type y), Mvs.add x y mv in let (mt,mv) = List.fold_left2 add (Mtv.empty, Mvs.empty) vl tl in let mt = oty_match mt e.t_ty ty in t_ty_subst mt mv e let is_constructor kn ls = match Mid.find ls.ls_name kn with | { d_node = Ddata dl } -> let constr (_,csl) = List.exists (fun (cs,_) -> ls_equal cs ls) csl in List.exists constr dl | _ -> false let is_projection kn ls = match Mid.find ls.ls_name kn with | { d_node = Ddata dl } -> let constr (_,csl) = List.exists (fun (cs,_) -> ls_equal cs ls) csl in not (List.exists constr dl) | _ -> false let apply_projection kn ls t = match t.t_node with | Tapp (cs,tl) -> let ts = match cs.ls_value with | Some { ty_node = Tyapp (ts,_) } -> ts | _ -> assert false in let pjl = try List.assq cs (find_constructors kn ts) with Not_found -> assert false in let find acc v = function | Some pj when ls_equal pj ls -> v | _ -> acc in List.fold_left2 find t_true tl pjl | _ -> assert false let flat_case t bl = let mk_b b = let p,t = t_open_branch b in [p],t in let mk_case = t_case_close and mk_let = t_let_close_simp in Pattern.compile_bare ~mk_case ~mk_let [t] (List.map mk_b bl) let rec add_quant kn (vl,tl,f) v = let ty = v.vs_ty in let cl = match ty.ty_node with | Tyapp (ts, _) -> find_constructors kn ts | _ -> [] in match cl with | [ls,pjl] -> (* there is only one constructor *) let s = ty_match Mtv.empty (Opt.get ls.ls_value) ty in let mk_v ty pj = (* The name of the field corresponding to the variable that is created *) let field_name = (match pj with | Some pj_ls -> begin try Ident.get_model_trace_string ~labels:pj_ls.ls_name.id_label with Not_found -> "."^pj_ls.ls_name.id_string end | _ -> "" ) in let label = if field_name = "@hide_field" then Ident.remove_model_labels ~labels:v.vs_name.id_label else Ident.append_to_model_element_name ~labels:v.vs_name.id_label ~to_append:(field_name) in create_vsymbol (id_lab label v.vs_name) (ty_inst s ty) in let nvl = List.map2 mk_v ls.ls_args pjl in let t = fs_app ls (List.map t_var nvl) ty in let f = t_let_close_simp v t f in let tl = tr_map (t_subst_single v t) tl in (* in case any of the fields is also a record, we recurse over the new variables. *) List.fold_left (add_quant kn) (vl,tl,f) nvl | _ -> (* zero or more than one constructor *) (v::vl, tl, f) let let_map fn env t1 tb = let x,t2,close = t_open_bound_cb tb in let t2 = fn (Mvs.add x t1 env) t2 in t_let_simp t1 (close x t2) let branch_map fn env t1 bl = let mk_b b = let p,t2,close = t_open_branch_cb b in close p (fn env t2) in t_case t1 (List.map mk_b bl) let dive_to_constructor kn fn env t = let rec dive env t = t_label_copy t (match t.t_node with | Tvar x -> dive env (Mvs.find_exn Exit x env) | Tlet (t1,tb) -> let_map dive env t1 tb | Tcase (t1,bl) -> branch_map dive env t1 bl | Tif (f,t1,t2) -> t_if_simp f (dive env t1) (dive env t2) | Tapp (ls,_) when is_constructor kn ls -> fn env t | _ -> raise Exit) in dive env t let rec cs_equ kn env t1 t2 = if t_equal t1 t2 then t_true else let aux cs tl t = let fn = apply_cs_equ kn cs tl in try dive_to_constructor kn fn env t with Exit -> t_equ t1 t2 in match t1,t2 with (* cannot merge the 2 patterns because of warning 57 *) | { t_node = Tapp (cs,tl) }, t when is_constructor kn cs -> aux cs tl t | t, { t_node = Tapp (cs,tl) } when is_constructor kn cs -> aux cs tl t | _ -> t_equ t1 t2 and apply_cs_equ kn cs1 tl1 env t = match t.t_node with | Tapp (cs2,tl2) when ls_equal cs1 cs2 -> let merge t1 t2 f = t_and_simp (cs_equ kn env t1 t2) f in List.fold_right2 merge tl1 tl2 t_true | Tapp _ -> t_false | _ -> assert false let eval_match ~inline kn t = let rec eval stop env t = let stop = stop || Slab.mem Split_goal.stop_split t.t_label || Slab.mem keep_on_simp_label t.t_label in let eval = eval stop in let t_eval_matched = (match t.t_node with | Tapp (ls, [t1;t2]) when ls_equal ls ps_equ -> cs_equ kn env (eval env t1) (eval env t2) | Tapp (ls, [t1]) when is_projection kn ls -> let t1 = eval env t1 in let fn _env t = apply_projection kn ls t in begin try dive_to_constructor kn fn env t1 with Exit -> t_app ls [t1] t.t_ty end | Tapp (ls, tl) when inline kn ls (List.map t_type tl) t.t_ty -> begin match find_logic_definition kn ls with | None -> t_map (eval env) t | Some def -> eval env (unfold def tl t.t_ty) end | Tlet (t1, tb2) -> let t1 = eval env t1 in let_map eval env t1 tb2 | Tcase (t1, bl1) -> let t1 = eval env t1 in let fn env t2 = eval env (Loc.try2 ?loc:t.t_loc flat_case t2 bl1) in begin try dive_to_constructor kn fn env t1 with Exit -> branch_map eval env t1 bl1 end | Tquant (q, qf) -> let vl,tl,f,close = t_open_quant_cb qf in let vl,tl,f = if stop then (List.rev vl,tl,f) else List.fold_left (add_quant kn) ([],tl,f) vl in t_quant_simp q (close (List.rev vl) tl (eval env f)) | _ -> t_map_simp (eval env) t) in (* Copy all labels of t to t_eval_matched except for "model_trace:*" label. This label is not copied if both t and t_eval_matched contain it. *) let t = (try let _ = Ident.get_model_trace_label ~labels:t_eval_matched.t_label in let original_mt_label = Ident.get_model_trace_label ~labels:t.t_label in (* If both t_eval_matched and t contain model_trace label, remove it *) t_label_remove original_mt_label t with Not_found -> t) in t_label_copy t t_eval_matched in eval false Mvs.empty t let rec linear vars t = match t.t_node with | Tvar x -> Svs.add_new Exit x vars | Tif _ | Teps _ -> raise Exit | _ -> t_fold linear vars t let linear t = try ignore (linear Svs.empty t); true with Exit -> false let is_algebraic_type kn ty = match ty.ty_node with | Tyapp (ts, _) -> find_constructors kn ts <> [] | Tyvar _ -> false (* The following memoization by function definition is unsafe, since the same definition can be used in different contexts. If we could produce the record updates {| x with field = v |} that were linear (by eliminating occurrences of x.field in v), inline_nonrec_linear might not call eval_match at all and so be independent of the context. FIXME/TODO *) let inline_cache = Wdecl.create 17 let rec inline_nonrec_linear kn ls tyl ty = (* at least one actual parameter (or the result) has an algebraic type *) List.exists (is_algebraic_type kn) (oty_cons tyl ty) && (* and ls is not recursively defined and is linear *) let d = Mid.find ls.ls_name kn in if Mid.mem ls.ls_name d.d_syms then false else match d.d_node with | Dlogic [_,def] -> begin try Wdecl.find inline_cache d with Not_found -> let vl,t = open_ls_defn def in let _,_,t = List.fold_left (add_quant kn) ([],[],t) vl in let t = eval_match ~inline:inline_nonrec_linear kn t in let res = linear t in Wdecl.set inline_cache d res; res end | _ -> false why3-0.88.3/src/transform/encoding_guards.ml0000664000175100017510000001422713225666037021551 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** transformation from polymorphic logic to many-sorted logic *) (** an implementation of "featherweight guards" encoding g?? from Blanchette et al., Encoding monomorphic and polymorphic types, TACAS 2013, LNCS 7795, pp. 493–507 *) open Ident open Ty open Term open Decl open Libencoding type info = { kept : Sty.t; (* ground types to preserve *) infts : Sts.t; (* infinite type constructors *) margs : bool list Mts.t; (* material type arguments *) varm : term Mtv.t; (* tyvar-to-variable mapping *) polar : bool; (* polarity is known *) } let mk_info kept infts margs = { kept = kept; infts = infts; margs = margs; varm = Mtv.empty; polar = true; } let is_infinite_ty info ty = Eliminate_algebraic.is_infinite_ty info.infts info.margs ty let ps_sort = let tv = ty_var (create_tvsymbol (id_fresh "a")) in create_psymbol (id_fresh "sort") [tv] (* add to [svs] each variable that [t] may be equal to *) let rec collect svs t = match t.t_node with | Tvar v -> Svs.add v svs | Tapp _ | Tconst _ -> svs | Tif (_,t1,t2) -> collect (collect svs t1) t2 | Tlet (t1, b) -> let s = collect Svs.empty t1 in let u,t2 = t_open_bound b in let svs = collect svs t2 in if Svs.mem u svs then Svs.union s (Svs.remove u svs) else svs | _ -> assert false (* match and epsilon gone, the rest is prop *) let rec expl_term info svs sign t = match t.t_node with | Tapp (ls,tl) when not (ls_equal ls ps_equ) -> let tv_to_ty = ls_app_inst ls tl t.t_ty in let tl = List.map (expl_term info svs sign) tl in let add _ ty tl = term_of_ty info.varm ty :: tl in let tl = Mtv.fold add tv_to_ty tl in t_label_copy t (t_app (ls_extend ls) tl t.t_ty) | Tapp (ls,[t1;t2]) when (not info.polar || sign) && ls_equal ls ps_equ -> svs := collect (collect !svs t1) t2; let t1 = expl_term info svs sign t1 in let t2 = expl_term info svs sign t2 in t_label_copy t (t_equ t1 t2) | Tlet (t1, b) -> let s = collect Svs.empty t1 in let u,t2,close = t_open_bound_cb b in let t1 = expl_term info svs sign t1 in let t2 = expl_term info svs sign t2 in if Svs.mem u !svs then svs := Svs.union s (Svs.remove u !svs); t_label_copy t (t_let t1 (close u t2)) | Tquant (q, b) -> let vl,tl,f1,close = t_open_quant_cb b in let tl = tr_map (expl_term info svs sign) tl in let f1 = expl_term info svs sign f1 in let guard v f = let skip = is_protected_vs info.kept v || (info.polar && sign = (q = Tforall) && (not (Svs.mem v !svs) || is_infinite_ty info v.vs_ty)) in svs := Svs.remove v !svs; if skip then f else let g = ps_app ps_sort [t_var v] in let g = expl_term info svs sign g in (if q = Tforall then t_implies else t_and) g f in let f1 = List.fold_right guard vl f1 in t_label_copy t (t_quant q (close vl tl f1)) | Tif (f1,t1,t2) when t.t_ty <> None -> let f1 = expl_term { info with polar = false } svs sign f1 in let t1 = expl_term info svs sign t1 in let t2 = expl_term info svs sign t2 in t_label_copy t (t_if f1 t1 t2) | _ -> t_map_sign (expl_term info svs) sign t let expl_term info sign varM t = expl_term { info with varm = varM } (ref Svs.empty) sign t (** {2 main part} *) let ls_desc info ls = if ls.ls_value = None || is_protected_ls info.kept ls then [] else let vl = List.map (create_vsymbol (id_fresh "x")) ls.ls_args in let t = t_app ls (List.map t_var vl) ls.ls_value in let f = t_forall_close vl [] (ps_app ps_sort [t]) in let pr = create_prsymbol (id_fresh (ls.ls_name.id_string ^ "_sort")) in [create_prop_decl Paxiom pr (t_type_close (expl_term info true) f)] let decl info d = match d.d_node with | Dtype { ts_def = Alias _ } -> [] | Dtype ts -> [d; lsdecl_of_ts ts] | Ddata _ -> Printer.unsupportedDecl d "Algebraic types are not supported, run eliminate_algebraic" | Dparam ls -> [create_param_decl (ls_extend ls)] @ ls_desc info ls | Dlogic [ls,ld] when not (Sid.mem ls.ls_name d.d_syms) -> let f = t_type_close (expl_term info true) (ls_defn_axiom ld) in defn_or_axiom (ls_extend ls) f @ ls_desc info ls | Dlogic _ -> Printer.unsupportedDecl d "Recursively-defined symbols are not supported, run eliminate_recursion" | Dind _ -> Printer.unsupportedDecl d "Inductive predicates are not supported, run eliminate_inductive" | Dprop (k,pr,f) -> let sign = (k <> Pgoal) in [create_prop_decl k pr (t_type_close (expl_term info sign) f)] let d_witness = let tv = ty_var (create_tvsymbol (id_fresh "a")) in let fs_wit = create_fsymbol (id_fresh "witness") [] tv in let dummy_info = mk_info Sty.empty Sts.empty Mts.empty in decl dummy_info (create_param_decl fs_wit) let expl_init = let init = Task.add_decl None d_ts_type in let init = Task.add_param_decl init ps_equ in let init = Task.add_param_decl init (ls_extend ps_sort) in let init = List.fold_left Task.add_decl init d_witness in init let guards = Trans.on_tagged_ty Libencoding.meta_kept (fun kept -> Trans.on_tagged_ts Eliminate_algebraic.meta_infinite (fun infts -> Trans.on_meta Eliminate_algebraic.meta_material (fun matl -> let margs = Eliminate_algebraic.get_material_args matl in let info = mk_info kept infts margs in Trans.decl (decl info) expl_init))) let () = Stdlib.Hstr.replace Encoding.ft_enco_poly "guards" (fun _ -> Trans.compose guards monomorphise_task) why3-0.88.3/src/transform/eliminate_let.mli0000664000175100017510000000155313225666037021400 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** eliminate let *) val eliminate_let_term : Task.task Trans.trans val eliminate_let_fmla : Task.task Trans.trans val eliminate_let : Task.task Trans.trans why3-0.88.3/src/transform/prepare_for_counterexmp.mli0000664000175100017510000000207113225666037023516 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) val get_counterexmp : Task.task -> bool (** Returns true if counter-example should be get for the task. *) val prepare_for_counterexmp : Env.env -> Task.task Trans.trans (** Transformation that prepares the task for querying for the counter-example model. This transformation does so only when the solver will be asked for the counter-example. *) why3-0.88.3/src/transform/induction.mli0000664000175100017510000000130713225666037020556 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) why3-0.88.3/src/transform/encoding_sort.mli0000664000175100017510000000130713225666037021417 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) why3-0.88.3/src/transform/eliminate_inductive.ml0000664000175100017510000000446713225666037022444 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Ident open Term open Decl let log acc (ps,_) = create_param_decl ps :: acc let axm acc (pr,f) = create_prop_decl Paxiom pr f :: acc let imp acc (_,al) = List.fold_left axm acc al let exi vl (_,f) = let rec descend f = match f.t_node with | Tquant (Tforall,f) -> let vl,tl,f = t_open_quant f in t_exists_close vl tl (descend f) | Tbinop (Timplies,g,f) -> t_and g (descend f) | Tapp (_,tl) -> let marry acc v t = t_and_simp acc (t_equ v t) in List.fold_left2 marry t_true vl tl | Tlet (t, tb) -> let v, f = t_open_bound tb in t_let_close v t (descend f) | _ -> assert false (* ensured by Decl.create_ind_decl *) in descend f let inv acc (ps,al) = let vl = List.map (create_vsymbol (id_fresh "z")) ps.ls_args in let tl = List.map t_var vl in let hd = ps_app ps tl in let dj = Lists.map_join_left (exi tl) t_or al in let hsdj = Simplify_formula.fmla_remove_quant (t_implies hd dj) in let ax = t_forall_close vl [] hsdj in let nm = id_derive (ps.ls_name.id_string ^ "_inversion") ps.ls_name in create_prop_decl Paxiom (create_prsymbol nm) ax :: acc let elim d = match d.d_node with | Dind (_, il) -> let dl = List.fold_left log [] il in let dl = List.fold_left imp dl il in let dl = List.fold_left inv dl il in List.rev dl | _ -> [d] let eliminate_inductive = Trans.decl elim None let () = Trans.register_transform "eliminate_inductive" eliminate_inductive ~desc:"Replace@ inductive@ predicates@ by@ (incomplete)@ axiomatic@ \ definitions,@ i.e.@ construction@ axioms@ and@ an@ inversion@ axiom." why3-0.88.3/src/transform/encoding_tags.ml0000664000175100017510000001427613225666037021226 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** transformation from polymorphic logic to many-sorted logic *) (** an implementation of "featherweight tags" encoding t?? from Blanchette et al., Encoding monomorphic and polymorphic types, TACAS 2013, LNCS 7795, pp. 493–507 *) open Ident open Ty open Term open Decl open Libencoding type info = { kept : Sty.t; (* ground types to preserve *) infts : Sts.t; (* infinite type constructors *) margs : bool list Mts.t; (* material type arguments *) varm : term Mtv.t; (* tyvar-to-variable mapping *) polar : bool; (* polarity is known *) } let mk_info kept infts margs = { kept = kept; infts = infts; margs = margs; varm = Mtv.empty; polar = true; } let is_infinite_ty info ty = Eliminate_algebraic.is_infinite_ty info.infts info.margs ty let fs_sort = let tv = ty_var (create_tvsymbol (id_fresh "a")) in create_fsymbol (id_fresh "sort") [tv] tv (* detect if [t] may be equal to a variable in [svs] *) let rec detect svs t = match t.t_node with | Tvar v -> Svs.mem v svs | Tapp _ | Tconst _ -> false | Tif (_,t1,t2) -> detect svs t1 || detect svs t2 | Tlet (t1, b) -> let s = detect svs t1 in let u,t2 = t_open_bound b in let svs = if s then Svs.add u svs else svs in detect svs t2 | _ -> assert false (* match and epsilon gone, the rest is prop *) let rec expl_term info svs sign t = match t.t_node with | Tapp (ls,tl) when not (ls_equal ls ps_equ) -> let tv_to_ty = ls_app_inst ls tl t.t_ty in let tl = List.map (expl_term info svs sign) tl in let add _ ty tl = term_of_ty info.varm ty :: tl in let tl = Mtv.fold add tv_to_ty tl in t_label_copy t (t_app (ls_extend ls) tl t.t_ty) | Tapp (ls,[t1;t2]) when (not info.polar || sign) && ls_equal ls ps_equ -> let t1 = if detect svs t1 then t_app fs_sort [t1] t1.t_ty else t1 in let t2 = if detect svs t2 then t_app fs_sort [t2] t2.t_ty else t2 in let t1 = expl_term info svs sign t1 in let t2 = expl_term info svs sign t2 in t_label_copy t (t_equ t1 t2) | Tlet (t1, b) -> let s = detect svs t1 in let u,t2,close = t_open_bound_cb b in let t1 = expl_term info svs sign t1 in let svs = if s then Svs.add u svs else svs in let t2 = expl_term info svs sign t2 in t_label_copy t (t_let t1 (close u t2)) | Tquant (q, b) -> let vl,tl,f1,close = t_open_quant_cb b in let add_vs v (f,svs) = if is_protected_vs info.kept v then f, svs else if info.polar && sign = (q = Tforall) then f, if is_infinite_ty info v.vs_ty then svs else Svs.add v svs else let g = t_equ (fs_app fs_sort [t_var v] v.vs_ty) (t_var v) in (if q = Tforall then t_implies else t_and) g f, svs in let f1, svs = List.fold_right add_vs vl (f1,svs) in let tl = tr_map (expl_term info svs sign) tl in let f1 = expl_term info svs sign f1 in t_label_copy t (t_quant q (close vl tl f1)) | Tif (f1,t1,t2) when t.t_ty <> None -> let f1 = expl_term { info with polar = false } svs sign f1 in let t1 = expl_term info svs sign t1 in let t2 = expl_term info svs sign t2 in t_label_copy t (t_if f1 t1 t2) | _ -> t_map_sign (expl_term info svs) sign t let expl_term info sign varM t = expl_term { info with varm = varM } Svs.empty sign t (** {2 main part} *) let ls_desc info ls = if ls.ls_value = None || is_protected_ls info.kept ls then [] else let vl = List.map (create_vsymbol (id_fresh "x")) ls.ls_args in let t = t_app ls (List.map t_var vl) ls.ls_value in let f = t_forall_close vl [] (t_equ (t_app fs_sort [t] t.t_ty) t) in let pr = create_prsymbol (id_fresh (ls.ls_name.id_string ^ "_sort")) in [create_prop_decl Paxiom pr (t_type_close (expl_term info true) f)] let decl info d = match d.d_node with | Dtype { ts_def = Alias _ } -> [] | Dtype ts -> [d; lsdecl_of_ts ts] | Ddata _ -> Printer.unsupportedDecl d "Algebraic types are not supported, run eliminate_algebraic" | Dparam ls -> [create_param_decl (ls_extend ls)] @ ls_desc info ls | Dlogic [ls,ld] when not (Sid.mem ls.ls_name d.d_syms) -> let f = t_type_close (expl_term info true) (ls_defn_axiom ld) in defn_or_axiom (ls_extend ls) f @ ls_desc info ls | Dlogic _ -> Printer.unsupportedDecl d "Recursively-defined symbols are not supported, run eliminate_recursion" | Dind _ -> Printer.unsupportedDecl d "Inductive predicates are not supported, run eliminate_inductive" | Dprop (k,pr,f) -> let sign = (k <> Pgoal) in [create_prop_decl k pr (t_type_close (expl_term info sign) f)] let d_witness = let tv = ty_var (create_tvsymbol (id_fresh "a")) in let fs_wit = create_fsymbol (id_fresh "witness") [] tv in let dummy_info = mk_info Sty.empty Sts.empty Mts.empty in decl dummy_info (create_param_decl fs_wit) let expl_init = let init = Task.add_decl None d_ts_type in let init = Task.add_param_decl init ps_equ in let init = Task.add_param_decl init (ls_extend fs_sort) in let init = List.fold_left Task.add_decl init d_witness in init let tags = Trans.on_tagged_ty Libencoding.meta_kept (fun kept -> Trans.on_tagged_ts Eliminate_algebraic.meta_infinite (fun infts -> Trans.on_meta Eliminate_algebraic.meta_material (fun matl -> let margs = Eliminate_algebraic.get_material_args matl in let info = mk_info kept infts margs in Trans.decl (decl info) expl_init))) let () = Stdlib.Hstr.replace Encoding.ft_enco_poly "tags" (fun _ -> Trans.compose tags monomorphise_task) why3-0.88.3/src/transform/libencoding.ml0000664000175100017510000002421713225666037020673 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Ident open Ty open Term open Decl open Theory let debug = Debug.register_info_flag "encoding" ~desc:"Print@ debugging@ messages@ about@ polymorphism@ encoding." (* meta to tag the protected types *) let meta_kept = register_meta "encoding : kept" [MTty] ~desc:"Specify@ a@ type@ to@ keep@ during@ polymorphism@ encoding." (* meta to tag the custom base type *) let meta_base = register_meta_excl "encoding : base" [MTty] ~desc:"Specify@ the@ base@ type@ for@ monomorphic@ \ polymorphism@ encoding@ (`int'@ or@ `real'@ only)." (* sort symbol of the default base type *) let ts_base = create_tysymbol (id_fresh "uni") [] NoDef (* default base type *) let ty_base = ty_app ts_base [] (* ts_base declaration *) let d_ts_base = create_ty_decl ts_base (* sort symbol of (polymorphic) types *) let ts_type = create_tysymbol (id_fresh "ty") [] NoDef (* sort of (polymorphic) types *) let ty_type = ty_app ts_type [] (* ts_type declaration *) let d_ts_type = create_ty_decl ts_type (* add type args to the signature of a polymorphic lsymbol *) let ls_extend = Wls.memoize 63 (fun ls -> if ls_equal ls ps_equ then ls else let tvs = ls_ty_freevars ls in if Stv.is_empty tvs then ls else let args = Stv.fold (fun _ l -> ty_type::l) tvs ls.ls_args in Term.create_lsymbol (id_clone ls.ls_name) args ls.ls_value) (* function symbol mapping ty_type^n to ty_type *) let ls_of_ts = Wts.memoize 63 (fun ts -> let args = List.map (Util.const ty_type) ts.ts_args in create_fsymbol (id_clone ts.ts_name) args ty_type) (* convert a type to a term of type ty_type *) let rec term_of_ty tvmap ty = match ty.ty_node with | Tyvar tv -> Mtv.find tv tvmap | Tyapp (ts,tl) -> fs_app (ls_of_ts ts) (List.map (term_of_ty tvmap) tl) ty_type (* rewrite a closed formula modulo its free typevars *) let type_close tvs fn f = let get_vs tv = create_vsymbol (id_clone tv.tv_name) ty_type in let tvm = Mtv.mapi (fun v () -> get_vs v) tvs in let vl = Mtv.values tvm in let tvm = Mtv.map t_var tvm in t_forall_close_simp vl [] (fn tvm f) let t_type_close fn f = let tvs = t_ty_freevars Stv.empty f in type_close tvs fn f (* convert a type declaration to a list of lsymbol declarations *) let lsdecl_of_ts ts = create_param_decl (ls_of_ts ts) (* convert a constant to a functional symbol of type ty_base *) let ls_of_const = Hty.memo 3 (fun ty_base -> Hterm.memo 63 (fun t -> match t.t_node with | Tconst _ -> let s = "const_" ^ Pp.string_of_wnl Pretty.print_term t in create_fsymbol (id_fresh s) [] ty_base | _ -> assert false)) let ls_of_const ty_base t = ls_of_const ty_base (t_label Slab.empty t) (* unprotected and unprotecting idents *) let unprotected_label = Ident.create_label "encoding : unprotected" let unprotecting_label = Ident.create_label "encoding : unprotecting" let id_unprotected n = id_fresh ~label:(Slab.singleton unprotected_label) n let id_unprotecting n = id_fresh ~label:(Slab.singleton unprotecting_label) n let is_protected_id id = not (Slab.mem unprotected_label id.id_label) let is_protecting_id id = not (Slab.mem unprotecting_label id.id_label) let is_protected_vs kept vs = is_protected_id vs.vs_name && Sty.mem vs.vs_ty kept let is_protected_ls kept ls = is_protected_id ls.ls_name && Sty.mem (Opt.get ls.ls_value) kept (* monomorphise modulo the set of kept types * and an lsymbol map *) let vs_monomorph ty_base kept vs = if ty_equal vs.vs_ty ty_base || is_protected_vs kept vs then vs else create_vsymbol (id_clone vs.vs_name) ty_base let t_monomorph ty_base kept lsmap consts vmap t = let rec t_mono vmap t = t_label_copy t (match t.t_node with | Tvar v -> Mvs.find v vmap | Tconst _ when ty_equal (t_type t) ty_base || Sty.mem (t_type t) kept -> t | Tconst _ -> let ls = ls_of_const ty_base t in consts := Sls.add ls !consts; fs_app ls [] ty_base | Tapp (ps,[t1;t2]) when ls_equal ps ps_equ -> t_equ (t_mono vmap t1) (t_mono vmap t2) | Tapp (ls,tl) -> let ls = lsmap ls in t_app ls (List.map (t_mono vmap) tl) ls.ls_value | Tif (f,t1,t2) -> t_if (t_mono vmap f) (t_mono vmap t1) (t_mono vmap t2) | Tlet (t1,b) -> let u,t2,close = t_open_bound_cb b in let v = vs_monomorph ty_base kept u in let t2 = t_mono (Mvs.add u (t_var v) vmap) t2 in t_let (t_mono vmap t1) (close v t2) | Tcase _ -> Printer.unsupportedTerm t "no match expressions at this point" | Teps b -> let u,f,close = t_open_bound_cb b in let v = vs_monomorph ty_base kept u in let f = t_mono (Mvs.add u (t_var v) vmap) f in t_eps (close v f) | Tquant (q,b) -> let ul,tl,f1,close = t_open_quant_cb b in let vl = List.map (vs_monomorph ty_base kept) ul in let add acc u v = Mvs.add u (t_var v) acc in let vmap = List.fold_left2 add vmap ul vl in let tl = tr_map (t_mono vmap) tl in t_quant q (close vl tl (t_mono vmap f1)) | Tbinop (op,f1,f2) -> t_binary op (t_mono vmap f1) (t_mono vmap f2) | Tnot f1 -> t_not (t_mono vmap f1) | Ttrue | Tfalse -> t) in t_mono vmap t let d_monomorph ty_base kept lsmap d = let consts = ref Sls.empty in let t_mono = t_monomorph ty_base kept lsmap consts in let dl = match d.d_node with | Dtype { ts_def = Alias _ } -> [] | Dtype ts when not (Sty.exists (ty_s_any (ts_equal ts)) kept) -> [] | Dtype ts -> [create_ty_decl ts] | Ddata _ -> Printer.unsupportedDecl d "no algebraic types at this point" | Dparam ls -> let ls = if ls_equal ls ps_equ then ls else lsmap ls in [create_param_decl ls] | Dlogic ldl -> let conv (ls,ld) = let ls = if ls_equal ls ps_equ then ls else lsmap ls in let ul,e,close = open_ls_defn_cb ld in let vl = List.map (vs_monomorph ty_base kept) ul in let add acc u v = Mvs.add u (t_var v) acc in let vmap = List.fold_left2 add Mvs.empty ul vl in close ls vl (t_mono vmap e) in [create_logic_decl (List.map conv ldl)] | Dind (s, idl) -> let iconv (pr,f) = pr, t_mono Mvs.empty f in let conv (ls,il) = lsmap ls, List.map iconv il in [create_ind_decl s (List.map conv idl)] | Dprop (k,pr,f) -> [create_prop_decl k pr (t_mono Mvs.empty f)] in let add ls acc = create_param_decl ls :: acc in Sls.fold add !consts dl module OHTyl = Stdlib.OrderedHashedList(struct type t = ty let tag = ty_hash end) module Mtyl = Extmap.Make(OHTyl) let ls_inst = (* FIXME? Skolem type constants are short-living but will stay in lsmap as long as the lsymbol is alive *) let lsmap = Wls.memoize 63 (fun _ -> ref Mtyl.empty) in fun ls tyl tyv -> let m = lsmap ls in let l = oty_cons tyl tyv in match Mtyl.find_opt l !m with | Some ls -> ls | None -> let nls = create_lsymbol (id_clone ls.ls_name) tyl tyv in m := Mtyl.add l nls !m; nls let lsmap ty_base kept = Hls.memo 63 (fun ls -> let prot_arg = is_protecting_id ls.ls_name in let prot_val = is_protected_id ls.ls_name in let neg ty = if prot_arg && Sty.mem ty kept then ty else ty_base in let pos ty = if prot_val && Sty.mem ty kept then ty else ty_base in let ty_arg = List.map neg ls.ls_args in let ty_res = Opt.map pos ls.ls_value in if Opt.equal ty_equal ty_res ls.ls_value && List.for_all2 ty_equal ty_arg ls.ls_args then ls else ls_inst ls ty_arg ty_res) (* replace all non-kept types with ty_base *) let monomorphise_task = Trans.on_meta_excl meta_base (fun base -> let ty_base, d_ts_base = match base with | Some [MAty ({ty_node = Tyapp (ts,[])} as ty)] when ts_equal ts ts_int || ts_equal ts ts_real -> ty, create_ty_decl ts | Some [MAty _] -> Loc.errorm "the \"enconding : base\" meta can only apply to `int' or `real'" | Some _ -> assert false | None -> ty_base, d_ts_base in Trans.on_tagged_ty meta_kept (fun kept -> let kept = Sty.add ty_type kept in let lsmap = lsmap ty_base kept in let decl = d_monomorph ty_base kept lsmap in Trans.decl decl (Task.add_decl None d_ts_base))) (* replace type variables in a goal with fresh type constants *) let ts_of_tv = Htv.memo 63 (fun tv -> create_tysymbol (id_clone tv.tv_name) [] NoDef) let monomorphise_goal = Trans.goal (fun pr f -> let stv = t_ty_freevars Stv.empty f in if Stv.is_empty stv then [create_prop_decl Pgoal pr f] else let mty,ltv = Stv.fold (fun tv (mty,ltv) -> let ts = ts_of_tv tv in Mtv.add tv (ty_app ts []) mty, ts::ltv) stv (Mtv.empty,[]) in let f = t_ty_subst mty Mvs.empty f in List.fold_left (fun acc ts -> create_ty_decl ts :: acc) [create_prop_decl Pgoal pr f] ltv) (* close by subtype the set of types tagged by meta_kept *) let close_kept = Trans.on_tagged_ty meta_kept (fun kept -> let rec add acc ty = ty_fold add (Sty.add ty acc) ty in let kept' = Sty.fold (Util.flip add) kept kept in if kept == kept' then Trans.identity else let kept' = Sty.diff kept' kept in let fold ty acc = create_meta meta_kept [MAty ty] :: acc in Trans.add_tdecls (Sty.fold fold kept' [])) (* reconstruct a definition of an lsymbol or make a defining axiom *) let defn_or_axiom ls f = match Decl.ls_defn_of_axiom f with | Some ld -> [create_logic_decl [ld]] | None -> let nm = ls.ls_name.id_string ^ "_def" in let pr = create_prsymbol (id_derive nm ls.ls_name) in [create_param_decl ls; create_prop_decl Paxiom pr f] why3-0.88.3/src/transform/encoding_guards_full.mli0000664000175100017510000000130713225666037022737 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) why3-0.88.3/src/transform/reduction_engine.ml0000664000175100017510000007626013225666037021744 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Term (* {2 Values} *) type value = | Term of term (* invariant: is in normal form *) | Int of BigInt.t let v_label_copy orig v = match v with | Int _ -> v | Term t -> Term (t_label_copy orig t) let const_of_positive n = t_const (Number.ConstInt (Number.int_const_dec (BigInt.to_string n))) Ty.ty_int let ls_minus = ref ps_equ (* temporary *) let const_of_big_int n = if BigInt.ge n BigInt.zero then const_of_positive n else let t = const_of_positive (BigInt.minus n) in t_app_infer !ls_minus [t] let term_of_value v = match v with | Term t -> t | Int n -> const_of_big_int n exception NotNum let big_int_of_const c = match c with | Number.ConstInt i -> Number.compute_int i | _ -> raise NotNum let big_int_of_value v = match v with | Int n -> n | Term { t_node = Tconst c } -> big_int_of_const c | Term { t_node = Tapp (ls,[{ t_node = Tconst c }]) } when ls_compare ls !ls_minus = 0 -> BigInt.minus (big_int_of_const c) | _ -> raise NotNum (* {2 Builtin symbols} *) let builtins = Hls.create 17 (* all builtin functions *) exception Undetermined let to_bool b = if b then t_true else t_false let _t_app_value ls l ty = Term (t_app ls (List.map term_of_value l) ty) let is_zero v = try BigInt.eq (big_int_of_value v) BigInt.zero with NotNum -> false let is_one v = try BigInt.eq (big_int_of_value v) BigInt.one with NotNum -> false let eval_int_op op simpl ls l ty = match l with | [t1 ; t2] -> begin try let n1 = big_int_of_value t1 in let n2 = big_int_of_value t2 in Int (op n1 n2) with NotNum | Division_by_zero -> simpl ls t1 t2 ty end | _ -> assert false (* t_app_value ls l ty *) (* unused anymore, for the moment let simpl_none ls t1 t2 ty = t_app_value ls [t1;t2] ty *) let simpl_add _ls t1 t2 _ty = if is_zero t1 then t2 else if is_zero t2 then t1 else raise Undetermined (* t_app_value ls [t1;t2] ty *) let simpl_sub _ls t1 t2 _ty = if is_zero t2 then t1 else raise Undetermined (* t_app_value ls [t1;t2] ty *) let simpl_mul _ls t1 t2 _ty = if is_zero t1 then t1 else if is_zero t2 then t2 else if is_one t1 then t2 else if is_one t2 then t1 else raise Undetermined (* t_app_value ls [t1;t2] ty *) let simpl_divmod _ls t1 t2 _ty = if is_zero t1 then t1 else if is_one t2 then t1 else raise Undetermined (* t_app_value ls [t1;t2] ty *) let simpl_minmax _ls v1 v2 _ty = match v1,v2 with | Term t1, Term t2 -> if t_equal t1 t2 then v1 else raise Undetermined (* t_app_value ls [v1;v2] ty *) | _ -> raise Undetermined (* t_app_value ls [v1;v2] ty *) let eval_int_rel op _ls l _ty = match l with | [t1 ; t2] -> begin try let n1 = big_int_of_value t1 in let n2 = big_int_of_value t2 in Term (to_bool (op n1 n2)) with NotNum | Division_by_zero -> raise Undetermined (* t_app_value ls l ty *) end | _ -> assert false (* t_app_value ls l ty *) let eval_int_uop op _ls l _ty = match l with | [t1] -> begin try let n1 = big_int_of_value t1 in Int (op n1) with NotNum | Division_by_zero -> raise Undetermined (* t_app_value ls l ty *) end | _ -> assert false let built_in_theories = [ (* ["bool"],"Bool", [], [ "True", None, eval_true ; "False", None, eval_false ; ] ; *) ["int"],"Int", [], [ "infix +", None, eval_int_op BigInt.add simpl_add; "infix -", None, eval_int_op BigInt.sub simpl_sub; "infix *", None, eval_int_op BigInt.mul simpl_mul; "prefix -", Some ls_minus, eval_int_uop BigInt.minus; "infix <", None, eval_int_rel BigInt.lt; "infix <=", None, eval_int_rel BigInt.le; "infix >", None, eval_int_rel BigInt.gt; "infix >=", None, eval_int_rel BigInt.ge; ] ; ["int"],"MinMax", [], [ "min", None, eval_int_op BigInt.min simpl_minmax; "max", None, eval_int_op BigInt.max simpl_minmax; ] ; ["int"],"ComputerDivision", [], [ "div", None, eval_int_op BigInt.computer_div simpl_divmod; "mod", None, eval_int_op BigInt.computer_mod simpl_divmod; ] ; ["int"],"EuclideanDivision", [], [ "div", None, eval_int_op BigInt.euclidean_div simpl_divmod; "mod", None, eval_int_op BigInt.euclidean_mod simpl_divmod; ] ; (* ["map"],"Map", ["map", builtin_map_type], [ "const", Some ls_map_const, eval_map_const; "get", Some ls_map_get, eval_map_get; "set", Some ls_map_set, eval_map_set; ] ; *) ] let add_builtin_th env (l,n,t,d) = let th = Env.read_theory env l n in List.iter (fun (id,r) -> let ts = Theory.ns_find_ts th.Theory.th_export [id] in r ts) t; List.iter (fun (id,r,f) -> let ls = Theory.ns_find_ls th.Theory.th_export [id] in Hls.add builtins ls f; match r with | None -> () | Some r -> r := ls) d let get_builtins env = Hls.clear builtins; List.iter (add_builtin_th env) built_in_theories (* {2 the reduction machine} *) type rule = Svs.t * term list * term type params = { compute_defs : bool; compute_builtin : bool; compute_def_set : Term.Sls.t; } type engine = { known_map : Decl.decl Ident.Mid.t; rules : rule list Mls.t; params : params; } (* OBSOLETE COMMENT A configuration is a pair (t,s) where t is a stack of terms and s is a stack of function symbols. A configuration ([t1;..;tn],[f1;..;fk]) represents a whole term, its model, as defined recursively by model([t],[]) = t model(t1::..::tn::t,f::s) = model(f(t1,..,tn)::t,s) where f as arity n A given term can be "exploded" into a configuration by reversing the rules above During reduction, the terms in the first stack are kept in normal form. The normalization process can be defined as the repeated application of the following rules. ([t],[]) --> t // t is in normal form if f(t1,..,tn) is not a redex then (t1::..::tn::t,f::s) --> (f(t1,..,tn)::t,s) if f(t1,..,tn) is a redex l sigma for a rule l -> r then (t1::..::tn::t,f::s) --> (subst(sigma) @ t,explode(r) @ s) *) type substitution = term Mvs.t type cont = | Kapp of lsymbol * Ty.ty option | Kif of term * term * substitution | Klet of vsymbol * term * substitution | Kcase of term_branch list * substitution | Keps of vsymbol | Kquant of quant * vsymbol list * trigger | Kbinop of binop | Knot | Keval of term * substitution type config = { value_stack : value list; cont_stack : (cont * term) list; (* second term is the original term, for label and loc copy *) } exception NoMatch let first_order_matching (vars : Svs.t) (largs : term list) (args : term list) : Ty.ty Ty.Mtv.t * substitution = let rec loop ((mt,mv) as sigma) largs args = match largs,args with | [],[] -> sigma | t1::r1, t2::r2 -> begin (* Format.eprintf "matching terms %a and %a...@." Pretty.print_term t1 Pretty.print_term t2; *) match t1.t_node with | Tvar vs when Svs.mem vs vars -> begin try let t = Mvs.find vs mv in if t_equal t t2 then loop sigma r1 r2 else raise NoMatch with Not_found -> try let ts = Ty.ty_match mt vs.vs_ty (t_type t2) in loop (ts,Mvs.add vs t2 mv) r1 r2 with Ty.TypeMismatch _ -> raise NoMatch end | Tapp(ls1,args1) -> begin match t2.t_node with | Tapp(ls2,args2) when ls_equal ls1 ls2 -> let mt, mv = loop sigma (List.rev_append args1 r1) (List.rev_append args2 r2) in begin try Ty.oty_match mt t1.t_ty t2.t_ty, mv with Ty.TypeMismatch _ -> raise NoMatch end | _ -> raise NoMatch end | (Tconst _ | Ttrue | Tfalse) when t_equal t1 t2 -> loop sigma r1 r2 | _ -> raise NoMatch end | _ -> raise NoMatch in loop (Ty.Mtv.empty, Mvs.empty) largs args exception Irreducible let one_step_reduce engine ls args = try let rules = Mls.find ls engine.rules in let rec loop rules = match rules with | [] -> raise Irreducible | (vars,largs,rhs)::rem -> begin try let sigma = first_order_matching vars largs args in sigma,rhs with NoMatch -> loop rem end in loop rules with Not_found -> raise Irreducible let rec matching ((mt,mv) as sigma) t p = match p.pat_node with | Pwild -> sigma | Pvar v -> (mt,Mvs.add v t mv) | Por(p1,p2) -> begin try matching sigma t p1 with NoMatch -> matching sigma t p2 end | Pas(p,v) -> matching (mt,Mvs.add v t mv) t p | Papp(ls1,pl) -> match t.t_node with | Tapp(ls2,tl) -> if ls_equal ls1 ls2 then List.fold_left2 matching sigma tl pl else if ls2.ls_constr > 0 then raise NoMatch else raise Undetermined | _ -> raise Undetermined let rec extract_first n acc l = if n = 0 then acc,l else match l with | x :: r -> extract_first (n-1) (x::acc) r | [] -> assert false let rec reduce engine c = match c.value_stack, c.cont_stack with | _, [] -> assert false | st, (Keval (t,sigma),orig) :: rem -> reduce_eval st t ~orig sigma rem | [], (Kif _, _) :: _ -> assert false | v :: st, (Kif(t2,t3,sigma), orig) :: rem -> begin match v with | Term { t_node = Ttrue } -> { value_stack = st ; cont_stack = (Keval(t2,sigma),t_label_copy orig t2) :: rem } | Term { t_node = Tfalse } -> { value_stack = st ; cont_stack = (Keval(t3,sigma),t_label_copy orig t3) :: rem } | Term t1 -> begin match t1.t_node , t2.t_node , t3.t_node with | Tapp (ls,[b0;{ t_node = Tapp (ls1,_) }]) , Tapp(ls2,_) , Tapp(ls3,_) when ls_equal ls ps_equ && ls_equal ls1 fs_bool_true && ls_equal ls2 fs_bool_true && ls_equal ls3 fs_bool_false -> { value_stack = Term (t_label_copy orig b0) :: st; cont_stack = rem } | _ -> { value_stack = Term (t_label_copy orig (t_if t1 (t_subst sigma t2) (t_subst sigma t3))) :: st; cont_stack = rem; } end | Int _ -> assert false (* would be ill-typed *) end | [], (Klet _, _) :: _ -> assert false | t1 :: st, (Klet(v,t2,sigma), orig) :: rem -> let t1 = term_of_value t1 in { value_stack = st; cont_stack = (Keval(t2, Mvs.add v t1 sigma), t_label_copy orig t2) :: rem; } | [], (Kcase _, _) :: _ -> assert false | Int _ :: _, (Kcase _, _) :: _ -> assert false | (Term t1) :: st, (Kcase(tbl,sigma), orig) :: rem -> reduce_match st t1 ~orig tbl sigma rem | ([] | [_] | Int _ :: _ | Term _ :: Int _ :: _), (Kbinop _, _) :: _ -> assert false | (Term t1) :: (Term t2) :: st, (Kbinop op, orig) :: rem -> { value_stack = Term (t_label_copy orig (t_binary_simp op t2 t1)) :: st; cont_stack = rem; } | [], (Knot,_) :: _ -> assert false | Int _ :: _ , (Knot,_) :: _ -> assert false | (Term t) :: st, (Knot, orig) :: rem -> { value_stack = Term (t_label_copy orig (t_not_simp t)) :: st; cont_stack = rem; } | st, (Kapp(ls,ty), orig) :: rem -> reduce_app engine st ~orig ls ty rem | [], (Keps _, _) :: _ -> assert false | Int _ :: _ , (Keps _, _) :: _ -> assert false | Term t :: st, (Keps v, orig) :: rem -> { value_stack = Term (t_label_copy orig (t_eps_close v t)) :: st; cont_stack = rem; } | [], (Kquant _, _) :: _ -> assert false | Int _ :: _, (Kquant _, _) :: _ -> assert false | Term t :: st, (Kquant(q,vl,tr), orig) :: rem -> { value_stack = Term (t_label_copy orig (t_quant_close_simp q vl tr t)) :: st; cont_stack = rem; } and reduce_match st u ~orig tbl sigma cont = let rec iter tbl = match tbl with | [] -> assert false (* pattern matching not exhaustive *) | b::rem -> let p,t = t_open_branch b in try let (mt',mv') = matching (Ty.Mtv.empty,sigma) u p in (* Format.eprintf "Pattern-matching succeeded:@\nmt' = @["; Ty.Mtv.iter (fun tv ty -> Format.eprintf "%a -> %a," Pretty.print_tv tv Pretty.print_ty ty) mt'; Format.eprintf "@]@\n"; Format.eprintf "mv' = @["; Mvs.iter (fun v t -> Format.eprintf "%a -> %a," Pretty.print_vs v Pretty.print_term t) mv'; Format.eprintf "@]@."; Format.eprintf "branch before inst: %a@." Pretty.print_term t; *) let mv'',t = t_subst_types mt' mv' t in (* Format.eprintf "branch after types inst: %a@." Pretty.print_term t; Format.eprintf "mv'' = @["; Mvs.iter (fun v t -> Format.eprintf "%a -> %a," Pretty.print_vs v Pretty.print_term t) mv''; Format.eprintf "@]@."; *) { value_stack = st; cont_stack = (Keval(t,mv''), t_label_copy orig t) :: cont; } with NoMatch -> iter rem in try iter tbl with Undetermined -> let dmy = t_var (create_vsymbol (Ident.id_fresh "__dmy") (t_type u)) in let tbls = match t_subst sigma (t_case dmy tbl) with | { t_node = Tcase (_,tbls) } -> tbls | _ -> assert false in { value_stack = Term (t_label_copy orig (t_case u tbls)) :: st; cont_stack = cont; } and reduce_eval st t ~orig sigma rem = let orig = t_label_copy orig t in match t.t_node with | Tvar v -> begin try let t = Mvs.find v sigma in { value_stack = Term (t_label_copy orig t) :: st ; cont_stack = rem; } with Not_found -> (* this may happen, e.g when computing below a quantified formula *) (* Format.eprintf "Tvar not found: %a@." Pretty.print_vs v; assert false *) { value_stack = Term orig :: st ; cont_stack = rem; } end | Tif(t1,t2,t3) -> { value_stack = st; cont_stack = (Keval(t1,sigma),t1) :: (Kif(t2,t3,sigma),orig) :: rem; } | Tlet(t1,tb) -> let v,t2 = t_open_bound tb in { value_stack = st ; cont_stack = (Keval(t1,sigma),t1) :: (Klet(v,t2,sigma),orig) :: rem } | Tcase(t1,tbl) -> { value_stack = st; cont_stack = (Keval(t1,sigma),t1) :: (Kcase(tbl,sigma),orig) :: rem } | Tbinop(op,t1,t2) -> { value_stack = st; cont_stack = (Keval(t1,sigma),t1) :: (Keval(t2,sigma),t2) :: (Kbinop op, orig) :: rem; } | Tnot t1 -> { value_stack = st; cont_stack = (Keval(t1,sigma),t1) :: (Knot,orig) :: rem; } | Teps tb -> let v,t1 = t_open_bound tb in { value_stack = st ; cont_stack = (Keval(t1,sigma),t1) :: (Keps v,orig) :: rem; } | Tquant(q,tq) -> let vl,tr,t1 = t_open_quant tq in { value_stack = st; cont_stack = (Keval(t1,sigma),t1) :: (Kquant(q,vl,tr),orig) :: rem; } | Tapp(ls,tl) -> let args = List.rev_map (fun t -> (Keval(t,sigma),t)) tl in { value_stack = st; cont_stack = List.rev_append args ((Kapp(ls,t.t_ty),orig) :: rem); } | Ttrue | Tfalse | Tconst _ -> { value_stack = Term orig :: st; cont_stack = rem; } and reduce_app engine st ls ~orig ty rem_cont = if ls_equal ls ps_equ then match st with | t2 :: t1 :: rem_st -> begin try reduce_equ ~orig rem_st t1 t2 rem_cont with Undetermined -> reduce_app_no_equ engine st ls ~orig ty rem_cont end | _ -> assert false else if ls_equal ls fs_func_app then match st with | t2 :: t1 :: rem_st -> begin try reduce_func_app ~orig ty rem_st t1 t2 rem_cont with Undetermined -> reduce_app_no_equ engine st ls ~orig ty rem_cont end | _ -> assert false else reduce_app_no_equ engine st ls ~orig ty rem_cont and reduce_func_app ~orig _ty rem_st t1 t2 rem_cont = (* attempt to decompile t1 under the form (epsilon fc. forall x. fc @ x = body) that is equivalent to \x.body *) match t1 with | Term { t_node = Teps tb } -> let fc,t = Term.t_open_bound tb in begin match t.t_node with | Tquant(Tforall,tq) -> let vl,trig,t = t_open_quant tq in let process lhs body equ elim = let rvl = List.rev vl in let rec remove_var lhs rvh rvt = match lhs.t_node with | Tapp (ls2,[lhs1;{t_node = Tvar v1} as arg]) when ls_equal ls2 fs_func_app && vs_equal v1 rvh -> begin match rvt , lhs1 with | rvh::rvt , _ -> let lhs1 , fc2 = remove_var lhs1 rvh rvt in let lhs2 = t_app ls2 [lhs1;arg] lhs.t_ty in t_label_copy lhs lhs2 , fc2 | [] , { t_node = Tvar fc1 } when vs_equal fc1 fc -> let fcn = fc.vs_name in let fc2 = Ident.id_derive fcn.Ident.id_string fcn in let fc2 = create_vsymbol fc2 (t_type lhs) in t_label_copy lhs (t_var fc2) , fc2 | _ -> raise Undetermined end | _ -> raise Undetermined in begin match rvl with | rvh :: rvt -> let lhs , fc2 = remove_var lhs rvh rvt in let (vh,vl) = match vl with | [] -> assert false | vh::vl -> (vh,vl) in let t2 = term_of_value t2 in begin match vl with | [] -> elim body vh t2 | _ -> let eq = equ lhs body in let tq = t_quant Tforall (t_close_quant vl trig eq) in let body = t_label_copy t (t_eps_close fc2 tq) in { value_stack = rem_st; cont_stack = (Keval(body,Mvs.add vh t2 Mvs.empty), t_label_copy orig body) :: rem_cont; } end | _ -> raise Undetermined end in begin match t.t_node with | Tapp (ls1,[lhs;body]) when ls_equal ls1 ps_equ -> let equ lhs body = t_label_copy t (t_app ps_equ [lhs;body] None) in let elim body vh t2 = { value_stack = rem_st; cont_stack = (Keval(body,Mvs.add vh t2 Mvs.empty), t_label_copy orig body) :: rem_cont; } in process lhs body equ elim | Tbinop (Tiff, ({t_node=Tapp (ls1,[lhs;tr])} as teq), body) when ls_equal ls1 ps_equ && t_equal tr t_bool_true -> let equ lhs body = let lhs = t_label_copy teq (t_app ps_equ [lhs;tr] None) in t_label_copy t (t_binary Tiff lhs body) in let elim body vh t2 = let body = t_if body t_bool_true t_bool_false in { value_stack = rem_st; cont_stack = (Keval(body,Mvs.add vh t2 Mvs.empty), t_label_copy orig body) :: rem_cont } in process lhs body equ elim | _ -> raise Undetermined end | _ -> raise Undetermined end | _ -> raise Undetermined and reduce_app_no_equ engine st ls ~orig ty rem_cont = let arity = List.length ls.ls_args in let args,rem_st = extract_first arity [] st in try let f = Hls.find builtins ls in let v = f ls args ty in { value_stack = (v_label_copy orig v) :: rem_st; cont_stack = rem_cont; } with Not_found | Undetermined -> let args = List.map term_of_value args in let d = try Ident.Mid.find ls.ls_name engine.known_map with Not_found -> assert false in let rewrite () = (* try a rewrite rule *) begin try (* Format.eprintf "try a rewrite rule on %a@." Pretty.print_ls ls; *) let (mt,mv),rhs = one_step_reduce engine ls args in (* Format.eprintf "rhs = %a@." Pretty.print_term rhs; Format.eprintf "sigma = "; Mvs.iter (fun v t -> Format.eprintf "%a -> %a," Pretty.print_vs v Pretty.print_term t) (snd sigma); Format.eprintf "@."; Format.eprintf "try a type match: %a and %a@." (Pp.print_option Pretty.print_ty) ty (Pp.print_option Pretty.print_ty) rhs.t_ty; *) (* let type_subst = Ty.oty_match Ty.Mtv.empty rhs.t_ty ty in Format.eprintf "subst of rhs: "; Ty.Mtv.iter (fun tv ty -> Format.eprintf "%a -> %a," Pretty.print_tv tv Pretty.print_ty ty) type_subst; Format.eprintf "@."; let rhs = t_ty_subst type_subst Mvs.empty rhs in let sigma = Mvs.map (t_ty_subst type_subst Mvs.empty) sigma in Format.eprintf "rhs = %a@." Pretty.print_term rhs; Format.eprintf "sigma = "; Mvs.iter (fun v t -> Format.eprintf "%a -> %a," Pretty.print_vs v Pretty.print_term t) sigma; Format.eprintf "@."; *) let mv,rhs = t_subst_types mt mv rhs in { value_stack = rem_st; cont_stack = (Keval(rhs,mv),orig) :: rem_cont; } with Irreducible -> { value_stack = Term (t_label_copy orig (t_app ls args ty)) :: rem_st; cont_stack = rem_cont; } end in match d.Decl.d_node with | Decl.Dtype _ | Decl.Dprop _ -> assert false | Decl.Dlogic dl -> (* regular definition *) let d = List.assq ls dl in if engine.params.compute_defs || Term.Sls.mem ls engine.params.compute_def_set then begin let vl,e = Decl.open_ls_defn d in let add (mt,mv) x y = Ty.ty_match mt x.vs_ty (t_type y), Mvs.add x y mv in let (mt,mv) = List.fold_left2 add (Ty.Mtv.empty, Mvs.empty) vl args in let mt = Ty.oty_match mt e.t_ty ty in let mv,e = t_subst_types mt mv e in { value_stack = rem_st; cont_stack = (Keval(e,mv),orig) :: rem_cont; } end else rewrite () | Decl.Dparam _ | Decl.Dind _ -> rewrite () | Decl.Ddata dl -> (* constructor or projection *) begin try match args with | [ { t_node = Tapp(ls1,tl1) } ] -> (* if ls is a projection and ls1 is a constructor, we should compute that projection *) let rec iter dl = match dl with | [] -> raise Exit | (_,csl) :: rem -> let rec iter2 csl = match csl with | [] -> iter rem | (cs,prs) :: rem2 -> if ls_equal cs ls1 then (* we found the right constructor *) let rec iter3 prs tl1 = match prs,tl1 with | (Some pr)::prs, t::tl1 -> if ls_equal ls pr then (* projection found! *) { value_stack = (Term (t_label_copy orig t)) :: rem_st; cont_stack = rem_cont; } else iter3 prs tl1 | None::prs, _::tl1 -> iter3 prs tl1 | _ -> raise Exit in iter3 prs tl1 else iter2 rem2 in iter2 csl in iter dl | _ -> raise Exit with Exit -> rewrite () end and reduce_equ (* engine *) ~orig st v1 v2 cont = (* try *) match v1,v2 with | Int n1, Int n2 -> let b = to_bool (BigInt.eq n1 n2) in { value_stack = Term (t_label_copy orig b) :: st; cont_stack = cont; } | Int n, Term {t_node = Tconst c} | Term {t_node = Tconst c}, Int n -> begin try let n' = big_int_of_const c in let b = to_bool (BigInt.eq n n') in { value_stack = Term (t_label_copy orig b) :: st; cont_stack = cont; } with NotNum -> raise Undetermined end | Int _, Term _ | Term _, Int _ -> raise Undetermined | Term t1, Term t2 -> reduce_term_equ ~orig st t1 t2 cont (* with Undetermined -> { value_stack = Term (t_equ (term_of_value v1) (term_of_value v2)) :: st; cont_stack = cont; } *) and reduce_term_equ ~orig st t1 t2 cont = if t_equal t1 t2 then { value_stack = Term (t_label_copy orig t_true) :: st; cont_stack = cont; } else match (t1.t_node,t2.t_node) with | Tconst c1, Tconst c2 -> begin match c1,c2 with | Number.ConstInt i1, Number.ConstInt i2 -> let b = BigInt.eq (Number.compute_int i1) (Number.compute_int i2) in { value_stack = Term (t_label_copy orig (to_bool b)) :: st; cont_stack = cont; } | _ -> raise Undetermined end | Tapp(ls1,tl1), Tapp(ls2,tl2) when ls1.ls_constr > 0 && ls2.ls_constr > 0 -> if ls_equal ls1 ls2 then let rec aux sigma t tyl l1 l2 = match tyl,l1,l2 with | [],[],[] -> sigma,t | ty::tyl, t1::tl1, t2::tl2 -> let v1 = create_vsymbol (Ident.id_fresh "") ty in let v2 = create_vsymbol (Ident.id_fresh "") ty in aux (Mvs.add v1 t1 (Mvs.add v2 t2 sigma)) (t_and_simp (t_equ (t_var v1) (t_var v2)) t) tyl tl1 tl2 | _ -> assert false in let sigma,t = aux Mvs.empty t_true ls1.ls_args tl1 tl2 in { value_stack = st; cont_stack = (Keval(t,sigma),orig) :: cont; } else { value_stack = Term (t_label_copy orig t_false) :: st; cont_stack = cont; } | Tif (b,{ t_node = Tapp(ls1,_) },{ t_node = Tapp(ls2,_) }) , Tapp(ls3,_) when ls_equal ls3 fs_bool_true && ls_equal ls1 fs_bool_true && ls_equal ls2 fs_bool_false -> { value_stack = Term (t_label_copy orig b) :: st; cont_stack = cont } | _ -> raise Undetermined let rec reconstruct c = match c.value_stack, c.cont_stack with | [Term t], [] -> t | _, [] -> assert false | _, (k,orig) :: rem -> let t, st = match c.value_stack, k with | st, Keval (t,sigma) -> (t_subst sigma t), st | [], Kif _ -> assert false | v :: st, Kif(t2,t3,sigma) -> (t_if (term_of_value v) (t_subst sigma t2) (t_subst sigma t3)), st | [], Klet _ -> assert false | t1 :: st, Klet(v,t2,sigma) -> (t_let_close v (term_of_value t1) (t_subst sigma t2)), st | [], Kcase _ -> assert false | v :: st, Kcase(tbl,sigma) -> (t_subst sigma (t_case (term_of_value v) tbl)), st | ([] | [_]), Kbinop _ -> assert false | t1 :: t2 :: st, Kbinop op -> (t_binary_simp op (term_of_value t2) (term_of_value t1)), st | [], Knot -> assert false | t :: st, Knot -> (t_not (term_of_value t)), st | st, Kapp(ls,ty) -> let args,rem_st = extract_first (List.length ls.ls_args) [] st in let args = List.map term_of_value args in (t_app ls args ty), rem_st | [], Keps _ -> assert false | t :: st, Keps v -> (t_eps_close v (term_of_value t)), st | [], Kquant _ -> assert false | t :: st, Kquant(q,vl,tr) -> (t_quant_close_simp q vl tr (term_of_value t)), st in reconstruct { value_stack = (Term (t_label_copy orig t)) :: st; cont_stack = rem; } (** iterated reductions *) let normalize ~limit engine t0 = let rec many_steps c n = match c.value_stack, c.cont_stack with | [Term t], [] -> t | _, [] -> assert false | _ -> if n = limit then begin Warning.emit "reduction of term %a takes more than %d steps, aborted.@." Pretty.print_term t0 limit; reconstruct c end else let c = reduce engine c in many_steps c (n+1) in let c = { value_stack = []; cont_stack = [Keval(t0,Mvs.empty),t0] ; } in many_steps c 0 (* the rewrite engine *) let create p env km = if p.compute_builtin then get_builtins env else Hls.clear builtins; { known_map = km ; rules = Mls.empty; params = p; } exception NotARewriteRule of string let extract_rule _km t = (* let check_ls ls = try let _ = Hls.find builtins ls in raise (NotARewriteRule "root of lhs of rule must not be a built-in symbol") with Not_found -> let d = Ident.Mid.find ls.ls_name km in match d.Decl.d_node with | Decl.Dtype _ | Decl.Dprop _ -> assert false | Decl.Dlogic _ -> raise (NotARewriteRule "root of lhs of rule must not be defined symbol") | Decl.Ddata _ -> raise (NotARewriteRule "root of lhs of rule must not be a constructor nor a projection") | Decl.Dparam _ | Decl.Dind _ -> () in *) let check_vars acc t1 t2 = (* check that quantified variables all appear in the lefthand side *) let vars_lhs = t_vars t1 in if Svs.exists (fun vs -> not (Mvs.mem vs vars_lhs)) acc then raise (NotARewriteRule "lhs should contain all variables"); (* check the same with type variables *) if not (Ty.Stv.subset (t_ty_freevars Ty.Stv.empty t2) (t_ty_freevars Ty.Stv.empty t2)) then raise (NotARewriteRule "lhs should contain all type variables") in let rec aux acc t = match t.t_node with | Tquant(Tforall,q) -> let vs,_,t = t_open_quant q in aux (List.fold_left (fun acc v -> Svs.add v acc) acc vs) t | Tbinop(Tiff,t1,t2) -> begin match t1.t_node with | Tapp(ls,args) -> (* check_ls ls; *) check_vars acc t1 t2; acc,ls,args,t2 | _ -> raise (NotARewriteRule "lhs of <-> should be a predicate symbol") end | Tapp(ls,[t1;t2]) when ls == ps_equ -> begin match t1.t_node with | Tapp(ls,args) -> (* check_ls ls; *) check_vars acc t1 t2; acc,ls,args,t2 | _ -> raise (NotARewriteRule "lhs of = should be a function symbol") end | _ -> raise (NotARewriteRule "rule should be of the form forall ... t1 = t2 or f1 <-> f2") in aux Svs.empty t let add_rule t e = let vars,ls,args,r = extract_rule e.known_map t in let rules = try Mls.find ls e.rules with Not_found -> [] in {e with rules = Mls.add ls ((vars,args,r)::rules) e.rules} why3-0.88.3/src/transform/split_goal.ml0000664000175100017510000005321413225666037020552 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Ident open Ty open Term open Decl type split = { right_only : bool; byso_split : bool; side_split : bool; stop_split : bool; asym_split : bool; comp_match : known_map option; } let stop_split = Ident.create_label "stop_split" let compiled = Ident.create_label "split_goal: compiled match" let case_label = Ident.create_label "case_split" let stop f = Slab.mem stop_split f.t_label let asym f = Slab.mem Term.asym_label f.t_label let keep f = Slab.mem Term.keep_on_simp_label f.t_label let case f = Slab.mem case_label f.t_label let unstop f = t_label ?loc:f.t_loc (Slab.remove stop_split f.t_label) f (* Represent monoid of formula interpretation for conjonction and disjunction *) module M = struct (* Multiplication tree *) type comb = Base of term | Op of comb * comb (* zero: false for /\, true for \/ unit: true for /\, false for \/ *) type monoid = Zero of term | Unit | Comb of comb (* Triviality degree. *) let degree = function Unit -> 0 | Zero _ | Comb (Base _) -> 1 | _ -> 2 (* inject formula into monoid. *) let (!+) a = Comb (Base a) let rec filter c = match c with | Base a when keep a -> Some c | Base _ -> None | Op (a,b) -> match filter a, filter b with | None, u | u, None -> u | Some a, Some b -> Some (Op (a,b)) (* monoid law. *) let (++) a b = match a, b with | _, Unit -> a | Unit, _ -> b | Zero ta, Comb b -> begin match filter b with | None -> a | Some b -> Comb (Op (Base ta,b)) end | Comb a, Zero tb -> begin match filter a with | None -> b | Some a -> Comb (Op (a,Base tb)) end | Zero _, Zero _ -> a | Comb ca, Comb cb -> Comb (Op (ca, cb)) (* (base -> base) morphism application. *) let rec cmap f = function | Base a -> Base (f a) | Op (a,b) -> Op (cmap f a, cmap f b) (* (base -> general) morphism application *) let rec cbind f = function | Base a -> f a | Op (a,b) -> Op (cbind f a, cbind f b) (* Apply morphism phi from monoid 1 to monoid 2 (law may change) Implicit morphism phi must respect: phi(zero_1) = f0 (term representing the zero) phi(unit_1) = unit_2 phi(x `law_1` y) = phi(x) `law_2` phi(y) phi(a) = f a (for base values, and f a is a base value) Intended: monotone context closure, negation *) let map f0 f = function | Zero t -> f0 t | Unit -> Unit | Comb c -> Comb (cmap f c) (* Apply bimorphism phi from monoids 1 and 2 to monoid 3 Implicit bimorphism phi must respect: - partial applications of phi (phi(a,_) and phi(_,b)) are morphisms - phi(zero,b) = f0_ 'term for zero' b (for b a base value, f0_ _ b is a base value) - phi(a,zero) = f_0 'term for zero' a (for a a base value, f_0 a _ is a base value) - phi(zero,zero) = f00 'term for first zero' 'term for second zero' - phi(a,b) = f a b (for a,b base value, and f a b is a base value) Intended: mainly /\, \/ and -> *) let bimap f00 f0_ f_0 f a b = match a, b with | Unit, _ | _, Unit -> Unit | Zero t1, Zero t2 -> f00 t1 t2 | Zero t1, Comb cb -> Comb (cmap (f0_ t1) cb) | Comb ca, Zero t2 -> Comb (cmap (f_0 t2) ca) | Comb ca, Comb cb -> Comb (cbind (fun x -> cmap (f x) cb) ca) let rec to_list m acc = match m with | Base a -> a :: acc | Op (a,b) -> to_list a (to_list b acc) let to_list = function | Zero t -> [t] | Unit -> [] | Comb c -> to_list c [] end type split_ret = { (* implications are equivalences when byso_split is off *) (* Conjunctive decomposition of formula: /\ pos -> f *) pos : M.monoid; (* Disjunctive decomposition of formula: f -> \/ pos *) neg : M.monoid; (* Backward pull of formula: bwd -> f (typically from by) *) bwd : term; (* Forward pull of formula: f -> fwd (typically from so) *) fwd : term; (* Side-condition (generated from by/so occurrences when byso_split is on) *) side : M.monoid; (* Indicate whether positive/negative occurrences of formula force decomposition. *) cpos : bool; cneg : bool; } let rec drop_byso f = match f.t_node with | Tbinop (Timplies,{ t_node = Tbinop (Tor,_,{ t_node = Ttrue }) },f) -> drop_byso f | Tbinop (Tand,f,{ t_node = Tbinop (Tor,_,{ t_node = Ttrue }) }) -> drop_byso f | _ -> t_map drop_byso f open M let pat_condition kn tv cseen p = match p.pat_node with | Pwild -> let csl,sbs = match p.pat_ty.ty_node with | Tyapp (ts,_) -> Decl.find_constructors kn ts, let ty = ty_app ts (List.map ty_var ts.ts_args) in ty_match Mtv.empty ty p.pat_ty | _ -> assert false in let csall = Sls.of_list (List.rev_map fst csl) in let csnew = Sls.diff csall cseen in assert (not (Sls.is_empty csnew)); let add_cs cs g = let mk_v ty = create_vsymbol (id_fresh "w") (ty_inst sbs ty) in let vl = List.map mk_v cs.ls_args in let f = t_equ tv (fs_app cs (List.map t_var vl) p.pat_ty) in g ++ !+ (t_exists_close_simp vl [] f) in let g = Sls.fold add_cs csnew Unit in csall, [], g | Papp (cs, pl) -> let vl = List.map (function | {pat_node = Pvar v} -> v | _ -> assert false) pl in let g = t_equ tv (fs_app cs (List.map t_var vl) p.pat_ty) in Sls.add cs cseen, vl, !+g | _ -> assert false let rec fold_cond = function | Base a -> a | Op (a,b) -> t_or (fold_cond a) (fold_cond b) let fold_cond = function | Comb c -> !+ (fold_cond c) | x -> x let rec split_core sp f = let rc = split_core sp in let (~-) = t_label_copy f in let ro = sp.right_only in let alias fo1 unop f1 = if fo1 == f1 then f else - unop f1 in let alias2 fo1 fo2 binop f1 f2 = if fo1 == f1 && fo2 == f2 then f else - binop f1 f2 in let rec trivial n = function | [] -> true | x :: q -> let m = n + degree x in (m <= 1 && trivial m q) in let trivial bs = trivial 0 bs in let pcaset bs sf = let test = not ro || (sf.cpos && trivial bs) in (if test then sf.pos else !+(sf.bwd)), test in let pcase bs sf = let x, _ = pcaset bs sf in x in let ncaset bs sf = let test = not ro || (sf.cneg && trivial bs) in (if test then sf.neg else !+(sf.fwd)), test in let ncase bs sf = let x, _ = ncaset bs sf in x in let ngt _ a = t_not a and cpy _ a = a in let bimap = bimap (fun _ t -> Zero t) cpy in let iclose = bimap ngt t_implies in let aclose = bimap cpy t_and in let nclose ps = map (fun t -> Zero (t_label_copy t t_true)) t_not ps in let ret pos neg bwd fwd side cpos cneg = { pos; neg; bwd; fwd; side; cpos; cneg } in let r = match f.t_node with | _ when sp.stop_split && stop f -> let df = drop_byso f in ret !+(unstop f) !+(unstop df) f df Unit false false | (Ttrue | Tfalse) when keep f -> ret !+f !+f f f Unit false false | Ttrue -> ret Unit (Zero f) f f Unit false false | Tfalse -> ret (Zero f) Unit f f Unit false false | Tapp _ -> let uf = !+f in ret uf uf f f Unit false false (* f1 so f2 *) | Tbinop (Tand,f1,{ t_node = Tbinop (Tor,f2,{ t_node = Ttrue }) }) -> if not (sp.byso_split && asym f2) then rc f1 else let (&&&) f1 f2 = - t_and f1 f2 in let sf1 = rc f1 and sf2 = rc f2 in let fwd = sf1.fwd &&& sf2.fwd in let nf2, cn2 = ncaset [] sf2 in let nf1, cn1 = ncaset [nf2;sf2.side;sf2.pos] sf1 in let neg = bimap cpy (&&&) nf1 nf2 in let close = iclose nf1 in let lside = if sp.side_split then close sf2.pos else !+(t_implies sf1.fwd sf2.bwd) in let side = sf1.side ++ lside ++ close sf2.side in ret sf1.pos neg sf1.bwd fwd side sf1.cpos (cn1 || cn2) | Tbinop (Tand,f1,f2) -> let (&&&) = alias2 f1 f2 t_and in let sf1 = rc f1 and sf2 = rc f2 in let fwd = sf1.fwd &&& sf2.fwd and bwd = sf1.bwd &&& sf2.bwd in let asym = sp.asym_split && asym f1 in let nf2, cn2 = ncaset [] sf2 in let sd = if asym then [sf1.side] else [] in let dp = nf2::sd in let nf1, cn1 = ncaset dp sf1 in let neg = bimap cpy (&&&) nf1 nf2 in let pos2 = if not asym then sf2.pos else let nf1 = ncase (sf2.pos::sd) sf1 in iclose nf1 sf2.pos in let pos = sf1.pos ++ pos2 in let side = sf1.side ++ if not asym then sf2.side else let nf1 = ncase (sf2.pos::dp) sf1 in iclose nf1 sf2.side in ret pos neg bwd fwd side false (cn1 || cn2) (* f1 by f2 *) | Tbinop (Timplies,{ t_node = Tbinop (Tor,f2,{ t_node = Ttrue }) },f1) -> if not (sp.byso_split && asym f2) then rc f1 else let sf1 = rc f1 and sf2 = rc f2 in let close = iclose (ncase [sf1.pos;sf1.side] sf2) in let lside = if sp.side_split then close sf1.pos else !+(t_implies sf2.fwd sf1.bwd) in let side = sf2.side ++ lside ++ sf1.side in ret sf2.pos sf1.neg sf2.bwd sf1.fwd side sf2.cpos sf1.cneg | Tbinop (Timplies,f1,f2) -> let (>->) = alias2 f1 f2 t_implies in let sf1 = rc f1 and sf2 = rc f2 in let fwd = sf1.bwd >-> sf2.fwd and bwd = sf1.fwd >-> sf2.bwd in let asym = sp.asym_split && asym f1 in let sd = [sf1.side] in let neg1 = nclose sf1.pos in let neg2 = if not asym then sf2.neg else let nf1 = ncase (sf2.neg::sd) sf1 in aclose nf1 sf2.neg in let neg = neg1 ++ neg2 in let dp = sf2.pos::sd in let nf1, cn1 = ncaset dp sf1 in let pos = bimap (fun _ a -> - t_not a) (>->) nf1 sf2.pos in let nf1 = ncase (if asym then sf2.neg::dp else dp) sf1 in let side = sf1.side ++ iclose nf1 sf2.side in ret pos neg bwd fwd side (cn1 || sf2.cpos) false | Tbinop (Tor,f1,f2) -> let (|||) = alias2 f1 f2 t_or in let sf1 = rc f1 and sf2 = rc f2 in let fwd = sf1.fwd ||| sf2.fwd and bwd = sf1.bwd ||| sf2.bwd in let asym = sp.asym_split && asym f1 in let sd = if asym then [sf2.side] else [] in let pf2, cp2 = pcaset [] sf2 in let dp = sf2.pos::sd in let pf1, cp1 = pcaset dp sf1 in let pos = bimap cpy (|||) pf1 pf2 in let neg2 = if not asym then sf2.neg else let pf1 = pcase (sf2.neg::sd) sf1 in aclose (nclose pf1) sf2.neg in let side2 = if not asym then sf2.side else let pf1 = pcase (sf2.neg::dp) sf1 in bimap cpy (|||) pf1 sf2.side in ret pos (sf1.neg ++ neg2) bwd fwd (sf1.side ++ side2) (cp1 || cp2) false | Tbinop (Tiff,f1,f2) -> let sf1 = rc f1 and sf2 = rc f2 in let df = if sf1.fwd == sf1.bwd && sf2.fwd == sf2.bwd then alias2 f1 f2 t_iff sf1.fwd sf2.fwd else drop_byso f in let nf1 = ncase [sf2.pos] sf1 and nf2 = ncase [sf1.pos] sf2 in let pos = iclose nf1 sf2.pos ++ iclose nf2 sf1.pos in let nf2 = ncase [] sf2 and pf2 = pcase [] sf2 in let nf1 = ncase [nf2] sf1 and pf1 = pcase [pf2] sf1 in let neg_top = aclose nf1 nf2 in let neg_bot = aclose (nclose pf1) (nclose pf2) in ret pos (neg_top ++ neg_bot) df df (sf1.side ++ sf2.side) false false | Tif (fif,fthen,felse) -> let sfi = rc fif and sft = rc fthen and sfe = rc felse in let dfi = if sfi.fwd == sfi.bwd then sfi.fwd else drop_byso fif in let rebuild fif2 fthen2 felse2 = if fif == fif2 && fthen == fthen2 && felse == felse2 then f else - t_if fif2 fthen2 felse2 in let fwd = rebuild dfi sft.fwd sfe.fwd in let bwd = rebuild dfi sft.bwd sfe.bwd in let sdt = [sft.side] and sde = [sfe.side] in let spt = sft.pos::sdt and spe = sfe.pos::sde in let nfi = ncase spt sfi and pfi = pcase spe sfi in let pos = iclose nfi sft.pos ++ iclose (nclose pfi) sfe.pos in let nfi = ncase (sft.neg::sdt) sfi and pfi = pcase (sfe.neg::sde) sfi in let neg = aclose nfi sft.neg ++ aclose (nclose pfi) sfe.neg in let nfi = ncase (sft.neg::spt) sfi and pfi = pcase (sfe.neg::spe) sfi in let eside = iclose (nclose pfi) sfe.side in let side = sfi.side ++ iclose nfi sft.side ++ eside in ret pos neg bwd fwd side false false | Tnot f1 -> let sf = rc f1 in let (!) = alias f1 t_not in let (|>) zero = map (fun t -> !+(t_label_copy t zero)) (!) in let pos = t_false |> sf.neg and neg = t_true |> sf.pos in ret pos neg !(sf.fwd) !(sf.bwd) sf.side sf.cneg sf.cpos | Tlet (t,fb) -> let vs, f1 = t_open_bound fb in let (!) = alias f1 (t_let_close vs t) in let sf = rc f1 in let (!!) = map (fun t -> Zero t) (!) in ret !!(sf.pos) !!(sf.neg) !(sf.bwd) !(sf.fwd) !!(sf.side) sf.cpos sf.cneg | Tcase (t,bl) -> let k join = let case_close bl2 = if Lists.equal (==) bl bl2 then f else - t_case t bl2 in let sbl = List.map (fun b -> let p, f, close = t_open_branch_cb b in p, close, split_core sp f) bl in let blfwd = List.map (fun (p, close, sf) -> close p sf.fwd) sbl in let fwd = case_close blfwd in let blbwd = List.map (fun (p, close, sf) -> close p sf.bwd) sbl in let bwd = case_close blbwd in let pos, neg, side = join sbl in ret pos neg bwd fwd side false false in begin match sp.comp_match with | None -> let join sbl = let rec zip_all bf_top bf_bot = function | [] -> Unit, Unit, Unit, [], [] | (p, close, sf) :: q -> let c_top = close p t_true and c_bot = close p t_false in let dp_top = c_top :: bf_top and dp_bot = c_bot :: bf_bot in let pos, neg, side, af_top, af_bot = zip_all dp_top dp_bot q in let fzip bf af mid = - t_case t (List.rev_append bf (close p mid::af)) in let zip bf mid af = map (fun t -> !+(fzip bf af t)) (fzip bf af) mid in zip bf_top sf.pos af_top ++ pos, zip bf_bot sf.neg af_bot ++ neg, zip bf_top sf.side af_top ++ side, c_top :: af_top, c_bot :: af_bot in let pos, neg, side, _, _ = zip_all [] [] sbl in pos, neg, side in k join | Some kn -> if Slab.mem compiled f.t_label then (* keep the labels for single-case match *) let lab = match bl with | [_] -> Slab.remove case_label (Slab.remove compiled f.t_label) | _ -> Slab.empty in let join sbl = let vs = create_vsymbol (id_fresh "q") (t_type t) in let tv = t_var vs in let (~-) fb = t_label ?loc:f.t_loc lab (t_let_close_simp vs t fb) in let _, pos, neg, side = List.fold_left (fun (cseen, pos, neg, side) (p, _, sf) -> let cseen, vl, cond = pat_condition kn tv cseen p in let cond = if ro then fold_cond cond else cond in let fcl t = - t_forall_close_simp vl [] t in let ecl t = - t_exists_close_simp vl [] t in let ps cond f = fcl (t_implies cond f) in let ng cond f = ecl (t_and cond f) in let ngt _ a = fcl (t_not a) and tag _ a = ecl a in let pos = pos ++ bimap ngt ps cond sf.pos in let neg = neg ++ bimap tag ng cond sf.neg in let side = side ++ bimap ngt ps cond sf.side in cseen, pos, neg, side ) (Sls.empty, Unit, Unit, Unit) sbl in pos, neg, side in k join else let mk_let = t_let_close_simp in let mk_case t bl = t_label_add compiled (t_case_close t bl) in let mk_b b = let p, f = t_open_branch b in [p], f in let bl = List.map mk_b bl in let f = - Pattern.compile_bare ~mk_case ~mk_let [t] bl in split_core sp f end | Tquant (qn,fq) -> let vsl, trl, f1 = t_open_quant fq in let close = alias f1 (t_quant_close qn vsl trl) in let sf = rc f1 in let bwd = close sf.bwd and fwd = close sf.fwd in let pos, neg, cpos, cneg = match qn with | Tforall -> map (fun t -> Zero t) close sf.pos, !+fwd, sf.cpos, false | Texists -> !+bwd, map (fun t -> Zero t) close sf.neg, false, sf.cneg in let side = map (fun t -> Zero t) (t_forall_close vsl trl) sf.side in ret pos neg bwd fwd side cpos cneg | Tvar _ | Tconst _ | Teps _ -> raise (FmlaExpected f) in let r = if case f then { r with cpos = true; cneg = true } else r in match r with | { side = M.Zero _ } -> { r with pos = Unit; neg = Unit; fwd = t_false; bwd = t_true } | _ -> r let full_split kn = { right_only = false; byso_split = false; side_split = true; stop_split = false; asym_split = true; comp_match = kn; } let right_split kn = { (full_split kn) with right_only = true } let full_proof kn = { (full_split kn) with stop_split = true; byso_split = true } let right_proof kn = { (full_proof kn) with right_only = true } let full_intro kn = { (full_split kn) with asym_split = false; stop_split = true } let right_intro kn = { (full_intro kn) with right_only = true } let split_pos sp f = let core = split_core sp f in assert (core.side = Unit); to_list core.pos let split_neg sp f = let core = split_core sp f in assert (core.side = Unit); to_list core.neg let split_proof sp f = let core = split_core sp f in to_list (core.pos ++ core.side) let split_pos_full ?known_map f = split_pos (full_split known_map) f let split_pos_right ?known_map f = split_pos (right_split known_map) f let split_neg_full ?known_map f = split_neg (full_split known_map) f let split_neg_right ?known_map f = split_neg (right_split known_map) f let split_proof_full ?known_map f = split_proof (full_proof known_map) f let split_proof_right ?known_map f = split_proof (right_proof known_map) f let split_intro_full ?known_map f = split_pos (full_intro known_map) f let split_intro_right ?known_map f = split_pos (right_intro known_map) f let split_goal sp pr f = let make_prop f = [create_prop_decl Pgoal pr f] in List.map make_prop (split_proof sp f) let split_axiom sp pr f = let make_prop f = let pr = create_prsymbol (id_clone pr.pr_name) in create_prop_decl Paxiom pr f in let sp = { sp with asym_split = false; byso_split = false } in match split_pos sp f with | [f] -> [create_prop_decl Paxiom pr f] | fl -> List.map make_prop fl let split_all sp d = match d.d_node with | Dprop (Pgoal, pr,f) -> split_goal sp pr f | Dprop (Paxiom,pr,f) -> [split_axiom sp pr f] | _ -> [[d]] let split_premise sp d = match d.d_node with | Dprop (Paxiom,pr,f) -> split_axiom sp pr f | _ -> [d] let prep_goal split = Trans.store (fun t -> let split = split (Some (Task.task_known t)) in let trans = Trans.goal_l (split_goal split) in Trans.apply trans t) let prep_all split = Trans.store (fun t -> let split = split (Some (Task.task_known t)) in let trans = Trans.decl_l (split_all split) None in Trans.apply trans t) let prep_premise split = Trans.store (fun t -> let split = split (Some (Task.task_known t)) in let trans = Trans.decl (split_premise split) None in Trans.apply trans t) let split_goal_full = prep_goal full_proof let split_goal_right = prep_goal right_proof let split_goal_wp = split_goal_right let split_all_full = prep_all full_proof let split_all_right = prep_all right_proof let split_all_wp = split_all_right let split_premise_full = prep_premise full_proof let split_premise_right = prep_premise right_proof let split_premise_wp = split_premise_right let () = Trans.register_transform_l "split_goal_full" split_goal_full ~desc:"Put@ the@ goal@ in@ a@ conjunctive@ form,@ \ returns@ the@ corresponding@ set@ of@ subgoals.@ The@ number@ of@ subgoals@ \ generated@ may@ be@ exponential@ in@ the@ size@ of@ the@ initial@ goal." let () = Trans.register_transform_l "split_all_full" split_all_full ~desc:"Same@ as@ split_goal_full,@ but@ also@ split@ premises." let () = Trans.register_transform "split_premise_full" split_premise_full ~desc:"Same@ as@ split_all_full,@ but@ split@ only@ premises." let () = Trans.register_transform_l "split_goal_right" split_goal_right ~desc:"@[Same@ as@ split_goal_full,@ but@ don't@ split:@,\ - @[conjunctions under disjunctions@]@\n\ - @[conjunctions on the left of implications.@]@]" let () = Trans.register_transform_l "split_all_right" split_all_right ~desc:"Same@ as@ split_goal_right,@ but@ also@ split@ premises." let () = Trans.register_transform "split_premise_right" split_premise_right ~desc:"Same@ as@ split_all_right,@ but@ split@ only@ premises." let () = Trans.register_transform_l "split_goal_wp" split_goal_wp ~desc:"Same@ as@ split_goal_right." let () = Trans.register_transform_l "split_all_wp" split_all_wp ~desc:"Same@ as@ split_goal_wp,@ but@ also@ split@ premises." let () = Trans.register_transform "split_premise_wp" split_premise_wp ~desc:"Same@ as@ split_all_wp,@ but@ split@ only@ premises." why3-0.88.3/src/transform/abstraction.ml0000664000175100017510000000321113225666037020716 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Ident open Term open Decl let abstraction (keep : lsymbol -> bool) = let term_table = Hterm.create 257 in let extra_decls = ref [] in let rec abstract t : term = match t.t_node with | Tconst _ | Tapp(_,[]) | Ttrue | Tfalse -> t | Tapp(ls,_) when keep ls -> t_map abstract t | Tnot _ | Tbinop _ -> t_map abstract t | _ -> let t = t_label Slab.empty t in let (ls, tabs) = try Hterm.find term_table t with Not_found -> let ls = create_lsymbol (id_fresh "abstr") [] t.t_ty in let tabs = t_app ls [] t.t_ty in Hterm.add term_table t (ls, tabs); ls, tabs in extra_decls := ls :: !extra_decls; tabs in let abstract_decl (d : decl) : decl list = let d = decl_map abstract d in let l = List.fold_left (fun acc ls -> create_param_decl ls :: acc) [d] !extra_decls in extra_decls := []; l in Trans.decl abstract_decl None why3-0.88.3/src/transform/encoding_tags_full.mli0000664000175100017510000000130713225666037022410 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) why3-0.88.3/src/transform/induction.ml0000664000175100017510000004127613225666037020416 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Ident open Ty open Term open Decl open Theory open Task let lab_ind = create_label "induction" (* let desc_labels = [label_induction, ("Make the induction on the labeled variables." : Pp.formatted)] *) (*********************************************************) (******* Data type induction principle *********) (*********************************************************) (*INDUCTION SCHEME*) (*Induction scheme for some algebraic recursive datatype. For example: type tree 'a = Leaf | Node (tree 'a) 'a (tree 'a) tyscheme(tree 'a) = [Leaf "->" emptyset; Node l x r "->" (l,r)]*) type tyscheme = (pattern * Svs.t) list (*QUANTIFIERS GENERALIZATION INSIDE INDUCTION HYPOTHESES*) (*an information for induction hypothesis construction on some induction variable, taking into account its type's induction scheme and initial quantifier order. For example, if initial formula is Va.Vx3.Vb.Vx1.Vc.Vx2.Vd F(x1,x2,x3), and the lex. order of induction is (x1,x2,x3), then vlex(x1) = {x1; b; (x3,c,x2,d); x1.type.tyscheme}, vlex(x2) = {x2; c; (x3,d); x2.type.tyscheme}, vlex(x1) = {x3; a; (b,c,d); x3.type.tyscheme}*) type vlex = {vs: vsymbol; (*variable*) lq: vsymbol list; (*left immediate neutral quantifiers *) rq: vsymbol list; (*generalized neutral and induction quantifiers *) ts: tyscheme (*type scheme following its definition*) } (*HEURISTIC CANDIDATES FOR INDUCTION TACTIC *) (*Definitions for Svsl : "Set of variable symbol list". Each list corresponds to the largest prefix of some recursive function decreasing argument list, where arguments are instanciated with call actual parameters and recognized as possibles induction candidates if they are variables themselves. Note, that first are compared lists length, otherwise comparison is made on lexicographic order of vsymbols. Empty list corresponds to non-recurisve functions calls This definitions and methods using them are without use if some induction tags are provided in the goal by user.*) module VsList = Stdlib.OrderedHashedList(struct type t = vsymbol let tag = vs_hash end) module Mvsl = Extmap.Make(VsList) module Svsl = Extset.MakeOfMap(Mvsl) (* DEBUGGING AND PRINTING *) let debug = Debug.register_info_flag "induction" ~desc:"Print@ debugging@ messages@ of@ the@ 'induction'@ transformation." let print_ty_skm skm = List.iter (fun (p,svs) -> Format.printf "@[| %a : @]" Pretty.print_pat p; Svs.iter (Format.printf "%a " Pretty.print_vs) svs; Format.printf "@.") skm; Pretty.forget_all () let print_vset vset = let aux vl = Format.printf "[ "; List.iter (Format.printf "%a " Pretty.print_vs) vl; Format.printf "] " in Format.printf "************** t_candidates_lex *****************\n"; Format.printf "Candidates found : %d @." (Svsl.cardinal vset); Format.printf "Candidates : [ "; Svsl.iter (fun vl -> aux vl) vset; Format.printf "]\n@."; Pretty.forget_all () let print_heuristic_lex vl = let _,ivm = List.fold_left (fun (i,m) v -> (i+1, Mvs.add v i m)) (0,Mvs.empty) vl in Format.printf "**************** heuristic_lex ******************\n"; Format.printf "Induction variables (in lexicographic order): [ "; List.iter (Format.printf "%a " Pretty.print_vs) vl; Format.printf "]@."; Format.printf "Lex. order map : [ "; Mvs.iter (fun v i -> Format.printf "%a -> %d; " Pretty.print_vs v i) ivm; Format.printf "]\n@."; Pretty.forget_all () let print_lex lexl = let rec aux = function | [] -> () | v :: tl -> Format.printf "\n%a : [ " Pretty.print_vs v.vs; List.iter (Format.printf "%a " Pretty.print_vs) v.lq; Format.printf "] [ "; List.iter (Format.printf "%a " Pretty.print_vs) v.rq; Format.printf "]@."; Format.printf "--- Type scheme --- \n"; print_ty_skm v.ts; Format.printf "------------------- \n"; aux tl in Format.printf "******************* qsplit_lex ******************\n"; Format.printf "Induction variables (in the initial order): "; List.iter (fun v -> Format.printf "%a " Pretty.print_vs v.vs ) lexl; Format.printf "@.(Variable) (Introduced) (Generalized)\n"; aux lexl; Pretty.forget_all () (*****************************************************************************) (******************** INDUCTION BASED ON TYPE DEFINITIONS ********************) (************************* WITH LEXICOGRAPHIC ORDER **************************) (*****************************************************************************) (* dead code let split_quantifiers x qvl = let rec aux left = function | hd :: tl when vs_equal x hd -> List.rev left, tl | hd :: tl -> aux (hd :: left) tl | [] -> assert false in aux [] qvl *) (*INITIAL FORMULA SPLIT*) let decompose_forall t = let rec aux qvl_acc t = match t.t_node with | Tquant (Tforall, qt) -> let qvl, _, t = t_open_quant qt in aux (qvl_acc @ qvl) t | _ -> qvl_acc, t in let qvl, t = aux [] t in (List.fold_right Svs.add qvl Svs.empty), qvl, t let qvl_labeled qvl = List.filter (fun v -> Slab.mem lab_ind v.vs_name.id_label) qvl (*HEURISTICS SEARCH FOR CANDIDATES IN THE BODY OF THE FORMULA*) (* This function collects lists of variables corresponding to some recursive functions call parameters into the body of formula, if no user made induction tag is provided. If some user tags are provided, this function will return the corresponding list of variables will be returned according to the order of tags (from left to right). Otherwise, each list respects the lexicographic order of the corresponding recusrive function in which decrease its formal arguments. Note that one list contain the biggest lexicographic order prefix where all actual parameters are variables. For example, if function f(x,a,y,b,z) decreases on [a;b], but is called with some not-variable term T for argument b, then the resulting list will be [a]. *) let t_candidates_lex km qvs labeledvl t = (* let int_candidates _tl acc = acc List.fold_left (fun acc t -> match t.t_node with | Tvar x when Svs.mem x qvs && ty_equal x.vs_ty ty_int -> Svls.add [x] acc | _ -> acc) acc tl *) let rec_candidates il tl acc = let rec aux il vl = match il with | i :: iq -> begin match (List.nth tl i).t_node with | Tvar x when Svs.mem x qvs -> begin match x.vs_ty.ty_node with | Tyvar _ -> vl | Tyapp _ -> aux iq (x :: vl) end | _ -> vl end | [] -> vl in Svsl.add (List.rev (aux il [])) acc in let defn_candidates (ls,tl) acc = match (find_logic_definition km ls) with | Some defn -> let acc = acc (*int_candidates tl acc*) in rec_candidates (ls_defn_decrease defn) tl acc | None -> acc in let rec t_candidates acc t = let acc = match t.t_node with | Tapp (ls, tl) -> defn_candidates (ls, tl) acc | _ -> acc in t_fold t_candidates acc t in if labeledvl <> [] then Svsl.add labeledvl Svsl.empty else t_candidates Svsl.empty t exception No_candidates_found (*Chooses leftmost (in the formula's quantifiers list ) candidate list from the subset of lists of the biggest size ; raises an exception, if the candidate set is empty or contains only an empty list, *) let heuristic_lex vset = try let vl = Svsl.max_elt vset in if vl = [] then raise No_candidates_found else vl with Not_found -> raise No_candidates_found (*Generates induction scheme for one variable of some algebraic datatype according to datatype's definition *) let vs_tyscheme km x = let ts,ty = match x.vs_ty.ty_node with | Tyapp _ when ty_equal x.vs_ty ty_int -> assert false | Tyvar _ -> assert false | Tyapp (ts, _) -> ts, ty_app ts (List.map ty_var ts.ts_args) in let sigma = ty_match Mtv.empty ty x.vs_ty in let ty_str ty = let s = match ty.ty_node with | Tyapp (ts, _) -> ts.ts_name.id_string | Tyvar tv -> tv.tv_name.id_string in if s = "" then "x" else String.make 1 s.[0] in let ty_vs ty = let ty = ty_inst sigma ty in Term.create_vsymbol (Ident.id_fresh (ty_str ty)) ty in let tyscheme_constructor (ls, _) = let vlst = List.map ty_vs ls.ls_args in let plst = List.map pat_var vlst in let vset = List.fold_left (fun s v -> if ty_equal x.vs_ty v.vs_ty then Svs.add v s else s) Svs.empty vlst in pat_app ls plst x.vs_ty, vset in let cl = find_constructors km ts in ((List.map tyscheme_constructor cl) : tyscheme) (* Preprocesses selected induction candidate list for induction scheme instanciation.*) let qsplit km vl qvl = let rec aux (ivs,ivm) qvl lql lvl acc = match qvl with | [] -> List.rev acc, lql | q :: tl -> if Svs.mem q ivs then let qi = Mvs.find q ivm in let rleft = List.filter (fun v -> (Mvs.find v ivm) > qi) lvl in let rright = List.filter (fun v -> if (Mvs.mem v ivm) then (Mvs.find v ivm) > qi else true) tl in let v = { vs = q; lq = List.rev lql; rq = (List.rev rleft) @ rright; ts = vs_tyscheme km q} in aux ((Svs.remove q ivs),ivm) tl [] (q :: lvl) (v :: acc) else if Svs.is_empty ivs then List.rev acc, qvl else aux (ivs,ivm) tl (q :: lql) lvl acc in let _, ivs, ivm = List.fold_left (fun (i,s,m) v -> (i+1, Svs.add v s, Mvs.add v i m)) (0,Svs.empty,Mvs.empty) vl in aux (ivs,ivm) qvl [] [] [] let make_induction_lex lexl rql t = let make_h v vset timp = Svs.fold (fun x timp -> let t = t_subst_single v.vs (t_var x) t in let t = t_forall_close v.rq [] t in Term.t_implies t timp) vset timp in let rec aux lexl timp = match lexl with | [] -> timp | v :: vl -> let tbl = List.map (fun (pat, vset) -> let timp = (make_h v vset timp) in t_close_branch pat (aux vl timp)) v.ts in let t = t_case (t_var v.vs) tbl in let t = t_forall_close (v.lq @ [v.vs]) [] t in t in aux lexl (t_forall_close rql [] t) let induction_ty_lex km t0 = let qvs, qvl, t = decompose_forall t0 in let lblvl = qvl_labeled qvl in let vset = t_candidates_lex km qvs lblvl t in let vl = heuristic_lex vset in let lexl, rightmost_qvl = qsplit km vl qvl in let tcase = make_induction_lex lexl rightmost_qvl t in if Debug.test_flag debug then begin print_vset vset; print_heuristic_lex vl; print_lex lexl; Format.printf "Old Task: %a \n@." Pretty.print_term t0; Format.printf "New Task: %a \n@." Pretty.print_term tcase end; [tcase] let induction_ty_lex task = match task with | Some { task_decl = { td_node = Decl { d_node = Dprop (Pgoal, pr, f) } }; task_prev = prev; task_known = km } -> begin try let l = induction_ty_lex km f in List.map (add_prop_decl prev Pgoal pr) l with No_candidates_found -> Format.eprintf "induction_ty_lex: no candidate variable found in goal %a@." Pretty.print_pr pr; [task] end | _ -> assert false let () = Trans.register_transform_l "induction_ty_lex" (Trans.store induction_ty_lex) ~desc:"Generate@ induction@ hypotheses@ for@ goals@ over@ algebraic@ types." (***************************************************************************) (********************** INDUCTION TACTIC FOR INTEGERS **********************) (*************************** WITH LEX. ORDER ***************************) (***************************************************************************) (* induction_int_lex : induction tactic for ordered int tuples. No heuristic is provided. Use labels. Generalized variables inside the induction hypothesis are the variables on the right of the rightmost induction variable.*) (* separate prenex universal quantification from the body of the formula*) (* dead code let decompose_int_forall t = let rec aux qvl_acc t = match t.t_node with | Tquant (Tforall, qt) -> let qvl, _, t = t_open_quant qt in aux (qvl_acc @ qvl) t | _ -> qvl_acc, t in aux [] t *) (* find labeled variables (for induction variables), and the rest of the quantified variables after the last labeled variable (for the variables to generalize inside induction hypothesis). Ex: the result of Va.x1.b.x2.c.x3.d.P is [a.x1.b.x2.c.x3][x1.x2.x3][d]*) (* dead code let split_int_qlv_labeled qvl = let rec aux left_acc ind_acc gen_acc = function | [] -> List.rev left_acc, List.rev ind_acc, gen_acc | v :: tl -> let lbls = Slab.filter (fun v -> v.lab_string = "induction") v.vs_name.id_label in if not (Slab.is_empty lbls) then aux (v :: (gen_acc @ left_acc)) (v :: ind_acc) [] tl else aux left_acc ind_acc (v :: gen_acc) tl in aux [] [] [] qvl *) (* input: ordered induction variables, rightmost neutral variables output: new variables for rightmost neutral variables (generalization), new variabkes for induction hypothesis and the complete condition for induction variable non-negativeness and lexicographic order. For instance, if input: ivl = (x1,x2); rvl = (d,e) then output: (d',e') ~ 'generalization variables', (x1',x2',x3') ~ 'induction variables' (0 <= x1'/\0 <= x2'/\(x1' < x1 \/ x1' = x1 /\ x2' < x2) ~ 'hyp. condition' *) (* dead code let lex_order_ivl (le_int,lt_int) ivl rvl = let gen_rvl, (hd,hd',tl,tl') = let create_v v = Term.create_vsymbol (Ident.id_clone v.vs_name) ty_int in match (ivl, List.map create_v ivl) with | v :: tl, v':: tl' -> ((List.map create_v rvl), (v, v', tl, tl')) | _ -> assert false in let nonneg_ivl' = let positive v = ps_app le_int [t_nat_const 0; t_var v] in List.fold_left (fun t v -> t_and t (positive v)) (positive hd') tl' in let lt_lex = let lt_hd = ps_app lt_int [t_var hd'; t_var hd] in let eq_on_left (x, x', left, left') = let teq = t_equ (t_var x) (t_var x') in List.fold_left2 (fun t x x' -> t_and t (t_equ (t_var x) (t_var x'))) teq left left' in let rec lex_ord (hd, hd', left, left') acc_or = function | [],[] -> acc_or | v :: tl, v' :: tl' -> let v_eql = eq_on_left (hd, hd', left, left') in let v_lt = ps_app lt_int [t_var v'; t_var v] in lex_ord (v, v', hd :: left, hd' :: left') (t_or acc_or (t_and v_eql v_lt)) (tl,tl') | _ -> assert false in lex_ord (hd, hd', [],[]) lt_hd (tl, tl') in gen_rvl, (hd' :: tl'), t_and nonneg_ivl' lt_lex *) (*returns the resulting formula with induction hypothesis. The formula however is still not closed (by the quantifiers before the rightmost neutral quantifiers). *) (* dead code let int_strong_induction_lex (le_int,lt_int) ivl rvl t = let (gen_rvl, ind_ivl, hyp_cond) = lex_order_ivl (le_int,lt_int) ivl rvl in let hyp_goal = List.fold_left2 (fun t x x' -> t_subst_single x (t_var x') t) t (ivl @ rvl) (ind_ivl @ gen_rvl) in let ind_hyp = t_forall_close (ind_ivl @ gen_rvl) [] (t_implies hyp_cond hyp_goal) in let open_t = t_implies ind_hyp (t_forall_close rvl [] t) in open_t *) (* dead code let induction_int_lex _km (le_int,lt_int) t0 = let qvl, t = decompose_int_forall t0 in let lvl,ivl, genl = split_int_qlv_labeled qvl in if (ivl = []) then [t0] else begin let t = int_strong_induction_lex (le_int,lt_int) ivl genl t in let t = t_forall_close lvl [] t in if Debug.test_flag debug then (Format.printf "Old Task: %a \n@." Pretty.print_term t0; Format.printf "New Task: %a \n@." Pretty.print_term t); [t] end *) (* dead code let induction_int_lex th_int = function | Some { task_decl = { td_node = Decl { d_node = Dprop (Pgoal, pr, f) } }; task_prev = prev; task_known = km } as t -> begin try let le_int = ns_find_ls th_int.th_export ["infix <="] in let lt_int = ns_find_ls th_int.th_export ["infix <"] in if not (Mid.mem le_int.ls_name km) then raise Exit; List.map (add_prop_decl prev Pgoal pr) (induction_int_lex km (le_int, lt_int) f) with Exit -> [t] end | _ -> assert false *) (* let () = Trans.register_env_transform_l "induction_int_lex" (fun env -> let th_int = Env.find_theory env ["int"] "Int" in Trans.store (induction_int_lex th_int)) ~desc:"Generate@ induction@ hypotheses@ for@ goals@ over@ integers." *) (* Local Variables: compile-command: "unset LANG; make -C ../.. bin/why3.byte" End: *) why3-0.88.3/src/transform/encoding_twin.mli0000664000175100017510000000130713225666037021411 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) why3-0.88.3/src/transform/encoding_tags_full.ml0000664000175100017510000001072113225666037022237 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** transformation from polymorphic logic to many-sorted logic *) (** an implementation of "decoration" encoding Dec() from Bobot and Paskevich, Expressing Polymorphic Types in a Many-Sorted Language, FroCoS 2011, LNCS 6989, 87-102, and before that, Couchot and Lescuyer, Handling polymorphism in automated deduction, 2007, CADE-21, LNCS 4603. Referred to as "traditional tags" encoding t in Blanchette et al., Encoding monomorphic and polymorphic types, TACAS 2013, LNCS 7795. *) open Stdlib open Ident open Ty open Term open Decl open Libencoding (* From Encoding Polymorphism CADE07*) (* polymorphic decoration function *) let ls_poly_deco = let tyvar = ty_var (create_tvsymbol (id_fresh "a")) in create_fsymbol (id_fresh "sort") [ty_type;tyvar] tyvar let decorate tvar t = let tty = term_of_ty tvar (t_type t) in t_app ls_poly_deco [tty;t] t.t_ty let deco_term kept tvar = let rec deco t = match t.t_node with | Tvar v -> if is_protected_vs kept v then t else decorate tvar t | Tapp (ls,_) when ls.ls_value <> None && not (is_protected_ls kept ls) -> decorate tvar (expl t) | Tconst _ -> if Sty.mem (t_type t) kept then t else decorate tvar t | Teps tb -> let v,f,close = t_open_bound_cb tb in let t = t_eps (close v (deco f)) in if is_protected_vs kept v then t else decorate tvar t | _ -> expl t and expl t = match t.t_node with | Tlet (t1,tb) -> let v,e,close = t_open_bound_cb tb in t_let (expl t1) (close v (deco e)) | _ -> t_map deco t in deco let deco_decl kept d = match d.d_node with | Dtype { ts_def = Alias _ } -> [] | Dtype ts -> [d; lsdecl_of_ts ts] | Ddata _ -> Printer.unsupportedDecl d "Algebraic types are not supported, run eliminate_algebraic" | Dparam _ -> [d] | Dlogic [ls,ld] when not (Sid.mem ls.ls_name d.d_syms) -> let f = t_type_close (deco_term kept) (ls_defn_axiom ld) in defn_or_axiom ls f | Dlogic _ -> Printer.unsupportedDecl d "Recursively-defined symbols are not supported, run eliminate_recursion" | Dind _ -> Printer.unsupportedDecl d "Inductive predicates are not supported, run eliminate_inductive" | Dprop (k,pr,f) -> [create_prop_decl k pr (t_type_close (deco_term kept) f)] let d_poly_deco = create_param_decl ls_poly_deco let deco_init = let init = Task.add_decl None d_ts_type in let init = Task.add_decl init d_poly_deco in init let deco kept = Trans.decl (deco_decl kept) deco_init (** Monomorphisation *) let ts_base = create_tysymbol (id_fresh "uni") [] NoDef let ty_base = ty_app ts_base [] let ts_deco = create_tysymbol (id_fresh "deco") [] NoDef let ty_deco = ty_app ts_deco [] let ls_deco = create_fsymbol (id_fresh "sort") [ty_type;ty_base] ty_deco (* monomorphise a logical symbol *) let lsmap kept = Hls.memo 63 (fun ls -> if ls_equal ls ls_poly_deco then ls_deco else let prot_arg = is_protecting_id ls.ls_name in let prot_val = is_protected_id ls.ls_name in let neg ty = if prot_arg && Sty.mem ty kept then ty else ty_deco in let pos ty = if prot_val && Sty.mem ty kept then ty else ty_base in let tyl = List.map neg ls.ls_args in let tyr = Opt.map pos ls.ls_value in if Opt.equal ty_equal tyr ls.ls_value && List.for_all2 ty_equal tyl ls.ls_args then ls else create_lsymbol (id_clone ls.ls_name) tyl tyr) let mono_init = let init = Task.add_decl None (create_ty_decl ts_base) in let init = Task.add_decl init (create_ty_decl ts_deco) in init let mono kept = let kept = Sty.add ty_type kept in Trans.decl (d_monomorph ty_base kept (lsmap kept)) mono_init let t = Trans.on_tagged_ty Libencoding.meta_kept (fun kept -> Trans.compose (deco kept) (mono kept)) let () = Hstr.replace Encoding.ft_enco_poly "tags_full" (Util.const t) why3-0.88.3/src/transform/reduction_engine.mli0000664000175100017510000000574213225666037022112 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** A reduction engine for Why3 terms *) (* terms are normalized with respect to 1) built-in computation rules a) on propositional connectives, e.g. f /\ true -> f b) on integers, e.g. 35 + 7 -> 42 c) on projections of pairs and of other ADTs, e.g fst (x,y) -> x cdr (Cons x y) -> y d) on defined function symbols, e.g. function sqr (x:int) = x * x sqr 4 -> 4 * 4 -> 16 sqr x -> x * x e) (TODO?) on booleans, e.g. True xor False -> True f) (TODO?) on reals, e.g. 1.0 + 2.5 -> 3.5 2) axioms declared as rewrite rules, thanks to the "rewrite" metas, e.g. if function dot : t -> t -> t axiom assoc: forall x y z, dot (dot x y) z = dot x (dot y z) meta "rewrite" assoc then dot (dot a b) (dot c d) -> dot a (dot b (dot c d)) axioms used as rewrite rules must be either of the form forall ... t1 = t2 or forall ... f1 <-> f2 where the root symbol of t1 (resp. f1) is a non-interpreted function symbol (resp. non-interpreted predicate symbol) rewriting is done from left to right *) type engine (** abstract type for reduction engines *) type params = { compute_defs : bool; compute_builtin : bool; compute_def_set : Term.Sls.t; } (** Configuration of the engine. . [compute_defs]: if set to true, automatically compute symbols using known definitions. Otherwise, only symbols in [compute_def_set] will be computed. . [compute_builtin]: if set to true, compute builtin functions. *) val create : params -> Env.env -> Decl.decl Ident.Mid.t -> engine (** [create env known_map] creates a reduction engine with . builtins theories (int.Int, etc.) extracted from [env] . known declarations from [known_map] . empty set of rewrite rules *) exception NotARewriteRule of string val add_rule : Term.term -> engine -> engine (** [add_rule t e] turns [t] into a new rewrite rule and returns the new engine. raise NotARewriteRule if [t] cannot be seen as a rewrite rule according to the general rules given above. *) val normalize : limit:int -> engine -> Term.term -> Term.term (** [normalize e t] normalizes the term [t] with respect to the engine [e] parameter [limit] provides a maximum number of steps for execution. When limit is reached, the partially reduced term is returned. *) why3-0.88.3/src/transform/eliminate_algebraic.mli0000664000175100017510000000264613225666037022531 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) val compile_match : Task.task Trans.trans val meta_proj : Theory.meta (* [MTlsymbol; MTlsymbol; MTint; MTprsymbol] *) (* projection symbol, constructor symbol, position, defining axiom *) (* a type constructor generates an infinite type if either it is tagged by meta_infinite or one of its "material" arguments is an infinite type *) val meta_infinite : Theory.meta (* [MTtysymbol] *) val meta_material : Theory.meta (* [MTtysymbol; MTint] *) (* extracts the material type arguments from [meta_material] *) val get_material_args : Theory.meta_arg list list -> bool list Ty.Mts.t (* tests if a type is infinite given [meta_infinite] and [meta_material] *) val is_infinite_ty : Ty.Sts.t -> bool list Ty.Mts.t -> (Ty.ty -> bool) why3-0.88.3/src/transform/add_name_traceability_labels.ml0000664000175100017510000001100713225666037024215 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (* The transformation that adds labels with information needed for traceability from the names in the Why output to names in the Why input (more precisely to the names that are present at the time this transformation is run). This transformation should be called on the AST corresponding to the Why input. For each element it adds the label with the information about the name of the element. *) open Term open Ident open Format let debug = Debug.register_info_flag "add_name_traceability" ~desc:"Print@ debugging@ messages@ about@ adding@ traceability@ labels." let term2string_experimental t = (* TODO: Pretty.print_term prints also labels + it generates unique identifiers when printing *) Pretty.print_term str_formatter t; flush_str_formatter () (* TODO: should print the term *) let term2string t = "term" let create_traceability_label str = Ident.create_label ("model_trace:"^str) let create_traceability_identifier ident = id_clone ~label:(Slab.singleton (create_traceability_label ident.id_string)) ident (*Adds name traceability label to the list of terms. *) let rec add_traceability_label_list terms collected_terms = match terms with | [] -> List.rev collected_terms | t::tail -> let t_traceable = add_traceability_label t in add_traceability_label_list tail (t_traceable::collected_terms) (* Adds name traceability label to the term. *) and add_traceability_label t = let term = match t.t_node with |Tvar v -> Debug.dprintf debug "Adding traceability labels: variable@."; let vs_name_t = create_traceability_identifier v.vs_name in Debug.dprintf debug "Creating vsymbol@."; let v_t = create_vsymbol vs_name_t v.vs_ty in Debug.dprintf debug "Creating t_var@."; (* TODO: The following does not work - investigate. *) (* t_var v_t *) t_var v | Tapp (l_symb, terms) -> Debug.dprintf debug "Adding traceability labels: Tapp@."; let l_symb_name = create_traceability_identifier l_symb.ls_name in let l_symb_t = create_lsymbol l_symb_name l_symb.ls_args l_symb.ls_value in let terms_t = add_traceability_label_list terms [] in t_app l_symb terms_t t.t_ty | Tif (t1, t2, t3) -> Debug.dprintf debug "Adding traceability labels: Tif@."; let t1t = add_traceability_label t1 in let t2t = add_traceability_label t2 in let t3t = add_traceability_label t3 in t_if t1t t2t t3t | Tlet (t, t_bound) -> Debug.dprintf debug "Adding traceability labels: Tlet@."; let tt = add_traceability_label t in let vs_bound, term_bound = t_open_bound t_bound in let vs_boundt = vs_bound in (* TODO *) let term_boundt = add_traceability_label term_bound in let t_boundt = t_close_bound vs_boundt term_boundt in t_let tt t_boundt | Tcase (t, tbs) -> (* TODO *) t | Teps tb -> (* TODO *) t | Tquant (q, fq) -> let vl, tl, f = t_open_quant fq in let ft = add_traceability_label f in (* TODO tl, vl *) t_quant_close q vl tl ft | Tbinop (op, f1, f2) -> Debug.dprintf debug "Adding traceability labels: binary operation@."; let f1_t = add_traceability_label f1 in let f2_t = add_traceability_label f2 in t_binary op f1_t f2_t | Tnot t -> (* TODO *) t | _ -> Debug.dprintf debug "Adding traceability labels: unsupported term@."; t in let term = t_label_copy t term in Debug.dprintf debug "Adding label to toplevel term@."; t_label_add (create_traceability_label (term2string t)) term let add_traceability_labels = Trans.rewrite add_traceability_label None let () = Trans.register_transform "add_name_traceability_labels" add_traceability_labels ~desc:"Add@ labels@ to@ terms@ used@ in@ counterexample@ report@ holding information@ needed@ for@ traceability@ of@ identifiers'@ names."; why3-0.88.3/src/transform/encoding_select.ml0000664000175100017510000000736113225666037021544 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Stdlib open Ty open Term open Decl open Theory open Task open Encoding open Discriminate let register pr l = List.iter (fun (n,f) -> Hstr.replace pr n (Util.const f)) l let register pr none goal all = register pr ["none",none; "goal",goal; "all",all] (** {2 select Kept} *) let trans_on_goal fn = Trans.store (function | Some { task_decl = { td_node = Decl { d_node = Dprop (_,_,f) }}} -> fn f | _ -> assert false) module Kept = struct (* we ignore the type of the result as we are only interested in application arguments *) let add_kept sty _ls tyl _tyv = let add sty ty = if ty_closed ty then Sty.add ty sty else sty in List.fold_left add sty tyl let add_kept = t_app_fold add_kept let all_kept task sty = match task.task_decl.td_node with | Decl d -> decl_fold add_kept sty d | _ -> sty let kept_none = Trans.return Sty.empty let kept_goal = trans_on_goal (add_kept Sty.empty) let kept_all = Trans.fold all_kept Sty.empty let () = register ft_select_kept kept_none kept_goal kept_all let () = register ft_select_inst kept_none kept_goal kept_all end (** {2 select Lskept} *) module Lskept = struct let add_lskept sls ls = (* We require that every freely standing type variable occurs under a type constructor elsewhere in the lsymbol's signature. Thus we bound the (lskept * inst) product and avoid explosion. *) let ls_sig = oty_cons ls.ls_args ls.ls_value in let add_ty_t s ty = match ty.ty_node with | Tyapp _ -> ty_freevars s ty | _ -> s in let ls_tvs_t = List.fold_left add_ty_t Stv.empty ls_sig in if Stv.is_empty ls_tvs_t then sls else let add_ty_v s ty = match ty.ty_node with | Tyvar v -> Stv.add v s | _ -> s in let ls_tvs_v = List.fold_left add_ty_v Stv.empty ls_sig in if Stv.subset ls_tvs_v ls_tvs_t then Sls.add ls sls else sls let all_lskept task sls = match task.task_decl.td_node with | Decl { d_node = Dparam ls } -> add_lskept sls ls | Decl { d_node = Dlogic l } -> List.fold_left (fun sls (ls,_) -> add_lskept sls ls) sls l | _ -> sls let add_lskept = t_app_fold (fun sls ls _ _ -> add_lskept sls ls) let lskept_none = Trans.return Sls.empty let lskept_goal = trans_on_goal (add_lskept Sls.empty) let lskept_all = Trans.fold all_lskept Sls.empty let () = register ft_select_lskept lskept_none lskept_goal lskept_all end (** {2 select Lsinst} *) module Lsinst = struct let add_lsinst mls ls tyl tyv = if ls_equal ls ps_equ || List.for_all ty_closed (oty_cons ls.ls_args ls.ls_value) || List.exists (fun ty -> not (ty_closed ty)) (oty_cons tyl tyv) then mls else Lsmap.add ls tyl tyv mls let add_lsinst mls t = t_app_fold add_lsinst mls t let all_lsinst task mls = match task.task_decl.td_node with | Decl d -> decl_fold add_lsinst mls d | _ -> mls let lsinst_none = Trans.return Lsmap.empty let lsinst_goal = trans_on_goal (add_lsinst Lsmap.empty) let lsinst_all = Trans.fold all_lsinst Lsmap.empty let () = register ft_select_lsinst lsinst_none lsinst_goal lsinst_all end why3-0.88.3/src/transform/libencoding.mli0000664000175100017510000000525713225666037021047 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Ty open Term open Decl val debug : Debug.flag (* meta to tag the protected types *) val meta_kept : Theory.meta (* meta to tag the custom base type *) val meta_base : Theory.meta (* sort symbol of (polymorphic) types *) val ts_type : tysymbol (* sort of (polymorphic) types *) val ty_type : ty (* ts_type declaration *) val d_ts_type : decl (* function symbol mapping ty_type^n to ty_type *) val ls_of_ts : tysymbol -> lsymbol (* convert a type to a term of type ty_type *) val term_of_ty : term Mtv.t -> ty -> term (* add type args to the signature of a polymorphic lsymbol *) val ls_extend : lsymbol -> lsymbol (* rewrite a closed formula modulo the given free typevars *) val type_close : Stv.t -> (term Mtv.t -> 'a -> term) -> 'a -> term (* rewrite a closed formula modulo its free typevars *) val t_type_close : (term Mtv.t -> term -> term) -> term -> term (* convert a type declaration to a lsymbol declaration *) val lsdecl_of_ts : tysymbol -> decl (* a pre-id for vsymbols and lsymbols that produce non-kept values *) val id_unprotected : string -> Ident.preid val is_protected_id : Ident.ident -> bool (* a pre-id for lsymbols that treat their arguments as non-kept *) val id_unprotecting : string -> Ident.preid val is_protecting_id : Ident.ident -> bool (* the value type is in kept and the ident is not unprotected *) val is_protected_vs : Sty.t -> vsymbol -> bool val is_protected_ls : Sty.t -> lsymbol -> bool (* monomorphise wrt the base type, the set of kept types, and a symbol map *) val d_monomorph : ty -> Sty.t -> (lsymbol -> lsymbol) -> decl -> decl list (* replace all non-kept types with ty_base *) val monomorphise_task : Task.task Trans.trans (* replace type variables in a goal with fresh type constants *) val monomorphise_goal : Task.task Trans.trans (* close by subtype the set of types tagged by meta_kept *) val close_kept : Task.task Trans.trans (* reconstruct a definition of an lsymbol or make a defining axiom *) val defn_or_axiom : lsymbol -> term -> decl list why3-0.88.3/src/transform/close_epsilon.mli0000664000175100017510000000226513225666037021424 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** The aim of this translation is to obtain terms where all epsilon abstractions are closed *) (** We do this by applying the following rewriting rule: eps x.P(x) => eps F.(P(F@y_1@...@y_n)) where y_1...y_n are the free variables in P and @ is the higher-order application symbol. *) open Term type lambda_match = | Flam of vsymbol list * trigger * term | Tlam of vsymbol list * trigger * term | LNone val destruct_lambda : term -> lambda_match val is_lambda : term -> bool why3-0.88.3/src/transform/encoding_tags.mli0000664000175100017510000000130713225666037021366 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) why3-0.88.3/src/transform/compute.ml0000664000175100017510000000762313225666037020074 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Term open Decl open Task open Theory open Reduction_engine let meta_rewrite = Theory.register_meta "rewrite" [Theory.MTprsymbol] ~desc:"Declares@ the@ given@ proposition@ as@ a@ rewrite@ rule." let meta_rewrite_def = Theory.register_meta "rewrite_def" [Theory.MTlsymbol] ~desc:"Declares@ the@ definition@ of@ the@ symbol@ as@ a@ rewrite@ rule." let meta_compute_max_steps = Theory.register_meta_excl "compute_max_steps" [Theory.MTint] ~desc:"Maximal@ number@ of@ reduction@ steps@ done@ by@ compute@ \ transformation" let compute_max_steps = ref 1024 (* not yet used let meta_begin_compute_context = Theory.register_meta "begin_compute_context" [] ~desc:"Marks@ the@ position@ where@ computations@ are@ done@ by@ \ transformation@ 'compute_in_context'." *) let rule_label = Ident.create_label "rewrite" let collect_rules p env km prs t = let acc = Task.task_fold (fun acc td -> match td.Theory.td_node with | Theory.Decl { d_node = Dprop((Plemma|Paxiom), pr, t) } when Decl.Spr.mem pr prs || Ident.Slab.mem rule_label pr.pr_name.Ident.id_label || Ident.Slab.mem rule_label t.t_label -> (pr,t) :: acc | _ -> acc) [] t in List.fold_left (fun e (pr,t) -> try add_rule t e with NotARewriteRule msg -> Warning.emit "proposition %a cannot be turned into a rewrite rule: %s" Pretty.print_pr pr msg; e ) (create p env km) acc let normalize_goal p env (prs : Decl.Spr.t) task = match task with | Some { task_decl = { td_node = Decl { d_node = Dprop (Pgoal, pr, f) } }; task_prev = prev; task_known = km; } -> let engine = collect_rules p env km prs task in let f = normalize ~limit:!compute_max_steps engine f in begin match f.t_node with | Ttrue -> [] | _ -> let d = Decl.create_prop_decl Pgoal pr f in [Task.add_decl prev d] end | _ -> assert false let normalize_goal_transf p env : 'a Trans.trans = let tr : 'a Trans.trans = Trans.on_tagged_pr meta_rewrite (fun prs -> if p.compute_defs then Trans.store (normalize_goal p env prs) else Trans.on_tagged_ls meta_rewrite_def (fun lss -> let p = { p with compute_def_set = lss } in Trans.store (normalize_goal p env prs) )) in Trans.on_meta_excl meta_compute_max_steps (function | None -> tr | Some [Theory.MAint n] -> compute_max_steps := n; tr | _ -> assert false) let normalize_goal_transf_all env = let p = { compute_defs = true; compute_builtin = true; compute_def_set = Term.Mls.empty; } in normalize_goal_transf p env let normalize_goal_transf_few env = let p = { compute_defs = false; compute_builtin = true; compute_def_set = Term.Mls.empty; } in normalize_goal_transf p env let () = Trans.register_env_transform_l "compute_in_goal" normalize_goal_transf_all ~desc:"Performs@ possible@ computations@ in@ goal, including@ by@ \ declared@ rewrite@ rules" let () = Trans.register_env_transform_l "compute_specified" normalize_goal_transf_few ~desc:"Rewrite@ goal@ using@ specified@ rules" why3-0.88.3/src/transform/eliminate_literal.ml0000664000175100017510000001715613225666037022105 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Ident open Ty open Term open Decl open Theory let meta_keep_lit = register_meta "literal:keep" [MTtysymbol] ~desc:"Preserve@ literals@ of@ a@ given@ type." let add_literal (known_lit, decl as acc) t c ls_proj fin = try acc, Mterm.find t known_lit with Not_found -> (* TODO: pretty-print the constant to have a readable name *) let litname = match fin with None -> "rliteral" | _ -> "fliteral" in let ls = create_lsymbol (id_fresh litname) [] t.t_ty in let ls_decl = create_param_decl ls in let pr = create_prsymbol (id_fresh (litname^"_axiom")) in let ls_t = t_app ls [] t.t_ty in let f = t_app ls_proj [ls_t] ls_proj.ls_value in let f = t_equ f (t_const c (Opt.get f.t_ty)) in let f = match fin with | None -> f | Some isF -> t_and (t_app isF [ls_t] None) f in let ax_decl = create_prop_decl Paxiom pr f in let decl = ax_decl::ls_decl::decl in (Mterm.add t ls_t known_lit, decl), ls_t (* TODO: remove int and real literals if not supported. NOTE: in this case, [add_literal] above is incorrect. *) let rec abstract_terms kn range_metas float_metas type_kept acc t = match t.t_node, t.t_ty with | Tconst (Number.ConstInt _ as c), Some {ty_node = Tyapp (ts,[])} when not (ts_equal ts ts_int || Sts.mem ts type_kept) -> let to_int = Mts.find ts range_metas in add_literal acc t c to_int None | Tconst (Number.ConstReal _ as c), Some {ty_node = Tyapp (ts,[])} when not (ts_equal ts ts_real || Sts.mem ts type_kept) -> let to_real,isF = Mts.find ts float_metas in add_literal acc t c to_real (Some isF) | _ -> t_map_fold (abstract_terms kn range_metas float_metas type_kept) acc t let elim le_int le_real neg_real type_kept kn range_metas float_metas d (known_lit,task) = match d.d_node with | Dtype ts when Mts.exists (fun ts' _ -> ts_equal ts ts') range_metas && not (Sts.mem ts type_kept) -> let to_int = Mts.find ts range_metas in let ir = match ts.ts_def with Range ir -> ir | _ -> assert false in let lo = Number.int_const_dec (BigInt.to_string ir.Number.ir_lower) in let hi = Number.int_const_dec (BigInt.to_string ir.Number.ir_upper) in let ty_decl = create_ty_decl ts in let ls_decl = create_param_decl to_int in let pr = create_prsymbol (id_fresh (ts.ts_name.id_string ^ "'axiom")) in let v = create_vsymbol (id_fresh "i") (ty_app ts []) in let v_term = t_app to_int [t_var v] (Some ty_int) in let a_term = t_const (Number.ConstInt lo) ty_int in let b_term = t_const (Number.ConstInt hi) ty_int in let f = t_and (t_app le_int [a_term; v_term] None) (t_app le_int [v_term; b_term] None) in let f = t_forall_close [v] [] f in let ax_decl = create_prop_decl Paxiom pr f in (known_lit, List.fold_left Task.add_decl task [ty_decl; ls_decl; ax_decl]) | Dtype ts when Mts.exists (fun ts' _ -> ts_equal ts ts') float_metas && not (Sts.mem ts type_kept) -> let to_real,is_finite = Mts.find ts float_metas in let fp = match ts.ts_def with Float fp -> fp | _ -> assert false in let eb = BigInt.of_int fp.Number.fp_exponent_digits in let sb = BigInt.of_int fp.Number.fp_significand_digits in (* declare abstract type [t] *) let ty_decl = create_ty_decl ts in (* declare projection to_real *) let proj_decl = create_param_decl to_real in (* declare predicate is_finite *) let isFinite_decl = create_param_decl is_finite in (* create defining axiom *) (* [forall v:t. is_finite v -> | to_real v | <= max] *) let pr = create_prsymbol (id_fresh (ts.ts_name.id_string ^ "'axiom")) in let v = create_vsymbol (id_fresh "x") (ty_app ts []) in let v_term = t_app to_real [t_var v] (Some ty_real) in (* compute max *) let emax = BigInt.pow_int_pos_bigint 2 (BigInt.pred eb) in let m = BigInt.pred (BigInt.pow_int_pos_bigint 2 sb) in let e = BigInt.sub emax sb in Number.print_in_base 16 None Format.str_formatter m; let m_string = Format.flush_str_formatter () in Number.print_in_base 10 None Format.str_formatter e; let e_string = Format.flush_str_formatter () in let max_term = t_const (Number.ConstReal (Number.real_const_hex m_string "" (Some e_string))) ty_real in (* compose axiom *) let f = t_and (t_app le_real [t_app neg_real [max_term] (Some ty_real); v_term] None) (t_app le_real [v_term; max_term] None) in (* t_app le_real [t_app abs_real [v_term] (Some ty_real); term] None in *) let f = t_implies (t_app is_finite [t_var v] None) f in let f = t_forall_close [v] [] f in let ax_decl = create_prop_decl Paxiom pr f in (known_lit, List.fold_left Task.add_decl task [ty_decl; proj_decl; isFinite_decl; ax_decl]) | _ -> let (known_lit, local_decl), d = decl_map_fold (abstract_terms kn range_metas float_metas type_kept) (known_lit,[]) d in let t = List.fold_left Task.add_decl task (List.rev local_decl) in (known_lit, Task.add_decl t d) let eliminate le_int le_real neg_real type_kept range_metas float_metas t (known_lit, acc) = match t.Task.task_decl.td_node with | Decl d -> elim le_int le_real neg_real type_kept t.Task.task_known range_metas float_metas d (known_lit, acc) | Meta (m, [MAts ts]) when meta_equal m meta_keep_lit -> let td = create_meta Libencoding.meta_kept [MAty (ty_app ts [])] in let acc = Task.add_tdecl acc t.Task.task_decl in known_lit, Task.add_tdecl acc td | Use _ | Clone _ | Meta _ -> known_lit, Task.add_tdecl acc t.Task.task_decl let eliminate_literal env = (* FIXME: int.Int.le_sym should be imported in the task *) let th = Env.read_theory env ["int"] "Int" in let le_int = ns_find_ls th.th_export ["infix <="] in let th = Env.read_theory env ["real"] "Real" in let le_real = ns_find_ls th.th_export ["infix <="] in let neg_real = ns_find_ls th.th_export ["prefix -"] in Trans.on_meta meta_range (fun range_metas -> Trans.on_meta meta_float (fun float_metas -> let range_metas = List.fold_left (fun acc meta_arg -> match meta_arg with | [MAts ts; MAls to_int] -> Mts.add ts to_int acc | _ -> assert false) Mts.empty range_metas in let float_metas = List.fold_left (fun acc meta_arg -> match meta_arg with | [MAts ts; MAls to_real; MAls is_finite] -> Mts.add ts (to_real,is_finite) acc | _ -> assert false) Mts.empty float_metas in Trans.on_tagged_ts meta_keep_lit (fun type_kept -> Trans.fold_map (eliminate le_int le_real neg_real type_kept range_metas float_metas) Mterm.empty None))) let () = Trans.register_env_transform "eliminate_literal" eliminate_literal ~desc:"Eliminate@ unsupported@ literals." why3-0.88.3/src/transform/discriminate.ml0000664000175100017510000003422013225666037021064 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Stdlib open Ident open Ty open Term open Decl open Theory open Task let meta_inst = register_meta "encoding : inst" [MTty] ~desc:"Specify@ which@ types@ should@ instantiate@ symbols@ marked@ by@ \ 'encoding : lskept'." let meta_lskept = register_meta "encoding : lskept" [MTlsymbol] ~desc:"Specify@ which@ function/predicate@ symbols@ should@ be@ kept.@ \ When@ the@ symbol@ is@ polymorphic,@ generate@ every@ possible@ \ type@ instances@ with@ types@ marked@ by@ 'encoding : inst'." let meta_lsinst = register_meta "encoding : lsinst" [MTlsymbol;MTlsymbol] ~desc:"Specify@ which@ type@ instances@ of@ symbols@ should@ be@ kept.@ \ The first@ symbol@ specifies@ the@ polymorphic@ symbol,@ \ the@ second@ provides@ a@ monomorphic@ type@ signature@ to@ keep." let meta_select_inst = register_meta_excl "select_inst" [MTstring] ~desc:"Specify@ the@ types@ to@ mark@ with@ 'encoding : inst':@; \ @[\ - none: @[don't@ mark@ any@ type@ automatically@]@\n\ - goal: @[mark@ every@ closed@ type@ in@ the@ goal@]@\n\ - all: @[mark@ every@ closed@ type@ in@ the@ task.@]\ @]" let meta_select_lskept = register_meta_excl "select_lskept" [MTstring] ~desc:"Specify@ the@ symbols@ to@ mark@ with@ 'encoding : lskept':@; \ @[\ - none: @[don't@ mark@ any@ symbol@ automatically@]@\n\ - goal: @[mark@ every@ polymorphic@ symbol@ in@ the@ goal@]@\n\ - all: @[mark@ every@ polymorphic@ symbol@ in@ the@ task.@]\ @]" let meta_select_lsinst = register_meta_excl "select_lsinst" [MTstring] ~desc:"Specify@ the@ symbols@ to@ mark@ with@ 'encoding : lsinst':@; \ @[\ - none: @[don't@ mark@ any@ symbol@ automatically@]@\n\ - goal: @[mark@ every@ monomorphic@ instance@ in@ the@ goal@]@\n\ - all: @[mark@ every@ monomorphic@ instance@ in@ the@ task.@]\ @]" let meta_select_inst_default = register_meta_excl "select_inst_default" [MTstring] ~desc:"Default@ setting@ for@ select_inst" let meta_select_lskept_default = register_meta_excl "select_lskept_default" [MTstring] ~desc:"Default@ setting@ for@ select_lskept" let meta_select_lsinst_default = register_meta_excl "select_lsinst_default" [MTstring] ~desc:"Default@ setting@ for@ select_lsinst" module OHTy = OrderedHashed(struct type t = ty let tag = ty_hash end) module OHTyl = OrderedHashedList(struct type t = ty let tag = ty_hash end) module Mtyl = Extmap.Make(OHTyl) module Lsmap = struct (* TODO : transmettre les tags des logiques polymorphe vers les logiques instantié. Un tag sur un logique polymorphe doit être un tag sur toute la famille de fonctions *) let ls_inst = (* FIXME? Skolem type constants are short-living but will stay in lsmap as long as the lsymbol is alive *) let lsmap = Wls.memoize 63 (fun _ -> ref Mtyl.empty) in fun ls tyl tyv -> let m = lsmap ls in let l = oty_cons tyl tyv in match Mtyl.find_opt l !m with | Some ls -> ls | None -> let nls = create_lsymbol (id_clone ls.ls_name) tyl tyv in m := Mtyl.add l nls !m; nls type t = lsymbol Mtyl.t Mls.t let empty = Mls.empty let add ls tyl tyv lsmap = if ls_equal ls ps_equ then lsmap else if not (List.for_all Ty.ty_closed (oty_cons tyl tyv)) then lsmap else let newls = function | None -> Some (ls_inst ls tyl tyv) | nls -> nls in let insts = Mls.find_def Mtyl.empty ls lsmap in Mls.add ls (Mtyl.change newls (oty_cons tyl tyv) insts) lsmap (* dead code let print_env fmt menv = Format.fprintf fmt "defined_lsymbol (%a)@." (Pp.print_iter2 Mls.iter Pp.semi Pp.comma Pretty.print_ls (Pp.print_iter2 Mtyl.iter Pp.semi Pp.arrow (Pp.print_list Pp.space Pretty.print_ty) Pretty.print_ls)) menv *) (** From/To metas *) let metas lsmap = let fold_inst ls _ lsinst decls = create_meta meta_lsinst [MAls ls; MAls lsinst] :: decls in let fold_ls ls insts decls = Mtyl.fold (fold_inst ls) insts decls in Mls.fold fold_ls lsmap [] let of_metas metas = let fold env args = match args with | [MAls ls; MAls lsinst] -> let tydisl = oty_cons lsinst.ls_args lsinst.ls_value in if not (List.for_all Ty.ty_closed tydisl) then env else let insts = Mls.find_def Mtyl.empty ls env in Mls.add ls (Mtyl.add tydisl lsinst insts) env | _ -> assert false in List.fold_left fold Mls.empty metas end let find_logic env ls tyl tyv = if ls_equal ls ps_equ then ls else try Mtyl.find (oty_cons tyl tyv) (Mls.find ls env) with Not_found -> ls module Ssubst = Set.Make(struct type t = ty Mtv.t let compare = Mtv.compare OHTy.compare end) (* find all the possible instantiation which can create a kept instantiation *) let ty_quant env t = let add_vs acc0 ls tyl tyv = if ls_equal ls ps_equ then acc0 else try let insts = Mls.find ls env in let tyl = oty_cons tyl tyv in let fold_inst inst _ acc = let fold_subst subst acc = try let subst = List.fold_left2 ty_match subst tyl inst in Ssubst.add subst acc with TypeMismatch _ -> acc in (* fold on acc0 *) Ssubst.fold fold_subst acc0 acc in Mtyl.fold fold_inst insts acc0 with Not_found (* no such p *) -> acc0 in t_app_fold add_vs (Ssubst.singleton (Mtv.empty)) t let ts_of_ls env ls decls = if ls_equal ls ps_equ then decls else let add_ts sts ts = Sts.add ts sts in let add_ty sts ty = ty_s_fold add_ts sts ty in let add_tyl tyl _ sts = List.fold_left add_ty sts tyl in let insts = Mls.find_def Mtyl.empty ls env in let sts = Mtyl.fold add_tyl insts Sts.empty in let add_ts ts dl = create_ty_decl ts :: dl in Sts.fold add_ts sts decls (* The Core of the transformation *) let map metas_rewrite_pr env d = let decls,metas = match d.d_node with | Dtype _ -> [d],[] | Ddata _ -> Printer.unsupportedDecl d "Algebraic and recursively-defined types are \ not supported, run eliminate_algebraic" | Dparam ls -> let lls = Mtyl.values (Mls.find_def Mtyl.empty ls env) in let lds = List.map create_param_decl lls in ts_of_ls env ls (d::lds),[] | Dlogic [ls,ld] when not (Sid.mem ls.ls_name d.d_syms) -> let f = ls_defn_axiom ld in let substs = ty_quant env f in let conv_f tvar (defns,axioms) = let f = t_ty_subst tvar Mvs.empty f in let f = t_app_map (find_logic env) f in match ls_defn_of_axiom f with | Some ld -> create_logic_decl [ld] :: defns, axioms | None -> let nm = ls.ls_name.id_string ^ "_inst" in let pr = create_prsymbol (id_derive nm ls.ls_name) in defns, create_prop_decl Paxiom pr f :: axioms in let defns,axioms = Ssubst.fold conv_f substs ([],[]) in ts_of_ls env ls (List.rev_append defns axioms),[] | Dlogic _ -> Printer.unsupportedDecl d "Recursively-defined symbols are not supported, run eliminate_recursion" | Dind _ -> Printer.unsupportedDecl d "Inductive predicates are not supported, run eliminate_inductive" | Dprop (k,pr,f) -> let substs = ty_quant env f in let substs_len = Ssubst.cardinal substs in let conv_f tvar (task,metas) = (* Format.eprintf "f0 : %a@. env : %a@." Pretty.print_fmla *) (* (t_ty_subst tvar Mvs.empty f) *) (* print_env env; *) let f = t_ty_subst tvar Mvs.empty f in let f = t_app_map (find_logic env) f in (* Format.eprintf "f : %a@. env : %a@." Pretty.print_fmla f *) (* print_env menv; *) (* Format.eprintf "undef ls : %a, ts : %a@." *) (* (Pp.print_iter1 Sls.iter Pp.comma Pretty.print_ls) *) (* menv.undef_lsymbol *) (* (Pp.print_iter1 Sts.iter Pp.comma Pretty.print_ts) *) (* menv.undef_tsymbol; *) if substs_len = 1 then create_prop_decl k pr f :: task, metas else let pr' = create_prsymbol (id_clone pr.pr_name) in create_prop_decl k pr' f :: task, (if Spr.mem pr metas_rewrite_pr then create_meta Compute.meta_rewrite [MApr pr'] :: metas else metas) in Ssubst.fold conv_f substs ([],[]) in List.rev_append (List.rev_map create_decl decls) metas let ft_select_inst = ((Hstr.create 17) : (Env.env,Sty.t) Trans.flag_trans) let ft_select_lskept = ((Hstr.create 17) : (Env.env,Sls.t) Trans.flag_trans) let ft_select_lsinst = ((Hstr.create 17) : (Env.env,Lsmap.t) Trans.flag_trans) let metas_from_env env = let fold_inst tyl _ s = List.fold_left (fun s ty -> Sty.add ty s) s tyl in let fold_ls _ insts s = Mtyl.fold fold_inst insts s in let sty = Mls.fold fold_ls env Sty.empty in let add ty decls = create_meta Libencoding.meta_kept [MAty ty] :: decls in Sty.fold add sty (Lsmap.metas env) let inst_completion kn kept = let rec inst_constructors ty acc = match ty.ty_node with | Tyapp (ts,tyl) when not (Sty.mem ty acc) -> let acc = Sty.add ty acc in let tys = Sty.of_list tyl in let csl = Decl.find_constructors kn ts in let tys = if csl = [] then tys else let d = Mid.find ts.ts_name kn in let base = ty_app ts (List.map ty_var ts.ts_args) in let sbs = ty_match Mtv.empty base ty in let recu ts = Sid.mem ts.ts_name d.d_news in let add_fd tys ty = if ty_s_any recu ty then tys else Sty.add (ty_inst sbs ty) tys in let add_cs tys (cs,_) = List.fold_left add_fd tys cs.ls_args in List.fold_left add_cs tys csl in Sty.fold inst_constructors tys acc | _ -> acc in Sty.fold inst_constructors kept Sty.empty let lsinst_completion kept lskept env = let fold_ls ls env = let rec aux env tydisl subst = function | [] -> let tydisl = List.rev tydisl in let tyl,tyv = match tydisl, ls.ls_value with | tyv::tyl, Some _ -> tyl, Some tyv | tyl, None -> tyl, None | _ -> assert false in Lsmap.add ls tyl tyv env | ty::tyl -> let fold_ty tykept env = try let subst = ty_match subst ty tykept in aux env (tykept::tydisl) subst tyl with TypeMismatch _ -> env in Sty.fold fold_ty kept env in aux env [] Mtv.empty (oty_cons ls.ls_args ls.ls_value) in Sls.fold fold_ls lskept env let add_user_lsinst env = function | [MAls ls; MAls nls] -> Lsmap.add ls nls.ls_args nls.ls_value env | _ -> assert false let clear_metas = Trans.fold (fun hd task -> match hd.task_decl.td_node with | Meta (m,_) when meta_equal m meta_lsinst -> task | _ -> add_tdecl task hd.task_decl) None let select_lsinst env = let select m1 m2 ft = Trans.on_flag_t m1 ft (Trans.on_flag m2 ft "none") env in let inst = select meta_select_inst meta_select_inst_default ft_select_inst in let lskept = select meta_select_lskept meta_select_lskept_default ft_select_lskept in let lsinst = select meta_select_lsinst meta_select_lsinst_default ft_select_lsinst in let trans task = let inst = Trans.apply inst task in let lskept = Trans.apply lskept task in let lsinst = Trans.apply lsinst task in let inst = Sty.union inst (Task.on_tagged_ty meta_inst task) in let lskept = Sls.union lskept (Task.on_tagged_ls meta_lskept task) in let lsinst = Task.on_meta meta_lsinst add_user_lsinst lsinst task in let inst = inst_completion (Task.task_known task) inst in let lsinst = lsinst_completion inst lskept lsinst in let task = Trans.apply clear_metas task in Trans.apply (Trans.add_tdecls (metas_from_env lsinst)) task in Trans.store trans let lsymbol_distinction = Trans.on_meta meta_lsinst (fun metas -> if metas = [] then Trans.identity else let env = Lsmap.of_metas metas in (* Format.eprintf "instantiate %a@." print_env env; *) Trans.on_tagged_pr Compute.meta_rewrite (fun rewrite_pr -> Trans.tdecl (map rewrite_pr env) None)) let discriminate env = Trans.seq [ Libencoding.monomorphise_goal; select_lsinst env; Trans.print_meta Libencoding.debug meta_lsinst; lsymbol_distinction; ] let () = Trans.register_env_transform "discriminate" discriminate ~desc:"Generate@ monomorphic@ type@ instances@ of@ function@ and@ \ predicate@ symbols@ and@ monomorphize@ task@ premises." let discriminate_if_poly env = Trans.on_meta Detect_polymorphism.meta_monomorphic_types_only (function | [] -> discriminate env | _ -> Trans.identity) let () = Trans.register_env_transform "discriminate_if_poly" discriminate_if_poly ~desc:"Same@ as@ discriminate@ but@ only@ if@ polymorphism@ appear." let li_add_ls acc = function | [MAls ls; MAls nls] -> Mls.add nls ls acc | _ -> assert false let get_lsinst task = Task.on_meta meta_lsinst li_add_ls Mls.empty task let on_lsinst fn = Trans.on_meta meta_lsinst (fun dls -> fn (List.fold_left li_add_ls Mls.empty dls)) let sm_add_ls sm0 sm = function | [MAls ls; MAls nls] -> begin match Mid.find_opt ls.ls_name sm0 with | Some s -> Mid.add nls.ls_name s sm | None -> sm end | _ -> assert false let get_syntax_map task = let sm0 = Printer.get_syntax_map task in Task.on_meta meta_lsinst (sm_add_ls sm0) sm0 task let on_syntax_map fn = Printer.on_syntax_map (fun sm0 -> Trans.on_meta meta_lsinst (fun dls -> fn (List.fold_left (sm_add_ls sm0) sm0 dls))) why3-0.88.3/src/transform/inlining.mli0000664000175100017510000000524313225666037020374 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** Inline non-recursive definitions *) val meta : Theory.meta (** {2 Generic inlining} *) val t : ?use_meta:bool -> ?in_goal:bool -> notdeft:(Term.term -> bool) -> notdeff:(Term.term -> bool) -> notls :(Term.lsymbol -> bool) -> Task.task Trans.trans (** [t ~use_meta ~in_goal ~notdeft ~notdeff ~notls] returns a transformation that expands a symbol [ls] in the subsequent declarations unless [ls] satisfies one of the following conditions: - [ls] is defined via a (mutually) recursive definition; - [ls] is an inductive predicate or an algebraic type constructor; - [ls] is a function symbol and [notdeft] returns true on its definition; - [ls] is a predicate symbol and [notdeff] returns true on its definition; - [notls ls] returns [true]; - [use_meta] is set and [ls] is tagged by "inline : no" Notice that [use_meta], [notdeft], [notdeff], [notls] restrict only which symbols are inlined not when. If [in_goal] is set, only the top-most symbols in the goal are expanded. *) (** {2 Registered Transformation} *) val all : Task.task Trans.trans (** [all] corresponds to the transformation "inline_all" *) val goal : Task.task Trans.trans (** [goal] corresponds to the transformation "inline_goal" *) val trivial : Task.task Trans.trans (** [trivial] corresponds to the transformation "inline_trivial" Inline only the trivial definition : logic c : t = a logic f(x : t,...) : t = g(y : t2,...) *) (* (** Functions to use in other transformations if inlining is needed *) type env val empty_env : env val addfs : env -> Term.lsymbol -> Term.vsymbol list -> Term.term -> env val addps : env -> Term.lsymbol -> Term.vsymbol list -> Term.term -> env (** [addls env ls vs t] trigger the inlining of [ls] by the definition [t] with the free variables [vs]. The variables of [vs] must have the same type as the arguments of [ls] *) val replacet : env -> Term.term -> Term.term val replacep : env -> Term.term -> Term.term *) why3-0.88.3/src/transform/eliminate_inductive.mli0000664000175100017510000000153413225666037022605 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) val eliminate_inductive : Task.task Trans.trans (* exported to be used in the PVS printer *) val exi: Term.term list -> 'a * Term.term -> Term.term why3-0.88.3/src/transform/intro_vc_vars_counterexmp.mli0000664000175100017510000000453713225666037024101 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) val intro_vc_vars_counterexmp : Task.task Trans.trans (** Finds the position of the term t_vc that trigger VC and saves this position in meta (for smtv2 printer). For every variable v inside the term t_vc that triggers VC introduces constant c equal to the variable v with the location of t_vc, label "model_trace:*", and either label "model" or "model_projected". This means that all variables that should be collected for counterexample will marked by model labels. If the term triggering VC is postcondition of a function, appends to the label "model_trace:*" string "@old" for variables corresponding to old values of input arguments and string "@return" for the variable corresponding to the return value of the function. ------------------------------------------------------------------ The rationale of this transformation: Variables that should be displayed in counterexample are marked by model labels ("model", "model_projected", "model_trace"). Variables inside the term that triggers VC should be displayed in counterexample for that VC. However, many VCs (tasks) can be generated for a signle *.mlw file and only variables in the term that trigger the VC (task) that is currently proven should be displayed. That means that the process of selecting variables inside the term that triggers VC for counterexample cannot be done before the task is processed. It is done by this transformation. *) val get_location_of_vc : Task.task -> Loc.position option (** Gets the location of the term that triggers vc. This location is collected by transformation intro_vc_vars_counterexmp. *) why3-0.88.3/src/transform/smoke_detector.mli0000664000175100017510000000141013225666037021564 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) val top : Task.task Trans.trans val deep : Task.task Trans.trans why3-0.88.3/src/transform/eliminate_epsilon.ml0000664000175100017510000002146613225666037022121 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Ident open Term open Decl (* Canonical forms for epsilon terms. *) type canonical = | Id (* identity lambda (\x (x_i). x (x_i)) *) | Eta of term (* eta-expansed term (\(x_i). t (x_i)) (x_i not in t's free variables) *) | Partial of lsymbol * term list (* partial application (\(x_i). f (arguments) (x_i)) (x_i not free in arguments) *) | Nothing (* No canonical form found. *) let canonicalize x f = let vl,_,f = match f.t_node with | Tquant (Tforall,b) -> t_open_quant b | _ -> [],[],f in let hd,e = match f.t_node with | Tapp (ls, [hd; t]) when ls_equal ls ps_equ -> hd,t | Tbinop (Tiff, {t_node = Tapp (ls, [hd; t])}, f) when ls_equal ls ps_equ && t_equal t t_bool_true -> hd, begin match f.t_node with | Tapp (ls, [t1;t2]) when ls_equal ls ps_equ && t_equal t2 t_bool_true -> t1 | _ -> f end | _ -> raise Exit in let rvl = List.rev vl in let rec match_args tl vl = match tl, vl with | _, [] -> let tvs = List.fold_left t_freevars Mvs.empty tl in if Mvs.set_disjoint tvs (Svs.of_list rvl) then tl else raise Exit | {t_node = Tvar u} :: tl, v :: vl when vs_equal u v -> match_args tl vl | _ -> raise Exit in let rec match_apps e vl = match e.t_node, vl with | _, [] -> if Mvs.set_disjoint (t_freevars Mvs.empty e) (Svs.of_list rvl) then Eta e else raise Exit | Tvar u, [v] when vs_equal u v -> Id | Tapp (ls, [fn; {t_node = Tvar u}]), v :: vl when ls_equal ls fs_func_app -> if vs_equal u v then match_apps fn vl else raise Exit | Tapp (ls,tl), vl -> Partial (ls, match_args (List.rev tl) vl) | _ -> raise Exit in let canon = match_apps e rvl in let rec check_head hd vl = match hd.t_node, vl with | Tapp (ls, [hd; {t_node = Tvar u}]), v :: vl when ls_equal ls fs_func_app && vs_equal u v -> check_head hd vl | Tvar y, [] when vs_equal y x -> () | _ -> raise Exit in check_head hd rvl; canon let canonicalize x f = try canonicalize x f with Exit -> Nothing let get_canonical ls = let ty = Opt.get_def Ty.ty_bool ls.ls_value in let ty = List.fold_right Ty.ty_func ls.ls_args ty in let nm = ls.ls_name.id_string ^ "_closure" in let cs = create_fsymbol (id_derive nm ls.ls_name) [] ty in let mk_vs ty = create_vsymbol (id_fresh "y") ty in let vl = List.map mk_vs ls.ls_args in let tl = List.map t_var vl in let t = List.fold_left t_func_app (fs_app cs [] ty) tl in let e = t_app ls tl ls.ls_value in let f = if ls.ls_value = None then t_iff (t_equ t t_bool_true) e else t_equ t e in let nm = ls.ls_name.id_string ^ "_closure_def" in let pr = create_prsymbol (id_derive nm ls.ls_name) in let ax = create_prop_decl Paxiom pr (t_forall_close vl [] f) in create_param_decl cs, ax, cs let id_canonical = let ty = Ty.ty_var (Ty.tv_of_string "a") in let tyf = Ty.ty_func ty ty in let cs = create_fsymbol (id_fresh "identity") [] tyf in let vs = create_vsymbol (id_fresh "y") ty in let tvs = t_var vs in let eq = t_equ (t_func_app (fs_app cs [] tyf) tvs) tvs in let pr = create_prsymbol (id_fresh "identity_def") in let ax = create_prop_decl Paxiom pr (t_forall_close [vs] [] eq) in create_param_decl cs, ax, cs let get_canonical = let ht = Hls.create 3 in fun ls -> try Hls.find ht ls with Not_found -> let res = get_canonical ls in Hls.add ht ls res; res type to_elim = | All (* eliminate all epsilon-terms *) | NonLambda (* preserve lambda-terms *) | NonLambdaSet (* preserve lambda-terms with value-typed body *) let to_elim el t = match el with | All -> true | NonLambda -> not (t_is_lambda t) | NonLambdaSet -> let vl,_,t = t_open_lambda t in vl = [] || t.t_ty = None let rec lift_f el acc t0 = let elim_eps_eq t1 fb t2 = let vs, f = t_open_bound fb in if canonicalize vs f <> Nothing then match t1.t_node with | Teps fb when to_elim el t1 -> let vs, f = t_open_bound fb in if canonicalize vs f <> Nothing then t_map_fold (lift_f el) acc t0 else let f = t_let_close_simp vs t2 f in lift_f el acc (t_label_copy t0 f) | _ -> t_map_fold (lift_f el) acc t0 else let f = t_let_close_simp vs t1 f in lift_f el acc (t_label_copy t0 f) in match t0.t_node with (* cannot merge the 2 patterns because of warning 57 *) | Tapp (ps, [t1; {t_node = Teps fb} as t2]) when ls_equal ps ps_equ && to_elim el t2 -> elim_eps_eq t1 fb t2 | Tapp (ps, [{t_node = Teps fb} as t2; t1]) when ls_equal ps ps_equ && to_elim el t2 -> elim_eps_eq t1 fb t2 | Teps fb when to_elim el t0 -> let vl = Mvs.keys (t_vars t0) in let vs, f = t_open_bound fb in let acc, t = match canonicalize vs f with | Id -> let ld, ax, cs = id_canonical in let abst, axml = acc in (ld :: abst, ax :: axml), fs_app cs [] vs.vs_ty | Eta t -> lift_f el acc t | Partial (ls, rargs) -> let ld, ax, cs = get_canonical ls in let args, ty, acc = List.fold_left (fun (args, ty, acc) x -> let acc, y = lift_f el acc x in y :: args, Ty.ty_func (t_type y) ty, acc ) ([], vs.vs_ty, acc) rargs in let abst, axml = acc in let apply f x = t_app_infer fs_func_app [f;x] in let ap = List.fold_left apply (fs_app cs [] ty) args in (ld :: abst, ax :: axml), ap | Nothing -> let (abst,axml), f = lift_f el acc f in let tyl = List.map (fun x -> x.vs_ty) vl in let ls = create_fsymbol (id_clone vs.vs_name) tyl vs.vs_ty in let t = fs_app ls (List.map t_var vl) vs.vs_ty in let f = t_forall_close_merge vl (t_subst_single vs t f) in let id = id_derive (vs.vs_name.id_string ^ "_def") vs.vs_name in let ax = create_prop_decl Paxiom (create_prsymbol id) f in (create_param_decl ls :: abst, ax :: axml), t in acc, t_label_copy t0 t | _ -> t_map_fold (lift_f el) acc t0 let lift_l el (acc,dl) (ls,ld) = let vl, t, close = open_ls_defn_cb ld in match t.t_node with | Teps fb when to_elim el t -> let vs, f = t_open_bound fb in let (abst,axml), f = lift_f el acc f in let t = t_app ls (List.map t_var vl) t.t_ty in let f = t_forall_close_merge vl (t_subst_single vs t f) in let id = id_derive (ls.ls_name.id_string ^ "_def") ls.ls_name in let ax = create_prop_decl Paxiom (create_prsymbol id) f in (create_param_decl ls :: abst, ax :: axml), dl | _ -> let acc, t = lift_f el acc t in acc, close ls vl t :: dl let lift_d el d = match d.d_node with | Dlogic dl -> let (abst,axml), dl = List.fold_left (lift_l el) (([],[]),[]) dl in if dl = [] then List.rev_append abst (List.rev axml) else let d = create_logic_decl (List.rev dl) in let add_ax (axml1, axml2) ax = if Sid.disjoint ax.d_syms d.d_news then ax :: axml1, axml2 else axml1, ax :: axml2 in let axml1, axml2 = List.fold_left add_ax ([],[]) axml in List.rev_append abst (axml1 @ d :: axml2) | _ -> let (abst,axml), d = decl_map_fold (lift_f el) ([],[]) d in List.rev_append abst (List.rev_append axml [d]) let eliminate_epsilon = Trans.decl (lift_d All) None let eliminate_nl_epsilon = Trans.decl (lift_d NonLambda) None let eliminate_nls_epsilon = Trans.decl (lift_d NonLambdaSet) None let () = Trans.register_transform "eliminate_epsilon" eliminate_epsilon ~desc:"Eliminate@ lambda-terms@ and@ other@ comprehension@ forms." let () = Trans.register_transform "eliminate_non_lambda_epsilon" eliminate_nl_epsilon ~desc:"Eliminate@ all@ comprehension@ forms@ except@ lambda-terms." let () = Trans.register_transform "eliminate_non_lambda_set_epsilon" eliminate_nls_epsilon ~desc:"Eliminate@ all@ comprehension@ forms@ except@ value-typed@ lambda-terms." why3-0.88.3/src/transform/eliminate_if.ml0000664000175100017510000001241713225666037021042 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Ident open Term open Decl (** Eliminate if-then-else in terms *) let rec has_if t = match t.t_node with | Tif _ -> true | _ -> TermTF.t_any has_if Util.ffalse t let rec elim_t contT t = let contTl e = contT (t_label_copy t e) in match t.t_node with | Tlet (t1,tb) -> let u,t2,close = t_open_bound_cb tb in let cont_in t1 t2 = contTl (t_let t1 (close u t2)) in let cont_let_t t1 = elim_t (cont_in t1) t2 in let cont_let_f t1 = t_let_close u t1 (elim_t contT t2) in elim_t (if has_if t2 then cont_let_f else cont_let_t) t1 | Tif (f,t1,t2) -> let f = elim_f (fun f -> f) f in t_if f (elim_t contT t1) (elim_t contT t2) | Tcase (t1, bl) -> let bl = List.rev_map t_open_branch_cb bl in let fi = List.exists (fun (_,t,_) -> has_if t) bl in let fnB ctB (p,t,cl) = elim_t (fun t -> ctB (cl p t)) t in let cont_with t1 bl = contTl (t_case t1 (List.rev bl)) in let cont_case_t t1 = list_map_cont fnB (cont_with t1) bl in let close (p,t,_) = t_close_branch p (elim_t contT t) in let cont_case_f t1 = t_case t1 (List.rev_map close bl) in elim_t (if fi then cont_case_f else cont_case_t) t1 | _ -> TermTF.t_map_cont elim_t elim_f contT t and elim_f contF f = match f.t_node with | Tapp _ | Tlet _ | Tcase _ -> contF (TermTF.t_map_cont elim_t elim_f (fun f -> f) f) | _ -> TermTF.t_map_cont elim_tr elim_f contF f (* the only terms we still can meet are the terms in triggers *) and elim_tr contT t = match t.t_node with | Tif _ -> Printer.unsupportedTerm t "cannot eliminate 'if-then-else' in trigger terms" | _ -> TermTF.t_map_cont elim_tr elim_f contT t let elim_f f = elim_f (fun f -> f) f let rec elim_t t = TermTF.t_map elim_t elim_f t let add_ld (ls,ld) (abst,defn,axl) = let vl,e,close = open_ls_defn_cb ld in match e.t_ty with | Some _ when has_if e -> let nm = ls.ls_name.id_string ^ "_def" in let pr = create_prsymbol (id_derive nm ls.ls_name) in let hd = t_app ls (List.map t_var vl) e.t_ty in let ax = t_forall_close vl [] (elim_f (t_equ hd e)) in let ax = create_prop_decl Paxiom pr ax in let ld = create_param_decl ls in ld :: abst, defn, ax :: axl | _ -> let d = close ls vl (TermTF.t_select elim_t elim_f e) in abst, d :: defn, axl let elim_d d = match d.d_node with | Dlogic l -> let abst,defn,axl = List.fold_right add_ld l ([],[],[]) in let defn = if defn = [] then [] else [create_logic_decl defn] in abst @ defn @ axl | Dind (s, l) -> let rec clause f = match f.t_node with | Tquant (Tforall, f) -> let vs,tr,f = t_open_quant f in List.map (t_forall_close vs tr) (clause f) | Tbinop (Timplies, g, f) -> List.map (t_implies g) (clause f) | Tlet (t, bf) -> let v, f = t_open_bound bf in List.map (t_let_close v t) (clause f) (* need to eliminate if to get a clause *) | Tif (f1,f2,f3) -> clause (t_implies f1 f2) @ clause (t_implies (t_not f1) f3) | _ -> [f] in let fn (pr,f) = match clause (elim_f f) with | [] -> assert false | [f] -> [pr, f] (* keep the same symbol when one clause *) | l -> List.map (fun f -> create_prsymbol (id_clone pr.pr_name), f) l in let fn (ps,l) = ps, List.concat (List.map fn l) in [create_ind_decl s (List.map fn l)] | _ -> [DeclTF.decl_map (fun _ -> assert false) elim_f d] let eliminate_if_term = Trans.decl elim_d None (** Eliminate if-then-else in formulas *) let rec elim_t t = TermTF.t_map elim_t (elim_f true) t and elim_f sign f = match f.t_node with | Tif (f1,f2,f3) -> let f1p = elim_f sign f1 in let f1n = elim_f (not sign) f1 in let f2 = elim_f sign f2 in let f3 = elim_f sign f3 in if sign then t_and (t_implies f1n f2) (t_implies (t_not f1p) f3) else t_or (t_and f1p f2) (t_and (t_not f1n) f3) | _ -> TermTF.t_map_sign (Util.const elim_t) elim_f sign f let eliminate_if_fmla = Trans.rewriteTF elim_t (elim_f true) None let eliminate_if = Trans.compose eliminate_if_term eliminate_if_fmla let () = Trans.register_transform "eliminate_if_term" eliminate_if_term ~desc:"Replaces@ terms@ of@ the@ form@ [if f1 then t2 else t3]@ by@ \ lifting@ them@ at@ the@ level@ of@ formulas."; Trans.register_transform "eliminate_if_fmla" eliminate_if_fmla ~desc:"Eliminate@ formulas@ of@ the@ form@ [if f1 then f2 else f3]."; Trans.register_transform "eliminate_if" eliminate_if ~desc:"Eliminate@ all@ if-expressions." why3-0.88.3/src/transform/detect_polymorphism.mli0000664000175100017510000000136513225666037022660 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) val meta_monomorphic_types_only : Theory.meta why3-0.88.3/src/transform/smoke_detector.ml0000664000175100017510000000367713225666037021434 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (* Smoke detector try to find if the axiomatisation is self-contradicting. The second smoke detector add the negation under the implication and universal quantification (replace implication by conjunction). *) open Term open Decl let create app = Trans.goal (fun pr t -> [create_prop_decl Pgoal pr (app t)]) let top = create t_not let rec neg f = match f.t_node with | Tbinop (Timplies,f1,f2) -> t_and f1 (neg f2) (* Would show too much smoke ? | Tbinop (Timplies,f1,f2) -> t_implies f1 (neg f2) *) | Tquant (Tforall,fq) -> let vsl,_trl,f = t_open_quant fq in t_forall_close vsl _trl (neg f) | Tlet (t,fb) -> let vs,f = t_open_bound fb in t_let_close vs t (neg f) | _ -> t_not f let deep = create neg let () = Trans.register_transform "smoke_detector_top" top ~desc:"Put@ the@ goal@ under@ negation.@ Used@ to@ \ detect@ inconsistency@ in@ premises." let () = Trans.register_transform "smoke_detector_deep" deep ~desc:"Put@ the@ conclusion@ of@ the@ goal@ (under@ universal@ \ quantifiers@ and@ implications)@ under@ negation.@ \ Used@ to@ detect@ inconsistency@ in@ premises@ \ and@ goal@ hypotheses." (* Local Variables: compile-command: "unset LANG; make -C ../.. byte" End: *) why3-0.88.3/src/transform/abstraction.mli0000664000175100017510000000227513225666037021100 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) val abstraction : (Term.lsymbol -> bool) -> Task.task Trans.trans (** [abstract keep t] applies variable abstraction of the task [t], that is replaces subterms or subformulas headed by a logic symbol f that do not satisfies [keep f] into a fresh variable. Notice that the numeric constants are always kept Example (approximate syntax): [abstraction (fun f -> List.mem f ["+";"-"]) "goal x*x+y*y = 1"] returns ["logic abs1 : int; logic abs2 : int; goal abs1+abs2 = 1"] *) why3-0.88.3/src/transform/detect_polymorphism.ml0000664000175100017510000001035313225666037022504 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Decl open Theory let debug = Debug.register_info_flag "detect_poly" ~desc:"Print@ debugging@ messages@ of@ the@ \ 'detect_polymorphism'@ transformation." (* metas to attach to symbols or propositions to tell their polymorphic nature can be ignored because it will be treated specifically by drivers *) let meta_ignore_polymorphism_ts = register_meta "encoding:ignore_polymorphism_ts" [MTtysymbol] ~desc:"Ignore@ polymorphism@ of@ given@ type@ symbol." let meta_ignore_polymorphism_ls = register_meta "encoding:ignore_polymorphism_ls" [MTlsymbol] ~desc:"Ignore@ polymorphism@ of@ given@ logic@ symbol." let meta_ignore_polymorphism_pr = register_meta "encoding:ignore_polymorphism_pr" [MTprsymbol] ~desc:"Ignore@ polymorphism@ of@ given@ proposition." (* exclusive meta that is set by the transformation when no polymorphic definition is found *) let meta_monomorphic_types_only = register_meta_excl "encoding:monomorphic_only" [] ~desc:"Set@ when@ no@ occurrences@ of@ type@ variables@ occur." let check_ts ign_ts ts = ts.Ty.ts_args <> [] && not (Ty.Sts.mem ts ign_ts) let check_ls ign_ls ls = not (Term.Sls.mem ls ign_ls) && List.fold_left (fun acc ty -> acc || not (Ty.ty_closed ty)) false (Ty.oty_cons ls.Term.ls_args ls.Term.ls_value) let detect_polymorphism_in_decl ign_ts ign_ls ign_pr d = Debug.dprintf debug "[detect_polymorphism] |sts|=%d |sls|=%d |spr|=%d@." (Ty.Sts.cardinal ign_ts) (Term.Sls.cardinal ign_ls) (Spr.cardinal ign_pr); Debug.dprintf debug "[detect_polymorphism] decl %a@." Pretty.print_decl d; match d.d_node with | Dtype ts -> check_ts ign_ts ts | Ddata dl -> List.fold_left (fun acc (ts,_) -> acc || check_ts ign_ts ts) false dl | Dparam ls -> Debug.dprintf debug "[detect_polymorphism] param %a@." Pretty.print_ls ls; check_ls ign_ls ls | Dlogic dl -> (* note: we don't need to check also that definition bodies are monomorphic, since it is checked by typing *) List.fold_left (fun acc (ls,_) -> acc || check_ls ign_ls ls) false dl | Dind (_,indl) -> (* note: we don't need to check also that clauses are monomorphic, since it is checked by typing *) List.fold_left (fun acc (ls,_) -> acc || check_ls ign_ls ls) false indl | Dprop (_,pr,t) -> (* todo: NE PAS TESTER le goal *) not (Spr.mem pr ign_pr) && let s = Term.t_ty_freevars Ty.Stv.empty t in not (Ty.Stv.is_empty s) let detect_polymorphism_in_task_hd ign_ts ign_l ign_pr t acc = match t.Task.task_decl.td_node with | Decl d -> acc || detect_polymorphism_in_decl ign_ts ign_l ign_pr d | Use _ | Clone _ | Meta _ -> acc let detect_polymorphism_in_task = Trans.on_tagged_ts meta_ignore_polymorphism_ts (fun sts -> Trans.on_tagged_ls meta_ignore_polymorphism_ls (fun sls -> Trans.on_tagged_pr meta_ignore_polymorphism_pr (fun spr -> Trans.fold (detect_polymorphism_in_task_hd sts sls spr) false))) let detect_polymorphism task = if Trans.apply detect_polymorphism_in_task task then task else try let g,t = Task.task_separate_goal task in let ta = Task.add_meta t meta_monomorphic_types_only [] in Task.add_tdecl ta g with Task.GoalNotFound -> Task.add_meta task meta_monomorphic_types_only [] let () = Trans.register_transform "detect_polymorphism" (Trans.store detect_polymorphism) ~desc:"Detect if task has polymorphic types somewhere." why3-0.88.3/src/transform/simplify_array.ml0000664000175100017510000000271213225666037021444 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Term open Theory let make_rt_rf env = let array = Env.read_theory env ["map"] "Map" in let store = (ns_find_ls array.th_export ["set"]).ls_name in let select = (ns_find_ls array.th_export ["get"]).ls_name in let rec rt t = let t = TermTF.t_map rt rf t in match t.t_node with | Tapp (lselect,[{t_node=Tapp(lstore,[_;a1;b])};a2]) when lselect.ls_name == select && lstore.ls_name == store && t_equal a1 a2 -> b | _ -> t and rf f = TermTF.t_map rt rf f in rt,rf let t env = let rt,rf = make_rt_rf env in Trans.rewriteTF rt rf None let () = Trans.register_env_transform "simplify_array" t ~desc:"Apply,@ wherever@ possible,@ the@ axiom@ 'Select_eq'@ of@ \ the@ library@ theory@ map.Map." why3-0.88.3/src/transform/prop_curry.ml0000664000175100017510000000233313225666037020615 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Term open Decl let rec curry t = match t.t_node with | Tbinop (Timplies, lhs, rhs) -> expand t lhs (curry rhs) | _ -> t_map curry t and expand orig l r = match l.t_node with | Tbinop (Tand, a, b) -> expand orig a (expand orig b r) | _ -> t_label_copy orig (t_implies (curry l) r) let curry = Trans.goal (fun pr t -> [create_prop_decl Pgoal pr (curry t)]) let () = Trans.register_transform "prop_curry" curry ~desc:"Transform@ conjunctions@ in@ implication@ premises@ into@ \ sequences@ of@ premises." why3-0.88.3/src/transform/compute.mli0000664000175100017510000000141313225666037020234 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) val meta_rewrite : Theory.meta val meta_rewrite_def : Theory.meta why3-0.88.3/src/transform/eliminate_definition.ml0000664000175100017510000003005713225666037022574 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Ident open Ty open Term open Decl (** Discard definitions of built-in symbols *) let add_id undef_ls rem_ls (ls,ld) (abst,defn) = if Sls.mem ls rem_ls then abst,defn else if Sls.mem ls undef_ls then create_param_decl ls :: abst, defn else abst, (ls,ld) :: defn (** TODO: go further? such as constructor that are removed? *) let elim_abstract undef_ls rem_pr rem_ls rem_ts d = match d.d_node with | Dlogic l -> let ld, id = List.fold_right (add_id undef_ls rem_ls) l ([],[]) in ld @ (if id = [] then [] else [create_logic_decl id]) | Dind (s, l) -> let ld, id = List.fold_right (add_id undef_ls rem_ls) l ([],[]) in ld @ (if id = [] then [] else [create_ind_decl s id]) | Dprop (Paxiom,pr,_) when Spr.mem pr rem_pr -> [] | Dtype ts when Sts.mem ts rem_ts -> [] | Ddata l -> let test_id (ts,_) = not (Sts.mem ts rem_ts) in let l = List.filter test_id l in (if l = [] then [] else [create_data_decl l]) | _ -> [d] let eliminate_builtin = Trans.on_tagged_ls Printer.meta_syntax_logic (fun undef_ls -> Trans.on_tagged_pr Printer.meta_remove_prop (fun rem_pr -> Trans.on_tagged_ls Printer.meta_remove_logic (fun rem_ls -> Trans.on_tagged_ts Printer.meta_remove_type (fun rem_ts -> Trans.decl (elim_abstract undef_ls rem_pr rem_ls rem_ts) None)))) let () = Trans.register_transform "eliminate_builtin" eliminate_builtin ~desc:"Eliminate@ propositions@ and@ definitions@ of@ symbols@ \ that@ are@ builtin@ in@ the@ prover@ (see@ 'syntax'@ and@ \ 'remove'@ clauses@ in@ the@ prover's@ driver)." (** compute the meta_remove_* given two task one included in the other *) let compute_diff t1 t2 = let km = Mid.set_diff (Task.task_known t1) (Task.task_known t2) in let hdone = Hdecl.create 10 in let remove_ts acc ts = (Printer.meta_remove_type, [Theory.MAts ts])::acc in let remove_ls acc ls = (Printer.meta_remove_logic, [Theory.MAls ls])::acc in let remove_pr acc pr = (Printer.meta_remove_prop, [Theory.MApr pr])::acc in Mid.fold_left (fun acc _ decl -> if Hdecl.mem hdone decl then acc else begin Hdecl.replace hdone decl (); match decl.d_node with | Dtype ts -> remove_ts acc ts | Ddata l -> List.fold_left (fun acc (ts,_) -> remove_ts acc ts) acc l | Dparam ls -> remove_ls acc ls | Dlogic l -> List.fold_left (fun acc (ls,_) -> remove_ls acc ls) acc l | Dind (_,l) -> List.fold_left (fun acc (ls,_) -> remove_ls acc ls) acc l | Dprop (_,pr,_) -> remove_pr acc pr end) [] km let compute_diff = Trans.store (fun t1 -> Trans.store (fun t2 -> compute_diff t1 t2)) (** Eliminate definitions of functions and predicates *) let rec t_insert hd t = match t.t_node with | Tif (f1,t2,t3) -> t_if f1 (t_insert hd t2) (t_insert hd t3) | Tlet (t1,bt) -> let v,t2 = t_open_bound bt in t_let_close v t1 (t_insert hd t2) | Tcase (tl,bl) -> let br b = let pl,t1 = t_open_branch b in t_close_branch pl (t_insert hd t1) in t_case tl (List.map br bl) | _ -> TermTF.t_selecti t_equ_simp t_iff_simp hd t let add_ld which meta_rewrite_def (ls,ld) (abst,defn,axl,metas) = if which ls then let vl,e = open_ls_defn ld in let nm = ls.ls_name.id_string ^ "_def" in let pr = create_prsymbol (id_derive nm ls.ls_name) in let hd = t_app ls (List.map t_var vl) e.t_ty in let ax = t_forall_close vl [] (t_insert hd e) in let ax = create_prop_decl Paxiom pr ax in let ld = create_param_decl ls in let metas = if Sls.mem ls meta_rewrite_def then Theory.create_meta Compute.meta_rewrite [Theory.MApr pr] :: metas else metas in ld :: abst, defn, ax :: axl, metas else abst, (ls,ld) :: defn, axl, metas let elim_decl which meta_rewrite_def l = let abst,defn,axl,metas = List.fold_right (add_ld which meta_rewrite_def) l ([],[],[],[]) in let defn = if defn = [] then [] else [create_logic_decl defn] in List.rev_append (List.rev_map Theory.create_decl (abst @ defn @ axl)) metas let elim which meta_rewrite_def d = match d.d_node with | Dlogic l -> elim_decl which meta_rewrite_def l | _ -> [Theory.create_decl d] let elim_recursion d = match d.d_node with | Dlogic ([s,_] as l) when Sid.mem s.ls_name d.d_syms -> elim_decl Util.ttrue Sls.empty l | Dlogic l when List.length l > 1 -> elim_decl Util.ttrue Sls.empty l | _ -> [Theory.create_decl d] let is_struct dl = (* FIXME? Shouldn't 0 be allowed too? *) List.for_all (fun (_,ld) -> List.length (ls_defn_decrease ld) = 1) dl (* FIXME? We can have non-recursive functions in a group *) let elim_non_struct_recursion d = match d.d_node with | Dlogic ((s,_) :: _ as dl) when Sid.mem s.ls_name d.d_syms && not (is_struct dl) -> elim_decl Util.ttrue Sls.empty dl | _ -> [Theory.create_decl d] let elim_mutual d = match d.d_node with | Dlogic l when List.length l > 1 -> elim_decl Util.ttrue Sls.empty l | _ -> [Theory.create_decl d] let eliminate_definition_gen which = Trans.on_tagged_ls Compute.meta_rewrite_def (fun rew -> Trans.tdecl (elim which rew) None) let eliminate_definition_func = eliminate_definition_gen (fun ls -> ls.ls_value <> None) let eliminate_definition_pred = eliminate_definition_gen (fun ls -> ls.ls_value = None) let eliminate_definition = eliminate_definition_gen Util.ttrue let eliminate_recursion = Trans.tdecl elim_recursion None let eliminate_non_struct_recursion = Trans.tdecl elim_non_struct_recursion None let eliminate_mutual_recursion = Trans.tdecl elim_mutual None let () = Trans.register_transform "eliminate_definition_func" eliminate_definition_func ~desc:"Transform@ function@ definitions@ into@ axioms."; Trans.register_transform "eliminate_definition_pred" eliminate_definition_pred ~desc:"Transform@ predicate@ definitions@ into@ axioms."; Trans.register_transform "eliminate_definition" eliminate_definition ~desc:"Transform@ function@ and@ predicate@ definitions@ into@ axioms."; Trans.register_transform "eliminate_recursion" eliminate_recursion ~desc:"Same@ as@ eliminate_definition,@ but@ only@ for@ recursive@ \ definitions."; Trans.register_transform "eliminate_non_struct_recursion" eliminate_non_struct_recursion ~desc:"Same@ as@ eliminate_recursion,@ but@ only@ for@ non-structural@ \ recursive@ definitions."; Trans.register_transform "eliminate_mutual_recursion" eliminate_mutual_recursion ~desc:"Same@ as@ eliminate_recursion,@ but@ only@ for@ mutually@ \ recursive@ definitions." (** conditional transformations, only applied when polymorphic types occur *) let eliminate_definition_if_poly = Trans.on_meta Detect_polymorphism.meta_monomorphic_types_only (function | [] -> eliminate_definition | _ -> eliminate_recursion) let () = Trans.register_transform "eliminate_definition_if_poly" eliminate_definition_if_poly ~desc:"Same@ as@ eliminate_definition@ but@ only@ if@ polymorphism@ appear." (** Bisect *) open Task open Theory type bisect_step = | BSdone of (Theory.meta * Theory.meta_arg list) list | BSstep of task * (bool -> bisect_step) type rem = { rem_pr : Spr.t; rem_ls : Sls.t; rem_ts : Sts.t } let _print_rem fmt rem = Format.fprintf fmt "@[rem_pr:@[%a@]@\nrem_ls:@[%a@]@\nrem_ts:@[%a@]@\n" (Pp.print_iter1 Spr.iter Pp.comma Pretty.print_pr) rem.rem_pr (Pp.print_iter1 Sls.iter Pp.comma Pretty.print_ls) rem.rem_ls (Pp.print_iter1 Sts.iter Pp.comma Pretty.print_ts) rem.rem_ts let rec elim_task task rem = match task with | Some ({task_decl = {td_node = Decl decl}} as task) -> let task = elim_task task.task_prev rem in let l = elim_abstract Sls.empty rem.rem_pr rem.rem_ls rem.rem_ts decl in List.fold_left Task.add_decl task l | Some task -> Task.add_tdecl (elim_task task.task_prev rem) task.task_decl | None -> None let add_rem rem decl = let remove_ts rem ts = { rem with rem_ts = Sts.add ts rem.rem_ts} in let remove_ls rem ls = { rem with rem_ls = Sls.add ls rem.rem_ls} in let remove_pr rem pr = { rem with rem_pr = Spr.add pr rem.rem_pr} in match decl.d_node with | Dtype ts -> remove_ts rem ts | Ddata l -> List.fold_left (fun rem (ts,_) -> remove_ts rem ts) rem l | Dparam ls -> remove_ls rem ls | Dlogic l -> List.fold_left (fun rem (ls,_) -> remove_ls rem ls) rem l | Dind (_,l) -> List.fold_left (fun rem (ls,_) -> remove_ls rem ls) rem l | Dprop (_,pr,_) -> remove_pr rem pr let _union_rem rem1 rem2 = { rem_ts = Sts.union rem1.rem_ts rem2.rem_ts; rem_ls = Sls.union rem1.rem_ls rem2.rem_ls; rem_pr = Spr.union rem1.rem_pr rem2.rem_pr; } let create_meta_rem_list rem = let remove_ts acc ts = (Printer.meta_remove_type, [Theory.MAts ts])::acc in let remove_ls acc ls = (Printer.meta_remove_logic, [Theory.MAls ls])::acc in let remove_pr acc pr = (Printer.meta_remove_prop, [Theory.MApr pr])::acc in let acc = Sts.fold_left remove_ts [] rem.rem_ts in let acc = Sls.fold_left remove_ls acc rem.rem_ls in let acc = Spr.fold_left remove_pr acc rem.rem_pr in acc let fold_sub f acc a i1 i2 = let acc = ref acc in for i=i1 to i2-1 do acc := f !acc a.(i) done; !acc let rec bisect_aux task a i1 i2 rem cont (* lt i lk *) = (* Format.eprintf "i1: %i, i2: %i@\nrem:%a@." i1 i2 *) (* print_rem rem; *) let call rem valid invalid = try BSstep (elim_task task rem, fun b -> if b then valid () else invalid ()) with UnknownIdent _ -> invalid () in if i2 - i1 < 2 then let rem1 = add_rem rem a.(i1) in call rem1 (fun () -> assert (i2 - i1 = 1); cont rem1) (fun () -> cont rem) else let m = (i1+i2)/2 in let rem1 = fold_sub add_rem rem a m i2 in call rem1 (fun () -> bisect_aux task a i1 m rem1 cont) (fun () -> bisect_aux task a m i2 rem (fun rem1 -> (* rem c rem1 c \old(rem1) *) let rem2 = fold_sub add_rem rem1 a i1 m in call rem2 (fun () -> cont rem2) (fun () -> bisect_aux task a i1 m rem1 cont))) let bisect_step task0 = let task= match task0 with | Some {task_decl = {td_node = Decl {d_node = Dprop (Pgoal,_,_)}}; task_prev = task} -> task | _ -> raise GoalNotFound in let rec length acc = function | Some {task_decl = {td_node = Decl _}; task_prev = t} -> length (acc + 1) t | Some {task_prev = t} -> length acc t | None -> acc in let n = length 0 task in let a = Array.make n (Obj.magic 0) in let rec init acc = function | Some {task_decl = {td_node = Decl d}; task_prev = t} -> a.(acc) <- d; init (acc - 1) t | Some { task_prev = t} -> init acc t | None -> assert (acc = -1) in init (n-1) task; let empty_rem = {rem_ts = Sts.empty; rem_ls = Sls.empty; rem_pr = Spr.empty} in bisect_aux task0 a 0 n empty_rem (fun rem -> BSdone (create_meta_rem_list rem)) let bisect f task = let rec run = function | BSdone r -> r | BSstep (t,c) -> run (c (f t)) in run (bisect_step task) (** catch exception for debug *) (* let bisect_step task0 = *) (* let res = try bisect_step task0 with exn -> *) (* Format.eprintf "bisect_step fail: %a@." Exn_printer.exn_printer exn; *) (* raise exn in *) (* match res with *) (* | BSdone _ as d -> d *) (* | BSstep (t,f) -> BSstep (t,fun b -> try f b with exn -> *) (* Format.eprintf "bisect_step fail: %a@." Exn_printer.exn_printer exn; *) (* raise exn) *) why3-0.88.3/src/transform/introduction.ml0000664000175100017510000001006513225666037021133 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (* This module was poorly designed by Claude Marché, with the enormous help of Jean-Christophe Filliâtre and Andrei Paskevich for finding the right function in the Why3 API *) open Ident open Ty open Term open Decl let rec intros pr f = match f.t_node with (* (f2 \/ True) => _ *) | Tbinop (Timplies,{ t_node = Tbinop (Tor,f2,{ t_node = Ttrue }) },_) when Slab.mem Term.asym_label f2.t_label -> [create_prop_decl Pgoal pr f] | Tbinop (Timplies,f1,f2) -> (* split f1 *) (* f is going to be removed, preserve its labels and location in f2 *) let f2 = t_label_copy f f2 in let l = Split_goal.split_intro_right f1 in List.fold_right (fun f acc -> let id = create_prsymbol (id_fresh "H") in let d = create_prop_decl Paxiom id f in d :: acc) l (intros pr f2) | Tquant (Tforall,fq) -> let vsl,_trl,f_t = t_open_quant fq in let intro_var subst vs = let ls = create_lsymbol (id_clone vs.vs_name) [] (Some vs.vs_ty) in Mvs.add vs (fs_app ls [] vs.vs_ty) subst, create_param_decl ls in let subst, dl = Lists.map_fold_left intro_var Mvs.empty vsl in (* preserve labels and location of f *) let f = t_label_copy f (t_subst subst f_t) in dl @ intros pr f | Tlet (t,fb) -> let vs,f = t_open_bound fb in let ls = create_lsymbol (id_clone vs.vs_name) [] (Some vs.vs_ty) in let f = t_subst_single vs (fs_app ls [] vs.vs_ty) f in let d = create_logic_decl [make_ls_defn ls [] t] in d :: intros pr f | _ -> [create_prop_decl Pgoal pr f] let intros pr f = let tvs = t_ty_freevars Stv.empty f in let mk_ts tv () = create_tysymbol (id_clone tv.tv_name) [] NoDef in let tvm = Mtv.mapi mk_ts tvs in let decls = Mtv.map create_ty_decl tvm in let subst = Mtv.map (fun ts -> ty_app ts []) tvm in Mtv.values decls @ intros pr (t_ty_subst subst Mvs.empty f) let introduce_premises = Trans.goal intros let () = Trans.register_transform "introduce_premises" introduce_premises ~desc:"Introduce@ universal@ quantification@ and@ hypothesis@ in@ the@ \ goal@ into@ constant@ symbol@ and@ axioms." let split_intro = Trans.compose_l Split_goal.split_goal_wp (Trans.singleton introduce_premises) let () = Trans.register_transform_l "split_intro" split_intro ~desc:"Same@ as@ split_goal_wp,@ but@ moves@ \ the@ implication@ antecedents@ to@ premises." (** Destruction of existential quantifiers in axioms. Contributed by Nicolas Jeannerod [niols@niols.fr] *) let rec eliminate_exists_aux pr t = match t.t_node with | Tquant (Texists, q) -> let vsl, _, t' = t_open_quant q in let intro_var subst vs = let ls = create_lsymbol (id_clone vs.vs_name) [] (Some vs.vs_ty) in Mvs.add vs (fs_app ls [] vs.vs_ty) subst, create_param_decl ls in let subst, dl = Lists.map_fold_left intro_var Mvs.empty vsl in let t' = t_subst subst t' in let t = t_label_copy t t' in dl @ eliminate_exists_aux pr t | _ -> [create_prop_decl Paxiom pr t] let eliminate_exists d = match d.d_node with | Dprop (Paxiom, pr, t) -> eliminate_exists_aux pr t | _ -> [d] let () = Trans.register_transform "introduce_exists" (Trans.decl eliminate_exists None) ~desc:"Replace axioms of the form 'exists x. P' by 'constant x axiom P'." why3-0.88.3/src/transform/eliminate_algebraic.ml0000664000175100017510000005152613225666037022361 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Ident open Ty open Term open Decl open Theory open Task (* a type constructor generates an infinite type if either it is tagged by meta_infinite or one of its "material" arguments is an infinite type *) let meta_infinite = register_meta "infinite_type" [MTtysymbol] ~desc:"Specify@ that@ the@ given@ type@ has@ always@ an@ infinite@ \ cardinality." let meta_material = register_meta "material_type_arg" [MTtysymbol;MTint] ~desc:"If@ the@ given@ type@ argument@ is@ instantiated@ by@ an@ infinite@ \ type@ then@ the@ associated@ type@ constructor@ is@ infinite" let get_material_args matl = let add_arg acc = function | [MAts ts; MAint i] -> let acc, mat = try acc, Mts.find ts acc with Not_found -> let mat = Array.make (List.length ts.ts_args) false in Mts.add ts mat acc, mat in Array.set mat i true; acc | _ -> assert false in Mts.map Array.to_list (List.fold_left add_arg Mts.empty matl) let is_infinite_ty inf_ts ma_map = let rec inf_ty ty = match ty.ty_node with | Tyapp (ts,[_;ty]) when ts_equal ts ts_func -> inf_ty ty | Tyapp (ts,_) when Mts.mem ts inf_ts -> true | Tyapp (ts,_) when not (Mts.mem ts ma_map) -> false | Tyapp (ts,l) -> let mat = Mts.find ts ma_map in List.exists2 (fun mat ty -> mat && inf_ty ty) mat l | _ -> false (* FIXME? can we have non-ground types here? *) in inf_ty (** Compile match patterns *) let rec rewriteT t = match t.t_node with | Tcase (t,bl) -> let t = rewriteT t in let mk_b b = let p,t = t_open_branch b in [p], rewriteT t in let mk_case = t_case_close and mk_let = t_let_close_simp in Pattern.compile_bare ~mk_case ~mk_let [t] (List.map mk_b bl) | _ -> t_map rewriteT t let compile_match = Trans.decl (fun d -> [decl_map rewriteT d]) None (** Eliminate algebraic types and match statements *) type state = { mt_map : lsymbol Mts.t; (* from type symbols to selector functions *) pj_map : lsymbol list Mls.t; (* from constructors to projections *) tp_map : decl Mid.t; (* skipped tuple symbols *) inf_ts : Sts.t; (* infinite types *) ma_map : bool list Mts.t; (* material type arguments *) keep_t : bool; (* keep algebraic type definitions *) keep_e : bool; (* keep monomorphic enumeration types *) keep_r : bool; (* keep non-recursive records *) no_ind : bool; (* do not generate indexing functions *) no_inv : bool; (* do not generate inversion axioms *) no_sel : bool; (* do not generate selector *) } let empty_state = { mt_map = Mts.empty; pj_map = Mls.empty; tp_map = Mid.empty; inf_ts = Sts.add ts_real (Sts.singleton ts_int); ma_map = Mts.empty; keep_t = false; keep_e = false; keep_r = false; no_ind = false; no_inv = false; no_sel = false; } let uncompiled = "eliminate_algebraic: compile_match required" let rec rewriteT kn state t = match t.t_node with | Tcase (t1,bl) -> let t1 = rewriteT kn state t1 in let mk_br (w,m) br = let (p,e) = t_open_branch br in let e = rewriteT kn state e in match p with | { pat_node = Papp (cs,pl) } -> let add_var e p pj = match p.pat_node with | Pvar v -> t_let_close_simp v (fs_app pj [t1] v.vs_ty) e | _ -> Printer.unsupportedTerm t uncompiled in let pjl = Mls.find cs state.pj_map in let e = List.fold_left2 add_var e pl pjl in w, Mls.add cs e m | { pat_node = Pwild } -> Some e, m | _ -> Printer.unsupportedTerm t uncompiled in let w,m = List.fold_left mk_br (None,Mls.empty) bl in let find (cs,_) = try Mls.find cs m with Not_found -> Opt.get w in let ts = match t1.t_ty with | Some { ty_node = Tyapp (ts,_) } -> ts | _ -> Printer.unsupportedTerm t uncompiled in begin match List.map find (find_constructors kn ts) with | [t] -> t | tl -> t_app (Mts.find ts state.mt_map) (t1::tl) t.t_ty end | _ -> TermTF.t_map (rewriteT kn state) (rewriteF kn state Svs.empty true) t and rewriteF kn state av sign f = match f.t_node with | Tcase (t1,bl) -> let t1 = rewriteT kn state t1 in let av' = Mvs.set_diff av (t_vars t1) in let mk_br (w,m) br = let (p,e) = t_open_branch br in let e = rewriteF kn state av' sign e in match p with | { pat_node = Papp (cs,pl) } -> let get_var p = match p.pat_node with | Pvar v -> v | _ -> Printer.unsupportedTerm f uncompiled in w, Mls.add cs (List.map get_var pl, e) m | { pat_node = Pwild } -> Some e, m | _ -> Printer.unsupportedTerm f uncompiled in let w,m = List.fold_left mk_br (None,Mls.empty) bl in let find (cs,_) = let vl,e = try Mls.find cs m with Not_found -> let var = create_vsymbol (id_fresh "w") in let get_var pj = var (t_type (t_app_infer pj [t1])) in List.map get_var (Mls.find cs state.pj_map), Opt.get w in let hd = t_app cs (List.map t_var vl) t1.t_ty in match t1.t_node with | Tvar v when Svs.mem v av -> let hd = t_let_close_simp v hd e in if sign then t_forall_close_simp vl [] hd else t_exists_close_simp vl [] hd | _ -> let hd = t_equ t1 hd in if sign then t_forall_close_simp vl [] (t_implies_simp hd e) else t_exists_close_simp vl [] (t_and_simp hd e) in let ts = match t1.t_ty with | Some { ty_node = Tyapp (ts,_) } -> ts | _ -> Printer.unsupportedTerm f uncompiled in let op = if sign then t_and_simp else t_or_simp in Lists.map_join_left find op (find_constructors kn ts) | Tquant (q, bf) when (q = Tforall && sign) || (q = Texists && not sign) -> let vl, tr, f1, close = t_open_quant_cb bf in let tr = TermTF.tr_map (rewriteT kn state) (rewriteF kn state Svs.empty sign) tr in let av = List.fold_left (fun s v -> Svs.add v s) av vl in let f1 = rewriteF kn state av sign f1 in (* Preserve labels and location of f *) t_label_copy f (t_quant_simp q (close vl tr f1)) | Tbinop (o, _, _) when (o = Tand && sign) || (o = Tor && not sign) -> TermTF.t_map_sign (Util.const (rewriteT kn state)) (rewriteF kn state av) sign f | Tlet (t1, _) -> let av = Mvs.set_diff av (t_vars t1) in TermTF.t_map_sign (Util.const (rewriteT kn state)) (rewriteF kn state av) sign f | _ -> TermTF.t_map_sign (Util.const (rewriteT kn state)) (rewriteF kn state Svs.empty) sign f let add_selector (state,task) ts ty csl = if state.no_sel then state, task else (* declare the selector function *) let mt_id = id_derive ("match_" ^ ts.ts_name.id_string) ts.ts_name in let mt_ty = ty_var (create_tvsymbol (id_fresh "a")) in let mt_al = ty :: List.rev_map (fun _ -> mt_ty) csl in let mt_ls = create_fsymbol mt_id mt_al mt_ty in let mtmap = Mts.add ts mt_ls state.mt_map in let task = add_param_decl task mt_ls in (* define the selector function *) let mt_vs _ = create_vsymbol (id_fresh "z") mt_ty in let mt_vl = List.rev_map mt_vs csl in let mt_tl = List.rev_map t_var mt_vl in let mt_add tsk (cs,_) t = let id = mt_ls.ls_name.id_string ^ "_" ^ cs.ls_name.id_string in let pr = create_prsymbol (id_derive id cs.ls_name) in let vl = List.rev_map (create_vsymbol (id_fresh "u")) cs.ls_args in let hd = fs_app cs (List.rev_map t_var vl) (Opt.get cs.ls_value) in let hd = fs_app mt_ls (hd::mt_tl) mt_ty in let vl = List.rev_append mt_vl (List.rev vl) in let ax = t_forall_close vl [] (t_equ hd t) in add_prop_decl tsk Paxiom pr ax in let task = List.fold_left2 mt_add task csl mt_tl in { state with mt_map = mtmap }, task let add_selector acc ts ty = function | [_] -> acc | csl -> add_selector acc ts ty csl let add_indexer (state,task) ts ty csl = (* declare the indexer function *) let mt_id = id_derive ("index_" ^ ts.ts_name.id_string) ts.ts_name in let mt_ls = create_fsymbol mt_id [ty] ty_int in let task = add_param_decl task mt_ls in (* define the indexer function *) let index = ref (-1) in let mt_add tsk (cs,_) = incr index; let id = mt_ls.ls_name.id_string ^ "_" ^ cs.ls_name.id_string in let pr = create_prsymbol (id_derive id cs.ls_name) in let vl = List.rev_map (create_vsymbol (id_fresh "u")) cs.ls_args in let hd = fs_app cs (List.rev_map t_var vl) (Opt.get cs.ls_value) in let ax = t_equ (fs_app mt_ls [hd] ty_int) (t_nat_const !index) in let ax = t_forall_close (List.rev vl) [[hd]] ax in add_prop_decl tsk Paxiom pr ax in let task = List.fold_left mt_add task csl in state, task let add_discriminator (state,task) ts ty csl = let d_add (c1,_) task (c2,_) = let id = c1.ls_name.id_string ^ "_" ^ c2.ls_name.id_string in let pr = create_prsymbol (id_derive id ts.ts_name) in let ul = List.rev_map (create_vsymbol (id_fresh "u")) c1.ls_args in let vl = List.rev_map (create_vsymbol (id_fresh "v")) c2.ls_args in let t1 = fs_app c1 (List.rev_map t_var ul) ty in let t2 = fs_app c2 (List.rev_map t_var vl) ty in let ax = t_neq t1 t2 in let ax = t_forall_close (List.rev vl) [[t2]] ax in let ax = t_forall_close (List.rev ul) [[t1]] ax in add_prop_decl task Paxiom pr ax in let rec dl_add task = function | c :: cl -> dl_add (List.fold_left (d_add c) task cl) cl | _ -> task in state, dl_add task csl let add_indexer acc ts ty = function | [_] -> acc | _ when (fst acc).keep_t -> acc | csl when not ((fst acc).no_ind) -> add_indexer acc ts ty csl | csl when List.length csl <= 16 -> add_discriminator acc ts ty csl | _ -> acc let meta_proj = (* projection symbol, constructor symbol, position, defining axiom *) register_meta "algtype projection" [MTlsymbol;MTlsymbol;MTint;MTprsymbol] ~desc:"Specify@ which@ projection@ symbol@ is@ used@ for@ the@ \ given@ constructor@ at@ the@ specified@ position.@ \ For@ internal@ use." let add_projections (state,task) _ts _ty csl = (* declare and define the projection functions *) let pj_add (m,tsk) (cs,pl) = let id = cs.ls_name.id_string ^ "_proj_" in let vl = List.rev_map (create_vsymbol (id_fresh "u")) cs.ls_args in let tl = List.rev_map t_var vl in let hd = fs_app cs tl (Opt.get cs.ls_value) in let c = ref 0 in let add (pjl,tsk) t pj = let ls = incr c; match pj with | Some pj -> pj | None -> let cn = string_of_int !c in let id = id_derive (id ^ cn) cs.ls_name in create_lsymbol id [Opt.get cs.ls_value] t.t_ty in let tsk = add_param_decl tsk ls in let id = id_derive (ls.ls_name.id_string ^ "_def") ls.ls_name in let pr = create_prsymbol id in let hh = t_app ls [hd] t.t_ty in let ax = t_forall_close (List.rev vl) [] (t_equ hh t) in let mal = [MAls ls; MAls cs; MAint (!c - 1); MApr pr] in let tsk = add_prop_decl tsk Paxiom pr ax in let tsk = if state.keep_t then add_meta tsk meta_proj mal else tsk in ls::pjl, tsk in let pjl,tsk = List.fold_left2 add ([],tsk) tl pl in Mls.add cs (List.rev pjl) m, tsk in let pjmap, task = List.fold_left pj_add (state.pj_map, task) csl in { state with pj_map = pjmap }, task let add_inversion (state,task) ts ty csl = if state.keep_t || state.no_inv then state, task else (* add the inversion axiom *) let ax_id = ts.ts_name.id_string ^ "_inversion" in let ax_pr = create_prsymbol (id_derive ax_id ts.ts_name) in let ax_vs = create_vsymbol (id_fresh "u") ty in let ax_hd = t_var ax_vs in let mk_cs (cs,_) = let pjl = Mls.find cs state.pj_map in let app pj = t_app_infer pj [ax_hd] in t_equ ax_hd (fs_app cs (List.map app pjl) ty) in let ax_f = Lists.map_join_left mk_cs t_or csl in let ax_f = t_forall_close [ax_vs] [] ax_f in state, add_prop_decl task Paxiom ax_pr ax_f let add_type (state,task) (ts,csl) = (* declare constructors as abstract functions *) let cs_add tsk (cs,_) = add_param_decl tsk cs in let task = if state.keep_t then task else List.fold_left cs_add task csl in (* add selector, projections, and inversion axiom *) let ty = ty_app ts (List.map ty_var ts.ts_args) in let state,task = add_selector (state,task) ts ty csl in let state,task = add_indexer (state,task) ts ty csl in let state,task = add_projections (state,task) ts ty csl in let state,task = add_inversion (state,task) ts ty csl in state, task let add_tags mts (state,task) (ts,csl) = let rec mat_ts sts ts csl = let sts = Sts.add ts sts in let add s (ls,_) = List.fold_left (mat_ty sts) s ls.ls_args in let stv = List.fold_left add Stv.empty csl in List.map (fun v -> Stv.mem v stv) ts.ts_args and mat_ty sts stv ty = match ty.ty_node with | Tyvar tv -> Stv.add tv stv | Tyapp (ts,tl) -> if Sts.mem ts sts then raise Exit; (* infinite type *) let matl = try Mts.find ts state.ma_map with Not_found -> mat_ts sts ts (Mts.find_def [] ts mts) in let add s mat ty = if mat then mat_ty sts s ty else s in List.fold_left2 add stv matl tl in try let matl = mat_ts state.inf_ts ts csl in let state = { state with ma_map = Mts.add ts matl state.ma_map } in let c = ref (-1) in let add_material task m = incr c; if m then add_meta task meta_material [MAts ts; MAint !c] else task in state, List.fold_left add_material task matl with Exit -> let state = { state with inf_ts = Sts.add ts state.inf_ts } in state, add_meta task meta_infinite [MAts ts] let comp t (state,task) = match t.task_decl.td_node with | Decl { d_node = Ddata dl } -> (* add type declarations *) let conv (cs,pjl) = cs, List.map (fun _ -> None) pjl in let conv (ts,csl) = ts, List.map conv csl in let task = if state.keep_t then add_data_decl task (List.map conv dl) else List.fold_left (fun t (ts,_) -> add_ty_decl t ts) task dl in (* add needed functions and axioms *) let state, task = List.fold_left add_type (state,task) dl in (* add the tags for infitite types and material arguments *) let mts = List.fold_right (fun (t,l) -> Mts.add t l) dl Mts.empty in let state, task = List.fold_left (add_tags mts) (state,task) dl in (* return the updated state and task *) state, task | Decl d -> let fnT = rewriteT t.task_known state in let fnF = rewriteF t.task_known state Svs.empty true in state, add_decl task (DeclTF.decl_map fnT fnF d) | Meta (m, [MAts ts]) when meta_equal m meta_infinite -> let state = { state with inf_ts = Sts.add ts state.inf_ts } in state, add_tdecl task t.task_decl | Meta (m, [MAts ts; MAint i]) when meta_equal m meta_material -> let ma = try Array.of_list (Mts.find ts state.ma_map) with | Not_found -> Array.make (List.length ts.ts_args) false in let ml = Array.set ma i true; Array.to_list ma in let state = { state with ma_map = Mts.add ts ml state.ma_map } in state, add_tdecl task t.task_decl | _ -> state, add_tdecl task t.task_decl let comp t (state,task) = match t.task_decl.td_node with | Decl ({ d_node = Ddata dl } as d) -> (* are we going to keep this type? *) let old_keep_t = state.keep_t in let state = match dl with | _ when state.keep_t -> state | [ts, [_]] when state.keep_r && not (Sid.mem ts.ts_name d.d_syms) -> { state with keep_t = true } | [{ ts_args = [] }, csl] when state.keep_e && List.for_all (fun (_,l) -> l = []) csl -> { state with keep_t = true } | _ -> state in let state,task = comp t (state,task) in { state with keep_t = old_keep_t }, task | _ -> comp t (state,task) let comp t (state,task) = match t.task_decl.td_node with | Decl ({ d_node = Ddata [ts,_] } as d) when is_ts_tuple ts -> let tp_map = Mid.add ts.ts_name d state.tp_map in { state with tp_map = tp_map }, task | Decl d -> let rstate,rtask = ref state, ref task in let add _ d () = let t = Opt.get (add_decl None d) in let state,task = comp t (!rstate,!rtask) in rstate := state ; rtask := task ; None in let tp_map = Mid.diff add state.tp_map d.d_syms in comp t ({ !rstate with tp_map = tp_map }, !rtask) | _ -> comp t (state,task) let init_task = let init = Task.add_meta None meta_infinite [MAts ts_int] in let init = Task.add_meta init meta_infinite [MAts ts_real] in init let eliminate_match = Trans.compose compile_match (Trans.fold_map comp empty_state init_task) let meta_elim = register_meta "eliminate_algebraic" [MTstring] ~desc:"@[Configure the 'eliminate_algebraic' transformation:@\n\ \"keep_types\" : @[keep algebraic type definitions@]@\n\ \"keep_enums\" : @[keep monomorphic enumeration types@]@\n\ \"keep_recs\" : @[keep non-recursive records@]@\n\ \"no_index\" : @[do not generate indexing functions@]@\n\ \"no_inversion\" : @[do not generate inversion axioms@]@\n\ \"no_selector\" : @[do not generate selector@]@]" let eliminate_algebraic = Trans.compose compile_match (Trans.on_meta meta_elim (fun ml -> let st = empty_state in let check st = function | [MAstr "keep_types"] -> { st with keep_t = true } | [MAstr "keep_enums"] -> { st with keep_e = true } | [MAstr "keep_recs"] -> { st with keep_r = true } | [MAstr "no_index"] -> { st with no_ind = true } | [MAstr "no_inversion"] -> { st with no_inv = true } | [MAstr "no_selector"] -> { st with no_sel = true } | _ -> raise (Invalid_argument "meta eliminate_algebraic") in let st = List.fold_left check st ml in Trans.fold_map comp st init_task)) (** Eliminate user-supplied projection functions *) let elim d = match d.d_node with | Ddata dl -> (* add type declarations *) let conv (cs,pjl) = cs, List.map (fun _ -> None) pjl in let conv (ts,csl) = ts, List.map conv csl in let td = create_data_decl (List.map conv dl) in (* add projection definitions *) let add vs csl acc pj = let mk_b (cs,pjl) = let mk_v = create_vsymbol (id_fresh "x") in let vl = List.map mk_v cs.ls_args in let p = pat_app cs (List.map pat_var vl) vs.vs_ty in let find acc v = function | Some ls when ls_equal ls pj -> t_var v | _ -> acc in let t = List.fold_left2 find t_true vl pjl in t_close_branch p t in let bl = List.map mk_b csl in let f = t_case (t_var vs) bl in let def = make_ls_defn pj [vs] f in create_logic_decl [def] :: acc in let add acc (_,csl) = let (cs,pjl) = List.hd csl in let ty = Opt.get cs.ls_value in let vs = create_vsymbol (id_fresh "v") ty in let get l = function Some p -> p::l | _ -> l in let pjl = List.fold_left get [] pjl in List.fold_left (add vs csl) acc pjl in td :: List.rev (List.fold_left add [] dl) | _ -> [d] let eliminate_projections = Trans.decl elim None let () = Trans.register_transform "compile_match" compile_match ~desc:"Transform@ pattern-matching@ with@ nested@ patterns@ \ into@ nested@ pattern-matching@ with@ flat@ patterns."; Trans.register_transform "eliminate_match" eliminate_match ~desc:"Eliminate@ all@ pattern-matching@ expressions."; Trans.register_transform "eliminate_algebraic" eliminate_algebraic ~desc:"Replace@ algebraic@ data@ types@ by@ first-order@ definitions."; Trans.register_transform "eliminate_projections" eliminate_projections ~desc:"Define@ algebraic@ projection@ symbols@ separately." (** conditional transformations, only applied when polymorphic types occur *) let eliminate_algebraic_if_poly = Trans.on_meta Detect_polymorphism.meta_monomorphic_types_only (function | [] -> eliminate_algebraic | _ -> compile_match) let () = Trans.register_transform "eliminate_algebraic_if_poly" eliminate_algebraic_if_poly ~desc:"Same@ as@ eliminate_algebraic@ but@ only@ if@ polymorphism@ appear." why3-0.88.3/src/transform/eliminate_if.mli0000664000175100017510000000152213225666037021206 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) val eliminate_if_term : Task.task Trans.trans val eliminate_if_fmla : Task.task Trans.trans val eliminate_if : Task.task Trans.trans why3-0.88.3/src/transform/inlining.ml0000664000175100017510000001035013225666037020216 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Ty open Term open Decl open Theory open Task let rec relocate loc t = t_map (relocate loc) (t_label ?loc t.t_label t) let t_unfold loc env fs tl ty = match Mls.find_opt fs env with | None -> t_app fs tl ty | Some (vl,e) -> let add (mt,mv) x y = ty_match mt x.vs_ty (t_type y), Mvs.add x y mv in let (mt,mv) = List.fold_left2 add (Ty.Mtv.empty, Mvs.empty) vl tl in let mt = oty_match mt e.t_ty ty in t_ty_subst mt mv (relocate loc e) (* inline every symbol *) let rec t_replace_all env t = let t = t_map (t_replace_all env) t in match t.t_node with | Tapp (fs,tl) -> t_label_copy t (t_unfold t.t_loc env fs tl t.t_ty) | _ -> t (* inline the top-most symbol *) let rec f_replace_top env f = match f.t_node with | Tapp (ps,_) when ls_equal ps ps_equ -> t_map (f_replace_top env) f | Tapp (ls,tl) -> t_label_copy f (t_unfold f.t_loc env ls tl f.t_ty) | _ when f.t_ty = None -> TermTF.t_map (fun t -> t) (f_replace_top env) f | _ -> f (* treat a declaration *) let fold in_goal notdeft notdeff notls d (env, task) = let d = match d.d_node with | Dprop (Pgoal,_,_) when in_goal -> decl_map (f_replace_top env) d | _ when in_goal -> d | _ -> decl_map (t_replace_all env) d in match d.d_node with | Dlogic [ls,ld] when not (notls ls) -> let vl,e = open_ls_defn ld in let inline = not (TermTF.t_select notdeft notdeff e || t_s_any Util.ffalse (ls_equal ls) e) in let env = if inline then Mls.add ls (vl,e) env else env in let task = if inline && not in_goal then task else Task.add_decl task d in env, task | _ -> env, Task.add_decl task d let fold in_goal notdeft notdeff notls task_hd (env, task) = match task_hd.task_decl.td_node with | Decl d -> fold in_goal notdeft notdeff notls d (env, task) | _ -> env, add_tdecl task task_hd.task_decl (* transformations *) let meta = Theory.register_meta "inline : no" [Theory.MTlsymbol] ~desc:"Disallow@ the@ inlining@ of@ the@ given@ function/predicate@ symbol." let t ?(use_meta=true) ?(in_goal=false) ~notdeft ~notdeff ~notls = let trans notls = Trans.fold_map (fold in_goal notdeft notdeff notls) Mls.empty None in if use_meta then Trans.on_tagged_ls meta (fun sls -> let notls ls = Sls.mem ls sls || notls ls in trans notls) else trans notls let all = t ~use_meta:true ~in_goal:false ~notdeft:Util.ffalse ~notdeff:Util.ffalse ~notls:Util.ffalse let goal = t ~use_meta:true ~in_goal:true ~notdeft:Util.ffalse ~notdeff:Util.ffalse ~notls:Util.ffalse (* inline_trivial *) let trivial tl = let add vs t = match t.t_node with | Tvar v when Mvs.mem v vs -> raise Util.FoldSkip | Tvar v -> Svs.add v vs | Teps _ -> raise Util.FoldSkip | _ when t_closed t -> vs | _ -> raise Util.FoldSkip in try ignore (List.fold_left add Svs.empty tl); true with Util.FoldSkip -> false let notdeft t = match t.t_node with | Tvar _ | Tconst _ -> false | Ttrue | Tfalse -> false | Tapp (_,tl) -> not (trivial tl) | _ -> true let trivial = t ~use_meta:true ~in_goal:false ~notdeft:notdeft ~notdeff:notdeft ~notls:Util.ffalse let () = Trans.register_transform "inline_all" all ~desc:"Inline@ non-recursive@ definitions."; Trans.register_transform "inline_goal" goal ~desc:"Same@ as@ 'inline_all', but@ only@ inline in@ goals."; Trans.register_transform "inline_trivial" trivial ~desc:"Inline@ trivial@ definitions@ like@ @[f(x,y) = g(y,x,0)@]." why3-0.88.3/src/transform/split_goal.mli0000664000175100017510000000633413225666037020724 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) val stop_split : Ident.label val split_pos_full : ?known_map:Decl.known_map -> Term.term -> Term.term list (** [split_pos_full f] returns a list [[g1;..;gk]] such that [f] is logically equivalent to [g1 /\ .. /\ gk] and the length of the resulting list can be exponential wrt the size of [f] *) val split_neg_full : ?known_map:Decl.known_map -> Term.term -> Term.term list (** [split_neg_full f] returns a list [[g1;..;gk]] such that [f] is logically equivalent to [g1 \/ .. \/ gk] and the length of the resulting list can be exponential wrt the size of [f] *) val split_pos_right : ?known_map:Decl.known_map -> Term.term -> Term.term list (** [split_pos_right] works as [split_pos_full] but does not split conjunctions under disjunctions and on the left of implications *) val split_neg_right : ?known_map:Decl.known_map -> Term.term -> Term.term list (** [split_neg_right] works as [split_neg_full] but does not split disjunctions and implications under conjunctions *) val split_proof_full : ?known_map:Decl.known_map -> Term.term -> Term.term list (** [split_proof_full f] returns a list of formulas whose conjunction implies f. The reverse implication also holds when f does not contain the by/so connectives. In this case, [split_pos_wp] works as [split_pos_full] but stops at the [stop_split] label and removes it. *) val split_proof_right : ?known_map:Decl.known_map -> Term.term -> Term.term list (** [split_proof_right f] returns a list of formulas whose conjunction implies f. The reverse implication also holds when f does not contain the by/so connectives. In this case, [split_pos_wp] works as [split_pos_right] but stops at the [stop_split] label and removes it. *) val split_intro_full : ?known_map:Decl.known_map -> Term.term -> Term.term list (** [split_intro_full] works as [split_pos_full] but does not respect the [asym_split] label, stops at the [stop_split] label and removes it *) val split_intro_right : ?known_map:Decl.known_map -> Term.term -> Term.term list (** [split_intro_right] works as [split_pos_right] but does not respect the [asym_split] label, stops at the [stop_split] label and removes it *) val split_goal_full : Task.task Trans.tlist val split_all_full : Task.task Trans.tlist val split_premise_full : Task.task Trans.trans val split_goal_right : Task.task Trans.tlist val split_all_right : Task.task Trans.tlist val split_premise_right : Task.task Trans.trans val split_goal_wp : Task.task Trans.tlist val split_all_wp : Task.task Trans.tlist val split_premise_wp : Task.task Trans.trans why3-0.88.3/src/transform/discriminate.mli0000664000175100017510000000251613225666037021240 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) val meta_inst : Theory.meta val meta_lskept : Theory.meta val meta_lsinst : Theory.meta module Lsmap : sig type t val empty : t val add : Term.lsymbol -> Ty.ty list -> Ty.ty option -> t -> t end val ft_select_inst : (Env.env,Ty.Sty.t) Trans.flag_trans val ft_select_lskept : (Env.env,Term.Sls.t) Trans.flag_trans val ft_select_lsinst : (Env.env,Lsmap.t) Trans.flag_trans val get_lsinst : Task.task -> Term.lsymbol Term.Mls.t val get_syntax_map : Task.task -> Printer.syntax_map val on_lsinst : (Term.lsymbol Term.Mls.t -> 'a Trans.trans) -> 'a Trans.trans val on_syntax_map : (Printer.syntax_map -> 'a Trans.trans) -> 'a Trans.trans why3-0.88.3/src/transform/lift_epsilon.mli0000664000175100017510000000130713225666037021251 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) why3-0.88.3/src/transform/instantiate_predicate.mli0000664000175100017510000000130713225666037023125 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) why3-0.88.3/src/transform/intro_projections_counterexmp.mli0000664000175100017510000000753613225666037024777 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (* Handling of labels *) val model_trace_regexp: Str.regexp (* The term labeled with "model_trace:name" will be in counterexample with name "name" *) val label_starts_with: Str.regexp -> Ident.label -> bool val get_label: Ident.Slab.t -> Str.regexp -> Ident.Slab.elt val intro_projections_counterexmp : Env.env -> Task.task Trans.trans (** Transformation that for each declared abstract function or predicate p labeled with label "model_projected" creates a declaration of new constant c labeled with label "model" and declaration of new axiom stating that c = f p where f is projection for p. Projections are composed from projection functions. Projection function is a function with a single argument tagged with metas "model_projection". Projection f for abstract function or predicate p is defined as: f = pf_n ... pf_1 id where id is identity function and pf_i for i = 1 .. n are projection functions for that it holds that the argument of pf_1 is of the same type as p, the return value of pf_i is of the same type as the argument of pf_i+1, for all i, j = 1 .. n pf_i <> pf_j, and there is no projection function pf that could further project f. projected. That is, projection for p is identify if there is no projection function with an argument of the same type as p. Projections can be given names by labeling projection function by label of the form "model_trace:proj_name". If predicate p has has a label of the form "model_trace:p_name@*", the constant will have a label of the form "model_trace:p_nameproj_name@*". This is especially usefull when projetions are projecting record type to its elements (there is one projection for every record element with name ".record_element_name". Note that in order this work, projection functions cannot be inlined. If inlining transformation is performed, projection functions must be marked with meta "inline : no". This transformation is needed in situations when we want to display not value of a variable, but value of a projection function applied to a variable. This is needed, e.g., in cases when the type of a variable is abstract. Note that since Why3 supports namespaces (different projection functions can have the same name) and input languages of solvers typically not, Why3 renames projection functions to avoid name clashes. This is why it is not possible to just store the name of the projection function in a label and than query the solver directly for the value of the projection. Also, it means that this transformation must be executed before this renaming. *) val intro_const_equal_to_term : term : Term.term -> id_new : Ident.preid -> axiom_name : string -> Decl.decl list (** Creates declaration of new constant and declaration of axiom stating that the constant is equal to given term. @param term the term to which the new constant will be equal @param id_new the preid composed of the name, label and loc of the constant @param axiom_name the name of the axiom about the constant @return the definition of the constant and axiom about the constant *) why3-0.88.3/src/transform/encoding.ml0000664000175100017510000001051313225666037020176 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Stdlib open Ty open Theory open Task open Trans let meta_select_kept = register_meta_excl "select_kept" [MTstring] ~desc:"Specify@ the@ types@ to@ mark@ with@ 'encoding : kept':@; \ @[\ - none: @[don't@ mark@ any@ type@ automatically@]@\n\ - goal: @[mark@ every@ closed@ type@ in@ the@ goal@]@\n\ - all: @[mark@ every@ closed@ type@ in@ the@ task.@]\ @]" let meta_select_kept_default = register_meta_excl "select_kept_default" [MTstring] ~desc:"Default@ setting@ for@ select_kept" let meta_enco_kept = register_meta_excl "enco_kept" [MTstring] ~desc:"Specify@ the@ type@ protection@ transformation:@; \ @[\ - @[twin: use@ conversion@ functions@ between@ the@ kept@ types@ \ and@ the@ universal@ type@]@\ @]" let meta_enco_poly = register_meta_excl "enco_poly" [MTstring] ~desc:"Specify@ the@ type@ encoding@ transformation:@; \ @[\ - @[tags: protect@ variables@ in@ equalities@ \ with@ type@ annotations@]@\n\ - @[guards: protect@ variables@ in@ equalities@ \ with@ type@ conditions@]\n\ - @[tags_full: put@ type@ annotations@ on@ top@ \ of@ every@ term@]@\n\ - @[guards_full: add@ type@ conditions@ for@ every@ variable.@]\ @]" let def_enco_select_smt = "none" let def_enco_kept_smt = "twin" let def_enco_poly_smt = "guards" let def_enco_poly_tptp = "tags" let ft_select_kept = ((Hstr.create 17) : (Env.env,Sty.t) Trans.flag_trans) let ft_enco_kept = ((Hstr.create 17) : (Env.env,task) Trans.flag_trans) let ft_enco_poly = ((Hstr.create 17) : (Env.env,task) Trans.flag_trans) let select_kept def env = let def = Trans.on_flag meta_select_kept_default ft_select_kept def in let select = Trans.on_flag_t meta_select_kept ft_select_kept def env in let trans task = let add ty acc = create_meta Libencoding.meta_kept [MAty ty] :: acc in let decls = Sty.fold add (Trans.apply select task) [] in Trans.apply (Trans.add_tdecls decls) task in Trans.store trans let forget_kept = Trans.fold (fun hd task -> match hd.task_decl.td_node with | Meta (m,_) when meta_equal m Libencoding.meta_kept -> task | _ -> add_tdecl task hd.task_decl) None let encoding_smt env = Trans.seq [ Libencoding.monomorphise_goal; select_kept def_enco_select_smt env; Trans.print_meta Libencoding.debug Libencoding.meta_kept; Trans.trace_goal "meta_enco_kept" (Trans.on_flag meta_enco_kept ft_enco_kept def_enco_kept_smt env); Trans.on_flag meta_enco_poly ft_enco_poly def_enco_poly_smt env] let encoding_tptp env = Trans.seq [ Libencoding.monomorphise_goal; forget_kept; Trans.on_flag meta_enco_poly ft_enco_poly def_enco_poly_tptp env] let () = register_env_transform "encoding_smt" encoding_smt ~desc:"Encode@ polymorphic@ types@ for@ provers@ with@ sorts." let () = register_env_transform "encoding_tptp" encoding_tptp ~desc:"Encode@ polymorphic@ types@ for@ provers@ without@ sorts." (* encoding only if polymorphism occurs *) let encoding_smt_if_poly env = Trans.on_meta Detect_polymorphism.meta_monomorphic_types_only (function | [] -> encoding_smt env | _ -> Trans.identity) let () = Trans.register_env_transform "encoding_smt_if_poly" encoding_smt_if_poly ~desc:"Same@ as@ encoding_smt@ but@ only@ if@ polymorphism@ appear." let encoding_tptp_if_poly env = Trans.on_meta Detect_polymorphism.meta_monomorphic_types_only (function | [] -> encoding_tptp env | _ -> Trans.identity) let () = Trans.register_env_transform "encoding_tptp_if_poly" encoding_tptp_if_poly ~desc:"Same@ as@ encoding_tptp@ but@ only@ if@ polymorphism@ appear." why3-0.88.3/src/transform/introduction.mli0000664000175100017510000000245313225666037021306 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** Introduction of premises *) (** The premises of the goal of a task are introduced in the context, e.g goal G: forall x:t, f1 -> forall y:u, f2 and f3 -> f4 becomes logic x:t axiom H1: f1 logic y:u axiom H2: f2 axiom H3: f3 goal G: f4 *) val intros : Decl.prsymbol -> Term.term -> Decl.decl list (** [intros G f] returns the declarations after introducing premises of [goal G : f] *) val introduce_premises : Task.task Trans.trans val split_intro : Task.task Trans.tlist (** [split_intro] is [split_goal_wp] followed by [introduce_premises] *) why3-0.88.3/src/transform/encoding_twin.ml0000664000175100017510000001014613225666037021241 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Stdlib open Ident open Ty open Term open Decl let make_pont = Wty.memoize 3 (fun ty -> let t2tb = let t2tb_name = "t2tb" in let t2tb_id = Libencoding.id_unprotected t2tb_name in create_fsymbol t2tb_id [ty] ty in let tb2t = let tb2t_name = "tb2t" in let tb2t_id = Libencoding.id_unprotecting tb2t_name in create_fsymbol tb2t_id [ty] ty in let t2tb_def = create_param_decl t2tb in let tb2t_def = create_param_decl tb2t in let bridge_l = let x_vs = create_vsymbol (id_fresh "i") ty in let x_t = t_var x_vs in let t2tb_x = fs_app t2tb [x_t] ty in let tb2t_t2tb_x = fs_app tb2t [t2tb_x] ty in let eq = t_equ tb2t_t2tb_x x_t in let ax = t_forall_close [x_vs] [[t2tb_x]] eq in let pr = create_prsymbol (id_fresh "BridgeL") in create_prop_decl Paxiom pr ax in let bridge_r = let x_vs = create_vsymbol (Libencoding.id_unprotected "j") ty in let x_t = t_var x_vs in let tb2t_x = fs_app tb2t [x_t] ty in let t2tb_tb2t_x = fs_app t2tb [tb2t_x] ty in let eq = t_equ t2tb_tb2t_x x_t in let ax = t_forall_close [x_vs] [[t2tb_tb2t_x]] eq in let pr = create_prsymbol (id_fresh "BridgeR") in create_prop_decl Paxiom pr ax in t2tb, tb2t, [t2tb_def; tb2t_def; bridge_l; bridge_r]) let seen = Hty.create 7 let add_decls tenv decls = let add ty () decls = let _,_,defs = Mty.find ty tenv in List.append defs decls in let decls = Hty.fold add seen decls in Hty.clear seen; decls let conv_arg tenv t aty = let tty = t_type t in if ty_equal tty aty then t else try let t2tb,tb2t,_ = Mty.find tty tenv in Hty.replace seen tty (); match t.t_node with | Tapp (fs,[t]) when ls_equal fs tb2t -> t | _ -> fs_app t2tb [t] tty with Not_found -> t let conv_app tenv fs tl tty = let t = fs_app fs tl tty in let vty = Opt.get fs.ls_value in if ty_equal tty vty then t else try let _,tb2t,_ = Mty.find tty tenv in Hty.replace seen tty (); fs_app tb2t [t] tty with Not_found -> t (* FIXME? in quantifiers we might generate triggers with unnecessary bridge functions over them *) let rec rewrite tenv t = match t.t_node with | Tapp (ls,[t1;t2]) when ls_equal ls ps_equ -> t_label_copy t (t_equ (rewrite tenv t1) (rewrite tenv t2)) | Tapp (ls,tl) -> let tl = List.map (rewrite tenv) tl in let tl = List.map2 (conv_arg tenv) tl ls.ls_args in if t.t_ty = None then t_label_copy t (ps_app ls tl) else t_label_copy t (conv_app tenv ls tl (t_type t)) | _ -> t_map (rewrite tenv) t let decl tenv d = match d.d_node with | Dtype _ | Dparam _ -> [d] | Ddata _ -> Printer.unsupportedDecl d "Algebraic and recursively-defined types are \ not supported, run eliminate_algebraic" | Dlogic [ls,ld] when not (Sid.mem ls.ls_name d.d_syms) -> let f = rewrite tenv (ls_defn_axiom ld) in Libencoding.defn_or_axiom ls f | Dlogic _ -> Printer.unsupportedDecl d "Recursively defined symbols are not supported, run eliminate_recursion" | Dind _ -> Printer.unsupportedDecl d "Inductive predicates are not supported, run eliminate_inductive" | Dprop (k,pr,f) -> [create_prop_decl k pr (rewrite tenv f)] let decl tenv d = let decls = decl tenv d in add_decls tenv decls let t = Trans.on_tagged_ty Libencoding.meta_kept (fun s -> Trans.decl (decl (Mty.mapi (fun ty () -> make_pont ty) s)) None) let () = Hstr.replace Encoding.ft_enco_kept "twin" (Util.const t) why3-0.88.3/src/transform/prepare_for_counterexmp.ml0000664000175100017510000000412013225666037023342 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Task let debug = Debug.register_info_flag "prepare_for_counterexmp" ~desc:"Print@ debugging@ messages@ about@ preparing@ the@ task@ for@ getting@ counter-example." let meta_get_counterexmp = Theory.register_meta_excl "get_counterexmp" [] ~desc:"Set@ when@ counter-example@ should@ be@ get." let get_counterexmp task = let ce_meta = Task.find_meta_tds task meta_get_counterexmp in not (Theory.Stdecl.is_empty ce_meta.tds_set) let prepare_for_counterexmp2 env task = if not (get_counterexmp task) then begin (* Counter-example will not be queried, do nothing *) Debug.dprintf debug "Not get ce@."; task end else begin (* Counter-example will be queried, prepare the task *) Debug.dprintf debug "Get ce@."; let comp_trans = Trans.compose Intro_vc_vars_counterexmp.intro_vc_vars_counterexmp (Intro_projections_counterexmp.intro_projections_counterexmp env) in (Trans.apply comp_trans) task end let prepare_for_counterexmp env = Trans.store (prepare_for_counterexmp2 env) let () = Trans.register_env_transform "prepare_for_counterexmp" prepare_for_counterexmp ~desc:"Transformation@ that@ prepares@ the@ task@ for@ querying@ for@ \ the@ counter-example@ model.@ This@ transformation@ does@ so@ only@ \ when@ the@ solver@ will@ be@ asked@ for@ the@ counter-example." (* Local Variables: compile-command: "unset LANG; make -C ../.. byte" End: *) why3-0.88.3/src/transform/eliminate_epsilon.mli0000664000175100017510000000144613225666037022266 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) val eliminate_epsilon : Task.task Trans.trans val eliminate_nl_epsilon : Task.task Trans.trans why3-0.88.3/src/transform/encoding_select.mli0000664000175100017510000000165513225666037021715 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (* These modules are used only for their side-effects at load time Do not remove these from the .mli, it would trigger the new warning 60 of OCaml 4.04 *) module Kept : sig end module Lskept : sig end module Lsinst : sig end why3-0.88.3/src/transform/eliminate_definition.mli0000664000175100017510000000324513225666037022744 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) val eliminate_builtin : Task.task Trans.trans val compute_diff : (Theory.meta * Theory.meta_arg list) list Trans.trans Trans.trans (** compute the meta_remove given two tasks one included in the other *) val eliminate_definition_func : Task.task Trans.trans val eliminate_definition_pred : Task.task Trans.trans val eliminate_definition : Task.task Trans.trans val eliminate_definition_gen : (Term.lsymbol -> bool) -> Task.task Trans.trans val eliminate_mutual_recursion: Task.task Trans.trans (** bisection *) val bisect : (Task.task -> bool) -> Task.task -> (Theory.meta * Theory.meta_arg list) list (** [bisect test task] return metas that specify the symbols that can be removed without making the task invalid for the function test. *) type bisect_step = | BSdone of (Theory.meta * Theory.meta_arg list) list | BSstep of Task.task * (bool -> bisect_step) val bisect_step : Task.task -> bisect_step (** Same as before but doing it step by step *) why3-0.88.3/src/transform/induction_pr.mli0000664000175100017510000000130713225666037021257 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) why3-0.88.3/src/transform/close_epsilon.ml0000664000175100017510000000575413225666037021261 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Theory open Decl open Term let is_func_ty t = match t.Ty.ty_node with | Ty.Tyapp (s,_) -> Ty.ts_equal s Ty.ts_func || Ty.ts_equal s Ty.ts_pred | _ -> false type lambda_match = | Flam of vsymbol list * trigger * term | Tlam of vsymbol list * trigger * term | LNone let destruct_lambda t = match t.t_node with | Teps fb -> let fn, f = t_open_bound fb in if is_func_ty fn.vs_ty then begin match f.t_node with | Tquant (Tforall, fq) -> let args, trs, f = t_open_quant fq in begin match f.t_node with | Tbinop (Tiff,_,body) -> Flam (args, trs, body) | Tapp (ls,[_;body]) when ls_equal ls ps_equ -> Tlam (args, trs, body) | _ -> LNone end | _ -> LNone end else LNone | _ -> LNone let is_lambda t = destruct_lambda t <> LNone let rec rewriteT t = match t.t_node with | Teps fb when is_lambda t -> let fv = Mvs.keys (t_vars t) in let x, f = t_open_bound fb in let f = rewriteF f in if fv = [] then t_eps_close x f else (* the type, symbol and term of the new epsilon-symbol [magic] *) let magic_ty = List.fold_right (fun x acc -> Ty.ty_func x.vs_ty acc) fv x.vs_ty in let magic_fs = create_vsymbol (Ident.id_fresh "f") magic_ty in let magic_f = t_var magic_fs in (* the application of [magic] to the free variables *) let rx = List.fold_left (fun acc x -> t_func_app acc (t_var x)) magic_f fv in (* substitute [magic] for [x] *) let f = t_subst_single x rx f in (* quantify over free variables and epsilon-close over [magic] *) let f = t_forall_close_merge fv f in let f = t_eps_close magic_fs f in (* apply epsilon-term to variables *) List.fold_left (fun acc x -> t_func_app acc (t_var x)) f fv | _ -> TermTF.t_map rewriteT rewriteF t and rewriteF f = TermTF.t_map rewriteT rewriteF f let close d = [DeclTF.decl_map rewriteT rewriteF d] let close_epsilon = Trans.on_used_theory highord_theory (fun used -> if used then Trans.decl close None else Trans.identity) let () = Trans.register_transform "close_epsilon" close_epsilon ~desc:"Beta-abstract free variables out of lambda-terms." (* TODO variable abstraction *) why3-0.88.3/src/transform/induction_pr.ml0000664000175100017510000002116713225666037021114 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Ident open Ty open Term open Decl open Theory open Task let lab_ind = create_label "induction" let lab_inv = create_label "inversion" type context = { c_node : context_node; c_label: Slab.t; c_loc: Loc.position option } and context_node = | Hole | Clet of vsymbol * term * context (* triggers are forgotten on purpose *) | Cforall of vsymbol list * context | Cimplies of term * context exception Ind_not_found let make_context node term = { c_node = node; c_label = term.t_label; c_loc = term.t_loc } let make_context_ctx node context = { c_node = node; c_label = context.c_label; c_loc = context.c_loc } (* Locate induction term in [t]: either leftmost inductive on the implication chain, or the one labeled with [label]. If found, return [ctx, (ls,argl,cl), rhs] where: [ctx] is the context in which term is found (leftmost part of the context at top, e.g term with hole) [ls] is the inductive symbol [argl] are the argument with which the inductive symbol is instantiated [cl] are the inductive symbol clauses [rhs] is the part of the term 'right' to the induction term ([t] is decomposed as ctx[ls(argl) -> rhs]) If not found, raise Ind_not_found *) let locate kn label t = let rec locate_inductive find_any t = match t.t_node with | Tlet (t1, tb) -> let vs,t2 = t_open_bound tb in let ctx, ind, goal = locate_inductive find_any t2 in make_context (Clet (vs, t1, ctx)) t, ind, goal | Tquant(Tforall, tq) -> let vsl, _, t1 = t_open_quant tq in let ctx, ind, goal = locate_inductive find_any t1 in make_context (Cforall (vsl, ctx)) t, ind, goal | Tbinop (Timplies, lhs, rhs) -> let locate_rhs find_any = let ctx, ind, goal = locate_inductive find_any rhs in make_context (Cimplies (lhs, ctx)) t, ind, goal in let slab () = Slab.mem label lhs.t_label in if find_any || (slab ()) then match lhs.t_node with | Tapp (ls, argl) -> begin match (Mid.find ls.ls_name kn).d_node with | Dind (Ind, dl) -> let cl = List.assq ls dl in if find_any && not (slab ()) then (* take first labeled inductive in rhs if any. Otherwise, take lhs *) try locate_rhs false with Ind_not_found -> make_context Hole t, (ls, argl, cl), rhs else (* here a label has been found *) make_context Hole t, (ls, argl, cl), rhs | Dind _ | Dlogic _ | Dparam _ | Ddata _ -> locate_rhs find_any | Dtype _ | Dprop _ -> assert false end | _ -> locate_rhs find_any else locate_rhs find_any | _ -> raise Ind_not_found in locate_inductive true t (* Find arguments of the inductive that are unchanged within recursion. *) type 'a matching = | Any | Equal of 'a | Nothing let matching eq a b = match a with | Any -> Equal b | Equal a when eq a b -> Equal a | _ -> Nothing (* Identify parameters of an inductive declaration. *) let parameters ls cl = let rec explore l t = let l = match t.t_node with | Tapp (ls2, args) when ls_equal ls ls2 -> List.map2 (matching t_equal) l args | _ -> l in t_fold explore l t in let clause l (_,c) = List.map (function Nothing -> Nothing | _ -> Any) (explore l c) in let l = List.map (fun _ -> Any) ls.ls_args in let l = List.fold_left clause l cl in List.map (function Nothing -> false | _ -> true) l (* Partition [ctx] into two contexts, the first one containing the part independent on [vsi] and the second one containing the part that depends on [vsi]. input [ctx] is taken as a term with hole, and outputs are in reverse order (e.g zippers) *) let partition ctx vsi = let rec aux ctx vsi_acc cindep cdep = match ctx.c_node with | Hole -> cindep, cdep | Cimplies (t, ctx2) -> let add c = make_context_ctx (Cimplies (t, c)) ctx in let cindep, cdep = let fvs = t_vars t in if Mvs.is_empty (Mvs.set_inter fvs vsi_acc) then add cindep, cdep else cindep, add cdep in aux ctx2 vsi_acc cindep cdep | Cforall (vsl, ctx2) -> let add c = function | [] -> c | vl -> make_context_ctx (Cforall (vl, c)) ctx in let vsl = List.filter (fun v -> not (Mvs.mem v vsi)) vsl in let vdep, vindep = List.partition (fun v -> Mvs.mem v vsi_acc) vsl in aux ctx2 vsi_acc (add cindep vindep) (add cdep vdep) | Clet (vs, t, ctx2) -> if Mvs.mem vs vsi then let t = t_equ (t_var vs) t in let cdep = make_context_ctx (Cimplies (t, cdep)) ctx in aux ctx2 vsi_acc cindep cdep else let add c = make_context_ctx (Clet (vs, t, c)) ctx in let fvs = t_vars t in if Mvs.is_empty (Mvs.set_inter fvs vsi_acc) then aux ctx2 vsi_acc (add cindep) cdep else aux ctx2 (Mvs.add vs 1 vsi_acc) cindep (add cdep) in let hole = make_context_ctx Hole ctx in aux ctx vsi hole hole (* Add equalities between clause variables and parameters. *) let introduce_equalities vsi paraml argl goal = let goal = List.fold_left2 (fun g p a -> t_implies (t_equ a p) g) goal paraml argl in t_forall_close (Mvs.keys vsi) [] goal (* Zip term within context. *) let rec zip ctx goal = match ctx.c_node with | Hole -> goal | Cimplies (t, ctx2) -> zip ctx2 (t_label ?loc:ctx.c_loc ctx.c_label (t_implies t goal)) | Cforall (vsl, ctx2) -> zip ctx2 (t_label ?loc:ctx.c_loc ctx.c_label (t_forall_close vsl [] goal)) | Clet (vs, t, ctx2) -> zip ctx2 (t_label ?loc:ctx.c_loc ctx.c_label (t_let_close vs t goal)) (* Replace clause by the associated inductive case. *) let substitute_clause induct vsi ls argl goal c = let sigma = ls_arg_inst ls argl in let c = t_ty_subst sigma Mvs.empty c in let rec subst keepi t = match t.t_node with | Tapp (ls', paraml) when ls_equal ls ls' -> let t2 () = introduce_equalities vsi paraml argl goal in if keepi then if induct && List.for_all2 (fun a b -> Opt.equal ty_equal a.t_ty b.t_ty) argl paraml then t_and t (t2 ()) (* FIXME: in case of polymorphic recursion we do not generate IHs *) else t else t2 () | _ -> t_map (subst keepi) t in let rec aux t = match t.t_node with | Tlet (t1, tb) -> let vs, t2, cb = t_open_bound_cb tb in t_label_copy t (t_let t1 (cb vs (aux t2))) | Tquant(Tforall, tq) -> let vsl, tr, t1, cb = t_open_quant_cb tq in t_label_copy t (t_forall (cb vsl tr (aux t1))) | Tbinop (Timplies, lhs, rhs) -> t_label_copy t (t_implies (subst true lhs) (aux rhs)) | _ -> subst false t in aux c let induction_l label induct kn t = let (ctx, (ls, argl, cl), goal) = locate kn label t in let fold vsi p t = if p then vsi else t_freevars vsi t in let vsi = List.fold_left2 fold Mvs.empty (parameters ls cl) argl in (*let vsi = t_vars (t_app_infer ls argl) in*) let cindep, cdep = partition ctx vsi in let goal = zip cdep goal in List.map (fun (_,c) -> zip cindep (substitute_clause induct vsi ls argl goal c)) cl let induction_l label induct task = match task with | Some { task_decl ={ td_node = Decl { d_node = Dprop (Pgoal, pr, f) } }; task_prev = prev; task_known = kn } -> begin try List.map (add_prop_decl prev Pgoal pr) (induction_l label induct kn f) with Ind_not_found -> [task] end | _ -> assert false let () = Trans.register_transform_l "induction_pr" (Trans.store (induction_l lab_ind true)) ~desc:"Generate@ induction@ hypotheses@ for@ goals@ over@ inductive@ predicates." let () = Trans.register_transform_l "inversion_pr" (Trans.store (induction_l lab_inv false)) ~desc:"Invert@ inductive@ predicate." (* Local Variables: compile-command: "unset LANG; make -C ../.. bin/why3.byte" End: *) why3-0.88.3/src/transform/eval_match.mli0000664000175100017510000000160713225666037020670 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Ty open Term open Decl type inline = known_map -> lsymbol -> ty list -> ty option -> bool val eval_match: inline:inline -> known_map -> term -> term val inline_nonrec_linear : inline why3-0.88.3/src/transform/encoding_guards.mli0000664000175100017510000000130713225666037021715 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) why3-0.88.3/src/transform/simplify_formula.mli0000664000175100017510000000254313225666037022146 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) val fmla_simpl : Term.term -> Term.term val simplify_formula : Task.task Trans.trans val simplify_formula_and_task : Task.task list Trans.trans val fmla_remove_quant : Term.term -> Term.term (** transforms \exists x. x == y /\ F into F[y/x] and \forall x. x <> y \/ F into F[y/x] *) val fmla_cond_subst: (Term.term -> Term.term -> bool) -> Term.term -> Term.term (** given a formula [f] containing some equality or disequality [t1] ?= [t2] such that [filter t1 t2] (resp [filter t2 t1]) evaluates to true, [fmla_subst_cond filter f] performs the substitution [t1] -> [t2] (resp [t2] -> [t1]) wherever possible and returns an equivalent formula *) why3-0.88.3/src/transform/encoding.mli0000664000175100017510000000174113225666037020352 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) val ft_select_kept : (Env.env,Ty.Sty.t) Trans.flag_trans val ft_enco_kept : (Env.env,Task.task) Trans.flag_trans val ft_enco_poly : (Env.env,Task.task) Trans.flag_trans val encoding_smt : Env.env -> Task.task Trans.trans val encoding_tptp : Env.env -> Task.task Trans.trans why3-0.88.3/src/ide/0000775000175100017510000000000013225666037014604 5ustar guillaumeguillaumewhy3-0.88.3/src/ide/resetgc.c0000664000175100017510000000266213225666037016412 0ustar guillaumeguillaume/********************************************************************/ /* */ /* The Why3 Verification Platform / The Why3 Development Team */ /* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University */ /* */ /* This software is distributed under the terms of the GNU Lesser */ /* General Public License version 2.1, with the special exception */ /* on linking described in file LICENSE. */ /* */ /********************************************************************/ #include #include /* Whenever this variable reaches 1, a garbage collection starts and the variable is reset to 0. Unfortunately, it might take as few as 50 allocations of Glib/Gdk/Gtk objects for the variable to go from 0 to 1. Most IDE operations involve tens, if not, hundreds, of such objects, thus causing the garbage collector to constantly run. */ extern double caml_extra_heap_resources; /* Set the accumulator to -inf to prevent it from reaching 1. It might still reach it, since any collection sets it to 0, so the hack only works for a short while. */ CAMLprim value ml_reset_gc(value unit) { CAMLparam1(unit); caml_extra_heap_resources = - 1.0 / 0.0; CAMLreturn(Val_unit); } why3-0.88.3/src/ide/gconfig.mli0000664000175100017510000001042413225666037016724 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Why3 type t = { mutable window_width : int; mutable window_height : int; mutable tree_width : int; mutable font_size : int; mutable current_tab : int; mutable verbose : int; mutable default_prover : string; mutable default_editor : string; mutable intro_premises : bool; mutable show_labels : bool; mutable show_locs : bool; mutable show_time_limit : bool; mutable max_boxes : int; mutable saving_policy : int; mutable premise_color : string; mutable neg_premise_color : string; mutable goal_color : string; mutable error_color : string; mutable iconset : string; mutable env : Why3.Env.env; mutable config : Whyconf.config; original_config : Whyconf.config; (* mutable altern_provers : prover option Mprover.t; *) (* mutable replace_prover : conf_replace_prover; *) mutable hidden_provers : string list; mutable session_time_limit : int; mutable session_mem_limit : int; mutable session_nb_processes : int; mutable session_cntexample : bool; } val load_config : Whyconf.config -> Whyconf.config -> Why3.Env.env -> unit (** [load_config config original_config env] creates and saves IDE config *) val init : unit -> unit val save_config : unit -> unit val config : unit -> t (** [config ()] raise [invalid_arg "configuration not yet loaded"] if load_config is not called *) val get_main : unit -> Whyconf.main val incr_font_size : int -> int (** [incr_font_size n] increments current font size by [n] (can be negative) and returns the new size *) (*****************) (* images, icons *) (*****************) val why_icon : GdkPixbuf.pixbuf ref val image_yes : GdkPixbuf.pixbuf ref (* tree object icons *) val image_file : GdkPixbuf.pixbuf ref val image_theory : GdkPixbuf.pixbuf ref val image_goal : GdkPixbuf.pixbuf ref val image_prover : GdkPixbuf.pixbuf ref val image_transf : GdkPixbuf.pixbuf ref val image_metas : GdkPixbuf.pixbuf ref val image_editor : GdkPixbuf.pixbuf ref val image_replay : GdkPixbuf.pixbuf ref val image_cancel : GdkPixbuf.pixbuf ref val image_reload : GdkPixbuf.pixbuf ref val image_remove : GdkPixbuf.pixbuf ref val image_cleaning : GdkPixbuf.pixbuf ref (* status icons *) val image_undone : GdkPixbuf.pixbuf ref val image_scheduled : GdkPixbuf.pixbuf ref val image_running : GdkPixbuf.pixbuf ref val image_valid : GdkPixbuf.pixbuf ref val image_invalid : GdkPixbuf.pixbuf ref val image_timeout : GdkPixbuf.pixbuf ref val image_outofmemory : GdkPixbuf.pixbuf ref val image_steplimitexceeded : GdkPixbuf.pixbuf ref val image_unknown : GdkPixbuf.pixbuf ref val image_failure : GdkPixbuf.pixbuf ref val image_valid_obs : GdkPixbuf.pixbuf ref val image_invalid_obs : GdkPixbuf.pixbuf ref val image_timeout_obs : GdkPixbuf.pixbuf ref val image_outofmemory_obs : GdkPixbuf.pixbuf ref val image_steplimitexceeded_obs : GdkPixbuf.pixbuf ref val image_unknown_obs : GdkPixbuf.pixbuf ref val image_failure_obs : GdkPixbuf.pixbuf ref (*************************) (* miscellaneous dialogs *) (*************************) val show_legend_window : unit -> unit val show_about_window : unit -> unit val preferences : t -> unit val uninstalled_prover : t -> 'key Session.env_session -> Whyconf.prover -> Whyconf.prover_upgrade_policy (* val unknown_prover : t -> 'key Session.env_session -> Whyconf.prover -> Whyconf.prover option *) (* obsolete dialog val replace_prover : t -> 'key Session.proof_attempt -> 'key Session.proof_attempt -> bool *) (* Local Variables: compile-command: "unset LANG; make -C ../.. bin/why3ide.byte" End: *) why3-0.88.3/src/ide/gconfig.ml0000664000175100017510000012477513225666037016572 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Why3 open Rc open Whyconf let debug = Debug.register_info_flag "ide_info" ~desc:"Print@ why3ide@ debugging@ messages." (** set the exception call back handler to the Exn_printer of why3 *) let () = (***** TODO TODO make that work, it seems not called!!! *) let why3_handler exn = Format.eprintf "@[Why3ide callback raised an exception:@\n%a@]@.@." Exn_printer.exn_printer exn; (* print the stack trace if asked to (can't be done by the usual way) *) if Debug.test_flag Debug.stack_trace then Printf.eprintf "Backtrace:\n%t\n%!" Printexc.print_backtrace in GtkSignal.user_handler := why3_handler (* config file *) type t = { mutable window_width : int; mutable window_height : int; mutable tree_width : int; mutable font_size : int; mutable current_tab : int; mutable verbose : int; mutable default_prover : string; (* "" means none *) mutable default_editor : string; mutable intro_premises : bool; mutable show_labels : bool; mutable show_locs : bool; mutable show_time_limit : bool; mutable max_boxes : int; mutable saving_policy : int; (** 0 = always, 1 = never, 2 = ask *) mutable premise_color : string; mutable neg_premise_color : string; mutable goal_color : string; mutable error_color : string; mutable iconset : string; (** colors *) mutable env : Env.env; mutable config : Whyconf.config; original_config : Whyconf.config; (* mutable altern_provers : altern_provers; *) (* mutable replace_prover : conf_replace_prover; *) (* hidden prover buttons *) mutable hidden_provers : string list; mutable session_time_limit : int; mutable session_mem_limit : int; mutable session_nb_processes : int; mutable session_cntexample : bool; } type ide = { ide_window_width : int; ide_window_height : int; ide_tree_width : int; ide_font_size : int; ide_current_tab : int; ide_verbose : int; ide_intro_premises : bool; ide_show_labels : bool; ide_show_locs : bool; ide_show_time_limit : bool; ide_max_boxes : int; ide_saving_policy : int; ide_premise_color : string; ide_neg_premise_color : string; ide_goal_color : string; ide_error_color : string; ide_iconset : string; ide_default_prover : string; ide_default_editor : string; (* ide_replace_prover : conf_replace_prover; *) ide_hidden_provers : string list; } let default_ide = { ide_window_width = 1024; ide_window_height = 768; ide_tree_width = 512; ide_font_size = 10; ide_current_tab = 0; ide_verbose = 0; ide_intro_premises = true; ide_show_labels = false; ide_show_locs = false; ide_show_time_limit = false; ide_max_boxes = 16; ide_saving_policy = 2; ide_premise_color = "chartreuse"; ide_neg_premise_color = "pink"; ide_goal_color = "gold"; ide_error_color = "orange"; ide_iconset = "fatcow"; ide_default_prover = ""; ide_default_editor = (try Sys.getenv "EDITOR" ^ " %f" with Not_found -> "editor %f"); ide_hidden_provers = []; } let load_ide section = { ide_window_width = get_int section ~default:default_ide.ide_window_width "window_width"; ide_window_height = get_int section ~default:default_ide.ide_window_height "window_height"; ide_tree_width = get_int section ~default:default_ide.ide_tree_width "tree_width"; ide_current_tab = get_int section ~default:default_ide.ide_current_tab "current_tab"; ide_font_size = get_int section ~default:default_ide.ide_font_size "font_size"; ide_verbose = get_int section ~default:default_ide.ide_verbose "verbose"; ide_intro_premises = get_bool section ~default:default_ide.ide_intro_premises "intro_premises"; ide_show_labels = get_bool section ~default:default_ide.ide_show_labels "print_labels"; ide_show_locs = get_bool section ~default:default_ide.ide_show_locs "print_locs"; ide_show_time_limit = get_bool section ~default:default_ide.ide_show_time_limit "print_time_limit"; ide_max_boxes = get_int section ~default:default_ide.ide_max_boxes "max_boxes"; ide_saving_policy = get_int section ~default:default_ide.ide_saving_policy "saving_policy"; ide_premise_color = get_string section ~default:default_ide.ide_premise_color "premise_color"; ide_neg_premise_color = get_string section ~default:default_ide.ide_neg_premise_color "neg_premise_color"; ide_goal_color = get_string section ~default:default_ide.ide_goal_color "goal_color"; ide_error_color = get_string section ~default:default_ide.ide_error_color "error_color"; ide_iconset = get_string section ~default:default_ide.ide_iconset "iconset"; ide_default_editor = get_string section ~default:default_ide.ide_default_editor "default_editor"; ide_default_prover = get_string section ~default:default_ide.ide_default_prover "default_prover"; ide_hidden_provers = get_stringl ~default:default_ide.ide_hidden_provers section "hidden_prover"; } let set_labels_flag = let fl = Debug.lookup_flag "print_labels" in fun b -> (if b then Debug.set_flag else Debug.unset_flag) fl let set_locs_flag = let fl = Debug.lookup_flag "print_locs" in fun b -> (if b then Debug.set_flag else Debug.unset_flag) fl let load_config config original_config env = let main = get_main config in let ide = match Whyconf.get_section config "ide" with | None -> default_ide | Some s -> load_ide s in set_labels_flag ide.ide_show_labels; set_locs_flag ide.ide_show_locs; { window_height = ide.ide_window_height; window_width = ide.ide_window_width; tree_width = ide.ide_tree_width; current_tab = ide.ide_current_tab; font_size = ide.ide_font_size; verbose = ide.ide_verbose; intro_premises= ide.ide_intro_premises ; show_labels = ide.ide_show_labels ; show_locs = ide.ide_show_locs ; show_time_limit = ide.ide_show_time_limit; max_boxes = ide.ide_max_boxes; saving_policy = ide.ide_saving_policy ; premise_color = ide.ide_premise_color; neg_premise_color = ide.ide_neg_premise_color; goal_color = ide.ide_goal_color; error_color = ide.ide_error_color; iconset = ide.ide_iconset; default_prover = ide.ide_default_prover; default_editor = ide.ide_default_editor; config = config; original_config = original_config; env = env; hidden_provers = ide.ide_hidden_provers; session_time_limit = Whyconf.timelimit main; session_mem_limit = Whyconf.memlimit main; session_nb_processes = Whyconf.running_provers_max main; session_cntexample = Whyconf.cntexample main; } let save_config t = Debug.dprintf debug "[GUI config] saving IDE config file@."; (* taking original config, without the extra_config *) let config = t.original_config in (* copy possibly modified settings to original config *) let new_main = Whyconf.get_main t.config in let time = Whyconf.timelimit new_main in let mem = Whyconf.memlimit new_main in let nb = Whyconf.running_provers_max new_main in let config = set_main config (set_limits (get_main config) time mem nb) in let new_main = Whyconf.get_main t.config in let cntexample = Whyconf.cntexample new_main in let config = set_main config (set_cntexample (get_main config) cntexample) in (* copy also provers section since it may have changed (the editor can be set via the preferences dialog) *) let config = set_provers config (get_provers t.config) in (* copy also the possibly changed policies *) let config = set_policies config (get_policies t.config) in let ide = empty_section in let ide = set_int ide "window_height" t.window_height in let ide = set_int ide "window_width" t.window_width in let ide = set_int ide "tree_width" t.tree_width in let ide = set_int ide "current_tab" t.current_tab in let ide = set_int ide "font_size" t.font_size in let ide = set_int ide "verbose" t.verbose in let ide = set_bool ide "intro_premises" t.intro_premises in let ide = set_bool ide "print_labels" t.show_labels in let ide = set_bool ide "print_locs" t.show_locs in let ide = set_bool ide "print_time_limit" t.show_time_limit in let ide = set_int ide "max_boxes" t.max_boxes in let ide = set_int ide "saving_policy" t.saving_policy in let ide = set_string ide "premise_color" t.premise_color in let ide = set_string ide "neg_premise_color" t.neg_premise_color in let ide = set_string ide "goal_color" t.goal_color in let ide = set_string ide "error_color" t.error_color in let ide = set_string ide "iconset" t.iconset in let ide = set_string ide "default_prover" t.default_prover in let ide = set_string ide "default_editor" t.default_editor in let ide = set_stringl ide "hidden_prover" t.hidden_provers in let config = Whyconf.set_section config "ide" ide in Whyconf.save_config config let config,load_config = let config = ref None in (fun () -> match !config with | None -> invalid_arg "configuration not yet loaded" | Some conf -> conf), (fun conf base_conf env -> let c = load_config conf base_conf env in config := Some c) let save_config () = save_config (config ()) let get_main () = (get_main (config ()).config) let incr_font_size n = let c = config () in let s = max (c.font_size + n) 4 in c.font_size <- s; s (* images, icons *) let image_default = ref (GdkPixbuf.create ~width:1 ~height:1 ()) (* dumb pixbuf *) let image_undone = ref !image_default let image_scheduled = ref !image_default let image_running = ref !image_default let image_valid = ref !image_default let image_unknown = ref !image_default let image_invalid = ref !image_default let image_timeout = ref !image_default let image_outofmemory = ref !image_default let image_steplimitexceeded = ref !image_default let image_failure = ref !image_default let image_valid_obs = ref !image_default let image_unknown_obs = ref !image_default let image_invalid_obs = ref !image_default let image_timeout_obs = ref !image_default let image_outofmemory_obs = ref !image_default let image_steplimitexceeded_obs = ref !image_default let image_failure_obs = ref !image_default let image_yes = ref !image_default let image_no = ref !image_default let image_file = ref !image_default let image_theory = ref !image_default let image_goal = ref !image_default let image_prover = ref !image_default let image_transf = ref !image_default let image_metas = ref !image_default let image_editor = ref !image_default let image_replay = ref !image_default let image_cancel = ref !image_default let image_reload = ref !image_default let image_remove = ref !image_default let image_cleaning = ref !image_default let why_icon = ref !image_default let image ?size f = let main = get_main () in let n = Filename.concat (datadir main) (Filename.concat "images" (f^".png")) in match size with | None -> GdkPixbuf.from_file n | Some s -> GdkPixbuf.from_file_at_size ~width:s ~height:s n let iconname_default = ref "" let iconname_undone = ref "" let iconname_scheduled = ref "" let iconname_running = ref "" let iconname_valid = ref "" let iconname_unknown = ref "" let iconname_invalid = ref "" let iconname_timeout = ref "" let iconname_outofmemory = ref "" let iconname_steplimitexceeded = ref "" let iconname_failure = ref "" let iconname_valid_obs = ref "" let iconname_unknown_obs = ref "" let iconname_invalid_obs = ref "" let iconname_timeout_obs = ref "" let iconname_outofmemory_obs = ref "" let iconname_steplimitexceeded_obs = ref "" let iconname_failure_obs = ref "" let iconname_yes = ref "" let iconname_no = ref "" let iconname_file = ref "" let iconname_theory = ref "" let iconname_goal = ref "" let iconname_prover = ref "" let iconname_transf = ref "" let iconname_metas = ref "" let iconname_editor = ref "" let iconname_replay = ref "" let iconname_cancel = ref "" let iconname_reload = ref "" let iconname_remove = ref "" let iconname_cleaning = ref "" let iconsets () : (string * Why3.Rc.family) = let main = get_main () in let dir = Filename.concat (datadir main) "images" in let files = Sys.readdir dir in let f = ref [] in Array.iter (fun fn -> if Filename.check_suffix fn ".rc" then let n = Filename.concat dir fn in let d = Rc.from_file n in f := List.rev_append (Rc.get_family d "iconset") !f) files; (dir, !f) let load_icon_names () = let ide = config () in let iconset = ide.iconset in let _,iconsets = iconsets () in let iconset,d = try iconset, List.assoc iconset iconsets with Not_found -> try "fatcow", List.assoc "fatcow" iconsets with Not_found -> failwith "No icon set found" in let get_icon_name n = Filename.concat iconset (get_string ~default:"default" d n) in iconname_default := get_icon_name "default"; iconname_undone := get_icon_name "undone"; iconname_scheduled := get_icon_name "scheduled"; iconname_running := get_icon_name "running"; iconname_valid := get_icon_name "valid"; iconname_unknown := get_icon_name "unknown"; iconname_invalid := get_icon_name "invalid"; iconname_timeout := get_icon_name "timeout"; iconname_outofmemory := get_icon_name "outofmemory"; iconname_steplimitexceeded := get_icon_name "steplimitexceeded"; iconname_failure := get_icon_name "failure"; iconname_valid_obs := get_icon_name "valid_obs"; iconname_unknown_obs := get_icon_name "unknown_obs"; iconname_invalid_obs := get_icon_name "invalid_obs"; iconname_timeout_obs := get_icon_name "timeout_obs"; iconname_outofmemory_obs := get_icon_name "outofmemory_obs"; iconname_steplimitexceeded_obs := get_icon_name "steplimitexceeded_obs"; iconname_failure_obs := get_icon_name "failure_obs"; iconname_yes := get_icon_name "yes"; iconname_no := get_icon_name "no"; iconname_file := get_icon_name "file"; iconname_theory := get_icon_name "theory"; iconname_goal := get_icon_name "goal"; iconname_prover := get_icon_name "prover"; iconname_transf := get_icon_name "transf"; iconname_metas := get_icon_name "metas"; iconname_editor := get_icon_name "editor"; iconname_replay := get_icon_name "replay"; iconname_cancel := get_icon_name "cancel"; iconname_reload := get_icon_name "reload"; iconname_remove := get_icon_name "remove"; iconname_cleaning := get_icon_name "cleaning"; () let resize_images size = image_default := image ~size !iconname_default; image_undone := image ~size !iconname_undone; image_scheduled := image ~size !iconname_scheduled; image_running := image ~size !iconname_running; image_valid := image ~size !iconname_valid; image_unknown := image ~size !iconname_unknown; image_invalid := image ~size !iconname_invalid; image_timeout := image ~size !iconname_timeout; image_outofmemory := image ~size !iconname_outofmemory; image_steplimitexceeded := image ~size !iconname_steplimitexceeded; image_failure := image ~size !iconname_failure; image_valid_obs := image ~size !iconname_valid_obs; image_unknown_obs := image ~size !iconname_unknown_obs; image_invalid_obs := image ~size !iconname_invalid_obs; image_timeout_obs := image ~size !iconname_timeout_obs; image_outofmemory_obs := image ~size !iconname_outofmemory_obs; image_steplimitexceeded_obs := image ~size !iconname_steplimitexceeded_obs; image_failure_obs := image ~size !iconname_failure_obs; image_yes := image ~size !iconname_yes; image_no := image ~size !iconname_no; image_file := image ~size !iconname_file; image_theory := image ~size !iconname_theory; image_goal := image ~size !iconname_goal; image_prover := image ~size !iconname_prover; image_transf := image ~size !iconname_transf; image_metas := image ~size !iconname_metas; image_editor := image ~size !iconname_editor; image_replay := image ~size !iconname_replay; image_cancel := image ~size !iconname_cancel; image_reload := image ~size !iconname_reload; image_remove := image ~size !iconname_remove; image_cleaning := image ~size !iconname_cleaning; () let init () = Debug.dprintf debug "[GUI config] reading icons...@?"; load_icon_names (); why_icon := image "logo-why"; resize_images 20; Debug.dprintf debug " done.@." let show_legend_window () = let dialog = GWindow.dialog ~title:"Why3: legend of icons" ~icon:!why_icon () in let vbox = dialog#vbox in let text = GText.view ~packing:vbox#add ~editable:false ~cursor_visible:false () in let b = text#buffer in let tt = b#create_tag [`WEIGHT `BOLD; `JUSTIFICATION `CENTER; `PIXELS_ABOVE_LINES 15; `PIXELS_BELOW_LINES 3; ] in let i s = b#insert ~iter:b#end_iter s in let it s = b#insert ~iter:b#end_iter ~tags:[tt] s in let ib i = b#insert_pixbuf ~iter:b#end_iter ~pixbuf:!i in it "Tree view\n"; ib image_file; i " File, containing a set of theories\n"; ib image_theory; i " Theory, containing a set of goals\n"; ib image_goal; i " Goal\n"; ib image_prover; i " External prover\n"; ib image_transf; i " Transformation or strategy\n"; it "Status column\n"; ib image_undone; i " External proof attempt not done\n"; ib image_scheduled; i " Scheduled external proof attempt\n"; ib image_running; i " Running external proof attempt\n"; ib image_valid; i " Goal is proved / Theory is fully verified\n"; ib image_invalid; i " External prover disproved the goal\n"; ib image_timeout; i " External prover reached the time limit\n"; ib image_outofmemory; i " External prover ran out of memory\n"; ib image_steplimitexceeded; i " External prover exceeded the step limit\n"; ib image_unknown; i " External prover answer not conclusive\n"; ib image_failure; i " External prover call failed\n"; ib image_valid_obs; i " Valid but obsolete result\n"; ib image_unknown_obs; i " Answer not conclusive and obsolete\n"; ib image_invalid_obs; i " Prover disproved goal, but obsolete\n"; ib image_failure_obs; i " External prover call failed, obsolete\n"; dialog#add_button "Close" `CLOSE ; let t = b#create_tag [`LEFT_MARGIN 10; `RIGHT_MARGIN 10 ] in b#apply_tag t ~start:b#start_iter ~stop:b#end_iter; let ( _ : GWindow.Buttons.about) = dialog#run () in dialog#destroy () let show_about_window () = let about_dialog = GWindow.about_dialog ~name:"The Why3 Verification Platform" ~authors:["François Bobot"; "Jean-Christophe Filliâtre"; "Claude Marché"; "Guillaume Melquiond"; "Andrei Paskevich"; ""; "with contributions of"; ""; "Stefan Berghofer"; "Sylvie Boldo"; "Martin Clochard"; "Simon Cruanes"; "Sylvain Dailler"; "Jacques-Pascal Deplaix"; "Clément Fumex"; "Leon Gondelman"; "David Hauzar"; "Daisuke Ishii"; "Johannes Kanig"; "Mikhail Mandrykin"; "David Mentré"; "Benjamin Monate"; "Kim Nguyễn"; "Thi-Minh-Tuyen Nguyen"; "Simão Melo de Sousa"; "Asma Tafat"; "Piotr Trojanek"; "Makarius Wenzel"; ] ~copyright:"Copyright 2010-2018 Inria, CNRS, Paris-Sud University" ~license:("See file " ^ Filename.concat Config.datadir "LICENSE") ~website:"http://why3.lri.fr/" ~website_label:"http://why3.lri.fr/" ~version:Config.version ~icon:!why_icon ~logo:!why_icon () in let ( _ : GWindow.Buttons.about) = about_dialog#run () in about_dialog#destroy () (**** Preferences Window ***) let general_settings (c : t) (notebook:GPack.notebook) = let label = GMisc.label ~text:"General" () in let page = GPack.vbox ~homogeneous:false ~packing: (fun w -> ignore(notebook#append_page ~tab_label:label#coerce w)) () in (* debug mode ? *) (* let debugmode = GButton.check_button ~label:"debug" ~packing:page1#add () ~active:(c.verbose > 0) in let (_ : GtkSignal.id) = debugmode#connect#toggled ~callback: (fun () -> c.verbose <- 1 - c.verbose) in *) let page_pack = page#pack ?from:None ?expand:None ?fill:None ?padding:None in let external_processes_options_frame = GBin.frame ~label:"External provers options" ~packing:page_pack () in let vb = GPack.vbox ~homogeneous:false ~packing:external_processes_options_frame#add () in (* time limit *) let width = 300 and xalign = 0.0 in let hb = GPack.hbox ~homogeneous:false ~packing:vb#add () in let hb_pack = hb#pack ~expand:false ?from:None ?fill:None ?padding:None in let _ = GMisc.label ~text:"Time limit (in sec.): " ~width ~xalign ~packing:hb_pack () in let timelimit_spin = GEdit.spin_button ~digits:0 ~packing:hb#add () in timelimit_spin#adjustment#set_bounds ~lower:0. ~upper:86_400. ~step_incr:5. (); timelimit_spin#adjustment#set_value (float_of_int c.session_time_limit); let (_ : GtkSignal.id) = timelimit_spin#connect#value_changed ~callback: (fun () -> c.session_time_limit <- timelimit_spin#value_as_int) in (* mem limit *) let hb = GPack.hbox ~homogeneous:false ~packing:vb#add () in let hb_pack = hb#pack ~expand:false ?from:None ?fill:None ?padding:None in let _ = GMisc.label ~text:"Memory limit (in Mb): " ~width ~xalign ~packing:hb_pack () in let memlimit_spin = GEdit.spin_button ~digits:0 ~packing:hb#add () in memlimit_spin#adjustment#set_bounds ~lower:0. ~upper:16_000. ~step_incr:500. (); memlimit_spin#adjustment#set_value (float_of_int c.session_mem_limit); let (_ : GtkSignal.id) = memlimit_spin#connect#value_changed ~callback: (fun () -> c.session_mem_limit <- memlimit_spin#value_as_int) in (* nb of processes *) let hb = GPack.hbox ~homogeneous:false ~packing:vb#add () in let hb_pack = hb#pack ~expand:false ?from:None ?fill:None ?padding:None in let _ = GMisc.label ~text:"Nb of processes: " ~width ~xalign ~packing:hb_pack () in let nb_processes_spin = GEdit.spin_button ~digits:0 ~packing:hb#add () in nb_processes_spin#adjustment#set_bounds ~lower:1. ~upper:64. ~step_incr:1. (); nb_processes_spin#adjustment#set_value (float_of_int c.session_nb_processes); let (_ : GtkSignal.id) = nb_processes_spin#connect#value_changed ~callback: (fun () -> c.session_nb_processes <- nb_processes_spin#value_as_int) in (* counter-example *) let cntexample_check = GButton.check_button ~label:"get counter-example" ~packing:vb#add () ~active:c.session_cntexample in let (_: GtkSignal.id) = cntexample_check#connect#toggled ~callback: (fun () -> c.session_cntexample <- not c.session_cntexample) in (* session saving policy *) let set_saving_policy n () = c.saving_policy <- n in let saving_policy_frame = GBin.frame ~label:"Session saving policy" ~packing:page_pack () in let saving_policy_box = GPack.button_box `VERTICAL ~border_width:5 ~spacing:5 ~packing:saving_policy_frame#add () in let saving_policy_box_pack = saving_policy_box#pack ?from:None ?expand:None ?fill:None ?padding:None in let choice0 = GButton.radio_button ~label:"always save on exit" ~active:(c.saving_policy = 0) ~packing:saving_policy_box_pack () in let choice1 = GButton.radio_button ~label:"never save on exit" ~group:choice0#group ~active:(c.saving_policy = 1) ~packing:saving_policy_box_pack () in let choice2 = GButton.radio_button ~label:"ask whether to save on exit" ~group:choice0#group ~active:(c.saving_policy = 2) ~packing:saving_policy_box_pack () in let (_ : GtkSignal.id) = choice0#connect#toggled ~callback:(set_saving_policy 0) in let (_ : GtkSignal.id) = choice1#connect#toggled ~callback:(set_saving_policy 1) in let (_ : GtkSignal.id) = choice2#connect#toggled ~callback:(set_saving_policy 2) in let (_ : GPack.box) = GPack.vbox ~packing:page_pack () in () (** Appearance *) let appearance_settings (c : t) (notebook:GPack.notebook) = let label = GMisc.label ~text:"Appearance" () in let page = GPack.vbox ~homogeneous:false ~packing: (fun w -> ignore(notebook#append_page ~tab_label:label#coerce w)) () in let page_pack = page#pack ?from:None ?expand:None ?fill:None ?padding:None in let display_options_frame = GBin.frame ~label:"Display options" ~packing:page_pack () in let vb = GPack.vbox ~homogeneous:false ~packing:display_options_frame#add () in (* max boxes *) let width = 300 and xalign = 0.0 in let hb = GPack.hbox ~homogeneous:false ~packing:vb#add () in let hb_pack = hb#pack ~expand:false ?fill:None ?from:None ?padding:None in let _ = GMisc.label ~text:"Use ellipsis for terms deeper than: " ~width ~xalign ~packing:hb_pack () in let max_boxes_spin = GEdit.spin_button ~digits:0 ~packing:hb#add () in max_boxes_spin#adjustment#set_bounds ~lower:0. ~upper:1000. ~step_incr:1. (); max_boxes_spin#adjustment#set_value (float_of_int c.max_boxes); let (_ : GtkSignal.id) = max_boxes_spin#connect#value_changed ~callback: (fun () -> c.max_boxes <- max_boxes_spin#value_as_int) in (* options for task display *) let display_options_box = GPack.button_box `VERTICAL ~border_width:5 ~spacing:5 ~packing:vb#add () in let intropremises = GButton.check_button ~label:"introduce premises" ~packing:display_options_box#add () ~active:c.intro_premises in let (_ : GtkSignal.id) = intropremises#connect#toggled ~callback: (fun () -> c.intro_premises <- not c.intro_premises) in let showlabels = GButton.check_button ~label:"show labels in formulas" ~packing:display_options_box#add () ~active:c.show_labels in let (_ : GtkSignal.id) = showlabels#connect#toggled ~callback: (fun () -> c.show_labels <- not c.show_labels; set_labels_flag c.show_labels) in let showlocs = GButton.check_button ~label:"show source locations in formulas" ~packing:display_options_box#add () ~active:c.show_locs in let (_ : GtkSignal.id) = showlocs#connect#toggled ~callback: (fun () -> c.show_locs <- not c.show_locs; set_locs_flag c.show_locs) in let showtimelimit = GButton.check_button ~label:"show time and memory limits for each proof" ~packing:display_options_box#add () ~active:c.show_time_limit in let (_ : GtkSignal.id) = showtimelimit#connect#toggled ~callback: (fun () -> c.show_time_limit <- not c.show_time_limit) in (* icon sets *) let icon_sets_frame = GBin.frame ~label:"Change icon family (needs save & restart)" ~packing:page_pack () in let icon_sets_box = GPack.button_box `VERTICAL ~border_width:5 ~spacing:5 ~packing:icon_sets_frame#add () in let icon_sets_box_pack = icon_sets_box#pack ?from:None ?expand:None ?fill:None ?padding:None in let dir,iconsets = iconsets () in let set_icon_set s () = c.iconset <- s in let (_,choices) = List.fold_left (fun (acc,l) (s,fields) -> let name = Rc.get_string ~default:s fields "name" in let license = Rc.get_string ~default:"" fields "license" in let acc,choice = match acc with | None -> let choice = GButton.radio_button ~label:name ~active:(c.iconset = s) ~packing:icon_sets_box_pack () in (Some choice,choice) | Some c0 -> let choice = GButton.radio_button ~label:name ~active:(c.iconset = s) ~group:c0#group ~packing:icon_sets_box_pack () in (acc,choice) in if license <> "" then begin let f = Filename.concat (Filename.concat dir s) license in let c = Sysutil.file_contents f in let text = "See license in " ^ f ^ ":\n\n" in let l = String.length c in let text = if l >= 256 then text ^ String.sub c 0 255 ^ "\n[...]" else text ^ c in choice#misc#set_tooltip_markup text end; (acc,(s,choice)::l)) (None,[]) iconsets in List.iter (fun (s,c) -> let (_ : GtkSignal.id) = c#connect#toggled ~callback:(set_icon_set s) in ()) choices; let (_ : GPack.box) = GPack.vbox ~packing:page_pack () in () (* Page "Provers" *) let provers_page c (notebook:GPack.notebook) = let label = GMisc.label ~text:"Provers" () in let page = GPack.vbox ~homogeneous:false ~packing: (fun w -> ignore(notebook#append_page ~tab_label:label#coerce w)) () in let page_pack = page#pack ~fill:true ~expand:true ?from:None ?padding:None in let hbox = GPack.hbox ~packing:page_pack () in let hbox_pack = hbox#pack ~fill:true ~expand:true ?from:None ?padding:None in let scrollview = try GBin.scrolled_window ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC ~packing:hbox_pack () with Gtk.Error _ -> assert false in let () = scrollview#set_shadow_type `OUT in let vbox = GPack.vbox ~packing:scrollview#add_with_viewport () in let vbox_pack = vbox#pack ~fill:true ~expand:true ?from:None ?padding:None in let hbox = GPack.hbox ~packing:vbox_pack () in let hbox_pack = hbox#pack ~fill:true ~expand:true ?from:None ?padding:None in (* show/hide provers *) let frame = GBin.frame ~label:"Prover button in the left toolbar" ~packing:hbox_pack () in let provers_box = GPack.button_box `VERTICAL ~border_width:5 ~spacing:5 ~packing:frame#add () in let hidden_provers = Hashtbl.create 7 in Mprover.iter (fun _ p -> let name = prover_parseable_format p.prover in let label = Pp.string_of_wnl print_prover p.prover in let hidden = ref (List.mem name c.hidden_provers) in Hashtbl.add hidden_provers name hidden; let b = GButton.check_button ~label ~packing:provers_box#add () ~active:(not !hidden) in let (_ : GtkSignal.id) = b#connect#toggled ~callback: (fun () -> hidden := not !hidden; c.hidden_provers <- Hashtbl.fold (fun l h acc -> if !h then l::acc else acc) hidden_provers []) in ()) (Whyconf.get_provers c.config); (* default prover *) let frame2 = GBin.frame ~label:"Default prover" ~packing:hbox_pack () in let provers_box = GPack.button_box `VERTICAL ~border_width:5 ~spacing:5 ~packing:frame2#add () in let group = let b = GButton.radio_button ~label:"(none)" ~packing:provers_box#add ~active:(c.default_prover = "") () in let (_ : GtkSignal.id) = b#connect#toggled ~callback:(fun () -> c.default_prover <- "") in b#group in Mprover.iter (fun _ p -> let name = prover_parseable_format p.prover in let label = Pp.string_of_wnl print_prover p.prover in let b = GButton.radio_button ~label ~group ~packing:provers_box#add ~active:(name = c.default_prover) () in let (_ : GtkSignal.id) = b#connect#toggled ~callback:(fun () -> c.default_prover <- name) in ()) (Whyconf.get_provers c.config) (* Page "Uninstalled provers" *) let alternatives_frame c (notebook:GPack.notebook) = let label = GMisc.label ~text:"Uninstalled provers" () in let page = GPack.vbox ~homogeneous:false ~packing: (fun w -> ignore(notebook#append_page ~tab_label:label#coerce w)) () in let page_pack = page#pack ?fill:None ?expand:None ?from:None ?padding:None in let frame = GBin.frame ~label:"Click to remove a setting" ~packing:page_pack () in let box = GPack.button_box `VERTICAL ~border_width:5 ~spacing:5 ~packing:frame#add () in let remove button p () = button#destroy (); c.config <- set_policies c.config (Mprover.remove p (get_policies c.config)) in let iter p policy = let label = match policy with | CPU_keep -> Pp.sprintf_wnl "proofs with %a kept as they are" print_prover p | CPU_upgrade t -> Pp.sprintf_wnl "proofs with %a moved to %a" print_prover p print_prover t | CPU_duplicate t -> Pp.sprintf_wnl "proofs with %a duplicated to %a" print_prover p print_prover t in let button = GButton.button ~label ~packing:box#add () in let (_ : GtkSignal.id) = button#connect#released ~callback:(remove button p) in () in Mprover.iter iter (get_policies c.config); let page_pack = page#pack ?fill:None ~expand:true ?from:None ?padding:None in let _fillbox = GPack.vbox ~packing:page_pack () in () let editors_page c (notebook:GPack.notebook) = let label = GMisc.label ~text:"Editors" () in let page = GPack.vbox ~homogeneous:false ~packing: (fun w -> ignore(notebook#append_page ~tab_label:label#coerce w)) () in let page_pack = page#pack ~fill:true ~expand:true ?from:None ?padding:None in let hbox = GPack.hbox ~packing:page_pack () in let hbox_pack = hbox#pack ~fill:true ~expand:true ?from:None ?padding:None in let scrollview = GBin.scrolled_window ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC ~packing:hbox_pack () in let vbox = GPack.vbox ~packing:scrollview#add_with_viewport () in let vbox_pack = vbox#pack ?fill:None ?expand:None ?from:None ?padding:None in let default_editor_frame = GBin.frame ~label:"Default editor" ~packing:vbox_pack () in let editor_entry = GEdit.entry ~text:c.default_editor ~packing:default_editor_frame#add () in let (_ : GtkSignal.id) = editor_entry#connect#changed ~callback: (fun () -> c.default_editor <- editor_entry#text) in let frame = GBin.frame ~label:"Specific editors" ~packing:vbox_pack () in let box = GPack.vbox ~border_width:5 ~packing:frame#add () in let box_pack = box#pack ?fill:None ?expand:None ?from:None ?padding:None in let editors = Whyconf.get_editors c.config in let _,strings,indexes,map = Meditor.fold (fun k data (i,str,ind,map) -> let n = data.editor_name in (i+1, n::str, Meditor.add k i ind, Meditor.add n k map)) editors (2, [], Meditor.empty, Meditor.empty) in let strings = "(default)" :: "--" :: (List.rev strings) in let add_prover p pi = let text = Pp.string_of_wnl Whyconf.print_prover p in let hb = GPack.hbox ~homogeneous:false ~packing:box_pack () in let hb_pack_fill_expand = hb#pack ~fill:true ~expand:true ?from:None ?padding:None in let hb_pack = hb#pack ?fill:None ?expand:None ?from:None ?padding:None in let _ = GMisc.label ~width:150 ~xalign:0.0 ~text ~packing:hb_pack_fill_expand () in let (combo, ((_ : GTree.list_store), column)) = GEdit.combo_box_text ~packing:hb_pack ~strings () in combo#set_row_separator_func (Some (fun m row -> m#get ~row ~column = "--")); let i = try Meditor.find pi.editor indexes with Not_found -> 0 in combo#set_active i; let ( _ : GtkSignal.id) = combo#connect#changed ~callback:(fun () -> match combo#active_iter with | None -> () | Some row -> let data = match combo#model#get ~row ~column with | "(default)" -> "" | s -> try Meditor.find s map with Not_found -> assert false in (* Debug.dprintf debug "prover %a : selected editor '%s'@." *) (* print_prover p data; *) let provers = Whyconf.get_provers c.config in c.config <- Whyconf.set_provers c.config (Mprover.add p { pi with editor = data} provers) ) in () in Mprover.iter add_prover (Whyconf.get_provers c.config) let preferences (c : t) = let dialog = GWindow.dialog ~modal:true ~icon:(!why_icon) ~title:"Why3: preferences" () in let vbox = dialog#vbox in let notebook = GPack.notebook ~packing:vbox#add () in (* page "general settings" **) general_settings c notebook; (* page "appearance" **) appearance_settings c notebook; (* page "editors" **) editors_page c notebook; (* page "Provers" **) provers_page c notebook; (* page "uninstalled provers" *) alternatives_frame c notebook; (* page "Colors" **) (* let label2 = GMisc.label ~text:"Colors" () in let _color_sel = GMisc.color_selection (* ~title:"Goal color" *) ~show:true ~packing:(fun w -> ignore(notebook#append_page ~tab_label:label2#coerce w)) () in let (_ : GtkSignal.id) = color_sel#connect ColorSelection.S.color_changed ~callback: (fun c -> Format.eprintf "Gconfig.color_sel : %s@." c) in *) (* bottom button **) dialog#add_button "Save&Close" `SAVE ; dialog#add_button "Close" `CLOSE ; let ( answer : [`SAVE | `CLOSE | `DELETE_EVENT ]) = dialog#run () in begin match answer with | `SAVE -> c.config <- Whyconf.set_main c.config (Whyconf.set_limits (Whyconf.get_main c.config) c.session_time_limit c.session_mem_limit c.session_nb_processes); c.config <- Whyconf.set_main c.config (Whyconf.set_cntexample (Whyconf.get_main c.config) c.session_cntexample); save_config () | `CLOSE | `DELETE_EVENT -> () end; dialog#destroy () (* let run_auto_detection gconfig = let config = Autodetection.run_auto_detection gconfig.config in gconfig.config <- config; let _provers = get_provers config in (* TODO: store the result differently gconfig.provers <- Mstr.fold (Session.get_prover_data gconfig.env) provers Mstr.empty *) () *) (*let () = Debug.dprintf debug "[GUI config] end of configuration initialization@."*) let uninstalled_prover c eS unknown = try Whyconf.get_prover_upgrade_policy c.config unknown with Not_found -> let others,names,versions = Session_tools.unknown_to_known_provers (Whyconf.get_provers eS.Session.whyconf) unknown in let dialog = GWindow.dialog ~icon:(!why_icon) ~modal:true ~title:"Why3: Uninstalled prover" () in let vbox = dialog#vbox in (* Does not work: why ?? let vbox_pack = vbox#pack ~fill:true ~expand:true ?from:None ?padding:None in let hbox = GPack.hbox ~packing:vbox_pack () in let hbox_pack = hbox#pack ~fill:true ~expand:true ?from:None ?padding:None in let scrollview = GBin.scrolled_window ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC ~packing:hbox_pack () in let () = scrollview#set_shadow_type `OUT in let vbox = GPack.vbox ~packing:scrollview#add_with_viewport () in *) (* header *) let hb = GPack.hbox ~packing:vbox#add () in let _ = GMisc.image ~stock:`DIALOG_WARNING ~packing:hb#add () in let _ = let text = Pp.sprintf "The prover %a is not installed" Whyconf.print_prover unknown in GMisc.label ~ypad:20 ~text ~xalign:0.5 ~packing:hb#add () in (* choices *) let vbox_pack = vbox#pack ~fill:true ~expand:true ?from:None ?padding:None in let label = "Please select a policy for associated proof attempts" in let policy_frame = GBin.frame ~label ~packing:vbox_pack () in let choice = ref 1 in let prover_choosed = ref None in let set_prover prover () = prover_choosed := Some prover in let box = GPack.button_box `VERTICAL ~border_width:5 ~spacing:5 ~packing:policy_frame#add () in let choice1 = GButton.radio_button ~label:"move proofs to the selected prover below" ~active:true ~packing:box#add () in let choice2 = GButton.radio_button ~label:"duplicate proofs to the selected prover below" ~active:false ~group:choice1#group ~packing:box#add () in let choice0 = GButton.radio_button ~label:"keep proofs as they are, do not try to play them" ~active:false ~group:choice1#group ~packing:box#add () in let first = ref None in let alternatives_section acc label alternatives = if alternatives <> [] then let frame = GBin.frame ~label ~packing:vbox#add () in let box = GPack.button_box `VERTICAL ~border_width:5 ~spacing:5 ~packing:frame#add () in let iter_alter prover = let choice_button = let label = Pp.string_of_wnl print_prover prover in match !first with | None -> let choice_button = GButton.radio_button ~label ~active:true ~packing:box#add () in prover_choosed := Some prover; first := Some choice_button; choice_button | Some first -> GButton.radio_button ~label ~group:first#group ~active:false ~packing:box#add () in ignore (choice_button#connect#toggled ~callback:(set_prover prover)) in List.iter iter_alter alternatives; frame#misc :: (* box#misc :: *) acc else acc in let boxes = alternatives_section [] "Same name and same version" versions in let boxes = alternatives_section boxes "Same name and different version" names in let boxes = alternatives_section boxes "Different name" others in let hide_provers () = List.iter (fun b -> b#set_sensitive false) boxes in let show_provers () = List.iter (fun b -> b#set_sensitive true) boxes in ignore (choice0#connect#toggled ~callback:(fun () -> choice := 0; hide_provers ())); ignore (choice1#connect#toggled ~callback:(fun () -> choice := 1; show_provers ())); ignore (choice2#connect#toggled ~callback:(fun () -> choice := 2; show_provers ())); dialog#add_button "Ok" `CLOSE ; ignore (dialog#run ()); dialog#destroy (); let policy = match !choice, !prover_choosed with | 0,_ -> CPU_keep | 1, Some p -> CPU_upgrade p | 2, Some p -> CPU_duplicate p | _ -> assert false in c.config <- set_prover_upgrade_policy c.config unknown policy; policy (* Local Variables: compile-command: "unset LANG; make -C ../.. bin/why3ide.byte" End: *) why3-0.88.3/src/ide/gmain.ml0000664000175100017510000022226613225666037016243 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Format open Why3 open Whyconf open Gconfig open Stdlib open Debug module C = Whyconf external reset_gc : unit -> unit = "ml_reset_gc" (* Setting a Gc.alarm is pointless; the function has to be called manually before each lablgtk operation. Indeed, each major slice resets caml_extra_heap_resources to zero, but alarms are executed only at finalization time, that is, after a full collection completes. Note that manual calls can fail to prevent extraneous collections too, if a major slice happens right in the middle of a sequence of lablgtk operations due to memory starvation. Hopefully, it seldom happens. *) let () = reset_gc () let debug = Debug.lookup_flag "ide_info" let debug_show_text_cntexmp = Debug.register_info_flag "show_text_cntexmp" ~desc:"Print@ textual@ counterexample@ before@ printing@ counterexample@ interleaved@ with@ cource@ code." (************************) (* parsing command line *) (************************) let files = Queue.create () let opt_parser = ref None let spec = Arg.align [ "-F", Arg.String (fun s -> opt_parser := Some s), " select input format (default: \"why\")"; "--format", Arg.String (fun s -> opt_parser := Some s), " same as -F"; (* "-f", Arg.String (fun s -> input_files := s :: !input_files), " add file to the project (ignored if it is already there)"; *) Termcode.arg_extra_expl_prefix ] let usage_str = sprintf "Usage: %s [options] [|]..." (Filename.basename Sys.argv.(0)) let gconfig = try let config, base_config, env = Whyconf.Args.initialize spec (fun f -> Queue.add f files) usage_str in if Queue.is_empty files then Whyconf.Args.exit_with_usage spec usage_str; Gconfig.load_config config base_config env; Gconfig.config () with e when not (Debug.test_flag Debug.stack_trace) -> eprintf "%a@." Exn_printer.exn_printer e; exit 1 let () = Debug.dprintf debug "[GUI] Init the GTK interface...@?"; ignore (GtkMain.Main.init ()); Debug.dprintf debug " done.@."; Gconfig.init () let (why_lang, any_lang) = let main = Gconfig.get_main () in let load_path = Filename.concat (datadir main) "lang" in let languages_manager = GSourceView2.source_language_manager ~default:true in languages_manager#set_search_path (load_path :: languages_manager#search_path); let why_lang = match languages_manager#language "why3" with | None -> eprintf "language file for 'why3' not found in directory %s@." load_path; exit 1 | Some _ as l -> l in let any_lang filename = if filename = "" then why_lang else match languages_manager#guess_language ~filename () with | None -> why_lang | Some _ as l -> l in (why_lang, any_lang) (* Borrowed from Frama-C src/gui/source_manager.ml: Try to convert a source file either as UTF-8 or as locale. *) let try_convert s = try if Glib.Utf8.validate s then s else Glib.Convert.locale_to_utf8 s with Glib.Convert.Error _ -> try Glib.Convert.convert_with_fallback ~fallback:"#neither UTF-8 nor locale nor ISO-8859-15#" ~to_codeset:"UTF-8" ~from_codeset:"ISO_8859-15" s with Glib.Convert.Error _ as e -> Printexc.to_string e (***************) (* Main window *) (***************) let w = GWindow.window ~allow_grow:true ~allow_shrink:true ~width:gconfig.window_width ~height:gconfig.window_height ~title:"Why3 Interactive Proof Session" () let () = w#set_icon (Some !Gconfig.why_icon) let (_ : GtkSignal.id) = w#misc#connect#size_allocate ~callback: (fun {Gtk.width=w;Gtk.height=h} -> gconfig.window_height <- h; gconfig.window_width <- w) let vbox = GPack.vbox ~packing:w#add () (* Menu *) let menubar = GMenu.menu_bar ~packing:(vbox#pack ?from:None ?expand:None ?fill:None ?padding:None) () let factory = new GMenu.factory menubar let accel_group = factory#accel_group let hb = GPack.hbox ~packing:vbox#add () let left_scrollview = try GBin.scrolled_window ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC ~packing:(hb#pack ~expand:false ?from:None ?fill:None ?padding:None) () with Gtk.Error _ -> assert false let () = left_scrollview#set_shadow_type `OUT let tools_window_vbox = try GPack.vbox ~packing:left_scrollview#add_with_viewport () with Gtk.Error _ -> assert false let tools_window_vbox_pack = tools_window_vbox#pack ~expand:false ?from:None ?fill:None ?padding:None let context_frame = GBin.frame ~label:"Context" ~shadow_type:`ETCHED_OUT ~packing:tools_window_vbox_pack () let context_box = GPack.button_box `VERTICAL ~border_width:5 ~spacing:5 ~packing:context_frame#add () let context_unproved_goals_only = ref true let () = let b1 = GButton.radio_button ~packing:context_box#add ~label:"Unproved goals" () in b1#misc#set_tooltip_markup "When selected, tools below are applied only to unproved goals"; let (_ : GtkSignal.id) = b1#connect#clicked ~callback:(fun () -> context_unproved_goals_only := true) in let b2 = GButton.radio_button ~group:b1#group ~packing:context_box#add ~label:"All goals" () in b2#misc#set_tooltip_markup "When selected, tools below are applied to all goals"; let (_ : GtkSignal.id) = b2#connect#clicked ~callback:(fun () -> context_unproved_goals_only := false) in () let strategies_frame = GBin.frame ~label:"Strategies" ~shadow_type:`ETCHED_OUT ~packing:tools_window_vbox_pack () let strategies_box = GPack.button_box `VERTICAL ~border_width:5 ~spacing:5 ~packing:strategies_frame#add () let provers_frame = GBin.frame ~label:"Provers" ~shadow_type:`ETCHED_OUT ~packing:tools_window_vbox_pack () let provers_box = GPack.button_box `VERTICAL ~border_width:5 ~spacing:5 ~packing:provers_frame#add () let () = provers_frame#set_resize_mode `PARENT let tools_frame = GBin.frame ~label:"Tools" ~shadow_type:`ETCHED_OUT ~packing:tools_window_vbox_pack () let tools_box = GPack.button_box `VERTICAL ~border_width:5 ~spacing:5 ~packing:tools_frame#add () let monitor_frame = GBin.frame ~label:"Proof monitoring" ~shadow_type:`ETCHED_OUT ~packing:tools_window_vbox_pack () let monitor_box = GPack.vbox ~homogeneous:false ~packing:monitor_frame#add () let monitor_waiting = GMisc.label ~text:" Waiting: 0" ~packing:monitor_box#add () let monitor_scheduled = GMisc.label ~text:"Scheduled: 0" ~packing:monitor_box#add () let monitor_running = GMisc.label ~text:" Running: 0" ~packing:monitor_box#add () (* horizontal paned *) let hp = GPack.paned `HORIZONTAL ~packing:hb#add () (* tree view *) let scrollview = try GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ~width:gconfig.tree_width ~shadow_type:`ETCHED_OUT ~packing:hp#add () with Gtk.Error _ -> assert false let (_ : GtkSignal.id) = scrollview#misc#connect#size_allocate ~callback: (fun {Gtk.width=w;Gtk.height=_h} -> gconfig.tree_width <- w) (****************) (* goals widget *) (****************) let cols = new GTree.column_list let name_column = cols#add Gobject.Data.string let icon_column = cols#add Gobject.Data.gobject let status_column = cols#add Gobject.Data.gobject let time_column = cols#add Gobject.Data.string let index_column = cols#add Gobject.Data.int let name_renderer = GTree.cell_renderer_text [`XALIGN 0.] let renderer = GTree.cell_renderer_text [`XALIGN 0.] let image_renderer = GTree.cell_renderer_pixbuf [ ] let icon_renderer = GTree.cell_renderer_pixbuf [ ] let view_name_column = GTree.view_column ~title:"Theories/Goals" () let () = view_name_column#pack icon_renderer ; view_name_column#add_attribute icon_renderer "pixbuf" icon_column ; view_name_column#pack name_renderer; view_name_column#add_attribute name_renderer "text" name_column; view_name_column#set_resizable true; view_name_column#set_max_width 800; (* view_name_column#set_alignment 1.0; *) () let view_status_column = GTree.view_column ~title:"Status" ~renderer:(image_renderer, ["pixbuf", status_column]) () let view_time_column = GTree.view_column ~title:"Time" ~renderer:(renderer, ["text", time_column]) () let () = view_status_column#set_resizable false; view_status_column#set_visible true; view_time_column#set_resizable false; view_time_column#set_visible true let goals_model,goals_view = Debug.dprintf debug "[GUI] Creating tree model...@?"; let model = GTree.tree_store cols in let view = GTree.view ~model ~packing:scrollview#add () in let () = view#selection#set_mode (* `SINGLE *) `MULTIPLE in let () = view#set_rules_hint true in ignore (view#append_column view_name_column); ignore (view#append_column view_status_column); ignore (view#append_column view_time_column); Debug.dprintf debug " done@."; model,view (******************************) (* notebook on the right *) (******************************) let notebook = GPack.notebook ~packing:hp#add () let source_page,source_tab = let label = GMisc.label ~text:"Source code" () in 0, GPack.vbox ~homogeneous:false ~packing: (fun w -> ignore(notebook#append_page ~tab_label:label#coerce w)) () let task_page,task_tab = let label = GMisc.label ~text:"Task" () in 1, GPack.vbox ~homogeneous:false ~packing: (fun w -> ignore(notebook#append_page ~tab_label:label#coerce w)) () let edited_page,edited_tab = let label = GMisc.label ~text:"Edited proof" () in 2, GPack.vbox ~homogeneous:false ~packing: (fun w -> ignore(notebook#append_page ~tab_label:label#coerce w)) () let output_page,output_tab = let label = GMisc.label ~text:"Prover Output" () in 3, GPack.vbox ~homogeneous:false ~packing: (fun w -> ignore(notebook#append_page ~tab_label:label#coerce w)) () let counterexample_page,counterexample_tab = let label = GMisc.label ~text:"Counter-example" () in 4, GPack.vbox ~homogeneous:false ~packing: (fun w -> ignore(notebook#append_page ~tab_label:label#coerce w)) () let (_ : GPack.box) = GPack.hbox ~packing:(source_tab#pack ~expand:false ?from:None ?fill:None ?padding:None) () let () = notebook#goto_page gconfig.current_tab; let page_selected n = gconfig.current_tab <- n in let (_ : GtkSignal.id) = notebook#connect#switch_page ~callback:page_selected in () (******************) (* views *) (******************) let current_file = ref "" let scrolled_task_view = GBin.scrolled_window ~hpolicy: `AUTOMATIC ~vpolicy: `AUTOMATIC ~shadow_type:`ETCHED_OUT ~packing:task_tab#add () let task_view = GSourceView2.source_view ~editable:false ~show_line_numbers:true ~packing:scrolled_task_view#add () let scrolled_edited_view = GBin.scrolled_window ~hpolicy: `AUTOMATIC ~vpolicy: `AUTOMATIC ~shadow_type:`ETCHED_OUT ~packing:edited_tab#add () let edited_view = GSourceView2.source_view ~editable:false ~show_line_numbers:true ~packing:scrolled_edited_view#add () let scrolled_output_view = GBin.scrolled_window ~hpolicy: `AUTOMATIC ~vpolicy: `AUTOMATIC ~shadow_type:`ETCHED_OUT ~packing:output_tab#add () let output_view = GSourceView2.source_view ~editable:false ~show_line_numbers:true ~packing:scrolled_output_view#add () let scrolled_counterexample_view = GBin.scrolled_window ~hpolicy: `AUTOMATIC ~vpolicy: `AUTOMATIC ~shadow_type:`ETCHED_OUT ~packing:counterexample_tab#add () let counterexample_view = GSourceView2.source_view ~editable:false ~show_line_numbers:true ~packing:scrolled_counterexample_view#add () let modifiable_sans_font_views = ref [goals_view#misc] let modifiable_mono_font_views = ref [task_view#misc;edited_view#misc;output_view#misc; counterexample_view#misc ] let () = task_view#source_buffer#set_language why_lang let () = task_view#set_highlight_current_line true let clear model = model#clear () let image_of_result ~obsolete result = match result with | Session.Interrupted -> !image_undone | Session.Unedited -> !image_editor | Session.JustEdited -> !image_unknown | Session.Scheduled -> !image_scheduled | Session.Running -> !image_running | Session.InternalFailure _ -> !image_failure | Session.Done r -> match r.Call_provers.pr_answer with | Call_provers.Valid -> if obsolete then !image_valid_obs else !image_valid | Call_provers.Invalid -> if obsolete then !image_invalid_obs else !image_invalid | Call_provers.Timeout -> if obsolete then !image_timeout_obs else !image_timeout | Call_provers.OutOfMemory -> if obsolete then !image_outofmemory_obs else !image_outofmemory | Call_provers.StepLimitExceeded -> if obsolete then !image_steplimitexceeded_obs else !image_steplimitexceeded | Call_provers.Unknown _ -> if obsolete then !image_unknown_obs else !image_unknown | Call_provers.Failure _ -> if obsolete then !image_failure_obs else !image_failure | Call_provers.HighFailure -> if obsolete then !image_failure_obs else !image_failure (* connecting to the Session model *) let fan n = match n mod 4 with | 0 -> "|" | 1 | -3 -> "\\" | 2 | -2 -> "-" | 3 | -1 -> "/" | _ -> assert false module S = Session let session_needs_saving = ref false let set_row_status row b = match b with | Some t -> goals_model#set ~row:row#iter ~column:status_column !image_yes; let t = Format.sprintf "%.2f" t in goals_model#set ~row:row#iter ~column:time_column t | None -> goals_model#set ~row:row#iter ~column:status_column !image_unknown; goals_model#set ~row:row#iter ~column:time_column "" let set_proof_state a = let obsolete = a.S.proof_obsolete in let row = a.S.proof_key in let res = a.S.proof_state in goals_model#set ~row:row#iter ~column:status_column (image_of_result ~obsolete res); let t = match res with | S.Done { Call_provers.pr_time = time; Call_provers.pr_steps = steps } -> let s = if gconfig.show_time_limit then Format.sprintf "%.2f [%d.0]" time (a.S.proof_limit.Call_provers.limit_time) else Format.sprintf "%.2f" time in if steps >= 0 then Format.sprintf "%s (steps: %d)" s steps else s | S.Unedited -> "(not yet edited)" | S.JustEdited -> "(edited)" | S.InternalFailure _ -> "(internal failure)" | S.Interrupted -> "(interrupted)" | S.Scheduled | S.Running -> Format.sprintf "[limit=%d sec., %d M]" (a.S.proof_limit.Call_provers.limit_time) (a.S.proof_limit.Call_provers.limit_mem) in let t = if obsolete then t ^ " (obsolete)" else t in (* TODO find a better way to signal archived row *) let t = if a.S.proof_archived then t ^ " (archived)" else t in goals_model#set ~row:row#iter ~column:time_column t let model_index = Hint.create 17 let get_any_from_iter row = try let idx = goals_model#get ~row ~column:index_column in Hint.find model_index idx with Not_found -> invalid_arg "Gmain.get_any_from_iter" (* let get_any (row:Gtk.tree_path) : M.any = get_any_from_iter (goals_model#get_iter row) *) let get_any_from_row_reference r = get_any_from_iter r#iter let get_selected_row_references () = List.map (fun path -> goals_model#get_row_reference path) goals_view#selection#get_selected_rows let row_expanded b iter _path = session_needs_saving := true; let expand_g g = goals_view#expand_row (S.goal_key g)#path in let expand_tr _ tr = goals_view#expand_row tr.S.transf_key#path in let expand_m _ m = goals_view#expand_row m.S.metas_key#path in match get_any_from_iter iter with | S.File f -> S.set_file_expanded f b | S.Theory t -> S.set_theory_expanded t b | S.Goal g -> S.set_goal_expanded g b; if b then begin Session.PHstr.iter expand_tr (S.goal_transformations g); Session.Mmetas_args.iter expand_m (S.goal_metas g) end | S.Transf tr -> S.set_transf_expanded tr b; if b then begin match tr.S.transf_goals with | [g] -> expand_g g | _ -> () end | S.Proof_attempt _ -> () | S.Metas m -> S.set_metas_expanded m b; if b then expand_g m.S.metas_goal let current_selected_row = ref None let current_env_session = ref None let env_session () = match !current_env_session with | None -> assert false | Some e -> e let task_text t = let max_boxes = (Gconfig.config ()).max_boxes in Pp.string_of ~max_boxes Pretty.print_task t let split_transformation = "split_goal_wp" let inline_transformation = "inline_goal" let intro_transformation = "introduce_premises" let goal_task_text g = if (Gconfig.config ()).intro_premises then let trans = Trans.lookup_transform intro_transformation (env_session()).S.env in task_text (try Trans.apply trans (S.goal_task g) with e -> eprintf "@.%a@." Exn_printer.exn_printer e; raise e) else task_text (S.goal_task g) let file_contents f = let s = try Sysutil.file_contents f with Invalid_argument s -> s in try_convert s let update_tabs a = let task_text = match a with | S.Goal g -> goal_task_text g | S.Proof_attempt a -> goal_task_text a.S.proof_parent | S.Theory th -> "Theory " ^ th.S.theory_name.Ident.id_string | S.File file -> "File " ^ file.S.file_name | S.Transf tr -> "transformation \"" ^ tr.S.transf_name ^ "\"" | S.Metas _ -> "metas" in let edited_text = match a with | S.Proof_attempt a -> begin let env = env_session () in match S.get_edited_as_abs env.S.session a with | None -> "" | Some f -> file_contents f end | _ -> "" in let output_text = match a with | S.Proof_attempt a -> begin match a.S.proof_state with | S.Interrupted -> "proof not yet scheduled for running" | S.Unedited -> "Interactive proof, not yet edited. Edit with \"Edit\" button" | S.JustEdited -> "Edited interactive proof. Run it with \"Replay\" button" | S.Done ({Call_provers.pr_answer = Call_provers.HighFailure} as r) -> Call_provers.print_prover_result str_formatter r; flush_str_formatter () | S.Done r -> let out = r.Call_provers.pr_output in if out = "" then "Output not available. Rerun it with \"Replay\" button" else out | S.Scheduled-> "proof scheduled but not running yet" | S.Running -> "prover currently running" | S.InternalFailure e -> fprintf str_formatter "%a" Exn_printer.exn_printer e; flush_str_formatter () end | S.Metas m -> let print_meta_args = Pp.hov 2 (Pp.print_list Pp.space Pretty.print_meta_arg) in let print = Pp.print_iter2 Mstr.iter Pp.newline2 Pp.newline Pp.string (Pp.indent 2 (Pp.print_iter1 S.Smeta_args.iter Pp.newline print_meta_args)) in (Pp.string_of (Pp.hov 2 print) m.S.metas_added) | _ -> "" in let counterexample_text = match a with | S.Proof_attempt a -> begin match a.S.proof_state with | S.Done r -> if not (Model_parser.is_model_empty r.Call_provers.pr_model) then begin let cntexample_text = if Debug.test_flag debug_show_text_cntexmp then "Counterexample:\n" ^ (Model_parser.model_to_string r.Call_provers.pr_model) ^ "\n\nSource code interleaved with counterexample:" else "" in let cntexample_text = cntexample_text ^ (Model_parser.interleave_with_source r.Call_provers.pr_model ~filename:!current_file ~source_code:(file_contents !current_file)) in cntexample_text end else "" | _ -> "" end | _ -> "" in let lang = if Filename.check_suffix !current_file ".why" || Filename.check_suffix !current_file ".mlw" then why_lang else any_lang !current_file in counterexample_view#source_buffer#set_language lang; task_view#source_buffer#set_text task_text; task_view#scroll_to_mark `INSERT; edited_view#source_buffer#set_text edited_text; edited_view#scroll_to_mark `INSERT; output_view#source_buffer#set_text output_text; counterexample_view#source_buffer#set_text counterexample_text; counterexample_view#scroll_to_mark `INSERT; module MA = struct type key = GTree.row_reference let create ?parent () = reset_gc (); session_needs_saving := true; let parent = match parent with | None -> None | Some r -> Some r#iter in let iter = goals_model#append ?parent () in goals_model#set ~row:iter ~column:index_column (-1); goals_model#get_row_reference (goals_model#get_path iter) let keygen = create let remove row = session_needs_saving := true; let (_:bool) = goals_model#remove row#iter in () let reset () = session_needs_saving := true; goals_model#clear () let idle f = let (_ : GMain.Idle.id) = GMain.Idle.add f in () let timeout ~ms f = let (_ : GMain.Timeout.id) = GMain.Timeout.add ~ms ~callback:f in () let notify_timer_state = let c = ref 0 in fun t s r -> reset_gc (); incr c; monitor_waiting#set_text ("Waiting: " ^ (string_of_int t)); monitor_scheduled#set_text ("Scheduled: " ^ (string_of_int s)); monitor_running#set_text (if r=0 then "Running: 0" else "Running: " ^ (string_of_int r)^ " " ^ (fan (!c / 10))) let notify any = reset_gc (); session_needs_saving := true; let row,expanded = match any with | S.Goal g -> (S.goal_key g), (S.goal_expanded g) | S.Theory t -> t.S.theory_key, t.S.theory_expanded | S.File f -> f.S.file_key, f.S.file_expanded | S.Proof_attempt a -> a.S.proof_key,false | S.Transf tr -> tr.S.transf_key,tr.S.transf_expanded | S.Metas m -> m.S.metas_key,m.S.metas_expanded in (* name is set by notify since upgrade policy may update the prover name *) goals_model#set ~row:row#iter ~column:name_column (match any with | S.Goal g -> S.goal_user_name g | S.Theory th -> th.S.theory_name.Ident.id_string | S.File f -> Filename.basename f.S.file_name | S.Proof_attempt a -> let p = a.S.proof_prover in Pp.string_of_wnl C.print_prover p | S.Transf tr -> tr.S.transf_name | S.Metas _m -> "Metas..." ); let ind = goals_model#get ~row:row#iter ~column:index_column in begin match !current_selected_row with | Some r when r == ind -> update_tabs any | _ -> () end; if expanded then goals_view#expand_to_path row#path else goals_view#collapse_row row#path; match any with | S.Goal g -> set_row_status row (S.goal_verified g) | S.Theory th -> set_row_status row th.S.theory_verified | S.File file -> set_row_status row file.S.file_verified | S.Proof_attempt a -> set_proof_state a | S.Transf tr -> set_row_status row tr.S.transf_verified | S.Metas m -> set_row_status row m.S.metas_verified let init = let cpt = ref (-1) in fun row any -> reset_gc (); let ind = goals_model#get ~row:row#iter ~column:index_column in if ind < 0 then begin incr cpt; Hint.add model_index !cpt any; goals_model#set ~row:row#iter ~column:index_column !cpt end else begin Hint.replace model_index ind any; end; (* useless since it has no child: goals_view#expand_row row#path; *) goals_model#set ~row:row#iter ~column:icon_column (match any with | S.Goal _ -> !image_goal | S.Theory _ -> !image_theory | S.File _ -> !image_file | S.Proof_attempt _ -> !image_prover | S.Transf _ -> !image_transf | S.Metas _ -> !image_metas); notify any let rec init_any any = init (S.key_any any) any; S.iter init_any any let uninstalled_prover = Gconfig.uninstalled_prover gconfig end module M = Session_scheduler.Make(MA) let () = w#add_accel_group accel_group let () = w#show () (********************) (* opening database *) (********************) (** TODO remove that should done only in session *) let project_dir = let fname = Queue.pop files in (* The remaining files in [files] are going to be open *) if Sys.file_exists fname then begin if Sys.is_directory fname then begin Debug.dprintf debug "[GUI] found directory '%s' for the project@." fname; fname end else if Queue.is_empty files then (* that was the only file *) begin Debug.dprintf debug "[GUI] found regular file '%s'@." fname; let d = try Filename.chop_extension fname with Invalid_argument _ -> fname in Debug.dprintf debug "[GUI] using '%s' as directory for the project@." d; Queue.push fname files; (* we need to open [fname] *) d end else begin (* The first argument is not a directory and it's not the only file *) Format.eprintf "[Error] @[When@ more@ than@ one@ file@ is@ given@ on@ the@ \ command@ line@ the@ first@ one@ must@ be@ the@ directory@ \ of@ the@ session.@]@."; Arg.usage spec usage_str; exit 1 end end else fname let () = if not (Sys.file_exists project_dir) then begin Debug.dprintf debug "[GUI] '%s' does not exist. \ Creating directory of that name for the project@." project_dir; Unix.mkdir project_dir 0o777 end let info_window ?(callback=(fun () -> ())) mt s = let buttons = match mt with | `INFO -> GWindow.Buttons.close | `WARNING -> GWindow.Buttons.close | `QUESTION -> GWindow.Buttons.ok_cancel | `ERROR -> GWindow.Buttons.close in let d = GWindow.message_dialog ~message:s ~message_type:(mt :> Gtk.Tags.message_type) ~buttons ~title:"Why3IDE" ~icon:(!Gconfig.why_icon) ~modal:true ~show:true () in let (_ : GtkSignal.id) = d#connect#response ~callback:(function x -> d#destroy (); if mt <> `QUESTION || x = `OK then callback ()) in () let file_info = GMisc.label ~text:"" ~packing:(source_tab#pack ~fill:true ?from:None ?expand:None ?padding:None) () let warnings = Queue.create () let record_warning ?loc msg = Format.eprintf "%awarning: %s@." (Pp.print_option Loc.report_position) loc msg; Queue.push (loc,msg) warnings let () = Warning.set_hook record_warning let display_warnings () = if Queue.is_empty warnings then () else begin let nwarn = ref 0 in begin try Queue.iter (fun (loc,msg) -> if !nwarn = 4 then begin Format.fprintf Format.str_formatter "[%d more warnings. See stderr for details]@\n" (Queue.length warnings - !nwarn); raise Exit end else begin incr nwarn; match loc with | None -> Format.fprintf Format.str_formatter "%s@\n@\n" msg | Some l -> (* scroll_to_loc ~color:error_tag ~yalign:0.5 loc; *) Format.fprintf Format.str_formatter "%a: %s@\n@\n" Loc.gen_report_position l msg end) warnings; with Exit -> (); end; Queue.clear warnings; let msg = Format.flush_str_formatter () in (* file_info#set_text msg; *) info_window `WARNING msg end (* check if provers are present *) let () = if C.Mprover.is_empty (C.get_provers gconfig.Gconfig.config) then begin info_window `ERROR "No prover configured.\nPlease run 'why3 config --detect-provers' first" ~callback:GMain.quit; GMain.main (); exit 2; end let sched = try Debug.dprintf debug "@[[GUI session] Opening session...@\n"; let session,use_shapes = if Sys.file_exists project_dir then S.read_session project_dir else S.create_session project_dir, false in let env,(_:bool),(_:bool) = M.update_session ~allow_obsolete:true ~release:false ~use_shapes session gconfig.env gconfig.Gconfig.config in Debug.dprintf debug "@]@\n[GUI session] Opening session: update done@. @["; let sched = M.init (gconfig.session_nb_processes) in Debug.dprintf debug "@]@\n[GUI session] Opening session: done@."; session_needs_saving := false; current_env_session := Some env; sched with e when not (Debug.test_flag Debug.stack_trace) -> eprintf "@[Error while opening session:@ %a@.@]" Exn_printer.exn_printer e; exit 1 (**********************************) (* add new file from command line *) (**********************************) let open_file ?(start=false) f = let f = Sysutil.relativize_filename project_dir f in Debug.dprintf debug "[GUI session] Adding file '%s'@." f; if S.PHstr.mem (env_session()).S.session.S.session_files f then Debug.dprintf debug "[GUI] file %s already in database@." f else try Debug.dprintf debug "[GUI] adding file %s in database@." f; ignore (M.add_file (env_session()) ?format:!opt_parser f); with e -> if start then begin eprintf "@[Error while reading file@ '%s':@ %a@]@." f Exn_printer.exn_printer e; exit 1 end else let msg = Pp.sprintf_wnl "@[Error while reading file@ '%s':@ %a@]" f Exn_printer.exn_printer e in info_window `ERROR msg let () = Queue.iter (open_file ~start:true) files (*****************************************************) (* method: run a given prover on each unproved goals *) (*****************************************************) let prover_on_selected_goals pr = let timelimit = gconfig.session_time_limit in let memlimit = gconfig.session_mem_limit in let cntexample = Whyconf.cntexample (Whyconf.get_main gconfig.config) in List.iter (fun row -> try let a = get_any_from_row_reference row in M.run_prover (env_session()) sched ~context_unproved_goals_only:!context_unproved_goals_only ~cntexample ~limit:{Call_provers.empty_limit with Call_provers.limit_time = timelimit; limit_mem = memlimit } pr a with e -> eprintf "@[Exception raised while running a prover:@ %a@.@]" Exn_printer.exn_printer e) (get_selected_row_references ()) (**********************************) (* method: replay obsolete proofs *) (**********************************) let replay_obsolete_proofs () = List.iter (fun r -> let a = get_any_from_row_reference r in M.replay (env_session()) sched ~obsolete_only:true ~context_unproved_goals_only:!context_unproved_goals_only a) (get_selected_row_references ()) (***********************************) (* method: mark proofs as obsolete *) (***********************************) let cancel_proofs () = List.iter (fun r -> let a = get_any_from_row_reference r in M.cancel a) (get_selected_row_references ()) (*****************************************) (* method: Set or unset the archive flag *) (*****************************************) let set_archive_proofs b () = List.iter (fun r -> let a = get_any_from_row_reference r in S.iter_proof_attempt (fun a -> M.set_archive a b) a) (get_selected_row_references ()) (*****************************************************) (* method: apply strategy on selected goals *) (*****************************************************) let apply_trans_on_selection tr = List.iter (fun r -> let a = get_any_from_row_reference r in M.transform (env_session()) sched ~context_unproved_goals_only:!context_unproved_goals_only tr a) (get_selected_row_references ()) let apply_strategy_on_selection str = List.iter (fun r -> let a = get_any_from_row_reference r in M.run_strategy (env_session()) sched ~context_unproved_goals_only:!context_unproved_goals_only str a) (get_selected_row_references ()) (*****************************************************) (* method: bisect goal *) (*****************************************************) let bisect_proof_attempt pa = let eS = env_session () in let timelimit = ref (-1) in let set_timelimit res = timelimit := 1 + (int_of_float (floor res.Call_provers.pr_time)) in let cntexample = Whyconf.cntexample (Whyconf.get_main gconfig.config) in let rec callback lp pa c = function | S.Running | S.Scheduled -> () | S.Interrupted -> dprintf debug "Bisecting interrupted.@." | S.Unedited | S.JustEdited -> assert false | S.InternalFailure exn -> (* Perhaps the test can be considered false in this case? *) dprintf debug "Bisecting interrupted by an error %a.@." Exn_printer.exn_printer exn | S.Done res -> let b = res.Call_provers.pr_answer = Call_provers.Valid in dprintf debug "Bisecting: %a.@." Call_provers.print_prover_result res; if b then set_timelimit res; let r = c b in match r with | Eliminate_definition.BSdone [] -> dprintf debug "Bisecting doesn't reduced the task.@." | Eliminate_definition.BSdone reml -> dprintf debug "Bisecting done.@."; begin try let keygen = MA.keygen in let notify = MA.notify in let reml = List.map (fun (m,l) -> m.Theory.meta_name,l) reml in let metas = S.add_registered_metas ~keygen eS reml pa.S.proof_parent in let trans = S.add_registered_transformation ~keygen eS "eliminate_builtin" metas.S.metas_goal in let goal = List.hd trans.S.transf_goals in (* only one *) let npa = S.copy_external_proof ~notify ~keygen ~obsolete:true ~goal ~env_session:eS pa in MA.init_any (S.Metas metas); M.run_external_proof eS sched ~cntexample npa with e -> dprintf debug "Bisecting error:@\n%a@." Exn_printer.exn_printer e end | Eliminate_definition.BSstep (t,c) -> assert (not lp.S.prover_config.C.in_place); (* TODO do this case *) M.schedule_proof_attempt ~cntexample ~limit:{Call_provers.empty_limit with Call_provers.limit_time = !timelimit; limit_mem = pa.S.proof_limit.Call_provers.limit_mem } ?old:(S.get_edited_as_abs eS.S.session pa) (* It is dangerous, isn't it? to be in place for bisecting? *) ~inplace:lp.S.prover_config.C.in_place ~command:(C.get_complete_command lp.S.prover_config ~with_steps:false) ~driver:lp.S.prover_driver ~callback:(callback lp pa c) sched t in (* Run once the complete goal in order to verify its validity and update the proof attempt *) let first_callback pa = function (* this pa can be different than the first pa *) | S.Running | S.Scheduled -> () | S.Interrupted -> dprintf debug "Bisecting interrupted.@." | S.Unedited | S.JustEdited -> assert false | S.InternalFailure exn -> dprintf debug "proof of the initial task interrupted by an error %a.@." Exn_printer.exn_printer exn | S.Done res -> if res.Call_provers.pr_answer <> Call_provers.Valid then dprintf debug "Initial task can't be proved.@." else let t = S.goal_task pa.S.proof_parent in let r = Eliminate_definition.bisect_step t in match r with | Eliminate_definition.BSdone res -> assert (res = []); dprintf debug "Task can't be reduced.@." | Eliminate_definition.BSstep (t,c) -> set_timelimit res; match S.load_prover eS pa.S.proof_prover with | None -> (* No prover so we do nothing *) dprintf debug "Prover can't be loaded.@." | Some lp -> M.schedule_proof_attempt ~cntexample ~limit:{pa.S.proof_limit with Call_provers.limit_steps = Call_provers.empty_limit.Call_provers.limit_steps; limit_time = !timelimit} ?old:(S.get_edited_as_abs eS.S.session pa) ~inplace:lp.S.prover_config.C.in_place ~command:(C.get_complete_command lp.S.prover_config ~with_steps:false) ~driver:lp.S.prover_driver ~callback:(callback lp pa c) sched t in dprintf debug "Bisecting with %a started.@." C.print_prover pa.S.proof_prover; M.run_external_proof eS sched ~cntexample ~callback:first_callback pa let apply_bisect_on_selection () = List.iter (fun r -> let a = get_any_from_row_reference r in S.iter_proof_attempt bisect_proof_attempt a ) (get_selected_row_references ()) (**************************************) (* Copy Paste proof, transf and metas *) (**************************************) let copy_queue = Queue.create () let copy_on_selection () = Queue.clear copy_queue; List.iter (fun r -> let a = get_any_from_row_reference r in let rec add = function | S.Goal g -> S.goal_iter add g | S.Transf f -> Queue.push (S.Transf (S.copy_transf f)) copy_queue | S.Metas m -> Queue.push (S.Metas (S.copy_metas m)) copy_queue | S.Proof_attempt pa -> Queue.push (S.Proof_attempt (S.copy_proof pa)) copy_queue | _ -> () in add a ) (get_selected_row_references ()) let paste_on_selection () = List.iter (fun r -> let a = get_any_from_row_reference r in match a with | S.Goal g -> let keygen = MA.keygen in let paste = function | S.Transf f -> MA.init_any (S.Transf (S.add_transf_to_goal ~keygen (env_session()) g f)) | S.Metas m -> MA.init_any (S.Metas (S.add_metas_to_goal ~keygen (env_session()) g m)) | S.Proof_attempt pa -> MA.init_any (S.Proof_attempt (S.add_proof_to_goal ~keygen (env_session()) g pa)) | _ -> () in Queue.iter paste copy_queue | _ -> () ) (get_selected_row_references ()) (*********************************) (* add a new file in the project *) (*********************************) let filter_all_files () = let f = GFile.filter ~name:"All" () in f#add_pattern "*" ; f let filter_why_files () = GFile.filter ~name:"Why3 source files" ~patterns:[ "*.why"; "*.mlw"] () let select_file () = let d = GWindow.file_chooser_dialog ~action:`OPEN ~title:"Why3: Add file in project" () in d#add_button_stock `CANCEL `CANCEL ; d#add_select_button_stock `OPEN `OPEN ; d#add_filter (filter_why_files ()) ; d#add_filter (filter_all_files ()) ; begin match d#run () with | `OPEN -> begin match d#filename with | None -> () | Some f -> open_file f end | `DELETE_EVENT | `CANCEL -> () end ; d#destroy () let not_implemented () = info_window `INFO "This feature is not yet implemented, sorry." (*************) (* File menu *) (*************) let file_menu = factory#add_submenu "_File" let file_factory = new GMenu.factory file_menu ~accel_group let (_ : GMenu.image_menu_item) = file_factory#add_image_item (* ~key:GdkKeysyms._A *) ~label:"_Add file" ~callback:select_file () let gui_items = ref [] let add_gui_item f = f (); gui_items := f :: !gui_items let recreate_gui () = List.iter (fun f -> f ()) (List.rev !gui_items) let (_ : GMenu.image_menu_item) = file_factory#add_image_item ~label:"_Preferences" ~callback: (fun () -> Gconfig.preferences gconfig; begin match !current_env_session with | None -> () | Some e -> Session.update_env_session_config e gconfig.config; Session.unload_provers e end; recreate_gui (); (* Mprover.iter (fun p pi -> Debug.dprintf debug "editor for %a : %s@." Whyconf.print_prover p pi.editor) (Whyconf.get_provers gconfig.config); *) let nb = gconfig.session_nb_processes in M.set_maximum_running_proofs nb sched) () (* let (_ : GMenu.image_menu_item) = file_factory#add_image_item ~label:"_Detect provers" ~callback: (fun () -> Gconfig.run_auto_detection gconfig; recreate_gui () ) () *) let save_session () = if !session_needs_saving then begin Debug.dprintf debug "[GUI] saving session@."; S.save_session gconfig.config (env_session()).S.session; session_needs_saving := false; end let exit_function ~destroy () = (* do not save automatically anymore Gconfig.save_config (); *) if not !session_needs_saving then GMain.quit () else match (Gconfig.config ()).saving_policy with | 0 -> save_session (); GMain.quit () | 1 -> GMain.quit () | 2 -> let answer = GToolbox.question_box ~title:"Why3 saving session" ~buttons:(["Yes"; "No"] @ (if destroy then [] else ["Cancel"])) "Do you want to save the session?" in begin match answer with | 1 -> save_session (); GMain.quit () | 2 -> GMain.quit () | _ -> if destroy then GMain.quit () else () end | _ -> eprintf "unexpected value for saving_policy@."; GMain.quit () (*************) (* View menu *) (*************) let sans_font_family = "Sans" let mono_font_family = "Monospace" let change_font size = (* Tools.resize_images (!Colors.font_size * 2 - 4); *) let sff = sans_font_family ^ " " ^ string_of_int size in let mff = mono_font_family ^ " " ^ string_of_int size in let sf = Pango.Font.from_string sff in let mf = Pango.Font.from_string mff in List.iter (fun v -> v#modify_font sf) !modifiable_sans_font_views; List.iter (fun v -> v#modify_font mf) !modifiable_mono_font_views let enlarge_font () = let size = Gconfig.incr_font_size 1 in change_font size let reduce_font () = let size = Gconfig.incr_font_size (-1) in change_font size let view_menu = factory#add_submenu "_View" let view_factory = new GMenu.factory view_menu ~accel_group let (_ : GMenu.image_menu_item) = view_factory#add_image_item ~key:GdkKeysyms._A ~label:"Select all" ~callback:(fun () -> goals_view#selection#select_all ()) () let (_ : GMenu.menu_item) = view_factory#add_item ~key:GdkKeysyms._plus ~callback:enlarge_font "Enlarge font" let (_ : GMenu.menu_item) = view_factory#add_item ~key:GdkKeysyms._minus ~callback:reduce_font "Reduce font" let (_ : GMenu.image_menu_item) = view_factory#add_image_item ~key:GdkKeysyms._E ~label:"Expand all" ~callback:(fun () -> goals_view#expand_all ()) () let rec collapse_verified = function | S.Goal g when Opt.inhabited (S.goal_verified g) -> let row = S.goal_key g in goals_view#collapse_row row#path | S.Theory th when Opt.inhabited th.S.theory_verified -> let row = th.S.theory_key in goals_view#collapse_row row#path | S.File f when Opt.inhabited f.S.file_verified -> let row = f.S.file_key in goals_view#collapse_row row#path | any -> S.iter collapse_verified any let collapse_all_verified_things () = S.session_iter collapse_verified (env_session()).S.session let (_ : GMenu.image_menu_item) = view_factory#add_image_item ~key:GdkKeysyms._C ~label:"Collapse proved goals" ~callback:collapse_all_verified_things () (* let rec hide_proved_in_goal g = if g.M.proved then begin let row = g.M.goal_row in goals_view#collapse_row (goals_model#get_path row); (* goals_model#set ~row ~column:M.visible_column false *) end else Hstr.iter (fun _ t -> List.iter hide_proved_in_goal t.M.subgoals) g.M.transformations let hide_proved_in_theory th = if th.M.verified then begin let row = th.M.theory_row in goals_view#collapse_row (goals_model#get_path row); goals_model#set ~row ~column:M.visible_column false end else List.iter hide_proved_in_goal th.M.goals let hide_proved_in_file f = if f.M.file_verified then begin let row = f.M.file_row in goals_view#collapse_row (goals_model#get_path row); goals_model#set ~row ~column:M.visible_column false end else List.iter hide_proved_in_theory f.M.theories let hide_proved_in_files () = List.iter hide_proved_in_file !M.all_files let rec show_all_in_goal g = let row = g.M.goal_row in goals_model#set ~row ~column:M.visible_column true; if g.M.proved then goals_view#collapse_row (goals_model#get_path row) else goals_view#expand_row (goals_model#get_path row); Hstr.iter (fun _ t -> List.iter show_all_in_goal t.M.subgoals) g.M.transformations let show_all_in_theory th = let row = th.M.theory_row in goals_model#set ~row ~column:M.visible_column true; if th.M.verified then goals_view#collapse_row (goals_model#get_path row) else begin goals_view#expand_row (goals_model#get_path row); List.iter show_all_in_goal th.M.goals end let show_all_in_file f = let row = f.M.file_row in goals_model#set ~row ~column:M.visible_column true; if f.M.file_verified then goals_view#collapse_row (goals_model#get_path row) else begin goals_view#expand_row (goals_model#get_path row); List.iter show_all_in_theory f.M.theories end let show_all_in_files () = List.iter show_all_in_file !M.all_files let (_ : GMenu.check_menu_item) = view_factory#add_check_item ~callback:(fun b -> M.toggle_hide_proved_goals := b; if b then hide_proved_in_files () else show_all_in_files ()) "Hide proved goals" *) (**************) (* Tools menu *) (**************) let goals_accel_group = GtkData.AccelGroup.create () let tools_menu = factory#add_submenu "_Tools" let tools_factory = new GMenu.factory tools_menu ~accel_group let () = add_gui_item (fun () -> List.iter (fun item -> item#destroy ()) provers_box#all_children; List.iter (fun item -> item#destroy ()) tools_menu#all_children) let add_tool_separator () = add_gui_item (fun () -> ignore(tools_factory#add_separator ())) let add_tool_item ?key label callback = add_gui_item (fun () -> let item = tools_factory#add_item ~callback label in match key with | None -> () | Some k -> item#add_accelerator ~group:goals_accel_group ~modi:[] k) let split_strategy = [| Strategy.Itransform(split_transformation,1) |] let inline_strategy = [| Strategy.Itransform(inline_transformation,1) |] (* let test_strategy () = let config = gconfig.Gconfig.config in let altergo = let fp = Whyconf.parse_filter_prover "Alt-Ergo" in Whyconf.filter_one_prover config fp in let cvc4 = let fp = Whyconf.parse_filter_prover "CVC4" in Whyconf.filter_one_prover config fp in [| Strategy.Icall_prover(altergo.Whyconf.prover,1,1000); Strategy.Icall_prover(cvc4.Whyconf.prover,1,1000); Strategy.Itransform(split_transformation,0); (* goto 0 on success *) Strategy.Icall_prover(altergo.Whyconf.prover,10,4000); Strategy.Icall_prover(cvc4.Whyconf.prover,10,4000); |] *) (* let strategies () : (string * Pp.formatted * M.strategy * (string * Gdk.keysym) option) list = [ "Split", "Splits@ conjunctions@ of@ the@ goal", split_strategy, Some("s",GdkKeysyms._s); "Inline", "Inline@ defined@ symbols", inline_strategy, Some("i",GdkKeysyms._i); "Blaster", "Blaster@ strategy", test_strategy (), Some("b",GdkKeysyms._b); ] *) let loaded_strategies = ref [] let load_shortcut s = match GtkData.AccelGroup.parse s with | (0,[]) -> None | (key, modi) -> Some (GtkData.AccelGroup.name ~key ~modi, key, modi) let strategies () = match !loaded_strategies with | [] -> let config = gconfig.Gconfig.config in let strategies = Whyconf.get_strategies config in let strategies = Mstr.fold_left (fun acc _ st -> let name = st.Whyconf.strategy_name in try let code = st.Whyconf.strategy_code in let code = Strategy_parser.parse (env_session()) code in let shortcut = load_shortcut st.Whyconf.strategy_shortcut in Debug.dprintf debug "[GUI] Strategy '%s' loaded.@." name; (name, st.Whyconf.strategy_desc, code, shortcut) :: acc with Strategy_parser.SyntaxError msg -> Format.eprintf "[GUI warning] Loading strategy '%s' failed: %s@." name msg; acc) [] strategies in let strategies = List.rev strategies in loaded_strategies := strategies; strategies | l -> l let escape_text = Glib.Markup.escape_text let sanitize_markup x = let remove = function | '_' -> "__" | c -> String.make 1 c in Ident.sanitizer remove remove (escape_text x) let string_of_desc desc = let print_trans_desc fmt (x,r) = fprintf fmt "@[%s@\n%a@]" x Pp.formatted r in escape_text (Pp.string_of print_trans_desc desc) let () = let transformations = List.sort (fun (x,_) (y,_) -> String.compare x y) (List.rev_append (Trans.list_transforms_l ()) (Trans.list_transforms ())) in let add_submenu_transform name filter () = let submenu = tools_factory#add_submenu name in let submenu = new GMenu.factory submenu ~accel_group in let iter ((name,_) as desc) = let callback () = apply_trans_on_selection name in let ii = submenu#add_image_item ~label:(sanitize_markup name) ~callback () in ii#misc#set_tooltip_text (string_of_desc desc) in let trans = List.filter filter transformations in List.iter iter trans in add_gui_item (add_submenu_transform "transformations (a-e)" (fun (x,_) -> x < "eliminate")); add_gui_item (add_submenu_transform "transformations (eliminate)" (fun (x,_) -> x >= "eliminate" && x < "eliminatf")); add_gui_item (add_submenu_transform "transformations (e-r)" (fun (x,_) -> x >= "eliminatf" && x < "s")); add_gui_item (add_submenu_transform "transformations (s-z)" (fun (x,_) -> x >= "s")); add_tool_separator (); add_tool_item "Bisect in selection" apply_bisect_on_selection let () = let iter (name,desc,strat,k) = let desc = Scanf.format_from_string desc "" in let b = GButton.button ~packing:strategies_box#add ~label:(sanitize_markup name) () in let name = match k with | None -> name | Some (s,_,_) -> Printf.sprintf "%s (shortcut: %s)" name s in b#misc#set_tooltip_markup (string_of_desc (name,desc)); let i = GMisc.image ~pixbuf:(!image_transf) () in let () = b#set_image i#coerce in let callback () = apply_strategy_on_selection strat in let (_ : GtkSignal.id) = b#connect#clicked ~callback in () in List.iter iter (strategies ()) (*************) (* Run menu *) (*************) (* let run_menu = factory#add_submenu "_Run" let run_factory = new GMenu.factory run_menu ~accel_group let eval const result = let msg = match Strings.split '.' const with | [f;m;i] -> begin let e = env_session () in let files = e.S.files in try let fi = Mstr.find f files in try let th = Mstr.find m fi in begin try let ls = Theory.ns_find_ls th.Theory.th_export [i] in match Decl.find_logic_definition th.Theory.th_known ls with | None -> Pp.sprintf "Symbol '%s' has no definition in theory '%s.%s'" i f m | Some d -> let l,t = Decl.open_ls_defn d in match l with | [] -> let t = Mlw_interp.eval_global_term e.S.env th.Theory.th_known t in Pp.sprintf "@[%a@]" Mlw_interp.print_value t | _ -> Pp.sprintf "Symbol '%s' is not a constant in theory '%s.%s'" i f m with Not_found -> Pp.sprintf "Constant '%s' not found in theory '%s.%s'" i f m end with Not_found -> Pp.sprintf "theory '%s.%s' not found" f m; with Not_found -> Pp.sprintf "@[file '%s' not found. Files are: [%a]@]" f (Pp.print_list Pp.comma Pp.string) (Mstr.keys files) end | _ -> "must be of the form .."; in result#source_buffer#set_text msg let constant_to_evaluate = ref "" (* let selected_file = ref "" *) let evaluate_window () = let dialog = GWindow.dialog ~modal:true ~title:"Why3: evaluate constant" ~icon:!Gconfig.why_icon () in let vbox = dialog#vbox in let frame = GBin.frame ~label:"Evaluation" ~shadow_type:`ETCHED_OUT ~packing:vbox#add () in let vbox = GPack.vbox ~packing:frame#add () in let text = "Enter the constant to evaluate under the form .." in let _ = GMisc.label ~ypad:20 ~text ~xalign:0.5 ~packing:vbox#add () in let exec_entry = GEdit.entry ~text:!constant_to_evaluate ~packing:vbox#add () in let (_ : GtkSignal.id) = exec_entry#connect#changed ~callback: (fun () -> constant_to_evaluate := exec_entry#text) in (* let hb = GPack.hbox ~homogeneous:false ~packing:vbox#pack () in let e = env_session () in let files_map = e.S.files in let (files_combo, _) = GEdit.combo_box_entry_text ~packing:hb#pack () in let _,file_names = Mstr.fold (fun f _th (i,names) -> if f = !selected_file then files_combo#set_active i; (i+1, f::names)) files_map (0, []) in let (_store, column) = GTree.store_of_list Gobject.Data.string file_names in files_combo#set_text_column column; let ( _ : GtkSignal.id) = files_combo#connect#changed ~callback:(fun () -> match files_combo#active_iter with | None -> () | Some row -> let s = files_combo#model#get ~row ~column in selected_file := s) in *) let b = GButton.button ~label:"Run" ~packing:vbox#add () in let text = "Result:" in let _input = GMisc.label ~ypad:20 ~text ~xalign:0.0 ~packing:vbox#add () in (* let _ = input#event#connect#key_press ~callback: (fun k -> if GdkEvent.Key.keyval k = GdkKeysyms._Return then eval !constant_to_evaluate view; true) in *) let scroll = GBin.scrolled_window ~hpolicy: `AUTOMATIC ~vpolicy: `AUTOMATIC ~shadow_type:`ETCHED_OUT ~packing:vbox#add () in let view = GSourceView2.source_view ~editable:false ~packing:scroll#add ~height:100 () in let (_ : GtkSignal.id) = b#connect#clicked ~callback:(fun () -> eval !constant_to_evaluate view) in dialog#add_button "Close" `CLOSE ; let _ = dialog#run () in dialog#destroy () let (_ : GMenu.image_menu_item) = run_factory#add_image_item ~label:"Evaluate a logic constant" ~callback:evaluate_window () let function_to_execute = ref "" let execute_window () = let dialog = GWindow.dialog ~modal:true ~title:"Why3: execute function" ~icon:!Gconfig.why_icon () in let vbox = dialog#vbox in let text = "Enter the function to execute under the form ." in let _ = GMisc.label ~ypad:20 ~text ~xalign:0.5 ~packing:vbox#add () in let exec_entry = GEdit.entry ~text:!function_to_execute ~packing:vbox#add () in let (_ : GtkSignal.id) = exec_entry#connect#changed ~callback: (fun () -> function_to_execute := exec_entry#text) in dialog#add_button "Close" `CLOSE ; let ( _ : GWindow.Buttons.about) = dialog#run () in dialog#destroy () (* let (_ : GMenu.image_menu_item) = run_factory#add_image_item ~label:"Execute a WhyML function" ~callback:execute_window () *) *) (*************) (* Help menu *) (*************) let help_menu = factory#add_submenu "_Help" let help_factory = new GMenu.factory help_menu ~accel_group let (_ : GMenu.image_menu_item) = help_factory#add_image_item ~label:"Legend" ~callback:show_legend_window () let (_ : GMenu.image_menu_item) = help_factory#add_image_item ~label:"About" ~callback:show_about_window () (***************) (* source view *) (***************) let scrolled_source_view = GBin.scrolled_window ~hpolicy: `AUTOMATIC ~vpolicy: `AUTOMATIC ~packing:source_tab#add ~shadow_type:`ETCHED_OUT () let allow_editing = false (* not reliable enough yet *) let source_view = GSourceView2.source_view ~auto_indent:true ~insert_spaces_instead_of_tabs:true ~tab_width:2 ~show_line_numbers:true ~right_margin_position:80 ~show_right_margin:true (* ~smart_home_end:true *) ~editable:allow_editing ~packing:scrolled_source_view#add () (* source_view#misc#modify_font_by_name font_name; *) let () = modifiable_mono_font_views := source_view#misc :: !modifiable_mono_font_views let () = change_font (Gconfig.incr_font_size 0) let () = source_view#source_buffer#set_language None let () = source_view#set_highlight_current_line true (* let () = source_view#source_buffer#set_text (source_text fname) *) let set_current_file f = current_file := f; file_info#set_text ("file: " ^ !current_file) let move_to_line ~yalign (v : GSourceView2.source_view) line = let line = max 0 line in let line = min line v#buffer#line_count in let it = v#buffer#get_iter (`LINE line) in v#buffer#place_cursor ~where:it; let mark = `MARK (v#buffer#create_mark it) in v#scroll_to_mark ~use_align:true ~yalign mark let premise_tag = source_view#buffer#create_tag ~name:"premise_tag" [`BACKGROUND gconfig.premise_color] let neg_premise_tag = source_view#buffer#create_tag ~name:"neg_premise_tag" [`BACKGROUND gconfig.neg_premise_color] let goal_tag = source_view#buffer#create_tag ~name:"goal_tag" [`BACKGROUND gconfig.goal_color] let error_tag = source_view#buffer#create_tag ~name:"error_tag" [`BACKGROUND gconfig.error_color] let erase_color_loc (v:GSourceView2.source_view) = let buf = v#buffer in buf#remove_tag premise_tag ~start:buf#start_iter ~stop:buf#end_iter; buf#remove_tag neg_premise_tag ~start:buf#start_iter ~stop:buf#end_iter; buf#remove_tag goal_tag ~start:buf#start_iter ~stop:buf#end_iter; buf#remove_tag error_tag ~start:buf#start_iter ~stop:buf#end_iter let color_loc (v:GSourceView2.source_view) ~color l b e = let buf = v#buffer in let top = buf#start_iter in let start = top#forward_lines (l-1) in let start = start#forward_chars b in let stop = start#forward_chars (e-b) in buf#apply_tag ~start ~stop color let scroll_to_file f = if f <> !current_file then begin let lang = if Filename.check_suffix f ".why" || Filename.check_suffix f ".mlw" then why_lang else any_lang f in source_view#source_buffer#set_language lang; source_view#source_buffer#set_text (file_contents f); set_current_file f; end let scroll_to_loc ?(yalign=0.0) ~color loc = reset_gc (); let (f,l,b,e) = Loc.get loc in scroll_to_file f; move_to_line ~yalign source_view (l-1); erase_color_loc source_view; (* FIXME: use another color or none at all *) color_loc source_view ~color l b e; ignore (color,l,b,e) let scroll_to_id ~color id = match id.Ident.id_loc with | Some loc -> scroll_to_loc ~color loc | None -> source_view#source_buffer#set_text "Non-localized ident (no position available)\n"; set_current_file "" let color_loc ~color loc = let f, l, b, e = Loc.get loc in if f = !current_file then color_loc ~color source_view l b e let rec color_locs ~color f = let b = ref false in Opt.iter (fun loc -> color_loc ~color loc; b := true) f.Term.t_loc; Term.t_fold (fun b loc -> color_locs ~color loc || b) !b f (* FIXME: we shouldn't open binders _every_time_ we redraw screen!!! No t_fold, no t_open_quant! *) let rec color_t_locs f = let premise_tag = function | { Term. t_node = Term.Tnot _; t_loc = None } -> neg_premise_tag | _ -> premise_tag in match f.Term.t_node with | Term.Tbinop (Term.Timplies,f1,f2) -> let b = color_locs ~color:(premise_tag f1) f1 in color_t_locs f2 || b | Term.Tlet (t,fb) -> let _,f1 = Term.t_open_bound fb in let b = color_locs ~color:(premise_tag t) t in color_t_locs f1 || b | Term.Tquant (Term.Tforall,fq) -> let _,_,f1 = Term.t_open_quant fq in color_t_locs f1 | _ -> color_locs ~color:goal_tag f let scroll_to_source_goal g = let t = S.goal_task g in let id = (Task.task_goal t).Decl.pr_name in scroll_to_id ~color:goal_tag id; match t with | Some { Task.task_decl = { Theory.td_node = Theory.Decl { Decl.d_node = Decl.Dprop (Decl.Pgoal, _, f)}}} -> if not (color_t_locs f) then Opt.iter (color_loc ~color:goal_tag) id.Ident.id_loc | _ -> assert false let scroll_to_theory th = let id = th.S.theory_name in scroll_to_id ~color:goal_tag id let reload () = try erase_color_loc source_view; current_file := ""; (* create a new environnement (in order to reload the files which are "use") *) gconfig.env <- Env.create_env (Env.get_loadpath gconfig.env); (* reload the session *) let old_session = (env_session()).S.session in let new_env_session,(_:bool),(_:bool) = (* use_shapes is true since session is in memory *) M.update_session ~allow_obsolete:true ~release:false ~use_shapes:true old_session gconfig.env gconfig.Gconfig.config in current_env_session := Some new_env_session; display_warnings () with | e -> begin match e with | Loc.Located(loc,_) -> scroll_to_loc ~color:error_tag ~yalign:0.5 loc; notebook#goto_page source_page (* go to "source" tab *) | _ -> () end; fprintf str_formatter "@[Error:@ %a@]" Exn_printer.exn_printer e; let msg = flush_str_formatter () in file_info#set_text msg; info_window `ERROR msg let (_ : GMenu.image_menu_item) = file_factory#add_image_item ~key:GdkKeysyms._R ~label:"_Reload" ~callback:reload () (* Saving the session *) let (_ : GMenu.image_menu_item) = file_factory#add_image_item (* no shortcut ~key:GdkKeysyms._S *) ~label:"_Save session" ~callback:save_session () (* Saving the source_view *) let save_file () = let f = !current_file in if f <> "" then begin save_session (); let s = source_view#source_buffer#get_text () in let c = open_out f in output_string c s; close_out c; reload () end else info_window `ERROR "No file currently edited" let () = if allow_editing then let (_ : GMenu.image_menu_item) = file_factory#add_image_item ~key:GdkKeysyms._S ~label:"_Save" ~callback:save_file () in () let (_ : GtkSignal.id) = w#connect#destroy ~callback:(exit_function ~destroy:true) let (_ : GMenu.image_menu_item) = file_factory#add_image_item ~key:GdkKeysyms._Q ~label:"_Quit" ~callback:(exit_function ~destroy:false) () (*****************************) (* method: edit current goal *) (*****************************) let edit_selected_row r = match get_any_from_row_reference r with | S.Goal _g -> () | S.Theory _th -> () | S.File _file -> () | S.Proof_attempt a -> let e = env_session () in let cntexample = Whyconf.cntexample (Whyconf.get_main gconfig.config) in (* let coq = { prover_name = "Coq" ; prover_version = "8.3pl3"; prover_altern = "" } in let c = e.Session.whyconf in let p = Mprover.find coq (get_provers c) in let time = Whyconf.timelimit (Whyconf.get_main c) in Debug.dprintf debug "[debug] save_config %d: timelimit=%d ; editor for Coq=%s@." 0 time p.editor; *) M.edit_proof ~cntexample e sched ~default_editor:gconfig.default_editor a | S.Transf _ -> () | S.Metas _ -> () let edit_current_proof () = match get_selected_row_references () with | [] -> () | [r] -> edit_selected_row r | _ -> info_window `INFO "Please select exactly one proof to edit" let () = add_tool_separator (); add_tool_item ~key:GdkKeysyms._e "Edit current proof" edit_current_proof; add_tool_item ~key:GdkKeysyms._r "Replay selection" replay_obsolete_proofs; add_tool_item ~key:GdkKeysyms._o "Mark as obsolete" cancel_proofs; add_tool_item "Mark as archived" (set_archive_proofs true); add_tool_item "Remove from archive" (set_archive_proofs false) let () = let b = GButton.button ~packing:tools_box#add ~label:"Edit" () in b#misc#set_tooltip_markup "Edit the selected proof with the appropriate editor"; let i = GMisc.image ~pixbuf:(!image_editor) () in let () = b#set_image i#coerce in let (_ : GtkSignal.id) = b#connect#clicked ~callback:edit_current_proof in () let () = let b = GButton.button ~packing:tools_box#add ~label:"Replay" () in b#misc#set_tooltip_markup "Replay obsolete proofs below the current selection"; let i = GMisc.image ~pixbuf:(!image_replay) () in let () = b#set_image i#coerce in let (_ : GtkSignal.id) = b#connect#clicked ~callback:replay_obsolete_proofs in () (*************) (* removing *) (*************) let confirm_remove_row r = match get_any_from_row_reference r with | S.Goal _g -> info_window `ERROR "Cannot remove a goal" | S.Theory _th -> info_window `ERROR "Cannot remove a theory" | S.File _file -> info_window `ERROR "Cannot remove a file" | S.Proof_attempt a -> info_window ~callback:(fun () -> M.remove_proof_attempt a) `QUESTION "Do you really want to remove the selected proof attempt?" | S.Transf tr -> info_window ~callback:(fun () -> M.remove_transformation tr) `QUESTION "Do you really want to remove the selected transformation\n\ and all its subgoals?" | S.Metas m -> info_window ~callback:(fun () -> M.remove_metas m) `QUESTION "Do you really want to remove the selected addition of metas\n\ and all its subgoals?" let remove_proof r = match get_any_from_row_reference r with | S.Goal _g -> () | S.Theory _th -> () | S.File _file -> () | S.Proof_attempt a -> M.remove_proof_attempt a | S.Transf _tr -> () | S.Metas _m -> () let confirm_remove_selection () = match get_selected_row_references () with | [] -> () | [r] -> confirm_remove_row r | l -> info_window ~callback:(fun () -> List.iter remove_proof l) `QUESTION "Do you really want to remove the selected proof attempts?" (* | _ -> info_window `INFO "Please select exactly one item to remove" *) let clean_selection () = List.iter (fun r -> M.clean (get_any_from_row_reference r)) (get_selected_row_references ()) let () = add_tool_separator (); add_tool_item ~key:GdkKeysyms._x "Remove current proof" confirm_remove_selection; add_tool_item ~key:GdkKeysyms._c "Clean selection" clean_selection let () = let b = GButton.button ~packing:tools_box#add ~label:"Remove" () in b#misc#set_tooltip_markup "Remove selected proof attempts and \ transformations"; let i = GMisc.image ~pixbuf:(!image_remove) () in let () = b#set_image i#coerce in let (_ : GtkSignal.id) = b#connect#clicked ~callback:confirm_remove_selection in () let () = let b = GButton.button ~packing:tools_box#add ~label:"Clean" () in b#misc#set_tooltip_markup "Remove unsuccessful proof attempts \ associated to proved goals"; let i = GMisc.image ~pixbuf:(!image_cleaning) () in let () = b#set_image i#coerce in let (_ : GtkSignal.id) = b#connect#clicked ~callback:clean_selection in () let () = let b = GButton.button ~packing:monitor_box#add ~label:"Interrupt" () in b#misc#set_tooltip_markup "Cancels all scheduled proof attempts"; let i = GMisc.image ~pixbuf:(!image_cancel) () in let () = b#set_image i#coerce in let (_ : GtkSignal.id) = b#connect#clicked ~callback:(fun () -> M.cancel_scheduled_proofs sched) in () (***) let () = add_tool_separator (); add_tool_item "Copy" copy_on_selection; add_tool_item "Paste" paste_on_selection; add_tool_separator (); let submenu = tools_factory#add_submenu "Strategies" in let submenu = new GMenu.factory submenu ~accel_group in let iter (name,desc,strat,k) = let desc = Scanf.format_from_string desc "" in let callback () = apply_strategy_on_selection strat in let ii = submenu#add_item ~callback (sanitize_markup name) in let name = match k with | None -> name | Some (s,key,modi) -> ii#add_accelerator ~group:goals_accel_group ~modi key; Printf.sprintf "%s (shortcut: %s)" name s in ii#misc#set_tooltip_text (string_of_desc (name,desc)) in List.iter iter (strategies ()); add_tool_separator (); let provers_factory = let tools_submenu_provers = tools_factory#add_submenu "Provers" in new GMenu.factory tools_submenu_provers in let add_item_provers () = let provers = C.get_provers gconfig.Gconfig.config in let provers = C.Mprover.fold (fun k p acc -> let pr = p.prover in if List.mem (C.prover_parseable_format pr) gconfig.hidden_provers then acc else C.Mprover.add k p acc) provers C.Mprover.empty in C.Mprover.iter (fun p _ -> let n = Pp.string_of_wnl C.print_prover p in let (_ : GMenu.image_menu_item) = provers_factory#add_image_item ~label:n ~callback:(fun () -> prover_on_selected_goals p) () in let b = GButton.button ~packing:provers_box#add ~label:n () in b#misc#set_tooltip_markup (Pp.sprintf_wnl "Start %a on the selected goals" C.print_prover p); let (_ : GtkSignal.id) = b#connect#clicked ~callback:(fun () -> prover_on_selected_goals p) in ()) provers in add_gui_item add_item_provers (***********************************************) (* Keyboard shortcuts in the (goals) tree view *) (***********************************************) (* TODO: - instead of a default prover, have instead keyboard shortcuts for any prover *) let () = let run_default_prover () = if gconfig.default_prover = "" then Debug.dprintf debug "no default prover@." else let fp = Whyconf.parse_filter_prover gconfig.default_prover in let pr = Whyconf.filter_one_prover gconfig.config fp in prover_on_selected_goals pr.prover in let callback ev = let key = GdkEvent.Key.keyval ev in if key = GdkKeysyms._p then begin run_default_prover (); true end else false (* otherwise, use the default event handler *) in ignore (goals_view#event#connect#key_press ~callback); ignore (goals_view#event#connect#focus_in ~callback:(fun _ -> w#add_accel_group goals_accel_group; true)); ignore (goals_view#event#connect#focus_out ~callback:(fun _ -> GtkWindow.Window.remove_accel_group w#as_window goals_accel_group; true)) (***************) (* Bind events *) (***************) (* to be run when a row in the tree view is selected *) let select_row r = let ind = goals_model#get ~row:r#iter ~column:index_column in current_selected_row := Some ind; let a = get_any_from_row_reference r in begin match a with | S.Goal g -> scroll_to_source_goal g | S.Theory th -> scroll_to_theory th; (* notebook#goto_page source_page (* go to "source" tab *)*) | S.File file -> scroll_to_file (Filename.concat project_dir file.S.file_name); (* notebook#goto_page source_page (\* go to "source" tab *\) *) | S.Proof_attempt a -> scroll_to_source_goal a.S.proof_parent; (* notebook#goto_page output_page (\* go to "prover output" tab *\) *) | S.Transf tr -> scroll_to_source_goal tr.S.transf_parent | S.Metas m -> scroll_to_source_goal m.S.metas_parent end; update_tabs a (* row selection on tree view on the left *) let (_ : GtkSignal.id) = goals_view#selection#connect#after#changed ~callback: begin fun () -> match get_selected_row_references () with | [p] -> select_row p | [] -> () | _ -> () end let (_:GtkSignal.id) = goals_view#connect#row_collapsed ~callback:(row_expanded false) let (_:GtkSignal.id) = goals_view#connect#row_expanded ~callback:(row_expanded true) (* let () = Debug.set_flag (Debug.lookup_flag "transform") *) let () = display_warnings () let () = GMain.main () (* Local Variables: compile-command: "unset LANG; make -C ../.. bin/why3ide.byte" End: *) why3-0.88.3/src/whyml/0000775000175100017510000000000013225666037015203 5ustar guillaumeguillaumewhy3-0.88.3/src/whyml/mlw_expr.mli0000664000175100017510000001632413225666037017551 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** {1 Program Expressions} *) open Stdlib open Ident open Term open Mlw_ty open Mlw_ty.T (** {2 Program/logic symbols} *) (** {!plsymbol}s represent algebraic type constructors and projections. They must be fully applied and the result is equal to the application of the lsymbol. We need this kind of symbols to cover nullary constructors, such as [Nil], which cannot be given a post-condition. They cannot be locally defined and therefore every type variable and region in their type signature can be instantiated. *) type field = { fd_ity : ity; fd_ghost : bool; fd_mut : region option; } type plsymbol = private { pl_ls : lsymbol; pl_args : field list; pl_value : field; pl_hidden : bool; pl_rdonly : bool; } val pl_equal : plsymbol -> plsymbol -> bool val create_plsymbol : ?hidden:bool -> ?rdonly:bool -> ?constr:int -> preid -> field list -> field -> plsymbol val restore_pl : lsymbol -> plsymbol (** raises [Not_found] if the argument is not a [pl_ls] *) exception HiddenPLS of plsymbol exception RdOnlyPLS of plsymbol (** {2 Cloning} *) type symbol_map = private { sm_pure : Theory.symbol_map; sm_its : itysymbol Mits.t; sm_pls : plsymbol Mls.t; } val pl_clone : Theory.symbol_map -> symbol_map (** {2 Patterns} *) type ppattern = private { ppat_pattern : pattern; ppat_ity : ity; ppat_ghost : bool; (* matches a ghost value *) ppat_fail : bool; (* refutable under ghost *) } type pre_ppattern = | PPwild | PPvar of preid | PPlapp of lsymbol * pre_ppattern list | PPpapp of plsymbol * pre_ppattern list | PPor of pre_ppattern * pre_ppattern | PPas of pre_ppattern * preid val make_ppattern : pre_ppattern -> ?ghost:bool -> ity -> pvsymbol Mstr.t * ppattern (** {2 Program symbols} *) (** {!psymbol}s represent lambda-abstractions. They are polymorphic and can be type-instantiated in some type variables and regions of their type signature. *) type psymbol = private { ps_name : ident; ps_aty : aty; ps_ghost : bool; ps_pvset : Spv.t; ps_vars : varset; (** this varset covers the type variables and regions of the defining lambda that cannot be instantiated. Every other type variable and region in [ps_aty] is generalized and can be instantiated. *) ps_subst : ity_subst; (** this substitution instantiates every type variable and region in [ps_vars] to itself *) } module Mps : Extmap.S with type key = psymbol module Sps : Extset.S with module M = Mps module Hps : Exthtbl.S with type key = psymbol module Wps : Weakhtbl.S with type key = psymbol val ps_equal : psymbol -> psymbol -> bool val create_psymbol : preid -> ?ghost:bool -> aty -> psymbol (** {2 Program expressions} *) type assertion_kind = Aassert | Aassume | Acheck type for_direction = To | DownTo type for_bounds = pvsymbol * for_direction * pvsymbol type invariant = term type let_sym = | LetV of pvsymbol | LetA of psymbol type symset = private { syms_pv : Spv.t; syms_ps : Sps.t; } type expr = private { e_node : expr_node; e_vty : vty; e_ghost : bool; e_effect : effect; e_syms : symset; e_label : Slab.t; e_loc : Loc.position option; } and expr_node = private | Elogic of term | Evalue of pvsymbol | Earrow of psymbol | Eapp of expr * pvsymbol * spec | Elet of let_defn * expr | Erec of fun_defn list * expr | Eif of expr * expr * expr | Ecase of expr * (ppattern * expr) list | Eassign of plsymbol * expr * region * pvsymbol | Eghost of expr | Eany of spec | Eloop of invariant * variant list * expr | Efor of pvsymbol * for_bounds * invariant * expr | Eraise of xsymbol * expr | Etry of expr * (xsymbol * pvsymbol * expr) list | Eabstr of expr * spec | Eassert of assertion_kind * term | Eabsurd and let_defn = private { let_sym : let_sym; let_expr : expr; } and fun_defn = private { fun_ps : psymbol; fun_lambda : lambda; fun_syms : symset; } and lambda = { l_args : pvsymbol list; l_expr : expr; l_spec : spec; } val e_label : ?loc:Loc.position -> Slab.t -> expr -> expr val e_label_add : label -> expr -> expr val e_label_copy : expr -> expr -> expr val e_value : pvsymbol -> expr val e_arrow : psymbol -> ity list -> ity -> expr (** [e_arrow p argl res] instantiates the program function symbol [p] into a program expression having the given types of the arguments and the result. The resulting expression can be applied to arguments using {!e_app} given below. See also [examples/use_api/mlw.ml] *) exception ValueExpected of expr exception ArrowExpected of expr val ity_of_expr : expr -> ity val aty_of_expr : expr -> aty val e_app : expr -> expr list -> expr (** [e_app e el] builds the application of [e] to arguments [el]. [e] is typically constructed using {!e_arrow} defined above. See also [examples/use_api/mlw.ml] *) val e_lapp : lsymbol -> expr list -> ity -> expr val e_plapp : plsymbol -> expr list -> ity -> expr val create_let_defn : preid -> expr -> let_defn val create_let_pv_defn : preid -> expr -> let_defn * pvsymbol val create_let_ps_defn : preid -> expr -> let_defn * psymbol val create_fun_defn : preid -> lambda -> fun_defn val create_rec_defn : (psymbol * lambda) list -> fun_defn list exception StaleRegion of expr * ident (** freshness violation: a previously reset region is associated to an ident *) val e_let : let_defn -> expr -> expr val e_rec : fun_defn list -> expr -> expr val e_if : expr -> expr -> expr -> expr val e_case : expr -> (ppattern * expr) list -> expr exception Immutable of expr val e_assign : plsymbol -> expr -> expr -> expr val e_ghost : expr -> expr val fs_void : lsymbol val t_void : term val e_void : expr val e_const : Number.constant -> ity -> expr val e_lazy_and : expr -> expr -> expr val e_lazy_or : expr -> expr -> expr val e_not : expr -> expr val e_true : expr val e_false : expr val e_raise : xsymbol -> expr -> ity -> expr val e_try : expr -> (xsymbol * pvsymbol * expr) list -> expr val e_loop : invariant -> variant list -> expr -> expr val e_for : pvsymbol -> expr -> for_direction -> expr -> invariant -> expr -> expr val e_abstract : expr -> spec -> expr val e_any : spec option -> vty -> expr val e_assert : assertion_kind -> term -> expr val e_absurd : ity -> expr (** {2 Expression traversal} *) val e_fold : ('a -> expr -> 'a) -> 'a -> expr -> 'a val e_find : (expr -> bool) -> expr -> expr (** [e_find pr e] returns a sub-expression of [e] satisfying [pr]. raises [Not_found] if no sub-expression satisfies [pr]. *) val e_purify : expr -> term option why3-0.88.3/src/whyml/mlw_interp.mli0000664000175100017510000000235713225666037020075 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (* WhyML interpretation *) type value val print_value: Format.formatter -> value -> unit val eval_global_term: Env.env -> Decl.known_map -> Term.term -> value type result = | Normal of value | Excep of Mlw_ty.xsymbol * value | Irred of Mlw_expr.expr | Fun of Mlw_expr.psymbol * Mlw_ty.pvsymbol list * int val eval_global_expr: Env.env -> Mlw_decl.known_map -> Decl.known_map -> 'a -> Mlw_expr.expr -> result * value Term.Mvs.t val eval_global_symbol: Env.env -> Mlw_module.modul -> Format.formatter -> Mlw_expr.fun_defn -> unit why3-0.88.3/src/whyml/mlw_ty.mli0000664000175100017510000002304313225666037017223 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** {1 Program Types} *) open Ident open Ty open Term (** {2 Individual types (first-order types w/o effects)} *) module rec T : sig type varset = private { vars_tv : Stv.t; vars_reg : Sreg.t; } type itysymbol = private { its_ts : tysymbol; (** "pure snapshot" type symbol *) its_regs : region list; (** region arguments *) its_def : ity option; (** type alias definition *) its_ghrl : bool list; (** ghost region arguments *) its_inv : bool; (** carries a type invariant *) its_abst : bool; (** is an abstract (= "model") type *) its_priv : bool; (** is a private (à la Ocaml) type *) } (** ity = individual type in programs, first-order, i.e. no functions *) and ity = private { ity_node : ity_node; ity_vars : varset; ity_tag : Weakhtbl.tag; } and ity_node = private | Ityvar of tvsymbol | Itypur of tysymbol * ity list | Ityapp of itysymbol * ity list * region list and region = private { reg_name : ident; reg_ity : ity; } end and Mreg : sig include Extmap.S with type key = T.region end and Sreg : sig include Extset.S with module M = Mreg end open T module Mits : Extmap.S with type key = itysymbol module Sits : Extset.S with module M = Mits module Hits : Exthtbl.S with type key = itysymbol module Wits : Weakhtbl.S with type key = itysymbol module Mity : Extmap.S with type key = ity module Sity : Extset.S with module M = Mity module Hity : Exthtbl.S with type key = ity module Wity : Weakhtbl.S with type key = ity module Hreg : Exthtbl.S with type key = region module Wreg : Weakhtbl.S with type key = region val its_equal : itysymbol -> itysymbol -> bool val ity_equal : ity -> ity -> bool val its_hash : itysymbol -> int val ity_hash : ity -> int val reg_equal : region -> region -> bool val reg_hash : region -> int exception BadItyArity of itysymbol * int exception BadRegArity of itysymbol * int exception DuplicateRegion of region exception UnboundRegion of region val create_region : preid -> ity -> region (** creation of a symbol for type in programs *) val create_itysymbol : preid -> ?abst:bool -> ?priv:bool -> ?inv:bool -> ?ghost_reg:Sreg.t -> tvsymbol list -> region list -> ity option -> itysymbol val restore_its : tysymbol -> itysymbol (** raises [Not_found] if the argument is not a its_ts *) val ity_var : tvsymbol -> ity val ity_pur : tysymbol -> ity list -> ity val ity_app : itysymbol -> ity list -> region list -> ity val ity_app_fresh : itysymbol -> ity list -> ity val ty_of_ity : ity -> ty (** all aliases expanded, all regions removed *) val ity_of_ty : ty -> ity (** replaces every [Tyapp] with [Itypur] *) (** {2 Generic traversal functions} *) val ity_map : (ity -> ity) -> ity -> ity val ity_fold : ('a -> ity -> 'a) -> 'a -> ity -> 'a val ity_all : (ity -> bool) -> ity -> bool val ity_any : (ity -> bool) -> ity -> bool (** {2 Traversal functions on type symbols} *) val ity_s_fold : ('a -> itysymbol -> 'a) -> ('a -> tysymbol -> 'a) -> 'a -> ity -> 'a val ity_s_all : (itysymbol -> bool) -> (tysymbol -> bool) -> ity -> bool val ity_s_any : (itysymbol -> bool) -> (tysymbol -> bool) -> ity -> bool val its_clone : Theory.symbol_map -> itysymbol Mits.t * region Mreg.t val ity_closed : ity -> bool val ity_immutable : ity -> bool val ity_has_inv : ity -> bool (* these functions attend the sub-regions *) val reg_fold : (region -> 'a -> 'a) -> varset -> 'a -> 'a val reg_any : (region -> bool) -> varset -> bool val reg_all : (region -> bool) -> varset -> bool val reg_iter : (region -> unit) -> varset -> unit val reg_occurs : region -> varset -> bool (* detect non-ghost regions *) val ity_nonghost_reg : Sreg.t -> ity -> Sreg.t val lookup_nonghost_reg : Sreg.t -> ity -> bool (** {2 Built-in types} *) val ts_unit : tysymbol (** the same as [Ty.ts_tuple 0] *) val ty_unit : ty val ity_int : ity val ity_real : ity val ity_bool : ity val ity_unit : ity type ity_subst = private { ity_subst_tv : ity Mtv.t; ity_subst_reg : region Mreg.t; } exception RegionMismatch of region * region * ity_subst exception TypeMismatch of ity * ity * ity_subst val ity_subst_empty : ity_subst val ity_match : ity_subst -> ity -> ity -> ity_subst val reg_match : ity_subst -> region -> region -> ity_subst val ity_equal_check : ity -> ity -> unit val reg_equal_check : region -> region -> unit val ity_full_inst : ity_subst -> ity -> ity val reg_full_inst : ity_subst -> region -> region (** {2 Varset manipulation} *) val vars_empty : varset val vars_union : varset -> varset -> varset val vars_freeze : varset -> ity_subst (** {2 Exception symbols} *) type xsymbol = private { xs_name : ident; xs_ity : ity; (** closed and immutable *) } val xs_equal : xsymbol -> xsymbol -> bool exception PolymorphicException of ident * ity exception MutableException of ident * ity val create_xsymbol : preid -> ity -> xsymbol module Mexn: Extmap.S with type key = xsymbol module Sexn: Extset.S with module M = Mexn (** {2 Effects} *) type effect = private { eff_writes : Sreg.t; eff_raises : Sexn.t; eff_ghostw : Sreg.t; (** ghost writes *) eff_ghostx : Sexn.t; (** ghost raises *) (* if r1 -> Some r2 then r1 appears in ty(r2) *) eff_resets : region option Mreg.t; eff_compar : Stv.t; eff_diverg : bool; } val eff_empty : effect val eff_equal : effect -> effect -> bool val eff_union : effect -> effect -> effect val eff_ghostify : bool -> effect -> effect val eff_write : effect -> ?ghost:bool -> region -> effect val eff_raise : effect -> ?ghost:bool -> xsymbol -> effect val eff_reset : effect -> region -> effect val eff_refresh : effect -> region -> region -> effect val eff_assign : effect -> ?ghost:bool -> region -> ity -> effect val eff_compare : effect -> tvsymbol -> effect val eff_diverge : effect -> effect val eff_remove_raise : effect -> xsymbol -> effect val eff_stale_region : effect -> varset -> bool exception IllegalAlias of region exception IllegalCompar of tvsymbol * ity exception GhostDiverg val eff_full_inst : ity_subst -> effect -> effect val eff_is_empty : effect -> bool (** {2 Specification} *) type pre = term (** precondition: pre_fmla *) type post = term (** postcondition: eps result . post_fmla *) type xpost = post Mexn.t (** exceptional postconditions *) type variant = term * lsymbol option (** tau * (tau -> tau -> prop) *) val create_post : vsymbol -> term -> post val open_post : post -> vsymbol * term val check_post : ty -> post -> unit type spec = { c_pre : pre; c_post : post; c_xpost : xpost; c_effect : effect; c_variant : variant list; c_letrec : int; } (** {2 Program variables} *) type pvsymbol = private { pv_vs : vsymbol; pv_ity : ity; pv_ghost : bool; } module Mpv : Extmap.S with type key = pvsymbol module Spv : Extset.S with module M = Mpv module Hpv : Exthtbl.S with type key = pvsymbol module Wpv : Weakhtbl.S with type key = pvsymbol val pv_equal : pvsymbol -> pvsymbol -> bool val create_pvsymbol : preid -> ?ghost:bool -> ity -> pvsymbol val restore_pv : vsymbol -> pvsymbol (** raises [Not_found] if the argument is not a [pv_vs] *) val t_pvset : Spv.t -> term -> Spv.t (** raises [Not_found] if the term contains non-pv variables *) val spec_pvset : Spv.t -> spec -> Spv.t (** raises [Not_found] if the spec contains non-pv variables *) (** {2 Program types} *) type vty = | VTvalue of ity | VTarrow of aty and aty = private { aty_args : pvsymbol list; aty_result : vty; aty_spec : spec; } exception UnboundException of xsymbol (** every raised exception must have a postcondition in [spec.c_xpost] *) val vty_arrow : pvsymbol list -> ?spec:spec -> vty -> aty val aty_pvset : aty -> Spv.t (** raises [Not_found] if the spec contains non-pv variables *) val aty_vars_match : ity_subst -> aty -> ity list -> ity -> ity_subst (** this only compares the types of arguments and results, and ignores the spec. In other words, only the type variables and regions in [aty_vars aty] are matched. The caller should supply a "freezing" substitution that covers all external type variables and regions. *) val aty_full_inst : ity_subst -> aty -> aty (** the substitution must cover not only [aty_vars aty] but also every type variable and every region in [aty_spec] *) val aty_filter : ?ghost:bool -> Spv.t -> aty -> aty (** remove from the given arrow every effect that is covered neither by the arrow's arguments nor by the given pvset *) val aty_app : aty -> pvsymbol -> spec * bool * vty (** apply a function specification to a variable argument *) val spec_check : ?full_xpost:bool -> spec -> vty -> unit (** verify that the spec corresponds to the result type *) val ity_of_vty : vty -> ity val ty_of_vty : vty -> ty (** convert arrows to the unit type *) val aty_vars : aty -> varset val vty_vars : vty -> varset (** collect the type variables and regions in arguments and values, but ignores the spec *) why3-0.88.3/src/whyml/mlw_wp.ml0000664000175100017510000024517313225666037017056 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Stdlib open Ident open Ty open Term open Decl open Theory open Mlw_ty open Mlw_ty.T open Mlw_expr open Mlw_decl let debug = Debug.register_info_flag "whyml_wp" ~desc:"Print@ details@ of@ verification@ conditions@ generation." let no_track = Debug.register_flag "wp_no_track" ~desc:"Do@ not@ remove@ redundant@ type@ invariant@ conditions@ from@ VCs." let no_eval = Debug.register_flag "wp_no_eval" ~desc:"Do@ not@ simplify@ pattern@ matching@ on@ record@ datatypes@ in@ VCs." let lemma_label = Ident.create_label "why3:lemma" (** Marks *) let fresh_mark () = create_vsymbol (id_fresh "'mark") ty_mark let fs_at = let ty = ty_var (create_tvsymbol (id_fresh "a")) in create_lsymbol (id_fresh "at") [ty; ty_mark] (Some ty) let fs_old = let ty = ty_var (create_tvsymbol (id_fresh "a")) in create_lsymbol (id_fresh "old") [ty] (Some ty) let mark_theory = let uc = create_theory ~path:["why3";"Mark"] (id_fresh "Mark") in let uc = add_ty_decl uc ts_mark in close_theory uc let th_mark_at = let uc = create_theory (id_fresh "WP builtins: at") in let uc = use_export uc mark_theory in let uc = add_param_decl uc fs_at in close_theory uc let th_mark_old = let uc = create_theory (id_fresh "WP builtins: old") in let uc = use_export uc th_mark_at in let uc = add_param_decl uc fs_old in close_theory uc let fs_now = create_lsymbol (id_fresh "%now") [] (Some ty_mark) let t_now = fs_app fs_now [] ty_mark let e_now = e_ghost (e_lapp fs_now [] (ity_pur ts_mark [])) (* [vs_old] appears in the postconditions given to the core API, which expects every vsymbol to be a pure part of a pvsymbol *) let vs_old = pv_old.pv_vs let t_old = t_var vs_old let t_at_old t = t_app fs_at [t; t_old] t.t_ty let ls_absurd = create_lsymbol (id_fresh "absurd") [] None let t_absurd = t_label_add Split_goal.stop_split (ps_app ls_absurd []) let mk_t_if f = t_if f t_bool_true t_bool_false let to_term t = if t.t_ty = None then mk_t_if t else t (* any vs in post/xpost is either a pvsymbol or a fresh mark *) let ity_of_vs vs = if Ty.ty_equal vs.vs_ty ty_mark then ity_mark else (restore_pv vs).pv_ity (* replace every occurrence of [old(t)] with [at(t,'old)] *) let rec remove_old f = match f.t_node with | Tapp (ls,[t]) when ls_equal ls fs_old -> t_at_old (remove_old t) | _ -> t_map remove_old f (* replace every occurrence of [at(t,'now)] with [t] *) let rec remove_at f = match f.t_node with | Tapp (ls, [t; { t_node = Tapp (fs,[]) }]) when ls_equal ls fs_at && ls_equal fs fs_now -> remove_at t | _ -> t_map remove_at f (* replace [at(t,'old)] with [at(t,lab)] everywhere in formula [f] *) let old_mark lab t = t_subst_single vs_old (t_var lab) t (* replace [at(t,lab)] with [at(t,'now)] everywhere in formula [f] *) let erase_mark lab t = t_subst_single lab t_now t (* retreat to the point of the current postcondition's ['old] *) let backstep fn q xq = let lab = fresh_mark () in let f = fn (old_mark lab q) (Mexn.map (old_mark lab) xq) in erase_mark lab f (** WP utilities *) let default_exn_post xs _ = let vs = create_vsymbol (id_fresh "result") (ty_of_ity xs.xs_ity) in create_post vs t_true let default_post vty ef = let vs = create_vsymbol (id_fresh "result") (ty_of_vty vty) in create_post vs t_true, Mexn.mapi default_exn_post ef.eff_raises let wp_label ?(override=false) e f = let loc = if e.e_loc = None then f.t_loc else if f.t_loc = None then e.e_loc else if override then e.e_loc else f.t_loc in let lab = Ident.Slab.union e.e_label f.t_label in t_label ?loc lab f let expl_pre = Ident.create_label "expl:precondition" let expl_post = Ident.create_label "expl:postcondition" let expl_xpost = Ident.create_label "expl:exceptional postcondition" let expl_assume = Ident.create_label "expl:assumption" let expl_assert = Ident.create_label "expl:assertion" let expl_check = Ident.create_label "expl:check" let expl_absurd = Ident.create_label "expl:unreachable point" let expl_type_inv = Ident.create_label "expl:type invariant" let expl_loop_init = Ident.create_label "expl:loop invariant init" let expl_loop_keep = Ident.create_label "expl:loop invariant preservation" let expl_loopvar = Ident.create_label "expl:loop variant decrease" let expl_variant = Ident.create_label "expl:variant decrease" let lab_has_expl = Slab.exists (fun l -> Strings.has_prefix "expl:" l.lab_string) let rec wp_expl l f = if lab_has_expl f.t_label then f else match f.t_node with | _ when Slab.mem Split_goal.stop_split f.t_label -> t_label_add l f | Tbinop (Tand,f1,f2) -> t_label_copy f (t_and (wp_expl l f1) (wp_expl l f2)) | Teps _ -> t_label_add l f (* post-condition, push down later *) | _ -> f let wp_and ~sym f1 f2 = if sym then t_and_simp f1 f2 else t_and_asym_simp f1 f2 let wp_ands ~sym fl = if sym then t_and_simp_l fl else t_and_asym_simp_l fl let wp_implies f1 f2 = t_implies_simp f1 f2 let wp_let v t f = t_let_close_simp v t f let wp_forall vl f = t_forall_close_simp vl [] f let is_equality_for v f = match f.t_node with | Tapp (ps, [{ t_node = Tvar u }; t]) when ls_equal ps ps_equ && vs_equal u v && t_v_occurs v t = 0 -> Some t | _ -> None let wp_forall_post v p f = (* we optimize for the case when a postcondition is of the form (... /\ result = t /\ ...) *) let rec down p = match p.t_node with | Tbinop (Tand,l,r) -> let t, l, r = let t, l = down l in if t <> None then t, l, r else let t, r = down r in t, l, r in t, if t = None then p else t_label_copy p (t_and_simp l r) | _ -> let t = is_equality_for v p in t, if t = None then p else t_true in if ty_equal v.vs_ty ty_unit then t_subst_single v t_void (wp_implies p f) else match down p with | Some t, p -> wp_let v t (wp_implies p f) | _ -> wp_forall [v] (wp_implies p f) let t_and_subst v t1 t2 = (* if [t1] defines variable [v], return [t2] with [v] replaced by its definition. Otherwise return [t1 /\ t2] *) match is_equality_for v t1 with | Some def -> t_subst_single v def t2 | None -> t_and_simp t1 t2 let t_implies_subst v t1 t2 = (* if [t1] defines variable [v], return [t2] with [v] replaced by its definition. Otherwise return [t1 -> t2] *) match is_equality_for v t1 with | Some def -> t_subst_single v def t2 | None -> t_implies_simp t1 t2 let regs_of_writes eff = Sreg.union eff.eff_writes eff.eff_ghostw let exns_of_raises eff = Sexn.union eff.eff_raises eff.eff_ghostx let open_post q = let v, f = open_post q in v, Slab.fold wp_expl q.t_label f let open_unit_post q = let v, q = open_post q in t_subst_single v t_void q let create_unit_post = let v = create_vsymbol (id_fresh "void") ty_unit in fun q -> create_post v q let vs_result e = create_vsymbol (id_fresh ?loc:e.e_loc "result") (ty_of_vty e.e_vty) (** WP state *) type wp_env = { prog_known : Mlw_decl.known_map; pure_known : Decl.known_map; global_env : Env.env; ps_int_le : Term.lsymbol; ps_int_ge : Term.lsymbol; ps_int_lt : Term.lsymbol; ps_int_gt : Term.lsymbol; fs_int_pl : Term.lsymbol; fs_int_mn : Term.lsymbol; letrec_var : variant list Mint.t; } let decrease_alg ?loc env old_t t = let oty = t_type old_t in let nty = t_type t in let quit () = Loc.errorm ?loc "no default order for %a" Pretty.print_term t in let ts = match oty with { ty_node = Tyapp (ts,_) } -> ts | _ -> quit () in let csl = Decl.find_constructors env.pure_known ts in if csl = [] then quit (); let sbs = ty_match Mtv.empty (ty_app ts (List.map ty_var ts.ts_args)) oty in let add_arg fty acc = let fty = ty_inst sbs fty in if ty_equal fty nty then let vs = create_vsymbol (id_fresh "f") nty in pat_var vs, t_or_simp (t_equ (t_var vs) t) acc else pat_wild fty, acc in let add_cs (cs,_) = let pl, f = Lists.map_fold_right add_arg cs.ls_args t_false in t_close_branch (pat_app cs pl oty) f in t_case old_t (List.map add_cs csl) let decrease_def ?loc env old_t t = if ty_equal (t_type old_t) ty_int && ty_equal (t_type t) ty_int then t_and (ps_app env.ps_int_le [t_nat_const 0;old_t]) (ps_app env.ps_int_lt [t;old_t]) else decrease_alg ?loc env old_t t let decrease loc lab env olds varl = let rec decr olds varl = match olds, varl with | (old_t, Some old_r)::olds, (t, Some r)::varl when oty_equal old_t.t_ty t.t_ty && ls_equal old_r r -> let dt = ps_app r [t; old_t] in t_or_simp dt (t_and_simp (t_equ old_t t) (decr olds varl)) | (old_t, None)::olds, (t, None)::varl when oty_equal old_t.t_ty t.t_ty -> let dt = decrease_def ?loc env old_t t in t_or_simp dt (t_and_simp (t_equ old_t t) (decr olds varl)) | (old_t, None)::_, (t, None)::_ -> decrease_def ?loc env old_t t | _ -> t_false in t_label ?loc lab (decr olds varl) let expl_variant = Slab.add Split_goal.stop_split (Slab.singleton expl_variant) let expl_loopvar = Slab.add Split_goal.stop_split (Slab.singleton expl_loopvar) (** Reconstruct pure values after writes *) (* The counter-example model related data needed for creating new variable. *) type model_data = { md_append_to_model_trace : string; (* The string that will be appended to the end of "model_trace:" label. It is used to specify the reason why the variable is created. *) md_loc : Loc.position option; (* The location of the new variable. *) md_context_labels : Slab.t option; (* The labels of an element that represents the context in that the variable is created. Used in SPARK branch - the SPARK locations are kept in labels and when a new variable is created, these location labels are copied from md_context_labels. *) } let create_model_data ?loc ?context_labels append_to_model_trace = (* Creates new counter-example model related data. @param loc : the location of the new variable @param context_labels : The labels of an element that represents the context in that the variable is created. Used in SPARK branch - the SPARK locations are kept in labels and when a new variable is created, these location labels are copied from md_context_labels. @param append_to_model_trace : The string that will be appended to the end of "model_trace:" label. It is used to specify the reason why the variable is created. *) { md_append_to_model_trace = append_to_model_trace; md_loc = loc; md_context_labels = context_labels; } let create_model_data_opt ~loc ?context_labels append_to_model_trace = match loc with | None -> None | Some loc -> Some (create_model_data ~loc ?context_labels append_to_model_trace) let mk_var id ty md = let new_labels, loc = match md with | None -> (* If there is no model data remove model labels (prevents counter-example projections of this variable, displaying this variable in counterexample, ...) *) let new_labels = Ident.remove_model_labels ~labels:id.id_label in (new_labels, None) | Some md -> begin (append_to_model_trace_label ~labels:id.id_label ~to_append:("@"^md.md_append_to_model_trace), md.md_loc) end in create_vsymbol (id_fresh ~label:new_labels ?loc id.id_string) ty (* replace "contemporary" variables with fresh ones *) let rec subst_at_now now mvs t = match t.t_node with | Tvar vs when now -> begin try t_var (Mvs.find vs mvs) with Not_found -> t end | Tapp (ls, _) when ls_equal ls fs_old -> assert false | Tapp (ls, [_; mark]) when ls_equal ls fs_at -> let now = match mark.t_node with | Tvar vs when vs_equal vs vs_old -> assert false | Tapp (ls,[]) when ls_equal ls fs_now -> true | _ -> false in t_map (subst_at_now now mvs) t | Tlet _ | Tcase _ | Teps _ | Tquant _ -> (* do not open unless necessary *) let mvs = Mvs.set_inter mvs (t_vars t) in if Mvs.is_empty mvs then t else t_map (subst_at_now now mvs) t | _ -> t_map (subst_at_now now mvs) t (* generic expansion of an algebraic type value *) let analyze_var fn_down fn_join lkm km vs ity = let var_of_fd fd = create_vsymbol (id_fresh "y") (ty_of_ity fd.fd_ity) in let branch (cs,fdl) = let vl = List.map var_of_fd fdl in let pat = pat_app cs (List.map pat_var vl) vs.vs_ty in let t = fn_join cs (List.map2 fn_down vl fdl) vs.vs_ty in t_close_branch pat t in let csl = Mlw_decl.inst_constructors lkm km ity in t_case_simp (t_var vs) (List.map branch csl) (* given a map of modified regions, construct the updated value of [vs] *) let update_var env (mreg : vsymbol Mreg.t) vs = let rec update vs { fd_ity = ity; fd_mut = mut } = (* are we a mutable variable? *) let get_vs r = Mreg.find_def vs r mreg in let vs = Opt.fold (fun _ -> get_vs) vs mut in (* should we update our value further? *) let check_reg r _ = reg_occurs r ity.ity_vars in if ity_immutable ity || not (Mreg.exists check_reg mreg) then t_var vs else analyze_var update fs_app env.pure_known env.prog_known vs ity in update vs { fd_ity = ity_of_vs vs; fd_ghost = false; fd_mut = None } (* given a map of modified regions, update every affected variable in [f] *) let update_term env (mreg : vsymbol Mreg.t) f = (* [vars] : modified variable -> updated value *) let update vs _ = match update_var env mreg vs with | { t_node = Tvar nv } when vs_equal vs nv -> None | t -> Some t in let vars = Mvs.mapi_filter update (t_vars f) in (* [vv'] : modified variable -> fresh variable *) let new_var vs _ = mk_var vs.vs_name vs.vs_ty (create_model_data_opt ~loc:f.t_loc ~context_labels:f.t_label "model_quantify") in let vv' = Mvs.mapi new_var vars in (* update modified variables *) let update v t f = wp_let (Mvs.find v vv') t f in Mvs.fold update vars (subst_at_now true vv' f) let get_single_region_of_var vs = match (ity_of_vs vs).ity_node with | Ityapp (_,_,[r]) -> Some r | _ -> None (* look for a variable with a single region equal to [reg] *) let var_of_region reg f = let test acc vs = match get_single_region_of_var vs with | Some r when reg_equal r reg -> Some vs | _ -> acc in t_v_fold test None f let quantify md env regs f = (* mreg : modified region -> vs *) let get_var reg () = let ty = ty_of_ity reg.reg_ity in let id = match var_of_region reg f with | Some vs -> vs.vs_name | None -> reg.reg_name in let md = match md.md_loc with | None -> ( match id.id_loc with | None -> None | Some l -> Some (create_model_data ~loc:l ~context_labels:id.id_label md.md_append_to_model_trace) ) | _ -> Some md in mk_var id ty md in let mreg = Mreg.mapi get_var regs in (* quantify over the modified resions *) let f = update_term env mreg f in wp_forall (List.rev (Mreg.values mreg)) f (** Invariants *) let get_invariant km t = let ty = t_type t in let ts = match ty.ty_node with | Tyapp (ts,_) -> ts | _ -> assert false in let rec find_td = function | (its,_,inv) :: _ when ts_equal ts its.its_ts -> inv | _ :: tdl -> find_td tdl | [] -> assert false in let pd = Mid.find ts.ts_name km in let inv = match pd.Mlw_decl.pd_node with | Mlw_decl.PDdata tdl -> find_td tdl | _ -> assert false in let sbs = Ty.ty_match Mtv.empty (t_type inv) ty in let u, p = open_post (t_ty_subst sbs Mvs.empty inv) in wp_expl expl_type_inv (t_subst_single u t p) let ps_inv = Term.create_psymbol (id_fresh "inv") [ty_var (create_tvsymbol (id_fresh "a"))] let full_invariant lkm km vs ity = let rec update vs { fd_ity = ity } = if not (ity_has_inv ity) then t_true else (* what is our current invariant? *) let f = match ity.ity_node with | Ityapp (its,_,_) when its.its_inv -> if Debug.test_flag no_track then get_invariant km (t_var vs) else ps_app ps_inv [t_var vs] | _ -> t_true in (* what are our sub-invariants? *) let join _ fl _ = wp_ands ~sym:true fl in let g = analyze_var update join lkm km vs ity in (* put everything together *) wp_and ~sym:true f g in update vs { fd_ity = ity; fd_ghost = false; fd_mut = None } (** Value tracking *) type point = int type value = point list Mls.t (* constructor -> field list *) type state = { st_km : Mlw_decl.known_map; st_lkm : Decl.known_map; st_mem : value Hint.t; st_next : point ref; } (* dead code type names = point Mvs.t (* variable -> point *) type condition = lsymbol Mint.t (* point -> constructor *) type lesson = condition list Mint.t (* point -> conditions for invariant *) *) let empty_state lkm km = { st_km = km; st_lkm = lkm; st_mem = Hint.create 5; st_next = ref 0; } let next_point state = let res = !(state.st_next) in incr state.st_next; res let make_value state ty = let get_p _ = next_point state in let new_cs cs = List.map get_p cs.ls_args in let add_cs m (cs,_) = Mls.add cs (new_cs cs) m in let csl = match ty.ty_node with | Tyapp (ts,_) -> Decl.find_constructors state.st_lkm ts | _ -> [] in List.fold_left add_cs Mls.empty csl let match_point state ty p = try Hint.find state.st_mem p with Not_found -> let value = make_value state ty in if not (Mls.is_empty value) then Hint.replace state.st_mem p value; value let rec open_pattern state names value p pat = match pat.pat_node with | Pwild -> names | Pvar vs -> Mvs.add vs p names | Papp (cs,patl) -> let add_pat names p pat = let value = match_point state pat.pat_ty p in open_pattern state names value p pat in List.fold_left2 add_pat names (Mls.find cs value) patl | Por _ -> let add_vs vs s = Mvs.add vs (next_point state) s in Svs.fold add_vs pat.pat_vars names | Pas (pat,vs) -> open_pattern state (Mvs.add vs p names) value p pat let rec point_of_term state names t = match t.t_node with | Tvar vs -> Mvs.find vs names | Tapp (ls, tl) -> begin match Mid.find ls.ls_name state.st_lkm with | { Decl.d_node = Decl.Ddata tdl } -> let is_cs (cs,_) = ls_equal ls cs in let is_cs (_,csl) = List.exists is_cs csl in if List.exists is_cs tdl then point_of_constructor state names ls tl else point_of_projection state names ls (List.hd tl) | _ -> next_point state end | Tlet (t1, bt) -> let p1 = point_of_term state names t1 in let v, t2 = t_open_bound bt in let names = Mvs.add v p1 names in point_of_term state names t2 | Tcase (t1,[br]) -> let pat, t2 = t_open_branch br in let p1 = point_of_term state names t1 in let value = match_point state pat.pat_ty p1 in let names = open_pattern state names value p1 pat in point_of_term state names t2 | Tcase (t1,bl) -> (* we treat here the case of a value update: the value of each branch must be a distinct constructor *) let p = next_point state in let ty = Opt.get t.t_ty in let p1 = point_of_term state names t1 in let value = match_point state (Opt.get t1.t_ty) p1 in let branch acc br = let pat, t2 = t_open_branch br in let ls = match t2.t_node with | Tapp (ls,_) -> ls | _ -> raise Exit in let names = open_pattern state names value p1 pat in let p2 = point_of_term state names t2 in let v2 = match_point state ty p2 in Mls.add_new Exit ls (Mls.find_exn Exit ls v2) acc in begin try let value = List.fold_left branch Mls.empty bl in let value = Mls.set_union value (make_value state ty) in Hint.replace state.st_mem p value with Exit -> () end; p | Tconst _ | Tif _ | Teps _ -> next_point state | Tquant _ | Tbinop _ | Tnot _ | Ttrue | Tfalse -> assert false and point_of_constructor state names ls tl = let p = next_point state in let pl = List.map (point_of_term state names) tl in let value = make_value state (Opt.get ls.ls_value) in let value = Mls.add ls pl value in Hint.replace state.st_mem p value; p and point_of_projection state names ls t1 = let ty = Opt.get t1.t_ty in let csl = match ty.ty_node with | Tyapp (ts,_) -> Decl.find_constructors state.st_lkm ts | _ -> assert false in match csl with | [cs,pjl] -> let p1 = point_of_term state names t1 in let value = match_point state ty p1 in let rec find_p pjl pl = match pjl, pl with | Some pj::_, p::_ when ls_equal ls pj -> p | _::pjl, _::pl -> find_p pjl pl | _ -> assert false in find_p pjl (Mls.find cs value) | _ -> next_point state (* more than one, can't choose *) let rec track_values state names lesson cond f = match f.t_node with | Tapp (ls, [t1]) when ls_equal ls ps_inv -> let p1 = point_of_term state names t1 in let condl = Mint.find_def [] p1 lesson in let contains c1 c2 = Mint.submap (fun _ -> ls_equal) c2 c1 in if List.exists (contains cond) condl then lesson, t_label_copy f t_true else let good c = not (contains c cond) in let condl = List.filter good condl in let l = Mint.add p1 (cond::condl) lesson in l, t_label_copy f (get_invariant state.st_km t1) | _ when (Slab.mem keep_on_simp_label f.t_label) -> lesson, f | Tbinop (Timplies, f1, f2) -> let l, f1 = track_values state names lesson cond f1 in let _, f2 = track_values state names l cond f2 in lesson, t_label_copy f (t_implies_simp f1 f2) | Tbinop (Tand, f1, f2) -> let l, f1 = track_values state names lesson cond f1 in let l, f2 = track_values state names l cond f2 in l, t_label_copy f (t_and_simp f1 f2) | Tbinop ((Tor|Tiff) as o, f1, f2) -> let _, f1 = track_values state names lesson cond f1 in let _, f2 = track_values state names lesson cond f2 in lesson, t_label_copy f (t_binary_simp o f1 f2) | Tnot f1 -> let _, f1 = track_values state names lesson cond f1 in lesson, t_label_copy f (t_not_simp f1) | Tif (fc, f1, f2) -> let _, f1 = track_values state names lesson cond f1 in let _, f2 = track_values state names lesson cond f2 in lesson, t_label_copy f (t_if_simp fc f1 f2) | Tcase (t1, bl) -> let p1 = point_of_term state names t1 in let value = match_point state (Opt.get t1.t_ty) p1 in let is_pat_var = function | { pat_node = Pvar _ } -> true | _ -> false in let branch l br = let pat, f1, cb = t_open_branch_cb br in let learn, cond = match bl, pat.pat_node with | [_], _ -> true, cond (* one branch, can learn *) | _, Papp (cs, pl) when List.for_all is_pat_var pl -> (try true, Mint.add_new Exit p1 cs cond (* can learn *) with Exit -> false, cond) (* contradiction, cannot learn *) | _, _ -> false, cond (* complex pattern, will not learn *) in let names = open_pattern state names value p1 pat in let m, f1 = track_values state names lesson cond f1 in let l = if learn then m else l in l, cb pat f1 in let l, bl = Lists.map_fold_left branch lesson bl in l, t_label_copy f (t_case_simp t1 bl) | Tlet (t1, bf) -> let p1 = point_of_term state names t1 in let v, f1, cb = t_open_bound_cb bf in let names = Mvs.add v p1 names in let l, f1 = track_values state names lesson cond f1 in l, t_label_copy f (t_let_simp t1 (cb v f1)) | Tquant (q, qf) -> let vl, trl, f1, cb = t_open_quant_cb qf in let add_vs s vs = Mvs.add vs (next_point state) s in let names = List.fold_left add_vs names vl in let l, f1 = track_values state names lesson cond f1 in l, t_label_copy f (t_quant_simp q (cb vl trl f1)) | Tapp _ | Ttrue | Tfalse -> lesson, f | Tvar _ | Tconst _ | Teps _ -> assert false let track_values lkm km f = let state = empty_state lkm km in let _, f = track_values state Mvs.empty Mint.empty Mint.empty f in f (** Weakest preconditions *) let rec wp_expr env e q xq = let f = wp_desc env e q xq in if Debug.test_flag debug then begin Format.eprintf "@[--------@\n@[e = %a@]@\n" Mlw_pretty.print_expr e; Format.eprintf "@[q = %a@]@\n" Pretty.print_term q; Format.eprintf "@[f = %a@]@\n----@]@." Pretty.print_term f; end; f and wp_desc env e q xq = match e.e_node with | Elogic t -> let v, q = open_post q in let t = wp_label e t in (* NOTE: if you replace this t_subst by t_let or anything else, you must handle separately the case "let mark = 'now in ...", which requires 'now to be substituted for mark in q *) if ty_equal v.vs_ty ty_mark then t_subst_single v (to_term t) q else t_let_close_simp v (to_term t) q | Evalue pv -> let v, q = open_post q in let t = wp_label e (t_var pv.pv_vs) in t_subst_single v t q | Earrow _ -> let q = open_unit_post q in (* wp_label e *) q (* FIXME? *) | Elet ({ let_sym = LetV v; let_expr = e1 }, e2) when Opt.equal Loc.equal v.pv_vs.vs_name.id_loc e1.e_loc -> (* we push the label down, past the implicitly inserted "let" *) let w = wp_expr env (e_label_copy e e2) q xq in let q = create_post v.pv_vs w in wp_expr env e1 q xq | Elet ({ let_sym = LetV v; let_expr = e1 }, e2) -> let w = wp_expr env e2 q xq in let q = create_post v.pv_vs w in wp_label e (wp_expr env e1 q xq) | Elet ({ let_sym = LetA _; let_expr = e1 }, e2) -> let w = wp_expr env e2 q xq in let q = create_unit_post w in wp_label e (wp_expr env e1 q xq) | Erec (fdl, e1) -> let eff = match e1.e_vty with | VTarrow _ -> None | VTvalue _ -> Some e1.e_effect in let fr = wp_rec_defn ?eff env fdl in let fe = wp_expr env e1 q xq in let fr = wp_ands ~sym:true fr in wp_label e (wp_and ~sym:true fr fe) | Eif (e1, e2, e3) -> let res = vs_result e1 in let test = t_equ (t_var res) t_bool_true in (* if both branches are pure, do not split *) let w = let get_term e = match e.e_node with | Elogic t -> to_term t | Evalue v -> t_var v.pv_vs | _ -> raise Exit in try let r2 = wp_label e2 (get_term e2) in let r3 = wp_label e3 (get_term e3) in let v, q = open_post q in t_subst_single v (t_if_simp test r2 r3) q with Exit -> let w2 = wp_expr env e2 q xq in let w3 = wp_expr env e3 q xq in t_if_simp test w2 w3 in let q = create_post res w in wp_label e (wp_expr env e1 q xq) (* optimization for the particular case let _ = e1 in e2 *) | Ecase (e1, [{ ppat_pattern = { pat_node = Term.Pwild }}, e2]) -> let w = wp_expr env e2 q xq in let q = create_post (vs_result e1) w in wp_label e (wp_expr env e1 q xq) (* optimization for the particular case let () = e1 in e2 *) | Ecase (e1, [{ ppat_pattern = { pat_node = Term.Papp (cs,[]) }}, e2]) when ls_equal cs fs_void -> let w = wp_expr env e2 q xq in let q = create_unit_post w in wp_label e (wp_expr env e1 q xq) | Ecase (e1, bl) -> let res = vs_result e1 in let branch ({ ppat_pattern = pat }, e) = t_close_branch pat (wp_expr env e q xq) in let w = t_case_simp (t_var res) (List.map branch bl) in let q = create_post res w in wp_label e (wp_expr env e1 q xq) | Eghost e1 -> wp_label e (wp_expr env e1 q xq) | Eraise (xs, e1) -> let q = try Mexn.find xs xq with Not_found -> assert false in wp_label e (wp_expr env e1 q xq) | Etry (e1, bl) -> let branch (xs,v,e) acc = let w = wp_expr env e q xq in let q = create_post v.pv_vs w in Mexn.add xs q acc in let xq = List.fold_right branch bl xq in wp_label e (wp_expr env e1 q xq) | Eassert (Aassert, f) -> let q = open_unit_post q in let f = wp_expl expl_assert f in wp_and ~sym:false (wp_label e f) q | Eassert (Acheck, f) -> let q = open_unit_post q in let f = wp_expl expl_check f in wp_and ~sym:true (wp_label e f) q | Eassert (Aassume, f) -> let q = open_unit_post q in let f = wp_expl expl_assume f in wp_implies (wp_label e f) q | Eabsurd -> wp_label e (wp_expl expl_absurd t_absurd) | Eany spec -> let p = wp_label e (wp_expl expl_pre spec.c_pre) in let p = t_label ?loc:e.e_loc p.t_label p in (* TODO: propagate call labels into tyc.c_post *) let w = wp_abstract (create_model_data ?loc:e.e_loc "any") env spec.c_effect spec.c_post spec.c_xpost q xq in wp_and ~sym:false p w | Eapp (e1,_,spec) -> let p = wp_label e (wp_expl expl_pre spec.c_pre) in let p = t_label ?loc:e.e_loc p.t_label p in let d = if spec.c_letrec = 0 || spec.c_variant = [] then t_true else let olds = Mint.find_def [] spec.c_letrec env.letrec_var in if olds = [] then t_true (* we are out of letrec *) else decrease e.e_loc expl_variant env olds spec.c_variant in (* TODO: propagate call labels into tyc.c_post *) let md = create_model_data ?loc:e1.e_loc ~context_labels:e1.e_label "call" in let w = wp_abstract md env spec.c_effect spec.c_post spec.c_xpost q xq in let w = wp_and ~sym:true d (wp_and ~sym:false p w) in let q = create_unit_post w in wp_expr env e1 q xq (* FIXME? should (wp_label e) rather be here? *) | Eabstr (e1, spec) -> let p = wp_label e (wp_expl expl_pre spec.c_pre) in (* every exception uncovered in spec is passed to xq *) let c_xq = Mexn.set_union spec.c_xpost xq in let w1 = backstep (wp_expr env e1) spec.c_post c_xq in (* so that now we don't need to prove these exceptions again *) let lost = Mexn.set_diff (exns_of_raises e1.e_effect) spec.c_xpost in let c_eff = Sexn.fold_left eff_remove_raise e1.e_effect lost in let md = create_model_data ?loc:e1.e_loc ~context_labels:e1.e_label "abstract" in let w2 = wp_abstract md env c_eff spec.c_post spec.c_xpost q xq in wp_and ~sym:false p (wp_and ~sym:true (wp_label e w1) w2) | Eassign (pl, e1, reg, pv) -> (* if we create an intermediate variable npv to represent e1 in the post-condition of the assign, the call to wp_abstract will have to update this variable separately (in addition to all existing variables in q that require update), creating duplication. To avoid it, we try to detect whether the value of e1 can be represented by an existing pure term that can be reused in the post-condition. *) let rec get_term d = match d.e_node with | Eghost e | Elet (_,e) | Erec (_,e) -> get_term e | Evalue v -> vs_result e1, t_var v.pv_vs | Elogic t -> vs_result e1, t | _ -> let ity = ity_of_expr e1 in let id = id_fresh ?loc:e1.e_loc "o" in (* must be a pvsymbol or restore_pv will fail *) let npv = create_pvsymbol id ~ghost:e1.e_ghost ity in npv.pv_vs, t_var npv.pv_vs in let res, t = get_term e1 in let t = fs_app pl.pl_ls [t] pv.pv_vs.vs_ty in let c_q = create_unit_post (t_equ t (t_var pv.pv_vs)) in let eff = eff_write eff_empty reg in let md = create_model_data ?loc:e1.e_loc ~context_labels:e1.e_label "assign" in let w = wp_abstract md env eff c_q Mexn.empty q xq in let q = create_post res w in wp_label e (wp_expr env e1 q xq) | Eloop (inv, varl, e1) -> (* TODO: what do we do about well-foundness? *) let i = wp_expl expl_loop_keep inv in let olds = List.map (fun (t,r) -> t_at_old t , r) varl in let i = if varl = [] then i else let d = decrease e.e_loc expl_loopvar env olds varl in wp_and ~sym:true i d in let q = create_unit_post i in let w = backstep (wp_expr env e1) q xq in let regs = regs_of_writes e1.e_effect in let md = create_model_data ?loc:e1.e_loc ~context_labels:e1.e_label "loop" in let w = quantify md env regs (wp_implies inv w) in let i = wp_expl expl_loop_init inv in wp_label e (wp_and ~sym:true i w) | Efor ({pv_vs = x}, ({pv_vs = v1}, d, {pv_vs = v2}), inv, e1) -> (* wp(for x = v1 to v2 do inv { I(x) } e1, Q, R) = v1 > v2 -> Q and v1 <= v2 -> I(v1) and forall S. forall i. v1 <= i <= v2 -> I(i) -> wp(e1, I(i+1), R) and I(v2+1) -> Q *) let gt, le, incr = match d with | Mlw_expr.To -> env.ps_int_gt, env.ps_int_le, env.fs_int_pl | Mlw_expr.DownTo -> env.ps_int_lt, env.ps_int_ge, env.fs_int_mn in let one = t_nat_const 1 in let v1_gt_v2 = ps_app gt [t_var v1; t_var v2] in let v1_le_v2 = ps_app le [t_var v1; t_var v2] in let q = open_unit_post q in let wp_init = wp_expl expl_loop_init (t_subst_single x (t_var v1) inv) in let wp_step = let next = fs_app incr [t_var x; one] ty_int in let post = wp_expl expl_loop_keep (t_subst_single x next inv) in wp_expr env e1 (create_unit_post post) xq in let wp_last = let v2pl1 = fs_app incr [t_var v2; one] ty_int in wp_implies (t_subst_single x v2pl1 inv) q in let md = create_model_data ?loc:e1.e_loc ~context_labels:e1.e_label "loop" in let wp_good = wp_and ~sym:true wp_init (quantify md env (regs_of_writes e1.e_effect) (wp_and ~sym:true (wp_forall [x] (wp_implies (wp_and ~sym:true (ps_app le [t_var v1; t_var x]) (ps_app le [t_var x; t_var v2])) (wp_implies inv wp_step))) wp_last)) in let wp_full = wp_and ~sym:true (wp_implies v1_gt_v2 q) (wp_implies v1_le_v2 wp_good) in wp_label e wp_full and wp_abstract md env c_eff c_q c_xq q xq = let regs = regs_of_writes c_eff in let exns = exns_of_raises c_eff in let quantify_post c_q q = let v, f = open_post q in let c_v, c_f = open_post c_q in let c_f = t_subst_single c_v (t_var v) c_f in let f = wp_forall_post v c_f f in quantify md env regs f in let quantify_xpost _ c_xq xq = Some (quantify_post c_xq xq) in let proceed c_q c_xq = let f = quantify_post c_q q in (* every xs in exns is guaranteed to be in c_xq and xq *) assert (Mexn.set_submap exns xq); assert (Mexn.set_submap exns c_xq); let xq = Mexn.set_inter xq exns in let c_xq = Mexn.set_inter c_xq exns in let mexn = Mexn.inter quantify_xpost c_xq xq in (* FIXME? This wp_ands is asymmetric in Pgm_wp *) wp_ands ~sym:true (f :: Mexn.values mexn) in backstep proceed c_q c_xq and wp_fun_regs ps l = (* regions to refresh at the top of function WP *) let add_arg = let seen = ref Sreg.empty in fun sbs pv -> (* we only need to "havoc" the regions that occur twice in [l.l_args]. If a region in an argument is shared with the context, then is it already frozen in [ps.ps_subst]. If a region in an argument is not shared at all, the last [wp_forall] over [args] will be enough. *) let rec down sbs ity = let rl = match ity.ity_node with | Ityapp (_,_,rl) -> rl | _ -> [] in ity_fold down (List.fold_left add_reg sbs rl) ity and add_reg sbs r = if Sreg.mem r !seen then reg_match sbs r r else (seen := Sreg.add r !seen; down sbs r.reg_ity) in down sbs pv.pv_ity in let sbs = List.fold_left add_arg ps.ps_subst l.l_args in Mreg.map (fun _ -> ()) sbs.ity_subst_reg and wp_fun_defn ?eff env { fun_ps = ps ; fun_lambda = l } = let lab = fresh_mark () and c = l.l_spec in let args = List.map (fun pv -> pv.pv_vs) l.l_args in let env = if c.c_letrec = 0 || c.c_variant = [] then env else let lab = t_var lab in let t_at_lab (t,r) = t_app fs_at [t; lab] t.t_ty , r in let tl = List.map t_at_lab c.c_variant in let lrv = Mint.add c.c_letrec tl env.letrec_var in { env with letrec_var = lrv } in let q = old_mark lab (wp_expl expl_post c.c_post) in let conv p = old_mark lab (wp_expl expl_xpost p) in let f = wp_expr env l.l_expr q (Mexn.map conv c.c_xpost) in let f = wp_implies c.c_pre (erase_mark lab f) in let md = create_model_data "init" in let keep_reg eff r = Sreg.mem r eff.eff_writes || Sreg.mem r eff.eff_ghostw || (* the test below is probably useless, since the surface language does not allow a function argument to be aliased with the context *) List.exists (fun v -> reg_occurs r v.pv_ity.ity_vars) l.l_args in let regs = wp_fun_regs ps l in let regs = match eff with | None -> regs | Some e -> Sreg.filter (keep_reg e) regs in wp_forall args (quantify md env regs f) and wp_rec_defn ?eff env fdl = List.map (wp_fun_defn ?eff env) fdl (*** let bool_to_prop env f = let ts_bool = find_ts ~pure:true env "bool" in let ls_andb = find_ls ~pure:true env "andb" in let ls_orb = find_ls ~pure:true env "orb" in let ls_notb = find_ls ~pure:true env "notb" in let ls_True = find_ls ~pure:true env "True" in let ls_False = find_ls ~pure:true env "False" in let t_True = fs_app ls_True [] (ty_app ts_bool []) in let is_bool ls = ls_equal ls ls_True || ls_equal ls ls_False in let rec t_iff_bool f1 f2 = match f1.t_node, f2.t_node with | Tnot f1, _ -> t_not_simp (t_iff_bool f1 f2) | _, Tnot f2 -> t_not_simp (t_iff_bool f1 f2) | Tapp (ps1, [t1; { t_node = Tapp (ls1, []) }]), Tapp (ps2, [t2; { t_node = Tapp (ls2, []) }]) when ls_equal ps1 ps_equ && ls_equal ps2 ps_equ && is_bool ls1 && is_bool ls2 -> if ls_equal ls1 ls2 then t_equ t1 t2 else t_neq t1 t2 | _ -> t_iff_simp f1 f2 in let rec t_btop t = t_label ?loc:t.t_loc t.t_label (* t_label_copy? *) (match t.t_node with | Tif (f,t1,t2) -> t_if_simp (f_btop f) (t_btop t1) (t_btop t2) | Tapp (ls, [t1;t2]) when ls_equal ls ls_andb -> t_and_simp (t_btop t1) (t_btop t2) | Tapp (ls, [t1;t2]) when ls_equal ls ls_orb -> t_or_simp (t_btop t1) (t_btop t2) | Tapp (ls, [t1]) when ls_equal ls ls_notb -> t_not_simp (t_btop t1) | Tapp (ls, []) when ls_equal ls ls_True -> t_true | Tapp (ls, []) when ls_equal ls ls_False -> t_false | _ -> t_equ_simp (f_btop t) t_True) and f_btop f = match f.t_node with | Tapp (ls, [{t_ty = Some {ty_node = Tyapp (ts, [])}} as l; r]) when ls_equal ls ps_equ && ts_equal ts ts_bool -> t_label ?loc:f.t_loc f.t_label (t_iff_bool (t_btop l) (t_btop r)) | _ -> t_map_simp f_btop f in f_btop f ***) (* replace t_absurd with t_false *) let rec unabsurd f = match f.t_node with | Tapp (ls, []) when ls_equal ls ls_absurd -> t_label_copy f (t_label_add keep_on_simp_label t_false) | _ -> t_map unabsurd f let add_wp_decl km name f uc = (* prepare a proposition symbol *) let s = "WP_parameter " ^ name.id_string in let label = let label = name.id_label in if lab_has_expl label then label else (* set a proper explanation *) let n = try let _, _, l = restore_path name in String.concat "." l with Not_found -> name.id_string in let lab = Ident.create_label ("expl:VC for " ^ n) in Slab.add lab label in let id = id_fresh ~label ?loc:name.id_loc s in let pr = create_prsymbol id in (* prepare the VC formula *) let f = remove_at f in (* let f = bool_to_prop uc f in *) let f = unabsurd f in (* get a known map with tuples added *) let lkm = Theory.get_known uc in (* remove redundant invariants *) let f = if Debug.test_flag no_track then f else track_values lkm km f in (* simplify f *) let f = if Debug.test_flag no_eval then f else (* do preliminary checks on f to spare eval_match any surprises *) let _lkm = Decl.known_add_decl lkm (create_prop_decl Pgoal pr f) in Eval_match.eval_match ~inline:Eval_match.inline_nonrec_linear lkm f in (* printf "wp: f=%a@." print_term f; *) let d = create_prop_decl Pgoal pr f in Theory.add_decl uc d let mk_env env km th = let th_int = Env.read_theory env ["int"] "Int" in { prog_known = km; pure_known = Theory.get_known th; global_env = env; ps_int_le = Theory.ns_find_ls th_int.th_export ["infix <="]; ps_int_ge = Theory.ns_find_ls th_int.th_export ["infix >="]; ps_int_lt = Theory.ns_find_ls th_int.th_export ["infix <"]; ps_int_gt = Theory.ns_find_ls th_int.th_export ["infix >"]; fs_int_pl = Theory.ns_find_ls th_int.th_export ["infix +"]; fs_int_mn = Theory.ns_find_ls th_int.th_export ["infix -"]; letrec_var = Mint.empty; } let wp_let env km th { let_sym = lv; let_expr = e } = let env = mk_env env km th in let q, xq = default_post e.e_vty e.e_effect in let f = wp_expr env e q xq in let f = wp_forall (Mvs.keys (t_vars f)) f in let id = match lv with | LetV pv -> pv.pv_vs.vs_name | LetA ps -> ps.ps_name in add_wp_decl km id f th let wp_rec env km th fdl = let env = mk_env env km th in let fl = wp_rec_defn env fdl in let add_one th d f = Debug.dprintf debug "wp %s = %a@\n----------------@." d.fun_ps.ps_name.id_string Pretty.print_term f; let f = wp_forall (Mvs.keys (t_vars f)) f in add_wp_decl km d.fun_ps.ps_name f th in List.fold_left2 add_one th fdl fl let wp_val _env _km th _lv = th (*****************************************************************************) (* Efficient Weakest Preconditions Following Leino, see http://research.microsoft.com/apps/pubs/default.aspx?id=70052 Roughly, the idea is the following. From a program expression e, we compute two formulas OK and N. Formula OK means ``the execution of e does not go wrong'' and formula N is an input-output relation between initial and final state of e's execution. Thus the weakest precondition of e is simply OK. N is involved in recursive computations, e.g. OK(fun x -> {p} e {q}) = forall x. p => OK(e) /\ (forall result. N(e) => q) And so on. In practice, this is a bit more involved, since execution of e may raise exceptions. So formula N comes with other formulas E(x), once for each exception x that is possibly raised by e. E(x) is the input-output relation that holds when exception x is raised. *) let fast_wp = Debug.register_flag "fast_wp" ~desc:"Efficient@ Weakest@ Preconditions.@ \ Work@ in@ progress,@ not@ ready@ for@ use." module Subst : sig (* A substitution, or state, represents the state at a given point in the program. It maps each region to the name that should be used to refer to the value of the region in the current state. *) type t (* the type of substitutions *) (* (* debugging code *) val print_state : Format.formatter -> t -> unit *) val init : Spv.t -> t (* the initial substitution for a program which mentions the given program variables *) val mark : t -> t val havoc : model_data option -> wp_env -> Sreg.t -> t -> t * term (* [havoc md env regions s] generates a new state in which all regions in [regions] are touched and all other regions unchanged. The result pair (s',f) is the new state [s'] and a formula [f] which defines the new values in [s'] with respect to the input state [s]. The parameter md can be used to pass information about new variables created in the new state. *) val extract_glue : wp_env -> Sreg.t -> t -> t -> term (* The formula [extract_glue env regs s1 s2] expresses what has not changed between [s1] and [s2], concerning program variables. The set of *) val merge : model_data option -> t -> t -> t -> t * term * term (* Given a start state and two states that parted from there, return a new "join" state and two formulas. The first formula links the first branch state with the join state, the second formula links the second branch state with the join state. The parameter of type model_data can be used to pass information about new variables created in the new state. *) val merge_l : model_data option -> t -> t list -> t * term list (* same as merge, but merges n states *) val save_label : vsymbol -> t -> t (* [save_label vs s] registers the state s as being the one that corresponds to label [vs]. This mapping is preserved even after calls to [havoc] and [merge], so that any labeled previous state can be obtained *) val term : t -> term -> term (* [term s f] apply the state [s] to the term [f]. If [f] contains labeled subterms, these will be appropriately dealt with. *) val add_pvar : model_data option -> pvsymbol -> t -> t (* [add_pvar md v s] adds the variable v to s, if it is mutable. The parameter md can be used to pass information about new variables created in the new state. *) end = struct type subst = { subst_regions : vsymbol Mreg.t; subst_vars : term Mvs.t; } (* a substitution or state knows the current variables to use for each region and each mutable program variable. *) type t = { now : subst; other : subst Mvs.t; reg_names : vsymbol Mreg.t; marked : bool; } (* the reg_names field is a simple name hint; a mapping reg |-> name means that [name] should be used as a base for new variables in region [reg]. This mapping is not required to be complete for regions. *) (* the actual state knows not only the current state, but also all labeled past states. *) let mk_var name ity md = mk_var name (ty_of_ity ity) md let fresh_var_from_region md hints reg = let name = try (Mreg.find reg hints).vs_name with Not_found -> reg.reg_name in mk_var name reg.reg_ity md let fresh_var_from_var md vs = mk_var vs.vs_name (ity_of_vs vs) md let is_simple_var = get_single_region_of_var let is_simple_pvar pv = is_simple_var pv.pv_vs let add_pvar md pv s = (* register a single program variable in the state. Use the variable itself as its first name; for subsequent havocs this will change. All regions belonging to this program variable are also added to the state, if not already there. Note that [add_pvar] doesn't really change the state, only adds new knowledge. *) (* for simple variables (1 variable = 1 mutable region), we do not introduce a new program variable each time, instead we use directly the [update_var] term. See also [havoc]. This is a heuristics which assumes that in this case, the program variable would be an overhead. In particular for simple references it is an important optimization. *) let ity = pv.pv_ity in if ity_immutable ity then s else let vs = pv.pv_vs in let is_simple = is_simple_pvar pv in let vars = Mvs.add vs (t_var vs) s.now.subst_vars in let reg_names = match is_simple with | None -> s.reg_names | Some r -> Mreg.add r vs s.reg_names in { other = s.other; reg_names = reg_names; marked = s.marked; now = { subst_vars = vars; subst_regions = reg_fold (fun r acc -> if Mreg.mem r acc then acc else Mreg.add r (fresh_var_from_region md reg_names r) acc) ity.ity_vars s.now.subst_regions; } } let empty = { other = Mvs.empty; reg_names = Mreg.empty; marked = false; now = { subst_regions = Mreg.empty; subst_vars = Mvs.empty; } } let mark s = { s with marked = true } (* (* debugging code *) let print_state fmt s = Format.fprintf fmt "{ "; Mvs.iter (fun _ v -> Format.printf " %a " Pretty.print_term v) s.now.subst_vars; Format.fprintf fmt " }" *) let init pvs = (* init the state with the given program variables. *) Spv.fold (add_pvar None) pvs empty let save_label vs sub = (* simply store the "now" substitution in the map with the given label *) { sub with other = Mvs.add vs sub.now sub.other } let pv_is_touched_by_regions vs regset = (* decide whether a (logic) variable [vs] changes value when [regset] has been touched. *) reg_any (fun reg -> Sreg.mem reg regset) (restore_pv vs).pv_ity.ity_vars let havoc md env regset s = (* introduce new variables for all regions, and all program variables for a region. *) let regs = Sreg.fold (fun reg acc -> Mreg.add reg (fresh_var_from_region md s.reg_names reg) acc) regset s.now.subst_regions in let touched_regs = Mreg.set_inter regs regset in (* We special case simple variables: no new variable is introduced for the * program variable, we directly use the "update_var" term. *) let vars, f = Mvs.fold (fun vs _ ((acc_vars, acc_f) as acc) -> if pv_is_touched_by_regions vs regset then begin let new_term = update_var env touched_regs vs in if is_simple_var vs <> None then Mvs.add vs new_term acc_vars, acc_f else let var = t_var (fresh_var_from_var md vs) in Mvs.add vs var acc_vars, t_and_simp (t_equ_simp var new_term) acc_f end else begin acc end) s.now.subst_vars (s.now.subst_vars, t_true) in { s with now = { subst_regions = regs; subst_vars = vars; }; marked = s.marked }, f let rec term s t = (* apply a substitution to a formula. This is straightforward, we only need to take care of labels that may point to previous states. We update the "current" substitution accordingly. *) match t.t_node with | Tvar vs -> (* We simply replace the program variable [vs] by its "now" value. *) begin try Mvs.find vs s.now.subst_vars with Not_found -> t end | Tapp (ls, _) when ls_equal ls fs_old -> assert false | Tapp (ls, [subterm; mark]) when ls_equal ls fs_at -> let label = match mark.t_node with | Tvar vs when vs_equal vs vs_old -> assert false | Tvar vs -> vs | _ -> assert false in let subst = try { s with now = Mvs.find label s.other } with Not_found -> (* all labels should have been registered in the "others" map *) assert false in t_map (term subst) subterm | Tlet _ | Tcase _ | Teps _ | Tquant _ -> (* do not open unless necessary *) let mvs = Mvs.set_inter s.now.subst_vars (t_vars t) in if Mvs.is_empty mvs then t else t_map (term s) t | _ -> t_map (term s) t let extract_glue env regions s1 s2 = (* we are only interested in "now" program vars *) let touched_regions = Mreg.filter (fun r _ -> Sreg.mem r regions) s2.now.subst_regions in let s1 = s1.now.subst_vars and s2 = s2.now.subst_vars in (* We iterate over the first state, because the second one potentially * contains more variables *) Mvs.fold (fun var old_f acc -> let f = Mvs.find var s2 in if t_equal f old_f || is_simple_var var <> None then acc else let new_value = update_var env touched_regions var in t_and_simp acc (t_equ_simp f new_value) ) s1 t_true let subst_inter a b = (* compute the intersection of two substitutions. *) { subst_vars = Mvs.set_inter a.subst_vars b.subst_vars; subst_regions = Mreg.set_inter a.subst_regions b.subst_regions; } let rec first_different base eq l = match l with | [] -> None | x :: xs -> if eq base x then first_different base eq xs else Some x let first_different_vars base l = first_different base vs_equal l let first_different_terms base l = first_different base t_equal l let merge_vars md marked base domain mapl = Mvs.fold (fun k _ (map , fl) -> let all_terms = List.map (fun m -> Mvs.find k m) mapl in match first_different_terms (Mvs.find k base) all_terms with | None -> Mvs.add k (List.hd all_terms) map, fl | Some new_ -> let new_ = if marked then t_var (fresh_var_from_var md k) else new_ in Mvs.add k new_ map, List.map2 (fun old f -> t_and_simp (t_equ new_ old) f) all_terms fl) domain (Mvs.empty, List.map (fun _ -> t_true) mapl) let merge_regs md names marked base domain mapl = Mreg.fold (fun k _ (map, fl) -> let all_vars = List.map (fun m -> Mreg.find k m) mapl in match first_different_vars (Mreg.find k base) all_vars with | None -> Mreg.add k (List.hd all_vars) map, fl | Some new_ -> let new_ = if marked then fresh_var_from_region md names k else new_ in Mreg.add k new_ map, List.map2 (fun old f -> if vs_equal old new_ then f else t_and_simp (t_equ (t_var new_) (t_var old)) f) all_vars fl) domain (Mreg.empty, List.map (fun _ -> t_true) mapl) let merge_l md base sl = match sl with | [] -> assert false | [s] -> s, [t_true] | _ -> (* we can work on the intersection of the domains, because relevant program variables/regions should be present in all of them. *) let domain = List.fold_left (fun acc s -> subst_inter acc s.now) base.now sl in let marked = List.exists (fun x -> x.marked) sl in let vars, fl1 = merge_vars md marked base.now.subst_vars domain.subst_vars (List.map (fun x -> x.now.subst_vars) sl) in let regs, fl2 = merge_regs md base.reg_names marked base.now.subst_regions domain.subst_regions (List.map (fun x -> x.now.subst_regions) sl) in { base with now = { subst_vars = vars; subst_regions = regs }; marked = marked; }, List.map2 t_and_simp fl1 fl2 let merge md base s1 s2 = let s, fl = merge_l md base [s1; s2] in match fl with | [f1; f2] -> s, f1, f2 | _ -> assert false end let fastwp_or_label = Ident.create_label "fastwp:or" let wp_or f1 f2 = t_label_add fastwp_or_label (t_or_simp f1 f2) let xs_result xs = create_vsymbol (id_fresh "result") (ty_of_ity xs.xs_ity) let result e = vs_result e, Mexn.mapi (fun xs _ -> xs_result xs) e.e_effect.eff_raises let is_vty_unit = function | VTvalue ity -> ity_equal ity ity_unit | VTarrow _ -> false (* The type for postconditions of expressions is the pair of the actual formula [ne], and a substitution [s] to be applied to [ne] to get the final postcondition. This allows delayed choice of names. *) type fwp_post = { ne : term; s : Subst.t } (* The type for postconditions in case of exceptions maps every exception to its postcondition. *) type fast_wp_exn_map = fwp_post Mexn.t (* The type for the result of fast weakest preconditions over expression e is a triple where - formula [ok] means ``e evaluates without any fault'' (whatever the execution flow is) - postcondition [post] relates the input state and the output state, and it contains the output state. - exceptional postconditions [exn] relate relates the input state and the output state, and contain the output state, in case an exception is raised. *) type fast_wp_result = { ok : term; post : fwp_post; exn : fast_wp_exn_map } (* Create a formula expressing that "n" implies "q", and for each exception "xn" implies "xq", quantifying over the result names. *) let wp_nimplies (n : term) (xn : fast_wp_exn_map) ((result, q), xq) = let f = wp_forall [result] (wp_implies n q) in assert (Mexn.cardinal xn = Mexn.cardinal xq); let x_implies _xs { ne = n } (xresult, q) f = t_and_simp f (wp_forall [xresult] (wp_implies n q)) in Mexn.fold2_inter x_implies xn xq f type res_type = vsymbol * vsymbol Mexn.t (* Take a [post], and place the postcondition [post.ne] in the poststate [post.s]. Also, open the postcondition and replace the result variable by [result_var]. In [post.s], [lab] is used to define the prestate. *) let apply_state_to_single_post glue lab expl result_var post = (* get the result var of the post *) let res, ne = open_post post.ne in (* substitute result_var and replace "old" label with new label *) let ne = t_subst_single res (t_var result_var) (old_mark lab ne) in (* apply the prestate = replace previously "old" variables *) { post with ne = t_and_simp glue (wp_expl expl (Subst.term post.s ne)) } (* Given normal and exceptional [post,xpost], each with its own poststate, place all [(x)post.ne] in the state defined by [(x)post.s].*) let apply_state_to_post glue lab result_vars post xpost = let result, xresult = result_vars in let f expl = apply_state_to_single_post glue lab expl in let a = f expl_post result post in let b = Mexn.mapi (fun ex post -> f expl_xpost (Mexn.find ex xresult) post) xpost in a, b let all_exns xmap_list = let add_elt k _ acc = Sexn.add k acc in List.fold_left (fun acc m -> Mexn.fold add_elt m acc) Sexn.empty xmap_list let iter_exns exns f = Sexn.fold (fun x acc -> let v = f x in Mexn.add x v acc) exns Mexn.empty let iter_all_exns xmap_list f = iter_exns (all_exns xmap_list) f let merge_opt md s opt_sl = (* merge a list of optional states: all present states are merged together, and the merged state is returned, together with the glue formula for all states. For absent states, the glue formula "false" is returned *) let l = List.filter (fun x -> x <> None) opt_sl in let l = List.map Opt.get l in let s, fl = Subst.merge_l md s l in let rec merge_lists acc opt_sl fl = match opt_sl, fl with | None :: rest, _ -> merge_lists (t_false :: acc) rest fl | Some _ :: rest, f :: fl -> merge_lists (f :: acc) rest fl | [], [] -> List.rev acc | _, _ -> assert false in s, merge_lists [] opt_sl fl let merge_opt_post_l md s opt_l = (* given a list of optional fwp_post states, merge them and return a tuple s, postl such that s is the merged state, and postl is the list of formulas that express each input fwp in the new state s.*) let opt_sl = List.map (fun x -> Opt.map (fun x -> x.s) x) opt_l in let s, fl = merge_opt md s opt_sl in s, List.map2 (fun opt f -> match opt with | None -> t_false | Some x -> t_and_simp f x.ne) opt_l fl let merge_opt_post md s opt1 opt2 = (* wrapper for merge_opt_post_l for two input states *) let s, fl = merge_opt_post_l md s [opt1;opt2] in match fl with | [f1;f2] -> s, f1, f2 | _ -> assert false let merge_opt_post_3 md s opt_p1 opt_p2 opt_p3 = (* wrapper for merge_opt_post for three input states *) let s, fl = merge_opt_post_l md s [opt_p1;opt_p2;opt_p3] in match fl with | [f1;f2;f3] -> s, f1, f2, f3 | _ -> assert false (* Input - a state s: Subst.t - names r = (result: vsymbol, xresult: vsymbol Mexn.t) - an expression e with: dom(xresult) = XS, the set of exceptions possibly raised by a, that is e.e_effect.eff_raises Output is a triple (OK, ((NE, s), EX)) where - formula OK means ``e evaluates without any fault'' (whatever the execution flow is) - formula NE means ``e terminates normally with final state s and output result'' - for each exception x, EX(x) = (fx,sx), where formula fx means ``e raises exception x, with final state sx and value xresult(x) in sx'' *) let rec fast_wp_expr (env : wp_env) (s : Subst.t) (r : res_type) (e : expr) : fast_wp_result = let res = fast_wp_desc env s r e in if Debug.test_flag debug then begin Format.eprintf "@[--------@\n@[e = %a@]@\n" Mlw_pretty.print_expr e; Format.eprintf "@[OK = %a@]@\n" Pretty.print_term res.ok; end; res (* TODO: Should we make sure the label of [e] is always propagated to the result of fast wp? In that case, should it be put on [ok], on [ne], on both? *) and fast_wp_desc (env : wp_env) (s : Subst.t) (r : res_type) (e : expr) : fast_wp_result = let result, xresult = r in match e.e_node with | Elogic t -> (* OK: true *) (* NE: result = t *) let t = wp_label e t in let t = Subst.term s (to_term t) in let ne = if is_vty_unit e.e_vty then t_true else t_equ (t_var result) t in { ok = t_true; post = { ne = ne; s = s }; exn = Mexn.empty } | Evalue v -> (* OK: true *) (* NE: result = v *) let va = wp_label e (t_var v.pv_vs) in let ne = Subst.term s (t_equ (t_var result) va) in { ok = t_true; post = { ne = ne; s = s }; exn = Mexn.empty } | Earrow _ -> (* OK: true *) (* NE: true *) { ok = t_true; post = { ne = t_true; s = s }; exn = Mexn.empty } | Eabsurd -> (* OK: false *) (* NE: false *) { ok = wp_label e (wp_expl expl_absurd t_absurd); post = { ne = t_false ; s = s }; exn = Mexn.empty } | Eassert (kind, f) -> (* assert: OK = f / NE = f *) (* check : OK = f / NE = true *) (* assume: OK = true / NE = f *) let f = wp_label e (Subst.term s f) in let expl = match kind with | Aassume -> expl_assume | Acheck -> expl_check | Aassert -> expl_assert in let ok = wp_expl expl (if kind = Aassume then t_true else f) in let ne = if kind = Acheck then t_true else f in { ok = ok; post = { ne = ne; s = s }; exn = Mexn.empty } | Eapp (e1, _, spec) -> (* OK: ok(e1) /\ (ne(e1) => spec.pre /\ variant) *) (* NE: ne(e1) /\ spec.post *) (* EX(x): ex(e1)(x) \/ (ne(e1) /\ spec.ex(x)) *) let arg_res = vs_result e1 in let wp1 = fast_wp_expr env s (arg_res, xresult) e1 in (* Next we have to deal with the call itself. *) let call_regs = regs_of_writes spec.c_effect in let pre_call_label = fresh_mark () in let state_before_call = Subst.save_label pre_call_label wp1.post.s in let pre = wp_label ~override:true e (wp_expl expl_pre (Subst.term state_before_call spec.c_pre)) in let md = create_model_data_opt ~loc:e1.e_loc ~context_labels:e1.e_label "call" in let state_after_call, call_glue = Subst.havoc md env call_regs state_before_call in let xpost = Mexn.map (fun p -> { s = state_after_call; ne = p }) spec.c_xpost in let call_post = { s = state_after_call; ne = spec.c_post } in let post, xpost = apply_state_to_post call_glue pre_call_label r call_post xpost in let variant = if spec.c_letrec = 0 || spec.c_variant = [] then t_true else let olds = Mint.find_def [] spec.c_letrec env.letrec_var in if olds = [] then t_true (* we are out of letrec *) else let news = List.map (fun (t,rel) -> Subst.term state_before_call t, rel) spec.c_variant in decrease e.e_loc expl_variant env olds news in let ok = t_and_simp wp1.ok (wp_implies wp1.post.ne (t_and_simp variant pre)) in let ne = wp_label e (t_and_simp wp1.post.ne post.ne) in let xne = iter_all_exns [xpost; wp1.exn] (fun ex -> let s, post1, post2 = merge_opt_post md s (Mexn.find_opt ex wp1.exn) (Mexn.find_opt ex xpost) in { s = s; ne = wp_label e (wp_or post1 (t_and_simp wp1.post.ne post2)) }) in { ok = ok; post = { ne = ne; s = state_after_call }; exn = xne } | Elet ({ let_sym = LetV v; let_expr = _ }, e2) (* ??? can we really ignore the first expression? *) when ty_equal v.pv_vs.vs_ty ty_mark -> let s = Subst.save_label v.pv_vs s in fast_wp_expr env s r e2 | Erec (fdl, e1) -> let fr = fast_wp_rec_defn env fdl in let wp1 = fast_wp_expr env s r e1 in let ok = wp_label e (wp_and ~sym:true (wp_ands ~sym:true fr) wp1.ok) in { ok = ok; post = wp1.post; exn = wp1.exn; } | Elet ({ let_sym = sym; let_expr = e1 }, e2) -> (* OK: ok(e1) /\ (ne(e1) => ok(e2)) *) (* NE: ne(e1) /\ ne(e2) *) (* EX(x): ex(e1)(x) \/ (ne(e1) /\ ex(e2)(x)) *) let vs = match sym with | LetV v -> v.pv_vs | LetA _ -> vs_result e1 in let e2 = if Opt.equal Loc.equal vs.vs_name.id_loc e1.e_loc then e_label_copy e e2 else e2 in let wp1 = fast_wp_expr env s (vs, xresult) e1 in let md = create_model_data_opt ~loc:e1.e_loc ~context_labels:e1.e_label "let" in let wp1posts = match sym with | LetV v -> Subst.add_pvar md v wp1.post.s | _ -> wp1.post.s in let wp2 = fast_wp_expr env wp1posts r e2 in let ok = t_and_simp wp1.ok (t_implies_subst vs wp1.post.ne wp2.ok) in let ok = wp_label e ok in let ne = wp_label e (t_and_subst vs wp1.post.ne wp2.post.ne) in let xne = iter_all_exns [wp1.exn; wp2.exn] (fun ex -> let s, post1, post2 = merge_opt_post md s (Mexn.find_opt ex wp1.exn) (Mexn.find_opt ex wp2.exn) in { s = s; ne = wp_label e (wp_or post1 (t_and_simp wp1.post.ne post2)) }) in { ok = ok; post = { ne = ne; s = wp2.post.s }; exn = xne } | Eif (e1, e2, e3) -> (* OK: ok(e1) /\ ne(e1) => (if e1=True then ok(e2) else ok(e3)) *) (* NE: ne(e1) /\ (if e1=True then ne(e2) else ne(e3)) *) (* EX(x): ex(e1)(x) \/ (ne(e1) /\ e1=True /\ ex(e2)(x)) \/ (ne(e1) /\ e1=False /\ ex(e3)(x)) *) (* First thing is the evaluation of e1 *) let cond_res = vs_result e1 in let wp1 = fast_wp_expr env s (cond_res, xresult) e1 in let wp2 = fast_wp_expr env wp1.post.s r e2 in let wp3 = fast_wp_expr env wp1.post.s r e3 in let test = t_equ (t_var cond_res) t_bool_true in let ok = t_and_simp wp1.ok (t_implies_subst cond_res wp1.post.ne (t_if_simp test wp2.ok wp3.ok)) in let ok = wp_label e ok in let md = create_model_data_opt ~loc:e1.e_loc ~context_labels:e1.e_label "if" in let state, f2, f3 = Subst.merge md wp1.post.s wp2.post.s wp3.post.s in let ne = t_and_subst cond_res wp1.post.ne (t_if test (t_and_simp wp2.post.ne f2) (t_and_simp wp3.post.ne f3)) in let ne = wp_label e ne in let xne = iter_all_exns [wp1.exn; wp2.exn; wp3.exn] (fun ex -> let s, post1, post2, post3 = merge_opt_post_3 md s (Mexn.find_opt ex wp1.exn) (Mexn.find_opt ex wp2.exn) (Mexn.find_opt ex wp3.exn) in { s = s; ne = wp_label e (wp_or post1 (t_and_subst cond_res wp1.post.ne (t_if test post2 post3))) }) in { ok = ok; post = { ne = ne; s = state }; exn = xne } | Eraise (ex, e1) -> (* OK: ok(e1) *) (* NE: false *) (* EX(ex): (ne(e1) /\ xresult=e1) \/ ex(e1)(ex) *) (* EX(x): ex(e1)(x) *) let ex_res = vs_result e1 in let wp1 = fast_wp_expr env s (ex_res, xresult) e1 in let rpost = (* avoid to introduce useless equation between void terms *) if ty_equal (ty_of_vty e1.e_vty) (ty_tuple []) then t_true else t_equ (t_var ex_res) (t_var (Mexn.find ex xresult)) in let s, ne = try let p = Mexn.find ex wp1.exn in let md = create_model_data_opt ~loc:e1.e_loc ~context_labels:e1.e_label "raise" in let s, r1, r2 = Subst.merge md s p.s wp1.post.s in let ne = wp_or (t_and_simp p.ne r1) (t_and_simp_l [wp1.post.ne; r2; rpost]) in s, ne with Not_found -> wp1.post.s, t_and_simp wp1.post.ne rpost in let expost = { s = Subst.mark s; ne = wp_label e ne } in let xne = Mexn.add ex expost wp1.exn in { ok = wp1.ok; post = { ne = t_false; s = wp1.post.s }; exn = xne } | Etry (e1, handlers) -> (* OK: ok(e1) /\ (forall x. ex(e1)(x) => ok(handlers(x))) *) (* NE: ne(e1) \/ (bigor x. ex(e1)(x) /\ ne(handlers(x))) *) (* EX(x): if x is captured in handlers (bigor y. ex(e1)(y) /\ ex(handlers(y))(x)) *) (* EX(x): if x is not captured in handlers ex(e1)(x) \/ (bigor y. ex(e1)(y) /\ ex(handlers(y))(x)) *) let handlers = List.fold_left (fun acc (ex,pv,expr) -> Mexn.add ex (pv,expr) acc) Mexn.empty handlers in let result, xresult = r in let xresult' = Mexn.fold (fun ex (pv,_) acc -> Mexn.add ex pv.pv_vs acc) handlers xresult in let wp1 = fast_wp_expr env s (result,xresult') e1 in let result = Mexn.fold (fun ex post acc -> try let _, e2 = Mexn.find ex handlers in let wp2 = fast_wp_expr env post.s r e2 in let md = create_model_data_opt ~loc:e1.e_loc ~context_labels:e1.e_label "try" in let s,f1,f2 = Subst.merge md s wp1.post.s wp2.post.s in let ne = wp_or (t_and_simp acc.post.ne f1) (t_and_simp_l [post.ne; wp2.post.ne; f2]) in { ok = t_and_simp acc.ok (t_implies_simp post.ne wp2.ok); post = { s = s; ne = ne; }; exn = Mexn.fold Mexn.add wp2.exn acc.exn } with Not_found -> { acc with exn = Mexn.add ex post acc.exn } ) wp1.exn { ok = wp1.ok; post = wp1.post; exn = Mexn.empty } in result | Eabstr (e1, spec) -> (* OK: spec.pre /\ ok(e1) /\ (ne(e1) => spec.post) /\ (forall x. ex(e1)(x) => spec.xpost(x) *) (* NE: spec.post *) (* EX: spec.xpost *) let pre_abstr_label = fresh_mark () in let pre_abstr_state = Subst.save_label pre_abstr_label s in let wp1 = fast_wp_expr env pre_abstr_state r e1 in let xpost = Mexn.map (fun p -> { s = wp1.post.s; ne = p }) spec.c_xpost in let abstr_post = { s = wp1.post.s; ne = spec.c_post } in let post, xpost = apply_state_to_post t_true pre_abstr_label r abstr_post xpost in let ok_post = (* This is the formula which expresses that "abstract" indeed implies its normal and exceptional postcondition. Note that we only do this for the exceptions that are actually listed. *) let wp1_exn_filtered = Mexn.filter (fun ex _ -> Mexn.mem ex xpost) wp1.exn in let xq = Mexn.mapi (fun ex q -> Mexn.find ex xresult, q.ne) xpost in wp_nimplies wp1.post.ne wp1_exn_filtered ((result, post.ne), xq) in (* We now enrich the xpost used by the context to "leak" information about the exceptional exits that are *not* covered by the xpost of the abstract expression *) let xpost = Mexn.fold (fun ex post acc -> if Mexn.mem ex acc then acc else Mexn.add ex post acc) wp1.exn xpost in let regs = regs_of_writes e1.e_effect in let glue = Subst.extract_glue env regs pre_abstr_state wp1.post.s in let post = { post with ne = t_and_simp glue post.ne } in let pre = wp_expl expl_pre (Subst.term s spec.c_pre) in let ok = t_and_simp_l [wp1.ok; pre ; ok_post] in { ok = wp_label e ok; post = post; exn = xpost } | Eany spec -> (* OK: spec.pre *) (* NE: spec.post *) (* EX: spec.xpost *) let pre_any_label = fresh_mark () in let prestate = Subst.save_label pre_any_label s in let poststate, glue = Subst.havoc None env (regs_of_writes spec.c_effect) prestate in let post = { s = poststate; ne = spec.c_post } in let xpost = Mexn.map (fun p -> { s = poststate; ne = p }) spec.c_xpost in let post, xpost = apply_state_to_post glue pre_any_label r post xpost in let pre = wp_expl expl_pre (Subst.term s spec.c_pre) in { ok = wp_label e pre; post = post; exn = xpost; } | Eloop (inv, varl, e1) -> (* OK: inv /\ (forall r in writes(e1), replace r by fresh r' in inv => (ok(e1) /\ (ne(e1) => inv' /\ var))) *) (* NE: inv[r -> r'] *) (* EX: ex(e1)[r -> r'] *) let md = create_model_data_opt ~loc:e1.e_loc ~context_labels:e1.e_label "loop" in let havoc_state, glue = Subst.havoc md env (regs_of_writes e1.e_effect) s in let init_inv = wp_expl expl_loop_init (Subst.term s inv) in let inv_hypo = t_and_simp glue (Subst.term havoc_state inv) in let wp1 = fast_wp_expr env havoc_state r e1 in let post_inv = wp_expl expl_loop_keep (Subst.term wp1.post.s inv) in (* preservation also includes the "OK" of the loop body, the overall form is: I => (OK /\ (NE => I' /\ V)) *) let variant = if varl = [] then t_true else let old_vars = List.map (fun (t,r) -> Subst.term havoc_state t,r) varl in let new_vars = List.map (fun (t,rel) -> Subst.term wp1.post.s t,rel) varl in decrease e.e_loc expl_loopvar env old_vars new_vars in let preserv_inv = t_implies_simp inv_hypo (t_and_simp wp1.ok (t_implies_simp wp1.post.ne (t_and_simp post_inv variant))) in let exn = Mexn.map (fun post -> { post with ne = t_and_simp inv_hypo post.ne }) wp1.exn in let ok = t_and_simp_l [init_inv; preserv_inv] in { ok = ok; post = { s = wp1.post.s; ne = t_false }; (* this is an infinite loop *) exn = exn } | Ecase (e1, bl) -> let cond_res = vs_result e1 in let wp1 = fast_wp_expr env s (cond_res, xresult) e1 in let wps = List.map (fun (_,e) -> fast_wp_expr env wp1.post.s r e) bl in let cond_t = t_var cond_res in let pats = List.map (fun ({ppat_pattern = pat}, _) -> pat) bl in let build_case f l = t_case_close_simp cond_t (List.map2 (fun pat x -> pat, (f x)) pats l) in let ok = t_and_simp wp1.ok (t_implies_subst cond_res wp1.post.ne (build_case (fun wp -> wp.ok) wps)) in let md = create_model_data_opt ~loc:e1.e_loc ~context_labels:e1.e_label "case" in let state, fl = Subst.merge_l md wp1.post.s (List.map (fun wp -> wp.post.s) wps) in let posts = List.map2 (fun f wp -> t_and_simp f wp.post.ne) fl wps in let ne = t_and_subst cond_res wp1.post.ne (build_case (fun x -> x) posts) in let ok = wp_label e ok in let ne = wp_label e ne in let all_wps = wp1 :: wps in let exns = List.map (fun x -> x.exn) all_wps in let xne = iter_all_exns exns (fun ex -> let opt_postl = List.map (fun wp -> Mexn.find_opt ex wp) exns in let s, post_l = merge_opt_post_l md s opt_postl in match post_l with | cond_f :: branches -> { s = s; ne = wp_label e (wp_or cond_f (t_and_subst cond_res wp1.post.ne (build_case (fun b -> b) branches))) } | _ -> assert false) in { ok = ok; post = { ne = ne; s = state }; exn = xne } | Eghost e1 -> fast_wp_expr env s r e1 | Efor ({pv_vs = x}, ({pv_vs = v1}, d, {pv_vs = v2}), inv, e1) -> let gt, le, incr = match d with | Mlw_expr.To -> env.ps_int_gt, env.ps_int_le, env.fs_int_pl | Mlw_expr.DownTo -> env.ps_int_lt, env.ps_int_ge, env.fs_int_mn in let one = t_nat_const 1 in let v1_gt_v2 = ps_app gt [t_var v1; t_var v2] in let v1_le_v2 = ps_app le [t_var v1; t_var v2] in let init_inv = wp_expl expl_loop_init (Subst.term s (t_subst_single x (t_var v1) inv)) in let init_inv = t_implies_simp v1_le_v2 init_inv in let md = create_model_data_opt ~loc:e1.e_loc ~context_labels:e1.e_label "loop" in let havoc_state, glue = Subst.havoc md env (regs_of_writes e1.e_effect) s in let inv_hypo = t_and_simp_l [ps_app le [t_var v1; t_var x]; ps_app le [t_var x; t_var v2]; t_and_simp glue (Subst.term havoc_state inv)] in let wp1 = fast_wp_expr env havoc_state r e1 in let post_inv = let next = fs_app incr [t_var x; one] ty_int in wp_expl expl_loop_keep (Subst.term wp1.post.s (t_subst_single x next inv)) in let preserv_inv = t_implies_simp inv_hypo (t_and_simp wp1.ok (t_implies_simp wp1.post.ne post_inv)) in let ok = wp_label e (t_and_simp init_inv preserv_inv) in let post_state, f1, f2 = Subst.merge md s s wp1.post.s in let v2pl1 = fs_app incr [t_var v2; one] ty_int in let ne = wp_label e (t_if_simp v1_le_v2 (t_and_simp f2 (Subst.term post_state (t_subst_single x v2pl1 inv))) (t_and_simp f1 v1_gt_v2)) in let exn = Mexn.map (fun post -> { post with ne = t_and_simp inv_hypo post.ne }) wp1.exn in { ok = ok; post = { s = post_state; ne = ne }; exn = exn } | Eassign (pl, e1, reg, pv) -> let rec get_term d = match d.e_node with | Eghost e | Elet (_,e) | Erec (_,e) -> get_term e | Evalue v -> vs_result e1, t_var v.pv_vs | Elogic t -> vs_result e1, t | _ -> let ity = ity_of_expr e1 in let id = id_fresh ?loc:e1.e_loc "o" in (* must be a pvsymbol or restore_pv will fail *) let npv = create_pvsymbol id ~ghost:e1.e_ghost ity in npv.pv_vs, t_var npv.pv_vs in let res, t = get_term e1 in let t = fs_app pl.pl_ls [t] pv.pv_vs.vs_ty in let wp1 = fast_wp_expr env s (res, xresult) e1 in let md = create_model_data_opt ~loc:e1.e_loc ~context_labels:e1.e_label "assign" in let s2, glue = Subst.havoc md env (Sreg.singleton reg) wp1.post.s in let t = Subst.term s2 t in let ne = t_and_simp_l [wp1.post.ne; glue; t_equ t (t_var pv.pv_vs)] in { ok = wp_label e wp1.ok; exn = wp1.exn; post = { s = s2; ne = wp_label e ne } } and fast_wp_fun_defn env { fun_lambda = l } = (* OK: forall bl. pl => ok(e) NE: true *) let lab = fresh_mark () and c = l.l_spec in let args = List.map (fun pv -> pv.pv_vs) l.l_args in let build_set svs = Mvs.fold (fun x _ acc -> Spv.add (restore_pv x) acc) svs Spv.empty in let pre_vars = build_set (t_vars c.c_pre) in let post_vars = build_set (t_vars c.c_post) in let all_vars = Spv.union l.l_expr.e_syms.syms_pv pre_vars in let all_vars = Spv.union all_vars post_vars in let prestate = Subst.init all_vars in let prestate = Subst.save_label lab prestate in let env = if c.c_letrec = 0 || c.c_variant = [] then env else let tl = List.map (fun (t,r) -> Subst.term prestate t,r) c.c_variant in let lrv = Mint.add c.c_letrec tl env.letrec_var in { env with letrec_var = lrv } in (* generate the initial state, using the overall effect of the function *) (* extract the result and xresult variables *) let result, _ = open_post c.c_post in let xresult = Mexn.map (fun x -> fst (open_post x)) c.c_xpost in (* call the fast wp, using the result variables *) let res = fast_wp_expr env prestate (result, xresult) l.l_expr in (* put the post of the function in the right format expected by adapt_post_to_state_pair. This is doen by wrapping everything in [fwp_post] records *) let xq = Mexn.mapi (fun ex q -> {ne = q; s = (Mexn.find ex res.exn).s }) c.c_xpost in let fun_post = { s = res.post.s ; ne = c.c_post } in let q, xq = apply_state_to_post t_true lab (result, xresult) fun_post xq in (* apply the prestate to the precondition *) let pre = Subst.term prestate c.c_pre in let xq = Mexn.mapi (fun ex q -> Mexn.find ex xresult, q.ne) xq in (* build the formula "forall variables, pre implies OK, and NE implies post" *) let f = t_and_simp res.ok (wp_nimplies res.post.ne res.exn ((result, q.ne), xq)) in let f = wp_implies pre f in let f = wp_forall args (t_forall_close (Mvs.keys (t_vars f)) [] f) in f and fast_wp_rec_defn env fdl = List.map (fast_wp_fun_defn env) fdl let fast_wp_let env km th { let_sym = lv; let_expr = e } = let env = mk_env env km th in let res = fast_wp_expr env (Subst.init e.e_syms.syms_pv) (result e) e in let f = wp_forall (Mvs.keys (t_vars res.ok)) res.ok in let id = match lv with | LetV pv -> pv.pv_vs.vs_name | LetA ps -> ps.ps_name in add_wp_decl km id f th let fast_wp_rec env km th fdl = let env = mk_env env km th in let fl = fast_wp_rec_defn env fdl in let add_one th d f = Debug.dprintf debug "wp %s = %a@\n----------------@." d.fun_ps.ps_name.id_string Pretty.print_term f; let f = wp_forall (Mvs.keys (t_vars f)) f in add_wp_decl km d.fun_ps.ps_name f th in List.fold_left2 add_one th fdl fl let fast_wp_val _env _km th _lv = th (* Select either traditional or fast WP *) let if_fast_wp f1 f2 x = if Debug.test_flag fast_wp then f1 x else f2 x let wp_val = if_fast_wp fast_wp_val wp_val let wp_let = if_fast_wp fast_wp_let wp_let let wp_rec = if_fast_wp fast_wp_rec wp_rec (* Lemma functions *) let wp_val ~wp env kn th ls = if wp then wp_val env kn th ls else th let wp_let ~wp env kn th ld = if wp then wp_let env kn th ld else th let wp_rec ~wp env kn th fdl = let th = if wp then wp_rec env kn th fdl else th in let add_one th { fun_ps = ps; fun_lambda = l } = let name = ps.ps_name in if Slab.mem lemma_label name.id_label then let loc = name.id_loc in let spec = ps.ps_aty.aty_spec in if not (eff_is_empty spec.c_effect) then Loc.errorm ?loc "lemma functions can not have effects"; if not (ity_equal (ity_of_expr l.l_expr) ity_unit) then Loc.errorm ?loc "lemma functions must return unit"; let env = mk_env env kn th in let lab = fresh_mark () in let args = List.map (fun pv -> pv.pv_vs) l.l_args in let q = old_mark lab spec.c_post in let f = wp_expr env e_void q Mexn.empty in let f = wp_implies spec.c_pre (erase_mark lab f) in let md = create_model_data "lemma function" in let f = wp_forall args (quantify md env (wp_fun_regs ps l) f) in let f = t_forall_close (Mvs.keys (t_vars f)) [] f in let lkn = Theory.get_known th in let f = if Debug.test_flag no_track then f else track_values lkn kn f in (*let f = if Debug.test_flag no_eval then f else Eval_match.eval_match ~inline:Eval_match.inline_nonrec_linear lkn f in*) let pr = create_prsymbol (id_clone name) in let d = create_prop_decl Paxiom pr f in Theory.add_decl ~warn:false th d else th in List.fold_left add_one th fdl why3-0.88.3/src/whyml/mlw_module.ml0000664000175100017510000006033113225666037017704 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Stdlib open Ident open Ty open Term open Theory open Mlw_ty open Mlw_ty.T open Mlw_expr open Mlw_decl (* module = theory + namespace + program decls (no logic decl here) extraction to OCaml 1. all types follow order given by theory, and retrieve program types when necessary 2. logic decls (no types) 3. program decls *) type type_symbol = | PT of itysymbol | TS of tysymbol type prog_symbol = | PV of pvsymbol | PS of psymbol | PL of plsymbol | XS of xsymbol | LS of lsymbol type namespace = { ns_ts : type_symbol Mstr.t; (* type symbols *) ns_ps : prog_symbol Mstr.t; (* program symbols *) ns_ns : namespace Mstr.t; (* inner namespaces *) } let empty_ns = { ns_ts = Mstr.empty; ns_ps = Mstr.empty; ns_ns = Mstr.empty; } let ns_replace sub chk x vo vn = if not chk then vn else if sub vo vn then vn else raise (ClashSymbol x) let tsym_sub t1 t2 = match t1,t2 with | PT t1, PT t2 -> its_equal t1 t2 | TS t1, TS t2 -> ts_equal t1 t2 | _, _ -> false let psym_sub p1 p2 = match p1,p2 with | PV p1, PV p2 -> pv_equal p1 p2 | PS p1, PS p2 -> ps_equal p1 p2 | PL p1, PL p2 -> pl_equal p1 p2 | XS p1, XS p2 -> xs_equal p1 p2 | LS p1, LS p2 -> ls_equal p1 p2 (* program symbols may overshadow pure symbols *) | LS _, (PV _|PS _|PL _|XS _) -> true | _, _ -> false let rec merge_ns chk ns1 ns2 = if ns1 == ns2 then ns1 else let join sub x n o = Some (ns_replace sub chk x o n) in let ns_union sub m1 m2 = if m1 == m2 then m1 else Mstr.union (join sub) m1 m2 in let fusion _ ns1 ns2 = Some (merge_ns chk ns1 ns2) in { ns_ts = ns_union tsym_sub ns1.ns_ts ns2.ns_ts; ns_ps = ns_union psym_sub ns1.ns_ps ns2.ns_ps; ns_ns = Mstr.union fusion ns1.ns_ns ns2.ns_ns; } let add_ns chk x ns m = Mstr.change (function | Some os -> Some (merge_ns chk ns os) | None -> Some ns) x m let ns_add sub chk x vn m = Mstr.change (function | Some vo -> Some (ns_replace sub chk x vo vn) | None -> Some vn) x m let add_ts chk x ts ns = { ns with ns_ts = ns_add tsym_sub chk x ts ns.ns_ts } let add_ps chk x pf ns = { ns with ns_ps = ns_add psym_sub chk x pf ns.ns_ps } let add_ns chk x nn ns = { ns with ns_ns = add_ns chk x nn ns.ns_ns } let rec convert_pure_ns ns = { ns_ts = Mstr.map (fun ts -> TS ts) ns.Theory.ns_ts; ns_ps = Mstr.map (fun ls -> LS ls) ns.Theory.ns_ls; ns_ns = Mstr.map convert_pure_ns ns.Theory.ns_ns; } let rec ns_find get_map ns = function | [] -> assert false | [a] -> Mstr.find a (get_map ns) | a::l -> ns_find get_map (Mstr.find a ns.ns_ns) l let ns_find_type_symbol = ns_find (fun ns -> ns.ns_ts) let ns_find_prog_symbol = ns_find (fun ns -> ns.ns_ps) let ns_find_ns = ns_find (fun ns -> ns.ns_ns) let ns_find_its ns s = match ns_find_type_symbol ns s with | PT its -> its | _ -> raise Not_found let ns_find_ts ns s = match ns_find_type_symbol ns s with | TS ts -> ts | _ -> raise Not_found let ns_find_pv ns s = match ns_find_prog_symbol ns s with | PV pv -> pv | _ -> raise Not_found let ns_find_ps ns s = match ns_find_prog_symbol ns s with | PS ps -> ps | _ -> raise Not_found let ns_find_pl ns s = match ns_find_prog_symbol ns s with | PL pl -> pl | _ -> raise Not_found let ns_find_xs ns s = match ns_find_prog_symbol ns s with | XS xs -> xs | _ -> raise Not_found let ns_find_ls ns s = match ns_find_prog_symbol ns s with | LS ls -> ls | _ -> raise Not_found (** Module *) type modul = { mod_theory: theory; (* pure theory *) mod_decls : pdecl list; (* module declarations *) mod_export: namespace; (* exported namespace *) mod_known : known_map; (* known identifiers *) mod_local : Sid.t; (* locally declared idents *) mod_used : Sid.t; (* used modules *) } (** Module under construction *) type module_uc = { muc_theory : theory_uc; muc_name : string; muc_path : string list; muc_decls : pdecl list; muc_prefix : string list; muc_import : namespace list; muc_export : namespace list; muc_known : known_map; muc_local : Sid.t; muc_used : Sid.t; muc_env : Env.env option; } (* FIXME? We wouldn't need to store muc_name, muc_path, and muc_prefix if theory_uc was exported *) let empty_module env n p = { muc_theory = create_theory ~path:p n; muc_name = n.Ident.pre_name; muc_path = p; muc_decls = []; muc_prefix = []; muc_import = [empty_ns]; muc_export = [empty_ns]; muc_known = Mid.empty; muc_local = Sid.empty; muc_used = Sid.empty; muc_env = env; } let close_module, restore_module = let h = Hid.create 17 in (fun uc -> let th = close_theory uc.muc_theory in (* catches errors *) let m = { mod_theory = th; mod_decls = List.rev uc.muc_decls; mod_export = List.hd uc.muc_export; mod_known = uc.muc_known; mod_local = uc.muc_local; mod_used = uc.muc_used; } in Hid.add h th.th_name m; m), (fun th -> Hid.find h th.th_name) let get_theory uc = uc.muc_theory let get_namespace uc = List.hd uc.muc_import let get_known uc = uc.muc_known let open_namespace uc s = match uc.muc_import with | ns :: _ -> { uc with muc_theory = Theory.open_namespace uc.muc_theory s; muc_prefix = s :: uc.muc_prefix; muc_import = ns :: uc.muc_import; muc_export = empty_ns :: uc.muc_export; } | [] -> assert false let close_namespace uc import = let th = Theory.close_namespace uc.muc_theory import in (* catches errors *) match uc.muc_prefix, uc.muc_import, uc.muc_export with | s :: prf, _ :: i1 :: sti, e0 :: e1 :: ste -> let i1 = if import then merge_ns false e0 i1 else i1 in let _ = if import then merge_ns true e0 e1 else e1 in let i1 = add_ns false s e0 i1 in let e1 = add_ns true s e0 e1 in { uc with muc_theory = th; muc_prefix = prf; muc_import = i1 :: sti; muc_export = e1 :: ste; } | _ -> assert false (** Use *) let add_to_module uc th ns = match uc.muc_import, uc.muc_export with | i0 :: sti, e0 :: ste -> { uc with muc_theory = th; muc_import = merge_ns false ns i0 :: sti; muc_export = merge_ns true ns e0 :: ste; } | _ -> assert false let use_export uc m = let mth = m.mod_theory in let id = mth.th_name in let uc = if Sid.mem id uc.muc_used then uc else { uc with muc_known = merge_known uc.muc_known m.mod_known; muc_used = Sid.add id uc.muc_used } in let th = Theory.use_export uc.muc_theory mth in add_to_module uc th m.mod_export (** Logic decls *) let add_to_theory f uc x = { uc with muc_theory = f uc.muc_theory x } let store_path, store_module, restore_path = let id_to_path = Wid.create 17 in let store_path uc path id = (* this symbol already belongs to some theory *) if Wid.mem id_to_path id then () else let prefix = List.rev (id.id_string :: path @ uc.muc_prefix) in Wid.set id_to_path id (uc.muc_path, uc.muc_name, prefix) in let store_module m = let id = m.mod_theory.th_name in (* this symbol is already a module *) if Wid.mem id_to_path id then () else Wid.set id_to_path id (m.mod_theory.th_path, id.id_string, []) in let restore_path id = Wid.find id_to_path id in store_path, store_module, restore_path let close_module uc = let m = close_module uc in store_module m; m let add_symbol add id v uc = store_path uc [] id; match uc.muc_import, uc.muc_export with | i0 :: sti, e0 :: ste -> { uc with muc_import = add false id.id_string v i0 :: sti; muc_export = add true id.id_string v e0 :: ste } | _ -> assert false let add_decl uc d = let add_ts uc ts = add_symbol add_ts ts.ts_name (TS ts) uc in let add_ls uc ls = add_symbol add_ps ls.ls_name (LS ls) uc in let add_pj uc pj = Opt.fold add_ls uc pj in let add_cs uc (cs,pjl) = List.fold_left add_pj (add_ls uc cs) pjl in let add_data uc (ts,csl) = List.fold_left add_cs (add_ts uc ts) csl in let add_logic uc (ls,_) = add_ls uc ls in let uc = match d.Decl.d_node with | Decl.Dtype ts -> add_ts uc ts | Decl.Ddata dl -> List.fold_left add_data uc dl | Decl.Dparam ls -> add_ls uc ls | Decl.Dlogic dl -> List.fold_left add_logic uc dl | Decl.Dind (_,dl) -> List.fold_left add_logic uc dl | Decl.Dprop _ -> uc in add_to_theory (Theory.add_decl ?warn:None) uc d let use_export_theory uc th = let nth = Theory.use_export uc.muc_theory th in let nns = convert_pure_ns th.th_export in add_to_module uc nth nns let clone_export_theory uc th inst = let nth = Theory.clone_export uc.muc_theory th inst in let sm = match Theory.get_rev_decls nth with | { td_node = Clone (_,sm) } :: _ -> sm | _ -> assert false in let g_ts _ ts = not (Mts.mem ts inst.inst_ts) in let g_ls _ ls = not (Mls.mem ls inst.inst_ls) in let f_ts p ts = try let ts = Mts.find ts sm.sm_ts in store_path uc p ts.ts_name; TS ts with Not_found -> TS ts in let f_ls p ls = try let ls = Mls.find ls sm.sm_ls in store_path uc p ls.ls_name; LS ls with Not_found -> LS ls in let rec f_ns p ns = { ns_ts = Mstr.map (f_ts p) (Mstr.filter g_ts ns.Theory.ns_ts); ns_ps = Mstr.map (f_ls p) (Mstr.filter g_ls ns.Theory.ns_ls); ns_ns = Mstr.mapi (fun n -> f_ns (n::p)) ns.Theory.ns_ns; } in add_to_module uc nth (f_ns [] th.th_export) let add_meta uc m al = { uc with muc_theory = Theory.add_meta uc.muc_theory m al } (** Program decls *) let add_type uc its = add_symbol add_ts its.its_ts.ts_name (PT its) uc let add_data uc (its,csl,_) = let add_pl uc pl = add_symbol add_ps pl.pl_ls.ls_name (PL pl) uc in let add_pj uc pj = Opt.fold add_pl uc pj in let add_cs uc (cs,pjl) = List.fold_left add_pj (add_pl uc cs) pjl in let uc = add_symbol add_ts its.its_ts.ts_name (PT its) uc in if its.its_abst then uc else List.fold_left add_cs uc csl let add_let uc = function | LetV pv -> add_symbol add_ps pv.pv_vs.vs_name (PV pv) uc | LetA ps -> add_symbol add_ps ps.ps_name (PS ps) uc let add_rec uc { fun_ps = ps } = add_symbol add_ps ps.ps_name (PS ps) uc let add_exn uc xs = add_symbol add_ps xs.xs_name (XS xs) uc let pdecl_ns uc d = match d.pd_node with | PDtype its -> add_type uc its | PDdata tdl -> List.fold_left add_data uc tdl | PDval lv | PDlet { let_sym = lv } -> add_let uc lv | PDrec fdl -> List.fold_left add_rec uc fdl | PDexn xs -> add_exn uc xs let pdecl_vc ~wp env km th d = match d.pd_node with | PDtype _ | PDdata _ | PDexn _ -> th | PDval lv -> Mlw_wp.wp_val ~wp env km th lv | PDlet ld -> Mlw_wp.wp_let ~wp env km th ld | PDrec rd -> Mlw_wp.wp_rec ~wp env km th rd let pdecl_vc ~wp uc d = match uc.muc_env with | Some env -> add_to_theory (pdecl_vc ~wp env uc.muc_known) uc d | None -> uc let pure_data_decl tdl = let proj pj = Opt.map (fun pls -> pls.pl_ls) pj in let cons (pls,pjl) = pls.pl_ls, List.map proj pjl in let defn (its,csl,_) = its.its_ts, List.map cons csl in List.map defn tdl let pdecl_pure th d = match d.pd_node with | PDtype its -> Theory.add_ty_decl th its.its_ts | PDdata tdl -> Theory.add_data_decl th (pure_data_decl tdl) | PDval _ | PDlet _ | PDrec _ | PDexn _ -> th let add_pdecl ~wp uc d = let uc = { uc with muc_decls = d :: uc.muc_decls; muc_known = known_add_decl (Theory.get_known uc.muc_theory) uc.muc_known d; muc_local = Sid.union uc.muc_local d.pd_news } in let uc = pdecl_ns uc d in let uc = pdecl_vc ~wp uc d in let uc = add_to_theory pdecl_pure uc d in uc (* we can safely add a new type invariant as long as the type was introduced in the last program decl, and no let, rec or val could see it *) exception TooLateInvariant let add_invariant uc its p = let rec add = function | d :: dl when Mid.mem its.its_ts.ts_name d.pd_news -> let d = Mlw_decl.add_invariant d its p in d, d :: dl | { pd_node = PDtype _ } as d :: dl -> let nd, dl = add dl in nd, d :: dl | _ -> raise TooLateInvariant in let decl, decls = add uc.muc_decls in let kn = Mid.map (Util.const decl) decl.pd_news in let kn = Mid.set_union kn uc.muc_known in { uc with muc_decls = decls; muc_known = kn } (* create module *) let xs_exit = create_xsymbol (id_fresh "%Exit") ity_unit let mod_prelude = let pd_exit = create_exn_decl xs_exit in let uc = empty_module None (id_fresh "Prelude") ["why3";"Prelude"] in let uc = add_pdecl ~wp:false uc pd_exit in close_module uc let create_module env ?(path=[]) n = let m = empty_module (Some env) n path in let m = use_export_theory m builtin_theory in let m = use_export_theory m bool_theory in let m = use_export_theory m unit_theory in let m = use_export m mod_prelude in m (** WhyML language *) type mlw_file = modul Mstr.t * theory Mstr.t let mlw_language = (Env.register_language Env.base_language snd : mlw_file Env.language) let () = Env.add_builtin mlw_language (function | [s] when s = mod_prelude.mod_theory.th_name.id_string -> Mstr.singleton s mod_prelude, Mstr.singleton s mod_prelude.mod_theory | _ -> raise Not_found) let () = Env.add_builtin Env.base_language (function | [s] when s = Mlw_wp.mark_theory.th_name.id_string -> Mstr.singleton s Mlw_wp.mark_theory | _ -> raise Not_found) exception ModuleNotFound of Env.pathname * string exception ModuleOrTheoryNotFound of Env.pathname * string type module_or_theory = Module of modul | Theory of theory let read_module env path s = let path = if path = [] then ["why3"; s] else path in let mm, _ = Env.read_library mlw_language env path in Mstr.find_exn (ModuleNotFound (path,s)) s mm let read_module_or_theory env path s = let path = if path = [] then ["why3"; s] else path in try let mm, mt = Env.read_library mlw_language env path in try Module (Mstr.find s mm) with Not_found -> try Theory (Mstr.find s mt) with Not_found -> raise (ModuleOrTheoryNotFound (path,s)) with Env.InvalidFormat _ | Env.LibraryNotFound _ -> let mt = Env.read_library Env.base_language env path in try Theory (Mstr.find s mt) with Not_found -> raise (ModuleOrTheoryNotFound (path,s)) let print_path fmt sl = Pp.print_list (Pp.constant_string ".") Format.pp_print_string fmt sl let () = Exn_printer.register (fun fmt e -> match e with | ModuleNotFound (sl,s) -> Format.fprintf fmt "Module %s not found in library %a" s print_path sl | ModuleOrTheoryNotFound (sl,s) -> Format.fprintf fmt "Module/theory %s not found in library %a" s print_path sl | TooLateInvariant -> Format.fprintf fmt "Cannot add a type invariant after another program declaration" | _ -> raise e) (** Clone *) type mod_inst = { inst_pv : pvsymbol Mpv.t; inst_ps : psymbol Mps.t; } let clone_export uc m minst inst = let nth = Theory.clone_export uc.muc_theory m.mod_theory inst in let sm = match Theory.get_rev_decls nth with | { td_node = Clone (_,sm) } :: _ -> sm | _ -> assert false in let psm = pl_clone sm in let conv_its its = Mits.find_def its its psm.sm_its in let conv_ts ts = Mts.find_def ts ts sm.Theory.sm_ts in let conv_ls ls = Mls.find_def ls ls sm.Theory.sm_ls in let extras = Mid.set_diff m.mod_known m.mod_local in let regh = Hreg.create 5 in let rec conv_ity ity = match ity.ity_node with | Ityapp (s,tl,rl) -> ity_app (conv_its s) (List.map conv_ity tl) (List.map conv_reg rl) | Itypur (s,tl) -> ity_pur (conv_ts s) (List.map conv_ity tl) | Ityvar _ -> ity and conv_reg r = if Mid.mem r.reg_name extras then r else try Hreg.find regh r with Not_found -> let nr = create_region (id_clone r.reg_name) (conv_ity r.reg_ity) in Hreg.replace regh r nr; nr in let conv_pv pv = create_pvsymbol (id_clone pv.pv_vs.vs_name) ~ghost:pv.pv_ghost (conv_ity pv.pv_ity) in let psh = Hid.create 3 in let conv_xs xs = try match Hid.find psh xs.xs_name with | XS xs -> xs | _ -> assert false with Not_found -> xs in let conv_eff mv eff = let e = eff_empty in let conv ghost r e = eff_write ~ghost e (conv_reg r) in let e = Sreg.fold (conv false) eff.eff_writes e in let e = Sreg.fold (conv true) eff.eff_ghostw e in let conv ghost xs e = eff_raise ~ghost e (conv_xs xs) in let e = Sexn.fold (conv false) eff.eff_raises e in let e = Sexn.fold (conv true) eff.eff_ghostx e in let conv r u e = match u with | Some u -> eff_refresh e (conv_reg r) (conv_reg u) | None -> eff_reset e (conv_reg r) in let e = Mreg.fold conv eff.eff_resets e in let tvs = Mvs.fold (fun _ vs s -> ty_freevars s vs.vs_ty) mv Stv.empty in let tvs = Stv.inter tvs eff.eff_compar in Stv.fold (fun tv e -> eff_compare e tv) tvs e in let conv_term mv t = t_gen_map (ty_s_map conv_ts) conv_ls mv t in let addx mv xs t q = Mexn.add (conv_xs xs) (conv_term mv t) q in let conv_vari mv (t,r) = conv_term mv t, Opt.map conv_ls r in let conv_spec mv c = { c_pre = conv_term mv c.c_pre; c_post = conv_term mv c.c_post; c_xpost = Mexn.fold (addx mv) c.c_xpost Mexn.empty; c_effect = conv_eff mv c.c_effect; c_variant = List.map (conv_vari mv) c.c_variant; c_letrec = 0; } in let rec conv_aty mv a = let args = List.map conv_pv a.aty_args in let add mv pv npv = Mvs.add pv.pv_vs npv.pv_vs mv in let mv = List.fold_left2 add mv a.aty_args args in let spec = conv_spec mv a.aty_spec in let vty = match a.aty_result with | VTarrow a -> VTarrow (conv_aty mv a) | VTvalue v -> VTvalue (conv_ity v) in vty_arrow args ~spec vty in let mvs = ref (Mvs.singleton pv_old.pv_vs pv_old.pv_vs) in let add_pdecl uc d = { uc with muc_decls = d :: uc.muc_decls; muc_known = known_add_decl (Theory.get_known nth) uc.muc_known d; muc_local = Sid.union uc.muc_local d.pd_news } in let rnth = ref nth in let add_pd uc pd = match pd.pd_node with | PDtype its -> add_pdecl uc (create_ty_decl (conv_its its)) | PDdata _ -> add_pdecl uc (clone_data_decl psm pd) | PDexn xs -> let ity = conv_ity xs.xs_ity in let nxs = create_xsymbol (id_clone xs.xs_name) ity in Hid.add psh xs.xs_name (XS nxs); add_pdecl uc (create_exn_decl nxs) | PDlet _ -> Loc.errorm "Cannot clone top-level computations" (* TODO? Should we clone the defining expression and let it participate in the top-level module WP? If not, what do we do about its effects? *) | PDval (LetV pv) when Mpv.mem pv minst.inst_pv -> (* TODO: ensure that we do not introduce undetected aliases. This may happen when the cloned module uses a base module with a global variable, and then we instantiate another global variable with it. *) Loc.errorm "Cannot instantiate top-level variables" | PDval (LetV pv) -> let npv = conv_pv pv in Hid.add psh pv.pv_vs.vs_name (PV npv); mvs := Mvs.add pv.pv_vs npv.pv_vs !mvs; add_pdecl uc (create_val_decl (LetV npv)) | PDval (LetA ps) when Mps.mem ps minst.inst_ps -> let nps = Mps.find ps minst.inst_ps in let aty = conv_aty !mvs ps.ps_aty in let app = match aty.aty_result, nps.ps_aty.aty_result with | VTvalue res, VTvalue _ -> let argl = List.map (fun pv -> pv.pv_ity) aty.aty_args in e_app (e_arrow nps argl res) (List.map e_value aty.aty_args) | _ -> Loc.errorm "Program@ symbol@ instantiation@ does@ not@ \ support@ specifications@ for@ partially@ applied@ symbols" in let spec = { aty.aty_spec with c_variant = []; c_letrec = 0 } in let lam = { l_args = aty.aty_args; l_expr = app; l_spec = spec } in let (lp,md,nm) = restore_path ps.ps_name in let sl = String.concat " " in let nm = sl lp ^ " " ^ md ^ " " ^ sl nm in let id = id_derive nm ps.ps_name in let fd = create_fun_defn id lam in if fd.fun_ps.ps_ghost && not ps.ps_ghost then Loc.errorm "Program@ symbol@ instantiation@ must@ preserve@ ghostness"; let oeff = aty.aty_spec.c_effect in let neff = fd.fun_ps.ps_aty.aty_spec.c_effect in if not (Sreg.subset neff.eff_writes oeff.eff_writes && Sexn.subset neff.eff_raises oeff.eff_raises && Sreg.subset neff.eff_ghostw oeff.eff_ghostw && Sexn.subset neff.eff_ghostx oeff.eff_ghostx && Mreg.submap (fun _ -> Opt.equal reg_equal) neff.eff_resets oeff.eff_resets && Stv.subset neff.eff_compar oeff.eff_compar && (oeff.eff_diverg || not neff.eff_diverg)) then Loc.errorm "Extra effects in program symbol instantiation"; if not (Spv.subset nps.ps_pvset (aty_pvset aty)) then Loc.errorm "Extra hidden state in program symbol instantiation"; begin match uc.muc_env with | Some env -> rnth := Mlw_wp.wp_rec ~wp:true env uc.muc_known !rnth [fd] | None -> () end; Hid.add psh ps.ps_name (PS nps); uc | PDval (LetA { ps_name = id; ps_ghost = ghost; ps_aty = aty }) -> let aty = conv_aty !mvs aty in let nps = Mlw_expr.create_psymbol (id_clone id) ~ghost aty in Hid.add psh id (PS nps); add_pdecl uc (create_val_decl (LetA nps)) | PDrec fdl -> let conv_fd uc { fun_ps = ps } = if Mps.mem ps minst.inst_ps then raise (Theory.CannotInstantiate ps.ps_name); let id = id_clone ps.ps_name in let aty = conv_aty !mvs ps.ps_aty in let vari = Spv.fold (fun pv l -> (t_var (Mvs.find_def pv.pv_vs pv.pv_vs !mvs), None)::l) ps.ps_pvset [] in (* we save all external pvsymbols to preserve the effects *) let spec = { aty.aty_spec with c_variant = vari } in let aty = vty_arrow ~spec aty.aty_args aty.aty_result in let nps = Mlw_expr.create_psymbol id ~ghost:ps.ps_ghost aty in Hid.add psh ps.ps_name (PS nps); add_pdecl uc (create_val_decl (LetA nps)) in List.fold_left conv_fd uc fdl in let uc = { uc with muc_known = merge_known uc.muc_known extras; muc_used = Sid.union uc.muc_used m.mod_used } in let uc = List.fold_left add_pd uc m.mod_decls in let nth = !rnth in let g_ts _ = function | TS ts -> not (Mts.mem ts inst.inst_ts) | _ -> true in let g_ps _ = function | LS ls -> not (Mls.mem ls inst.inst_ls) | PV pv -> not (Mpv.mem pv minst.inst_pv) | PS ps -> not (Mps.mem ps minst.inst_ps) | _ -> true in let f_ts p = function | TS ts -> begin try let ts = Mts.find ts sm.Theory.sm_ts in store_path uc p ts.ts_name; TS ts with Not_found -> TS ts end | PT pt -> begin try let pt = Mits.find pt psm.sm_its in store_path uc p pt.its_ts.ts_name; PT pt with Not_found -> PT pt end in let find_prs p def id = try let s = Hid.find psh id in match s with | PV pv -> store_path uc p pv.pv_vs.vs_name; s | PS ps -> store_path uc p ps.ps_name; s | XS xs -> store_path uc p xs.xs_name; s | LS _ | PL _ -> assert false with Not_found -> def in let f_ps p prs = match prs with | LS ls -> begin try let ls = Mls.find ls sm.Theory.sm_ls in store_path uc p ls.ls_name; LS ls with Not_found -> LS ls end | PL pl -> begin try let pl = Mls.find pl.pl_ls psm.sm_pls in store_path uc p pl.pl_ls.ls_name; PL pl with Not_found -> PL pl end | PV pv -> find_prs p prs pv.pv_vs.vs_name | PS ps -> find_prs p prs ps.ps_name | XS xs -> find_prs p prs xs.xs_name in let rec f_ns p ns = { ns_ts = Mstr.map (f_ts p) (Mstr.filter g_ts ns.ns_ts); ns_ps = Mstr.map (f_ps p) (Mstr.filter g_ps ns.ns_ps); ns_ns = Mstr.mapi (fun n -> f_ns (n::p)) ns.ns_ns; } in add_to_module uc nth (f_ns [] m.mod_export) why3-0.88.3/src/whyml/mlw_driver.mli0000664000175100017510000000237613225666037020070 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) type driver = private { drv_env : Env.env; drv_printer : string option; drv_prelude : Printer.prelude; drv_thprelude : Printer.prelude_map; drv_blacklist : Printer.blacklist; drv_syntax : Printer.syntax_map; drv_converter : Printer.syntax_map; } val load_driver : Env.env -> string -> string list -> driver (** loads a driver from a file @param env environment to interpret theories and modules @param string driver file name @param string list additional drivers containing only theories/modules *) why3-0.88.3/src/whyml/mlw_exec.mli0000664000175100017510000000216613225666037017516 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** Decide whether an expression/symbol/declaration is executable *) type t (** The context in which we make such a decision *) val create: Mlw_driver.driver -> Decl.known_map -> Mlw_decl.known_map -> t val is_exec_term: t -> Term.term -> bool val is_exec_lsymbol: t -> Term.lsymbol -> bool val is_exec_decl: t -> Decl.decl -> bool val is_exec_expr: t -> Mlw_expr.expr -> bool val is_exec_pdecl: t -> Mlw_decl.pdecl -> bool why3-0.88.3/src/whyml/mlw_main.ml0000664000175100017510000000306713225666037017346 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Stdlib open Mlw_module let debug = Debug.register_info_flag "print_modules" ~desc:"Print@ program@ modules@ after@ typechecking." let read_channel env path file c = let lb = Lexing.from_channel c in Loc.set_file file lb; let inc = Mlw_typing.open_file env path in Lexer.parse_program_file inc lb; let mm, tm = Mlw_typing.close_file () in if path = [] && Debug.test_flag debug then begin let add_m _ m modm = Ident.Mid.add m.mod_theory.Theory.th_name m modm in let modm = Mstr.fold add_m mm Ident.Mid.empty in let print_m _ m = Format.eprintf "@[module %a@\n%a@]@\nend@\n@." Pretty.print_th m.mod_theory (Pp.print_list Pp.newline2 Mlw_pretty.print_pdecl) m.mod_decls in Ident.Mid.iter print_m modm end; mm, tm let () = Env.register_format mlw_language "whyml" ["mlw"] read_channel ~desc:"WhyML@ programming@ language" why3-0.88.3/src/whyml/mlw_driver.ml0000664000175100017510000002017313225666037017712 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Ident open Ty open Term open Theory open Printer open Driver_ast open Mlw_ty open Mlw_expr open Mlw_module type driver = { drv_env : Env.env; drv_printer : string option; drv_prelude : Printer.prelude; drv_thprelude : Printer.prelude_map; drv_blacklist : Printer.blacklist; drv_syntax : Printer.syntax_map; drv_converter : Printer.syntax_map; } let load_file file = let c = open_in file in let lb = Lexing.from_channel c in Loc.set_file file lb; let to_close = Stack.create () in Stack.push c to_close; let input_lexer filename = let c = open_in filename in Stack.push c to_close; let lb = Lexing.from_channel c in Loc.set_file filename lb; lb in let f = Driver_lexer.parse_file_extract input_lexer lb in Stack.iter close_in to_close; f exception Duplicate of string exception UnknownType of (string list * string list) exception UnknownLogic of (string list * string list) exception UnknownProp of (string list * string list) exception UnknownVal of (string list * string list) exception UnknownExn of (string list * string list) exception FSymExpected of lsymbol exception PSymExpected of lsymbol let load_driver env file extra_files = let prelude = ref [] in let printer = ref None in let blacklist = Queue.create () in let set_or_raise loc r v error = match !r with | Some _ -> raise (Loc.Located (loc, Duplicate error)) | None -> r := Some v in let add_to_list r v = (r := v :: !r) in let add_global (loc, g) = match g with | EPrelude s -> add_to_list prelude s | EPrinter s -> set_or_raise loc printer s "printer" | EBlacklist sl -> List.iter (fun s -> Queue.add s blacklist) sl in let f = load_file file in List.iter add_global f.fe_global; let thprelude = ref Mid.empty in let syntax_map = ref Mid.empty in let converter_map = ref Mid.empty in let qualid = ref [] in let find_pr th (loc,q) = try Theory.ns_find_pr th.th_export q with Not_found -> raise (Loc.Located (loc, UnknownProp (!qualid,q))) in let find_ls th (loc,q) = try Theory.ns_find_ls th.th_export q with Not_found -> raise (Loc.Located (loc, UnknownLogic (!qualid,q))) in let find_ts th (loc,q) = try Theory.ns_find_ts th.th_export q with Not_found -> raise (Loc.Located (loc, UnknownType (!qualid,q))) in let find_fs th q = let ls = find_ls th q in if ls.ls_value = None then raise (FSymExpected ls) else ls in let find_ps th q = let ls = find_ls th q in if ls.ls_value <> None then raise (PSymExpected ls) else ls in let add_syntax id s b = syntax_map := Mid.add id (s,if b then 1 else 0) !syntax_map in let add_converter id s b = converter_map := Mid.add id (s,if b then 1 else 0) !converter_map in let add_local th = function | Rprelude s -> let l = Mid.find_def [] th.th_name !thprelude in thprelude := Mid.add th.th_name (s::l) !thprelude | Rsyntaxts (q,s,b) -> let ts = find_ts th q in check_syntax_type ts s; add_syntax ts.ts_name s b | Rsyntaxfs (q,s,b) -> let fs = find_fs th q in check_syntax_logic fs s; add_syntax fs.ls_name s b | Rsyntaxps (q,s,b) -> let ps = find_ps th q in check_syntax_logic ps s; add_syntax ps.ls_name s b | Rconverter _ -> Loc.errorm "Syntax converter cannot be used in pure theories" | Rliteral _ -> Loc.errorm "Syntax literal cannot be used in pure theories" | Rremovepr (q) -> ignore (find_pr th q) | Rremoveall -> let it key _ = match (Mid.find key th.th_known).Decl.d_node with | Decl.Dprop (_,symb,_) -> ignore symb | _ -> () in Mid.iter it th.th_local | Rmeta (s,al) -> let rec ty_of_pty = function | PTyvar x -> Ty.ty_var (Ty.tv_of_string x) | PTyapp ((loc,_) as q,tyl) -> let ts = find_ts th q in let tyl = List.map ty_of_pty tyl in Loc.try2 ~loc Ty.ty_app ts tyl | PTuple tyl -> let ts = Ty.ts_tuple (List.length tyl) in Ty.ty_app ts (List.map ty_of_pty tyl) in let convert = function | PMAty (PTyapp (q,[])) -> MAts (find_ts th q) | PMAty ty -> MAty (ty_of_pty ty) | PMAfs q -> MAls (find_fs th q) | PMAps q -> MAls (find_ps th q) | PMApr q -> MApr (find_pr th q) | PMAstr s -> MAstr s | PMAint i -> MAint i in let m = lookup_meta s in ignore (create_meta m (List.map convert al)) in let add_local th (loc,rule) = Loc.try2 ~loc add_local th rule in let find_val m (loc,q) = try match ns_find_prog_symbol m.mod_export q with | PV pv -> pv.pv_vs.vs_name | PS ps -> ps.ps_name | PL _ | XS _ | LS _ -> raise Not_found with Not_found -> raise (Loc.Located (loc, UnknownVal (!qualid,q))) in let find_xs m (loc,q) = try ns_find_xs m.mod_export q with Not_found -> raise (Loc.Located (loc, UnknownExn (!qualid,q))) in let add_local_module loc m = function | MRexception (q,s) -> let xs = find_xs m q in add_syntax xs.xs_name s false | MRval (q,s) -> let id = find_val m q in add_syntax id s false | MRtheory (Rconverter (q,s,b)) -> let id = find_val m q in add_converter id s b | MRtheory trule -> add_local m.mod_theory (loc,trule) in let add_local_module m (loc,rule) = Loc.try3 ~loc add_local_module loc m rule in let add_theory { thr_name = (loc,q); thr_rules = trl } = let f,id = let l = List.rev q in List.rev (List.tl l),List.hd l in let th = Loc.try3 ~loc Env.read_theory env f id in qualid := q; List.iter (add_local th) trl in let add_module { mor_name = (loc,q); mor_rules = mrl } = let f,id = let l = List.rev q in List.rev (List.tl l),List.hd l in let m = Loc.try3 ~loc read_module env f id in qualid := q; List.iter (add_local_module m) mrl in List.iter add_theory f.fe_th_rules; List.iter add_module f.fe_mo_rules; List.iter (fun f -> let fe = load_file f in List.iter add_theory fe.fe_th_rules; List.iter add_module fe.fe_mo_rules) extra_files; { drv_env = env; drv_printer = !printer; drv_prelude = List.rev !prelude; drv_thprelude = Mid.map List.rev !thprelude; drv_blacklist = Queue.fold (fun l s -> s :: l) [] blacklist; drv_syntax = !syntax_map; drv_converter = !converter_map; } (* exception report *) let string_of_qualid thl idl = String.concat "." thl ^ "." ^ String.concat "." idl let () = Exn_printer.register (fun fmt exn -> match exn with | Duplicate s -> Format.fprintf fmt "Duplicate %s specification" s | UnknownType (thl,idl) -> Format.fprintf fmt "Unknown type symbol %s" (string_of_qualid thl idl) | UnknownLogic (thl,idl) -> Format.fprintf fmt "Unknown logical symbol %s" (string_of_qualid thl idl) | UnknownProp (thl,idl) -> Format.fprintf fmt "Unknown proposition %s" (string_of_qualid thl idl) | UnknownVal (thl,idl) -> Format.fprintf fmt "Unknown val %s" (string_of_qualid thl idl) | UnknownExn (thl,idl) -> Format.fprintf fmt "Unknown exception %s" (string_of_qualid thl idl) | FSymExpected ls -> Format.fprintf fmt "%a is not a function symbol" Pretty.print_ls ls | PSymExpected ls -> Format.fprintf fmt "%a is not a predicate symbol" Pretty.print_ls ls | e -> raise e) why3-0.88.3/src/whyml/mlw_decl.mli0000664000175100017510000000513413225666037017477 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** {1 Program Declarations} *) open Ident open Term open Mlw_ty open Mlw_ty.T open Mlw_expr (** {2 Type declaration} *) type constructor = plsymbol * plsymbol option list type data_decl = itysymbol * constructor list * post (** {2 Declaration type} *) type pdecl = private { pd_node : pdecl_node; pd_syms : Sid.t; (* idents used in declaration *) pd_news : Sid.t; (* idents introduced in declaration *) pd_tag : int; (* unique tag *) } and pdecl_node = private | PDtype of itysymbol | PDdata of data_decl list | PDval of let_sym | PDlet of let_defn | PDrec of fun_defn list | PDexn of xsymbol (** {2 Marks} *) val ts_mark : Ty.tysymbol val ty_mark : Ty.ty val ity_mark : ity val pv_old : pvsymbol (** {2 Declaration constructors} *) type pre_field = preid option * field type pre_constructor = preid * pre_field list type pre_data_decl = itysymbol * pre_constructor list val create_data_decl : pre_data_decl list -> pdecl val create_ty_decl : itysymbol -> pdecl val create_val_decl : let_sym -> pdecl val create_let_decl : let_defn -> pdecl val create_rec_decl : fun_defn list -> pdecl val create_exn_decl : xsymbol -> pdecl (** {2 Type invariants} *) val null_invariant : itysymbol -> post val add_invariant : pdecl -> itysymbol -> post -> pdecl (** {2 Cloning} *) val clone_data_decl : Mlw_expr.symbol_map -> pdecl -> pdecl (** {2 Known identifiers} *) type known_map = pdecl Mid.t val known_id : known_map -> ident -> unit val known_add_decl : Decl.known_map -> known_map -> pdecl -> known_map val merge_known : known_map -> known_map -> known_map val find_constructors : known_map -> itysymbol -> constructor list val find_invariant : known_map -> itysymbol -> post val find_definition : known_map -> psymbol -> fun_defn option exception NonupdatableType of ity val inst_constructors : Decl.known_map -> known_map -> ity -> (lsymbol * field list) list why3-0.88.3/src/whyml/mlw_typing.mli0000664000175100017510000000146113225666037020101 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) val open_file : Env.env -> Env.pathname -> Ptree.incremental val close_file : unit -> Mlw_module.mlw_file why3-0.88.3/src/whyml/mlw_wp.mli0000664000175100017510000000277613225666037017227 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** {1 Weakest preconditions} *) open Theory open Mlw_ty.T open Mlw_decl open Mlw_expr (** {2 WP-only builtins} *) val lemma_label : Ident.label val fs_at : Term.lsymbol val fs_old : Term.lsymbol val t_at_old : Term.term -> Term.term val mark_theory : Theory.theory val th_mark_at : Theory.theory val th_mark_old : Theory.theory val fs_now : Term.lsymbol val e_now : expr val remove_old : Term.term -> Term.term val full_invariant : Decl.known_map -> Mlw_decl.known_map -> Term.vsymbol -> ity -> Term.term (** {2 Weakest precondition computations} *) val wp_val: wp:bool -> Env.env -> known_map -> theory_uc -> let_sym -> theory_uc val wp_let: wp:bool -> Env.env -> known_map -> theory_uc -> let_defn -> theory_uc val wp_rec: wp:bool -> Env.env -> known_map -> theory_uc -> fun_defn list -> theory_uc why3-0.88.3/src/whyml/mlw_main.mli0000664000175100017510000000130713225666037017512 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) why3-0.88.3/src/whyml/mlw_ocaml.ml0000664000175100017510000011645613225666037017524 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (* TODO - no more parentheses in drivers (the printer will add them with protect_on) - driver uses %1, %2, etc. and translation eta-expanses if necessary introduce a let when %1 appears several times? - simplications let x = y in ... let x = 17 in ... (converter) let x = () in ... let f (us: unit) = ... (when variable us is not used) some beta-reductions, at least (fun _ -> e) () - singleton types record/constructor fields of type unit - ghost code remove it as much as possible (in types and function arguments) *) open Format open Pp open Stdlib open Ident open Ty open Term open Theory open Printer let debug = Debug.register_info_flag "extraction" ~desc:"Print@ details@ of@ program@ extraction." let clean_fname fname = let fname = Filename.basename fname in (try Filename.chop_extension fname with _ -> fname) let modulename ?fname path t = let fname = match fname, path with | Some fname, _ -> clean_fname fname | None, [] -> "why3" | None, _ -> String.concat "__" path in fname ^ "__" ^ t (** Abstract syntax of ML *) module ML = struct type ty = | Tvar of ident | Tapp of ident * ty list | Ttuple of ty list | Tsyntax of string * ty list type var = ident * ty type pat = | Pwild | Pident of ident | Papp of ident * pat list | Ptuple of pat list | Precord of (ident * pat) list | Psyntax of string * pat list | Por of pat * pat | Pas of pat * ident type is_rec = bool type binop = Band | Bor | Beq type for_direction = To | DownTo type exn = | Xident of ident | Xsyntax of string | Xexit (* Pervasives.Exit *) type expr = | Econst of Number.integer_constant | Ebool of bool | Eident of ident | Esyntax of string * expr list | Eapp of expr * expr list | Efun of var list * expr | Elet of ident * expr * expr | Eletrec of is_rec * (ident * var list * expr) list * expr | Eif of expr * expr * expr | Ecast of expr * ty | Etuple of expr list (* at least 2 expressions *) | Econstr of ident * expr list | Ematch of expr * (pat * expr) list | Ebinop of expr * binop * expr | Enot of expr | Eblock of expr list | Ewhile of expr * expr | Efor of ident * ident * for_direction * ident * expr | Eraise of exn * expr option | Etry of expr * (exn * ident option * expr) list | Eabsurd (* records *) | Erecord of (ident * expr) list | Egetfield of expr * ident | Esetfield of expr * ident * expr type is_mutable = bool type typedef = | Dabstract | Ddata of (ident * ty list) list | Drecord of (is_mutable * ident * ty) list | Dalias of ty type decl = | Dtype of (ident * ident list * typedef) list | Dlet of is_rec * (ident * var list * expr) list (* TODO add return type? *) | Dexn of ident * ty option (** smart constructors *) let tunit = Ttuple [] let enop = Eblock [] let etuple = function | [] -> enop | [e] -> e | l -> Etuple l let eseq e1 e2 = match e1, e2 with | Eblock [], e | e, Eblock [] -> e | Eblock l1, Eblock l2 -> Eblock (l1 @ l2) | _, Eblock l2 -> Eblock (e1 :: l2) | Eblock l1, _ -> Eblock (l1 @ [e2]) | _ -> Eblock [e1; e2] end (** Translation from WhyML to ML *) type info = { exec: Mlw_exec.t; info_syn: syntax_map; converters: syntax_map; current_theory: Theory.theory; current_module: Mlw_module.modul option; th_known_map: Decl.known_map; mo_known_map: Mlw_decl.known_map; fname: string option; unsafe_int: bool; } module Translate = struct open Decl let type_unit = ML.Ttuple [] let rec type_ info ty = match ty.ty_node with | Tyvar v -> ML.Tvar v.tv_name | Tyapp (ts, tl) when is_ts_tuple ts -> ML.Ttuple (List.map (type_ info) tl) | Tyapp (ts, tl) -> begin match query_syntax info.info_syn ts.ts_name with | Some s -> ML.Tsyntax (s, List.map (type_ info) tl) | None -> ML.Tapp (ts.ts_name, List.map (type_ info) tl) end let vsty info vs = vs.vs_name, type_ info vs.vs_ty let has_syntax info id = Mid.mem id info.info_syn let get_record info ls = match Mid.find_opt ls.ls_name info.th_known_map with | Some { d_node = Ddata dl } -> let rec lookup = function | [] -> [] | (_, [cs, pjl]) :: _ when ls_equal cs ls -> (try List.map Opt.get pjl with _ -> []) | _ :: dl -> lookup dl in lookup dl | Some _ | None -> [] let type_decl info ts = match ts.ts_def with | NoDef | Range _ | Float _ -> (* FIXME: how should we extract Range and Float? *) ML.Dabstract | Alias ty -> ML.Dalias (type_ info ty) let type_args = List.map (fun tv -> tv.tv_name) let type_decl info ts = if has_syntax info ts.ts_name then [] else [ML.Dtype [ts.ts_name, type_args ts.ts_args, type_decl info ts]] let data_decl info (ts, csl) = let default () = let constr (cs, _) = cs.ls_name, List.map (type_ info) cs.ls_args in ML.Ddata (List.map constr csl) in let field ls = false, ls.ls_name, type_ info (Opt.get ls.ls_value) in let defn = function | [cs, _] -> let pjl = get_record info cs in if pjl = [] then default () else ML.Drecord (List.map field pjl) | _ -> default () in ts.ts_name, type_args ts.ts_args, defn csl let data_decl info (ts, _ as d) = if has_syntax info ts.ts_name then [] else [data_decl info d] let projections _info (ts, csl) = let pjl = List.filter ((<>) None) (snd (List.hd csl)) in let pjl = List.map Opt.get pjl in let x = id_register (id_fresh "x") in let projection ls = let branch (cs, pjl) = let arg = function | Some ls' when ls_equal ls' ls -> ML.Pident x | _ -> ML.Pwild in ML.Papp (cs.ls_name, List.map arg pjl), ML.Eident x in let id = id_register (id_fresh "x") in let ty = ML.Tapp (ts.ts_name, List.map (fun tv -> ML.Tvar tv.tv_name) ts.ts_args) in let def = ML.Ematch (ML.Eident id, List.map branch csl) in ML.Dlet (false, [ls.ls_name, [id, ty], def]) in List.map projection pjl let is_record = function | _, [_, pjl] -> List.for_all ((<>) None) pjl | _ -> false let projections info (ts, _ as d) = if has_syntax info ts.ts_name || is_record d then [] else projections info d let filter_ghost_fields ls def al = let flt fd arg = if fd.Mlw_expr.fd_ghost then def else arg in try List.map2 flt (Mlw_expr.restore_pl ls).Mlw_expr.pl_args al with Not_found -> al let rec pat info p = match p.pat_node with | Pwild -> ML.Pwild | Pvar v -> ML.Pident v.vs_name | Pas (p, v) -> ML.Pas (pat info p, v.vs_name) | Por (p, q) -> ML.Por (pat info p, pat info q) | Papp (cs, pl) when is_fs_tuple cs -> ML.Ptuple (List.map (pat info) pl) | Papp (cs, pl) -> begin match query_syntax info.info_syn cs.ls_name with | Some s -> ML.Psyntax (s, List.map (pat info) pl) | None -> let pat_void = Term.pat_app Mlw_expr.fs_void [] Mlw_ty.ty_unit in let pl = filter_ghost_fields cs pat_void pl in let pjl = get_record info cs in if pjl = [] then ML.Papp (cs.ls_name, List.map (pat info) pl) else let field ls p = ls.ls_name, pat info p in ML.Precord (List.map2 field pjl pl) end let is_constructor info ls = (* eprintf "is_constructor: ls=%s@." ls.ls_name.id_string; *) match Mid.find_opt ls.ls_name info.th_known_map with | Some { d_node = Ddata dl } -> let constr (_,csl) = List.exists (fun (cs,_) -> ls_equal cs ls) csl in List.exists constr dl | _ -> false (* can the type of a value be derived from the type of the arguments? *) let unambig_fs fs = let rec lookup v ty = match ty.ty_node with | Tyvar u when tv_equal u v -> true | _ -> ty_any (lookup v) ty in let lookup v = List.exists (lookup v) fs.ls_args in let rec inspect ty = match ty.ty_node with | Tyvar u when not (lookup u) -> false | _ -> ty_all inspect ty in Opt.fold (fun _ -> inspect) true fs.ls_value let oty_int = Some ty_int let rec app ls info tl = let isconstr = is_constructor info ls in let is_field (_, csl) = match csl with | [_, pjl] -> let is_ls = function None -> false | Some ls' -> ls_equal ls ls' in List.for_all ((<>) None) pjl && List.exists is_ls pjl | _ -> false in let isfield = match Mid.find_opt ls.ls_name info.th_known_map with | Some { d_node = Ddata dl } -> not isconstr && List.exists is_field dl | _ -> false in let id = ls.ls_name in match tl with | tl when isconstr -> let tl = filter_ghost_fields ls Mlw_expr.t_void tl in let pjl = get_record info ls in if pjl = [] then ML.Econstr (id, List.map (term info) tl) else let field ls t = ls.ls_name, term info t in ML.Erecord (List.map2 field pjl tl) | [t1] when isfield -> ML.Egetfield (term info t1, id) | tl -> ML.Eapp (ML.Eident id, List.map (term info) tl) and term info t = match t.t_node with | Tvar v -> let gh = try (Mlw_ty.restore_pv v).Mlw_ty.pv_ghost with Not_found -> false in if gh then ML.enop else ML.Eident v.vs_name | Ttrue -> ML.Ebool true | Tfalse -> ML.Ebool false | Tconst (Number.ConstInt c) -> ML.Econst c | Tconst (Number.ConstReal _) -> assert false | Tapp (fs, tl) when is_fs_tuple fs -> ML.etuple (List.map (term info) tl) | Tapp (fs, [t1; t2]) when not info.unsafe_int && ls_equal fs ps_equ && oty_equal t1.t_ty oty_int -> ML.Esyntax ("(Why3extract.Why3__BigInt.eq %1 %2)", [term info t1; term info t2]) | Tapp (fs, tl) -> begin match query_syntax info.info_syn fs.ls_name with | Some s -> ML.Esyntax (s, List.map (term info) tl) | None when unambig_fs fs -> app fs info tl | None -> ML.Ecast (app fs info tl, type_ info (t_type t)) end | Tif (t1, t2, t3) -> ML.Eif (term info t1, term info t2, term info t3) | Tlet (t1, tb) -> let v, t2 = t_open_bound tb in ML.Elet (v.vs_name, term info t1, term info t2) | Tcase (t1, bl) -> ML.Ematch (term info t1, List.map (tbranch info) bl) | Teps _ when t_is_lambda t -> let vl, _, t1 = t_open_lambda t in ML.Efun (List.map (vsty info) vl, term info t1) | Teps _ | Tquant _ -> Format.eprintf "t = %a@." Pretty.print_term t; assert false | Tbinop (op, t1, t2) -> let t1 = term info t1 in let t2 = term info t2 in begin match op with | Tand -> ML.Ebinop (t1, ML.Band, t2) | Tor -> ML.Ebinop (t1, ML.Bor, t2) | Tiff -> ML.Ebinop (t1, ML.Beq, t2) | Timplies -> ML.Ebinop (ML.Enot t1, ML.Bor, t2) end | Tnot t1 -> ML.Enot (term info t1) and tbranch info br = let p, t = t_open_branch br in pat info p, term info t let logic_defn info (ls, ld) = let vl, t = open_ls_defn ld in (ls.ls_name, List.map (vsty info) vl, term info t) let logic_defn info (ls, _ as d) = if has_syntax info ls.ls_name then [] else [logic_defn info d] let logic_decl info d = match d.d_node with | Dtype ts -> type_decl info ts | Ddata tl -> begin match List.flatten (List.map (data_decl info) tl) with | [] -> [] | dl -> [ML.Dtype dl] end @ List.flatten (List.map (projections info) tl) | Dlogic [ls, _ as ld] -> if has_syntax info ls.ls_name then [] else let isrec = Sid.mem ls.ls_name d.d_syms in [ML.Dlet (isrec, logic_defn info ld)] | Dlogic ll -> begin match List.flatten (List.map (logic_defn info) ll) with | [] -> [] | dl -> [ML.Dlet (true, dl)] end | Decl.Dparam _ | Dind _ | Dprop _ -> [] let logic_decl info d = if Mlw_exec.is_exec_decl info.exec d then logic_decl info d else [] let logic_decl info td = match td.td_node with | Decl d -> let union = Sid.union d.d_syms d.d_news in let inter = Mid.set_inter union info.mo_known_map in if Sid.is_empty inter then logic_decl info d else [] | Use _ | Clone _ | Meta _ -> [] let theory info th = List.flatten (List.map (logic_decl info) th.th_decls) (** programs *) open Mlw_ty open Mlw_ty.T open Mlw_expr open Mlw_decl open Mlw_module let rec ity info t = match t.ity_node with | Ityvar v -> ML.Tvar v.tv_name | Itypur (ts, tl) when is_ts_tuple ts -> ML.Ttuple (List.map (ity info) tl) | Itypur (ts, tl) | Ityapp ({its_ts=ts}, tl, _) -> begin match query_syntax info.info_syn ts.ts_name with | Some s -> ML.Tsyntax (s, List.map (ity info) tl) | None -> ML.Tapp (ts.ts_name, List.map (ity info) tl) end let is_underscore pv = pv.pv_vs.vs_name.id_string = "_" && ity_equal pv.pv_ity ity_unit let is_int_constant e = match e.e_node with | Elogic { t_node = Tconst (Number.ConstInt _) } -> true | _ -> false let get_int_constant e = match e.e_node with | Elogic { t_node = Tconst (Number.ConstInt n) } -> n | _ -> assert false let pv_name pv = pv.pv_vs.vs_name let pvty info pv = if pv.pv_ghost then (pv.pv_vs.vs_name, type_unit) else vsty info pv.pv_vs let lv_name = function | LetV pv -> pv_name pv | LetA ps -> ps.ps_name let for_direction = function | To -> ML.To | DownTo -> ML.DownTo let is_letrec = function | [fd] -> fd.fun_lambda.l_spec.c_letrec <> 0 | _ -> true let filter_ghost_params = (* removal of ghost does not work let dummy = create_pvsymbol (Ident.id_fresh "") ity_unit in fun args -> match List.filter (fun v -> not v.Mlw_ty.pv_ghost) args with | [] -> [dummy] | l -> l *) fun args -> args (* filtering ghost happens in pvty *) (* List.map (fun v -> if v.Mlw_ty.pv_ghost then create_pvsymbol (Ident.id_fresh "") ity_unit else v) *) let rec expr info e = assert (not e.e_ghost); match e.e_node with | Elogic t -> term info t | Evalue pv when pv.pv_ghost -> ML.enop | Evalue pv -> ML.Eident (pv_name pv) | Earrow a -> begin match query_syntax info.info_syn a.ps_name with | Some s -> ML.Esyntax (s, []) | None -> ML.Eident a.ps_name end (* converter *) | Elet ({ let_sym = LetV pv; let_expr = e1 }, { e_node = Eapp ({ e_node = Earrow a }, pv', _) }) when pv_equal pv' pv && Mid.mem a.ps_name info.converters && is_int_constant e1 -> let s = fst (Mid.find a.ps_name info.converters) in let n = Number.compute_int (get_int_constant e1) in let e1 = ML.Esyntax (BigInt.to_string n, []) in ML.Esyntax (s, [e1]) | Eapp (e, v, _) when v.pv_ghost -> (* ghost parameters are unit *) ML.Eapp (expr info e, [ML.enop]) | Eapp (e, v, _) -> ML.Eapp (expr info e, [ML.Eident (pv_name v)]) | Elet ({ let_sym = _lv; let_expr = e1 }, e2) when e1.e_ghost -> (* TODO: remove superflous let *) (* ML.Elet (lv_name lv, ML.enop, *) expr info e2 (* ) *) | Elet ({ let_sym = LetV pv }, e2) when ity_equal pv.pv_ity ity_mark -> expr info e2 | Elet ({ let_sym = LetV pv; let_expr = e1 }, e2) when is_underscore pv -> ML.eseq (expr info e1) (expr info e2) | Elet ({ let_sym = lv ; let_expr = e1 }, e2) -> ML.Elet (lv_name lv, expr info e1, expr info e2) | Eif (e0, e1, e2) -> ML.Eif (expr info e0, expr info e1, expr info e2) | Eassign (pl, e1, _, pv) -> ML.Esetfield (expr info e1, pl.pl_ls.ls_name, ML.Eident (pv_name pv)) | Eloop (_, _, e1) -> ML.Ewhile (ML.Ebool true, expr info e1) | Efor (pv, (pvfrom, dir, pvto), _, e1) -> ML.Efor (pv_name pv, pv_name pvfrom, for_direction dir, pv_name pvto, expr info e1) | Eraise (xs,_) when xs_equal xs xs_exit -> ML.Eraise (ML.Xexit, None) | Eraise (xs, e1) -> begin match query_syntax info.info_syn xs.xs_name with | Some s -> ML.Eraise (ML.Xsyntax s, Some (expr info e1)) | None when ity_equal xs.xs_ity ity_unit -> ML.Eraise (ML.Xident xs.xs_name, None) | None -> ML.Eraise (ML.Xident xs.xs_name, Some (expr info e1)) end | Etry (e1, bl) -> ML.Etry (expr info e1, List.map (xbranch info) bl) | Eabstr (e1, _) -> expr info e1 | Eabsurd -> ML.Eabsurd | Eassert _ -> ML.enop | Eghost _ | Eany _ -> assert false | Ecase (e1, [_,e2]) when e1.e_ghost -> expr info e2 | Ecase (e1, bl) -> ML.Ematch (expr info e1, List.map (ebranch info) bl) | Erec (fdl, e1) -> (* FIXME what about ghosts? *) let cmp {fun_ps=ps1} {fun_ps=ps2} = Pervasives.compare ps1.ps_ghost ps2.ps_ghost in let fdl = List.sort cmp fdl in ML.Eletrec (is_letrec fdl, List.map (recdef info) fdl, expr info e1) and recdef info { fun_ps = ps; fun_lambda = lam } = assert (not ps.ps_ghost); let args = filter_ghost_params lam.l_args in ps.ps_name, List.map (pvty info) args, expr info lam.l_expr and ebranch info ({ppat_pattern=p}, e) = pat info p, expr info e and xbranch info (xs, pv, e) = match query_syntax info.info_syn xs.xs_name with | Some s -> ML.Xsyntax s, Some (pv_name pv), expr info e | None when xs_equal xs xs_exit -> ML.Xexit, None, expr info e | None when ity_equal xs.xs_ity ity_unit -> ML.Xident xs.xs_name, None, expr info e | None -> ML.Xident xs.xs_name, Some (pv_name pv), expr info e let pdata_decl info (its, csl, _) = let field fd = if fd.fd_ghost then ML.tunit else ity info fd.fd_ity in let default () = let constr (cs, _) = cs.pl_ls.ls_name, List.map field cs.pl_args in ML.Ddata (List.map constr csl) in let field (ls, fd) = fd.fd_mut <> None, ls.ls_name, field fd in let defn = function | [cs, _] -> let pjl = get_record info cs.pl_ls in if pjl = [] then default () else ML.Drecord (List.map field (List.combine pjl cs.pl_args)) | _ -> default () in let ts = its.its_ts in ts.ts_name, type_args ts.ts_args, defn csl let pdata_decl info (its, _, _ as d) = if has_syntax info its.its_ts.ts_name then [] else [pdata_decl info d] let pprojections _info ({its_ts=ts}, csl, _) = let pjl = List.filter ((<>) None) (snd (List.hd csl)) in let pjl = List.map Opt.get pjl in let x = id_register (id_fresh "x") in let projection ls = let branch (cs, pjl) = let arg = function | Some ls' when pl_equal ls' ls -> ML.Pident x | _ -> ML.Pwild in ML.Papp (cs.pl_ls.ls_name, List.map arg pjl), ML.Eident x in let id = id_register (id_fresh "x") in let ty = ML.Tapp (ts.ts_name, List.map (fun tv -> ML.Tvar tv.tv_name) ts.ts_args) in let def = ML.Ematch (ML.Eident id, List.map branch csl) in ML.Dlet (false, [ls.pl_ls.ls_name, [id, ty], def]) in List.map projection pjl let is_record = function | _, [_, pjl], _ -> List.for_all ((<>) None) pjl | _ -> false let pprojections info (ts, _, _ as d) = if has_syntax info ts.its_ts.ts_name || is_record d then [] else pprojections info d let pdecl info pd = match pd.pd_node with | PDval (LetV pv) when pv_equal pv Mlw_decl.pv_old -> [] | PDval _ -> [] | PDtype ({ its_ts = ts } as its) -> let id = ts.ts_name in begin match its.its_def with | None -> [ML.Dtype [id, type_args ts.ts_args, ML.Dabstract]] | Some ty -> [ML.Dtype [id, type_args ts.ts_args, ML.Dalias (ity info ty)]] end | PDlet { let_sym = lv ; let_expr = e } -> Debug.dprintf debug "extract 'let' declaration %s@." (lv_name lv).id_string; [ML.Dlet (false, [lv_name lv, [], expr info e])] | PDdata tl -> begin match List.flatten (List.map (pdata_decl info) tl) with | [] -> [] | dl -> [ML.Dtype dl] end @ List.flatten (List.map (pprojections info) tl) | PDrec fdl -> (* print defined, non-ghost first *) let cmp {fun_ps=ps1} {fun_ps=ps2} = Pervasives.compare (ps1.ps_ghost || has_syntax info ps1.ps_name) (ps2.ps_ghost || has_syntax info ps2.ps_name) in let fdl = List.sort cmp fdl in List.iter (fun {fun_ps=ps} -> Debug.dprintf debug "extract 'let rec' declaration %s@." ps.ps_name.id_string) fdl; [ML.Dlet (is_letrec fdl, List.map (recdef info) fdl)] | PDexn xs -> let id = xs.xs_name in if ity_equal xs.xs_ity ity_unit then [ML.Dexn (id, None)] else [ML.Dexn (id, Some (ity info xs.xs_ity))] let warn_non_ghost_non_exec ps = if not ps.ps_ghost then Warning.emit ?loc:ps.ps_name.id_loc "Cannot extract code from non-ghost function %s: body is not executable" ps.ps_name.id_string let pdecl info d = if Mlw_exec.is_exec_pdecl info.exec d then pdecl info d else begin begin match d.pd_node with | PDlet { let_sym = LetA ps } -> warn_non_ghost_non_exec ps | PDrec fdl -> List.iter (fun {fun_ps=ps} -> warn_non_ghost_non_exec ps) fdl | _ -> () end; [] end let module_ info m = List.flatten (List.map (pdecl info) m.mod_decls) end (** OCaml printers *) module Print = struct open ML let ocaml_keywords = ["and"; "as"; "assert"; "asr"; "begin"; "class"; "constraint"; "do"; "done"; "downto"; "else"; "end"; "exception"; "external"; "false"; "for"; "fun"; "function"; "functor"; "if"; "in"; "include"; "inherit"; "initializer"; "land"; "lazy"; "let"; "lor"; "lsl"; "lsr"; "lxor"; "match"; "method"; "mod"; "module"; "mutable"; "new"; "object"; "of"; "open"; "or"; "private"; "rec"; "sig"; "struct"; "then"; "to"; "true"; "try"; "type"; "val"; "virtual"; "when"; "while"; "with"; "raise";] let is_ocaml_keyword = let h = Hstr.create 17 in List.iter (fun s -> Hstr.add h s ()) ocaml_keywords; Hstr.mem h let iprinter,aprinter,_tprinter,_pprinter = let isanitize = sanitizer char_to_alpha char_to_alnumus in let lsanitize = sanitizer char_to_lalpha char_to_alnumus in create_ident_printer ocaml_keywords ~sanitizer:isanitize, create_ident_printer ocaml_keywords ~sanitizer:lsanitize, create_ident_printer ocaml_keywords ~sanitizer:lsanitize, create_ident_printer ocaml_keywords ~sanitizer:isanitize let forget_tvs () = forget_all aprinter (* type variables always start with a quote *) let print_tv fmt tv = fprintf fmt "'%s" (id_unique aprinter tv) let forget_id vs = forget_id iprinter vs let _forget_ids = List.iter forget_id let forget_var (vs, _) = forget_id vs let forget_vars = List.iter forget_var let rec forget_pat = function | Pwild -> () | Pident id -> forget_id id | Papp (_, pl) | Ptuple pl | Psyntax (_, pl) -> List.iter forget_pat pl | Precord fl -> List.iter (fun (_, p) -> forget_pat p) fl | Por (p1, p2) -> forget_pat p1; forget_pat p2 | Pas (p, _) -> forget_pat p let print_ident fmt id = let s = id_unique iprinter id in fprintf fmt "%s" s let print_path = print_list dot pp_print_string let print_qident ~sanitizer info fmt id = try let lp, t, p = try Mlw_module.restore_path id with Not_found -> Theory.restore_path id in let s = String.concat "__" p in let s = Ident.sanitizer char_to_alpha char_to_alnumus s in let s = sanitizer s in let s = if is_ocaml_keyword s then s ^ "_renamed" else s in if Sid.mem id info.current_theory.th_local || Opt.fold (fun _ m -> Sid.mem id m.Mlw_module.mod_local) false info.current_module then fprintf fmt "%s" s else let fname = if lp = [] then info.fname else None in let m = Strings.capitalize (modulename ?fname lp t) in fprintf fmt "%s.%s" m s with Not_found -> let s = id_unique ~sanitizer iprinter id in fprintf fmt "%s" s let print_lident = print_qident ~sanitizer:Strings.uncapitalize let print_uident = print_qident ~sanitizer:Strings.capitalize let print_path_id fmt = function | [], id -> print_ident fmt id | p , id -> fprintf fmt "%a.%a" print_path p print_ident id let print_theory_name fmt th = print_path_id fmt (th.th_path, th.th_name) let print_module_name fmt m = print_theory_name fmt m.Mlw_module.mod_theory (** Types *) let protect_on x s = if x then "(" ^^ s ^^ ")" else s let star fmt () = fprintf fmt " *@ " let rec print_ty ?(paren=false) info fmt = function | Tvar v -> print_tv fmt v | Ttuple [] -> fprintf fmt "unit" | Ttuple tl -> fprintf fmt (protect_on paren "%a") (print_list star (print_ty info)) tl | Tapp (ts, []) -> print_lident info fmt ts | Tapp (ts, [ty]) -> fprintf fmt (protect_on paren "%a@ %a") (print_ty ~paren:true info) ty (print_lident info) ts | Tapp (ts, tl) -> fprintf fmt (protect_on paren "(%a)@ %a") (print_list comma (print_ty info)) tl (print_lident info) ts | Tsyntax (s, tl) -> syntax_arguments s (print_ty info) fmt tl let print_vsty info fmt (v, ty) = fprintf fmt "%a:@ %a" (print_lident info) v (print_ty info) ty let print_tv_arg = print_tv let print_tv_args fmt = function | [] -> () | [tv] -> fprintf fmt "%a@ " print_tv_arg tv | tvl -> fprintf fmt "(%a)@ " (print_list comma print_tv_arg) tvl let print_ty_arg info fmt ty = fprintf fmt "%a" (print_ty ~paren:true info) ty let print_vs_arg info fmt vs = fprintf fmt "@[(%a)@]" (print_vsty info) vs let print_type_decl info fst fmt (ts, args, def) = let print_constr fmt (cs, args) = match args with | [] -> fprintf fmt "@[| %a@]" (print_uident info) cs | tl -> fprintf fmt "@[| %a of %a@]" (print_uident info) cs (print_list star (print_ty_arg info)) tl in let print_field fmt (mut, ls, ty) = fprintf fmt "%s%a: %a;" (if mut then "mutable " else "") (print_lident info) ls (print_ty info) ty in let print_defn fmt = function | Dabstract -> () | Ddata csl -> fprintf fmt " =@\n%a" (print_list newline print_constr) csl | Drecord fl -> fprintf fmt " = {@\n%a@\n}" (print_list newline print_field) fl | Dalias ty -> fprintf fmt " =@ %a" (print_ty info) ty in fprintf fmt "@[%s %a%a%a@]" (if fst then "type" else "and") print_tv_args args (print_lident info) ts print_defn def let print_list_next sep print fmt = function | [] -> () | [x] -> print true fmt x | x :: r -> print true fmt x; sep fmt (); print_list sep (print false) fmt r let rec print_pat ?(paren=false) info fmt = function | Pwild -> fprintf fmt "_" | Pident v -> print_lident info fmt v | Pas (p, v) -> fprintf fmt (protect_on paren "%a as %a") (print_pat ~paren:true info) p (print_lident info) v | Por (p, q) -> fprintf fmt (protect_on paren "%a | %a") (print_pat info) p (print_pat info) q | Ptuple pl -> fprintf fmt "(%a)" (print_list comma (print_pat info)) pl | Psyntax (s, pl) -> syntax_arguments s (print_pat ~paren:true info) fmt pl | Papp (cs, []) -> print_uident info fmt cs | Papp (cs, [p]) -> fprintf fmt (protect_on paren "%a@ %a") (print_uident info) cs (print_pat ~paren:true info) p | Papp (cs, pl) -> fprintf fmt (protect_on paren "%a@ (%a)") (print_uident info) cs (print_list comma (print_pat info)) pl | Precord fl -> let print_field fmt (ls, p) = fprintf fmt "%a = %a" (print_lident info) ls (print_pat info) p in fprintf fmt "{ %a }" (print_list semi print_field) fl let min_int31 = BigInt.of_int (- 0x40000000) let max_int31 = BigInt.of_int 0x3FFFFFFF let print_const ~paren fmt c = let n = Number.compute_int c in if BigInt.eq n BigInt.zero then fprintf fmt "Why3extract.Why3__BigInt.zero" else if BigInt.eq n BigInt.one then fprintf fmt "Why3extract.Why3__BigInt.one" else if BigInt.le min_int31 n && BigInt.le n max_int31 then let m = BigInt.to_int n in fprintf fmt (protect_on paren "Why3extract.Why3__BigInt.of_int %d") m else let s = BigInt.to_string n in fprintf fmt (protect_on paren "Why3extract.Why3__BigInt.of_string \"%s\"") s let print_binop fmt = function | Band -> fprintf fmt "&&" | Bor -> fprintf fmt "||" | Beq -> fprintf fmt "=" let is_unit = function | Eblock [] -> true | _ -> false let rec print_expr ?(paren=false) info fmt = function | Eident v -> print_lident info fmt v | Ebool b -> fprintf fmt "%b" b | Econst c when info.unsafe_int -> fprintf fmt "%s" (BigInt.to_string (Number.compute_int c)) | Econst c -> print_const ~paren fmt c | Etuple el -> fprintf fmt "(%a)" (print_list comma (print_expr info)) el | Esyntax (s, tl) -> syntax_arguments s (print_expr_p info) fmt tl | Ecast (e, ty) -> fprintf fmt "@[(%a:@ %a)@]" (print_expr info) e (print_ty info) ty | Eif (e1, e2, e3) when is_unit e3 -> fprintf fmt (protect_on paren "@[@[if@ %a@]@ then@;<1 2>@[%a@]@]") (print_expr info) e1 (print_expr ~paren:true info) e2 | Eif (e1, e2, e3) -> fprintf fmt (protect_on paren "@[@[if@ %a@]@ then@;<1 2>@[%a@]@;<1 0>else@;<1 2>@[%a@]@]") (print_expr info) e1 (print_expr info) e2 (print_expr info) e3 | Elet (v, e1, e2) -> fprintf fmt (protect_on paren "@[let @[%a@] =@ @[%a@]@] in@ %a") (print_lident info) v (print_expr info) e1 (print_expr info) e2; forget_id v | Ematch (e1, [p, b1]) -> fprintf fmt (protect_on paren "@[let @[%a@] =@ @[%a@]@] in@ %a") (print_pat info) p (print_expr info) e1 (print_expr info) b1 | Ematch (e1, bl) -> fprintf fmt "@[begin match @[%a@] with@\n@[%a@] end@]" (print_expr info) e1 (print_list newline (print_branch info)) bl | Ebinop (e1, op, e2) -> fprintf fmt (protect_on paren "@[%a %a@ %a@]") (print_expr_p info) e1 print_binop op (print_expr_p info) e2 | Enot e1 -> fprintf fmt (protect_on paren "not %a") (print_expr_p info) e1 | Eapp (e, el) -> fprintf fmt (protect_on paren "@[%a@ %a@]") (print_expr info) e (print_list space (print_expr_p info)) el | Efun (vl, e1) -> fprintf fmt (protect_on paren "@[(fun %a ->@ %a)@]") (print_list space (print_vs_arg info)) vl (print_expr info) e1; forget_vars vl | Econstr (c, []) -> print_uident info fmt c | Econstr (c, [e1]) -> fprintf fmt (protect_on paren "%a %a") (print_uident info) c (print_expr_p info) e1 | Econstr (c, el) -> fprintf fmt (protect_on paren "@[%a@ (%a)@]") (print_uident info) c (print_list comma (print_expr info)) el | Erecord fl -> let print_field fmt (f, e) = fprintf fmt "%a = %a" (print_lident info) f (print_expr info) e in fprintf fmt "@[{ %a }@]" (print_list semi print_field) fl | Egetfield (e, f) -> fprintf fmt "%a.%a" (print_expr_p info) e (print_lident info) f | Esetfield (e1, f, e2) -> fprintf fmt (protect_on paren "%a.%a <- %a") (print_expr_p info) e1 (print_lident info) f (print_expr info) e2 | Eblock [] -> fprintf fmt "()" | Eblock [e] -> print_expr ~paren info fmt e | Eblock bl -> fprintf fmt "@[begin@;<1 2>@[%a@]@ end@]" (print_list semi (print_expr info)) bl | Ewhile (e1, e2) -> fprintf fmt "@[while %a do@;<1 2>@[%a@]@ done@]" (print_expr info) e1 (print_expr info) e2 | Efor (x, vfrom, dir, vto, e1) when info.unsafe_int -> fprintf fmt "@[for %a = %a %s %a do@\n%a@\ndone@]" (print_lident info) x (print_lident info) vfrom (if dir = To then "to" else "downto") (print_lident info) vto (print_expr info) e1 | Efor (x, vfrom, dir, vto, e1) -> fprintf fmt "@[(Why3extract.Why3__IntAux.for_loop_%s %a %a@ (fun %a ->@ %a))@]" (if dir = To then "to" else "downto") (print_lident info) vfrom (print_lident info) vto (print_lident info) x (print_expr info) e1 | Eraise (Xexit, a) -> assert (a = None); fprintf fmt (protect_on paren "raise Pervasives.Exit") | Eraise (Xsyntax s, None) -> fprintf fmt (protect_on paren "raise %a") (syntax_arguments s (print_expr info)) [] | Eraise (Xsyntax s, Some e1) -> fprintf fmt (protect_on paren "raise %a") (syntax_arguments s (print_expr info)) [e1] | Eraise (Xident id, None) -> fprintf fmt (protect_on paren "raise %a") (print_uident info) id | Eraise (Xident id, Some e1) -> fprintf fmt (protect_on paren "raise (%a %a)") (print_uident info) id (print_expr ~paren:true info) e1 | Etry (e1, bl) -> fprintf fmt "@[@[@[begin@ try@ %a@]@ with@]@\n@[%a@]@\nend@]" (print_expr info) e1 (print_list newline (print_xbranch info)) bl | Eabsurd -> fprintf fmt (protect_on paren "assert false (* absurd *)") | Eletrec (is_rec, fdl, e1) -> fprintf fmt (protect_on paren "@[%a@\nin@\n%a@]") (print_list_next newline (print_rec is_rec info)) fdl (print_expr info) e1 and print_rec lr info fst fmt (id, args, e) = let print_arg fmt v = fprintf fmt "@[%a@]" (print_vs_arg info) v in fprintf fmt "@[%s %a %a =@\n@[%a@]@]" (if fst then if lr then "let rec" else "let" else "and") (print_lident info) id (print_list space print_arg) args (print_expr info) e; forget_vars args and print_expr_p info fmt t = print_expr ~paren:true info fmt t and print_branch info fmt (p, e) = fprintf fmt "@[| %a ->@ %a@]" (print_pat info) p (print_expr info) e; forget_pat p and print_xbranch info fmt (xs, v, e) = begin match xs, v with | Xsyntax s, _ -> let v = match v with None -> [] | Some v -> [v] in fprintf fmt "@[| %a ->@ %a@]" (syntax_arguments s (print_lident info)) v (print_expr info) e | Xexit, _ -> fprintf fmt "@[| Pervasives.Exit ->@ %a@]" (print_expr info) e | Xident xs, None -> fprintf fmt "@[| %a ->@ %a@]" (print_uident info) xs (print_expr info) e | Xident xs, Some v -> fprintf fmt "@[| %a %a ->@ %a@]" (print_uident info) xs (print_lident info) v (print_expr info) e end; Opt.iter forget_id v let print_decl info fmt = function | Dtype dl -> print_list_next newline (print_type_decl info) fmt dl; fprintf fmt "@\n@\n" | Dlet (isrec, dl) -> let print_one fst fmt (ls, vl, e) = fprintf fmt "@[%s %a@ %a@ =@ %a@]" (if fst then if isrec then "let rec" else "let" else "and") (print_lident info) ls (print_list space (print_vs_arg info)) vl (print_expr info) e; forget_vars vl; forget_tvs () in print_list_next newline print_one fmt dl; fprintf fmt "@\n@\n" | Dexn (xs, None) -> fprintf fmt "exception %a@\n@\n" (print_uident info) xs | Dexn (xs, Some ty) -> fprintf fmt "@[exception %a of %a@]@\n@\n" (print_uident info) xs (print_ty ~paren:true info) ty end (** Exported functions *) let extract_filename ?fname th = (modulename ?fname th.th_path th.th_name.Ident.id_string) ^ ".ml" let unsafe_int drv = drv.Mlw_driver.drv_printer = Some "ocaml-unsafe-int" let print_preludes used fmt pm = (* we do not print the same prelude twice *) let ht = Hstr.create 5 in let add l s = if Hstr.mem ht s then l else (Hstr.add ht s (); s :: l) in let l = Sid.fold (fun id l -> List.fold_left add l (Mid.find_def [] id pm)) used [] in print_prelude fmt l let extract_theory drv ?old ?fname fmt th = ignore (old); ignore (fname); let info = { exec = Mlw_exec.create drv th.th_known Mid.empty; info_syn = drv.Mlw_driver.drv_syntax; converters = drv.Mlw_driver.drv_converter; current_theory = th; current_module = None; th_known_map = th.th_known; mo_known_map = Mid.empty; fname = Opt.map clean_fname fname; unsafe_int = unsafe_int drv; } in let decls = Translate.theory info th in fprintf fmt "(* This file has been generated from Why3 theory %a *)@\n@\n" Print.print_theory_name th; print_prelude fmt drv.Mlw_driver.drv_prelude; print_preludes th.th_used fmt drv.Mlw_driver.drv_thprelude; fprintf fmt "@\n"; print_list nothing (Print.print_decl info) fmt decls; fprintf fmt "@." open Mlw_module let extract_module drv ?old ?fname fmt m = ignore (old); ignore (fname); let th = m.mod_theory in let info = { exec = Mlw_exec.create drv th.th_known m.mod_known; info_syn = drv.Mlw_driver.drv_syntax; converters = drv.Mlw_driver.drv_converter; current_theory = th; current_module = Some m; th_known_map = th.th_known; mo_known_map = m.mod_known; fname = Opt.map clean_fname fname; unsafe_int = unsafe_int drv; } in let decls = Translate.theory info th in let mdecls = Translate.module_ info m in fprintf fmt "(* This file has been generated from Why3 module %a *)@\n@\n" Print.print_module_name m; print_prelude fmt drv.Mlw_driver.drv_prelude; let used = Sid.union m.mod_used m.mod_theory.th_used in print_preludes used fmt drv.Mlw_driver.drv_thprelude; fprintf fmt "@\n"; print_list nothing (Print.print_decl info) fmt decls; print_list nothing (Print.print_decl info) fmt mdecls; fprintf fmt "@." (* Local Variables: compile-command: "unset LANG; make -C ../.." End: *) why3-0.88.3/src/whyml/mlw_exec.ml0000664000175100017510000001321313225666037017340 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (* First implementation by Jacques-Pascal Deplaix during an internship at LRI, May-August 2014 *) open Ty open Ident open Term open Decl type t = { driver : Mlw_driver.driver; th_known_map: Decl.known_map; mo_known_map: Mlw_decl.known_map; is_exec_id : bool Hid.t; (* cache *) } let create dr thkm mokm = { driver = dr; th_known_map = thkm; mo_known_map = mokm; is_exec_id = Hid.create 17; } let has_syntax ctx id = Mid.mem id ctx.driver.Mlw_driver.drv_syntax || Mid.mem id ctx.driver.Mlw_driver.drv_converter let is_exec_id ctx id f = try Hid.find ctx.is_exec_id id with Not_found -> let b = has_syntax ctx id || f ctx id in Hid.add ctx.is_exec_id id b; b let declare_id ctx id b = Hid.add ctx.is_exec_id id b (** Logic *) let is_exec_const = function | Number.ConstInt _ -> true | Number.ConstReal _ -> false let rec is_exec_term ctx t = match t.t_node with | Ttrue | Tfalse | Tvar _ -> true | Tconst c -> is_exec_const c | Tapp (ls, tl) when ls.ls_constr > 0 -> begin match try Some (Mlw_expr.restore_pl ls) with Not_found -> None with | Some pl -> let test fd arg = fd.Mlw_expr.fd_ghost || is_exec_term ctx arg in List.for_all2 test pl.Mlw_expr.pl_args tl | None -> List.for_all (is_exec_term ctx) tl end | Tapp (ls, tl) -> is_exec_lsymbol ctx ls && List.for_all (is_exec_term ctx) tl | Tif (t1, t2, t3) -> is_exec_term ctx t1 && is_exec_term ctx t2 && is_exec_term ctx t3 | Tbinop (_, t1, t2) -> is_exec_term ctx t1 && is_exec_term ctx t2 | Tnot t -> is_exec_term ctx t | Tlet (t1, b2) -> is_exec_term ctx t1 && is_exec_bound ctx b2 | Tcase (t1, bl) -> is_exec_term ctx t1 && List.for_all (is_exec_branch ctx) bl | Teps _ when t_is_lambda t -> let _, _, t1 = t_open_lambda t in is_exec_term ctx t1 | Teps _ | Tquant _ -> false and is_exec_branch ctx b = let _, t = t_open_branch b in is_exec_term ctx t and is_exec_bound ctx b = let _, t = t_open_bound b in is_exec_term ctx t and is_exec_lsymbol ctx ls = is_exec_id ctx ls.ls_name (fun _ _ -> match Mid.find_opt ls.ls_name ctx.th_known_map with | None -> false | Some d -> ignore (is_exec_decl ctx d); is_exec_lsymbol ctx ls) and is_exec_decl ctx d = let allow_ts ts = declare_id ctx ts.ts_name true in let allow_ls ls = declare_id ctx ls.ls_name true in let forbid_ls ls = declare_id ctx ls.ls_name false in match d.d_node with | Dtype ts -> allow_ts ts; true | Ddata ddl -> let constructor (ls, prl) = allow_ls ls; List.iter (Opt.iter allow_ls) prl in let declare (ts, cl) = allow_ts ts; List.iter constructor cl in List.iter declare ddl; true | Dparam ls -> forbid_ls ls; false | Dlogic ll -> List.iter (fun (ls, _) -> allow_ls ls) ll; List.for_all (fun (_, ld) -> is_exec_term ctx (snd (open_ls_defn ld))) ll || begin List.iter (fun (ls, _) -> forbid_ls ls) ll; false end (* TODO? we could be more precise if two definitions are unnecessarily recursive and one is executable and the other is not *) | Dind (_, l) -> List.iter (fun (ls, _) -> forbid_ls ls) l; false | Dprop _ -> false open Mlw_ty open Mlw_expr open Mlw_decl let rec is_exec_expr ctx e = not e.e_ghost && match e.e_node with | Eassert _ | Eabsurd | Evalue _ | Earrow _ -> true | Eany _ -> false | Elogic t -> is_exec_term ctx t | Eloop (_, _, e1) | Efor (_, _, _, e1) | Eraise (_, e1) | Eapp (e1, _, _) | Eabstr (e1, _) | Eassign (_, e1, _, _) -> is_exec_expr ctx e1 | Elet ({let_expr = e1; _}, e2) when e1.e_ghost -> is_exec_expr ctx e2 | Elet ({let_expr = e1; _}, e2) -> is_exec_expr ctx e1 && is_exec_expr ctx e2 | Eif (e0, e1, e2) -> is_exec_expr ctx e0 && is_exec_expr ctx e1 && is_exec_expr ctx e2 | Erec (fdl, e1) -> let aux f = is_exec_expr ctx f.fun_lambda.l_expr in List.for_all aux fdl && is_exec_expr ctx e1 | Ecase (e1, [_, e2]) when e1.e_ghost -> is_exec_expr ctx e2 | Ecase (e1, bl) -> let aux (_, e) = is_exec_expr ctx e in is_exec_expr ctx e1 && List.for_all aux bl | Etry (e1, bl) -> let aux (_, _, e) = is_exec_expr ctx e in is_exec_expr ctx e1 && List.for_all aux bl | Eghost _ -> assert false let is_ghost_lv = function | LetV pv -> pv.pv_ghost | LetA ps -> ps.ps_ghost let is_exec_pdecl ctx pd = match pd.pd_node with | PDtype _ | PDexn _ | PDdata _ -> true | PDlet {let_sym = lv; _} | PDval lv when is_ghost_lv lv -> false | PDval (LetV {pv_vs = {vs_name = name}; _} | LetA {ps_name = name; _}) -> has_syntax ctx name | PDlet ld -> is_exec_expr ctx ld.let_expr | PDrec fdl -> let aux f = is_exec_expr ctx f.fun_lambda.l_expr in List.for_all aux fdl why3-0.88.3/src/whyml/mlw_interp.ml0000664000175100017510000011643713225666037017731 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Format open Term let debug = Debug.register_info_flag "trace_exec" ~desc:"trace execution of code given by --exec or --eval" (* environment *) open Mlw_ty open Mlw_ty.T open Mlw_expr module Nummap = Map.Make(BigInt) type value = | Vapp of lsymbol * value list | Vnum of BigInt.t | Vbool of bool | Vvoid | Vreg of region (* | Varray of Big_int.big_int * value * value Nummap.t (* length, default, elements *) *) | Vmap of value * value Nummap.t (* default, elements *) | Vbin of binop * value * value | Veq of value * value | Vnot of value | Vif of value * term * term | Vquant of quant * term_quant | Veps of term_bound | Vcase of value * term_branch list let array_cons_ls = ref ps_equ let ls_true = ref ps_equ let ls_false = ref ps_equ let rec print_value fmt v = match v with | Vnum n -> if BigInt.ge n BigInt.zero then fprintf fmt "%s" (BigInt.to_string n) else fprintf fmt "(%s)" (BigInt.to_string n) | Vbool b -> fprintf fmt "%b" b | Vvoid -> fprintf fmt "()" | Vreg reg -> Mlw_pretty.print_reg fmt reg | Vmap(def,m) -> fprintf fmt "@[[def=%a" print_value def; Nummap.iter (fun i v -> fprintf fmt ",@ %s -> %a" (BigInt.to_string i) print_value v) m; fprintf fmt "]@]" | Vapp(ls,[Vnum len;Vmap(def,m)]) when ls_equal ls !array_cons_ls -> fprintf fmt "@[["; let i = ref BigInt.zero in while BigInt.lt !i len do let v = try Nummap.find !i m with Not_found -> def in if BigInt.gt !i BigInt.zero then fprintf fmt ",@ "; fprintf fmt "%a" print_value v; i := BigInt.succ !i done; fprintf fmt "]@]" | Vapp(ls,vl) when is_fs_tuple ls -> fprintf fmt "@[(%a)@]" (Pp.print_list Pp.comma print_value) vl | Vapp(ls,[]) -> fprintf fmt "@[%a@]" Pretty.print_ls ls | Vapp(ls,vl) -> fprintf fmt "@[(%a %a)@]" Pretty.print_ls ls (Pp.print_list Pp.space print_value) vl | Vbin(op,v1,v2) -> fprintf fmt "@[(%a %a@ %a)@]" print_value v1 (Pretty.print_binop ~asym:false) op print_value v2 | Veq(v1,v2) -> fprintf fmt "@[(%a =@ %a)@]" print_value v1 print_value v2 | Vnot v -> fprintf fmt "@[(not@ %a)@]" print_value v | Vif(v,t1,t2) -> fprintf fmt "@[(if %a@ then %a@ else %a)@]" print_value v Pretty.print_term t1 Pretty.print_term t2 | Vquant(q,tq) -> Pretty.print_term fmt (t_quant q tq) | Veps(tb) -> Pretty.print_term fmt (t_eps tb) | Vcase(v,_) -> fprintf fmt "@[match %a@ with ... end@]" print_value v let v_eq v1 v2 = Veq(v1,v2) let v_and v1 v2 = match (v1,v2) with | Vbool b1, Vbool b2 -> Vbool (b1 && b2) | _ -> Vbin(Tand,v1,v2) let v_or v1 v2 = match (v1,v2) with | Vbool b1, Vbool b2 -> Vbool (b1 || b2) | _ -> Vbin(Tor,v1,v2) let v_implies v1 v2 = match (v1,v2) with | Vbool b1, Vbool b2 -> Vbool (not b1 || b2) | _ -> Vbin(Timplies,v1,v2) let v_iff v1 v2 = match (v1,v2) with | Vbool b1, Vbool b2 -> Vbool (b1 == b2) | _ -> Vbin(Tiff,v1,v2) let v_not v = match v with | Vbool b -> Vbool (not b) | _ -> Vnot(v) let v_if v t1 t2 = Vif(v,t1,t2) type env = { mknown : Mlw_decl.known_map; tknown : Decl.known_map; funenv : Mlw_expr.fun_defn Mps.t; regenv : region Mreg.t; vsenv : value Mvs.t; } type state = value Mreg.t let bind_vs v (t:value) env = { env with vsenv = Mvs.add v t env.vsenv } let multibind_vs l tl env = try List.fold_right2 bind_vs l tl env with Invalid_argument _ -> assert false let bind_pvs pv t env = { env with vsenv = Mvs.add pv.pv_vs t env.vsenv } let multibind_pvs l tl env = try List.fold_right2 bind_pvs l tl env with Invalid_argument _ -> assert false let p_regvar fmt (reg,t) = fprintf fmt "@[<%a> -> %a@]" Mlw_pretty.print_reg reg Mlw_pretty.print_reg t let print_regenv fmt s = let l = Mreg.bindings s in fprintf fmt "@[%a@]" (Pp.print_list Pp.semi p_regvar) l let get_reg env r = let rec aux n r = if n > 1000 then begin eprintf "@[looping region association ??? regenv =@ %a@]@." print_regenv env.regenv; assert false end; match Mreg.find_opt r env.regenv with | None -> r | Some r' -> aux (succ n) r' in aux 0 r (* store *) let p_reg fmt (reg,t) = fprintf fmt "@[<%a> -> %a@]" Mlw_pretty.print_reg reg print_value t let print_state fmt s = let l = Mreg.bindings s in fprintf fmt "@[%a@]" (Pp.print_list Pp.semi p_reg) l let p_vsvar fmt (vs,t) = fprintf fmt "@[%a -> %a@]" Pretty.print_vs vs print_value t let print_vsenv fmt s = let l = Mvs.bindings s in fprintf fmt "@[%a@]" (Pp.print_list Pp.semi p_vsvar) l (* evaluation of terms *) exception NoMatch exception Undetermined exception CannotCompute let rec matching env (t:value) p = match p.pat_node with | Pwild -> env | Pvar v -> bind_vs v t env | Por(p1,p2) -> begin try matching env t p1 with NoMatch -> matching env t p2 end | Pas(p,v) -> matching (bind_vs v t env) t p | Papp(ls1,pl) -> match t with | Vapp(ls2,tl) -> if ls_equal ls1 ls2 then List.fold_left2 matching env tl pl else if ls2.ls_constr > 0 then raise NoMatch else raise Undetermined | Vbool b -> let l = if b then !ls_true else !ls_false in if ls_equal ls1 l then env else raise NoMatch | _ -> raise Undetermined (* builtin symbols *) let builtins = Hls.create 17 let ls_minus = ref ps_equ (* temporary *) exception NotNum let big_int_of_const c = match c with | Number.ConstInt i -> Number.compute_int i | _ -> raise NotNum let big_int_of_value v = match v with | Vnum i -> i | _ -> raise NotNum let eval_true _ls _l = Vbool true let eval_false _ls _l = Vbool false let eval_int_op op ls l = match l with | [Vnum i1;Vnum i2] -> begin try Vnum (op i1 i2) with NotNum | Division_by_zero -> Vapp(ls,l) end | _ -> Vapp(ls,l) let eval_int_uop op ls l = match l with | [Vnum i1] -> begin try Vnum (op i1) with NotNum -> Vapp(ls,l) end | _ -> Vapp(ls,l) let eval_int_rel op ls l = match l with | [Vnum i1;Vnum i2] -> begin try Vbool (op i1 i2) with NotNum -> Vapp(ls,l) end | _ -> Vapp(ls,l) let must_be_true b = if b then true else raise Undetermined let rec value_equality v1 v2 = match (v1,v2) with | Vnum i1, Vnum i2 -> BigInt.eq i1 i2 | Vbool b1, Vbool b2 -> b1 == b2 | Vapp(ls1,vl1), Vapp(ls2,vl2) -> must_be_true (ls_equal ls1 ls2 && List.for_all2 value_equality vl1 vl2) | Vbin(o1,v11,v12),Vbin(o2,v21,v22) -> must_be_true (o1 == o2 && value_equality v11 v21 && value_equality v12 v22) | Veq(v11,v12),Veq(v21,v22) -> must_be_true (value_equality v11 v21 && value_equality v12 v22) | Vnot v1, Vnot v2 -> must_be_true (value_equality v1 v2) | Vif(v1,t11,t12),Vif(v2,t21,t22) -> must_be_true (value_equality v1 v2 && t_equal t11 t21 && t_equal t12 t22) | Vquant(q1,t1),Vquant(q2,t2) -> must_be_true (q1 = q2 && t1 == t2) | Veps t1, Veps t2 -> must_be_true (t1 == t2) | Vcase(v1,b1),Vcase(v2,b2) -> must_be_true(value_equality v1 v2 && b1 == b2) | _ -> raise Undetermined let eval_equ _ls l = (* eprintf "[interp] eval_equ ? @."; *) let res = match l with | [t1;t2] -> begin try Vbool(value_equality t1 t2) with Undetermined -> v_eq t1 t2 end | _ -> assert false in (* Format.eprintf "[interp] eval_equ: OK@."; *) res let eval_now ls l = Vapp(ls,l) (* functions on map.Map *) let ts_map = ref Ty.ts_int let builtin_map_type ts = ts_map := ts let ls_map_const = ref ps_equ let ls_map_get = ref ps_equ let ls_map_set = ref ps_equ let eval_map_const ls l = match l with | [d] -> Vmap(d,Nummap.empty) | _ -> Vapp(ls,l) let eval_map_get ls_get l = match l with | [m;x] -> (* eprintf "Looking for get:"; *) let rec find m = match m with | Vmap(def,m) -> begin match x with | Vnum i -> begin try Nummap.find i m with Not_found -> def end | _ -> assert false end | Vapp(ls,[m';y;v]) when ls_equal ls !ls_map_set -> begin try if value_equality x y then ((* Format.eprintf "ok!@.";*) v) else ((* Format.eprintf "recur...@.";*) find m' ) with Undetermined -> (* Format.eprintf "failed.@."; *) Vapp(ls_get,[m;x]) end | Vapp(ls,[def]) when ls_equal ls !ls_map_const -> def | _ -> Vapp(ls_get,[m;x]) in find m | _ -> assert false let eval_map_set ls_set l = match l with | [m;x;v] -> let rec compress m = match m with | Vmap(def,m) -> begin match x with | Vnum i -> Vmap(def,Nummap.add i v m) | _ -> assert false end | Vapp(ls,[m';y;v']) when ls_equal ls !ls_map_set -> begin try if value_equality x y then Vapp(ls_set,[m';x;v]) else let c = compress m' in Vapp(ls_set,[c;y;v']) with Undetermined -> Vapp(ls_set,[m;x;v]) end | _ -> Vapp(ls_set,[m;x;v]) in compress m | _ -> assert false (* all builtin functions *) let built_in_theories = [ ["bool"],"Bool", [], [ "True", Some ls_true, eval_true ; "False", Some ls_false, eval_false ; ] ; ["int"],"Int", [], [ "infix +", None, eval_int_op BigInt.add; "infix -", None, eval_int_op BigInt.sub; "infix *", None, eval_int_op BigInt.mul; "prefix -", Some ls_minus, eval_int_uop BigInt.minus; "infix <", None, eval_int_rel BigInt.lt; "infix <=", None, eval_int_rel BigInt.le; "infix >", None, eval_int_rel BigInt.gt; "infix >=", None, eval_int_rel BigInt.ge; ] ; ["int"],"MinMax", [], [ "min", None, eval_int_op BigInt.min; "max", None, eval_int_op BigInt.max; ] ; ["int"],"ComputerDivision", [], [ "div", None, eval_int_op BigInt.computer_div; "mod", None, eval_int_op BigInt.computer_mod; ] ; ["int"],"EuclideanDivision", [], [ "div", None, eval_int_op BigInt.euclidean_div; "mod", None, eval_int_op BigInt.euclidean_mod; ] ; ["map"],"Map", ["map", builtin_map_type], [ "get", Some ls_map_get, eval_map_get; "set", Some ls_map_set, eval_map_set; ] ; ["map"],"Const", [], [ "const", Some ls_map_const, eval_map_const ] ; ] let add_builtin_th env (l,n,t,d) = let th = Env.read_theory env l n in List.iter (fun (id,r) -> let ts = Theory.ns_find_ts th.Theory.th_export [id] in r ts) t; List.iter (fun (id,r,f) -> let ls = Theory.ns_find_ls th.Theory.th_export [id] in Hls.add builtins ls f; match r with | None -> () | Some r -> r := ls) d let get_builtins env = Hls.add builtins ps_equ eval_equ; Hls.add builtins Mlw_wp.fs_now eval_now; List.iter (add_builtin_th env) built_in_theories (* promotes logic value v of program type ty into a program value, e.g if type t = { mutable a : int; c: int ; mutable b : int } then to_value (mk_t 1 43 2 : t ) = Vapp(mk_t,[Vreg r1,Vnum 43, Vreg r2]) with new regions in s -> Vnum 1 -> Vnum 2 *) (* let rec to_program_value_rec env regions s ity ls vl = try let csl = Mlw_decl.inst_constructors env.tknown env.mknown ity in let rec find_cs csl = match csl with | [] -> assert false (* FIXME ? *) | (cs,fdl)::rem -> if ls_equal cs ls then (* we found the fields of that constructor *) begin let (s,regions,vl) = List.fold_left2 (fun (s,regions,vl) fd v -> match fd.fd_mut,regions with | None,_ -> (* non mutable field, but some subfield may be mutable *) begin match v with | Vapp(ls1,vl1) -> let s, regions, v = to_program_value_rec env regions s fd.fd_ity ls1 vl1 in (s,regions,v::vl) | _ -> (s,regions,v::vl) end | Some _r, reg::regions -> (* found a mutable field *) let s' = Mreg.add reg v s in (s',regions,Vreg reg :: vl) | Some _, [] -> assert false) (s,regions,[]) fdl vl in s,regions,Vapp(ls,List.rev vl) end else find_cs rem in find_cs csl with Not_found -> (* absurd, it would be a pure type *) assert false let rec get_regions acc ity = match ity.ity_node with | Ityvar _ -> assert false | Ityapp(its,tl,rl) -> List.map (get_reg env) rl | Itypur(ts,tl) -> *) let find_fields env ity ls = try let csl = Mlw_decl.inst_constructors env.tknown env.mknown ity in let rec find_cs csl = match csl with | [] -> assert false (* FIXME ? *) | (cs,fdl)::rem -> if ls_equal cs ls then fdl else find_cs rem in find_cs csl with Not_found -> (* absurd, [ity] would be a pure type *) assert false let rec remove_prefix l r = match l,r with | _,[] -> l | [],_ -> assert false | r1::l,r2::r -> assert (r1 == r2); remove_prefix l r let rec to_program_value env s ity v = match v with | Vapp(ls,vl) -> if ity_immutable ity then [],s,v else begin let fdl = find_fields env ity ls in let targs,regions = match ity.ity_node with | Ityapp(_,tl,rl) -> tl, List.map (get_reg env) rl | Ityvar _ -> assert false | Itypur(_,tl) -> tl, [] in let s,v = to_program_value_list env s targs fdl regions ls vl in regions, s, v end | _ -> assert (ity_immutable ity); [], s,v and to_program_value_list env s _tl fdl regions ls vl = let (s,regions,vl) = List.fold_left2 (fun (s,regions,vl) fd v -> match fd.fd_mut,regions with | None,_ -> (* non mutable field, but some subfield may be mutable *) let regs, s, v = to_program_value env s fd.fd_ity v in let rem_regs = match regions with | [] -> [] | _ -> remove_prefix regions regs in (s,rem_regs,v::vl) | Some _r, reg::regions -> (* found a mutable field *) let s' = Mreg.add reg v s in (s',regions,Vreg reg :: vl) | Some _, [] -> assert false) (s,regions,[]) fdl vl in match regions with | [] -> s, Vapp(ls,List.rev vl) | _ -> eprintf "@[error while converting logic value (%a) \ to a program value:@ regions should be empty, not@ [%a]@]@." print_value (Vapp(ls,vl)) (Pp.print_list Pp.comma Mlw_pretty.print_reg) regions; assert false let to_program_value env s ty v = match ty with | VTarrow _ -> s,v | VTvalue ity -> if ity_immutable ity then s,v else let _regs,s,v = to_program_value env s ity v in s,v let rec any_value_of_type env ty = match ty.Ty.ty_node with | Ty.Tyvar _ -> assert false | Ty.Tyapp(ts,_) when Ty.ts_equal ts Ty.ts_int -> let n = Random.int 199 - 99 in Vnum (BigInt.of_int n) | Ty.Tyapp(ts,_) when Ty.ts_equal ts Ty.ts_real -> Vvoid (* FIXME *) | Ty.Tyapp(ts,_) when Ty.ts_equal ts Ty.ts_bool -> Vbool(Random.bool ()) | Ty.Tyapp(ts,_tyl) when Ty.is_ts_tuple ts -> Vvoid (* FIXME *) | Ty.Tyapp(ts,tyargs) -> try let csl = Decl.find_constructors env.tknown ts in match csl with | [] -> Vvoid (* FIXME *) | [cs,_] -> let ts_args = ts.Ty.ts_args in let subst = List.fold_left2 (fun acc v t -> Ty.Mtv.add v t acc) Ty.Mtv.empty ts_args tyargs in let tyl = List.map (Ty.ty_inst subst) cs.ls_args in let vl = List.map (any_value_of_type env) tyl in Vapp(cs,vl) | (cs,_)::_rem -> (* FIXME *) let tyl = cs.ls_args in let vl = List.map (any_value_of_type env) tyl in Vapp(cs,vl) with Not_found -> Vvoid (* FIXME *) type result = | Normal of value | Excep of xsymbol * value | Irred of expr | Fun of psymbol * pvsymbol list * int let builtin_progs = Hps.create 17 let builtin_array_type kn its = let csl = Mlw_decl.find_constructors kn its in match csl with | [(pls,_)] -> array_cons_ls := pls.pl_ls | _ -> assert false let exec_array_make env s vty args = match args with | [Vnum n;def] -> let m = Vmap(def,Nummap.empty) in let v = Vapp(!array_cons_ls,[Vnum n;m]) in let s',v' = to_program_value env s vty v in Normal v',s' | _ -> raise CannotCompute let exec_array_copy env s vty args = match args with | [Vapp(ls,[len;m])] when ls_equal ls !array_cons_ls -> begin match m with | Vreg r -> let m = Mreg.find r s in let v = Vapp(!array_cons_ls,[len;m]) in let s',v' = to_program_value env s vty v in Normal v',s' | _ -> raise CannotCompute end | _ -> raise CannotCompute let exec_array_get _env s _vty args = match args with | [t;Vnum i] -> begin match t with | Vapp(ls,[_len;m]) when ls_equal ls !array_cons_ls -> begin match m with | Vreg r -> let m = Mreg.find r s in let t = eval_map_get !ls_map_get [m;Vnum i] in (* eprintf "[interp] exec_array_get (on reg %a)@ state =@ %a@ t[%a] -> %a@." Mlw_pretty.print_reg r print_state s print_value (Vnum i) print_value t; *) Normal t,s | _ -> raise CannotCompute (* let t = eval_map_get !ls_map_get [m;Vnum i] in eprintf "[interp] exec_array_get (on map %a)@ state =@ %a@ t[%a] -> %a@." print_value m print_state s print_value (Vnum i) print_value t; Normal t,s *) end | _ -> raise CannotCompute end | _ -> raise CannotCompute let exec_array_length _env s _vty args = match args with | [t] -> begin match t with | Vapp(ls,[len;_m]) when ls_equal ls !array_cons_ls -> Normal len,s | _ -> raise CannotCompute end | _ -> raise CannotCompute let exec_array_set _env s _vty args = match args with | [t;i;v] -> begin match t with | Vapp(ls,[_len;m]) when ls_equal ls !array_cons_ls -> begin match m with | Vreg r -> let m = Mreg.find r s in (* eprintf "[interp] exec_array_set (on reg %a)@ state =@ %a@ t[%a] -> %a@." Mlw_pretty.print_reg r print_state s print_value i print_value t; *) let t = eval_map_set !ls_map_set [m;i;v] in let s' = Mreg.add r t s in Normal Vvoid,s' (* let effs = spec.c_effect.eff_writes in let reg = if Sreg.cardinal effs = 1 then Sreg.choose effs else assert false in let reg = try Mreg.find reg env.regenv with Not_found -> reg in let s' = Mreg.add reg t s in eprintf "[interp] t[%a] <- %a (state = %a)@." print_value i print_value v print_state s'; Normal Vvoid,s' *) | _ -> raise CannotCompute end | _ -> raise CannotCompute end | _ -> assert false let built_in_modules = [ ["array"],"Array", ["array", builtin_array_type], ["make", None, exec_array_make ; "mixfix []", None, exec_array_get ; "length", None, exec_array_length ; "mixfix []<-", None, exec_array_set ; "copy", None, exec_array_copy ; ] ; ] let add_builtin_mo env (l,n,t,d) = let mo = Mlw_module.read_module env l n in let exp = mo.Mlw_module.mod_export in let kn = mo.Mlw_module.mod_known in List.iter (fun (id,r) -> let its = Mlw_module.ns_find_its exp [id] in r kn its) t; List.iter (fun (id,r,f) -> let ps = Mlw_module.ns_find_ps exp [id] in Hps.add builtin_progs ps f; match r with | None -> () | Some r -> r := ps) d let get_builtin_progs lib = List.iter (add_builtin_mo lib) built_in_modules let get_vs env vs = try let t = Mvs.find vs env.vsenv in t with Not_found -> eprintf "logic variable %s not found in env@." vs.vs_name.Ident.id_string; assert false let get_pvs env pvs = let t = try Mvs.find pvs.pv_vs env.vsenv with Not_found -> eprintf "program variable %s not found in env@." pvs.pv_vs.vs_name.Ident.id_string; assert false in t let rec to_logic_value env s v = let eval_rec t = to_logic_value env s t in match v with | Vreg r -> Mreg.find (get_reg env r) s | Vnum _ | Vbool _ | Vvoid | Vmap _ -> v | Vbin(Tand,t1,t2) -> v_and (eval_rec t1) (eval_rec t2) | Vbin(Tor,t1,t2) -> v_or (eval_rec t1) (eval_rec t2) | Vbin(Timplies,t1,t2) -> v_implies (eval_rec t1) (eval_rec t2) | Vbin(Tiff,t1,t2) -> v_iff (eval_rec t1) (eval_rec t2) | Vnot t1 -> v_not (eval_rec t1) | Vapp(ls,tl) -> eval_app env s ls (List.map eval_rec tl) | Veq (v1, v2) -> eval_equ ps_equ [v1;v2] | Vif(t1,t2,t3) -> let u = eval_rec t1 in begin match u with | Vbool true -> eval_term env s t2 | Vbool false -> eval_term env s t3 | _ -> v_if u t2 t3 end | Vcase(t1,tbl) -> (* eprintf "found a match ... with ...@."; *) let u = eval_rec t1 in eval_match env s u tbl | Vquant(q,t) -> Vquant(q,t) | Veps t -> Veps t and eval_term env s t = let eval_rec t = eval_term env s t in match t.t_node with | Tvar x -> begin try to_logic_value env s (get_vs env x) with Not_found -> assert false end | Tbinop(Tand,t1,t2) -> v_and (eval_rec t1) (eval_rec t2) | Tbinop(Tor,t1,t2) -> v_or (eval_rec t1) (eval_rec t2) | Tbinop(Timplies,t1,t2) -> v_implies (eval_rec t1) (eval_rec t2) | Tbinop(Tiff,t1,t2) -> v_iff (eval_rec t1) (eval_rec t2) | Tnot t1 -> v_not (eval_rec t1) | Tapp(ls,tl) -> eval_app env s ls (List.map eval_rec tl) | Tif(t1,t2,t3) -> let u = eval_rec t1 in begin match u with | Vbool true -> eval_term env s t2 | Vbool false -> eval_term env s t3 | _ -> v_if u t2 t3 end | Tlet(t1,tb) -> let u = eval_rec t1 in let v,t2 = t_open_bound tb in eval_term (bind_vs v u env) s t2 | Tcase(t1,tbl) -> (* eprintf "found a match ... with ...@."; *) let u = eval_rec t1 in eval_match env s u tbl | Tquant(q,t) -> Vquant(q,t) | Teps t -> Veps t | Tconst n -> Vnum (big_int_of_const n) | Ttrue -> Vbool true | Tfalse -> Vbool false and eval_match env s u tbl = let rec iter tbl = match tbl with | [] -> eprintf "[Exec] fatal error: pattern matching not exhaustive in evaluation.@."; assert false | b::rem -> let p,t = t_open_branch b in try let env' = matching env u p in eval_term env' s t with NoMatch -> iter rem in try iter tbl with Undetermined -> Vcase(u,tbl) and eval_app env s ls tl = try let f = Hls.find builtins ls in f ls tl with Not_found -> try let d = Ident.Mid.find ls.ls_name env.tknown in match d.Decl.d_node with | Decl.Dtype _ | Decl.Dprop _ -> assert false | Decl.Dlogic dl -> (* regular definition *) let d = List.assq ls dl in let l,t = Decl.open_ls_defn d in let env' = multibind_vs l tl env in eval_term env' s t | Decl.Dparam _ | Decl.Dind _ -> Vapp(ls,tl) | Decl.Ddata dl -> (* constructor or projection *) match tl with | [ Vapp(ls1,tl1) ] -> (* if ls is a projection and ls1 is a constructor, we should compute that projection *) let rec iter dl = match dl with | [] -> Vapp(ls,tl) | (_,csl) :: rem -> let rec iter2 csl = match csl with | [] -> iter rem | (cs,prs) :: rem2 -> if ls_equal cs ls1 then (* we found the right constructor *) let rec iter3 prs tl1 = match prs,tl1 with | (Some pr)::prs, t::tl1 -> if ls_equal ls pr then (* projection found! *) t else iter3 prs tl1 | None::prs, _::tl1 -> iter3 prs tl1 | _ -> Vapp(ls,tl) in iter3 prs tl1 else iter2 rem2 in iter2 csl in iter dl | _ -> Vapp(ls,tl) with Not_found -> Format.eprintf "[Exec] definition of logic symbol %s not found@." ls.ls_name.Ident.id_string; Vapp(ls,tl) let to_logic_result env st res = match res with | Normal v -> Normal(to_logic_value env st v) | Excep(e,v) -> Excep(e,to_logic_value env st v) | Irred _ | Fun _ -> res let eval_global_term env km t = get_builtins env; let env = { mknown = Ident.Mid.empty; tknown = km; funenv = Mps.empty; regenv = Mreg.empty; vsenv = Mvs.empty; } in eval_term env Mreg.empty t (* explicit printing of expr *) let p_pvs fmt pvs = fprintf fmt "@[{ pv_vs =@ %a;@ pv_ity =@ %a;@ pv_ghost =@ %B }@]" Pretty.print_vs pvs.pv_vs Mlw_pretty.print_ity pvs.pv_ity pvs.pv_ghost let p_ps fmt ps = fprintf fmt "@[{ ps_name =@ %s;@ ... }@]" ps.ps_name.Ident.id_string let p_pls fmt pls = fprintf fmt "@[{ pl_ls =@ %s;@ ... }@]" pls.pl_ls.ls_name.Ident.id_string let p_letsym fmt lsym = match lsym with | LetV pvs -> fprintf fmt "@[LetV(%a)@]" p_pvs pvs | LetA _ -> fprintf fmt "@[LetA(_)@]" let rec p_let fmt ld = fprintf fmt "@[{ let_sym =@ %a;@ let_expr =@ %a }@]" p_letsym ld.let_sym p_expr ld.let_expr and p_expr fmt e = match e.e_node with | Elogic t -> fprintf fmt "@[Elogic{type=%a}(%a)@]" Mlw_pretty.print_vty e.e_vty Pretty.print_term t | Evalue pvs -> fprintf fmt "@[Evalue(%a)@]" p_pvs pvs | Earrow ps -> fprintf fmt "@[Earrow(%a)@]" p_ps ps | Eapp (e1, pvs, _) -> fprintf fmt "@[Eapp(%a,@ %a,@ )@]" p_expr e1 p_pvs pvs | Elet(ldefn,e1) -> fprintf fmt "@[Elet(%a,@ %a)@]" p_let ldefn p_expr e1 | Erec (_, _) -> fprintf fmt "@[Erec(_,@ _,@ _)@]" | Eif (_, _, _) -> fprintf fmt "@[Eif(_,@ _,@ _)@]" | Ecase (_, _) -> fprintf fmt "@[Ecase(_,@ _)@]" | Eassign (pls, e1, reg, pvs) -> fprintf fmt "@[Eassign(%a,@ %a,@ %a,@ %a)@]" p_pls pls p_expr e1 Mlw_pretty.print_reg reg p_pvs pvs | Eghost _ -> fprintf fmt "@[Eghost(_)@]" | Eany _ -> fprintf fmt "@[Eany(_)@]" | Eloop (_, _, _) -> fprintf fmt "@[Eloop(_,@ _,@ _)@]" | Efor (_, _, _, _) -> fprintf fmt "@[Efor(_,@ _,@ _,@ _)@]" | Eraise (_, _) -> fprintf fmt "@[Eraise(_,@ _)@]" | Etry (_, _) -> fprintf fmt "@[Etry(_,@ _)@]" | Eabstr (_, _) -> fprintf fmt "@[Eabstr(_,@ _)@]" | Eassert (_, _) -> fprintf fmt "@[Eassert(_,@ _)@]" | Eabsurd -> fprintf fmt "@[Eabsurd@]" let print_logic_result fmt r = match r with | Normal v -> fprintf fmt "@[%a@]" print_value v | Excep(x,v) -> fprintf fmt "@[exception %s(@[%a@])@]" x.xs_name.Ident.id_string print_value v | Irred e -> fprintf fmt "@[Cannot execute expression@ @[%a@]@]" Mlw_pretty.print_expr (* p_expr *) e | Fun _ -> fprintf fmt "@[Result is a function@]" let print_result env s fmt r = print_logic_result fmt (to_logic_result env s r) (* let print_result env s fmt r = let env = { mknown = mkm; tknown = tkm; regenv = Mreg.empty; vsenv = Mvs.empty; } in print_result_aux env s fmt r *) (* evaluation of WhyML expressions *) let find_definition env ps = try Some (Mps.find ps env.funenv) with Not_found -> Mlw_decl.find_definition env.mknown ps (* evaluate expressions *) let rec eval_expr env (s:state) (e : expr) : result * state = match e.e_node with | Elogic t -> (* eprintf "@[[interp]before@ @[%a@]:@ vsenv =@ %a@ regenv=@ %a@ state=@ %a@]@." p_expr e print_vsenv env.vsenv print_regenv env.regenv print_state s; *) let v = eval_term env s t in let s',v' = to_program_value env s e.e_vty v in (* eprintf "@[[interp]after@ @[%a@]: state=@ %a@]@." p_expr e print_state s'; *) Normal v', s' | Evalue pvs -> begin try let t = get_pvs env pvs in (Normal t),s with Not_found -> assert false (* Irred e, s *) end | Elet(ld,e1) -> begin match ld.let_sym with | LetV pvs -> begin match eval_expr env s ld.let_expr with | Normal t,s' -> eval_expr (bind_pvs pvs t env) s' e1 | r -> r end | LetA _ -> Irred e, s end | Eapp(e1,pvs,_spec) -> begin match eval_expr env s e1 with | Fun(ps,args,n), s' -> if n > 1 then Fun(ps,pvs::args,n-1), s' else let ity_result = match e.e_vty with | VTvalue ity -> ity | VTarrow _ -> assert false in begin try exec_app env s' ps (pvs::args) (*spec*) ity_result with CannotCompute -> Irred e, s end | _ -> Irred e, s end | Earrow ps -> let len = List.length ps.ps_aty.aty_args in Fun(ps,[],len),s | Eif(e1,e2,e3) -> begin (* eprintf "[interp] condition of the if : @?"; *) match eval_expr env s e1 with | Normal t, s' -> begin match t with | Vbool true -> eval_expr env s' e2 | Vbool false -> eval_expr env s' e3 | _ -> begin eprintf "@[[Exec] Cannot decide condition of if: @[%a@]@]@." print_value t; Irred e, s end end | r -> r end | Eraise(xs,e1) -> begin let r,s' = eval_expr env s e1 in match r with | Normal t -> Excep(xs,t),s' | _ -> r,s' end | Etry(e1,el) -> begin let r = eval_expr env s e1 in match r with | Excep(ex,t), s' -> let rec find_exc l = match l with | [] -> r | (xs,pvs,e2)::rem -> if xs_equal ex xs then let env' = bind_vs pvs.pv_vs t env in eval_expr env' s' e2 else find_exc rem in find_exc el | _ -> r end | Eloop(_inv,_var,e1) -> begin let r = eval_expr env s e1 in match r with | Normal _, s' -> eval_expr env s' e | _ -> r end | Efor(pvs,(pvs1,dir,pvs2),_inv,e1) -> begin try let a = big_int_of_value (get_pvs env (*s*) pvs1) in let b = big_int_of_value (get_pvs env (*s*) pvs2) in let le,suc = match dir with | To -> BigInt.le, BigInt.succ | DownTo -> BigInt.ge, BigInt.pred in let rec iter i s = Debug.dprintf debug "[interp] for loop with index = %s@." (BigInt.to_string i); if le i b then let env' = bind_vs pvs.pv_vs (Vnum i) env in match eval_expr env' s e1 with | Normal _,s' -> iter (suc i) s' | r -> r else Normal Vvoid, s in iter a s with NotNum -> Irred e,s end | Ecase(e1,ebl) -> begin match eval_expr env s e1 with | Normal t, s' -> begin try exec_match env t s' ebl with Undetermined -> Irred e, s end | r -> r end | Eassign(_pl,_e1,reg,pvs) -> (* eprintf "@[[interp]before@ @[%a@]:@ regenv =@ %a@ state=@ %a@]@." p_expr e print_regenv env.regenv print_state s; *) let t = get_pvs env pvs in let r = get_reg env reg in (* eprintf "updating region <%a> with value %a@." Mlw_pretty.print_reg r print_value t; *) let _ = try Mreg.find r s with Not_found -> Format.eprintf "region %a not found@." Mlw_pretty.print_reg r; assert false in let s' = Mreg.add r t s in (* eprintf "@[[interp]after@ @[%a@]: state=@ %a@]@." p_expr e print_state s; *) Normal Vvoid, s' | Eassert(_,t) -> (* TODO: do not eval t if no assertion check *) if true then (* noassert *) Normal Vvoid, s else begin match (eval_term env s t) with | Vbool true -> Normal Vvoid, s | Vbool false -> eprintf "@[Assertion failed at %a@]@." (Pp.print_option Pretty.print_loc) e.e_loc; Irred e, s | _ -> Warning.emit "@[Warning: assertion cannot be evaluated at %a@]@." (Pp.print_option Pretty.print_loc) e.e_loc; Normal Vvoid, s end | Eghost e1 -> (* TODO: do not eval ghost if no assertion check *) eval_expr env s e1 | Erec (defs,e1) -> let env' = { env with funenv = List.fold_left (fun acc d -> Mps.add d.fun_ps d acc) env.funenv defs } in eval_expr env' s e1 | Eany _ | Eabstr _ | Eabsurd -> eprintf "@[[Exec] unsupported expression: @[%a@]@]@." (if Debug.test_flag debug then p_expr else Mlw_pretty.print_expr) e; Irred e, s and exec_match env t s ebl = let rec iter ebl = match ebl with | [] -> eprintf "[Exec] Pattern matching not exhaustive in evaluation@."; assert false | (p,e)::rem -> try let env' = matching env t p.ppat_pattern in eval_expr env' s e with NoMatch -> iter rem in iter ebl and exec_app env s ps args (*spec*) ity_result = let args' = List.rev_map (fun pvs -> get_pvs env (*s*) pvs) args in let args_ty = List.rev_map (fun pvs -> pvs.pv_ity) args in let subst = Mlw_ty.aty_vars_match ps.ps_subst ps.ps_aty args_ty ity_result in let subst = subst.ity_subst_reg in let subst = (* remove superfluous substitutions *) Mreg.filter (fun r1 r2 -> not (reg_equal r1 r2)) subst in let env1 = { env with regenv = (* Mreg.union (fun _ x _ -> Some x) subst env.regenv } *) Mreg.set_union subst env.regenv } in match find_definition env ps with | Some d -> let lam = d.fun_lambda in let env' = multibind_pvs lam.l_args args' env1 in Debug.dprintf debug "@[Evaluating function body of %s in regenv:@\n%a@\nand state:@\n%a@]@." ps.ps_name.Ident.id_string print_regenv env'.regenv print_state s; let r,s' = eval_expr env' s lam.l_expr in Debug.dprintf debug "@[Return from function %s@ result@ %a in state:@\n%a@]@." ps.ps_name.Ident.id_string (print_result env s') r print_state s'; r,s' | None -> let f = try Hps.find builtin_progs ps with Not_found -> eprintf "[Exec] definition of psymbol %s not found@." ps.ps_name.Ident.id_string; raise CannotCompute in Debug.dprintf debug "@[Evaluating builtin function %s in regenv:@\n%a@\nand state:@\n%a@]@." ps.ps_name.Ident.id_string print_regenv env1.regenv print_state s; let r,s' = f env1 (*spec*) s (VTvalue ity_result) args' in Debug.dprintf debug "@[Return from builtin function %s result %a in state:@\n%a@]@." ps.ps_name.Ident.id_string (print_result env s') r print_state s'; r, s' let eval_global_expr env mkm tkm _writes e = (* eprintf "@[[interp] eval_global_expr:@ %a@]@." p_expr e; *) get_builtins env; get_builtin_progs env; let env = { mknown = mkm; tknown = tkm; funenv = Mps.empty; regenv = Mreg.empty; vsenv = Mvs.empty; } in let add_glob _ d ((venv,renv) as acc) = match d.Mlw_decl.pd_node with | Mlw_decl.PDval (Mlw_expr.LetV pvs) when not (pv_equal pvs Mlw_decl.pv_old) -> let ity = pvs.pv_ity in let v = any_value_of_type env (ty_of_ity ity) in let renv,v = to_program_value env renv (VTvalue ity) v in (Mvs.add pvs.pv_vs v venv,renv) | _ -> acc in let init_env,init_state = Ident.Mid.fold add_glob mkm (Mvs.empty,Mreg.empty) in let env = { mknown = mkm; tknown = tkm; funenv = Mps.empty; regenv = Mreg.empty; vsenv = init_env; } in let res,st = eval_expr env init_state e in let final_env = Mvs.map (fun v -> to_logic_value env st v) init_env in let res = to_logic_result env st res in res, final_env let eval_global_symbol env m fmt d = let lam = d.Mlw_expr.fun_lambda in match lam.Mlw_expr.l_args with | [pvs] when Mlw_ty.ity_equal pvs.Mlw_ty.pv_ity Mlw_ty.ity_unit -> begin let spec = lam.Mlw_expr.l_spec in let eff = spec.Mlw_ty.c_effect in let writes = eff.Mlw_ty.eff_writes in let body = lam.Mlw_expr.l_expr in fprintf fmt "@[ type:@ %a@]@." Mlw_pretty.print_vty body.Mlw_expr.e_vty; (* printf "effect: %a@\n" *) (* Mlw_pretty.print_effect body.Mlw_expr.e_effect; *) let res, final_env = eval_global_expr env m.Mlw_module.mod_known m.Mlw_module.mod_theory.Theory.th_known writes lam.Mlw_expr.l_expr in match res with | Normal _ -> fprintf fmt "@[ result:@ %a@\nglobals:@ %a@]@." print_logic_result res print_vsenv final_env (* fprintf fmt "@[ result:@ %a@\nstate :@ %a@]@." (print_result m.Mlw_module.mod_known m.Mlw_module.mod_theory.Theory.th_known st) res print_state st *) | Excep _ -> fprintf fmt "@[exceptional result:@ %a@\nglobals:@ %a@]@." print_logic_result res print_vsenv final_env; (* fprintf fmt "@[exceptional result:@ %a@\nstate:@ %a@]@." (print_result m.Mlw_module.mod_known m.Mlw_module.mod_theory.Theory.th_known st) res print_state st; *) exit 1 | Irred _ | Fun _ -> fprintf fmt "@\n@]@."; eprintf "Execution error: %a@." print_logic_result res; exit 2 end | _ -> eprintf "Only functions with one unit argument can be executed.@."; exit 1 (* Local Variables: compile-command: "unset LANG; make -C ../.. bin/why3.byte" End: *) why3-0.88.3/src/whyml/mlw_ocaml.mli0000664000175100017510000000211713225666037017661 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (* OCaml program extraction *) val debug: Debug.flag val extract_filename: ?fname:string -> Theory.theory -> string val extract_theory: Mlw_driver.driver -> ?old:Pervasives.in_channel -> ?fname:string -> Format.formatter -> Theory.theory -> unit val extract_module: Mlw_driver.driver -> ?old:Pervasives.in_channel -> ?fname:string -> Format.formatter -> Mlw_module.modul -> unit why3-0.88.3/src/whyml/mlw_ty.ml0000664000175100017510000007762513225666037017071 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Stdlib open Ident open Ty open Term (** value types (w/o effects) *) module rec T : sig type varset = { vars_tv : Stv.t; vars_reg : Reg.S.t; } type itysymbol = { its_ts : tysymbol; its_regs : region list; its_def : ity option; its_ghrl : bool list; its_inv : bool; its_abst : bool; its_priv : bool; } and ity = { ity_node : ity_node; ity_vars : varset; ity_tag : Weakhtbl.tag; } and ity_node = | Ityvar of tvsymbol | Itypur of tysymbol * ity list | Ityapp of itysymbol * ity list * region list and region = { reg_name : ident; reg_ity : ity; } end = struct type varset = { vars_tv : Stv.t; vars_reg : Reg.S.t; } type itysymbol = { its_ts : tysymbol; its_regs : region list; its_def : ity option; its_ghrl : bool list; its_inv : bool; its_abst : bool; its_priv : bool; } and ity = { ity_node : ity_node; ity_vars : varset; ity_tag : Weakhtbl.tag; } and ity_node = | Ityvar of tvsymbol | Itypur of tysymbol * ity list | Ityapp of itysymbol * ity list * region list and region = { reg_name : ident; reg_ity : ity; } end and Reg : sig module M : Extmap.S with type key = T.region module S : Extset.S with module M = M module H : Exthtbl.S with type key = T.region module W : Weakhtbl.S with type key = T.region end = MakeMSHW (struct type t = T.region let tag r = r.T.reg_name.id_tag end) open T (** regions *) module Sreg = Reg.S module Mreg = Reg.M module Hreg = Reg.H module Wreg = Reg.W let reg_equal : region -> region -> bool = (==) let reg_hash r = id_hash r.reg_name let create_region id ty = { reg_name = id_register id; reg_ity = ty } (* variable sets *) let vars_empty = { vars_tv = Stv.empty ; vars_reg = Sreg.empty } let vars_union s1 s2 = { vars_tv = Stv.union s1.vars_tv s2.vars_tv; vars_reg = Sreg.union s1.vars_reg s2.vars_reg; } (* value type symbols *) module Itsym = MakeMSHW (struct type t = itysymbol let tag its = its.its_ts.ts_name.id_tag end) module Sits = Itsym.S module Mits = Itsym.M module Hits = Itsym.H module Wits = Itsym.W let its_equal : itysymbol -> itysymbol -> bool = (==) let ity_equal : ity -> ity -> bool = (==) let its_hash its = id_hash its.its_ts.ts_name let ity_hash ity = Weakhtbl.tag_hash ity.ity_tag module Hsity = Hashcons.Make (struct type t = ity let equal ity1 ity2 = match ity1.ity_node, ity2.ity_node with | Ityvar n1, Ityvar n2 -> tv_equal n1 n2 | Itypur (s1,l1), Itypur (s2,l2) -> ts_equal s1 s2 && List.for_all2 ity_equal l1 l2 | Ityapp (s1,l1,r1), Ityapp (s2,l2,r2) -> its_equal s1 s2 && List.for_all2 ity_equal l1 l2 && List.for_all2 reg_equal r1 r2 | _ -> false let hash ity = match ity.ity_node with | Ityvar v -> tv_hash v | Itypur (s,tl) -> Hashcons.combine_list ity_hash (ts_hash s) tl | Ityapp (s,tl,rl) -> Hashcons.combine_list reg_hash (Hashcons.combine_list ity_hash (its_hash s) tl) rl let ity_vars s ity = vars_union s ity.ity_vars let reg_vars s r = { s with vars_reg = Sreg.add r s.vars_reg } let vars ity = match ity.ity_node with | Ityvar v -> { vars_tv = Stv.singleton v; vars_reg = Sreg.empty } | Itypur (_,tl) -> List.fold_left ity_vars vars_empty tl | Ityapp (_,tl,rl) -> List.fold_left reg_vars (List.fold_left ity_vars vars_empty tl) rl let tag n ity = { ity with ity_vars = vars ity; ity_tag = Weakhtbl.create_tag n } end) module Ity = MakeMSHW (struct type t = ity let tag ity = ity.ity_tag end) module Sity = Ity.S module Mity = Ity.M module Hity = Ity.H module Wity = Ity.W let mk_ity n = { ity_node = n; ity_vars = vars_empty; ity_tag = Weakhtbl.dummy_tag; } let ity_var n = Hsity.hashcons (mk_ity (Ityvar n)) let ity_pur_unsafe s tl = Hsity.hashcons (mk_ity (Itypur (s,tl))) let ity_app_unsafe s tl rl = Hsity.hashcons (mk_ity (Ityapp (s,tl,rl))) (* generic traversal functions *) let ity_map fn ity = match ity.ity_node with | Ityvar _ -> ity | Itypur (f,tl) -> ity_pur_unsafe f (List.map fn tl) | Ityapp (f,tl,rl) -> ity_app_unsafe f (List.map fn tl) rl let ity_fold fn acc ity = match ity.ity_node with | Ityvar _ -> acc | Itypur (_,tl) | Ityapp (_,tl,_) -> List.fold_left fn acc tl let ity_all pr ity = Util.all ity_fold pr ity let ity_any pr ity = Util.any ity_fold pr ity (* symbol-wise map/fold *) let rec ity_s_fold fn fts acc ity = match ity.ity_node with | Ityvar _ -> acc | Itypur (ts, tl) -> List.fold_left (ity_s_fold fn fts) (fts acc ts) tl | Ityapp (f, tl, rl) -> let acc = List.fold_left (ity_s_fold fn fts) (fn acc f) tl in List.fold_left (fun acc r -> ity_s_fold fn fts acc r.reg_ity) acc rl let ity_s_all pr pts ity = Util.alld ity_s_fold pr pts ity let ity_s_any pr pts ity = Util.anyd ity_s_fold pr pts ity (* traversal functions on type variables and regions *) let rec ity_v_map fnv fnr ity = match ity.ity_node with | Ityvar v -> fnv v | Itypur (f,tl) -> ity_pur_unsafe f (List.map (ity_v_map fnv fnr) tl) | Ityapp (f,tl,rl) -> ity_app_unsafe f (List.map (ity_v_map fnv fnr) tl) (List.map fnr rl) let ity_subst_unsafe mv mr ity = ity_v_map (fun v -> Mtv.find v mv) (fun r -> Mreg.find r mr) ity let ity_closed ity = Stv.is_empty ity.ity_vars.vars_tv let ity_immutable ity = Sreg.is_empty ity.ity_vars.vars_reg let rec ity_has_inv ity = match ity.ity_node with | Ityapp (its,_,_) -> its.its_inv || ity_any ity_has_inv ity | _ -> ity_any ity_has_inv ity let rec reg_fold fn vars acc = let on_reg r acc = reg_fold fn r.reg_ity.ity_vars (fn r acc) in Sreg.fold on_reg vars.vars_reg acc let rec reg_all fn vars = let on_reg r = fn r && reg_all fn r.reg_ity.ity_vars in Sreg.for_all on_reg vars.vars_reg let rec reg_any fn vars = let on_reg r = fn r || reg_any fn r.reg_ity.ity_vars in Sreg.exists on_reg vars.vars_reg let rec reg_iter fn vars = let on_reg r = fn r; reg_iter fn r.reg_ity.ity_vars in Sreg.iter on_reg vars.vars_reg let reg_occurs r vars = reg_any (reg_equal r) vars (* detect non-ghost type variables and regions *) let rec fold_nonghost on_reg acc ity = let fn = fold_nonghost on_reg in if ity_immutable ity then acc else match ity.ity_node with | Ityvar _ -> acc | Itypur (_,tl) -> List.fold_left fn acc tl | Ityapp ({ its_ghrl = ghrl },tl,rl) -> let acc = List.fold_left fn acc tl in List.fold_left2 (fun s gh ({ reg_ity = ity } as r) -> if gh then s else fn (on_reg r s) ity) acc ghrl rl let ity_nonghost_reg regs ity = fold_nonghost Sreg.add regs ity let lookup_nonghost_reg regs ity = if reg_any (fun r -> Sreg.mem r regs) ity.ity_vars then try fold_nonghost (fun r acc -> if Sreg.mem r regs then raise Util.FoldSkip else acc) false ity with Util.FoldSkip -> true else false (* smart constructors *) exception BadItyArity of itysymbol * int exception BadRegArity of itysymbol * int exception DuplicateRegion of region exception UnboundRegion of region type ity_subst = { ity_subst_tv : ity Mtv.t; ity_subst_reg : region Mreg.t; (* must preserve ghost-ness *) } let ity_subst_empty = { ity_subst_tv = Mtv.empty; ity_subst_reg = Mreg.empty; } exception RegionMismatch of region * region * ity_subst exception TypeMismatch of ity * ity * ity_subst let ity_equal_check ty1 ty2 = if not (ity_equal ty1 ty2) then raise (TypeMismatch (ty1,ty2,ity_subst_empty)) let reg_equal_check r1 r2 = if not (reg_equal r1 r2) then raise (RegionMismatch (r1,r2,ity_subst_empty)) let reg_full_inst s r = Mreg.find r s.ity_subst_reg let ity_full_inst s ity = if ity_closed ity && ity_immutable ity then ity else ity_subst_unsafe s.ity_subst_tv s.ity_subst_reg ity let rec ity_match s ity1 ity2 = let set = function | None -> Some ity2 | Some ity3 as r when ity_equal ity3 ity2 -> r | _ -> raise Exit in match ity1.ity_node, ity2.ity_node with | Ityapp (s1, l1, r1), Ityapp (s2, l2, r2) when its_equal s1 s2 -> let s = List.fold_left2 ity_match s l1 l2 in List.fold_left2 reg_match s r1 r2 | Itypur (s1, l1), Itypur (s2, l2) when ts_equal s1 s2 -> List.fold_left2 ity_match s l1 l2 | Ityvar tv1, _ -> { s with ity_subst_tv = Mtv.change set tv1 s.ity_subst_tv } | _ -> raise Exit and reg_match s r1 r2 = let is_new = ref false in let set = function | None -> is_new := true; Some r2 | Some r3 as r when reg_equal r3 r2 -> r | _ -> raise Exit in let reg_map = Mreg.change set r1 s.ity_subst_reg in let s = { s with ity_subst_reg = reg_map } in if !is_new then ity_match s r1.reg_ity r2.reg_ity else s let ity_match s ity1 ity2 = try ity_match s ity1 ity2 with Exit -> raise (TypeMismatch (ity1,ity2,s)) let reg_match s r1 r2 = try reg_match s r1 r2 with Exit -> raise (RegionMismatch (r1,r2,s)) let rec ty_of_ity ity = match ity.ity_node with | Ityvar v -> ty_var v | Itypur (s,tl) -> ty_app s (List.map ty_of_ity tl) | Ityapp (s,tl,_) -> ty_app s.its_ts (List.map ty_of_ity tl) let rec ity_of_ty ty = match ty.ty_node with | Tyvar v -> ity_var v | Tyapp (s,tl) -> ity_pur_unsafe s (List.map ity_of_ty tl) let rec ity_inst_fresh mv mr ity = match ity.ity_node with | Ityvar v -> mr, Mtv.find v mv | Itypur (s,tl) -> let mr,tl = Lists.map_fold_left (ity_inst_fresh mv) mr tl in mr, ity_pur_unsafe s tl | Ityapp (s,tl,rl) -> let mr,tl = Lists.map_fold_left (ity_inst_fresh mv) mr tl in let mr,rl = Lists.map_fold_left (reg_refresh mv) mr rl in mr, ity_app_unsafe s tl rl and reg_refresh mv mr r = match Mreg.find_opt r mr with | Some r -> mr, r | None -> let mr,ity = ity_inst_fresh mv mr r.reg_ity in let id = id_clone r.reg_name in let reg = create_region id ity in Mreg.add r reg mr, reg let ity_app_fresh s tl = (* type variable map *) let mv = try List.fold_right2 Mtv.add s.its_ts.ts_args tl Mtv.empty with | Invalid_argument _ -> raise (BadItyArity (s, List.length tl)) in (* refresh regions *) let mr,rl = Lists.map_fold_left (reg_refresh mv) Mreg.empty s.its_regs in let sub = { ity_subst_tv = mv; ity_subst_reg = mr } in (* every top region in def is guaranteed to be in mr *) match s.its_def with | Some ity -> ity_full_inst sub ity | None -> ity_app_unsafe s tl rl let ity_app s tl rl = (* type variable map *) let mv = try List.fold_right2 Mtv.add s.its_ts.ts_args tl Mtv.empty with | Invalid_argument _ -> raise (BadItyArity (s, List.length tl)) in (* region map *) let sub = { ity_subst_tv = mv; ity_subst_reg = Mreg.empty } in let sub = try List.fold_left2 reg_match sub s.its_regs rl with | Invalid_argument _ -> raise (BadRegArity (s, List.length rl)) in (* every type var and top region in def are in its_ts.ts_args and its_regs *) match s.its_def with | Some ity -> ity_full_inst sub ity | None -> ity_app_unsafe s tl rl let ity_pur s tl = (* type variable map *) let mv = try List.fold_right2 Mtv.add s.ts_args tl Mtv.empty with | Invalid_argument _ -> raise (Ty.BadTypeArity (s, List.length tl)) in let sub = { ity_subst_tv = mv; ity_subst_reg = Mreg.empty } in (* every top region in def is guaranteed to be in mr *) match s.ts_def with | Alias ty -> ity_full_inst sub (ity_of_ty ty) | _ -> ity_pur_unsafe s tl (* itysymbol creation *) let create_itysymbol_unsafe, restore_its = let ts_to_its = Wts.create 17 in (fun ts ~abst ~priv ~inv ~ghrl regs def -> let its = { its_ts = ts; its_regs = regs; its_def = def; its_ghrl = ghrl; its_inv = inv; its_abst = abst; its_priv = priv; } in Wts.set ts_to_its ts its; its), Wts.find ts_to_its let create_itysymbol name ?(abst=false) ?(priv=false) ?(inv=false) ?(ghost_reg=Sreg.empty) args regs def = let puredef = match def with | Some def -> Alias (ty_of_ity def) | None -> NoDef in let purets = create_tysymbol name args puredef in (* all regions *) let add s r = Sreg.add_new (DuplicateRegion r) r s in let sregs = List.fold_left add Sreg.empty regs in (* all type variables *) let sargs = List.fold_right Stv.add args Stv.empty in (* all type variables in [regs] must be in [args] *) let check dtvs = if not (Stv.subset dtvs sargs) then raise (UnboundTypeVar (Stv.choose (Stv.diff dtvs sargs))) in List.iter (fun r -> check r.reg_ity.ity_vars.vars_tv) regs; (* all regions in [def] must be in [regs] *) let check dregs = if not (Sreg.subset dregs sregs) then raise (UnboundRegion (Sreg.choose (Sreg.diff dregs sregs))) in Opt.iter (fun d -> check d.ity_vars.vars_reg) def; (* if a type is an alias then it cannot be abstract or private *) if def <> None then begin if abst then Loc.errorm "Type aliases cannot be abstract"; if priv then Loc.errorm "Type aliases cannot be private"; if inv then Loc.errorm "Type aliases cannot have invariants" end; (* every ghost region argument must be in [regs] *) if not (Sreg.subset ghost_reg sregs) then invalid_arg "Mlw_ty.create_itysymbol"; Opt.iter (fun ity -> let nogh = ity_nonghost_reg Sreg.empty ity in if Sreg.exists (fun r -> Sreg.mem r ghost_reg) nogh then invalid_arg "Mlw_ty.create_itysymbol") def; let ghrl = List.map (fun r -> Sreg.mem r ghost_reg) regs in (* create the type symbol *) create_itysymbol_unsafe purets ~abst ~priv ~inv ~ghrl regs def let ts_unit = ts_tuple 0 let ty_unit = ty_tuple [] let ity_int = ity_of_ty Ty.ty_int let ity_real = ity_of_ty Ty.ty_real let ity_bool = ity_of_ty Ty.ty_bool let ity_unit = ity_of_ty ty_unit let vars_freeze s = let sbs = Stv.fold (fun v -> Mtv.add v (ity_var v)) s.vars_tv Mtv.empty in let sbs = { ity_subst_tv = sbs ; ity_subst_reg = Mreg.empty } in Sreg.fold (fun r s -> reg_match s r r) s.vars_reg sbs (** cloning *) let its_clone sm = let itsh = Hits.create 3 in let regh = Hreg.create 3 in let rec add_ts oits nts = let nits = try restore_its nts with Not_found -> let abst = oits.its_abst in let priv = oits.its_priv in let ghrl = oits.its_ghrl in let inv = oits.its_inv in let regs = List.map conv_reg oits.its_regs in let def = Opt.map conv_ity oits.its_def in create_itysymbol_unsafe nts ~abst ~priv ~inv ~ghrl regs def in Hits.replace itsh oits nits; nits and conv_reg r = try Hreg.find regh r with Not_found -> let ity = conv_ity r.reg_ity in let nr = create_region (id_clone r.reg_name) ity in Hreg.replace regh r nr; nr and conv_ity ity = match ity.ity_node with | Ityapp (its,tl,rl) -> let tl = List.map conv_ity tl in let rl = List.map conv_reg rl in ity_app (conv_its its) tl rl | Itypur (ts,tl) -> let tl = List.map conv_ity tl in ity_pur (conv_ts ts) tl | Ityvar _ -> ity and conv_its its = try Hits.find itsh its with Not_found -> try add_ts its (Mts.find its.its_ts sm.Theory.sm_ts) with Not_found -> its and conv_ts ts = Mts.find_def ts ts sm.Theory.sm_ts in let add_ts ots nts = try ignore (add_ts (restore_its ots) nts) with Not_found -> () in Mts.iter add_ts sm.Theory.sm_ts; Hits.fold Mits.add itsh Mits.empty, Hreg.fold Mreg.add regh Mreg.empty (** computation types (with effects) *) (* exception symbols *) type xsymbol = { xs_name : ident; xs_ity : ity; (* closed and pure *) } exception PolymorphicException of ident * ity exception MutableException of ident * ity let xs_equal : xsymbol -> xsymbol -> bool = (==) let create_xsymbol id ity = let id = id_register id in if not (ity_closed ity) then raise (PolymorphicException (id, ity)); if not (ity_immutable ity) then raise (MutableException (id, ity)); { xs_name = id; xs_ity = ity; } module Exn = MakeMSH (struct type t = xsymbol let tag xs = Weakhtbl.tag_hash xs.xs_name.id_tag end) module Sexn = Exn.S module Mexn = Exn.M (* effects *) type effect = { eff_writes : Sreg.t; eff_raises : Sexn.t; eff_ghostw : Sreg.t; (* ghost writes *) eff_ghostx : Sexn.t; (* ghost raises *) (* if r1 -> Some r2 then r1 appears in ty(r2) *) eff_resets : region option Mreg.t; eff_compar : Stv.t; eff_diverg : bool; } let eff_empty = { eff_writes = Sreg.empty; eff_raises = Sexn.empty; eff_ghostw = Sreg.empty; eff_ghostx = Sexn.empty; eff_resets = Mreg.empty; eff_compar = Stv.empty; eff_diverg = false; } let eff_is_empty e = Sreg.is_empty e.eff_writes && Sexn.is_empty e.eff_raises && Sreg.is_empty e.eff_ghostw && Sexn.is_empty e.eff_ghostx && Mreg.is_empty e.eff_resets && (* eff_compar is not a side effect *) not e.eff_diverg let eff_equal e1 e2 = Sreg.equal e1.eff_writes e2.eff_writes && Sexn.equal e1.eff_raises e2.eff_raises && Sreg.equal e1.eff_ghostw e2.eff_ghostw && Sexn.equal e1.eff_ghostx e2.eff_ghostx && Mreg.equal (Opt.equal reg_equal) e1.eff_resets e2.eff_resets && Stv.equal e1.eff_compar e2.eff_compar && e1.eff_diverg = e2.eff_diverg let join_reset _key v1 v2 = match v1, v2 with | Some r1, Some r2 -> if reg_equal r1 r2 then Some v1 else if reg_occurs r1 r2.reg_ity.ity_vars then Some v2 else if reg_occurs r2 r1.reg_ity.ity_vars then Some v1 else Some None | _ -> Some None let eff_union x y = { eff_writes = Sreg.union x.eff_writes y.eff_writes; eff_raises = Sexn.union x.eff_raises y.eff_raises; eff_ghostw = Sreg.union x.eff_ghostw y.eff_ghostw; eff_ghostx = Sexn.union x.eff_ghostx y.eff_ghostx; eff_resets = Mreg.union join_reset x.eff_resets y.eff_resets; eff_compar = Stv.union x.eff_compar y.eff_compar; eff_diverg = x.eff_diverg || y.eff_diverg; } exception GhostDiverg let eff_ghostify e = { eff_writes = Sreg.empty; eff_raises = Sexn.empty; eff_ghostw = Sreg.union e.eff_writes e.eff_ghostw; eff_ghostx = Sexn.union e.eff_raises e.eff_ghostx; eff_resets = e.eff_resets; eff_compar = e.eff_compar; (* from the code extraction point of view, we can allow comparing opaque types in the ghost code, as it is never extracted. However, if we consider Coq realisations, we have to treat some pure types (e.g., maps) as opaque, too, and never compare them even in pure formulas. Therefore, we play safe and forbid comparison of opaque types in the ghost code. *) eff_diverg = if e.eff_diverg then raise GhostDiverg else false; } let eff_ghostify gh e = if gh then eff_ghostify e else e let eff_write e ?(ghost=false) r = if ghost then { e with eff_ghostw = Sreg.add r e.eff_ghostw } else { e with eff_writes = Sreg.add r e.eff_writes } let eff_raise e ?(ghost=false) x = if ghost then { e with eff_ghostx = Sexn.add x e.eff_ghostx } else { e with eff_raises = Sexn.add x e.eff_raises } let eff_reset e r = { e with eff_resets = Mreg.add r None e.eff_resets } let eff_compare e tv = { e with eff_compar = Stv.add tv e.eff_compar } let eff_diverge e = { e with eff_diverg = true } exception IllegalAlias of region exception IllegalCompar of tvsymbol * ity let eff_refresh e r u = if not (reg_occurs r u.reg_ity.ity_vars) then invalid_arg "Mlw_ty.eff_refresh"; let reset = Mreg.singleton r (Some u) in { e with eff_resets = Mreg.union join_reset e.eff_resets reset } let eff_assign e ?(ghost=false) r ty = let e = eff_write e ~ghost r in let sub = ity_match ity_subst_empty r.reg_ity ty in (* assignment cannot instantiate type variables *) let check tv ity = match ity.ity_node with | Ityvar tv' -> tv_equal tv tv' | _ -> false in if not (Mtv.for_all check sub.ity_subst_tv) then raise (TypeMismatch (r.reg_ity,ty,ity_subst_empty)); (* r:t[r1,r2] <- t[r1,r1] introduces an alias *) let add_right _ v s = Sreg.add_new (IllegalAlias v) v s in ignore (Mreg.fold add_right sub.ity_subst_reg Sreg.empty); (* every region on the rhs must be erased *) let add_right k v m = if reg_equal k v then m else Mreg.add v None m in let reset = Mreg.fold add_right sub.ity_subst_reg Mreg.empty in (* ...except those which occur on the lhs : they are preserved under r *) let add_left k v m = if reg_equal k v then m else Mreg.add k (Some r) m in let reset = Mreg.fold add_left sub.ity_subst_reg reset in { e with eff_resets = Mreg.union join_reset e.eff_resets reset } let eff_remove_raise e x = { e with eff_raises = Sexn.remove x e.eff_raises; eff_ghostx = Sexn.remove x e.eff_ghostx; } let eff_full_inst sbs e = let s = sbs.ity_subst_reg in (* modified or reset regions in e *) let wr = Mreg.map (Util.const ()) e.eff_resets in let wr = Sreg.union e.eff_writes wr in let wr = Sreg.union e.eff_ghostw wr in (* read-only regions in e *) let ro = Sreg.diff (Mreg.map (Util.const ()) s) wr in (* all modified or reset regions are instantiated into distinct regions *) let add_affected r acc = let r = Mreg.find r s in Sreg.add_new (IllegalAlias r) r acc in let wr = Sreg.fold add_affected wr Sreg.empty in (* all read-only regions are instantiated outside wr *) let add_readonly r = let r = Mreg.find r s in if Sreg.mem r wr then raise (IllegalAlias r) in Sreg.iter add_readonly ro; (* all type variables are instantiated outside wr *) let check_tv _ ity = Sreg.iter (fun r -> if reg_occurs r ity.ity_vars then raise (IllegalAlias r)) wr in Mtv.iter check_tv sbs.ity_subst_tv; (* calculate instantiated effect *) let add_sreg r acc = Sreg.add (Mreg.find r s) acc in let add_mreg r v acc = Mreg.add (Mreg.find r s) (Opt.map (fun v -> Mreg.find v s) v) acc in (* compute compared type variables *) let add_stv tv acc = let ity = Mtv.find tv sbs.ity_subst_tv in let check () _ = raise (IllegalCompar (tv,ity)) in ity_s_fold check (fun () _ -> ()) () ity; Stv.union acc ity.ity_vars.vars_tv in { e with eff_writes = Sreg.fold add_sreg e.eff_writes Sreg.empty; eff_ghostw = Sreg.fold add_sreg e.eff_ghostw Sreg.empty; eff_resets = Mreg.fold add_mreg e.eff_resets Mreg.empty; eff_compar = Stv.fold add_stv e.eff_compar Stv.empty; } let eff_filter vars e = let check r = reg_occurs r vars in let reset r = function | _ when not (check r) -> None | Some u as v when check u -> Some v | _ -> Some None in { e with eff_writes = Sreg.filter check e.eff_writes; eff_ghostw = Sreg.filter check e.eff_ghostw; eff_resets = Mreg.mapi_filter reset e.eff_resets; eff_compar = Stv.inter vars.vars_tv e.eff_compar; } let eff_stale_region eff vars = let check_reset r u = let rec check_reg reg = reg_equal r reg || match u with | Some u when reg_equal u reg -> false | _ -> Sreg.exists check_reg reg.reg_ity.ity_vars.vars_reg in Sreg.exists check_reg vars.vars_reg in Mreg.exists check_reset eff.eff_resets (** specification *) type pre = term (* precondition: pre_fmla *) type post = term (* postcondition: eps result . post_fmla *) type xpost = post Mexn.t (* exceptional postconditions *) type variant = term * lsymbol option (* tau * (tau -> tau -> prop) *) let create_post vs f = t_eps_close vs f let open_post f = match f.t_node with | Teps bf -> t_open_bound bf | _ -> Loc.errorm "invalid post-condition" let check_post ty f = match f.t_node with | Teps _ -> Ty.ty_equal_check ty (t_type f) | _ -> Loc.errorm "invalid post-condition" type spec = { c_pre : pre; c_post : post; c_xpost : xpost; c_effect : effect; c_variant : variant list; c_letrec : int; } let spec_empty ty = { c_pre = t_true; c_post = create_post (create_vsymbol (id_fresh "dummy") ty) t_true; c_xpost = Mexn.empty; c_effect = eff_empty; c_variant = []; c_letrec = 0; } let spec_full_inst sbs tvm vsm c = let subst = t_ty_subst tvm vsm in { c_pre = subst c.c_pre; c_post = subst c.c_post; c_xpost = Mexn.map subst c.c_xpost; c_effect = eff_full_inst sbs c.c_effect; c_variant = List.map (fun (t,rel) -> subst t, rel) c.c_variant; c_letrec = c.c_letrec; } let spec_subst sbs c = let subst = t_subst sbs in { c_pre = subst c.c_pre; c_post = subst c.c_post; c_xpost = Mexn.map subst c.c_xpost; c_effect = c.c_effect; c_variant = List.map (fun (t,rel) -> subst t, rel) c.c_variant; c_letrec = c.c_letrec; } let spec_vsset c = let add f s = Mvs.set_union (t_vars f) s in let s = add c.c_pre (t_vars c.c_post) in let s = Mexn.fold (fun _ f s -> add f s) c.c_xpost s in List.fold_left (fun s (t,_) -> add t s) s c.c_variant let spec_filter ghost svs vars c = let s = spec_vsset c in if not (Mvs.set_submap s svs) then Loc.errorm "Local variable %s escapes from its scope" (fst (Mvs.choose (Mvs.set_diff s svs))).vs_name.id_string; if not ghost && not (Sexn.is_empty c.c_effect.eff_ghostx) then Loc.errorm "Only ghost functions may raise ghost exceptions"; { c with c_effect = eff_ghostify ghost (eff_filter vars c.c_effect) } exception UnboundException of xsymbol let spec_check ~full_xpost c ty = if c.c_pre.t_ty <> None then Loc.error ?loc:c.c_pre.t_loc (Term.FmlaExpected c.c_pre); check_post ty c.c_post; Mexn.iter (fun xs q -> check_post (ty_of_ity xs.xs_ity) q) c.c_xpost; (* we admit non-empty variant list even for null letrec, so that we can store there external variables from user-written effects to save them from spec_filter *) let check_variant (t,rel) = match rel with | Some ps -> ignore (ps_app ps [t;t]) | None -> ignore (t_type t) in List.iter check_variant c.c_variant; if full_xpost && not (Mexn.set_submap c.c_effect.eff_raises c.c_xpost) then raise (UnboundException (Sexn.choose (Mexn.set_diff c.c_effect.eff_raises c.c_xpost))); if full_xpost && not (Mexn.set_submap c.c_effect.eff_ghostx c.c_xpost) then raise (UnboundException (Sexn.choose (Mexn.set_diff c.c_effect.eff_ghostx c.c_xpost))) (** program variables *) type pvsymbol = { pv_vs : vsymbol; pv_ity : ity; pv_ghost : bool; } module PVsym = MakeMSHW (struct type t = pvsymbol let tag pv = pv.pv_vs.vs_name.id_tag end) module Spv = PVsym.S module Mpv = PVsym.M module Hpv = PVsym.H module Wpv = PVsym.W let pv_equal : pvsymbol -> pvsymbol -> bool = (==) let create_pvsymbol id ghost ity = { pv_vs = create_vsymbol id (ty_of_ity ity); pv_ity = ity; pv_ghost = ghost; } let create_pvsymbol, restore_pv = let vs_to_pv = Wvs.create 17 in (fun id ?(ghost=false) ity -> let pv = create_pvsymbol id ghost ity in Wvs.set vs_to_pv pv.pv_vs pv; pv), (fun vs -> Wvs.find vs_to_pv vs) let pvs_of_vss pvs vss = Mvs.fold (fun vs _ s -> Spv.add (restore_pv vs) s) vss pvs let t_pvset pvs t = pvs_of_vss pvs (t_vars t) let spec_pvset pvs spec = pvs_of_vss pvs (spec_vsset spec) (** program types *) type vty = | VTvalue of ity | VTarrow of aty and aty = { aty_args : pvsymbol list; aty_result : vty; aty_spec : spec; } let rec aty_vars aty = let add_arg vars pv = vars_union vars pv.pv_ity.ity_vars in List.fold_left add_arg (vty_vars aty.aty_result) aty.aty_args and vty_vars = function | VTvalue ity -> ity.ity_vars | VTarrow aty -> aty_vars aty let rec aty_pvset aty = let spv = match aty.aty_result with | VTarrow a -> aty_pvset a | VTvalue _ -> Spv.empty in let spv = spec_pvset spv aty.aty_spec in List.fold_right Spv.remove aty.aty_args spv let ity_of_vty = function | VTvalue ity -> ity | VTarrow _ -> ity_unit let ty_of_vty = function | VTvalue ity -> ty_of_ity ity | VTarrow _ -> ty_unit let spec_check ?(full_xpost=true) spec vty = spec_check ~full_xpost spec (ty_of_vty vty) let vty_arrow_unsafe argl spec vty = { aty_args = argl; aty_result = vty; aty_spec = spec; } let vty_arrow argl ?spec vty = let exn = Invalid_argument "Mlw.vty_arrow" in (* the arguments must be all distinct *) if argl = [] then raise exn; let add_arg pvs pv = Spv.add_new exn pv pvs in ignore (List.fold_left add_arg Spv.empty argl); let spec = match spec with | Some spec -> spec_check spec vty; spec | None -> spec_empty (ty_of_vty vty) in vty_arrow_unsafe argl spec vty (* this only compares the types of arguments and results, and ignores the spec. In other words, only the type variables and regions in [aty_vars aty] are matched. The caller should supply a "freezing" substitution that covers all external type variables and regions. *) let rec aty_vars_match s a argl res = let rec match_args s l1 l2 = match l1, l2 with | v1::l1, v2::l2 -> match_args (ity_match s v1.pv_ity v2) l1 l2 | [], l -> s, l | _, [] -> invalid_arg "Mlw_ty.aty_vars_match" in let s, argl = match_args s a.aty_args argl in match a.aty_result, argl with | VTvalue v, [] -> ity_match s v res | VTvalue _, _ | VTarrow _, [] -> invalid_arg "Mlw_ty.aty_vars_match" | VTarrow a, _ -> aty_vars_match s a argl res (* the substitution must cover not only [aty_vars aty] but also every type variable and every region in [aty_spec] *) let aty_full_inst sbs aty = let tvm = Mtv.map ty_of_ity sbs.ity_subst_tv in let pv_inst { pv_vs = vs; pv_ity = ity; pv_ghost = ghost } = create_pvsymbol (id_clone vs.vs_name) ~ghost (ity_full_inst sbs ity) in let add_arg vsm pv = let nv = pv_inst pv in Mvs.add pv.pv_vs (t_var nv.pv_vs) vsm, nv in let rec aty_inst vsm aty = let vsm, args = Lists.map_fold_left add_arg vsm aty.aty_args in let spec = spec_full_inst sbs tvm vsm aty.aty_spec in let vty = match aty.aty_result with | VTarrow aty -> VTarrow (aty_inst vsm aty) | VTvalue ity -> VTvalue (ity_full_inst sbs ity) in vty_arrow_unsafe args spec vty in aty_inst Mvs.empty aty (* remove from the given arrow every inner effect *) let rec aty_filter ghost svs vars aty = let add svs pv = Svs.add pv.pv_vs svs in let svs = List.fold_left add svs aty.aty_args in let add vars pv = vars_union vars pv.pv_ity.ity_vars in let vars = List.fold_left add vars aty.aty_args in (* remove the effects that do not affect the context *) let spec = spec_filter ghost svs vars aty.aty_spec in (* reset every fresh region in the returned value *) let spec = match aty.aty_result with | VTvalue v -> let on_reg r e = if reg_occurs r vars then e else eff_reset e r in { spec with c_effect = reg_fold on_reg v.ity_vars spec.c_effect } | VTarrow _ -> spec in (* filter the result type *) let vty = match aty.aty_result with | VTarrow a -> VTarrow (aty_filter ghost svs vars a) | VTvalue _ -> aty.aty_result in vty_arrow_unsafe aty.aty_args spec vty let aty_filter ?(ghost=false) pvs aty = let add pv svs = Svs.add pv.pv_vs svs in let svs = Spv.fold add pvs Svs.empty in let add pv vars = vars_union vars pv.pv_ity.ity_vars in let vars = Spv.fold add pvs vars_empty in aty_filter ghost svs vars aty let aty_app aty pv = let arg, rest = match aty.aty_args with | arg::rest -> arg,rest | _ -> assert false in ity_equal_check arg.pv_ity pv.pv_ity; let sbs = Mvs.singleton arg.pv_vs (t_var pv.pv_vs) in let rec vty_subst = function | VTarrow a when not (List.exists (pv_equal arg) a.aty_args) -> let result = vty_subst a.aty_result in let spec = spec_subst sbs a.aty_spec in VTarrow (vty_arrow_unsafe a.aty_args spec result) | vty -> vty in let result = vty_subst aty.aty_result in let spec = spec_subst sbs aty.aty_spec in if not pv.pv_ghost && arg.pv_ghost then Loc.errorm "non-ghost value passed as a ghost argument"; let ghost = pv.pv_ghost && not arg.pv_ghost in if rest = [] then spec, ghost, result else spec_empty ty_unit, ghost, VTarrow (vty_arrow_unsafe rest spec result) why3-0.88.3/src/whyml/mlw_pretty.mli0000664000175100017510000000404313225666037020115 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Format open Mlw_ty open Mlw_ty.T open Mlw_expr open Mlw_decl val forget_all : unit -> unit (* flush id_unique *) val forget_regs : unit -> unit (* flush id_unique for regions *) val forget_tvs_regs : unit -> unit (* flush for type vars and regions *) val forget_pv : pvsymbol -> unit (* flush for a program variable *) val forget_ps : psymbol -> unit (* flush for a program symbol *) val print_xs : formatter -> xsymbol -> unit (* exception symbol *) val print_reg : formatter -> region -> unit (* region *) val print_its : formatter -> itysymbol -> unit (* type symbol *) val print_ity : formatter -> ity -> unit (* individual type *) val print_aty : formatter -> aty -> unit (* arrow type *) val print_vty : formatter -> vty -> unit (* expression type *) val print_pv : formatter -> pvsymbol -> unit (* program variable *) val print_pvty : formatter -> pvsymbol -> unit (* pvsymbol : type *) val print_ps : formatter -> psymbol -> unit (* program symbol *) val print_psty : formatter -> psymbol -> unit (* psymbol : type *) val print_effect : formatter -> effect -> unit (* effect *) val print_ppat : formatter -> ppattern -> unit (* program patterns *) val print_expr : formatter -> expr -> unit (* expression *) val print_pdecl : formatter -> pdecl -> unit why3-0.88.3/src/whyml/mlw_pretty.ml0000664000175100017510000004302013225666037017742 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Format open Pp open Ident open Ty open Term open Pretty open Mlw_ty open Mlw_ty.T open Mlw_expr open Mlw_decl let debug_print_labels = Debug.register_info_flag "print_labels" ~desc:"Print@ labels@ of@ identifiers@ and@ expressions." let debug_print_locs = Debug.register_info_flag "print_locs" ~desc:"Print@ locations@ of@ identifiers@ and@ expressions." let debug_print_reg_types = Debug.register_info_flag "print_reg_types" ~desc:"Print@ types@ of@ regions@ (mutable@ fields)." let iprinter = let isanitize = sanitizer char_to_alpha char_to_alnumus in create_ident_printer [] ~sanitizer:isanitize let rprinter = let isanitize = sanitizer char_to_alpha char_to_alnumus in create_ident_printer [] ~sanitizer:isanitize let forget_regs () = Ident.forget_all rprinter let forget_tvs_regs () = Ident.forget_all rprinter; forget_tvs () let forget_all () = Ident.forget_all rprinter; forget_all () (* Labels and locs - copied from Pretty *) let print_labels = print_iter1 Slab.iter space print_label let print_ident_labels fmt id = if Debug.test_flag debug_print_labels && not (Slab.is_empty id.id_label) then fprintf fmt "@ %a" print_labels id.id_label; if Debug.test_flag debug_print_locs then Opt.iter (fprintf fmt "@ %a" print_loc) id.id_loc (* identifiers *) let print_reg fmt reg = fprintf fmt "%s" (id_unique rprinter reg.reg_name) let print_pv fmt pv = fprintf fmt "%s%a" (if pv.pv_ghost then "?" else "") print_vs pv.pv_vs let forget_pv pv = forget_var pv.pv_vs let print_name fmt id = fprintf fmt "%s%a" (id_unique iprinter id) print_ident_labels id let print_xs fmt xs = print_name fmt xs.xs_name let print_ps fmt ps = fprintf fmt "%s%a" (if ps.ps_ghost then "?" else "") print_name ps.ps_name let forget_ps ps = forget_id iprinter ps.ps_name let print_its fmt ts = print_ts fmt ts.its_ts (** Types *) let protect_on x s = if x then "(" ^^ s ^^ ")" else s let rec print_ity_node s pri fmt ity = match ity.ity_node with | Ityvar v -> begin match Mtv.find_opt v s.ity_subst_tv with | Some ity -> print_ity_node ity_subst_empty pri fmt ity | None -> print_tv fmt v end | Itypur (ts,[t1;t2]) when ts_equal ts Ty.ts_func -> fprintf fmt (protect_on (pri > 0) "%a@ ->@ %a") (print_ity_node s 1) t1 (print_ity_node s 0) t2 | Itypur (ts,tl) when is_ts_tuple ts -> fprintf fmt "(%a)" (print_list comma (print_ity_node s 0)) tl | Itypur (ts,[]) -> print_ts fmt ts | Itypur (ts,tl) -> fprintf fmt (protect_on (pri > 1) "%a@ %a") print_ts ts (print_list space (print_ity_node s 2)) tl | Ityapp (ts,[],rl) -> fprintf fmt (protect_on (pri > 1) "%a@ <%a>") print_its ts (print_list comma print_regty) (List.map (fun r -> Mreg.find_def r r s.ity_subst_reg) rl) | Ityapp (ts,tl,rl) -> fprintf fmt (protect_on (pri > 1) "%a@ <%a>@ %a") print_its ts (print_list comma print_regty) (List.map (fun r -> Mreg.find_def r r s.ity_subst_reg) rl) (print_list space (print_ity_node s 2)) tl and print_regty fmt reg = if Debug.test_noflag debug_print_reg_types then print_reg fmt reg else fprintf fmt "@[%a:@,%a@]" print_reg reg print_ity reg.reg_ity and print_ity fmt ity = print_ity_node ity_subst_empty 2 fmt ity let print_reg_opt fmt = function | Some r -> fprintf fmt "<%a>" print_regty r | None -> () let print_effect fmt eff = let print_xs s xs = fprintf fmt "{%s %a}@ " s print_xs xs in let print_reg s r = fprintf fmt "{%s %a}@ " s print_regty r in let print_reset r = function | None -> print_reg "fresh" r | Some u -> fprintf fmt "{refresh %a@ under %a}@ " print_regty r print_regty u in Sreg.iter (print_reg "write") eff.eff_writes; Sexn.iter (print_xs "raise") eff.eff_raises; Sreg.iter (print_reg "ghost write") eff.eff_ghostw; Sexn.iter (print_xs "ghost raise") eff.eff_ghostx; Mreg.iter print_reset eff.eff_resets let rec print_aty fmt aty = let print_arg fmt pv = fprintf fmt "%a ->@ " print_ity pv.pv_ity in fprintf fmt "%a%a%a" (print_list nothing print_arg) aty.aty_args print_effect aty.aty_spec.c_effect print_vty aty.aty_result and print_vty fmt = function | VTarrow aty -> print_aty fmt aty | VTvalue ity -> print_ity fmt ity let print_pvty fmt pv = fprintf fmt "@[%a:@,%a@]" print_pv pv print_ity pv.pv_ity let print_psty fmt ps = let print_tvs fmt tvs = if not (Stv.is_empty tvs) then fprintf fmt "[%a]@ " (print_list comma print_tv) (Stv.elements tvs) in let print_regs fmt regs = if not (Sreg.is_empty regs) then fprintf fmt "<%a>@ " (print_list comma print_regty) (Sreg.elements regs) in let vars = aty_vars ps.ps_aty in fprintf fmt "@[%a :@ %a%a%a@]" print_ps ps print_tvs (Mtv.set_diff vars.vars_tv ps.ps_subst.ity_subst_tv) print_regs (Mreg.set_diff vars.vars_reg ps.ps_subst.ity_subst_reg) print_aty ps.ps_aty (* specification *) let print_post fmt post = let vs,f = open_post post in fprintf fmt "@[%a ->@ %a@]" print_vs vs print_term f; Pretty.forget_var vs let print_lv fmt = function | LetV pv -> print_pvty fmt pv | LetA ps -> print_psty fmt ps let forget_lv = function | LetV pv -> forget_pv pv | LetA ps -> forget_ps ps let rec print_type_v fmt = function | VTvalue ity -> print_ity fmt ity | VTarrow aty -> let print_arg fmt pv = fprintf fmt "@[(%a)@] ->@ " print_pvty pv in fprintf fmt "%a%a" (print_list nothing print_arg) aty.aty_args (print_type_c aty.aty_spec) aty.aty_result; List.iter forget_pv aty.aty_args and print_type_c spec fmt vty = fprintf fmt "{ %a }@ %a%a@ { %a }" print_term spec.c_pre print_effect spec.c_effect print_type_v vty print_post spec.c_post (* TODO: print_xpost *) let print_invariant fmt f = fprintf fmt "invariant@ { %a }@ " Pretty.print_term f let print_variant fmt varl = let print_rel fmt = function | Some ps -> fprintf fmt "@ [%a]" Pretty.print_ls ps | None -> () in let print_var fmt (t, ps) = fprintf fmt " %a%a" Pretty.print_term t print_rel ps in fprintf fmt "variant@ {%a }@ " (print_list comma print_var) varl let print_invariant fmt f = match f.t_node with | Ttrue -> () | _ -> print_invariant fmt f let print_variant fmt = function | [] -> () | varl -> print_variant fmt varl (* expressions *) let print_ppat fmt ppat = print_pat fmt ppat.ppat_pattern let print_ak fmt = function | Aassert -> fprintf fmt "assert" | Aassume -> fprintf fmt "assume" | Acheck -> fprintf fmt "check" let print_list_next sep print fmt = function | [] -> () | [x] -> print true fmt x | x :: r -> print true fmt x; sep fmt (); print_list sep (print false) fmt r let is_letrec = function | [fd] -> fd.fun_lambda.l_spec.c_letrec <> 0 | _ -> true let rec print_expr fmt e = print_lexpr 0 fmt e and print_lexpr pri fmt e = let print_elab pri fmt e = if Debug.test_flag debug_print_labels && not (Slab.is_empty e.e_label) then fprintf fmt (protect_on (pri > 0) "@[%a@ %a@]") print_labels e.e_label (print_enode 0) e else print_enode pri fmt e in let print_eloc pri fmt e = if Debug.test_flag debug_print_locs && e.e_loc <> None then fprintf fmt (protect_on (pri > 0) "@[%a@ %a@]") (print_option print_loc) e.e_loc (print_elab 0) e else print_elab pri fmt e in print_eloc pri fmt e (* and print_app pri ls fmt tl = match extract_op ls, tl with | _, [] -> print_ls fmt ls | Some s, [t1] when tight_op s -> fprintf fmt (protect_on (pri > 7) "%s%a") s (print_lterm 7) t1 | Some s, [t1] -> fprintf fmt (protect_on (pri > 4) "%s %a") s (print_lterm 5) t1 | Some s, [t1;t2] -> fprintf fmt (protect_on (pri > 4) "@[%a %s@ %a@]") (print_lterm 5) t1 s (print_lterm 5) t2 | _, [t1;t2] when ls.ls_name.id_string = "mixfix []" -> fprintf fmt (protect_on (pri > 6) "%a[%a]") (print_lterm 6) t1 print_term t2 | _, [t1;t2;t3] when ls.ls_name.id_string = "mixfix [<-]" -> fprintf fmt (protect_on (pri > 6) "%a[%a <- %a]") (print_lterm 6) t1 (print_lterm 5) t2 (print_lterm 5) t3 | _, tl -> fprintf fmt (protect_on (pri > 5) "@[%a@ %a@]") print_ls ls (print_list space (print_lterm 6)) tl *) and print_enode pri fmt e = match e.e_node with | Elogic t -> fprintf fmt "(%a)" print_term t | Evalue v -> print_pv fmt v | Earrow a -> print_ps fmt a | Eapp (e,v,_) -> fprintf fmt "(%a@ %a)" (print_lexpr pri) e print_pv v | Elet ({ let_sym = LetV pv ; let_expr = e1 }, e2) when pv.pv_vs.vs_name.id_string = "_" && ity_equal pv.pv_ity ity_unit -> fprintf fmt (protect_on (pri > 0) "%a;@\n%a") print_expr e1 print_expr e2; | Elet ({ let_sym = lv ; let_expr = e1 }, e2) -> fprintf fmt (protect_on (pri > 0) "@[let %a =@ %a@ in@]@\n%a") print_lv lv (print_lexpr 4) e1 print_expr e2; forget_lv lv | Erec (fdl, e) -> fprintf fmt (protect_on (pri > 0) "%a@ in@\n%a") (print_list_next newline (print_rec (is_letrec fdl))) fdl print_expr e; List.iter (fun fd -> forget_ps fd.fun_ps) fdl | Eif (e0,e1,e2) -> fprintf fmt (protect_on (pri > 0) "if %a then %a@ else %a") print_expr e0 print_expr e1 print_expr e2 | Eassign (pl,e,r,pv) -> fprintf fmt (protect_on (pri > 0) "%a.%a <%a> <- %a") print_expr e print_ls pl.pl_ls print_regty r print_pv pv | Ecase (e0,bl) -> fprintf fmt "match %a with@\n@[%a@]@\nend" print_expr e0 (print_list newline print_branch) bl | Eloop (inv,var,e) -> fprintf fmt "loop@ %a%a@\n@[%a@]@\nend" print_invariant inv print_variant var print_expr e | Efor (pv,(pvfrom,dir,pvto),inv,e) -> fprintf fmt "@[for@ %a =@ %a@ %s@ %a@ %ado@\n%a@]@\ndone" print_pv pv print_pv pvfrom (if dir = To then "to" else "downto") print_pv pvto print_invariant inv print_expr e | Eraise (xs,e) -> fprintf fmt "raise (%a %a)" print_xs xs print_expr e | Etry (e,bl) -> fprintf fmt "try %a with@\n@[%a@]@\nend" print_expr e (print_list newline print_xbranch) bl | Eabsurd -> fprintf fmt "absurd" | Eassert (ak,f) -> fprintf fmt "%a { %a }" print_ak ak print_term f | Eabstr (e,spec) -> (* TODO: print_spec *) fprintf fmt "abstract %a@ { %a }" print_expr e print_post spec.c_post | Eghost e -> fprintf fmt "ghost@ %a" print_expr e | Eany spec -> fprintf fmt "any@ %a" (print_type_c spec) e.e_vty and print_branch fmt ({ ppat_pattern = p }, e) = fprintf fmt "@[| %a ->@ %a@]" print_pat p print_expr e; Svs.iter forget_var p.pat_vars and print_xbranch fmt (xs, pv, e) = fprintf fmt "@[| %a %a ->@ %a@]" print_xs xs print_pv pv print_expr e; forget_pv pv and print_rec lr fst fmt { fun_ps = ps ; fun_lambda = lam } = let print_arg fmt pv = fprintf fmt "@[(%a)@]" print_pvty pv in fprintf fmt "@[%s (%a)@ %a =@\n{ %a }@\n%a%a@\n{ %a }@]" (if fst then if lr then "let rec" else "let" else "with") print_psty ps (print_list space print_arg) lam.l_args print_term lam.l_spec.c_pre print_variant lam.l_spec.c_variant print_expr lam.l_expr print_post lam.l_spec.c_post (* TODO: print_spec *) (* and print_tl fmt tl = if tl = [] then () else fprintf fmt "@ [%a]" (print_list alt (print_list comma print_term)) tl *) (** Type declarations *) let print_tv_arg fmt tv = fprintf fmt "@ %a" print_tv tv let print_ty_arg fmt ty = fprintf fmt "@ %a" (print_ity_node ity_subst_empty 2) ty let print_constr fmt (cs,pjl) = let print_pj fmt (fd,pj) = match pj with | Some { pl_ls = ls } -> fprintf fmt "@ (%s%s%a%a:@,%a)" (if fd.fd_ghost then "ghost " else "") (if fd.fd_mut <> None then "mutable " else "") print_ls ls print_reg_opt fd.fd_mut print_ity fd.fd_ity | None when fd.fd_ghost || fd.fd_mut <> None -> fprintf fmt "@ (%s%s%a@ %a)" (if fd.fd_ghost then "ghost" else "") (if fd.fd_mut <> None then "mutable " else "") print_reg_opt fd.fd_mut print_ity fd.fd_ity | None -> print_ty_arg fmt fd.fd_ity in fprintf fmt "@[| %a%a%a@]" print_cs cs.pl_ls print_ident_labels cs.pl_ls.ls_name (print_list nothing print_pj) (List.map2 (fun fd pj -> (fd,pj)) cs.pl_args pjl) let print_head fst fmt ts = fprintf fmt "%s %s%s%a%a <%a>%a" (if fst then "type" else "with") (if ts.its_abst then "abstract " else "") (if ts.its_priv then "private " else "") print_its ts print_ident_labels ts.its_ts.ts_name (print_list comma print_regty) ts.its_regs (print_list nothing print_tv_arg) ts.its_ts.ts_args let print_ty_decl fmt ts = match ts.its_def with | None -> fprintf fmt "@[%a@]" (print_head true) ts | Some ty -> fprintf fmt "@[%a =@ %a@]" (print_head true) ts print_ity ty let print_ty_decl fmt ts = print_ty_decl fmt ts; forget_tvs_regs () let print_data_decl fst fmt (ts,csl,inv) = let print_inv fmt inv = if ts.its_inv then fprintf fmt "@ invariant { %a }" print_post inv else () in fprintf fmt "@[%a =@ %a%a@]" (print_head fst) ts (print_list newline print_constr) csl print_inv inv; forget_tvs_regs () let print_val_decl fmt lv = let vty = match lv with | LetV pv -> VTvalue pv.pv_ity | LetA ps -> VTarrow ps.ps_aty in fprintf fmt "@[val (%a) :@ %a@]" print_lv lv print_type_v vty; (* FIXME: forget only generalized regions *) match lv with LetA _ -> forget_tvs_regs () | _ -> () let print_let_decl fmt { let_sym = lv ; let_expr = e } = fprintf fmt "@[let %a =@ %a@]" print_lv lv print_expr e; (* FIXME: forget only generalized regions *) match lv with LetA _ -> forget_tvs_regs () | _ -> () let print_rec_decl lr fst fmt fd = print_rec lr fst fmt fd; forget_tvs_regs () let print_exn_decl fmt xs = fprintf fmt "@[exception %a of@ %a@]" print_xs xs print_ity xs.xs_ity (* Declarations *) let print_pdecl fmt d = match d.pd_node with | PDtype ts -> print_ty_decl fmt ts | PDdata tl -> print_list_next newline print_data_decl fmt tl | PDval vd -> print_val_decl fmt vd | PDlet ld -> print_let_decl fmt ld | PDrec fdl -> print_list_next newline (print_rec_decl (is_letrec fdl)) fmt fdl | PDexn xs -> print_exn_decl fmt xs (* Print exceptions *) let () = Exn_printer.register begin fun fmt exn -> match exn with | Mlw_ty.BadItyArity ({its_ts = {ts_args = []}} as ts, _) -> fprintf fmt "Type symbol %a expects no arguments" print_its ts | Mlw_ty.BadItyArity (ts, app_arg) -> let i = List.length ts.its_ts.ts_args in fprintf fmt "Type symbol %a expects %i argument%s but is applied to %i" print_its ts i (if i = 1 then "" else "s") app_arg | Mlw_ty.BadRegArity (ts, app_arg) -> let i = List.length ts.its_regs in fprintf fmt "Type symbol %a expects \ %i region argument%s but is applied to %i" print_its ts i (if i = 1 then "" else "s") app_arg | Mlw_ty.DuplicateRegion r -> fprintf fmt "Region %a is used twice" print_reg r | Mlw_ty.UnboundRegion r -> fprintf fmt "Unbound region %a" print_reg r | Mlw_ty.UnboundException xs -> fprintf fmt "This function raises %a but does not \ specify a post-condition for it" print_xs xs | Mlw_ty.RegionMismatch (r1,r2,s) -> let r1 = Mreg.find_def r1 r1 s.ity_subst_reg in fprintf fmt "Region mismatch between %a and %a" print_regty r1 print_regty r2 | Mlw_ty.TypeMismatch (t1,t2,s) -> fprintf fmt "Type mismatch between %a and %a" (print_ity_node s 0) t1 print_ity t2 | Mlw_ty.PolymorphicException (id,_ity) -> fprintf fmt "Exception %s has a polymorphic type" id.id_string | Mlw_ty.MutableException (id,_ity) -> fprintf fmt "The type of exception %s has mutable components" id.id_string | Mlw_ty.IllegalAlias _reg -> fprintf fmt "This application creates an illegal alias" | Mlw_ty.IllegalCompar (tv,_ity) -> fprintf fmt "This application instantiates \ a non-opaque type parameter %a with a program type" print_tv tv | Mlw_ty.GhostDiverg -> fprintf fmt "This ghost expression contains potentially \ non-terminating loops or function calls" | Mlw_expr.RdOnlyPLS _ls -> fprintf fmt "Cannot construct or modify values of a private type" | Mlw_expr.HiddenPLS pl -> fprintf fmt "'%a' is a constructor/field of an abstract type \ and cannot be used in a program" print_ls pl.pl_ls; | Mlw_expr.StaleRegion (_e, id) -> fprintf fmt "This expression prohibits further \ usage of variable %s" id.id_string | Mlw_expr.ValueExpected _e -> fprintf fmt "This expression is not a first-order value" | Mlw_expr.ArrowExpected _e -> fprintf fmt "This expression is not a function and cannot be applied" | Mlw_expr.Immutable _e -> fprintf fmt "Mutable expression expected" | Mlw_decl.NonupdatableType ity -> fprintf fmt "Cannot update values of type @[%a@]" print_ity ity | _ -> raise exn end why3-0.88.3/src/whyml/mlw_expr.ml0000664000175100017510000010671113225666037017400 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Stdlib open Ident open Ty open Term open Mlw_ty open Mlw_ty.T (** program/logic symbols *) type field = { fd_ity : ity; fd_ghost : bool; fd_mut : region option; } type plsymbol = { pl_ls : lsymbol; pl_args : field list; pl_value : field; pl_hidden : bool; pl_rdonly : bool; } let pl_equal : plsymbol -> plsymbol -> bool = (==) let create_plsymbol_unsafe, restore_pl = let ls_to_pls = Wls.create 17 in (fun ls args value ~hidden ~rdonly -> let pl = { pl_ls = ls; pl_args = args; pl_value = value; pl_hidden = hidden; pl_rdonly = rdonly; } in Wls.set ls_to_pls ls pl; pl), Wls.find ls_to_pls let create_plsymbol ?(hidden=false) ?(rdonly=false) ?(constr=0) id args value = let ty_of_field fd = Opt.iter (fun r -> ity_equal_check fd.fd_ity r.reg_ity) fd.fd_mut; ty_of_ity fd.fd_ity in let pure_args = List.map ty_of_field args in let pure_value = ty_of_field value in (* plsymbols are used for constructors and projections, which are safe *) let opaque = List.fold_left ty_freevars Stv.empty (pure_value::pure_args) in let ls = create_fsymbol ~opaque ~constr id pure_args pure_value in create_plsymbol_unsafe ls args value ~hidden ~rdonly let ity_of_ty_opt ty = ity_of_ty (Opt.get_def ty_bool ty) let fake_field ty = { fd_ity = ity_of_ty ty; fd_ghost = false; fd_mut = None } let fake_pls = Wls.memoize 17 (fun ls -> { pl_ls = ls; pl_args = List.map fake_field ls.ls_args; pl_value = fake_field (Opt.get_def ty_bool ls.ls_value); pl_hidden = false; pl_rdonly = false; }) exception HiddenPLS of plsymbol exception RdOnlyPLS of plsymbol (** cloning *) type symbol_map = { sm_pure : Theory.symbol_map; sm_its : itysymbol Mits.t; sm_pls : plsymbol Mls.t; } let pl_clone sm = let itsm, regm = its_clone sm in let conv_reg r = Mreg.find r regm in let conv_its its = Mits.find_def its its itsm in let conv_ts ts = Mts.find_def ts ts sm.Theory.sm_ts in let rec conv_ity ity = match ity.ity_node with | Ityapp (its,tl,rl) -> let tl = List.map conv_ity tl in let rl = List.map conv_reg rl in ity_app (conv_its its) tl rl | Itypur (ts,tl) -> let tl = List.map conv_ity tl in ity_pur (conv_ts ts) tl | Ityvar _ -> ity in let conv_field fd = { fd_ity = conv_ity fd.fd_ity; fd_ghost = fd.fd_ghost; fd_mut = Opt.map conv_reg fd.fd_mut } in let add_pl opls nls acc = let npls = try restore_pl nls with Not_found -> let args = List.map conv_field opls.pl_args in let value = conv_field opls.pl_value in let hidden = opls.pl_hidden in let rdonly = opls.pl_rdonly in create_plsymbol_unsafe nls args value ~hidden ~rdonly in Mls.add opls.pl_ls npls acc in let add_ls ols nls acc = try add_pl (restore_pl ols) nls acc with Not_found -> acc in let plsm = Mls.fold add_ls sm.Theory.sm_ls Mls.empty in { sm_pure = sm; sm_its = itsm; sm_pls = plsm; } (** patterns *) type ppattern = { ppat_pattern : pattern; ppat_ity : ity; ppat_ghost : bool; (* matches a ghost value *) ppat_fail : bool; (* refutable under ghost *) } type pre_ppattern = | PPwild | PPvar of preid | PPlapp of lsymbol * pre_ppattern list | PPpapp of plsymbol * pre_ppattern list | PPor of pre_ppattern * pre_ppattern | PPas of pre_ppattern * preid let make_ppattern pp ?(ghost=false) ity = let hv = Hstr.create 3 in let fail = ref false in let find id ghost ity = try let pv = Hstr.find hv id.pre_name in ity_equal_check ity pv.pv_ity; if (pv.pv_ghost <> ghost) then invalid_arg "Mlw_expr.make_ppattern"; pv with Not_found -> let pv = create_pvsymbol id ~ghost ity in Hstr.add hv id.pre_name pv; pv in let rec make ghost ity = function | PPwild -> pat_wild (ty_of_ity ity) | PPvar id -> pat_var (find id ghost ity).pv_vs | PPpapp (pls,ppl) -> if pls.pl_hidden then raise (HiddenPLS pls); if pls.pl_ls.ls_constr = 0 then raise (Term.ConstructorExpected pls.pl_ls); if ghost && pls.pl_ls.ls_constr > 1 then fail := true; let ityv = pls.pl_value.fd_ity in let sbs = ity_match ity_subst_empty ityv ity in let mtch arg pp = let ghost = ghost || arg.fd_ghost in make ghost (ity_full_inst sbs arg.fd_ity) pp in let ppl = try List.map2 mtch pls.pl_args ppl with | Not_found -> raise (Term.ConstructorExpected pls.pl_ls) | Invalid_argument _ -> raise (Term.BadArity (pls.pl_ls, List.length ppl)) in pat_app pls.pl_ls ppl (ty_of_ity ity) | PPlapp (ls,ppl) -> if ls.ls_constr = 0 then raise (Term.ConstructorExpected ls); if ghost && ls.ls_constr > 1 then fail := true; let ityv = ity_of_ty_opt ls.ls_value in let sbs = ity_match ity_subst_empty ityv ity in let mtch arg pp = make ghost (ity_full_inst sbs (ity_of_ty arg)) pp in let ppl = try List.map2 mtch ls.ls_args ppl with | Not_found -> raise (Term.ConstructorExpected ls) | Invalid_argument _ -> raise (Term.BadArity (ls, List.length ppl)) in pat_app ls ppl (ty_of_ity ity) | PPor (pp1,pp2) -> pat_or (make ghost ity pp1) (make ghost ity pp2) | PPas (pp,id) -> pat_as (make ghost ity pp) (find id ghost ity).pv_vs; in let pat = make ghost ity pp in Hstr.fold Mstr.add hv Mstr.empty, { ppat_pattern = pat; ppat_ity = ity; ppat_ghost = ghost; ppat_fail = !fail } (** program symbols *) type psymbol = { ps_name : ident; ps_aty : aty; ps_ghost : bool; ps_pvset : Spv.t; ps_vars : varset; ps_subst : ity_subst; } module Psym = MakeMSHW (struct type t = psymbol let tag ps = ps.ps_name.id_tag end) module Sps = Psym.S module Mps = Psym.M module Hps = Psym.H module Wps = Psym.W type symset = { syms_pv : Spv.t; syms_ps : Sps.t; } let ps_equal : psymbol -> psymbol -> bool = (==) let add_pv_vars vars pv = vars_union vars pv.pv_ity.ity_vars let add_ps_vars vars ps = vars_union vars ps.ps_vars let create_psymbol_raw ~poly id ghost syms aty = let { syms_pv = pvset; syms_ps = psset } = syms in let tyvars = if poly then vars_empty else aty_vars aty in let pvvars = Spv.fold_left add_pv_vars vars_empty pvset in let psvars = Sps.fold_left add_ps_vars vars_empty psset in let vars = vars_union psvars (vars_union pvvars tyvars) in (* we must be polymorphic in every region not fixed by the context *) reg_iter (fun reg -> if not (reg_occurs reg pvvars) then Loc.errorm "This partial application produces non-generalizable effects") tyvars; assert (reg_all (fun reg -> reg_occurs reg pvvars) psvars); { ps_name = id_register id; ps_aty = aty_filter ~ghost pvset aty; ps_ghost = ghost; ps_pvset = pvset; ps_vars = vars; ps_subst = vars_freeze vars; } (** specification *) let rec aty_check vars aty = if aty.aty_spec.c_letrec <> 0 then invalid_arg "Mlw_expr.aty_check"; let test_or_raise c = if not c then Loc.errorm "every external effect must be mentioned in specification" in let vars = List.fold_left add_pv_vars vars aty.aty_args in let ch_tv tv = test_or_raise (Stv.mem tv vars.vars_tv) in let check reg = test_or_raise (reg_occurs reg vars) in let eff = aty.aty_spec.c_effect in Sreg.iter check eff.eff_writes; Sreg.iter check eff.eff_ghostw; Stv.iter ch_tv eff.eff_compar; match aty.aty_result with | VTarrow a -> aty_check vars a | VTvalue _ -> () let create_psymbol id ?(ghost=false) aty = let syms = { syms_pv = aty_pvset aty; syms_ps = Sps.empty } in let vars = Spv.fold_left add_pv_vars vars_empty syms.syms_pv in aty_check vars aty; create_psymbol_raw ~poly:true id ghost syms aty (** program expressions *) type assertion_kind = Aassert | Aassume | Acheck type for_direction = To | DownTo type for_bounds = pvsymbol * for_direction * pvsymbol type invariant = term type let_sym = | LetV of pvsymbol | LetA of psymbol type expr = { e_node : expr_node; e_vty : vty; e_ghost : bool; e_effect : effect; e_syms : symset; e_label : Slab.t; e_loc : Loc.position option; } and expr_node = | Elogic of term | Evalue of pvsymbol | Earrow of psymbol | Eapp of expr * pvsymbol * spec | Elet of let_defn * expr | Erec of fun_defn list * expr | Eif of expr * expr * expr | Ecase of expr * (ppattern * expr) list | Eassign of plsymbol * expr * region * pvsymbol | Eghost of expr | Eany of spec | Eloop of invariant * variant list * expr | Efor of pvsymbol * for_bounds * invariant * expr | Eraise of xsymbol * expr | Etry of expr * (xsymbol * pvsymbol * expr) list | Eabstr of expr * spec | Eassert of assertion_kind * term | Eabsurd and let_defn = { let_sym : let_sym; let_expr : expr; } and fun_defn = { fun_ps : psymbol; fun_lambda : lambda; fun_syms : symset; } and lambda = { l_args : pvsymbol list; l_expr : expr; l_spec : spec; } (* symset manipulation *) let syms_empty = { syms_pv = Spv.empty; syms_ps = Sps.empty; } let del_pv_syms pv syms = { (* TODO/FIXME: removing a pvsymbol directly from syms_pv may break the symset invariant requiring that all pvs in syms_ps*ps_pvset were in syms_pv. This is only possible if one reuses a let_defn in an expr, and reusing let_defn breaks WP anyway, so we ignore this for now, until a proper variable binding is implemented. *) syms_pv = Spv.remove pv syms.syms_pv; syms_ps = syms.syms_ps; } let del_ps_syms ps syms = { syms_pv = syms.syms_pv; syms_ps = Sps.remove ps syms.syms_ps; } let add_pv_syms pv syms = { syms_pv = Spv.add pv syms.syms_pv; syms_ps = syms.syms_ps; } let add_ps_syms ps syms = { syms_pv = Spv.union ps.ps_pvset syms.syms_pv; syms_ps = Sps.add ps syms.syms_ps; } let add_e_syms e syms = { syms_pv = Spv.union e.e_syms.syms_pv syms.syms_pv; syms_ps = Sps.union e.e_syms.syms_ps syms.syms_ps; } let add_t_syms t syms = { syms_pv = t_pvset syms.syms_pv t; syms_ps = syms.syms_ps; } let add_spec_syms c syms = { syms_pv = spec_pvset syms.syms_pv c; syms_ps = syms.syms_ps; } let syms_union syms1 syms2 = { syms_pv = Spv.union syms1.syms_pv syms2.syms_pv; syms_ps = Sps.union syms1.syms_ps syms2.syms_ps; } (* base tools *) let e_label ?loc l e = { e with e_label = l; e_loc = loc } let e_label_add l e = { e with e_label = Slab.add l e.e_label } let e_label_copy { e_label = lab; e_loc = loc } e = let lab = Slab.union lab e.e_label in let loc = if e.e_loc = None then loc else e.e_loc in { e with e_label = lab; e_loc = loc } exception ValueExpected of expr exception ArrowExpected of expr let ity_of_expr e = match e.e_vty with | VTvalue ity -> ity | VTarrow _ -> Loc.error ?loc:e.e_loc (ValueExpected e) let aty_of_expr e = match e.e_vty with | VTvalue _ -> Loc.error ?loc:e.e_loc (ArrowExpected e) | VTarrow aty -> aty (* fold *) let e_fold fn acc e = match e.e_node with | Elet (ld,e) -> fn (fn acc ld.let_expr) e | Erec (fdl,e) -> let fn_fd acc fd = fn acc fd.fun_lambda.l_expr in fn (List.fold_left fn_fd acc fdl) e | Ecase (e,bl) -> let fnbr acc (_,e) = fn acc e in List.fold_left fnbr (fn acc e) bl | Etry (e,bl) -> let fn_br acc (_,_,e) = fn acc e in List.fold_left fn_br (fn acc e) bl | Eif (e1,e2,e3) -> fn (fn (fn acc e1) e2) e3 | Eapp (e,_,_) | Eassign (_,e,_,_) | Eghost e | Eloop (_,_,e) | Efor (_,_,_,e) | Eraise (_,e) | Eabstr (e,_) -> fn acc e | Elogic _ | Evalue _ | Earrow _ | Eany _ | Eassert _ | Eabsurd -> acc exception Found of expr let e_find pr e = let rec find () e = e_fold find () e; if pr e then raise (Found e) in try find () e; raise Not_found with Found e -> e (* check admissibility of consecutive events *) exception StaleRegion of expr * ident let check_reset e { syms_pv = spv; syms_ps = sps } = (* If we reset a region, then it may only occur in the later code as the result of the resetting expression. Otherwise, this is a freshness violation: some symbol defined earlier carries that region into the later code. *) let check id vars = if eff_stale_region e.e_effect vars then Loc.error ?loc:e.e_loc (StaleRegion (e,id)) in if not (Mreg.is_empty e.e_effect.eff_resets) then begin Sps.iter (fun ps -> check ps.ps_name ps.ps_vars) sps; Spv.iter (fun pv -> check pv.pv_vs.vs_name pv.pv_ity.ity_vars) spv end let check_ghost_write { eff_ghostw = regs } { syms_pv = pvs } = let check { pv_ghost = gh; pv_ity = ity } = if not gh && lookup_nonghost_reg regs ity then Loc.errorm "This expression makes a ghost write into a non-ghost location" in if not (Sreg.is_empty regs) then Spv.iter check pvs let check_postexpr e _eff syms = check_reset e syms (* smart constructors *) let mk_expr node vty ghost eff syms = let ghost = ghost || not (Sexn.is_empty eff.eff_ghostx) in let eff = eff_ghostify ghost eff in check_ghost_write eff syms; { e_node = node; e_vty = vty; e_ghost = ghost; e_effect = eff; e_syms = syms; e_label = Slab.empty; e_loc = None; } (* program variables and program symbols *) let e_value pv = let syms = add_pv_syms pv syms_empty in mk_expr (Evalue pv) (VTvalue pv.pv_ity) pv.pv_ghost eff_empty syms let e_arrow ps argl res = let syms = add_ps_syms ps syms_empty in let sbs = aty_vars_match ps.ps_subst ps.ps_aty argl res in let aty = aty_full_inst sbs ps.ps_aty in mk_expr (Earrow ps) (VTarrow aty) ps.ps_ghost eff_empty syms let e_arrow_aty ps aty = let rec get_types argl a = let add argl pv = pv.pv_ity :: argl in let argl = List.fold_left add argl a.aty_args in match a.aty_result with | VTarrow a -> get_types argl a | VTvalue v -> e_arrow ps (List.rev argl) v in get_types [] aty (* let-definitions *) let create_let_defn id e = let lv = match e.e_vty with | VTarrow aty -> let rec is_value e = match e.e_node with | Earrow _ -> true | Erec ([fd], {e_node = Earrow ps}) -> (* (fun ... -> ...) *) ps_equal fd.fun_ps ps && fd.fun_lambda.l_spec.c_letrec = 0 | Eany spec -> eff_is_empty spec.c_effect (* && empty spec? *) | Eghost e -> is_value e | _ -> false in LetA (create_psymbol_raw ~poly:(is_value e) id e.e_ghost e.e_syms aty) | VTvalue ity -> LetV (create_pvsymbol id ~ghost:e.e_ghost ity) in { let_sym = lv ; let_expr = e } let create_let_pv_defn id e = let ld = create_let_defn id e in match ld.let_sym with | LetA _ -> Loc.error ?loc:e.e_loc (ValueExpected e) | LetV pv -> ld, pv let create_let_ps_defn id e = let ld = create_let_defn id e in match ld.let_sym with | LetV _ -> Loc.error ?loc:e.e_loc (ArrowExpected e) | LetA ps -> ld, ps let e_let ({ let_sym = lv ; let_expr = d } as ld) e = let syms = match lv with | LetV pv -> del_pv_syms pv e.e_syms | LetA ps -> del_ps_syms ps e.e_syms in check_postexpr d e.e_effect syms; let eff = eff_union d.e_effect e.e_effect in mk_expr (Elet (ld,e)) e.e_vty e.e_ghost eff (add_e_syms d syms) let on_value fn e = match e.e_node with | Evalue pv -> fn pv | _ -> let ld,pv = create_let_pv_defn (id_fresh ?loc:e.e_loc "o") e in e_let ld (fn pv) (* application *) let e_app_real e pv = let spec,ghost,vty = aty_app (aty_of_expr e) pv in let ghost = e.e_ghost || ghost in let eff = eff_ghostify ghost spec.c_effect in check_postexpr e eff (add_pv_syms pv syms_empty); let eff = eff_union e.e_effect eff in mk_expr (Eapp (e,pv,spec)) vty ghost eff (add_pv_syms pv e.e_syms) let rec e_app_flatten e pv = match e.e_node with (* TODO/FIXME? here, we avoid capture in the first case, but such an expression would break WP anyway. Though it cannot come from a parsed WhyML program where the typing ensures the uniqueness of pvsymbols, one can construct it using the API directly. *) | Elet ({ let_sym = LetV pv' }, _) when pv_equal pv pv' -> e_app_real e pv | Elet (ld, e) -> e_let ld (e_app_flatten e pv) | _ -> e_app_real e pv (* We adopt right-to-left evaluation order so that expression get_ref (create_ref 5) produces let pv : ref int = let pv1 : int = Elogic 5 in Eapp (Earrow create_ref) pv1 [reset ro] in Eapp (Earrow get_ref) pv [read ro] which is ok. If (Earrow get_ref) is computed before pv, the second application would violate the freshness of ro. FIXME? This means that some reasonable programs, such as let local_get_ref = get_ref in let my_ref = create_ref 5 in local_get_ref my_ref will be rejected, since local_get_ref is instantiated to the region introduced (reset) by create_ref. Is it bad? *) let e_app e1 e2 = on_value (fun pv -> e_app_flatten e1 pv) e2 let e_app e1 el = List.fold_left e_app e1 el let e_plapp pls el ity = if pls.pl_hidden then raise (HiddenPLS pls); if pls.pl_rdonly then raise (RdOnlyPLS pls); let rec app tl syms ghost eff sbs fdl argl = match fdl, argl with | [],[] -> let mut_fold leff fd = Opt.fold eff_reset leff fd.fd_mut in let leff = List.fold_left mut_fold eff_empty pls.pl_args in let mtv = Mtv.set_diff sbs.ity_subst_tv pls.pl_ls.ls_opaque in let leff = Mtv.fold (fun tv _ e -> eff_compare e tv) mtv leff in let eff = eff_union eff (eff_full_inst sbs leff) in let t = match pls.pl_ls.ls_value with | Some _ -> fs_app pls.pl_ls tl (ty_of_ity ity) | None -> ps_app pls.pl_ls tl in mk_expr (Elogic t) (VTvalue ity) ghost eff syms | [],_ | _,[] -> raise (Term.BadArity (pls.pl_ls, List.length el)) | fd::fdl, ({ e_node = Elogic t } as e)::argl when Spv.for_all (fun pv -> ity_immutable pv.pv_ity) e.e_syms.syms_pv -> let t = match t.t_ty with | Some _ -> t | None -> t_if_simp t t_bool_true t_bool_false in let ghost = ghost || (e.e_ghost && not fd.fd_ghost) in if fd.fd_ghost && not e.e_ghost then Loc.errorm "non-ghost value passed as a ghost argument"; let eff = eff_union eff e.e_effect in let sbs = ity_match sbs fd.fd_ity (ity_of_expr e) in app (t::tl) (add_e_syms e syms) ghost eff sbs fdl argl | fd::fdl, e::argl -> let apply_to_pv pv = let t = t_var pv.pv_vs in let ghost = ghost || (pv.pv_ghost && not fd.fd_ghost) in let sbs = ity_match sbs fd.fd_ity pv.pv_ity in app (t::tl) (add_pv_syms pv syms) ghost eff sbs fdl argl in if fd.fd_ghost && not e.e_ghost then Loc.errorm "non-ghost value passed as a ghost argument"; on_value apply_to_pv e in let argl = List.rev el and fdl = List.rev pls.pl_args in let sbs = ity_match ity_subst_empty pls.pl_value.fd_ity ity in app [] syms_empty pls.pl_value.fd_ghost eff_empty sbs fdl argl let e_lapp ls el ity = e_plapp (fake_pls ls) el ity let fs_void = fs_tuple 0 let t_void = fs_app fs_void [] ty_unit let e_void = e_lapp fs_void [] ity_unit (* if and match *) let e_if e0 e1 e2 = ity_equal_check (ity_of_expr e0) ity_bool; ity_equal_check (ity_of_expr e1) (ity_of_expr e2); let eff = eff_union e1.e_effect e2.e_effect in let syms = add_e_syms e2 (add_e_syms e1 syms_empty) in let ghost = e0.e_ghost || e1.e_ghost || e2.e_ghost in let eff = eff_ghostify ghost eff in check_postexpr e0 eff syms; let syms = add_e_syms e0 syms in let eff = eff_union e0.e_effect eff in mk_expr (Eif (e0,e1,e2)) e1.e_vty ghost eff syms let e_case e0 bl = let bity = match bl with | (_,e)::_ -> ity_of_expr e | [] -> raise Term.EmptyCase in let rec branch ghost eff syms = function | (pp,e)::bl -> if e0.e_ghost <> pp.ppat_ghost then Loc.errorm "Invalid pattern ghost status"; ity_equal_check (ity_of_expr e0) pp.ppat_ity; ity_equal_check (ity_of_expr e) bity; let eff = eff_union eff e.e_effect in let del_vs vs _ syms = del_pv_syms (restore_pv vs) syms in let bsyms = Mvs.fold del_vs pp.ppat_pattern.pat_vars e.e_syms in let ghost = ghost || pp.ppat_fail || e.e_ghost in branch ghost eff (syms_union syms bsyms) bl | [] -> (* the cumulated effect of all branches, w/out e0 *) let eff = eff_ghostify ghost eff in check_postexpr e0 eff syms; (* cumulated symset *) let eff = eff_union e0.e_effect eff in let syms = add_e_syms e0 syms in mk_expr (Ecase (e0,bl)) (VTvalue bity) ghost eff syms in (* one-branch match is not ghost even if the matched value is *) branch (e0.e_ghost && List.length bl > 1) eff_empty syms_empty bl (* ghost *) let e_ghost e = mk_expr (Eghost e) e.e_vty true e.e_effect e.e_syms (* assignment *) exception Immutable of expr let e_assign_real pls e0 pv = if pls.pl_hidden then raise (HiddenPLS pls); if pls.pl_rdonly then raise (RdOnlyPLS pls); let r = match pls.pl_value.fd_mut, pls.pl_args with (* if pls.pl_value is mutable, it can only be a projection *) | Some r, [{fd_ity = {ity_node = Ityapp (s,_,_)} as ity}] -> if s.its_priv then raise (RdOnlyPLS pls); let sbs = ity_match ity_subst_empty ity (ity_of_expr e0) in reg_full_inst sbs r | _,_ -> raise (Immutable (e_plapp pls [e0] pv.pv_ity)) in let lghost = e0.e_ghost || pls.pl_value.fd_ghost in let ghost = lghost || pv.pv_ghost in let eff = eff_assign eff_empty ~ghost r pv.pv_ity in let syms = add_pv_syms pv syms_empty in check_postexpr e0 eff syms; let syms = add_e_syms e0 syms in let eff = eff_union eff e0.e_effect in mk_expr (Eassign (pls,e0,r,pv)) (VTvalue ity_unit) ghost eff syms let e_assign pls e0 e1 = on_value (e_assign_real pls e0) e1 (* numeric constants *) let e_from_t t = mk_expr (Elogic t) (VTvalue (ity_of_ty_opt t.t_ty)) false eff_empty syms_empty let e_const c ity = e_from_t (t_const c (ty_of_ity ity)) (* boolean expressions *) (* FIXME? Should we rather use boolean constants here? *) let e_true = mk_expr (Elogic t_true) (VTvalue ity_bool) false eff_empty syms_empty let e_false = mk_expr (Elogic t_false) (VTvalue ity_bool) false eff_empty syms_empty let on_fmla fn e = match e.e_node with | Elogic ({ t_ty = None } as f) -> fn e f | Elogic t -> fn e (t_equ_simp t t_bool_true) | Evalue pv -> fn e (t_equ_simp (t_var pv.pv_vs) t_bool_true) | _ -> let ld,pv = create_let_pv_defn (id_fresh ?loc:e.e_loc "o") e in e_let ld (fn (e_value pv) (t_equ_simp (t_var pv.pv_vs) t_bool_true)) let e_not e = on_fmla (fun e f -> ity_equal_check (ity_of_expr e) ity_bool; mk_expr (Elogic (t_not f)) e.e_vty e.e_ghost e.e_effect e.e_syms) e let e_binop op e1 e2 = on_fmla (fun e1 f1 -> on_fmla (fun e2 f2 -> ity_equal_check (ity_of_expr e1) ity_bool; ity_equal_check (ity_of_expr e2) ity_bool; let syms = add_e_syms e1 e2.e_syms in let eff = eff_union e1.e_effect e2.e_effect in let ghost = e1.e_ghost || e2.e_ghost in mk_expr (Elogic (t_binary op f1 f2)) e1.e_vty ghost eff syms) e2) e1 let rec e_nospec e = match e.e_node with | Elogic _ | Evalue _ -> true | Eif (e1,e2,e3) -> e_nospec e1 && e_nospec e2 && e_nospec e3 | Ecase (e1,bl) -> e_nospec e1 && List.for_all (fun (_,e2) -> e_nospec e2) bl | Elet ({let_sym = LetV _; let_expr = e1}, e2) -> e_nospec e1 && e_nospec e2 | Eghost e1 -> e_nospec e1 | _ -> false let e_lazy_and e1 e2 = if eff_is_empty e2.e_effect && e_nospec e2 then e_binop Tand e1 e2 else e_if e1 e2 e_false let e_lazy_or e1 e2 = if eff_is_empty e2.e_effect && e_nospec e2 then e_binop Tor e1 e2 else e_if e1 e_true e2 (* loops *) let e_loop inv variant ({e_effect = eff} as e) = ity_equal_check (ity_of_expr e) ity_unit; let syms = List.fold_left (fun s (t,_) -> add_t_syms t s) e.e_syms variant in let syms = add_t_syms inv syms in check_postexpr e eff syms; let eff = if variant = [] then eff_diverge eff else eff in mk_expr (Eloop (inv,variant,e)) e.e_vty e.e_ghost eff syms let e_for_real pv bounds inv e = let pvfrom,_,pvto = bounds in ity_equal_check (ity_of_expr e) ity_unit; ity_equal_check pv.pv_ity ity_int; ity_equal_check pvfrom.pv_ity ity_int; ity_equal_check pvto.pv_ity ity_int; let ghost = pv.pv_ghost || pvfrom.pv_ghost || pvto.pv_ghost || e.e_ghost in let eff = eff_ghostify ghost e.e_effect in let syms = add_t_syms inv e.e_syms in (* FIXME? We check that no variable in the loop body, _including_ the index variable, is not invalidated because of a region reset. We ignore the loop bounds, since they are computed just once. *) check_postexpr e eff syms; let syms = del_pv_syms pv syms in let syms = add_pv_syms pvfrom (add_pv_syms pvto syms) in mk_expr (Efor (pv,bounds,inv,e)) e.e_vty ghost eff syms let e_for pv efrom dir eto inv e = let apply pvto pvfrom = e_for_real pv (pvfrom,dir,pvto) inv e in let apply pvto = on_value (apply pvto) efrom in on_value apply eto (* raise and try *) let e_raise xs e ity = ity_equal_check (ity_of_expr e) xs.xs_ity; let eff = eff_raise eff_empty ~ghost:e.e_ghost xs in check_postexpr e eff syms_empty; let eff = eff_union eff e.e_effect in mk_expr (Eraise (xs,e)) (VTvalue ity) e.e_ghost eff e.e_syms let e_try e0 bl = let rec branch ghost eff syms = function | (xs,pv,e)::bl -> ity_equal_check (ity_of_expr e) (ity_of_expr e0); ity_equal_check pv.pv_ity xs.xs_ity; (* we don't care about pv being ghost *) let ghost = ghost || e.e_ghost in let eff = eff_union eff e.e_effect in let bsyms = del_pv_syms pv e.e_syms in branch ghost eff (syms_union syms bsyms) bl | [] -> (* the cumulated effect of all branches, w/out e0 *) let eff = eff_ghostify ghost eff in check_postexpr e0 eff syms; (* cumulated symset *) (* remove from e0.e_effect the catched exceptions *) let remove eff0 (xs,_,_) = eff_remove_raise eff0 xs in let eff0 = List.fold_left remove e0.e_effect bl in (* total effect and symset *) let eff = eff_union eff0 eff in let syms = add_e_syms e0 syms in mk_expr (Etry (e0,bl)) e0.e_vty ghost eff syms in branch e0.e_ghost eff_empty syms_empty bl (* specification-related expressions *) let pv_dummy = create_pvsymbol (id_fresh "dummy") ity_unit let e_any spec vty = let aty = vty_arrow [pv_dummy] ?spec vty in let ps = create_psymbol (id_fresh "dummy") aty in let syms = del_ps_syms ps (add_ps_syms ps syms_empty) in let vty = ps.ps_aty.aty_result in let spec = ps.ps_aty.aty_spec in mk_expr (Eany spec) vty false spec.c_effect syms let e_abstract ({ e_effect = eff } as e) spec = if spec.c_letrec <> 0 then invalid_arg "Mlw_expr.e_abstract"; let spec = { spec with c_effect = eff } in spec_check ~full_xpost:false spec e.e_vty; let syms = add_spec_syms spec e.e_syms in mk_expr (Eabstr (e,spec)) e.e_vty e.e_ghost e.e_effect syms let e_assert ak f = let syms = add_t_syms f syms_empty in mk_expr (Eassert (ak, f)) (VTvalue ity_unit) false eff_empty syms let e_absurd ity = mk_expr Eabsurd (VTvalue ity) false eff_empty syms_empty (* simple functional definitions *) let create_fun_defn id ({l_expr = e; l_spec = c} as lam) = let eff = if c.c_letrec <> 0 && c.c_variant = [] then eff_diverge e.e_effect else e.e_effect in let spec = { c with c_effect = eff } in let lam = { lam with l_spec = spec } in let syms = add_spec_syms lam.l_spec lam.l_expr.e_syms in let syms = List.fold_right del_pv_syms lam.l_args syms in let aty = vty_arrow lam.l_args ~spec e.e_vty in { fun_ps = create_psymbol_raw ~poly:true id e.e_ghost syms aty; fun_lambda = lam; fun_syms = syms; } let e_rec fdl e = (* check letrec *) let fd, rest = match fdl with | [] -> invalid_arg "Mlw_expr.e_rec" | fd :: fdl -> fd, fdl in let lr = fd.fun_ps.ps_aty.aty_spec.c_letrec in let bad fd = fd.fun_ps.ps_aty.aty_spec.c_letrec <> lr in if List.exists bad rest then invalid_arg "Mlw_expr.e_rec"; if lr = 0 && rest <> [] then invalid_arg "Mlw_expr.e_rec"; (* compute syms *) let add_fd syms fd = syms_union fd.fun_syms syms in let del_fd syms fd = del_ps_syms fd.fun_ps syms in let syms = List.fold_left add_fd e.e_syms fdl in let syms = List.fold_left del_fd syms fdl in mk_expr (Erec (fdl,e)) e.e_vty e.e_ghost e.e_effect syms (* compute the fixpoint on recursive definitions *) let rec aty_compat a1 a2 = assert (List.for_all2 pv_equal a1.aty_args a2.aty_args); (* no need to compare the rest of the spec, see below *) eff_equal a1.aty_spec.c_effect a2.aty_spec.c_effect && match a1.aty_result, a2.aty_result with | VTarrow a1, VTarrow a2 -> aty_compat a1 a2 | VTvalue v1, VTvalue v2 -> ity_equal v1 v2 | _,_ -> assert false let ps_compat ps1 ps2 = aty_compat ps1.ps_aty ps2.ps_aty && ps1.ps_ghost = ps2.ps_ghost && Spv.equal ps1.ps_pvset ps2.ps_pvset && Stv.equal ps1.ps_vars.vars_tv ps2.ps_vars.vars_tv && Sreg.equal ps1.ps_vars.vars_reg ps2.ps_vars.vars_reg let rec expr_subst psm e = e_label_copy e (match e.e_node with | Earrow ps when Mps.mem ps psm -> e_arrow_aty (Mps.find ps psm) (aty_of_expr e) | Eapp (e,pv,_) -> e_app_real (expr_subst psm e) pv | Elet ({ let_sym = LetV pv; let_expr = d }, e) -> let nd = expr_subst psm d in if not (ity_equal (ity_of_expr nd) pv.pv_ity) then Loc.errorm "vty_value mismatch"; e_let { let_sym = LetV pv; let_expr = nd } (expr_subst psm e) | Elet ({ let_sym = LetA ps; let_expr = d }, e) -> let ld,ns = create_let_ps_defn (id_clone ps.ps_name) (expr_subst psm d) in e_let ld (expr_subst (Mps.add ps ns psm) e) | Erec ([{fun_ps = ps; fun_lambda = lam}], e) when lam.l_spec.c_letrec = 0 -> let lam = { lam with l_expr = expr_subst psm lam.l_expr } in let fd = create_fun_defn (id_clone ps.ps_name) lam in e_rec [fd] (expr_subst (Mps.add ps fd.fun_ps psm) e) | Erec (fdl, e) -> let conv lam = { lam with l_expr = expr_subst psm lam.l_expr } in let defl = List.map (fun fd -> fd.fun_ps, conv fd.fun_lambda) fdl in let fdl = create_rec_defn defl in let add psm (ps,_) fd = Mps.add ps fd.fun_ps psm in e_rec fdl (expr_subst (List.fold_left2 add psm defl fdl) e) | Eif (e,e1,e2) -> e_if (expr_subst psm e) (expr_subst psm e1) (expr_subst psm e2) | Ecase (e,bl) -> let branch (pp,e) = pp, expr_subst psm e in e_case (expr_subst psm e) (List.map branch bl) | Eassign (pls,e,_,pv) -> e_assign_real pls (expr_subst psm e) pv | Eghost e -> e_ghost (expr_subst psm e) | Eabstr (e,spec) -> e_abstract (expr_subst psm e) spec | Eraise (xs,e0) -> e_raise xs (expr_subst psm e0) (ity_of_expr e) | Etry (e,bl) -> let branch (xs,pv,e) = xs, pv, expr_subst psm e in e_try (expr_subst psm e) (List.map branch bl) | Eloop (inv,var,e) -> e_loop inv var (expr_subst psm e) | Efor (pv,bounds,inv,e) -> e_for_real pv bounds inv (expr_subst psm e) | Elogic _ | Evalue _ | Earrow _ | Eany _ | Eabsurd | Eassert _ -> e) and create_rec_defn defl = let conv m (ps,lam) = let fd = create_fun_defn (id_clone ps.ps_name) lam in if ps_compat ps fd.fun_ps then m, { fd with fun_ps = ps } else Mps.add ps fd.fun_ps m, fd in let m, fdl = Lists.map_fold_left conv Mps.empty defl in if Mps.is_empty m then fdl else subst_fd m fdl and subst_fd psm fdl = let subst { fun_ps = ps; fun_lambda = lam } = Mps.find_def ps ps psm, { lam with l_expr = expr_subst psm lam.l_expr } in create_rec_defn (List.map subst fdl) (* Before we start computing the fixpoint for effects, we must get the pre/post/xpost right. Therefore we require every ps participating in the recursion to have a first-order body, so that its spec (except the effect) is known from the start. Then we apply one round of substitution, to ensure that in each pair (ps,lam), the two sides have vty of the same shape and with the same final spec (except the effect). The result is passed to create_rec_defn above which repeats substitution until the effects are stabilized. TODO: prove correctness *) let create_rec_defn = let letrec = ref 1 in fun defl -> if defl = [] then invalid_arg "Mlw_expr.create_rec_defn"; (* Check that all variants use compatible orders for their first component. *) let variant1 = (snd (List.hd defl)).l_spec.c_variant in let check_variant (_, { l_spec = { c_variant = vl }}) = match variant1, vl with | [], [] | (_,None)::_, (_,None)::_ -> () | (t1, Some r1)::_, (t2, Some r2)::_ when oty_equal t1.t_ty t2.t_ty && ls_equal r1 r2 -> () | _ -> Loc.errorm "All functions in a recursive definition \ must use the same well-founded order for the first variant component" in List.iter check_variant (List.tl defl); (* create the first list of fun_defns *) let conv m (ps,lam) = match lam.l_expr.e_vty with | VTarrow _ -> Loc.errorm ?loc:lam.l_expr.e_loc "The body of a recursive function must be a first-order value" | VTvalue _ -> if lam.l_spec.c_letrec <> 0 then invalid_arg "Mlw_expr.create_rec_defn"; let spec = { lam.l_spec with c_letrec = !letrec } in let lam = { lam with l_spec = spec } in let fd = create_fun_defn (id_clone ps.ps_name) lam in Mps.add ps fd.fun_ps m, fd in let m, fdl = Lists.map_fold_left conv Mps.empty defl in incr letrec; subst_fd m fdl let create_fun_defn id lam = if lam.l_spec.c_letrec <> 0 then invalid_arg "Mlw_expr.create_fun_defn"; create_fun_defn id lam (* expr to term *) let spec_purify sp = let vs, f = Mlw_ty.open_post sp.c_post in match f.t_node with | Tapp (ps, [{t_node = Tvar us}; t]) when ls_equal ps ps_equ && vs_equal vs us && t_v_occurs vs t = 0 -> t | Tbinop (Tiff, {t_node = Tapp (ps,[{t_node = Tvar us};{t_node = Ttrue}])},f) when ls_equal ps ps_equ && vs_equal vs us && t_v_occurs vs f = 0 -> t_if f t_bool_true t_bool_false | _ -> raise Exit let rec e_purify e = let t = match e.e_node with | Elogic f when f.t_ty = None -> t_if f t_bool_true t_bool_false | Elogic t -> t | Evalue pv -> t_var pv.pv_vs | Earrow _ | Eassert _ -> t_void | Eapp (_,_,sp) -> spec_purify sp | Elet ({ let_sym = LetV pv; let_expr = e1 }, e2) -> t_let_close_simp pv.pv_vs (e_purify e1) (e_purify e2) | Elet ({ let_sym = LetA _ }, e1) | Erec (_,e1) | Eghost e1 -> e_purify e1 | Eif (e1,e2,e3) -> t_if_simp (t_equ_simp (e_purify e1) t_bool_true) (e_purify e2) (e_purify e3) | Ecase (e1,bl) -> let conv (p,e) = t_close_branch p.ppat_pattern (e_purify e) in t_case (e_purify e1) (List.map conv bl) | Eany sp | Eabstr (_,sp) -> spec_purify sp | Eassign _ | Eloop _ | Efor _ | Eraise _ | Etry _ | Eabsurd -> raise Exit in let loc = if t.t_loc = None then e.e_loc else t.t_loc in t_label ?loc (Slab.union e.e_label t.t_label) t let e_purify e = if Sreg.is_empty e.e_effect.eff_writes && Sreg.is_empty e.e_effect.eff_ghostw && Sexn.is_empty e.e_effect.eff_raises && Sexn.is_empty e.e_effect.eff_ghostx then try Some (e_purify e) with Exit -> None else None why3-0.88.3/src/whyml/mlw_dexpr.ml0000664000175100017510000015315513225666037017550 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Stdlib open Ident open Ty open Term open Mlw_ty open Mlw_ty.T open Mlw_expr (** Program types *) type dity = | Dvar of dvar ref | Dutv of tvsymbol | Dapp of itysymbol * dity list * dreg list | Dpur of tysymbol * dity list and dvar = | Dtvs of tvsymbol | Dval of dity and dreg = | Rreg of region * dity | Rvar of rvar ref and rvar = | Rtvs of tvsymbol * dity | Rval of dreg type dvty = dity list * dity (* A -> B -> C == ([A;B],C) *) let create_dreg dity = Rvar (ref (Rtvs (create_tvsymbol (id_fresh "rho"), dity))) let dity_of_ity ity = let hreg = Hreg.create 3 in let rec dity ity = match ity.ity_node with | Ityvar tv -> Dutv tv | Ityapp (s,tl,rl) -> Dapp (s, List.map dity tl, List.map dreg rl) | Itypur (s,tl) -> Dpur (s, List.map dity tl) and dreg reg = try Hreg.find hreg reg with Not_found -> let r = create_dreg (dity reg.reg_ity) in Hreg.add hreg reg r; r in dity ity let ity_of_dity dity = let rec ity = function | Dvar { contents = Dval t } -> ity t | Dvar ref -> let tv = create_tvsymbol (id_fresh "xi") in ref := Dval (Dutv tv); ity_var tv | Dutv tv -> ity_var tv | Dapp (s,tl,rl) -> ity_app s (List.map ity tl) (List.map reg rl) | Dpur (s,tl) -> ity_pur s (List.map ity tl) and reg = function | Rreg (r,_) -> r | Rvar { contents = Rval r } -> reg r | Rvar ({ contents = Rtvs (tv,t) } as ref) -> let r = create_region (id_clone tv.tv_name) (ity t) in ref := Rval (Rreg (r,t)); r in ity dity let dity_int = Dpur (ts_int, []) let dity_bool = Dpur (ts_bool, []) let dity_unit = Dpur (ts_unit, []) let dvty_bool = [], dity_bool let dvty_unit = [], dity_unit (** Destructive type unification *) let rec occur_check tv = function | Dvar { contents = Dval d } -> occur_check tv d | Dapp (_,dl,_) | Dpur (_,dl) -> List.iter (occur_check tv) dl | Dvar { contents = Dtvs tv' } | Dutv tv' -> if tv_equal tv tv' then raise Exit let rec dity_unify d1 d2 = match d1,d2 with | Dvar { contents = Dval d1 }, d2 | d1, Dvar { contents = Dval d2 } -> dity_unify d1 d2 | Dvar { contents = Dtvs tv1 }, Dvar { contents = Dtvs tv2 } when tv_equal tv1 tv2 -> () | Dvar ({ contents = Dtvs tv } as r), d | d, Dvar ({ contents = Dtvs tv } as r) -> occur_check tv d; r := Dval d | Dutv tv1, Dutv tv2 when tv_equal tv1 tv2 -> () | Dapp (s1,dl1,_), Dapp (s2,dl2,_) when its_equal s1 s2 -> List.iter2 dity_unify dl1 dl2 | Dpur (s1,dl1), Dpur (s2,dl2) when ts_equal s1 s2 -> List.iter2 dity_unify dl1 dl2 | _ -> raise Exit (** Reunify regions *) let dtvs_queue : dvar ref Queue.t = Queue.create () let unify_queue : (dity * dity) Queue.t = Queue.create () let dity_fresh () = let r = ref (Dtvs (create_tvsymbol (id_fresh "a"))) in Queue.add r dtvs_queue; Dvar r let its_app_fresh s dl = let htv = Htv.create 3 in let hreg = Hreg.create 3 in let rec inst ity = match ity.ity_node with | Ityvar v -> Htv.find htv v | Ityapp (s,tl,rl) -> Dapp (s, List.map inst tl, List.map fresh rl) | Itypur (s,tl) -> Dpur (s, List.map inst tl) and fresh r = try Hreg.find hreg r with Not_found -> let reg = create_dreg (inst r.reg_ity) in Hreg.add hreg r reg; reg in List.iter2 (Htv.add htv) s.its_ts.ts_args dl; match s.its_def with | None -> Dapp (s, dl, List.map fresh s.its_regs) | Some ity -> inst ity let rec dity_refresh = function | Dvar { contents = Dval dty } -> dity_refresh dty | Dvar { contents = Dtvs _ } as dity -> dity | Dapp (s,dl,_) -> its_app_fresh s (List.map dity_refresh dl) | Dpur (s,dl) -> Dpur (s, List.map dity_refresh dl) | Dutv _ as dity -> dity let dity_unify_weak = dity_unify let dity_unify d1 d2 = dity_unify d1 d2; Queue.add (d1,d2) unify_queue let rec reunify d1 d2 = match d1,d2 with | Dvar { contents = Dval d1 }, d2 | d1, Dvar { contents = Dval d2 } -> reunify d1 d2 | Dvar _, Dvar _ | Dutv _, Dutv _ -> () | Dapp (_,dl1,rl1), Dapp (_,dl2,rl2) -> List.iter2 reunify dl1 dl2; List.iter2 unify_reg rl1 rl2 | Dpur (_,dl1), Dpur (_,dl2) -> List.iter2 reunify dl1 dl2 | _ -> assert false and unify_reg r1 r2 = match r1,r2 with | Rvar { contents = Rval r1 }, r2 | r1, Rvar { contents = Rval r2 } -> unify_reg r1 r2 | Rvar { contents = Rtvs (tv1,_) }, Rvar { contents = Rtvs (tv2,_) } when tv_equal tv1 tv2 -> () | Rvar ({ contents = Rtvs (_,d1) } as r), (Rvar { contents = Rtvs (_,d2) } as d) | Rvar ({ contents = Rtvs (_,d1) } as r), (Rreg (_,d2) as d) | (Rreg (_,d1) as d), Rvar ({ contents = Rtvs (_,d2) } as r) -> reunify d1 d2; r := Rval d | Rreg _, Rreg _ -> () (* we don't check whether the regions are the same, because we won't have a good location for the error. Let the core API raise the exception later. *) let reunify_regions () = Queue.iter (fun r -> match !r with | Dval d -> r := Dval (dity_refresh d) | Dtvs _ -> ()) dtvs_queue; Queue.clear dtvs_queue; Queue.iter (fun (d1,d2) -> reunify d1 d2) unify_queue; Queue.clear unify_queue (** Chainable relations *) let rec dity_is_bool = function | Dvar { contents = Dval dty } -> dity_is_bool dty | Dpur (ts,_) -> ts_equal ts ts_bool | _ -> false let dvty_is_chainable = function | [t1;t2],t -> dity_is_bool t && not (dity_is_bool t1) && not (dity_is_bool t2) | _ -> false (** Pretty-printing *) let debug_print_reg_types = Debug.register_info_flag "print_reg_types" ~desc:"Print@ types@ of@ regions@ (mutable@ fields)." let print_dity fmt dity = let protect_on x s = if x then "(" ^^ s ^^ ")" else s in let print_rtvs fmt tv = Mlw_pretty.print_reg fmt (create_region (id_clone tv.tv_name) Mlw_ty.ity_unit) in let rec print_dity pri fmt = function | Dvar { contents = Dtvs tv } | Dutv tv -> Pretty.print_tv fmt tv | Dvar { contents = Dval dty } -> print_dity pri fmt dty | Dpur (s,[t1;t2]) when ts_equal s Ty.ts_func -> Format.fprintf fmt (protect_on (pri > 0) "%a@ ->@ %a") (print_dity 1) t1 (print_dity 0) t2 | Dpur (s,tl) when is_ts_tuple s -> Format.fprintf fmt "(%a)" (Pp.print_list Pp.comma (print_dity 0)) tl | Dpur (s,[]) -> Pretty.print_ts fmt s | Dpur (s,tl) -> Format.fprintf fmt (protect_on (pri > 1) "%a@ %a") Pretty.print_ts s (Pp.print_list Pp.space (print_dity 2)) tl | Dapp (s,[],rl) -> Format.fprintf fmt (protect_on (pri > 1) "%a@ <%a>") Mlw_pretty.print_its s (Pp.print_list Pp.comma print_dreg) rl | Dapp (s,tl,rl) -> Format.fprintf fmt (protect_on (pri > 1) "%a@ <%a>@ %a") Mlw_pretty.print_its s (Pp.print_list Pp.comma print_dreg) rl (Pp.print_list Pp.space (print_dity 2)) tl and print_dreg fmt = function | Rreg (r,_) when Debug.test_flag debug_print_reg_types -> Format.fprintf fmt "@[%a:@,%a@]" Mlw_pretty.print_reg r Mlw_pretty.print_ity r.reg_ity | Rreg (r,_) -> Mlw_pretty.print_reg fmt r | Rvar { contents = Rtvs (tv,dity) } when Debug.test_flag debug_print_reg_types -> Format.fprintf fmt "@[%a:@,%a@]" print_rtvs tv (print_dity 0) dity | Rvar { contents = Rtvs (tv,_) } -> print_rtvs fmt tv | Rvar { contents = Rval dreg } -> print_dreg fmt dreg in print_dity 0 fmt dity (* Specialization of symbols *) let specialize_scheme tvs (argl,res) = let htv = Htv.create 3 and hreg = Htv.create 3 in let rec spec_dity = function | Dvar { contents = Dval dity } -> spec_dity dity | Dvar { contents = Dtvs tv } | Dutv tv as dity -> get_tv tv dity | Dapp (s,dl,rl) -> Dapp (s, List.map spec_dity dl, List.map spec_reg rl) | Dpur (s,dl) -> Dpur (s, List.map spec_dity dl) and spec_reg = function | Rvar { contents = Rval r } -> spec_reg r | Rvar { contents = Rtvs (tv,dity) } -> get_reg tv dity | Rreg _ as r -> r and get_tv tv dity = try Htv.find htv tv with Not_found -> let v = dity_fresh () in (* can't return dity, might differ in regions *) if not (Stv.mem tv tvs) then dity_unify_weak v dity; Htv.add htv tv v; v and get_reg tv dity = try Htv.find hreg tv with Not_found -> let r = create_dreg (spec_dity dity) in Htv.add hreg tv r; r in List.map spec_dity argl, spec_dity res let spec_ity htv hreg vars ity = let get_tv tv = try Htv.find htv tv with Not_found -> let v = dity_fresh () in Htv.add htv tv v; v in let rec dity ity = match ity.ity_node with | Ityvar tv -> if Stv.mem tv vars.vars_tv then Dutv tv else get_tv tv | Ityapp (s,tl,rl) -> Dapp (s, List.map dity tl, List.map dreg rl) | Itypur (s,tl) -> Dpur (s, List.map dity tl) and dreg reg = try Hreg.find hreg reg with Not_found -> let t = dity reg.reg_ity in let r = if reg_occurs reg vars then Rreg (reg,t) else create_dreg t in Hreg.add hreg reg r; r in dity ity let specialize_pv { pv_ity = ity } = spec_ity (Htv.create 3) (Hreg.create 3) ity.ity_vars ity let specialize_xs { xs_ity = ity } = spec_ity (Htv.create 3) (Hreg.create 3) ity.ity_vars ity let specialize_ps { ps_aty = aty; ps_vars = vars } = let htv = Htv.create 3 and hreg = Hreg.create 3 in let conv pv = spec_ity htv hreg vars pv.pv_ity in let rec spec_aty a = let argl = List.map conv a.aty_args in let narg,res = match a.aty_result with | VTvalue v -> [], spec_ity htv hreg vars v | VTarrow a -> spec_aty a in argl @ narg, res in spec_aty aty let specialize_pl pl = let htv = Htv.create 3 and hreg = Hreg.create 3 in let conv fd = spec_ity htv hreg vars_empty fd.fd_ity in List.map conv pl.pl_args, conv pl.pl_value let dity_of_ty htv hreg vars ty = let rec pure ty = match ty.ty_node with | Tyapp (ts,tl) -> begin try ignore (restore_its ts); false with Not_found -> List.for_all pure tl end | Tyvar _ -> true in if not (pure ty) then raise Exit; spec_ity htv hreg vars (ity_of_ty ty) let specialize_ls ls = let htv = Htv.create 3 and hreg = Hreg.create 3 in let conv ty = dity_of_ty htv hreg vars_empty ty in let ty = Opt.get_def ty_bool ls.ls_value in List.map conv ls.ls_args, conv ty let specialize_ls ls = try specialize_ls ls with Exit -> Loc.errorm "Function symbol `%a' can only be used in specification" Pretty.print_ls ls (** Patterns *) type dpattern = { dp_pat : pre_ppattern; dp_dity : dity; dp_vars : dity Mstr.t; dp_loc : Loc.position option; } type dpattern_node = | DPwild | DPvar of preid | DPlapp of lsymbol * dpattern list | DPpapp of plsymbol * dpattern list | DPor of dpattern * dpattern | DPas of dpattern * preid | DPcast of dpattern * ity (** Specifications *) type ghost = bool type opaque = Stv.t type dbinder = preid option * ghost * opaque * dity type 'a later = vsymbol Mstr.t -> 'a (* specification terms are parsed and typechecked after the program expressions, when the types of locally bound program variables are already established. *) type dspec_final = { ds_pre : term list; ds_post : (vsymbol option * term) list; ds_xpost : (vsymbol option * term) list Mexn.t; ds_reads : vsymbol list; ds_writes : term list; ds_variant : variant list; ds_checkrw : bool; ds_diverge : bool; } type dspec = ty -> dspec_final (* Computation specification is also parametrized by the result type. All vsymbols in the postcondition clauses in the [ds_post] field must have this type. All vsymbols in the exceptional postcondition clauses must have the type of the corresponding exception. *) type dtype_v = | DSpecV of dity | DSpecA of dbinder list * dtype_c and dtype_c = dtype_v * dspec later (** Expressions *) type dinvariant = term list type dlazy_op = DEand | DEor type dexpr = { de_node : dexpr_node; de_dvty : dvty; de_loc : Loc.position option; } and dexpr_node = | DEvar of string * dvty | DEgpvar of pvsymbol | DEgpsym of psymbol | DEplapp of plsymbol * dexpr list | DElsapp of lsymbol * dexpr list | DEapply of dexpr * dexpr | DEconst of Number.constant * ity | DElam of dbinder list * dexpr * dspec later | DElet of dlet_defn * dexpr | DEfun of dfun_defn * dexpr | DErec of drec_defn * dexpr | DEif of dexpr * dexpr * dexpr | DEcase of dexpr * (dpattern * dexpr) list | DEassign of plsymbol * dexpr * dexpr | DElazy of dlazy_op * dexpr * dexpr | DEnot of dexpr | DEtrue | DEfalse | DEraise of xsymbol * dexpr | DEtry of dexpr * (xsymbol * dpattern * dexpr) list | DEfor of preid * dexpr * for_direction * dexpr * dinvariant later * dexpr | DEwhile of dexpr * (variant list * dinvariant) later * dexpr | DEloop of (variant list * dinvariant) later * dexpr | DEabsurd | DEassert of assertion_kind * term later | DEabstract of dexpr * dspec later | DEmark of preid * dexpr | DEghost of dexpr | DEany of dtype_v * dspec later option | DEcast of dexpr * ity | DEuloc of dexpr * Loc.position | DElabel of dexpr * Slab.t and dlet_defn = preid * ghost * dexpr and dfun_defn = preid * ghost * dbinder list * dexpr * dspec later and drec_defn = { fds : dfun_defn list } type dval_decl = preid * ghost * dtype_v (** Environment *) type denv = { frozen : dity list; locals : (Stv.t option * dvty) Mstr.t; } let denv_empty = { frozen = []; locals = Mstr.empty } let is_frozen frozen tv = try List.iter (occur_check tv) frozen; false with Exit -> true let freeze_dvty frozen (argl,res) = let rec add l = function | Dvar { contents = Dval d } -> add l d | Dvar { contents = Dtvs _ } as d -> d :: l | Dutv _ as d -> d :: l | Dapp (_,tl,_) | Dpur (_,tl) -> List.fold_left add l tl in List.fold_left add (add frozen res) argl let free_vars frozen (argl,res) = let rec add s = function | Dvar { contents = Dval d } -> add s d | Dvar { contents = Dtvs tv } | Dutv tv -> if is_frozen frozen tv then s else Stv.add tv s | Dapp (_,tl,_) | Dpur (_,tl) -> List.fold_left add s tl in List.fold_left add (add Stv.empty res) argl let denv_add_mono { frozen = frozen; locals = locals } id dvty = let locals = Mstr.add id.pre_name (None, dvty) locals in { frozen = freeze_dvty frozen dvty; locals = locals } let denv_add_poly { frozen = frozen; locals = locals } id dvty = let ftvs = free_vars frozen dvty in let locals = Mstr.add id.pre_name (Some ftvs, dvty) locals in { frozen = frozen; locals = locals } let denv_add_rec_mono { frozen = frozen; locals = locals } id dvty = let locals = Mstr.add id.pre_name (Some Stv.empty, dvty) locals in { frozen = freeze_dvty frozen dvty; locals = locals } let denv_add_rec_poly { frozen = frozen; locals = locals } frozen0 id dvty = let ftvs = free_vars frozen0 dvty in let locals = Mstr.add id.pre_name (Some ftvs, dvty) locals in { frozen = frozen; locals = locals } let denv_add_rec denv frozen0 id ((argl,res) as dvty) = let rec is_explicit = function | Dapp (_,tl,_) | Dpur (_,tl) -> List.for_all is_explicit tl | Dvar { contents = Dval d } -> is_explicit d | Dvar { contents = Dtvs _ } -> false | Dutv _ -> true in if List.for_all is_explicit argl && is_explicit res then denv_add_rec_poly denv frozen0 id dvty else denv_add_rec_mono denv id dvty let dvty_of_dtype_v dtv = let rec dvty argl = function | DSpecA (bl,(DSpecV res,_)) -> List.rev_append argl (List.map (fun (_,_,_,t) -> t) bl), res | DSpecA (bl,(dtv,_)) -> dvty (List.fold_left (fun l (_,_,_,t) -> t::l) argl bl) dtv | DSpecV res -> List.rev argl, res in dvty [] dtv let denv_add_var denv id dity = denv_add_mono denv id ([], dity) let denv_add_let denv (id,_,({de_dvty = dvty} as de)) = if fst dvty = [] then denv_add_mono denv id dvty else let rec is_value de = match de.de_node with | DEghost de | DEuloc (de,_) | DElabel (de,_) -> is_value de | DEvar _ | DEgpsym _ | DElam _ | DEany (_,None) -> true | _ -> false in if is_value de then denv_add_poly denv id dvty else denv_add_mono denv id dvty let denv_add_fun denv (id,_,bl,{de_dvty = (argl,res)},_) = if bl = [] then invalid_arg "Mlw_dexpr.denv_add_fun: empty argument list"; let argl = List.fold_right (fun (_,_,_,t) l -> t::l) bl argl in denv_add_poly denv id (argl, res) let denv_add_args { frozen = frozen; locals = locals } bl = let l = List.fold_left (fun l (_,_,_,t) -> t::l) frozen bl in let add s (id,_,_,t) = match id with | Some {pre_name = n} -> Mstr.add_new (Dterm.DuplicateVar n) n (None, ([],t)) s | None -> s in let s = List.fold_left add Mstr.empty bl in { frozen = l; locals = Mstr.set_union s locals } let denv_add_pat { frozen = frozen; locals = locals } dp = let l = Mstr.fold (fun _ t l -> t::l) dp.dp_vars frozen in let s = Mstr.map (fun t -> None, ([], t)) dp.dp_vars in { frozen = l; locals = Mstr.set_union s locals } let mk_node n = function | Some tvs, dvty -> DEvar (n, specialize_scheme tvs dvty) | None, dvty -> DEvar (n, dvty) let denv_get denv n = mk_node n (Mstr.find_exn (Dterm.UnboundVar n) n denv.locals) let denv_get_opt denv n = Opt.map (mk_node n) (Mstr.find_opt n denv.locals) (** Unification tools *) let dity_unify_app ls fn (l1: 'a list) (l2: dity list) = try List.iter2 fn l1 l2 with Invalid_argument _ -> raise (BadArity (ls, List.length l1)) let dpat_expected_type {dp_dity = dp_dity; dp_loc = loc} dity = try dity_unify dp_dity dity with Exit -> Loc.errorm ?loc "This pattern has type %a,@ but is expected to have type %a" print_dity dp_dity print_dity dity let dpat_expected_type_weak {dp_dity = dp_dity; dp_loc = loc} dity = try dity_unify_weak dp_dity dity with Exit -> Loc.errorm ?loc "This pattern has type %a,@ but is expected to have type %a" print_dity dp_dity print_dity dity let dexpr_expected_type {de_dvty = (al,res); de_loc = loc} dity = if al <> [] then Loc.errorm ?loc "This expression is not a first-order value"; try dity_unify res dity with Exit -> Loc.errorm ?loc "This expression has type %a,@ but is expected to have type %a" print_dity res print_dity dity let dexpr_expected_type_weak {de_dvty = (al,res); de_loc = loc} dity = if al <> [] then Loc.errorm ?loc "This expression is not a first-order value"; try dity_unify_weak res dity with Exit -> Loc.errorm ?loc "This expression has type %a,@ but is expected to have type %a" print_dity res print_dity dity (** Generation of letrec blocks *) type pre_fun_defn = preid * ghost * dbinder list * dity * (denv -> dexpr * dspec later) exception DupId of preid let drec_defn denv0 prel = if prel = [] then invalid_arg "Mlw_dexpr.drec_defn: empty function list"; let add s (id,_,_,_,_) = Sstr.add_new (DupId id) id.pre_name s in let _ = try List.fold_left add Sstr.empty prel with DupId id -> Loc.errorm ?loc:id.pre_loc "duplicate function name %s" id.pre_name in let add denv (id,_,bl,res,_) = if bl = [] then invalid_arg "Mlw_dexpr.drec_defn: empty argument list"; let argl = List.map (fun (_,_,_,t) -> t) bl in denv_add_rec denv denv0.frozen id (argl,res) in let denv1 = List.fold_left add denv0 prel in let parse (id,gh,bl,res,pre) = let de, dsp = pre (denv_add_args denv1 bl) in dexpr_expected_type_weak de res; (id,gh,bl,de,dsp) in let fdl = List.map parse prel in let add denv ((id,_,_,_,_) as fd) = let check tv = if is_frozen denv0.frozen tv then Loc.errorm ?loc:id.pre_loc "This function is expected to be polymorphic in type variable %a" Pretty.print_tv tv in begin match Mstr.find_opt id.pre_name denv1.locals with | Some (Some tvs, _) -> Stv.iter check tvs | Some (None, _) | None -> assert false end; denv_add_fun denv fd in List.fold_left add denv0 fdl, { fds = fdl } (** Constructors *) let dpattern ?loc node = let mk_dpat pre dity vars = { dp_pat = pre; dp_dity = dity; dp_vars = vars; dp_loc = loc } in let dpat = function | DPwild -> mk_dpat PPwild (dity_fresh ()) Mstr.empty | DPvar id -> let dity = dity_fresh () in mk_dpat (PPvar id) dity (Mstr.singleton id.pre_name dity) | DPlapp (ls,dpl) -> if ls.ls_constr = 0 then raise (ConstructorExpected ls); let argl, res = specialize_ls ls in dity_unify_app ls dpat_expected_type dpl argl; let join n _ _ = raise (Dterm.DuplicateVar n) in let add acc dp = Mstr.union join acc dp.dp_vars in let vars = List.fold_left add Mstr.empty dpl in let ppl = List.map (fun dp -> dp.dp_pat) dpl in mk_dpat (PPlapp (ls, ppl)) res vars | DPpapp ({pl_ls = ls} as pl, dpl) -> if ls.ls_constr = 0 then raise (ConstructorExpected ls); let argl, res = specialize_pl pl in dity_unify_app ls dpat_expected_type dpl argl; let join n _ _ = raise (Dterm.DuplicateVar n) in let add acc dp = Mstr.union join acc dp.dp_vars in let vars = List.fold_left add Mstr.empty dpl in let ppl = List.map (fun dp -> dp.dp_pat) dpl in mk_dpat (PPpapp (pl, ppl)) res vars | DPor (dp1,dp2) -> dpat_expected_type dp2 dp1.dp_dity; let join n dity1 dity2 = try dity_unify dity1 dity2; Some dity1 with Exit -> Loc.errorm ?loc "Variable %s has type %a,@ but is expected to have type %a" n print_dity dity1 print_dity dity2 in let vars = Mstr.union join dp1.dp_vars dp2.dp_vars in mk_dpat (PPor (dp1.dp_pat, dp2.dp_pat)) dp1.dp_dity vars | DPas (dp, ({pre_name = n} as id)) -> let { dp_pat = pat; dp_dity = dity; dp_vars = vars } = dp in let vars = Mstr.add_new (Dterm.DuplicateVar n) n dity vars in mk_dpat (PPas (pat, id)) dity vars | DPcast (dp, ity) -> dpat_expected_type_weak dp (dity_of_ity ity); dp in Loc.try1 ?loc dpat node let dexpr ?loc node = let get_dvty = function | DEvar (_,dvty) -> dvty | DEgpvar pv -> [], specialize_pv pv | DEgpsym ps -> specialize_ps ps | DEplapp (pl,del) -> let argl, res = specialize_pl pl in dity_unify_app pl.pl_ls dexpr_expected_type del argl; [], res | DElsapp (ls,del) -> let argl, res = specialize_ls ls in dity_unify_app ls dexpr_expected_type del argl; [], res | DEapply ({de_dvty = (dity::argl, res)}, de2) -> dexpr_expected_type de2 dity; argl, res | DEapply ({de_dvty = ([],res)} as de1, de2) -> let rec not_arrow = function | Dvar {contents = Dval dity} -> not_arrow dity | Dpur (ts,_) -> not (ts_equal ts Ty.ts_func) | Dvar _ -> false | _ -> true in if not_arrow res then Loc.errorm ?loc:de1.de_loc "This expression has type %a,@ it cannot be applied" print_dity res; let argl, res = specialize_ls fs_func_app in dity_unify_app fs_func_app dexpr_expected_type [de1;de2] argl; [], res | DEconst (_, ity) -> [], dity_of_ity ity | DEfun ((_,_,[],_,_),_) -> invalid_arg "Mlw_dexpr.dexpr: empty argument list in DEfun" | DElet (_,de) | DEfun (_,de) | DErec (_,de) -> de.de_dvty | DElam ([],_,_) -> invalid_arg "Mlw_dexpr.dexpr: empty argument list in DElam" | DElam (bl,{de_dvty = (argl,res)},_) -> List.fold_right (fun (_,_,_,t) l -> t::l) bl argl, res | DEif (de1,de2,de3) -> let res = dity_fresh () in dexpr_expected_type de1 dity_bool; dexpr_expected_type de2 res; dexpr_expected_type de3 res; de2.de_dvty | DEcase (_,[]) -> invalid_arg "Mlw_dexpr.dexpr: empty branch list in DEcase" | DEcase (de,bl) -> let ety = dity_fresh () in let res = dity_fresh () in dexpr_expected_type de ety; let branch (dp,de) = dpat_expected_type dp ety; dexpr_expected_type de res in List.iter branch bl; [], res | DEassign (pl,de1,de2) -> let argl, res = specialize_pl pl in dity_unify_app pl.pl_ls dexpr_expected_type [de1] argl; dexpr_expected_type_weak de2 res; dvty_unit | DElazy (_,de1,de2) -> dexpr_expected_type de1 dity_bool; dexpr_expected_type de2 dity_bool; de1.de_dvty | DEnot de -> dexpr_expected_type de dity_bool; de.de_dvty | DEtrue | DEfalse -> dvty_bool | DEraise (xs,de) -> dexpr_expected_type de (specialize_xs xs); [], dity_fresh () | DEtry (_,[]) -> invalid_arg "Mlw_dexpr.dexpr: empty branch list in DEtry" | DEtry (de,bl) -> let res = dity_fresh () in dexpr_expected_type de res; let branch (xs,dp,de) = let ety = specialize_xs xs in dpat_expected_type dp ety; dexpr_expected_type de res in List.iter branch bl; de.de_dvty | DEfor (_,de_from,_,de_to,_,de) -> dexpr_expected_type de_from dity_int; dexpr_expected_type de_to dity_int; dexpr_expected_type de dity_unit; de.de_dvty | DEwhile (de1,_,de2) -> dexpr_expected_type de1 dity_bool; dexpr_expected_type de2 dity_unit; de2.de_dvty | DEloop (_,de) -> dexpr_expected_type de dity_unit; de.de_dvty | DEabsurd -> [], dity_fresh () | DEassert _ -> dvty_unit | DEabstract (de,_) | DEmark (_,de) | DEghost de -> de.de_dvty | DEany (dtv,_) -> dvty_of_dtype_v dtv | DEcast (de,ity) -> dexpr_expected_type_weak de (dity_of_ity ity); de.de_dvty | DEuloc (de,_) | DElabel (de,_) -> de.de_dvty in let dvty = Loc.try1 ?loc get_dvty node in { de_node = node; de_dvty = dvty; de_loc = loc } let mk_dexpr loc d n = { de_node = n; de_dvty = d; de_loc = loc } let de_void loc = mk_dexpr loc dvty_unit (DElsapp (fs_void, [])) let pat_void loc = { dp_pat = PPlapp (fs_void, []); dp_dity = dity_unit; dp_vars = Mstr.empty; dp_loc = loc } (** Final stage *) (** Binders *) let binders bl = let sn = ref Sstr.empty in let binder (id, ghost, _, dity) = let id = match id with | Some ({pre_name = n} as id) -> let exn = match id.pre_loc with | Some loc -> Loc.Located (loc, Dterm.DuplicateVar n) | None -> Dterm.DuplicateVar n in sn := Sstr.add_new exn n !sn; id | None -> id_fresh "_" in create_pvsymbol id ~ghost (ity_of_dity dity) in List.map binder bl let opaque_binders otv bl = List.fold_left (fun otv (_,_,s,_) -> Stv.union otv s) otv bl (** Specifications *) let to_fmla f = match f.t_ty with | None -> f | Some ty when ty_equal ty ty_bool -> t_equ f t_bool_true | _ -> Loc.error ?loc:f.t_loc Dterm.FmlaExpected let create_assert f = t_label_add Split_goal.stop_split (to_fmla f) let create_pre fl = t_and_simp_l (List.map create_assert fl) let create_inv = create_pre let create_post u (v,f) = let f = match v with | Some v when vs_equal u v -> f | Some v -> Loc.try3 ?loc:f.t_loc t_subst_single v (t_var u) f | None -> f in let f = Mlw_wp.remove_old (to_fmla f) in t_label_add Split_goal.stop_split f let create_post ty ql = let rec get_var = function | [] -> create_vsymbol (id_fresh "result") ty | (Some v, _) :: _ -> Ty.ty_equal_check ty v.vs_ty; v | _ :: l -> get_var l in let u = get_var ql in let f = t_and_simp_l (List.map (create_post u) ql) in Mlw_ty.create_post u f let create_xpost xql = Mexn.mapi (fun xs ql -> create_post (ty_of_ity xs.xs_ity) ql) xql let spec_of_dspec eff ty dsp = { c_pre = create_pre dsp.ds_pre; c_post = create_post ty dsp.ds_post; c_xpost = create_xpost dsp.ds_xpost; c_effect = eff; c_variant = dsp.ds_variant; c_letrec = 0; } (** User effects *) let mk_field ity gh mut = {fd_ity = ity; fd_ghost = gh; fd_mut = mut} let rec effect_of_term t = match t.t_node with | Tvar vs -> let pv = try restore_pv vs with Not_found -> Loc.errorm ?loc:t.t_loc "unsupported effect expression" in vs, mk_field pv.pv_ity pv.pv_ghost None | Tapp (fs,[ta]) -> let vs, fa = effect_of_term ta in let ofa,ofv = try match restore_pl fs with | {pl_args = [ofa]; pl_value = ofv} -> ofa, ofv | _ -> assert false with Not_found -> match fs with | {ls_args = [tya]; ls_value = Some tyv} -> mk_field (ity_of_ty tya) false None, mk_field (ity_of_ty tyv) false None | {ls_args = [_]; ls_value = None} -> Loc.errorm ?loc:t.t_loc "unsupported effect expression" | _ -> assert false in let sbs = ity_match ity_subst_empty ofa.fd_ity fa.fd_ity in let ity = try ity_full_inst sbs ofv.fd_ity with Not_found -> Loc.errorm ?loc:t.t_loc "unsupported effect expression" in let gh = (fa.fd_ghost && not ofa.fd_ghost) || ofv.fd_ghost in let mut = Opt.map (reg_full_inst sbs) ofv.fd_mut in vs, mk_field ity gh mut | _ -> Loc.errorm ?loc:t.t_loc "unsupported effect expression" let effect_of_dspec dsp = let add_raise xs _ eff = eff_raise eff xs in let eff = Mexn.fold add_raise dsp.ds_xpost eff_empty in let eff = if dsp.ds_diverge then eff_diverge eff else eff in let svs = List.fold_right Svs.add dsp.ds_reads Svs.empty in let add_write (svs,mreg,eff) t = let vs, fd = effect_of_term t in match fd.fd_mut, fd.fd_ity.ity_node with | Some reg, _ -> Svs.add vs svs, Mreg.add reg t mreg, eff_write eff ~ghost:fd.fd_ghost reg | None, Ityapp ({its_ghrl = ghrl},_,(_::_ as regl)) -> let add_reg mreg reg = Mreg.add reg t mreg in let add_write eff gh reg = eff_write eff ~ghost:(fd.fd_ghost || gh) reg in Svs.add vs svs, List.fold_left add_reg mreg regl, List.fold_left2 add_write eff ghrl regl | _ -> Loc.errorm ?loc:t.t_loc "mutable expression expected" in List.fold_left add_write (svs,Mreg.empty,eff) dsp.ds_writes let e_find_loc pr e = try (e_find (fun e -> e.e_loc <> None && pr e) e).e_loc with Not_found -> None let lab_w_diverges_no = Ident.create_label "W:diverges:N" let check_user_effect ?ps e spec args dsp = let has_write reg eff = Sreg.mem reg eff.eff_writes || Sreg.mem reg eff.eff_ghostw in let has_raise xs eff = Sexn.mem xs eff.eff_raises || Sexn.mem xs eff.eff_ghostx in (* computed effect vs user effect *) let eeff = spec.c_effect in let args = Spv.of_list args in let full_xpost = ps <> None in let usvs, mreg, ueff = effect_of_dspec dsp in (* check that every user effect actually happens *) let check_read vs = let pv = try restore_pv vs with Not_found -> Loc.errorm "unsupported@ effect@ expression" in if Spv.mem pv args then Warning.emit ?loc:e.e_loc "variable@ %a@ is@ a@ local@ function@ argument,@ \ it@ does@ not@ have@ to@ be@ listed@ in@ the@ `reads'@ clause" Pretty.print_vs vs; if not (Spv.mem pv e.e_syms.syms_pv) then Loc.errorm ?loc:e.e_loc "variable@ %a@ does@ not@ occur@ in@ this@ expression" Pretty.print_vs vs in List.iter check_read dsp.ds_reads; let check_write reg = if not (has_write reg eeff) then let t = Mreg.find reg mreg in Loc.errorm ?loc:t.t_loc "this@ write@ effect@ does@ not@ happen@ in@ the@ expression" in Sreg.iter check_write ueff.eff_writes; Sreg.iter check_write ueff.eff_ghostw; let check_raise xs _ = if not (has_raise xs eeff) then Loc.errorm ?loc:e.e_loc "this@ expression@ does@ not@ raise@ exception@ %a" Mlw_pretty.print_xs xs in Mexn.iter check_raise ueff.eff_raises; Mexn.iter check_raise ueff.eff_ghostx; if ueff.eff_diverg && not eeff.eff_diverg then Loc.errorm ?loc:e.e_loc "this@ expression@ does@ not@ diverge"; (* check that every computed effect is listed *) let check_read pv = if not (Svs.mem pv.pv_vs usvs) then Loc.errorm ?loc:(e_find_loc (fun e -> Spv.mem pv e.e_syms.syms_pv) e) "this@ expression@ depends@ on@ variable@ %a@ \ left@ out@ in@ the@ specification" Mlw_pretty.print_pv pv in let check_write reg = if not (has_write reg ueff) then Loc.errorm ?loc:(e_find_loc (fun e -> has_write reg e.e_effect) e) "this@ expression@ produces@ an@ unlisted@ write@ effect" in if dsp.ds_checkrw then begin let reads = Spv.remove Mlw_decl.pv_old e.e_syms.syms_pv in let reads = Spv.diff reads (spec_pvset Spv.empty spec) in Spv.iter check_read (Spv.diff reads args); Sreg.iter check_write eeff.eff_writes; Sreg.iter check_write eeff.eff_ghostw; end; let check_raise xs = if not (has_raise xs ueff) then Loc.errorm ?loc:(e_find_loc (fun e -> has_raise xs e.e_effect) e) "this@ expression@ raises@ unlisted@ exception@ %a" Mlw_pretty.print_xs xs in if full_xpost then Sexn.iter check_raise eeff.eff_raises; if full_xpost then Sexn.iter check_raise eeff.eff_ghostx; if eeff.eff_diverg && not ueff.eff_diverg then match ps with | Some {ps_name = {id_label = l}} when not (Slab.mem lab_w_diverges_no l) -> Warning.emit ?loc:(e_find_loc (fun e -> e.e_effect.eff_diverg) e) "this@ expression@ may@ diverge,@ \ which@ is@ not@ stated@ in@ the@ specification" | _ -> () let check_lambda_effect ({fun_lambda = lam} as fd) bl dsp = let spec = fd.fun_ps.ps_aty.aty_spec in let args = fd.fun_ps.ps_aty.aty_args in check_user_effect ~ps:fd.fun_ps lam.l_expr spec args dsp; let optv = opaque_binders Stv.empty bl in let bad_comp tv _ _ = Loc.errorm ?loc:(e_find_loc (fun e -> Stv.mem tv e.e_effect.eff_compar) lam.l_expr) "type parameter %a is not opaque in this expression" Pretty.print_tv tv in ignore (Mtv.inter bad_comp optv spec.c_effect.eff_compar) let check_user_ps recu ps = let ps_regs = ps.ps_subst.ity_subst_reg in let report r = if Mreg.mem r ps_regs then let spv = Spv.filter (fun pv -> reg_occurs r pv.pv_ity.ity_vars) ps.ps_pvset in Loc.errorm "The type of this function contains an alias with \ external variable %a" Mlw_pretty.print_pv (Spv.choose spv) else Loc.errorm "The type of this function contains an alias" in let rec check regs ity = match ity.ity_node with | Ityapp (_,_,rl) -> let add regs r = if Mreg.mem r regs then report r else check (Mreg.add r r regs) r.reg_ity in let regs = List.fold_left add regs rl in ity_fold check regs ity | _ -> ity_fold check regs ity in let rec down regs a = let add regs pv = check regs pv.pv_ity in let regs = List.fold_left add regs a.aty_args in match a.aty_result with | VTarrow a -> down regs a | VTvalue v -> check (if recu then regs else ps_regs) v (* we allow the value in a non-recursive function to contain regions coming the function's arguments, but not from the context. It is sometimes useful to write a function around a constructor or a projection. For recursive functions, we impose the full non-alias discipline, to ensure the safety of region polymorphism (see add_rec_mono). *) in ignore (down ps_regs ps.ps_aty) (** Environment *) type local_env = { kn : Mlw_decl.known_map; lkn : Decl.known_map; psm : psymbol Mstr.t; pvm : pvsymbol Mstr.t; vsm : vsymbol Mstr.t; } let env_empty lkn kn = { kn = kn; lkn = lkn; psm = Mstr.empty; pvm = Mstr.empty; vsm = Mstr.empty; } let add_psymbol ({psm = psm} as lenv) ps = let n = ps.ps_name.id_string in { lenv with psm = Mstr.add n ps psm } let add_pvsymbol ({pvm = pvm; vsm = vsm} as lenv) pv = let n = pv.pv_vs.vs_name.id_string in { lenv with pvm = Mstr.add n pv pvm; vsm = Mstr.add n pv.pv_vs vsm } let add_pv_map ({pvm = pvm; vsm = vsm} as lenv) vm = let um = Mstr.map (fun pv -> pv.pv_vs) vm in { lenv with pvm = Mstr.set_union vm pvm; vsm = Mstr.set_union um vsm } let add_let_sym env = function | LetV pv -> add_pvsymbol env pv | LetA ps -> add_psymbol env ps let add_fundef env fd = add_psymbol env fd.fun_ps let add_fundefs env fdl = List.fold_left add_fundef env fdl let add_binders env pvl = List.fold_left add_pvsymbol env pvl (** Invariant handling *) let env_invariant {lkn = lkn; kn = kn} eff pvs = let regs = Sreg.union eff.eff_writes eff.eff_ghostw in let add_pv pv (pinv,qinv) = let ity = pv.pv_ity in let written r = reg_occurs r ity.ity_vars in let inv = Mlw_wp.full_invariant lkn kn pv.pv_vs ity in let qinv = (* we reprove invariants for modified non-reset variables *) if Sreg.exists written regs && not (eff_stale_region eff ity.ity_vars) then t_and_simp qinv inv else qinv in t_and_simp pinv inv, qinv in Spv.fold add_pv pvs (t_true,t_true) let rec check_reset rvs t = match t.t_node with | Tvar vs when Svs.mem vs rvs -> Loc.errorm "Variable %s is reset and can only be used \ under `old' in the postcondition" vs.vs_name.id_string | Tapp (ls,_) when ls_equal ls Mlw_wp.fs_at -> false | Tlet _ | Tcase _ | Teps _ | Tquant _ -> let rvs = Mvs.set_inter rvs (t_vars t) in if Mvs.is_empty rvs then false else t_any (check_reset rvs) t | _ -> t_any (check_reset rvs) t let post_invariant {lkn = lkn; kn = kn} rvs inv ity q = ignore (check_reset rvs q); let vs, q = open_post q in let res_inv = Mlw_wp.full_invariant lkn kn vs ity in let q = t_and_asym_simp (t_and_simp res_inv inv) q in Mlw_ty.create_post vs q let reset_vars eff pvs = let add pv s = if eff_stale_region eff pv.pv_ity.ity_vars then Svs.add pv.pv_vs s else s in if Mreg.is_empty eff.eff_resets then Svs.empty else Spv.fold add pvs Svs.empty let spec_invariant env pvs vty spec = let ity = ity_of_vty vty in let pvs = spec_pvset pvs spec in let rvs = reset_vars spec.c_effect pvs in let pinv,qinv = env_invariant env spec.c_effect pvs in let post_inv = post_invariant env rvs qinv in let xpost_inv xs q = post_inv xs.xs_ity q in { spec with c_pre = t_and_asym_simp pinv spec.c_pre; c_post = post_inv ity spec.c_post; c_xpost = Mexn.mapi xpost_inv spec.c_xpost } (** Abstract values *) let warn_unused s loc = if not (Debug.test_flag Dterm.debug_ignore_unused_var) then if s = "" || s.[0] <> '_' then Warning.emit ?loc "unused variable %s" s let check_used_pv e pv = if not (Spv.mem pv e.e_syms.syms_pv) then warn_unused pv.pv_vs.vs_name.id_string pv.pv_vs.vs_name.id_loc let check_used_ps e ps = if not (Sps.mem ps e.e_syms.syms_ps) then warn_unused ps.ps_name.id_string ps.ps_name.id_loc let rec type_c env pvs vars otv (dtyv, dsp) = let vty = type_v env pvs vars otv dtyv in let res = ty_of_vty vty in let dsp = dsp env.vsm res in let esvs, _, eff = effect_of_dspec dsp in (* refresh every subregion of a modified region *) let writes = Sreg.union eff.eff_writes eff.eff_ghostw in let check u eff = reg_fold (fun r e -> eff_refresh e r u) u.reg_ity.ity_vars eff in let eff = Sreg.fold check writes eff in (* eff_compare every type variable not marked as opaque *) let eff = Stv.fold_left eff_compare eff (Stv.diff vars.vars_tv otv) in (* make spec *) let spec = spec_of_dspec eff res dsp in if spec.c_variant <> [] then Loc.errorm "variants are not allowed in a parameter declaration"; (* we add a fake variant term for every external variable in effect expressions which also does not occur in pre/post/xpost. In this way, we store the variable in the specification in order to keep the effect from being erased by Mlw_ty.spec_filter. Variants are ignored outside of "let rec" definitions, so WP are not affected. *) let del_pv pv s = Svs.remove pv.pv_vs s in let esvs = Spv.fold del_pv pvs esvs in let drop _ t s = Mvs.set_diff s (t_vars t) in let esvs = drop () spec.c_pre esvs in let esvs = drop () spec.c_post esvs in let esvs = Mexn.fold drop spec.c_xpost esvs in let add_vs vs varl = (t_var vs, None) :: varl in let varl = Svs.fold add_vs esvs spec.c_variant in let spec = { spec with c_variant = varl } in spec, vty and type_v env pvs vars otv = function | DSpecV v -> VTvalue (ity_of_dity v) | DSpecA (bl,tyc) -> let pvl = binders bl in let env = add_binders env pvl in let otv = opaque_binders otv bl in let add_pv pv s = vars_union pv.pv_ity.ity_vars s in let vars = List.fold_right add_pv pvl vars in let pvs = List.fold_right Spv.add pvl pvs in let spec, vty = type_c env pvs vars otv tyc in let spec = spec_invariant env pvs vty spec in VTarrow (vty_arrow pvl ~spec vty) let val_decl env (id,ghost,dtyv) = match type_v env Spv.empty vars_empty Stv.empty dtyv with | VTvalue v -> LetV (create_pvsymbol id ~ghost v) | VTarrow a -> LetA (create_psymbol id ~ghost a) (** Expressions *) let implicit_post = Debug.register_flag "implicit_post" ~desc:"Generate@ a@ postcondition@ for@ pure@ functions@ without@ one." let e_ghostify gh e = if gh && not e.e_ghost then e_ghost e else e let rec strip uloc labs de = match de.de_node with | DEcast (de,_) -> strip uloc labs de | DEuloc (de,loc) -> strip (Some loc) labs de | DElabel (de,s) -> strip uloc (Slab.union labs s) de | _ -> uloc, labs, de let rec expr ~keep_loc uloc env ({de_loc = loc} as de) = let uloc, labs, de = strip uloc Slab.empty de in let e = Loc.try4 ?loc try_expr keep_loc uloc env de in let loc = if keep_loc then loc else None in let loc = if uloc <> None then uloc else loc in if loc = None && Slab.is_empty labs then e else e_label ?loc labs e and try_expr keep_loc uloc env ({de_dvty = argl,res} as de0) = let get env de = expr ~keep_loc uloc env de in match de0.de_node with | DEvar (n,_) when argl = [] -> e_value (Mstr.find_exn (Dterm.UnboundVar n) n env.pvm) | DEvar (n,_) -> let ps = Mstr.find_exn (Dterm.UnboundVar n) n env.psm in e_arrow ps (List.map ity_of_dity argl) (ity_of_dity res) | DEgpvar pv -> e_value pv | DEgpsym ps -> e_arrow ps (List.map ity_of_dity argl) (ity_of_dity res) | DEplapp (pl,del) -> let get_gh fd de = e_ghostify fd.fd_ghost (get env de) in e_plapp pl (List.map2 get_gh pl.pl_args del) (ity_of_dity res) | DElsapp (ls,del) -> e_lapp ls (List.map (get env) del) (ity_of_dity res) | DEapply ({de_dvty = (_::_, _)} as de1,de2) -> let e1 = get env de1 in let gh = match e1.e_vty with | VTarrow {aty_args = pv::_} -> pv.pv_ghost | _ -> assert false in e_app e1 [e_ghostify gh (get env de2)] | DEapply (de1,de2) -> e_lapp fs_func_app [get env de1; get env de2] (ity_of_dity res) | DEconst (c,ity) -> e_const c ity | DElet ((id,gh,de1),de2) -> let e1 = get env de1 in let mk_expr e1 = let e1 = e_ghostify gh e1 in let ld1 = create_let_defn id e1 in let env = add_let_sym env ld1.let_sym in let e2 = get env de2 in let e2_unit = match e2.e_vty with | VTvalue ity -> ity_equal ity ity_unit | _ -> false in let id_in_e2 = match ld1.let_sym with | LetV pv -> Spv.mem pv e2.e_syms.syms_pv | LetA ps -> Sps.mem ps e2.e_syms.syms_ps in if not id_in_e2 then warn_unused id.pre_name id.pre_loc; let e1_no_eff = Sreg.is_empty e1.e_effect.eff_writes && Sexn.is_empty e1.e_effect.eff_raises && not e1.e_effect.eff_diverg && (* if e1 is a recursive call, we may not know yet its effects, so we have to rely on an heuristic: if the result of e1 is not used in e2, then it was probably called for the effect. *) id_in_e2 in let e2 = if e2_unit (* e2 is unit *) && e2.e_ghost (* and e2 is ghost *) && not e1.e_ghost (* and e1 is non-ghost *) && not e1_no_eff (* and e1 has observable effects *) then e_let (create_let_defn (id_fresh "gh") e2) e_void else e2 in e_let ld1 e2 in let rec flatten e1 = match e1.e_node with | Elet (ld,_) (* can't let a non-ghost expr escape *) when gh && not ld.let_expr.e_ghost -> mk_expr e1 | Elet (ld,e1) -> e_let ld (flatten e1) | _ -> mk_expr e1 in begin match e1.e_vty with | VTarrow _ when e1.e_ghost && not gh -> (* TODO: localize *) Loc.errorm "%s must be a ghost function" id.pre_name | VTarrow _ -> flatten e1 | VTvalue _ -> mk_expr e1 end | DEif (de1,de2,de3) -> let e1 = get env de1 in let e2 = get env de2 in let e3 = get env de3 in e_if e1 e2 e3 | DEcase (de1,bl) -> let e1 = get env de1 in let ity = ity_of_expr e1 in let ghost = e1.e_ghost in let branch (dp,de) = let vm, pat = make_ppattern dp.dp_pat ~ghost ity in let e = get (add_pv_map env vm) de in Mstr.iter (fun _ pv -> check_used_pv e pv) vm; pat, e in e_case e1 (List.map branch bl) | DEassign (pl,de1,de2) -> e_assign pl (get env de1) (get env de2) | DElazy (DEand,de1,de2) -> e_lazy_and (get env de1) (get env de2) | DElazy (DEor,de1,de2) -> e_lazy_or (get env de1) (get env de2) | DEnot de -> e_not (get env de) | DEtrue -> e_true | DEfalse -> e_false | DEraise (xs,de) -> e_raise xs (get env de) (ity_of_dity res) | DEtry (de1,bl) -> let e1 = get env de1 in let add_branch (m,l) (xs,dp,de) = let vm, pat = make_ppattern dp.dp_pat xs.xs_ity in let e = get (add_pv_map env vm) de in Mstr.iter (fun _ pv -> check_used_pv e pv) vm; try Mexn.add xs ((pat,e) :: Mexn.find xs m) m, l with Not_found -> Mexn.add xs [pat,e] m, (xs::l) in let xsm, xsl = List.fold_left add_branch (Mexn.empty,[]) bl in let mk_branch xs = match Mexn.find xs xsm with | [{ ppat_pattern = { pat_node = Pvar vs }}, e] -> xs, Mlw_ty.restore_pv vs, e | [{ ppat_pattern = { pat_node = Pwild }}, e] -> xs, create_pvsymbol (id_fresh "_") xs.xs_ity, e | [{ ppat_pattern = { pat_node = Papp (fs,[]) }}, e] when ls_equal fs Mlw_expr.fs_void -> xs, create_pvsymbol (id_fresh "_") xs.xs_ity, e | bl -> let pv = create_pvsymbol (id_fresh "res") xs.xs_ity in let pl = List.rev_map (fun (p,_) -> [p.ppat_pattern]) bl in let bl = if Pattern.is_exhaustive [t_var pv.pv_vs] pl then bl else let _,pp = make_ppattern PPwild pv.pv_ity in (pp, e_raise xs (e_value pv) (ity_of_dity res)) :: bl in xs, pv, e_case (e_value pv) (List.rev bl) in e_try e1 (List.rev_map mk_branch xsl) | DEfor (id,de_from,dir,de_to,dinv,de) -> let e_from = get env de_from in let e_to = get env de_to in let pv = create_pvsymbol id ity_int in let env = add_pvsymbol env pv in let e = get env de in let inv = dinv env.vsm in e_for pv e_from dir e_to (create_inv inv) e | DEwhile (de1,varl_inv,de2) -> let loc = de0.de_loc in let de3 = mk_dexpr loc dvty_unit (DEtry (mk_dexpr loc dvty_unit (DEloop (varl_inv, mk_dexpr loc dvty_unit (DEif (de1, de2, mk_dexpr loc dvty_unit (DEraise (Mlw_module.xs_exit, de_void loc)))))), [Mlw_module.xs_exit, pat_void loc, de_void loc])) in try_expr keep_loc uloc env de3 | DEloop (varl_inv,de) -> let e = get env de in let varl, inv = varl_inv env.vsm in e_loop (create_inv inv) varl e | DEabsurd -> e_absurd (ity_of_dity res) | DEassert (ak,f) -> e_assert ak (create_assert (f env.vsm)) | DEabstract (de,dsp) -> let e = get env de in let tyv = ty_of_vty e.e_vty in let dsp = dsp env.vsm tyv in if dsp.ds_variant <> [] then Loc.errorm "variants are not allowed in `abstract'"; let spec = spec_of_dspec e.e_effect tyv dsp in check_user_effect e spec [] dsp; let speci = spec_invariant env e.e_syms.syms_pv e.e_vty spec in (* we do not require invariants on free variables *) let spec = { speci with c_pre = spec.c_pre } in (* no user post => we try to purify *) let spec = if dsp.ds_post <> [] then spec else match e_purify e with | Some t -> let vs, f = Mlw_ty.open_post spec.c_post in let f = t_and_simp (t_equ_simp (t_var vs) t) f in let f = t_label_add Split_goal.stop_split f in let post = Mlw_ty.create_post vs f in { spec with c_post = post } | None -> spec in e_abstract e spec | DEmark (id,de) -> let ld = create_let_defn id Mlw_wp.e_now in let env = add_let_sym env ld.let_sym in e_let ld (get env de) | DEghost de -> (* keep user ghost annotations even if redundant *) e_ghost (get env de) | DEany (dtyv, Some dsp) -> (* we do not add invariants to the top spec *) let spec, vty = type_c env Spv.empty vars_empty Stv.empty (dtyv,dsp) in e_any (Some spec) vty | DEany (dtyv, None) -> e_any None (type_v env Spv.empty vars_empty Stv.empty dtyv) | DEfun (fd,de) -> let fd = expr_fun ~keep_loc ~strict:true uloc env fd in let e = get (add_fundef env fd) de in check_used_ps e fd.fun_ps; e_rec [fd] e | DElam (bl,de,sp) -> let fd = id_fresh "fn", false, bl, de, sp in let fd = expr_fun ~keep_loc ~strict:false uloc env fd in let de = { de0 with de_node = DEgpsym fd.fun_ps } in e_rec [fd] (get env de) | DErec (fdl,de) -> let fdl = expr_rec ~keep_loc uloc env fdl in let e = get (add_fundefs env fdl) de in e_rec fdl e | DEcast _ | DEuloc _ | DElabel _ -> assert false (* already stripped *) and expr_rec ~keep_loc uloc env {fds = dfdl} = let step1 env (id, gh, bl, de, dsp) = let pvl = binders bl in if fst de.de_dvty <> [] then Loc.errorm ?loc:de.de_loc "The body of a recursive function must be a first-order value"; let aty = vty_arrow pvl (VTvalue (ity_of_dity (snd de.de_dvty))) in let ps = create_psymbol id ~ghost:gh aty in add_psymbol env ps, (ps, gh, bl, pvl, de, dsp) in let env, fdl = Lists.map_fold_left step1 env dfdl in let step2 (ps, gh, bl, pvl, de, dsp) (fdl, dfdl) = let lam, dsp = expr_lam ~keep_loc ~strict:true uloc env gh pvl de dsp in (ps, lam) :: fdl, (ps.ps_name, gh, bl, de, dsp) :: dfdl in (* check for unexpected aliases in case of trouble *) let fdl, dfdl = try List.fold_right step2 fdl ([],[]) with | Loc.Located (_, Mlw_ty.TypeMismatch _) | Mlw_ty.TypeMismatch _ as exn -> List.iter (fun (ps,_,_,_,_,_) -> let loc = Opt.get ps.ps_name.Ident.id_loc in Loc.try2 ~loc check_user_ps true ps) fdl; raise exn in let fdl = try create_rec_defn fdl with | Loc.Located (_, Mlw_ty.TypeMismatch _) | Mlw_ty.TypeMismatch _ as exn -> List.iter (fun (ps,lam) -> let loc = Opt.get ps.ps_name.Ident.id_loc in let fd = create_fun_defn (id_clone ps.ps_name) lam in Loc.try2 ~loc check_user_ps true fd.fun_ps) fdl; raise exn in let step3 { fun_ps = ps; fun_lambda = lam } = let { l_spec = spec; l_expr = e } = lam in let spec = spec_invariant env e.e_syms.syms_pv e.e_vty spec in ps, { lam with l_spec = { spec with c_letrec = 0 }} in let fdl = create_rec_defn (List.map step3 fdl) in let step4 fd (id,_,bl,de,dsp) = Loc.try3 ?loc:de.de_loc check_lambda_effect fd bl dsp; Loc.try2 ?loc:id.id_loc check_user_ps true fd.fun_ps in List.iter2 step4 fdl dfdl; fdl and expr_fun ~keep_loc ~strict uloc env (id,gh,bl,de,dsp) = let lam, dsp = expr_lam ~keep_loc ~strict uloc env gh (binders bl) de dsp in if lam.l_spec.c_variant <> [] then Loc.errorm ?loc:id.pre_loc "variants are not allowed in a non-recursive definition"; let lam = (* TODO: the following cannot work in letrec *) if Debug.test_noflag implicit_post || dsp.ds_post <> [] || oty_equal lam.l_spec.c_post.t_ty (Some ty_unit) then lam else match e_purify lam.l_expr with | None -> lam | Some t -> let vs, f = Mlw_ty.open_post lam.l_spec.c_post in let f = t_and_simp (t_equ_simp (t_var vs) t) f in let f = t_label_add Split_goal.stop_split f in let post = Mlw_ty.create_post vs f in let spec = { lam.l_spec with c_post = post } in { lam with l_spec = spec } in (* add invariants *) let { l_spec = spec; l_expr = e } = lam in let spec = spec_invariant env e.e_syms.syms_pv e.e_vty spec in let fd = create_fun_defn id { lam with l_spec = spec } in Loc.try3 ?loc:de.de_loc check_lambda_effect fd bl dsp; Loc.try2 ?loc:id.pre_loc check_user_ps false fd.fun_ps; fd and expr_lam ~keep_loc ~strict uloc env gh pvl de dsp = let env = add_binders env pvl in let e = e_ghostify gh (expr ~keep_loc uloc env de) in if strict && not gh && e.e_ghost then (* TODO: localize better *) Loc.errorm ?loc:de.de_loc "ghost body in a non-ghost function"; let tyv = ty_of_vty e.e_vty in let dsp = dsp env.vsm tyv in let spec = spec_of_dspec e.e_effect tyv dsp in { l_args = pvl; l_expr = e; l_spec = spec }, dsp let val_decl ~keep_loc:_ lkn kn vald = reunify_regions (); val_decl (env_empty lkn kn) vald let let_defn ~keep_loc lkn kn (id,gh,de) = reunify_regions (); let e = expr ~keep_loc None (env_empty lkn kn) de in let e = e_ghostify gh e in if e.e_ghost && not gh then (* TODO: localize better *) Loc.errorm ?loc:id.pre_loc "%s must be a ghost variable" id.pre_name; create_let_defn id e let fun_defn ~keep_loc lkn kn dfd = reunify_regions (); expr_fun ~keep_loc ~strict:true None (env_empty lkn kn) dfd let rec_defn ~keep_loc lkn kn dfdl = reunify_regions (); expr_rec ~keep_loc None (env_empty lkn kn) dfdl let expr ~keep_loc lkn kn de = reunify_regions (); expr ~keep_loc None (env_empty lkn kn) de why3-0.88.3/src/whyml/mlw_module.mli0000664000175100017510000001052313225666037020053 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** {1 Program modules} *) open Stdlib open Ident open Ty open Term open Decl open Theory open Mlw_ty open Mlw_ty.T open Mlw_expr open Mlw_decl type type_symbol = | PT of itysymbol | TS of tysymbol type prog_symbol = | PV of pvsymbol | PS of psymbol | PL of plsymbol | XS of xsymbol | LS of lsymbol type namespace = { ns_ts : type_symbol Mstr.t; (* type symbols *) ns_ps : prog_symbol Mstr.t; (* program symbols *) ns_ns : namespace Mstr.t; (* inner namespaces *) } val ns_find_type_symbol : namespace -> string list -> type_symbol val ns_find_prog_symbol : namespace -> string list -> prog_symbol val ns_find_its : namespace -> string list -> itysymbol val ns_find_ts : namespace -> string list -> tysymbol val ns_find_pv : namespace -> string list -> pvsymbol val ns_find_ps : namespace -> string list -> psymbol val ns_find_pl : namespace -> string list -> plsymbol val ns_find_xs : namespace -> string list -> xsymbol val ns_find_ls : namespace -> string list -> lsymbol val ns_find_ns : namespace -> string list -> namespace (** {2 Module} *) type modul = private { mod_theory: theory; (* pure theory *) mod_decls : pdecl list; (* module declarations *) mod_export: namespace; (* exported namespace *) mod_known : Mlw_decl.known_map; (* known identifiers *) mod_local : Sid.t; (* locally declared idents *) mod_used : Sid.t; (* used modules *) } (** {2 Module under construction} *) type module_uc (* a module under construction *) val create_module : Env.env -> ?path:string list -> preid -> module_uc val close_module : module_uc -> modul val open_namespace : module_uc -> string -> module_uc val close_namespace : module_uc -> bool -> module_uc val get_theory : module_uc -> theory_uc val get_namespace : module_uc -> namespace val get_known : module_uc -> Mlw_decl.known_map val restore_path : ident -> string list * string * string list (** [restore_path id] returns the triple (library path, module, qualified symbol name) if the ident was ever introduced in a module declaration. If the ident was declared in several different modules, the first association is retained. If [id] is a module name, the third component is an empty list. Raises Not_found if the ident was never declared in/as a module. *) val restore_module : theory -> modul (** retrieves a module from its underlying theory raises [Not_found] if no such module exists *) (** {2 Use and clone} *) val use_export : module_uc -> modul -> module_uc type mod_inst = { inst_pv : pvsymbol Mpv.t; inst_ps : psymbol Mps.t; } val clone_export : module_uc -> modul -> mod_inst -> th_inst -> module_uc (** {2 Logic decls} *) val add_decl : module_uc -> decl -> module_uc val use_export_theory: module_uc -> theory -> module_uc val clone_export_theory: module_uc -> theory -> th_inst -> module_uc val add_meta : module_uc -> meta -> meta_arg list -> module_uc (** {2 Program decls} *) val add_pdecl : wp:bool -> module_uc -> pdecl -> module_uc (** [add_pdecl ~wp m d] adds declaration [d] in module [m]. If [wp] is [true], VC is computed and added to [m]. *) exception TooLateInvariant val add_invariant : module_uc -> itysymbol -> post -> module_uc (** {2 Builtin symbols} *) val xs_exit : xsymbol (* exception used to break the loops *) (** {2 WhyML language} *) open Env type mlw_file = modul Mstr.t * theory Mstr.t val mlw_language : mlw_file language exception ModuleNotFound of pathname * string exception ModuleOrTheoryNotFound of pathname * string type module_or_theory = Module of modul | Theory of theory val read_module : env -> pathname -> string -> modul val read_module_or_theory : env -> pathname -> string -> module_or_theory why3-0.88.3/src/whyml/mlw_decl.ml0000664000175100017510000002647613225666037017342 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Stdlib open Ident open Ty open Term open Decl open Mlw_ty open Mlw_ty.T open Mlw_expr type constructor = plsymbol * plsymbol option list type data_decl = itysymbol * constructor list * post type pdecl = { pd_node : pdecl_node; pd_syms : Sid.t; (* idents used in declaration *) pd_news : Sid.t; (* idents introduced in declaration *) pd_tag : int; (* unique tag *) } and pdecl_node = | PDtype of itysymbol | PDdata of data_decl list | PDval of let_sym | PDlet of let_defn | PDrec of fun_defn list | PDexn of xsymbol let pd_equal : pdecl -> pdecl -> bool = (==) let ts_mark = create_tysymbol (id_fresh "'mark") [] NoDef let ty_mark = ty_app ts_mark [] let ity_mark = ity_pur ts_mark [] let pv_old = create_pvsymbol ~ghost:true (id_fresh "%old") ity_mark let mk_decl = let r = ref 0 in fun node syms news -> incr r; let syms = Sid.remove pv_old.pv_vs.vs_name syms in { pd_node = node; pd_syms = syms; pd_news = news; pd_tag = !r; } let news_id s id = Sid.add_new (Decl.ClashIdent id) id s (** {2 Declaration constructors} *) let create_ty_decl its = let news = Sid.singleton its.its_ts.ts_name in (* an abstract type must be declared using Decl.create_ty_decl *) if its.its_def = None then invalid_arg "Mlw_decl.create_ty_decl"; mk_decl (PDtype its) Sid.empty news type pre_field = preid option * field type pre_constructor = preid * pre_field list type pre_data_decl = itysymbol * pre_constructor list let null_invariant { its_ts = ts } = let ty = ty_app ts (List.map ty_var ts.ts_args) in let vs = create_vsymbol (id_fresh "dummy") ty in create_post vs t_true let create_data_decl tdl = let news = ref Sid.empty in let build_type (its,cl) = news := news_id !news its.its_ts.ts_name; let projections = Hstr.create 3 in let hidden = its.its_abst in let rdonly = its.its_priv in let constr = List.length cl in let tvl = List.map ity_var its.its_ts.ts_args in let ity = ity_app its tvl its.its_regs in let res = { fd_ity = ity; fd_ghost = false; fd_mut = None } in let tvs = List.fold_right Stv.add its.its_ts.ts_args Stv.empty in let regs = List.fold_right Sreg.add its.its_regs Sreg.empty in let nogh = ity_nonghost_reg Sreg.empty ity in let build_constructor (id,al) = (* check well-formedness *) let fds = List.map snd al in let check_vars { vars_tv = atvs; vars_reg = aregs } = if not (Stv.subset atvs tvs) then raise (UnboundTypeVar (Stv.choose (Stv.diff atvs tvs))); if not (Sreg.subset aregs regs) then raise (UnboundRegion (Sreg.choose (Sreg.diff aregs regs))) in let check_vars fd = match fd.fd_mut with | Some r -> if not (Sreg.mem r regs) then raise (UnboundRegion r) | None -> check_vars fd.fd_ity.ity_vars in let check_ghost fd = let regs = ity_nonghost_reg Sreg.empty fd.fd_ity in let regs = Opt.fold_right Sreg.add fd.fd_mut regs in if not (Sreg.subset regs nogh) then invalid_arg "Mlw_decl.create_data_decl" in let check_fd fd = if not fd.fd_ghost then check_ghost fd; check_vars fd in List.iter check_fd fds; (* build the constructor symbol *) let cs = create_plsymbol ~hidden ~rdonly ~constr id fds res in news := news_id !news cs.pl_ls.ls_name; (* build the projections, if any *) let build_proj fd id = try let pj = Hstr.find projections id.pre_name in ity_equal_check pj.pl_value.fd_ity fd.fd_ity; begin match pj.pl_value.fd_mut, fd.fd_mut with | None, None -> () | Some r1, Some r2 -> reg_equal_check r1 r2 | _,_ -> invalid_arg "Mlw_decl.create_data_decl" end; if pj.pl_value.fd_ghost <> fd.fd_ghost then invalid_arg "Mlw_decl.create_data_decl"; pj with Not_found -> let pj = create_plsymbol ~hidden id [res] fd in news := news_id !news pj.pl_ls.ls_name; Hstr.add projections id.pre_name pj; pj in cs, List.map (fun (id,fd) -> Opt.map (build_proj fd) id) al in its, List.map build_constructor cl, null_invariant its in let tdl = List.map build_type tdl in mk_decl (PDdata tdl) Sid.empty !news let add_invariant pd its p = if not its.its_inv then invalid_arg "Mlw_decl.add_invariant"; t_v_fold (fun _ vs -> raise (Decl.UnboundVar vs)) () p; let rec add = function | (s, cls, inv) :: tdl when its_equal s its -> check_post (t_type inv) p; let v, q = open_post inv in let u, p = open_post p in let q = t_and_simp (t_subst_single v (t_var u) q) p in let inv = create_post u q in (s, cls, inv) :: tdl | td :: tdl -> td :: add tdl | [] -> raise Not_found in match pd.pd_node with | PDdata tdl -> mk_decl (PDdata (add tdl)) pd.pd_syms pd.pd_news | _ -> invalid_arg "Mlw_decl.add_invariant" let check_vars vars = if not (Stv.is_empty vars.vars_tv) then Loc.errorm "Type variable '%s cannot be generalized" (Stv.choose vars.vars_tv).tv_name.id_string let letvar_news = function | LetV pv -> check_vars pv.pv_ity.ity_vars; Sreg.fold (fun r acc -> Sid.add r.reg_name acc) pv.pv_ity.ity_vars.vars_reg (Sid.singleton pv.pv_vs.vs_name) | LetA ps -> check_vars ps.ps_vars; Sid.singleton ps.ps_name let ids_of_pvset s pvs = Spv.fold (fun pv s -> Sid.add pv.pv_vs.vs_name s) pvs s let ids_of_syms s { syms_pv = pvs; syms_ps = pss } = Sps.fold (fun ps s -> Sid.add ps.ps_name s) pss (ids_of_pvset s pvs) let create_let_decl ld = let news = letvar_news ld.let_sym in let syms = ids_of_syms Sid.empty ld.let_expr.e_syms in mk_decl (PDlet ld) syms news let create_rec_decl fdl = let add_fd s { fun_ps = p } = check_vars p.ps_vars; news_id s p.ps_name in let news = List.fold_left add_fd Sid.empty fdl in let syms = ids_of_syms Sid.empty (e_rec fdl e_void).e_syms in mk_decl (PDrec fdl) syms news let create_val_decl lv = let news = letvar_news lv in let syms = match lv with | LetA ps -> ids_of_pvset Sid.empty ps.ps_pvset | LetV _ -> Sid.empty in mk_decl (PDval lv) syms news let create_exn_decl xs = let news = Sid.singleton xs.xs_name in mk_decl (PDexn xs) Sid.empty news (** {2 Cloning} *) let clone_data_decl sm pd = match pd.pd_node with | PDdata tdl -> let news = ref Sid.empty in let add_pl pl = let pl = Mls.find pl.pl_ls sm.sm_pls in news := news_id !news pl.pl_ls.ls_name; pl in let add_cs (cs,pjl) = add_pl cs, List.map (Opt.map add_pl) pjl in let add_td (its,csl,inv) = let conv_ts ts = Mts.find_def ts ts sm.sm_pure.Theory.sm_ts in let conv_ls ls = Mls.find_def ls ls sm.sm_pure.Theory.sm_ls in let inv = Term.t_s_map (Ty.ty_s_map conv_ts) conv_ls inv in let its = Mits.find its sm.sm_its in news := news_id !news its.its_ts.ts_name; its, List.map add_cs csl, inv in let tdl = List.map add_td tdl in mk_decl (PDdata tdl) Sid.empty !news | _ -> invalid_arg "Mlw_decl.clone_data_decl" (** {2 Known identifiers} *) type known_map = pdecl Mid.t let known_id kn id = if not (Mid.mem id kn) then raise (UnknownIdent id) let merge_known kn1 kn2 = let check_known id decl1 decl2 = if pd_equal decl1 decl2 then Some decl1 else raise (RedeclaredIdent id) in Mid.union check_known kn1 kn2 let known_add_decl lkn0 kn0 d = let kn = Mid.map (Util.const d) d.pd_news in let check id decl0 _ = if pd_equal decl0 d then raise (KnownIdent id) else raise (RedeclaredIdent id) in let kn = Mid.union check kn0 kn in let unk = Mid.set_diff d.pd_syms kn in let unk = Mid.set_diff unk lkn0 in if Sid.is_empty unk then kn else raise (UnknownIdent (Sid.choose unk)) let rec find_td its1 = function | (its2,csl,inv) :: _ when its_equal its1 its2 -> csl,inv | _ :: tdl -> find_td its1 tdl | [] -> raise Not_found let find_constructors kn its = match (Mid.find its.its_ts.ts_name kn).pd_node with | PDtype _ -> [] | PDdata tdl -> fst (find_td its tdl) | PDval _ | PDlet _ | PDrec _ | PDexn _ -> assert false let find_invariant kn its = match (Mid.find its.its_ts.ts_name kn).pd_node with | PDtype _ -> null_invariant its | PDdata tdl -> snd (find_td its tdl) | PDval _ | PDlet _ | PDrec _ | PDexn _ -> assert false let rec find_def ps = function | d :: _ when ps_equal ps d.fun_ps -> d | _ :: l -> find_def ps l | [] -> raise Not_found let find_definition kn ps = match (Mid.find ps.ps_name kn).pd_node with | PDtype _ -> assert false | PDdata _ -> assert false | PDval _ -> None | PDlet _ -> assert false | PDrec dl -> Some (find_def ps dl) | PDexn _ -> assert false let check_match lkn _kn d = let rec checkE () e = match e.e_node with | Ecase (_,bl) -> let pl = List.map (fun (pp,_) -> [pp.ppat_pattern]) bl in let get_constructors s = List.map fst (Decl.find_constructors lkn s) in Loc.try2 ?loc:e.e_loc (Pattern.check_compile ~get_constructors) [] pl; e_fold checkE () e | _ -> e_fold checkE () e in match d.pd_node with | PDrec fdl -> List.iter (fun fd -> checkE () fd.fun_lambda.l_expr) fdl | PDlet { let_expr = e } -> checkE () e | PDval _ | PDtype _ | PDdata _ | PDexn _ -> () exception NonupdatableType of ity let inst_constructors lkn kn ity = match ity.ity_node with | Itypur (ts,_) -> let csl = Decl.find_constructors lkn ts in let d = Mid.find ts.ts_name lkn in let is_rec = Mid.mem ts.ts_name d.Decl.d_syms in if csl = [] || is_rec then raise (NonupdatableType ity); let base = ity_pur ts (List.map ity_var ts.ts_args) in let sbs = ity_match ity_subst_empty base ity in let subst ty = { fd_ity = ity_full_inst sbs (ity_of_ty ty); fd_ghost = false; fd_mut = None; } in List.map (fun (cs,_) -> cs, List.map subst cs.ls_args) csl | Ityapp (its,_,_) -> let csl = find_constructors kn its in let d = Mid.find its.its_ts.ts_name lkn in let is_rec = Mid.mem its.its_ts.ts_name d.Decl.d_syms in if csl = [] || is_rec then raise (NonupdatableType ity); let args = List.map ity_var its.its_ts.ts_args in let base = ity_app its args its.its_regs in let sbs = ity_match ity_subst_empty base ity in let subst fd = { fd_ity = ity_full_inst sbs fd.fd_ity; fd_ghost = fd.fd_ghost; fd_mut = Opt.map (reg_full_inst sbs) fd.fd_mut; } in List.map (fun (cs,_) -> cs.pl_ls, List.map subst cs.pl_args) csl | Ityvar _ -> invalid_arg "Mlw_decl.inst_constructors" let known_add_decl lkn kn d = let kn = known_add_decl lkn kn d in check_match lkn kn d; kn why3-0.88.3/src/whyml/mlw_dexpr.mli0000664000175100017510000001203413225666037017707 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Stdlib open Ident open Ty open Term open Mlw_ty open Mlw_ty.T open Mlw_expr (** Program types *) type dity val dity_fresh : unit -> dity val dity_of_ity : ity -> dity type dvty = dity list * dity (* A -> B -> C == ([A;B],C) *) val dity_is_bool : dity -> bool val dvty_is_chainable : dvty -> bool (** Patterns *) type dpattern = private { dp_pat : pre_ppattern; dp_dity : dity; dp_vars : dity Mstr.t; dp_loc : Loc.position option; } type dpattern_node = | DPwild | DPvar of preid | DPlapp of lsymbol * dpattern list | DPpapp of plsymbol * dpattern list | DPor of dpattern * dpattern | DPas of dpattern * preid | DPcast of dpattern * ity (** Binders *) type ghost = bool type opaque = Stv.t type dbinder = preid option * ghost * opaque * dity (** Specifications *) type 'a later = vsymbol Mstr.t -> 'a (* Specification terms are parsed and typechecked after the program expressions, when the types of locally bound program variables are already established. *) type dspec_final = { ds_pre : term list; ds_post : (vsymbol option * term) list; ds_xpost : (vsymbol option * term) list Mexn.t; ds_reads : vsymbol list; ds_writes : term list; ds_variant : variant list; ds_checkrw : bool; ds_diverge : bool; } type dspec = ty -> dspec_final (* Computation specification is also parametrized by the result type. All vsymbols in the postcondition clauses in the [ds_post] field must have this type. All vsymbols in the exceptional postcondition clauses must have the type of the corresponding exception. *) type dtype_v = | DSpecV of dity | DSpecA of dbinder list * dtype_c and dtype_c = dtype_v * dspec later (** Expressions *) type dinvariant = term list type dlazy_op = DEand | DEor type dexpr = private { de_node : dexpr_node; de_dvty : dvty; de_loc : Loc.position option; } and dexpr_node = | DEvar of string * dvty | DEgpvar of pvsymbol | DEgpsym of psymbol | DEplapp of plsymbol * dexpr list | DElsapp of lsymbol * dexpr list | DEapply of dexpr * dexpr | DEconst of Number.constant * ity | DElam of dbinder list * dexpr * dspec later | DElet of dlet_defn * dexpr | DEfun of dfun_defn * dexpr | DErec of drec_defn * dexpr | DEif of dexpr * dexpr * dexpr | DEcase of dexpr * (dpattern * dexpr) list | DEassign of plsymbol * dexpr * dexpr | DElazy of dlazy_op * dexpr * dexpr | DEnot of dexpr | DEtrue | DEfalse | DEraise of xsymbol * dexpr | DEtry of dexpr * (xsymbol * dpattern * dexpr) list | DEfor of preid * dexpr * for_direction * dexpr * dinvariant later * dexpr | DEwhile of dexpr * (variant list * dinvariant) later * dexpr | DEloop of (variant list * dinvariant) later * dexpr | DEabsurd | DEassert of assertion_kind * term later | DEabstract of dexpr * dspec later | DEmark of preid * dexpr | DEghost of dexpr | DEany of dtype_v * dspec later option | DEcast of dexpr * ity | DEuloc of dexpr * Loc.position | DElabel of dexpr * Slab.t and dlet_defn = preid * ghost * dexpr and dfun_defn = preid * ghost * dbinder list * dexpr * dspec later and drec_defn = private { fds : dfun_defn list } type dval_decl = preid * ghost * dtype_v (** Environment *) type denv val denv_empty : denv val denv_add_var : denv -> preid -> dity -> denv val denv_add_let : denv -> dlet_defn -> denv val denv_add_fun : denv -> dfun_defn -> denv val denv_add_args : denv -> dbinder list -> denv val denv_add_pat : denv -> dpattern -> denv val denv_get : denv -> string -> dexpr_node (** raises UnboundVar *) val denv_get_opt : denv -> string -> dexpr_node option (** Constructors *) val dpattern : ?loc:Loc.position -> dpattern_node -> dpattern val dexpr : ?loc:Loc.position -> dexpr_node -> dexpr type pre_fun_defn = preid * ghost * dbinder list * dity * (denv -> dexpr * dspec later) val drec_defn : denv -> pre_fun_defn list -> denv * drec_defn (** Final stage *) val expr : keep_loc:bool -> Decl.known_map -> Mlw_decl.known_map -> dexpr -> expr val let_defn : keep_loc:bool -> Decl.known_map -> Mlw_decl.known_map -> dlet_defn -> let_defn val fun_defn : keep_loc:bool -> Decl.known_map -> Mlw_decl.known_map -> dfun_defn -> fun_defn val rec_defn : keep_loc:bool -> Decl.known_map -> Mlw_decl.known_map -> drec_defn -> fun_defn list val val_decl : keep_loc:bool -> Decl.known_map -> Mlw_decl.known_map -> dval_decl -> let_sym why3-0.88.3/src/whyml/mlw_typing.ml0000664000175100017510000015104513225666037017734 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Stdlib open Ident open Ty open Term open Decl open Theory open Ptree open Mlw_ty open Mlw_ty.T open Mlw_expr open Mlw_decl open Mlw_pretty open Mlw_dexpr open Mlw_module open Mlw_wp (** errors *) exception DuplicateTypeVar of string exception UnboundTypeVar of string (** lazy declaration of tuples *) let ht_tuple = Hint.create 3 let ts_tuple n = Hint.replace ht_tuple n (); ts_tuple n let fs_tuple n = Hint.replace ht_tuple n (); fs_tuple n let count_term_tuples t = let syms_ts _ ts = match is_ts_tuple_id ts.ts_name with | Some n -> Hint.replace ht_tuple n () | _ -> () in let syms_ty _ ty = ty_s_fold syms_ts () ty in t_s_fold syms_ty (fun _ _ -> ()) () t let flush_tuples uc = let kn = Theory.get_known (get_theory uc) in let add_tuple n _ uc = if Mid.mem (Ty.ts_tuple n).ts_name kn then uc else use_export_theory uc (tuple_theory n) in let uc = Hint.fold add_tuple ht_tuple uc in Hint.clear ht_tuple; uc let add_pdecl_with_tuples ~wp uc pd = if Debug.test_flag Glob.flag then Sid.iter Glob.def pd.pd_news; add_pdecl ~wp (flush_tuples uc) pd let add_decl_with_tuples uc d = if Debug.test_flag Glob.flag then Sid.iter Glob.def d.d_news; add_decl (flush_tuples uc) d (** symbol lookup *) let qloc = Typing.qloc let print_qualid = Typing.print_qualid let ns_find_ts ns p = let get_id_ts = function | PT pt -> pt.its_ts.ts_name | TS ts -> ts.ts_name in Typing.find_qualid get_id_ts ns_find_type_symbol ns p let uc_find_ts uc p = ns_find_ts (get_namespace uc) p let ns_find_ps ns p = let get_id_ps = function | PV pv -> pv.pv_vs.vs_name | PS ps -> ps.ps_name | PL pl -> pl.pl_ls.ls_name | XS xs -> xs.xs_name | LS ls -> ls.ls_name in Typing.find_qualid get_id_ps ns_find_prog_symbol ns p let uc_find_ps uc p = ns_find_ps (get_namespace uc) p let uc_find_ls uc p = let ns = Theory.get_namespace (get_theory uc) in Typing.find_qualid (fun ls -> ls.ls_name) Theory.ns_find_ls ns p (** parsing types *) let ity_of_pty ?(noop=true) uc pty = let rec get_ty = function | PTtyvar ({id_loc = loc}, true) when noop -> Loc.errorm ~loc "Opaqueness@ annotations@ are@ only@ \ allowed@ in@ the@ types@ of@ formal@ arguments" | PTtyvar ({id_str = x}, _) -> ity_var (tv_of_string x) | PTtyapp (q, tyl) -> let tyl = List.map get_ty tyl in begin match uc_find_ts uc q with | PT s -> Loc.try2 ~loc:(qloc q) ity_app_fresh s tyl | TS s -> Loc.try2 ~loc:(qloc q) ity_pur s tyl end | PTtuple tyl -> let s = ts_tuple (List.length tyl) in ity_pur s (List.map get_ty tyl) | PTarrow (ty1, ty2) -> ity_pur ts_func [get_ty ty1; get_ty ty2] | PTparen ty -> get_ty ty in get_ty pty let rec opaque_tvs acc = function | PTtyvar (id, true) -> Stv.add (tv_of_string id.id_str) acc | PTtyvar (_, false) -> acc | PTtyapp (_, pl) | PTtuple pl -> List.fold_left opaque_tvs acc pl | PTarrow (ty1, ty2) -> opaque_tvs (opaque_tvs acc ty1) ty2 | PTparen ty -> opaque_tvs acc ty (** typing program expressions *) (* records *) let parse_prog_record uc fll = let pl = match fll with | [] -> raise EmptyRecord | (pl,_)::_ -> pl in let its = match pl.pl_args with | [{ fd_ity = { ity_node = Ityapp (its,_,_) }}] -> its | _ -> raise (BadRecordField pl.pl_ls) in let cs, pjl = match find_constructors (get_known uc) its with | [cs,pjl] -> cs, List.map (Opt.get_exn (BadRecordField pl.pl_ls)) pjl | _ -> raise (BadRecordField pl.pl_ls) in let pjs = List.fold_left (fun s pj -> Sls.add pj.pl_ls s) Sls.empty pjl in let flm = List.fold_left (fun m (pj,v) -> let pj = pj.pl_ls in if not (Sls.mem pj pjs) then raise (BadRecordField pj) else Mls.add_new (DuplicateRecordField (cs.pl_ls,pj)) pj v m) Mls.empty fll in cs,pjl,flm let find_prog_field uc (p,e) = match uc_find_ps uc p with PL pl -> pl, e | _ -> Loc.errorm ~loc:(qloc p) "Not a record field: %a" print_qualid p let find_pure_field uc (p,e) = match uc_find_ps uc p with LS ls -> ls, e | _ -> Loc.errorm ~loc:(qloc p) "Not a record field: %a" print_qualid p let prog_record ~loc uc get_val fl = let fl = List.map (find_prog_field uc) fl in let cs,pjl,flm = Loc.try2 ~loc parse_prog_record uc fl in let get_val pj = get_val cs pj (Mls.find_opt pj.pl_ls flm) in cs, List.map get_val pjl let pure_record ~loc uc get_val fl = let fl = List.map (find_pure_field uc) fl in let kn = Theory.get_known (get_theory uc) in let cs,pjl,flm = Loc.try2 ~loc Decl.parse_record kn fl in let get_val pj = get_val cs pj (Mls.find_opt pj flm) in cs, List.map get_val pjl (* patterns *) let create_user_id = Typing.create_user_id let rec dpattern uc { pat_desc = desc; pat_loc = loc } = Mlw_dexpr.dpattern ~loc (match desc with | Ptree.Pwild -> DPwild | Ptree.Pvar x -> DPvar (create_user_id x) | Ptree.Papp (q,pl) -> begin match uc_find_ps uc q with | PL s -> DPpapp (s, List.map (fun p -> dpattern uc p) pl) | LS s -> DPlapp (s, List.map (fun p -> dpattern uc p) pl) | _ -> Loc.errorm ~loc:(qloc q) "Not a constructor: %a" print_qualid q end | Ptree.Prec [] -> raise Decl.EmptyRecord | Ptree.Prec ((q,_)::_ as fl) -> let get_val _ _ = function | Some p -> dpattern uc p | None -> Mlw_dexpr.dpattern DPwild in begin match uc_find_ps uc q with | PL _ -> let cs,fl = prog_record ~loc uc get_val fl in DPpapp (cs,fl) | LS _ -> let cs,fl = pure_record ~loc uc get_val fl in DPlapp (cs,fl) | _ -> Loc.errorm ~loc:(qloc q) "Not a record field: %a" print_qualid q end | Ptree.Ptuple pl -> let pl = List.map (fun p -> dpattern uc p) pl in DPlapp (fs_tuple (List.length pl), pl) | Ptree.Pcast (p, pty) -> DPcast (dpattern uc p, ity_of_pty uc pty) | Ptree.Pas (p, x) -> DPas (dpattern uc p, create_user_id x) | Ptree.Por (p, q) -> DPor (dpattern uc p, dpattern uc q)) (* specifications *) type lenv = { uc : module_uc; th_at : Theory.theory_uc; th_old : Theory.theory_uc; } let create_lenv uc = { uc = uc; th_at = Theory.use_export (get_theory uc) Mlw_wp.th_mark_at; th_old = Theory.use_export (get_theory uc) Mlw_wp.th_mark_old; } let find_global_vs uc p = try match uc_find_ps uc p with | PV pv -> Some pv.pv_vs | _ -> None with _ -> None let find_local_vs uc lvm p = match p with | Qdot _ -> find_global_vs uc p | Qident id -> let ovs = Mstr.find_opt id.id_str lvm in if ovs = None then find_global_vs uc p else ovs let check_at f0 = let tvs0 = t_vars f0 in let rec check () f = match f.t_node with | Term.Tapp (ls, _) when ls_equal ls fs_at || ls_equal ls fs_old -> let tvs = t_vars f in if not (Mvs.set_submap tvs tvs0) then Loc.errorm ?loc:f.t_loc "locally bound variable %a under `at'/`old'" Pretty.print_vs (fst (Mvs.choose (Mvs.set_diff tvs tvs0))); t_fold check () f | _ -> t_fold check () f in check () f0 let type_term uc th lvm t = let gvars p = find_local_vs uc lvm p in let t = Typing.type_term th gvars t in check_at t; count_term_tuples t; t let type_fmla uc th lvm f = let gvars p = find_local_vs uc lvm p in let f = Typing.type_fmla th gvars f in check_at f; count_term_tuples f; f let dpre lenv pl lvm = let dpre f = type_fmla lenv.uc lenv.th_at lvm f in List.map dpre pl let dpost lenv ql lvm ty = let dpost (loc,pfl) = match pfl with | [{ pat_desc = Ptree.Pwild | Ptree.Ptuple [] }, f] -> None, Loc.try3 ~loc type_fmla lenv.uc lenv.th_old lvm f | [{ pat_desc = Ptree.Pvar id }, f] -> let v = create_vsymbol (create_user_id id) ty in let lvm = Mstr.add id.id_str v lvm in Some v, Loc.try3 ~loc type_fmla lenv.uc lenv.th_old lvm f | _ -> let v = create_vsymbol (id_fresh "result") ty in let i = { id_str = "(null)"; id_loc = loc; id_lab = [] } in let t = { term_desc = Tident (Qident i); term_loc = loc } in let f = { term_desc = Tmatch (t, pfl); term_loc = loc } in let lvm = Mstr.add "(null)" v lvm in Some v, Loc.try3 ~loc type_fmla lenv.uc lenv.th_old lvm f in List.map dpost ql let find_xsymbol uc p = match uc_find_ps uc p with XS xs -> xs | _ -> Loc.errorm ~loc:(qloc p) "exception symbol expected" let dxpost lenv ql lvm = let add_exn (q,pat,f) m = let xs = find_xsymbol lenv.uc q in Mexn.change (function | Some l -> Some ((pat,f) :: l) | None -> Some ((pat,f) :: [])) xs m in let mk_xpost loc xs pfl = dpost lenv [loc,pfl] lvm (ty_of_ity xs.xs_ity) in let exn_map (loc,xpfl) = let m = List.fold_right add_exn xpfl Mexn.empty in Mexn.mapi (fun xs pfl -> mk_xpost loc xs pfl) m in let add_map ql m = Mexn.union (fun _ l r -> Some (l @ r)) (exn_map ql) m in List.fold_right add_map ql Mexn.empty let dreads lenv rl lvm = let dreads q = match find_local_vs lenv.uc lvm q with Some vs -> vs | None -> Loc.errorm ~loc:(qloc q) "Not a variable: %a" print_qualid q in List.map dreads rl let dwrites lenv wl lvm = let dwrites t = type_term lenv.uc (get_theory lenv.uc) lvm t in List.map dwrites wl let find_variant_ls uc p = match uc_find_ls uc p with | { ls_args = [u;v]; ls_value = None } as ls when ty_equal u v -> ls | s -> Loc.errorm ~loc:(qloc p) "Not an order relation: %a" Pretty.print_ls s let dvariant lenv varl lvm = let dvar t = type_term lenv.uc lenv.th_at lvm t in let dvar (t,q) = dvar t, Opt.map (find_variant_ls lenv.uc) q in List.map dvar varl let dspec lenv sp lvm ty = { ds_pre = dpre lenv sp.sp_pre lvm; ds_post = dpost lenv sp.sp_post lvm ty; ds_xpost = dxpost lenv sp.sp_xpost lvm; ds_reads = dreads lenv sp.sp_reads lvm; ds_writes = dwrites lenv sp.sp_writes lvm; ds_variant = dvariant lenv sp.sp_variant lvm; ds_checkrw = sp.sp_checkrw; ds_diverge = sp.sp_diverge; } let dassert lenv f lvm = type_fmla lenv.uc lenv.th_at lvm f let dinvariant = dpre let dloopannot lenv ann lvm = dvariant lenv ann.loop_variant lvm, dinvariant lenv ann.loop_invariant lvm (* abstract values *) let dbinder uc id gh pty = let id = Opt.map create_user_id id in let otv = Opt.fold opaque_tvs Stv.empty pty in let dity = match pty with | Some pty -> dity_of_ity (ity_of_pty ~noop:false uc pty) | None -> dity_fresh () in id, gh, otv, dity let dparam uc (_,id,gh,pty) = dbinder uc id gh (Some pty) let dbinder uc (_,id,gh,pty) = dbinder uc id gh pty let rec dtype_c lenv (tyv, sp) = dtype_v lenv tyv, dspec lenv sp and dtype_v lenv = function | PTpure pty -> DSpecV (dity_of_ity (ity_of_pty lenv.uc pty)) | PTfunc (bl,tyc) -> DSpecA (List.map (fun p -> dparam lenv.uc p) bl, dtype_c lenv tyc) (* expressions *) let add_lemma_label ~top id = function | Gnone -> id, false | Gghost -> id, true | Glemma when not top -> Loc.errorm ~loc:id.id_loc "lemma functions are only allowed at toplevel" | Glemma -> { id with id_lab = Lstr Mlw_wp.lemma_label :: id.id_lab }, true let is_reusable de = match de.de_node with | DEvar _ | DEgpvar _ | DEconst _ | DEtrue | DEfalse -> true | DEplapp ({pl_value = {fd_ity = ity; fd_mut = None}},[]) -> ity_immutable ity (* cannot reuse since regions will not be shared *) | DElsapp (_,[]) -> true (* can reuse since dvty is shared and immutable *) | _ -> false let mk_var n de = Mlw_dexpr.dexpr ?loc:de.de_loc (DEvar (n, de.de_dvty)) let mk_let ~loc n de node = let de1 = Mlw_dexpr.dexpr ~loc node in DElet ((id_user n loc, false, de), de1) let chainable_ps = function | { ps_aty = { aty_args = [pv1;pv2]; aty_result = VTvalue ity }} | { ps_aty = { aty_args = [pv1]; aty_result = VTarrow { aty_args = [pv2]; aty_result = VTvalue ity }}} -> ity_equal ity ity_bool && not (ity_equal pv1.pv_ity ity_bool) && not (ity_equal pv2.pv_ity ity_bool) | _ -> false let chainable_qualid uc p = match uc_find_ps uc p with | PS ps -> chainable_ps ps | LS { ls_args = [ty1;ty2]; ls_value = ty } -> Opt.fold (fun _ ty -> ty_equal ty ty_bool) true ty && not (ty_equal ty1 ty_bool) && not (ty_equal ty2 ty_bool) | LS _ | PL _ | PV _ | XS _ -> false let chainable_op uc denv op = (* non-bool -> non-bool -> bool *) op.id_str = "infix =" || op.id_str = "infix <>" || match denv_get_opt denv op.id_str with | Some (DEvar (_,t)) -> dvty_is_chainable t | Some (DEgpsym ps) -> chainable_ps ps | Some _ -> false (* can never happen *) | None -> chainable_qualid uc (Qident op) let mk_closure loc _ls = Loc.errorm ~loc "Partial@ application@ of@ logical@ symbols@ \ is@ currently@ not@ supported@ in@ programs." (* let mk dt = Dterm.dterm ~loc dt in let id = id_user "fc" loc and dty = dty_fresh () in let mk_v i _ = id_user ("y" ^ string_of_int i) loc, dty_fresh () in let mk_t (id, dty) = mk (DTvar (id.pre_name, dty)) in let vl = Lists.mapi mk_v ls.ls_args in let tl = List.map mk_t vl in let app e1 e2 = DTapp (fs_func_app, [mk e1; e2]) in let e = List.fold_left app (DTvar ("fc", dty)) tl in let f = DTapp (ps_equ, [mk e; mk (DTapp (ls, tl))]) in DTeps (id, dty, mk (DTquant (Tforall, vl, [], mk f))) *) let rec dexpr ({uc = uc} as lenv) denv {expr_desc = desc; expr_loc = loc} = let expr_app e el = List.fold_left (fun e1 (loc, e2) -> DEapply (Mlw_dexpr.dexpr ~loc e1, e2)) e el in let rec apply_pl loc pl al l el = match l, el with | (_::l), (e::el) -> apply_pl loc pl (e::al) l el | [], _ -> expr_app (DEplapp (pl, List.rev_map snd al)) el | _, [] -> expr_app (mk_closure loc pl) (List.rev_append al el) in let rec apply_ls loc ls al l el = match l, el with | (_::l), (e::el) -> apply_ls loc ls (e::al) l el | [], _ -> expr_app (DElsapp (ls, List.rev_map snd al)) el | _, [] -> expr_app (mk_closure loc ls) (List.rev_append al el) in let qualid_app q el = match uc_find_ps uc q with | PV pv -> expr_app (DEgpvar pv) el | PS ps -> expr_app (DEgpsym ps) el | PL pl -> apply_pl (qloc q) pl [] pl.pl_args el | LS ls -> apply_ls (qloc q) ls [] ls.ls_args el | XS xs -> Loc.errorm ~loc:(qloc q) "unexpected exception symbol %a" print_xs xs in let qualid_app q el = match q with | Qident {id_str = n} -> (match denv_get_opt denv n with | Some d -> expr_app d el | None -> qualid_app q el) | _ -> qualid_app q el in let rec unfold_app e1 e2 el = match e1.expr_desc with | Ptree.Eapply (e11,e12) -> let e12 = dexpr lenv denv e12 in unfold_app e11 e12 ((e1.expr_loc, e2)::el) | Ptree.Eident q -> qualid_app q ((e1.expr_loc, e2)::el) | _ -> expr_app (DEapply (dexpr lenv denv e1, e2)) el in Mlw_dexpr.dexpr ~loc (match desc with | Ptree.Eident q -> qualid_app q [] | Ptree.Eidapp (q, tl) -> (* FIXME: qloc q is wrong for the 2nd and later arguments *) let loc = qloc q in qualid_app q (List.map (fun t -> loc, dexpr lenv denv t) tl) | Ptree.Eapply (e1, e2) -> unfold_app e1 (dexpr lenv denv e2) [] | Ptree.Etuple el -> let el = List.map (dexpr lenv denv) el in DElsapp (fs_tuple (List.length el), el) | Ptree.Einfix (e12, op2, e3) | Ptree.Einnfix (e12, op2, e3) -> let make_app de1 op de2 = if op.id_str = "infix <>" then let oq = Qident { op with id_str = "infix =" } in (* FIXME: op.id_loc is wrong for the 2nd argument *) let dt = qualid_app oq [(op.id_loc, de1); (op.id_loc, de2)] in DEnot (Mlw_dexpr.dexpr ~loc dt) else qualid_app (Qident op) [(op.id_loc, de1); (op.id_loc, de2)] in let rec make_chain n1 n2 de1 = function | [op,de2] -> make_app de1 op de2 | (op,de2) :: ch -> let re = is_reusable de2 in let v = if re then de2 else mk_var n1 de2 in let de12 = Mlw_dexpr.dexpr ~loc (make_app de1 op v) in let de23 = Mlw_dexpr.dexpr ~loc (make_chain n2 n1 v ch) in let d = DElazy (DEand, de12, de23) in if re then d else mk_let ~loc n1 de2 d | [] -> assert false in let rec get_chain e12 acc = match e12.expr_desc with | Ptree.Einfix (e1, op1, e2) when chainable_op uc denv op1 -> get_chain e1 ((op1, dexpr lenv denv e2) :: acc) | _ -> e12, acc in let ch = [op2, dexpr lenv denv e3] in let e1, ch = if chainable_op uc denv op2 then get_chain e12 ch else e12, ch in make_chain "q1 " "q2 " (dexpr lenv denv e1) ch | Ptree.Econst (Number.ConstInt _ as c) -> DEconst (c, ity_int) | Ptree.Econst (Number.ConstReal _ as c) -> DEconst (c, ity_real) | Ptree.Erecord [] -> raise Decl.EmptyRecord | Ptree.Erecord ((q,_)::_ as fl) -> let prog_val cs pj = function | None -> Loc.error ~loc (Decl.RecordFieldMissing (cs.pl_ls,pj.pl_ls)) | Some e -> dexpr lenv denv e in let pure_val cs pj = function | None -> Loc.error ~loc (Decl.RecordFieldMissing (cs,pj)) | Some e -> dexpr lenv denv e in begin match uc_find_ps uc q with | PL _ -> let cs,fl = prog_record ~loc uc prog_val fl in DEplapp (cs,fl) | LS _ -> let cs,fl = pure_record ~loc uc pure_val fl in DElsapp (cs,fl) | _ -> Loc.errorm ~loc:(qloc q) "Not a record field: %a" print_qualid q end | Ptree.Eupdate (_, []) -> raise Decl.EmptyRecord | Ptree.Eupdate (e1, ((q,_)::_ as fl)) -> let e1 = dexpr lenv denv e1 in let re = is_reusable e1 in let v = if re then e1 else mk_var "_q " e1 in let prog_val _ pj = function | None -> Mlw_dexpr.dexpr ~loc (DEplapp (pj, [v])) | Some e -> dexpr lenv denv e in let pure_val _ pj = function | None -> Mlw_dexpr.dexpr ~loc (DElsapp (pj, [v])) | Some e -> dexpr lenv denv e in let d = match uc_find_ps uc q with | PL _ -> let cs,fl = prog_record ~loc uc prog_val fl in DEplapp (cs,fl) | LS _ -> let cs,fl = pure_record ~loc uc pure_val fl in DElsapp (cs,fl) | _ -> Loc.errorm ~loc:(qloc q) "Not a record field: %a" print_qualid q in if re then d else mk_let ~loc "_q " e1 d | Ptree.Elet (id, gh, e1, e2) -> let id, gh = add_lemma_label ~top:false id gh in let ld = create_user_id id, gh, dexpr lenv denv e1 in DElet (ld, dexpr lenv (denv_add_let denv ld) e2) | Ptree.Efun (id, gh, lam, e2) -> let id, gh = add_lemma_label ~top:false id gh in let bl, de, sp = dlambda lenv denv lam in let fd = create_user_id id, gh, bl, de, sp in DEfun (fd, dexpr lenv (denv_add_fun denv fd) e2) | Ptree.Erec (fdl, e1) -> let denv, rd = drec_defn ~top:false lenv denv fdl in DErec (rd, dexpr lenv denv e1) | Ptree.Elam lam -> let bl, de, sp = dlambda lenv denv lam in DElam (bl, de, sp) | Ptree.Ematch (e1, bl) -> let e1 = dexpr lenv denv e1 in let branch (pp, e) = let pp = dpattern uc pp in let denv = denv_add_pat denv pp in pp, dexpr lenv denv e in DEcase (e1, List.map branch bl) | Ptree.Eif (e1, e2, e3) -> let e1 = dexpr lenv denv e1 in let e2 = dexpr lenv denv e2 in let e3 = dexpr lenv denv e3 in DEif (e1, e2, e3) | Ptree.Enot e1 -> DEnot (dexpr lenv denv e1) | Ptree.Elazy (e1, op, e2) -> let op = match op with | Ptree.LazyAnd -> DEand | Ptree.LazyOr -> DEor in let e1 = dexpr lenv denv e1 in let e2 = dexpr lenv denv e2 in DElazy (op, e1, e2) | Ptree.Etrue -> DEtrue | Ptree.Efalse -> DEfalse | Ptree.Esequence (e1, e2) -> let e1 = dexpr lenv denv e1 in let e2 = dexpr lenv denv e2 in DElet ((id_user "_" loc, false, e1), e2) | Ptree.Eloop (ann, e1) -> let e1 = dexpr lenv denv e1 in DEloop (dloopannot lenv ann, e1) | Ptree.Ewhile (e1, ann, e2) -> let e1 = dexpr lenv denv e1 in let e2 = dexpr lenv denv e2 in DEwhile (e1, dloopannot lenv ann, e2) | Ptree.Efor (id, efrom, dir, eto, inv, e1) -> let dir = match dir with | Ptree.To -> To | Ptree.Downto -> DownTo in let efrom = dexpr lenv denv efrom in let eto = dexpr lenv denv eto in let inv = dinvariant lenv inv in let id = create_user_id id in let denv = denv_add_var denv id (dity_of_ity ity_int) in DEfor (id, efrom, dir, eto, inv, dexpr lenv denv e1) | Ptree.Eassign (e1, q, e2) -> let pl = match uc_find_ps uc q with PL pl -> pl | _ -> Loc.errorm ~loc:(qloc q) "%a is not a field name" print_qualid q in DEassign (pl, dexpr lenv denv e1, dexpr lenv denv e2) | Ptree.Eraise (q, e1) -> let xs = find_xsymbol uc q in let e1 = match e1 with | Some e1 -> dexpr lenv denv e1 | None when ity_equal xs.xs_ity ity_unit -> Mlw_dexpr.dexpr ~loc (DElsapp (Mlw_expr.fs_void, [])) | _ -> Loc.errorm ~loc "exception argument expected" in DEraise (xs, e1) | Ptree.Etry (e1, cl) -> let e1 = dexpr lenv denv e1 in let branch (q, pp, e) = let xs = find_xsymbol uc q in let pp = match pp with | Some pp -> dpattern uc pp | None when ity_equal xs.xs_ity ity_unit -> Mlw_dexpr.dpattern ~loc (DPlapp (Mlw_expr.fs_void, [])) | _ -> Loc.errorm ~loc "exception argument expected" in let denv = denv_add_pat denv pp in let e = dexpr lenv denv e in xs, pp, e in DEtry (e1, List.map branch cl) | Ptree.Eghost e1 -> DEghost (dexpr lenv denv e1) | Ptree.Eany (tyv, sp) -> let dsp = if sp.sp_pre = [] && sp.sp_post = [] && sp.sp_xpost = [] && sp.sp_reads = [] && sp.sp_writes = [] && sp.sp_variant = [] && not sp.sp_checkrw && not sp.sp_diverge then None else Some (dspec lenv sp) in DEany (dtype_v lenv tyv, dsp) | Ptree.Eabstract (e1, sp) -> DEabstract (dexpr lenv denv e1, dspec lenv sp) | Ptree.Eabsurd -> DEabsurd | Ptree.Eassert (ak, lexpr) -> let ak = match ak with | Ptree.Aassert -> Aassert | Ptree.Aassume -> Aassume | Ptree.Acheck -> Acheck in DEassert (ak, dassert lenv lexpr) | Ptree.Emark (id, e1) -> DEmark (create_user_id id, dexpr lenv denv e1) | Ptree.Enamed (Lpos uloc, e1) -> DEuloc (dexpr lenv denv e1, uloc) | Ptree.Enamed (Lstr lab, e1) -> DElabel (dexpr lenv denv e1, Slab.singleton lab) | Ptree.Ecast (e1, pty) -> (* FIXME: accepts and silently ignores double casts: ((0:ty1):ty2) *) let e1 = dexpr lenv denv e1 in let ity = ity_of_pty uc pty in match e1.de_node with | DEconst (c, _) -> DEconst (c, ity) | _ -> DEcast (e1, ity)) and drec_defn ~top lenv denv fdl = let prep (id, gh, (bl, pty, e, sp)) = let id, gh = add_lemma_label ~top id gh in let bl = List.map (dbinder lenv.uc) bl in let dity = match pty with | Some pty -> dity_of_ity (ity_of_pty lenv.uc pty) | None -> dity_fresh () in let pre denv = dexpr lenv denv e, dspec lenv sp in create_user_id id, gh, bl, dity, pre in Mlw_dexpr.drec_defn denv (List.map prep fdl) and dlambda lenv denv (bl, pty, e1, sp) = let bl = List.map (dbinder lenv.uc) bl in let e1 = match pty with | Some pty -> { e1 with expr_desc = Ecast (e1, pty) } | None -> e1 in let e1 = dexpr lenv (denv_add_args denv bl) e1 in bl, e1, dspec lenv sp (** Type declaration *) let add_type_invariant loc uc id params inv = let x = "self" in let its = match uc_find_ts uc (Qident id) with | PT its when its.its_inv -> its | _ -> Loc.errorm ~loc "type %s does not have an invariant" id.id_str in let add_tv acc { id_str = id; id_loc = loc } = let e = Loc.Located (loc, DuplicateTypeVar id) in Sstr.add_new e id acc, tv_of_string id in let _, tvl = Lists.map_fold_left add_tv Sstr.empty params in let ty = ty_app its.its_ts (List.map ty_var tvl) in let res = create_vsymbol (id_fresh x) ty in let find = function | Qident { id_str = id } when id = x -> Some res | _ -> None in let mk_inv f = let f = Typing.type_fmla (get_theory uc) find f in t_label_add Split_goal.stop_split f in let inv = List.map mk_inv inv in let q = Mlw_ty.create_post res (t_and_simp_l inv) in let q = if List.for_all2 tv_equal its.its_ts.ts_args tvl then q else let add mtv u v = Mtv.add u (ty_var v) mtv in let mtv = List.fold_left2 add Mtv.empty tvl its.its_ts.ts_args in t_ty_subst mtv Mvs.empty q in let uc = (count_term_tuples q; flush_tuples uc) in Mlw_module.add_invariant uc its q let look_for_loc tdl s = let look_id loc id = if id.id_str = s then Some id.id_loc else loc in let look_pj loc (_,id,_,_) = Opt.fold look_id loc id in let look_cs loc (csloc,id,pjl) = let loc = if id.id_str = s then Some csloc else loc in List.fold_left look_pj loc pjl in let look_fl loc f = look_id loc f.f_ident in let look loc d = let loc = look_id loc d.td_ident in match d.td_def with | TDabstract | TDalias _ | TDrange _ | TDfloat _ -> loc | TDalgebraic csl -> List.fold_left look_cs loc csl | TDrecord fl -> List.fold_left look_fl loc fl in List.fold_left look None tdl let add_types ~wp uc tdl = let add m d = let id = d.td_ident.id_str in Mstr.add_new (Loc.Located (d.td_loc, ClashSymbol id)) id d m in let def = List.fold_left add Mstr.empty tdl in (* detect cycles *) let rec cyc_visit x d seen = match Mstr.find_opt x seen with | Some true -> seen | Some false -> Loc.errorm ~loc:d.td_loc "Cyclic type definition" | None -> let ts_seen seen = function | Qident { id_str = x } -> begin try cyc_visit x (Mstr.find x def) seen with Not_found -> seen end | _ -> seen in let rec check seen = function | PTtyvar _ -> seen | PTparen ty -> check seen ty | PTarrow (ty1,ty2) -> check (check seen ty1) ty2 | PTtyapp (q,tyl) -> List.fold_left check (ts_seen seen q) tyl | PTtuple tyl -> List.fold_left check seen tyl in let seen = match d.td_def with | TDabstract | TDrange _ | TDfloat _ | TDalgebraic _ | TDrecord _ -> seen | TDalias ty -> check (Mstr.add x false seen) ty in Mstr.add x true seen in ignore (Mstr.fold cyc_visit def Mstr.empty); (* detect impure types *) let impures = Hstr.create 5 in let rec imp_visit x = try Hstr.find impures x with Not_found -> let ts_imp = function | Qident { id_str = x } when Mstr.mem x def -> imp_visit x | q -> begin match uc_find_ts uc q with | PT _ -> true | TS _ -> false end in let rec check = function | PTtyvar _ -> false | PTparen ty -> check ty | PTarrow (ty1,ty2) -> check ty1 || check ty2 | PTtyapp (q,tyl) -> ts_imp q || List.exists check tyl | PTtuple tyl -> List.exists check tyl in Hstr.replace impures x false; let imp = let td = Mstr.find x def in match td.td_def with | TDabstract | TDrange _ | TDfloat _ -> false | TDalias ty -> check ty | TDalgebraic csl -> let check (_,_,gh,ty) = gh || check ty in let cons (_,_,l) = List.exists check l in td.td_inv <> [] || td.td_vis <> Public || List.exists cons csl | TDrecord fl -> let field f = f.f_ghost || f.f_mutable || check f.f_pty in td.td_inv <> [] || td.td_vis <> Public || List.exists field fl in Hstr.replace impures x imp; imp in Mstr.iter (fun x _ -> ignore (imp_visit x)) def; (* detect mutable types and invariants *) let mutables = Hstr.create 5 in let rec mut_visit x = try Hstr.find mutables x with Not_found -> let ts_mut = function | Qident { id_str = x } when Mstr.mem x def -> mut_visit x | q -> begin match uc_find_ts uc q with | PT its -> its.its_regs <> [] || its.its_inv | TS _ -> false end in let rec check = function | PTtyvar _ -> false | PTparen ty -> check ty | PTarrow (ty1,ty2) -> check ty1 || check ty2 | PTtyapp (q,tyl) -> ts_mut q || List.exists check tyl | PTtuple tyl -> List.exists check tyl in Hstr.replace mutables x false; let mut = let td = Mstr.find x def in match td.td_def with | TDabstract | TDrange _ | TDfloat _ -> false | TDalias ty -> check ty | TDalgebraic csl -> let check (_,_,_,ty) = check ty in let cons (_,_,l) = List.exists check l in td.td_inv <> [] || List.exists cons csl | TDrecord fl -> let field f = f.f_mutable || check f.f_pty in td.td_inv <> [] || List.exists field fl in Hstr.replace mutables x mut; mut in Mstr.iter (fun x _ -> ignore (mut_visit x)) def; (* create type symbols and predefinitions for mutable types *) let mk_field ity gh mut = { fd_ity = ity; fd_ghost = gh; fd_mut = mut } in let tysymbols = Hstr.create 5 in let predefs = Hstr.create 5 in let rec its_visit x = try match Hstr.find tysymbols x with | Some ts -> ts | None -> let td = Mstr.find x def in let loc = td.td_loc in if td.td_inv <> [] then Loc.errorm ~loc "Recursive types cannot have invariants" else Loc.errorm ~loc "Recursive types cannot have mutable components" with Not_found -> let d = Mstr.find x def in let add_tv acc id = let e = Loc.Located (id.Ptree.id_loc, DuplicateTypeVar id.id_str) in let tv = tv_of_string id.id_str in Mstr.add_new e id.id_str tv acc in let vars = List.fold_left add_tv Mstr.empty d.td_params in let vl = List.map (fun id -> Mstr.find id.id_str vars) d.td_params in let id = Typing.create_user_id d.td_ident in let abst = d.td_vis = Abstract in let priv = d.td_vis = Private in Hstr.add tysymbols x None; let get_ts = function | Qident { id_str = x } when Mstr.mem x def -> its_visit x | q -> uc_find_ts uc q in let rec parse = function | PTtyvar ({ id_loc = loc }, true) -> Loc.errorm ~loc "Opaqueness@ annotations@ are@ only@ \ allowed@ in@ function@ and@ predicate@ prototypes" | PTtyvar ({ id_str = v ; id_loc = loc }, _) -> let e = Loc.Located (loc, UnboundTypeVar v) in ity_var (Mstr.find_exn e v vars) | PTtyapp (q,tyl) -> let tyl = List.map parse tyl in begin match get_ts q with | TS ts -> Loc.try2 ~loc:(qloc q) ity_pur ts tyl | PT ts -> Loc.try2 ~loc:(qloc q) ity_app_fresh ts tyl end | PTtuple tyl -> let ts = ts_tuple (List.length tyl) in ity_pur ts (List.map parse tyl) | PTarrow (ty1,ty2) -> ity_pur ts_func [parse ty1; parse ty2] | PTparen ty -> parse ty in let ts = match d.td_def with | TDalias _ when abst || priv -> Loc.errorm ~loc:d.td_loc "type aliases cannot be abstract or private" | TDalias _ when d.td_inv <> [] -> Loc.errorm ~loc:d.td_loc "type aliases cannot have invariants" | TDalias ty when Hstr.find impures x -> let def = parse ty in let nogh = ity_nonghost_reg Sreg.empty def in let ghost_reg = Sreg.diff def.ity_vars.vars_reg nogh in let rl = Sreg.elements def.ity_vars.vars_reg in PT (create_itysymbol id ~abst ~priv ~inv:false ~ghost_reg vl rl (Some def)) | TDalias ty -> let def = ty_of_ity (parse ty) in TS (create_tysymbol id vl (Alias def)) | TDalgebraic csl when Hstr.find mutables x -> let projs = Hstr.create 5 in let nogh = ref Sreg.empty in (* to check projections' types we must fix the tyvars *) let add s v = let t = ity_var v in ity_match s t t in let sbs = List.fold_left add ity_subst_empty vl in let mk_proj (regs,inv) (_loc,id,gh,pty) = let ity = parse pty in let fd = mk_field ity gh None in let inv = inv || ity_has_inv ity in match id with | None -> if not gh then nogh := ity_nonghost_reg !nogh ity; let regs = Sreg.union regs ity.ity_vars.vars_reg in (regs, inv), (None, fd) | Some ({ id_str = x; id_loc = loc } as id) -> try let fd = Hstr.find projs x in if gh <> fd.fd_ghost then Loc.errorm ~loc "this field must be ghost in every constructor"; ignore (Loc.try3 ~loc ity_match sbs fd.fd_ity ity); (regs, inv), (Some (Typing.create_user_id id), fd) with Not_found -> Hstr.replace projs x fd; if not gh then nogh := ity_nonghost_reg !nogh ity; let regs = Sreg.union regs ity.ity_vars.vars_reg in (regs, inv), (Some (Typing.create_user_id id), fd) in let mk_constr s (_loc,cid,pjl) = let s,pjl = Lists.map_fold_left mk_proj s pjl in s, (Typing.create_user_id cid, pjl) in let init = (Sreg.empty, d.td_inv <> []) in let (regs,inv),def = Lists.map_fold_left mk_constr init csl in let ghost_reg = Sreg.diff regs !nogh in let rl = Sreg.elements regs in Hstr.replace predefs x def; PT (create_itysymbol id ~abst ~priv ~inv ~ghost_reg vl rl None) | TDrecord fl when Hstr.find mutables x -> let nogh = ref Sreg.empty in let mk_field (regs,inv) f = let ity = parse f.f_pty in let inv = inv || ity_has_inv ity in let fid = Typing.create_user_id f.f_ident in let regs,mut = if f.f_mutable then let r = create_region fid ity in Sreg.add r regs, Some r else Sreg.union regs ity.ity_vars.vars_reg, None in if not f.f_ghost then nogh := Opt.fold_right Sreg.add mut (ity_nonghost_reg !nogh ity); (regs, inv), (Some fid, mk_field ity f.f_ghost mut) in let init = (Sreg.empty, d.td_inv <> []) in let (regs,inv),pjl = Lists.map_fold_left mk_field init fl in let ghost_reg = Sreg.diff regs !nogh in let rl = Sreg.elements regs in let cid = { d.td_ident with id_str = "mk " ^ d.td_ident.id_str } in Hstr.replace predefs x [Typing.create_user_id cid, pjl]; PT (create_itysymbol id ~abst ~priv ~inv ~ghost_reg vl rl None) | TDalgebraic _ | TDrecord _ when Hstr.find impures x -> PT (create_itysymbol id ~abst ~priv ~inv:false vl [] None) | TDalgebraic _ | TDrecord _ | TDabstract -> TS (create_tysymbol id vl NoDef) | TDrange (lo,hi) -> let ir = { Number.ir_lower = lo; Number.ir_upper = hi } in TS (Loc.try2 ~loc:d.td_loc create_tysymbol id vl (Range ir)) | TDfloat (eb,sb) -> let fp = { Number.fp_exponent_digits = eb; Number.fp_significand_digits = sb } in TS (Loc.try2 ~loc:d.td_loc create_tysymbol id vl (Float fp)) in Hstr.add tysymbols x (Some ts); ts in Mstr.iter (fun x _ -> ignore (its_visit x)) def; (* create predefinitions for immutable types *) let def_visit d (abstr,algeb,alias) = let x = d.td_ident.id_str in let ts = Opt.get (Hstr.find tysymbols x) in let vl = match ts with | PT s -> s.its_ts.ts_args | TS s -> s.ts_args in let add_tv s x v = Mstr.add x.id_str v s in let vars = List.fold_left2 add_tv Mstr.empty d.td_params vl in let get_ts = function | Qident { id_str = x } when Mstr.mem x def -> Opt.get (Hstr.find tysymbols x) | q -> uc_find_ts uc q in let rec parse = function | PTtyvar ({ id_loc = loc }, true) -> Loc.errorm ~loc "Opaqueness@ annotations@ are@ only@ \ allowed@ in@ function@ and@ predicate@ prototypes" | PTtyvar ({ id_str = v ; id_loc = loc }, _) -> let e = Loc.Located (loc, UnboundTypeVar v) in ity_var (Mstr.find_exn e v vars) | PTtyapp (q,tyl) -> let tyl = List.map parse tyl in begin match get_ts q with | TS ts -> Loc.try2 ~loc:(qloc q) ity_pur ts tyl | PT ts -> Loc.try3 ~loc:(qloc q) ity_app ts tyl [] end | PTtuple tyl -> let ts = ts_tuple (List.length tyl) in ity_pur ts (List.map parse tyl) | PTarrow (ty1,ty2) -> ity_pur ts_func [parse ty1; parse ty2] | PTparen ty -> parse ty in match d.td_def with | TDabstract | TDrange _ | TDfloat _ -> ts :: abstr, algeb, alias | TDalias _ -> abstr, algeb, ts :: alias | (TDalgebraic _ | TDrecord _) when Hstr.find mutables x -> abstr, (ts, Hstr.find predefs x) :: algeb, alias | TDalgebraic csl -> let projs = Hstr.create 5 in let mk_proj (_loc,id,gh,pty) = let ity = parse pty in let fd = mk_field ity gh None in match id with | None -> None, fd | Some ({ id_str = x; id_loc = loc } as id) -> try let fd = Hstr.find projs x in if gh <> fd.fd_ghost then Loc.errorm ~loc "this field must be ghost in every constructor"; Loc.try2 ~loc ity_equal_check fd.fd_ity ity; Some (Typing.create_user_id id), fd with Not_found -> Hstr.replace projs x fd; Some (Typing.create_user_id id), fd in let mk_constr (_loc,cid,pjl) = Typing.create_user_id cid, List.map mk_proj pjl in abstr, (ts, List.map mk_constr csl) :: algeb, alias | TDrecord fl -> let mk_field f = let fid = Typing.create_user_id f.f_ident in Some fid, mk_field (parse f.f_pty) f.f_ghost None in let cid = { d.td_ident with id_str = "mk " ^ d.td_ident.id_str } in let csl = [Typing.create_user_id cid, List.map mk_field fl] in abstr, (ts, csl) :: algeb, alias in let abstr,algeb,alias = List.fold_right def_visit tdl ([],[],[]) in (* create pure type declarations *) let mk_pure_decl ts csl = let pjt = Hstr.create 3 in let constr = List.length csl in let opaque = Stv.of_list ts.ts_args in let ty = ty_app ts (List.map ty_var ts.ts_args) in let mk_proj (pj,fd) = let fty = ty_of_ity fd.fd_ity in fty, match pj with | None -> None | Some id -> try Hstr.find pjt id.pre_name with Not_found -> let pj = Some (create_fsymbol ~opaque id [ty] fty) in Hstr.replace pjt id.pre_name pj; pj in let mk_constr (id,pjl) = let pjl = List.map mk_proj pjl in let cs = create_fsymbol ~opaque ~constr id (List.map fst pjl) ty in cs, List.map snd pjl in List.map mk_constr csl in let mk_data_decl (s,csl) (alg_pur,alg_imp) = match s with | PT its -> alg_pur, (its, csl) :: alg_imp | TS ts -> (ts, mk_pure_decl ts csl) :: alg_pur, alg_imp in let alg_pur,alg_imp = List.fold_right mk_data_decl algeb ([],[]) in (* add type declarations *) let add_pure_type_decl uc ts = let uc = add_decl_with_tuples uc (Decl.create_ty_decl ts) in match ts.ts_def with | NoDef | Alias _ -> uc | Range _ -> (* FIXME: "t'to_int" is probably better *) let nm = ts.ts_name.id_string ^ "'int" in let id = id_derive nm ts.ts_name in let pj = create_fsymbol id [ty_app ts []] ty_int in let uc = add_decl uc (Decl.create_param_decl pj) in add_meta uc meta_range [MAts ts; MAls pj] | Float _ -> (* FIXME: "t'to_real" is probably better *) let nm = ts.ts_name.id_string ^ "'real" in let id = id_derive nm ts.ts_name in let pj = create_fsymbol id [ty_app ts []] ty_real in let uc = add_decl uc (Decl.create_param_decl pj) in (* FIXME: "t'is_finite" is probably better *) let nm = ts.ts_name.id_string ^ "'isFinite" in let id = id_derive nm ts.ts_name in let iF = Term.create_psymbol id [ty_app ts []] in let uc = add_decl uc (Decl.create_param_decl iF) in add_meta uc meta_float [MAts ts; MAls pj; MAls iF] in let add_type_decl uc = function | PT ts -> add_pdecl_with_tuples ~wp uc (create_ty_decl ts) | TS ts -> add_pure_type_decl uc ts in let add_invariant uc d = if d.td_inv = [] then uc else add_type_invariant d.td_loc uc d.td_ident d.td_params d.td_inv in try let uc = List.fold_left add_type_decl uc abstr in let uc = if alg_imp = [] then uc else add_pdecl_with_tuples ~wp uc (create_data_decl alg_imp) in let uc = if alg_pur = [] then uc else add_decl_with_tuples uc (Decl.create_data_decl alg_pur) in let uc = List.fold_left add_type_decl uc alias in let uc = List.fold_left add_invariant uc tdl in uc with | ClashSymbol s -> Loc.error ?loc:(look_for_loc tdl s) (ClashSymbol s) | RecordFieldMissing ({ ls_name = { id_string = s }} as cs,ls) -> Loc.error ?loc:(look_for_loc tdl s) (RecordFieldMissing (cs,ls)) | DuplicateRecordField ({ ls_name = { id_string = s }} as cs,ls) -> Loc.error ?loc:(look_for_loc tdl s) (DuplicateRecordField (cs,ls)) | DuplicateVar { vs_name = { id_string = s }} -> Loc.errorm ?loc:(look_for_loc tdl s) "Field %s is used twice in the same constructor" s let add_types ~wp uc tdl = match tdl with (* a single abstract type with an invariant is a late invariant declaration which adds an invariant to a recently declared program type (which must already have an invariant, e.g. true). Otherwise, we trust the parser to not produce abstract or alias type declarations with invariants. *) | [{ td_def = TDabstract; td_inv = _::_ as inv} as d] -> add_type_invariant d.td_loc uc d.td_ident d.td_params inv | _ -> add_types ~wp uc tdl (** Use/Clone of theories and modules *) let find_theory loc env mt path s = match path with | _::_ -> (* theory in file path *) Loc.try3 ~loc Env.read_theory env path s | [] -> (* local theory *) try Mstr.find s mt with Not_found -> Loc.try3 ~loc Env.read_theory env path s let find_module loc env mm mt path s = match path with | _::_ -> (* module/theory in file path *) Loc.try3 ~loc read_module_or_theory env path s | [] -> (* local module/theory *) try Module (Mstr.find s mm) with Not_found -> try Theory (Mstr.find s mt) with Not_found -> Loc.try3 ~loc read_module_or_theory env path s (** Top level *) let add_decl loc uc decl = let th0 = Mlw_module.get_theory uc in let dl0 = Theory.get_rev_decls th0 in let seen td = match dl0 with | td0 :: _ -> td_equal td td0 | [] -> false in (* we extract the added declarations and readd it to uc *) let rec add_td uc = function | [] -> uc | td :: _ when seen td -> uc | { td_node = Theory.Decl d } :: dl -> Mlw_module.add_decl (add_td uc dl) d | { td_node = Theory.Meta (m,al) } :: dl -> Mlw_module.add_meta (add_td uc dl) m al | { td_node = Theory.Use th } :: dl -> Mlw_module.use_export_theory (add_td uc dl) th | { td_node = Theory.Clone _ } :: _ -> assert false in add_td uc (Theory.get_rev_decls (Typing.add_decl loc th0 decl)) let add_decl ~wp loc uc = function | Ptree.Dtype tdl -> add_types ~wp uc tdl | decl -> add_decl loc uc decl let add_decl ~wp loc uc d = if Debug.test_flag Typing.debug_parse_only then uc else Loc.try3 ~loc (add_decl ~wp) loc uc d let add_pdecl ~wp _loc uc = function | Dlet (id, gh, e) -> let id, gh = add_lemma_label ~top:true id gh in let de = dexpr (create_lenv uc) denv_empty e in let ld = create_user_id id, gh, de in let uc = flush_tuples uc in let kn = get_known uc in let lkn = Theory.get_known (get_theory uc) in let ld = Mlw_dexpr.let_defn ~keep_loc:true lkn kn ld in add_pdecl_with_tuples ~wp uc (create_let_decl ld) | Dfun (id, gh, lam) -> let id, gh = add_lemma_label ~top:true id gh in let bl, de, sp = dlambda (create_lenv uc) denv_empty lam in let fd = create_user_id id, gh, bl, de, sp in let uc = flush_tuples uc in let kn = get_known uc in let lkn = Theory.get_known (get_theory uc) in let fd = Mlw_dexpr.fun_defn ~keep_loc:true lkn kn fd in add_pdecl_with_tuples ~wp uc (create_rec_decl [fd]) | Drec fdl -> let _, rd = drec_defn ~top:true (create_lenv uc) denv_empty fdl in let uc = flush_tuples uc in let kn = get_known uc in let lkn = Theory.get_known (get_theory uc) in let fdl = Mlw_dexpr.rec_defn ~keep_loc:true lkn kn rd in add_pdecl_with_tuples ~wp uc (create_rec_decl fdl) | Dval (id, gh, tyv) -> let id, gh = add_lemma_label ~top:true id gh in let tyv = dtype_v (create_lenv uc) tyv in let vd = create_user_id id, gh, tyv in let uc = flush_tuples uc in let kn = get_known uc in let lkn = Theory.get_known (get_theory uc) in let lv = Mlw_dexpr.val_decl ~keep_loc:true lkn kn vd in add_pdecl_with_tuples ~wp uc (create_val_decl lv) | Dexn (id, pty) -> let ity = ity_of_pty uc pty in let xs = create_xsymbol (create_user_id id) ity in add_pdecl_with_tuples ~wp uc (create_exn_decl xs) let add_pdecl ~wp loc uc d = if Debug.test_flag Typing.debug_parse_only then uc else Loc.try3 ~loc (add_pdecl ~wp) loc uc d let use_clone_pure env mth uc loc (use,inst) = let path, s = match use.use_theory with | Qdot (p,id) -> Typing.string_list_of_qualid p, id | Qident id -> [], id in let th = find_theory loc env mth path s.id_str in if Debug.test_flag Glob.flag then Glob.use s.id_loc th.th_name; (* open namespace, if any *) let uc = match use.use_import with | Some (_, use_as) -> Theory.open_namespace uc use_as | None -> uc in (* use or clone *) let uc = match inst with | None -> Theory.use_export uc th | Some inst -> Theory.warn_clone_not_abstract loc th; Theory.clone_export uc th (Typing.type_inst uc th inst) in (* close namespace, if any *) match use.use_import with | Some (import, _) -> Theory.close_namespace uc import | None -> uc let use_clone_pure env mth uc loc use = if Debug.test_flag Typing.debug_parse_only then uc else Loc.try5 ~loc use_clone_pure env mth uc loc use let use_clone env mmd mth uc loc (use,inst) = let path, s = match use.use_theory with | Qdot (p,id) -> Typing.string_list_of_qualid p, id | Qident id -> [], id in let mth = find_module loc env mmd mth path s.id_str in if Debug.test_flag Glob.flag then Glob.use s.id_loc (match mth with Module m -> m.mod_theory.th_name | Theory th -> th.th_name); (* open namespace, if any *) let uc = match use.use_import with | Some (_, use_as) -> open_namespace uc use_as | None -> uc in (* use or clone *) let uc = match mth, inst with | Module m, None -> use_export uc m | Theory th, None -> use_export_theory uc th | Module m, Some inst -> Theory.warn_clone_not_abstract loc m.mod_theory; let pure_inst, prog_inst = List.partition (function | CSvsym _ -> false | _ -> true) inst in let pure_sm = Typing.type_inst (get_theory uc) m.mod_theory pure_inst in let prog_sm = { inst_pv = Mpv.empty; inst_ps = Mps.empty } in let prog_sm = List.fold_left (fun s i -> match i with | CSvsym (loc,p,q) -> begin match ns_find_ps m.mod_export p, uc_find_ps uc q with | PV pv1, PV pv2 -> if Mpv.mem pv1 s.inst_pv then Loc.error ~loc (Theory.ClashSymbol pv1.pv_vs.vs_name.id_string); { s with inst_pv = Mpv.add pv1 pv2 s.inst_pv } | PS ps1, PS ps2 -> if Mps.mem ps1 s.inst_ps then Loc.error ~loc (Theory.ClashSymbol ps1.ps_name.id_string); { s with inst_ps = Mps.add ps1 ps2 s.inst_ps } | PV _, PS _ | PS _, PV _ -> Loc.errorm ~loc "type mismatch" | PV _, _ | PS _, _ -> Loc.errorm ~loc "not a program symbol: %a" print_qualid q | _ -> Loc.errorm ~loc "not a program symbol: %a" print_qualid p end | _ -> assert false) prog_sm prog_inst in clone_export uc m prog_sm pure_sm | Theory th, Some inst -> Theory.warn_clone_not_abstract loc th; clone_export_theory uc th (Typing.type_inst (get_theory uc) th inst) in (* close namespace, if any *) match use.use_import with | Some (import, _) -> close_namespace uc import | None -> uc let use_clone env mmd mth uc loc use = if Debug.test_flag Typing.debug_parse_only then uc else Loc.try6 ~loc use_clone env mmd mth uc loc use let close_theory (mmd,mth) uc = if Debug.test_flag Typing.debug_parse_only then (mmd,mth) else let th = Theory.close_theory uc in let id = th.th_name.id_string in let loc = th.th_name.Ident.id_loc in if Mstr.mem id mmd then Loc.errorm ?loc "clash with previous module %s" id; if Mstr.mem id mth then Loc.errorm ?loc "clash with previous theory %s" id; mmd, Mstr.add id th mth let close_module (mmd,mth) uc = if Debug.test_flag Typing.debug_parse_only then (mmd,mth) else let m = close_module uc in if Debug.test_flag Glob.flag then Glob.def m.mod_theory.th_name; let id = m.mod_theory.th_name.id_string in let loc = m.mod_theory.th_name.Ident.id_loc in if Mstr.mem id mmd then Loc.errorm ?loc "clash with previous module %s" id; if Mstr.mem id mth then Loc.errorm ?loc "clash with previous theory %s" id; Mstr.add id m mmd, Mstr.add id m.mod_theory mth let open_file, close_file = let inm = Stack.create () in let tuc = Stack.create () in let muc = Stack.create () in let lenv = Stack.create () in let open_file env path = let wp = path = [] && Debug.test_noflag Typing.debug_type_only in Stack.push (Mstr.empty,Mstr.empty) lenv; let open_theory id = Stack.push false inm; Stack.push (Theory.create_theory ~path (Typing.create_user_id id)) tuc in let open_module id = Stack.push true inm; Stack.push (create_module env ~path (Typing.create_user_id id)) muc in let close_theory () = ignore (Stack.pop inm); Stack.push (close_theory (Stack.pop lenv) (Stack.pop tuc)) lenv in let close_module () = ignore (Stack.pop inm); Stack.push (close_module (Stack.pop lenv) (Stack.pop muc)) lenv in let open_namespace name = if Stack.top inm then Stack.push (Mlw_module.open_namespace (Stack.pop muc) name) muc else Stack.push (Theory.open_namespace (Stack.pop tuc) name) tuc in let close_namespace imp = if Stack.top inm then Stack.push (Mlw_module.close_namespace (Stack.pop muc) imp) muc else Stack.push (Theory.close_namespace (Stack.pop tuc) imp) tuc in let new_decl loc d = if Stack.top inm then Stack.push (add_decl ~wp loc (Stack.pop muc) d) muc else Stack.push (Typing.add_decl loc (Stack.pop tuc) d) tuc in let new_pdecl loc d = Stack.push (add_pdecl ~wp loc (Stack.pop muc) d) muc in let use_clone loc use = let (mmd,mth) = Stack.top lenv in if Stack.top inm then Stack.push (use_clone env mmd mth (Stack.pop muc) loc use) muc else Stack.push (use_clone_pure env mth (Stack.pop tuc) loc use) tuc in { open_theory = open_theory; close_theory = close_theory; open_module = open_module; close_module = close_module; open_namespace = open_namespace; close_namespace = (fun loc imp -> Loc.try1 ~loc close_namespace imp); new_decl = new_decl; new_pdecl = new_pdecl; use_clone = use_clone; } in let close_file () = Stack.pop lenv in open_file, close_file (** Exception printing *) let () = Exn_printer.register (fun fmt e -> match e with | DuplicateTypeVar s -> Format.fprintf fmt "Type parameter %s is used twice" s | UnboundTypeVar s -> Format.fprintf fmt "Unbound type variable '%s" s | _ -> raise e) why3-0.88.3/src/session/0000775000175100017510000000000013225666037015526 5ustar guillaumeguillaumewhy3-0.88.3/src/session/compress_z.ml0000664000175100017510000000342613225666037020251 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) #13 "src/session/compress_z.ml" let compression_supported = true module type S = sig type out_channel val open_out: string -> out_channel val output_char: out_channel -> char -> unit val output_substring: out_channel -> string -> int -> int -> unit val output_string: out_channel -> string -> unit val close_out: out_channel -> unit type in_channel val open_in: string -> in_channel val input: in_channel -> bytes -> int -> int -> int val really_input: in_channel -> bytes -> int -> int -> unit val input_char: in_channel -> char val close_in: in_channel -> unit end module Compress_none = Pervasives module Compress_z = struct type out_channel = Gzip.out_channel let open_out fn = Gzip.open_out ~level:6 fn let output_char = Gzip.output_char let output_substring = Gzip.output_substring let output_string ch s = output_substring ch s 0 (String.length s) let close_out = Gzip.close_out type in_channel = Gzip.in_channel let open_in = Gzip.open_in let input = Gzip.input let really_input = Gzip.really_input let input_char = Gzip.input_char let close_in = Gzip.close_in end why3-0.88.3/src/session/strategy_parser.mli0000664000175100017510000000144413225666037021452 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) exception SyntaxError of string val parse : 'a Session.env_session -> string -> Strategy.t why3-0.88.3/src/session/session.mli0000664000175100017510000004324313225666037017722 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** Proof sessions Define all the functions needed for managing a session: creation, saving, loading, modification, and so on. All the operations are immediately performed. Use session_scheduler if you want to queue operations. *) open Stdlib val debug : Debug.flag (** The debug flag "session" *) module PHstr : Exthtbl.Private with type key = string module PHprover : Exthtbl.Private with type key = Whyconf.prover (** {2 Proof attempts} *) (** State of a proof *) type proof_attempt_status = | Unedited (** editor not yet run for interactive proof *) | JustEdited (** edited but not run yet *) | Interrupted (** external proof has never completed *) | Scheduled (** external proof attempt is scheduled *) | Running (** external proof attempt is in progress *) | Done of Call_provers.prover_result (** external proof done *) | InternalFailure of exn (** external proof aborted by internal error *) type task_option (** The task can be removed and later reconstructible *) type 'a hide (** For internal use *) type ident_path = { ip_library : string list; ip_theory : string; ip_qualid : string list; } type meta_args = Theory.meta_arg list module Mmeta_args : Extmap.S with type key = meta_args module Smeta_args : Extset.S with module M = Mmeta_args type metas_args = Smeta_args.t Mstr.t module Mmetas_args : Extmap.S with type key = metas_args type idpos = { idpos_ts : ident_path Ty.Mts.t; idpos_ls : ident_path Term.Mls.t; idpos_pr : ident_path Decl.Mpr.t; } (** {2 Session} *) (** All the element of a session contain a key which can hold whatever information the user want. It is generated by the keygen argument of the functions of this module *) type 'a goal (* = private { mutable goal_key : 'a; goal_name : Ident.ident; (** ident of the task *) mutable goal_expl : string option; goal_parent : 'a goal_parent; mutable goal_checksum : Termcode.checksum option; (** checksum of the task *) mutable goal_shape : Termcode.shape; (** shape of the task *) mutable goal_verified : float option; mutable goal_task: task_option; mutable goal_expanded : bool; goal_external_proofs : 'a proof_attempt PHprover.t; goal_transformations : 'a transf PHstr.t; mutable goal_metas : 'a metas Mmetas_args.t; } *) and 'a proof_attempt = private { proof_key : 'a; mutable proof_prover : Whyconf.prover; proof_parent : 'a goal; mutable proof_state : proof_attempt_status; mutable proof_limit : Call_provers.resource_limit; mutable proof_obsolete : bool; mutable proof_archived : bool; mutable proof_edited_as : string option; } and 'a goal_parent = private | Parent_theory of 'a theory | Parent_transf of 'a transf | Parent_metas of 'a metas and 'a metas = { mutable metas_key : 'a; metas_added : metas_args; metas_idpos : idpos; metas_parent : 'a goal; mutable metas_verified : float option; mutable metas_goal : 'a goal; (** Not mutated after the creation *) mutable metas_expanded : bool; } and 'a transf = private { mutable transf_key : 'a; transf_name : string; (** Why3 transformation name *) transf_parent : 'a goal; mutable transf_verified : float option; mutable transf_goals : 'a goal list; (** Not mutated after the creation *) mutable transf_expanded : bool; mutable transf_detached : 'a detached option; } and 'a detached = private { detached_goals: 'a goal list; } and 'a theory = private { mutable theory_key : 'a; theory_name : Ident.ident; theory_parent : 'a file; mutable theory_checksum : Termcode.checksum option; mutable theory_goals : 'a goal list; (** Not mutated after the creation *) mutable theory_verified : float option; mutable theory_expanded : bool; mutable theory_task : Theory.theory hide; mutable theory_detached : 'a detached option; } and 'a file = private { mutable file_key : 'a; file_name : string; file_format : string option; file_parent : 'a session; mutable file_theories: 'a theory list; (** Not mutated after the creation *) mutable file_verified : float option; mutable file_expanded : bool; mutable file_for_recovery : Theory.theory Mstr.t hide; } and 'a session = private { session_files : 'a file PHstr.t; mutable session_shape_version : int; session_prover_ids : int PHprover.t; session_dir : string; } val goal_key : 'a goal -> 'a val goal_name : 'a goal -> Ident.ident val goal_verified : 'a goal -> float option val goal_external_proofs : 'a goal -> 'a proof_attempt PHprover.t val goal_transformations : 'a goal -> 'a transf PHstr.t val goal_metas : 'a goal -> 'a metas Mmetas_args.t val goal_expanded : 'a goal -> bool val print_session : Format.formatter -> 'a session -> unit (** Print a session with a pstree format (cf Tree module) *) val print_attempt_status : Format.formatter -> proof_attempt_status -> unit val print_external_proof : Format.formatter -> 'key proof_attempt -> unit val create_session : ?shape_version:int -> string -> 'key session (** create a new session in the given directory. The directory is created if it doesn't exists yet. Don't change the current directory of the program if you give a relative path *) val get_project_dir : string -> string (** find the session which corresponds to the given file or return directly the given directory; return [Not_found] if the file or the directory doesn't exists *) (** {2 Read/Write} *) type 'key keygen = ?parent:'key -> unit -> 'key (** type of functions which can generate keys *) exception ShapesFileError of string exception SessionFileError of string val read_session: string -> unit session * bool (** Read a session stored on the disk. It returns a session without any task attached to goals. The returned boolean is set when there was shapes read from disk. raises [SessionFileError msg] if the database file cannot be read correctly. raises [ShapesFileError msg] if the database extra file for shapes cannot be read. *) val save_session : Whyconf.config -> 'key session -> unit (** Save a session on disk *) (** {2 Context of a session} *) (** A session which contains task and proof_attempt depends on an environment and a prover configuration. Loaded provers are cached in order to load drivers once *) type loaded_prover = { prover_config : Whyconf.config_prover; prover_driver : Driver.driver} type loaded_provers = loaded_prover option PHprover.t type 'a env_session = private { env : Env.env; mutable whyconf : Whyconf.config; loaded_provers : loaded_provers; mutable files : Theory.theory Stdlib.Mstr.t Stdlib.Mstr.t; session : 'a session} val update_env_session_config : 'a env_session -> Whyconf.config -> unit (** updates the configuration *) val load_prover : 'a env_session -> Whyconf.prover -> loaded_prover option (** load a prover *) val unload_provers : 'a env_session -> unit (** forces unloading of all provers, to force reading again the configuration *) (** {2 Update session} *) exception OutdatedSession type 'key update_context = { allow_obsolete_goals : bool; release_tasks : bool; use_shapes_for_pairing_sub_goals : bool; keygen : 'key keygen; keep_unmatched_theories : bool; } val mk_update_context: ?allow_obsolete_goals : bool -> ?release_tasks : bool -> ?use_shapes_for_pairing_sub_goals : bool -> ?keep_unmatched_theories : bool -> 'key keygen -> 'key update_context (** By default all optional arguments are false. The meaning of the arguments is described in {!Session.update_session} *) val update_session : ctxt:'key update_context -> 'oldkey session -> Env.env -> Whyconf.config -> 'key env_session * bool * bool (** reload the given session with the given environnement : - the files are reloaded - apply again the transformation - if some goals appear try to find to which goal in the given session it corresponds. The last case meant that the session was obsolete. It is authorized if [allow_obsolete] is [true], otherwise the exception {!OutdatedSession} is raised. If the session was obsolete is indicated by the second result. If the merge generated new unpaired goals is indicated by the third result. Theories in the session that don't correspond to new theories are dropped, unless keep_unmatched_theories is set to true. In this case, the theories will be kept, but the goals will not contain tasks. raises [OutdatedSession] if the session is obsolete and [allow_obsolete] is false *) (** {2 Copy/Paste } *) val copy_proof: 'a proof_attempt -> 'a proof_attempt val copy_transf: 'a transf -> 'a transf val copy_metas: 'a metas -> 'a metas (** keys are copied *) val add_proof_to_goal : keygen:'a keygen -> 'a env_session -> 'a goal -> 'a proof_attempt ->'a proof_attempt val add_transf_to_goal: keygen:'a keygen -> 'a env_session -> 'a goal -> 'a transf -> 'a transf val add_metas_to_goal : keygen:'a keygen -> 'a env_session -> 'a goal -> 'a metas -> 'a metas (** keys are normally generated *) (** {2 Accessor} *) exception NoTask val goal_task : 'key goal -> Task.task (** Return the task of a goal. Raise {!NoTask} if the goal doesn't contain a task (equivalent to ['key = notask] if {!release_task} is not used) *) val goal_task_option : 'key goal -> Task.task option (** Return the task of a goal. *) val goal_user_name : 'key goal -> string (** Return a user-friendly name for a goal, derived from its name, its number in a sequence of sub-goals, and/or its explanation *) val proof_verified : 'key proof_attempt -> float option (** Return [Some t] if the proof is not obsolete and the result is valid. [t] is the time needed to solved it *) val get_used_provers : 'a session -> Whyconf.Sprover.t (** Get the set of provers which appear in the session *) (* val metas_of_virtuals : 'a metas -> Theory.Smeta.t *) (* (\** Get the set of metas added (the parent goal must contain a task) *\) *) (** {2 Modificator} *) val set_transf_expanded : 'key transf -> bool -> unit val set_metas_expanded : 'key metas -> bool -> unit val set_goal_expanded : 'key goal -> bool -> unit val set_theory_expanded : 'key theory -> bool -> unit val set_file_expanded : 'key file -> bool -> unit (** open one level or close all the sub-level *) (** {2 General type} *) type 'a any = | File of 'a file | Theory of 'a theory | Goal of 'a goal | Proof_attempt of 'a proof_attempt | Transf of 'a transf | Metas of 'a metas val print_any : Format.formatter -> 'a any -> unit (** Print a subtree with a pstree format (cf Tree module) *) val key_any : 'a any -> 'a (** return the key of an element of the tree *) (** {2 External proof} *) type 'key notify = 'key any -> unit (** type of functions which notify modification of the verified field *) val add_external_proof : ?notify:'key notify -> keygen:'key keygen -> obsolete:bool -> archived:bool -> limit: Call_provers.resource_limit -> edit:string option -> 'key goal -> Whyconf.prover -> proof_attempt_status -> 'key proof_attempt val remove_external_proof : ?notify:'key notify -> 'key proof_attempt -> unit val set_proof_state : ?notify:'key notify -> obsolete:bool -> archived:bool -> proof_attempt_status -> 'key proof_attempt -> unit val change_prover : 'a proof_attempt -> Whyconf.prover -> unit val set_obsolete : ?notify:'key notify -> 'key proof_attempt -> unit val set_archived : 'key proof_attempt -> bool -> unit val set_edited_as : string option -> 'key proof_attempt -> unit val get_edited_as_abs : 'key session -> 'k proof_attempt -> string option (** return the edited filename after concatenation to [session_dir] *) val update_edit_external_proof : cntexample:bool -> 'key env_session -> 'key proof_attempt -> string (** return the absolute path of the edited file update with the current goal *) val set_timelimit : int -> 'key proof_attempt -> unit val set_memlimit : int -> 'key proof_attempt -> unit val copy_external_proof : ?notify:'key notify -> keygen:'key keygen -> ?obsolete:bool -> ?archived:bool -> ?limit:Call_provers.resource_limit -> ?edit:string option -> ?goal:'key goal -> ?prover:Whyconf.prover -> ?attempt_status:proof_attempt_status -> ?env_session:'key env_session -> ?session:'key session -> 'key proof_attempt -> 'key proof_attempt (** copy an external proof. if env_session and session are given only env_session.session is taken into account. The edited file is copied and an env_session is not required if : {ul {- the goal is not modified} {- the prover is not modified} {- a session is given} } The edited file is regenerated if {ul {- the external proof contain an edited file} {- an env_session is given} {- the given goal (or the old one if not modified) contain a task} } In all the other case the resulting external proof is considered not edited. *) (** {2 Transformation} *) val add_transformation : ?init:'key notify -> ?notify:'key notify -> keygen:'key keygen -> 'key env_session -> string -> 'key goal -> Task.task list -> 'key transf (** Add a transformation by its subgoals *) val add_registered_transformation : keygen:'key keygen -> 'key env_session -> string -> 'key goal -> 'key transf (** Apply a real transformation by its why3 name, raise {!NoTask} if the goal doesn't contain a task. If the goal already has a transformation with this name, it is returned. *) val remove_transformation : ?notify:'key notify -> 'key transf -> unit (** Remove a transformation *) (** {2 Metas} *) val add_registered_metas : keygen:'key keygen -> 'key env_session -> (string * Theory.meta_arg list) list -> 'key goal -> 'key metas (** Add some metas to a task. If the goal already contain a {!metas} with same metas, the old one is returned. *) val remove_metas : ?notify:'key notify -> 'key metas -> unit (** Remove the addition of metas *) (** {2 File} *) val add_file : keygen:'key keygen -> 'key env_session -> ?format:string -> string -> 'key file (** Add a real file by its filename. The filename must be relative to session_dir *) val remove_file : 'key file -> unit (** Remove a file *) (** {2 Free and recover task} *) (** Tasks are stored inside the goals. For releasing memory you can remove them. Later you can recompute them *) val release_task: 'a goal -> unit (** remove the task stored in this goal*) val release_sub_tasks: 'a goal -> unit (** apply the previous function on this goal and its its sub-goal *) val recover_theory_tasks: 'a env_session -> 'a theory -> unit (** Recover all the sub-goal (not only strict) of this theory *) val goal_task_or_recover: 'a env_session -> 'a goal -> Task.task (** same as goal_task but recover the task goal and all the one of this theory if this goal task have been released *) (** {2 Iterators} *) (** {3 Recursive} *) val goal_iter_proof_attempt : ('key proof_attempt -> unit) -> 'key goal -> unit (* unused val transf_iter_proof_attempt : ('key proof_attempt -> unit) -> 'key transf -> unit *) val theory_iter_proof_attempt : ('key proof_attempt -> unit) -> 'key theory -> unit val transf_iter_proof_attempt : ('key proof_attempt -> unit) -> 'key transf -> unit val file_iter_proof_attempt : ('key proof_attempt -> unit) -> 'key file -> unit val session_iter_proof_attempt : ('key proof_attempt -> unit) -> 'key session -> unit val iter_proof_attempt : ('key proof_attempt -> unit) -> 'key any -> unit val goal_iter_leaf_goal : unproved_only:bool -> ('key goal -> unit) -> 'key goal -> unit (** iter all the goals which are a leaf (no transformations are applied on it) *) val fold_all_sub_goals_of_theory : ('a -> 'key goal -> 'a) -> 'a -> 'key theory -> 'a (** {3 Not recursive} *) val iter_goal : ('key proof_attempt -> unit) -> ('key transf -> unit) -> ('key metas -> unit) -> 'key goal -> unit val iter_transf : ('key goal -> unit) -> 'key transf -> unit val iter_metas : ('key goal -> unit) -> 'key metas -> unit val iter_theory : ('key goal -> unit) -> 'key theory -> unit (** [iter_theory f th] applies [f] to all root goals of theory [th] *) val iter_file : ('key theory -> unit) -> 'key file -> unit val iter_session : ('key file -> unit) -> 'key session -> unit val goal_iter : ('key any -> unit) -> 'key goal -> unit (* unused val transf_iter : ('key any -> unit) -> 'key transf -> unit *) val theory_iter : ('key any -> unit) -> 'key theory -> unit val transf_iter : ('key any -> unit) -> 'key transf -> unit val metas_iter : ('key any -> unit) -> 'key metas -> unit val file_iter : ('key any -> unit) -> 'key file -> unit val session_iter : ('key any -> unit) -> 'key session -> unit val iter : ('key any -> unit) -> 'key any -> unit (* Local Variables: compile-command: "unset LANG; make -C ../.. bin/why3ide.byte" End: *) why3-0.88.3/src/session/xml.mli0000664000175100017510000000241313225666037017031 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) type attributes = (string * string) list type element = { name : string; attributes : attributes; elements : element list; } type t = { version : string; encoding : string; doctype : string; dtd : string; content : element; } exception Parse_error of string val from_file : ?fixattrs:(string -> attributes -> attributes) -> string -> t (** returns the list of XML elements from the given file. raise [Sys_error] if the file cannot be opened. raise [Parse_error] if the file does not follow XML syntax *) why3-0.88.3/src/session/session_tools.ml0000664000175100017510000000607113225666037020767 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Whyconf open Session (** convert unknown prover *) let unknown_to_known_provers provers pu = Mprover.fold (fun pk _ (others,name,version) -> match pk.prover_name = pu.prover_name, pk.prover_version = pu.prover_version, pk.prover_altern = pu.prover_altern with | false, _, _ -> pk::others, name, version | _, false, _ -> others, pk::name, version | _ -> others, name, pk::version ) provers ([],[],[]) let utkp provers pu () = let _,name,version = unknown_to_known_provers provers pu in version@name let convert_unknown_prover ~keygen env_session = let known_provers = get_provers env_session.whyconf in let provers = get_used_provers env_session.session in let unknown_provers = Mprover.set_diff provers known_provers in if not (Sprover.is_empty unknown_provers) then begin (* construct the list of compatible provers for each unknown provers *) let unknown_provers = Mprover.mapi (utkp known_provers) unknown_provers in session_iter_proof_attempt (fun pr -> let pks = Mprover.find_def [] pr.proof_prover unknown_provers in List.iter (fun pk -> (* If such a prover already exists we add nothing *) if not (PHprover.mem (goal_external_proofs pr.proof_parent) pk) then ignore (copy_external_proof ~keygen ~prover:pk pr) ) pks; ) env_session.session end (** filter the proof attempt *) let filter_proof_attempt ?notify f s = session_iter_proof_attempt (fun pr -> if not (f pr) then remove_external_proof ?notify pr) s (** get all proof_attempt *) let all_proof_attempts s = let l = ref [] in session_iter_proof_attempt (fun pr -> l:=pr::!l) s; !l (** apply a transformation on all the proof_attempt *) let transform_proof_attempt ?notify ~keygen env_session tr_name = let replace pr = let g = pr.proof_parent in remove_external_proof ?notify pr; let tr = try PHstr.find (goal_transformations g) tr_name with Not_found -> add_registered_transformation ~keygen env_session tr_name g in let add_pa sg = if not (PHprover.mem (goal_external_proofs sg) pr.proof_prover) then ignore (copy_external_proof ~keygen ~goal:sg ~attempt_status:Interrupted pr) in List.iter add_pa tr.transf_goals in let proofs = all_proof_attempts env_session.session in List.iter replace proofs why3-0.88.3/src/session/session.ml0000664000175100017510000027156013225666037017556 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Stdlib open Ty open Ident open Decl open Term open Theory open Task module Mprover = Whyconf.Mprover module Sprover = Whyconf.Sprover module PHprover = Whyconf.Hprover module C = Whyconf module Tc = Termcode let debug = Debug.register_info_flag "session" ~desc:"Pring@ debugging@ messages@ about@ Why3@ session@ \ creation,@ reading@ and@ writing." (** {2 Type definitions} *) module PHstr = Hstr type proof_attempt_status = | Unedited (** editor not yet run for interactive proof *) | JustEdited (** edited but not run yet *) | Interrupted (** external proof has never completed *) | Scheduled (** external proof attempt is scheduled *) | Running (** external proof attempt is in progress *) | Done of Call_provers.prover_result (** external proof done *) | InternalFailure of exn (** external proof aborted by internal error *) type task_option = Task.task option type 'a hide = 'a option type ident_path = { ip_library : string list; ip_theory : string; ip_qualid : string list; } let print_ident_path fmt ip = Format.fprintf fmt "%a.%s.%a" (Pp.print_list Pp.dot Pp.string) ip.ip_library ip.ip_theory (Pp.print_list Pp.dot Pp.string) ip.ip_qualid (* dead code let compare_ident_path x y = let c = Lists.compare String.compare x.ip_library y.ip_library in if c <> 0 then -c else (* in order to be bottom up *) let c = String.compare x.ip_theory y.ip_theory in if c <> 0 then c else let c = Lists.compare String.compare x.ip_qualid y.ip_qualid in c module Pos = struct type t = ident_path let compare = compare_ident_path let equal x y = (x : t) = y let hash x = Hashtbl.hash (x : t) end module Mpos = Extmap.Make(Pos) module Spos = Extset.MakeOfMap(Mpos) module Hpos = Exthtbl.Make(Pos) *) type meta_args = meta_arg list module Mmeta_args = Extmap.Make(struct type t = meta_args let meta_arg_id = function | MAty _ -> 0 | MAts _ -> 1 | MAls _ -> 2 | MApr _ -> 3 | MAstr _ -> 4 | MAint _ -> 5 let compare_meta_arg x y = match x,y with (* These hash are in fact tag *) | MAty x, MAty y -> compare (ty_hash x) (ty_hash y) | MAts x, MAts y -> compare (ts_hash x) (ts_hash y) | MAls x, MAls y -> compare (ls_hash x) (ls_hash y) | MApr x, MApr y -> compare (pr_hash x) (pr_hash y) | MAstr x, MAstr y -> String.compare x y | MAint x, MAint y -> compare x y | _ -> compare (meta_arg_id x) (meta_arg_id y) let compare = Lists.compare compare_meta_arg end) module Smeta_args = Extset.MakeOfMap(Mmeta_args) type metas_args = Smeta_args.t Mstr.t module Mmetas_args = Extmap.Make(struct type t = metas_args let compare = Mstr.compare Smeta_args.compare end) type idpos = { idpos_ts : ident_path Mts.t; idpos_ls : ident_path Mls.t; idpos_pr : ident_path Mpr.t; } let empty_idpos = { idpos_ts = Mts.empty; idpos_ls = Mls.empty; idpos_pr = Mpr.empty; } (* dead code let posid_of_idpos idpos = let posid = Mpos.empty in let posid = Mts.fold (fun ts pos -> Mpos.add pos (MAts ts)) idpos.idpos_ts posid in let posid = Mls.fold (fun ls pos -> Mpos.add pos (MAls ls)) idpos.idpos_ls posid in let posid = Mpr.fold (fun pr pos -> Mpos.add pos (MApr pr)) idpos.idpos_pr posid in posid *) type 'a goal = { mutable goal_key : 'a; goal_name : Ident.ident; goal_number : int; mutable goal_expl : string option; goal_parent : 'a goal_parent; mutable goal_checksum : Tc.checksum option; mutable goal_shape : Tc.shape; mutable goal_verified : float option; mutable goal_task: task_option; mutable goal_expanded : bool; goal_external_proofs : 'a proof_attempt PHprover.t; goal_transformations : 'a transf PHstr.t; mutable goal_metas : 'a metas Mmetas_args.t; } and 'a proof_attempt = { proof_key : 'a; mutable proof_prover : Whyconf.prover; proof_parent : 'a goal; mutable proof_state : proof_attempt_status; mutable proof_limit : Call_provers.resource_limit; mutable proof_obsolete : bool; mutable proof_archived : bool; mutable proof_edited_as : string option; } and 'a goal_parent = | Parent_theory of 'a theory | Parent_transf of 'a transf | Parent_metas of 'a metas and 'a metas = { mutable metas_key : 'a; metas_added : metas_args; metas_idpos : idpos; metas_parent : 'a goal; mutable metas_verified : float option; mutable metas_goal : 'a goal; (** Not mutated after the creation *) mutable metas_expanded : bool; } and 'a transf = { mutable transf_key : 'a; transf_name : string; (** Why3 tranformation name *) transf_parent : 'a goal; mutable transf_verified : float option; mutable transf_goals : 'a goal list; (** Not mutated after the creation of the session *) mutable transf_expanded : bool; mutable transf_detached : 'a detached option; } and 'a detached = { detached_goals: 'a goal list; } and 'a theory = { mutable theory_key : 'a; theory_name : Ident.ident; theory_parent : 'a file; mutable theory_checksum : Termcode.checksum option; mutable theory_goals : 'a goal list; mutable theory_verified : float option; mutable theory_expanded : bool; mutable theory_task : Theory.theory hide; mutable theory_detached : 'a detached option; } and 'a file = { mutable file_key : 'a; file_name : string; file_format : string option; file_parent : 'a session; mutable file_theories: 'a theory list; (** Not mutated after the creation *) mutable file_verified : float option; mutable file_expanded : bool; mutable file_for_recovery : Theory.theory Mstr.t hide; } and 'a session = { session_files : 'a file PHstr.t; mutable session_shape_version : int; session_prover_ids : int PHprover.t; session_dir : string; (** Absolute path *) } type loaded_prover = { prover_config : Whyconf.config_prover; prover_driver : Driver.driver} type loaded_provers = loaded_prover option PHprover.t type 'a env_session = { env : Env.env; mutable whyconf : Whyconf.config; loaded_provers : loaded_provers; mutable files : Theory.theory Stdlib.Mstr.t Stdlib.Mstr.t; session : 'a session} let goal_key g = g.goal_key let goal_name g = g.goal_name let goal_verified g = g.goal_verified let goal_external_proofs g = g.goal_external_proofs let goal_transformations g = g.goal_transformations let goal_metas g = g.goal_metas let goal_expanded g = g.goal_expanded let update_env_session_config e c = e.whyconf <- c (*************************) (** Iterators *) (*************************) type 'a any = | File of 'a file | Theory of 'a theory | Goal of 'a goal | Proof_attempt of 'a proof_attempt | Transf of 'a transf | Metas of 'a metas let rec goal_iter_proof_attempt f g = PHprover.iter (fun _ a -> f a) g.goal_external_proofs; PHstr.iter (fun _ t -> transf_iter_proof_attempt f t) g.goal_transformations; Mmetas_args.iter (fun _ t -> metas_iter_proof_attempt f t) g.goal_metas; and transf_iter_proof_attempt f t = List.iter (goal_iter_proof_attempt f) t.transf_goals and metas_iter_proof_attempt f t = goal_iter_proof_attempt f t.metas_goal let theory_iter_proof_attempt f t = List.iter (goal_iter_proof_attempt f) t.theory_goals let metas_iter_proof_attempt f m = goal_iter_proof_attempt f m.metas_goal let file_iter_proof_attempt f t = List.iter (theory_iter_proof_attempt f) t.file_theories let session_iter_proof_attempt f s = PHstr.iter (fun _ file -> file_iter_proof_attempt f file) s.session_files let iter_proof_attempt f = function | Goal g -> goal_iter_proof_attempt f g | Theory th -> theory_iter_proof_attempt f th | File file -> file_iter_proof_attempt f file | Proof_attempt a -> f a | Transf tr -> transf_iter_proof_attempt f tr | Metas m -> metas_iter_proof_attempt f m let rec goal_iter_leaf_goal ~unproved_only f g = if not (Opt.inhabited g.goal_verified && unproved_only) then let r = ref true in PHstr.iter (fun _ t -> r := false; List.iter (goal_iter_leaf_goal ~unproved_only f) t.transf_goals) g.goal_transformations; if !r then f g let rec fold_all_sub_goals_of_goal f acc g = let acc = PHstr.fold (fun _ tr acc -> List.fold_left (fold_all_sub_goals_of_goal f) acc tr.transf_goals) g.goal_transformations acc in let acc = Mmetas_args.fold (fun _ m acc -> fold_all_sub_goals_of_goal f acc m.metas_goal) g.goal_metas acc in f acc g let fold_all_sub_goals_of_theory f acc th = List.fold_left (fold_all_sub_goals_of_goal f) acc th.theory_goals (** iterators not reccursive *) let iter_goal fp ft fm g = PHprover.iter (fun _ a -> fp a) g.goal_external_proofs; PHstr.iter (fun _ t -> ft t) g.goal_transformations; Mmetas_args.iter (fun _ t -> fm t) g.goal_metas let iter_transf f t = List.iter (fun g -> f g) t.transf_goals let iter_metas f t = f t.metas_goal let iter_theory f t = List.iter f t.theory_goals let iter_file f fi = List.iter f fi.file_theories let iter_session f s = PHstr.iter (fun _ th -> f th) s.session_files let goal_iter f g = PHprover.iter (fun _ a -> f (Proof_attempt a)) g.goal_external_proofs; PHstr.iter (fun _ t -> f (Transf t)) g.goal_transformations; Mmetas_args.iter (fun _ t -> f (Metas t)) g.goal_metas let transf_iter f t = List.iter (fun g -> f (Goal g)) t.transf_goals let metas_iter f t = f (Goal t.metas_goal) let theory_iter f t = List.iter (fun g -> f (Goal g)) t.theory_goals let file_iter f t = List.iter (fun th -> f (Theory th)) t.file_theories let session_iter f s = PHstr.iter (fun _ file -> f (File file)) s.session_files let iter f = function | Goal g -> goal_iter f g | Theory th -> theory_iter f th | File file -> file_iter f file | Proof_attempt _ -> () | Transf tr -> transf_iter f tr | Metas m -> metas_iter f m (** Print session *) module PTreeT = struct type 'a t = | Any of 'a any | Session of 'a session let decomp = function | Any t -> let s = match t with | File f -> if Opt.inhabited f.file_verified then f.file_name else f.file_name^"?" | Theory th -> if Opt.inhabited th.theory_verified then th.theory_name.Ident.id_string else th.theory_name.Ident.id_string^"?" | Goal g -> if Opt.inhabited g.goal_verified then g.goal_name.Ident.id_string else g.goal_name.Ident.id_string^"?" | Proof_attempt pr -> Pp.sprintf_wnl "%a%s%s%s%s" Whyconf.print_prover pr.proof_prover (match pr.proof_state with | Done { Call_provers.pr_answer = Call_provers.Valid} -> "" | InternalFailure _ -> "!" | _ -> "?") (if pr.proof_obsolete || pr.proof_archived then " " else "") (if pr.proof_obsolete then "O" else "") (if pr.proof_archived then "A" else "") | Transf tr -> if Opt.inhabited tr.transf_verified then tr.transf_name else tr.transf_name^"?" | Metas metas -> if Opt.inhabited metas.metas_verified then "metas..." else "metas..."^"?" in let l = ref [] in iter (fun a -> l := (Any a)::!l) t; s,!l | Session s -> let l = ref [] in session_iter (fun a -> l := (Any a)::!l) s; (* Previously "" was `Filename.basename s.session_dir` but the tree depend on the filename given in input and not the content which is not easy for diffing *) "",!l end module PTree = Print_tree.PMake(PTreeT) let print_any fmt any = PTree.print fmt (PTreeT.Any any) let print_session fmt s = PTree.print fmt (PTreeT.Session s) (** 2 Create a session *) let empty_session ?shape_version dir = let shape_version = match shape_version with | Some v -> v | None -> Termcode.current_shape_version in { session_files = PHstr.create 3; session_shape_version = shape_version; session_prover_ids = PHprover.create 7; session_dir = dir; } let create_session ?shape_version project_dir = if not (Sys.file_exists project_dir) then begin Debug.dprintf debug "[Info] '%s' does not exists. Creating directory of that name \ for the project@." project_dir; Unix.mkdir project_dir 0o777 end; empty_session ?shape_version project_dir (* dead code let load_env_session ?(includes=[]) session conf_path_opt = let config = Whyconf.read_config conf_path_opt in let loadpath = (Whyconf.loadpath (Whyconf.get_main config)) @ includes in let env = Env.create_env loadpath in { session = session; env = env; whyconf = config; loaded_provers = PHprover.create 5; } *) (************************) (* session accessor *) (************************) (* dead code let get_session_file file = file.file_parent let get_session_theory th = get_session_file th.theory_parent let rec get_session_goal goal = match goal.goal_parent with | Parent_transf trans -> get_session_trans trans | Parent_theory th -> get_session_theory th | Parent_metas metas -> get_session_metas metas and get_session_trans transf = get_session_goal transf.transf_parent and get_session_metas metas = get_session_goal metas.metas_parent let get_session_proof_attempt pa = get_session_goal pa.proof_parent *) let get_used_provers session = let sprover = ref Sprover.empty in session_iter_proof_attempt (fun pa -> sprover := Sprover.add pa.proof_prover !sprover) session; !sprover let get_used_provers_with_stats session = let prover_table = PHprover.create 5 in session_iter_proof_attempt (fun pa -> (* record mostly used pa.proof_timelimit pa.proof_memlimit *) let prover = pa.proof_prover in let timelimits,steplimits,memlimits = try PHprover.find prover_table prover with Not_found -> let x = (Hashtbl.create 5,Hashtbl.create 5,Hashtbl.create 5) in PHprover.add prover_table prover x; x in let lim_time = pa.proof_limit.Call_provers.limit_time in let lim_mem = pa.proof_limit.Call_provers.limit_mem in let lim_steps = pa.proof_limit.Call_provers.limit_steps in let tf = try Hashtbl.find timelimits lim_time with Not_found -> 0 in let sf = try Hashtbl.find steplimits lim_steps with Not_found -> 0 in let mf = try Hashtbl.find memlimits lim_mem with Not_found -> 0 in Hashtbl.replace timelimits lim_time (tf+1); Hashtbl.replace steplimits lim_steps (sf+1); Hashtbl.replace memlimits lim_mem (mf+1)) session; prover_table exception NoTask let goal_task g = Opt.get_exn NoTask g.goal_task let goal_task_option g = g.goal_task let goal_expl_lazy g = match g.goal_expl with | Some s -> s | None -> match g.goal_task with | Some t -> let _name,expl,_task = Termcode.goal_expl_task ~root:false t in g.goal_expl <- Some expl; expl | None -> "" let goal_user_name g = let s = goal_expl_lazy g in if s <> "" then string_of_int g.goal_number ^ ". " ^ s else try let _,_,l = restore_path g.goal_name in String.concat "." l with Not_found -> g.goal_name.Ident.id_string (************************) (* saving state on disk *) (************************) open Format let db_filename = "why3session.xml" let shape_filename = "why3shapes" let compressed_shape_filename = "why3shapes.gz" let session_dir_for_save = ref "." let save_string = Pp.html_string let opt pr lab fmt = function | None -> () | Some s -> fprintf fmt "@ %s=\"%a\"" lab pr s let save_result fmt r = let steps = if r.Call_provers.pr_steps >= 0 then Some r.Call_provers.pr_steps else None in fprintf fmt "" (match r.Call_provers.pr_answer with | Call_provers.Valid -> "valid" | Call_provers.Failure _ -> "failure" | Call_provers.Unknown _ -> "unknown" | Call_provers.HighFailure -> "highfailure" | Call_provers.Timeout -> "timeout" | Call_provers.OutOfMemory -> "outofmemory" | Call_provers.StepLimitExceeded -> "steplimitexceeded" | Call_provers.Invalid -> "invalid") r.Call_provers.pr_time (opt pp_print_int "steps") steps let save_status fmt s = match s with | Unedited -> fprintf fmt "" | Scheduled | Running | Interrupted | JustEdited -> fprintf fmt "" | InternalFailure msg -> fprintf fmt "" save_string (Printexc.to_string msg) | Done r -> save_result fmt r let save_bool_def name def fmt b = if b <> def then fprintf fmt "@ %s=\"%b\"" name b let save_int_def name def fmt n = if n <> def then fprintf fmt "@ %s=\"%d\"" name n let opt_string = opt save_string let save_proof_attempt fmt ((id,tl,sl,ml),a) = fprintf fmt "@\n@[" id (save_int_def "timelimit" tl) (a.proof_limit.Call_provers.limit_time) (save_int_def "steplimit" sl) (a.proof_limit.Call_provers.limit_steps) (save_int_def "memlimit" ml) (a.proof_limit.Call_provers.limit_mem) (opt_string "edited") a.proof_edited_as (save_bool_def "obsolete" false) a.proof_obsolete (save_bool_def "archived" false) a.proof_archived; save_status fmt a.proof_state; fprintf fmt "@]" let save_ident fmt id = let n= try let (_,_,l) = Theory.restore_path id in String.concat "." l with Not_found -> id.Ident.id_string in fprintf fmt "name=\"%a\"" save_string n module Compr = Compress.Compress_z type save_ctxt = { prover_ids : int PHprover.t; provers : (int * int * int * int) Mprover.t; ch_shapes : Compr.out_channel; } let save_checksum fmt s = fprintf fmt "%s" (Tc.string_of_checksum s) let rec save_goal ctxt fmt g = let shape = Tc.string_of_shape g.goal_shape in assert (shape <> ""); fprintf fmt "@\n@[@[@]" save_ident g.goal_name (opt_string "expl") g.goal_expl (save_bool_def "expanded" false) g.goal_expanded; let sum = match g.goal_checksum with | None -> assert false | Some s -> Tc.string_of_checksum s in Compr.output_string ctxt.ch_shapes sum; Compr.output_char ctxt.ch_shapes ' '; Compr.output_string ctxt.ch_shapes shape; Compr.output_char ctxt.ch_shapes '\n'; (* Ident.Slab.iter (save_label fmt) g.goal_name.Ident.id_label; *) let l = PHprover.fold (fun _ a acc -> (Mprover.find a.proof_prover ctxt.provers, a) :: acc) g.goal_external_proofs [] in let l = List.sort (fun ((i1,_,_,_),_) ((i2,_,_,_),_) -> compare i1 i2) l in List.iter (save_proof_attempt fmt) l; let l = PHstr.fold (fun _ t acc -> t :: acc) g.goal_transformations [] in let l = List.sort (fun t1 t2 -> compare t1.transf_name t2.transf_name) l in List.iter (save_trans ctxt fmt) l; Mmetas_args.iter (save_metas ctxt fmt) g.goal_metas; fprintf fmt "@]@\n" and save_trans ctxt fmt t = fprintf fmt "@\n@[@[@]" save_string t.transf_name (save_bool_def "expanded" false) t.transf_expanded; List.iter (save_goal ctxt fmt) t.transf_goals; fprintf fmt "@]@\n" and save_metas ctxt fmt _ m = fprintf fmt "@\n@[" (save_bool_def "expanded" false) m.metas_expanded; let save_pos fmt pos = fprintf fmt "ip_theory=\"%a\">" save_string pos.ip_theory; List.iter (fprintf fmt "@\n@[@]" save_string) pos.ip_library; List.iter (fprintf fmt "@\n@[@]" save_string) pos.ip_qualid; in let save_ts_pos fmt ts pos = fprintf fmt "@\n@[" save_string ts.ts_name.id_string (List.length ts.ts_args) (ts_hash ts) save_pos pos in let save_ls_pos fmt ls pos = (* TODO: add the signature? *) fprintf fmt "@\n@[" save_string ls.ls_name.id_string (ls_hash ls) save_pos pos in let save_pr_pos fmt pr pos = fprintf fmt "@\n@[" save_string pr.pr_name.id_string (pr_hash pr) save_pos pos in Mts.iter (save_ts_pos fmt) m.metas_idpos.idpos_ts; Mls.iter (save_ls_pos fmt) m.metas_idpos.idpos_ls; Mpr.iter (save_pr_pos fmt) m.metas_idpos.idpos_pr; Mstr.iter (fun s smeta_args -> Smeta_args.iter (save_meta_args fmt s) smeta_args) m.metas_added; save_goal ctxt fmt m.metas_goal; fprintf fmt "@]@\n" and save_meta_args fmt s l = fprintf fmt "@\n@[" save_string s; let save_meta_arg fmt = function | MAty ty -> fprintf fmt "@\n@["; save_ty fmt ty; fprintf fmt "@]@\n" | MAts ts -> fprintf fmt "@\n@[@]" (ts_hash ts) | MAls ls -> fprintf fmt "@\n@[@]" (ls_hash ls) | MApr pr -> fprintf fmt "@\n@[@]" (pr_hash pr) | MAstr s -> fprintf fmt "@\n@[@]" s | MAint i -> fprintf fmt "@\n@[@]" i in List.iter (save_meta_arg fmt) l; fprintf fmt "@]@\n" and save_ty fmt ty = match ty.ty_node with | Tyvar tv -> fprintf fmt "@\n@[@]" (tv_hash tv) | Tyapp (ts,l) -> fprintf fmt "@\n@[" (ts_hash ts); List.iter (save_ty fmt) l; fprintf fmt "@]@\n" module CombinedTheoryChecksum = struct let b = Buffer.create 1024 let f () g = match g.goal_checksum with | None -> assert false | Some c -> Buffer.add_string b (Tc.string_of_checksum c) let compute th = let () = fold_all_sub_goals_of_theory f () th in let c = Tc.buffer_checksum b in Buffer.clear b; c end let save_theory ctxt fmt t = let c = CombinedTheoryChecksum.compute t in t.theory_checksum <- Some c; fprintf fmt "@\n@[@[@]" save_ident t.theory_name (opt save_checksum "sum") t.theory_checksum (save_bool_def "expanded" false) t.theory_expanded; List.iter (save_goal ctxt fmt) t.theory_goals; fprintf fmt "@]@\n" let save_file ctxt fmt _ f = fprintf fmt "@\n@[@[@]" save_string f.file_name (opt_string "format") f.file_format (save_bool_def "expanded" false) f.file_expanded; List.iter (save_theory ctxt fmt) f.file_theories; fprintf fmt "@]@\n" let get_prover_to_save prover_ids p (timelimits,steplimits,memlimits) provers = let mostfrequent_timelimit,_ = Hashtbl.fold (fun t f ((_,f') as t') -> if f > f' then (t,f) else t') timelimits (0,0) in let mostfrequent_steplimit,_ = Hashtbl.fold (fun s f ((_,f') as s') -> if f > f' then (s,f) else s') steplimits (0,0) in let mostfrequent_memlimit,_ = Hashtbl.fold (fun m f ((_,f') as m') -> if f > f' then (m,f) else m') memlimits (0,0) in let id = try PHprover.find prover_ids p with Not_found -> (* we need to find an unused prover id *) let occurs = Hashtbl.create 7 in PHprover.iter (fun _ n -> Hashtbl.add occurs n ()) prover_ids; let id = ref 0 in try while true do try let _ = Hashtbl.find occurs !id in incr id with Not_found -> raise Exit done; assert false with Exit -> PHprover.add prover_ids p !id; !id in Mprover.add p (id,mostfrequent_timelimit,mostfrequent_steplimit,mostfrequent_memlimit) provers let save_prover fmt id (p,mostfrequent_timelimit,mostfrequent_steplimit,mostfrequent_memlimit) = let steplimit = if mostfrequent_steplimit < 0 then None else Some mostfrequent_steplimit in fprintf fmt "@\n@[@]" id save_string p.C.prover_name save_string p.C.prover_version (fun fmt s -> if s <> "" then fprintf fmt "@ alternative=\"%a\"" save_string s) p.C.prover_altern mostfrequent_timelimit (opt pp_print_int "steplimit") steplimit mostfrequent_memlimit let save fname shfname _config session = let ch = open_out fname in let chsh = Compr.open_out shfname in let fmt = formatter_of_out_channel ch in fprintf fmt "@\n"; fprintf fmt "@\n"; (* let rel_file = Sysutil.relativize_filename !session_dir_for_save fname in fprintf fmt "@[" save_string rel_file session.session_shape_version; *) fprintf fmt "@[" session.session_shape_version; (* Tc.reset_dict (); *) let prover_ids = session.session_prover_ids in let provers = PHprover.fold (get_prover_to_save prover_ids) (get_used_provers_with_stats session) Mprover.empty in let provers_to_save = Mprover.fold (fun p (id,mostfrequent_timelimit,mostfrequent_steplimit,mostfrequent_memlimit) acc -> Mint.add id (p,mostfrequent_timelimit,mostfrequent_steplimit,mostfrequent_memlimit) acc) provers Mint.empty in Mint.iter (save_prover fmt) provers_to_save; let ctxt = { prover_ids = prover_ids; provers = provers; ch_shapes = chsh } in PHstr.iter (save_file ctxt fmt) session.session_files; fprintf fmt "@]@\n"; fprintf fmt "@."; close_out ch; Compr.close_out chsh let save_session config session = let f = Filename.concat session.session_dir db_filename in Sysutil.backup_file f; let fs = Filename.concat session.session_dir shape_filename in Sysutil.backup_file fs; let fz = Filename.concat session.session_dir compressed_shape_filename in Sysutil.backup_file fz; session_dir_for_save := session.session_dir; let fs = if Compress.compression_supported then fz else fs in save f fs config session (*****************************) (* update verified field *) (*****************************) type 'a notify = 'a any -> unit let notify : 'a notify = fun _ -> () let compute_verified get l = List.fold_left (fun acc t -> match acc,get t with | Some x, Some y -> Some (x +. y) | _ -> None) (Some 0.0) l let file_verified f = compute_verified (fun t -> t.theory_verified) f.file_theories let theory_verified t = compute_verified (fun g -> g.goal_verified) t.theory_goals let transf_verified t = compute_verified (fun g -> g.goal_verified) t.transf_goals let metas_verified m = m.metas_goal.goal_verified let proof_verified a = if a.proof_obsolete then None else match a.proof_state with | Done { Call_provers.pr_answer = Call_provers.Valid; Call_provers.pr_time = t } -> Some t | _ -> None let check_goal_verified g = let acc = ref None in let accumulate v = match v with | None -> () | Some t -> match !acc with | Some x -> acc := Some (x +. t) | None -> acc := v in PHprover.iter (fun _ a -> accumulate (proof_verified a)) g.goal_external_proofs; PHstr.iter (fun _ t -> accumulate t.transf_verified) g.goal_transformations; Mmetas_args.iter (fun _ t -> accumulate t.metas_verified) g.goal_metas; !acc let check_file_verified notify f = let b = file_verified f in if f.file_verified <> b then begin f.file_verified <- b; notify (File f) end let check_theory_proved notify t = let b = theory_verified t in if t.theory_verified <> b then begin t.theory_verified <- b; notify (Theory t); check_file_verified notify t.theory_parent end let rec check_goal_proved notify g = let b = check_goal_verified g in if g.goal_verified <> b then begin g.goal_verified <- b; notify (Goal g); match g.goal_parent with | Parent_theory t -> check_theory_proved notify t | Parent_transf t -> check_transf_proved notify t | Parent_metas t -> check_metas_proved notify t end and check_transf_proved notify t = let b = transf_verified t in if t.transf_verified <> b then begin t.transf_verified <- b; notify (Transf t); check_goal_proved notify t.transf_parent end and check_metas_proved notify m = let b = metas_verified m in if m.metas_verified <> b then begin m.metas_verified <- b; notify (Metas m); check_goal_proved notify m.metas_parent end (******************************) (* raw additions to the model *) (******************************) type 'a keygen = ?parent:'a -> unit -> 'a let add_external_proof ?(notify=notify) ~(keygen:'a keygen) ~obsolete ~archived ~limit ~edit (g:'a goal) p result = assert (edit <> Some ""); let key = keygen ~parent:g.goal_key () in let a = { proof_prover = p; proof_parent = g; proof_key = key; proof_obsolete = obsolete; proof_archived = archived; proof_state = result; proof_limit = limit; proof_edited_as = edit; } in PHprover.replace g.goal_external_proofs p a; check_goal_proved notify g; a let remove_external_proof ?(notify=notify) a = let g = a.proof_parent in PHprover.remove g.goal_external_proofs a.proof_prover; check_goal_proved notify g let set_proof_state ?(notify=notify) ~obsolete ~archived res a = a.proof_state <- res; a.proof_obsolete <- obsolete; a.proof_archived <- archived; notify (Proof_attempt a); check_goal_proved notify a.proof_parent let change_prover a p = let g = a.proof_parent in PHprover.remove g.goal_external_proofs a.proof_prover; PHprover.add g.goal_external_proofs p a; a.proof_prover <- p; a.proof_obsolete <- true let set_edited_as edited_as a = a.proof_edited_as <- edited_as let set_timelimit timelimit a = a.proof_limit <- { a.proof_limit with Call_provers.limit_time = timelimit} let set_memlimit memlimit a = a.proof_limit <- { a.proof_limit with Call_provers.limit_mem = memlimit} let set_obsolete ?(notify=notify) a = a.proof_obsolete <- true; notify (Proof_attempt a); check_goal_proved notify a.proof_parent let set_non_obsolete a = a.proof_obsolete <- false; notify (Proof_attempt a); check_goal_proved notify a.proof_parent let set_archived a b = a.proof_archived <- b let get_edited_as_abs session pr = Opt.map (Filename.concat session.session_dir) pr.proof_edited_as (* [raw_add_goal parent name expl sum t] adds a goal to the given parent DOES NOT record the new goal in its parent, thus this should not be exported *) let raw_add_no_task ~(keygen:'a keygen) ~(expanded:bool) parent name number expl sum shape = let parent_key = match parent with | Parent_theory mth -> mth.theory_key | Parent_transf mtr -> mtr.transf_key | Parent_metas mms -> mms.metas_key in let key = keygen ~parent:parent_key () in let goal = { goal_name = name; goal_number = number; goal_expl = expl; goal_parent = parent; goal_task = None ; goal_checksum = sum; goal_shape = shape; goal_key = key; goal_external_proofs = PHprover.create 7; goal_transformations = PHstr.create 3; goal_metas = Mmetas_args.empty; goal_verified = None; goal_expanded = expanded; } in goal let raw_add_task ~version ~(keygen:'a keygen) ~(expanded:bool) parent name number expl t = let parent_key = match parent with | Parent_theory mth -> mth.theory_key | Parent_transf mtr -> mtr.transf_key | Parent_metas mms -> mms.metas_key in let key = keygen ~parent:parent_key () in let sum = Some (Termcode.task_checksum ~version t) in (* let shape = Termcode.t_shape_buf ~version (Task.task_goal_fmla t) in *) let shape = Termcode.t_shape_task ~version ~expl t in let goal = { goal_name = name; goal_number = number; goal_expl = Some expl; goal_parent = parent; goal_task = Some t ; goal_checksum = sum; goal_shape = shape; goal_key = key; goal_external_proofs = PHprover.create 7; goal_transformations = PHstr.create 3; goal_metas = Mmetas_args.empty; goal_verified = None; goal_expanded = expanded; } in goal (* [raw_add_transformation g name adds a transformation to the given goal g Adds no subgoals, thus this should not be exported *) let raw_add_transformation ~(keygen:'a keygen) ~(expanded:bool) g name = let parent = g.goal_key in let key = keygen ~parent () in let tr = { transf_name = name; transf_parent = g; transf_verified = None; transf_key = key; transf_goals = []; transf_expanded = expanded; transf_detached = None; } in PHstr.replace g.goal_transformations name tr; tr let raw_add_metas ~(keygen:'a keygen) ~(expanded:bool) g added idpos = let parent = g.goal_key in let key = keygen ~parent () in let ms = { metas_added = added; metas_idpos = idpos; metas_parent = g; metas_verified = None; metas_key = key; metas_goal = g; metas_expanded = expanded; } in g.goal_metas <- Mmetas_args.add added ms g.goal_metas; ms let raw_add_theory ~(keygen:'a keygen) ~(expanded:bool) ~(checksum:Tc.checksum option) mfile thname = let parent = mfile.file_key in let key = keygen ~parent () in let mth = { theory_name = thname; theory_key = key; theory_parent = mfile; theory_checksum = checksum; theory_goals = []; theory_verified = None; theory_expanded = expanded; theory_task = None; theory_detached = None; } in mth let raw_add_file ~(keygen:'a keygen) ~(expanded:bool) session f fmt = let key = keygen () in let mfile = { file_name = f; file_key = key; file_format = fmt; file_theories = []; file_verified = None; file_expanded = expanded; file_parent = session; file_for_recovery = None; } in PHstr.replace session.session_files f mfile; mfile (****************************) (* session opening *) (****************************) exception LoadError of Xml.element * string (** LoadError (xml,messg) *) let bool_attribute field r def = try match List.assoc field r.Xml.attributes with | "true" -> true | "false" -> false | _ -> assert false with Not_found -> def let int_attribute_def field r def = try int_of_string (List.assoc field r.Xml.attributes) with Not_found | Invalid_argument _ -> def let int_attribute field r = try int_of_string (List.assoc field r.Xml.attributes) with Not_found | Invalid_argument _ -> (* TODO: use real error *) eprintf "[Error] missing required attribute '%s' from element '%s'@." field r.Xml.name; assert false let string_attribute_def field r def= try List.assoc field r.Xml.attributes with Not_found -> def let string_attribute_opt field r = try Some (List.assoc field r.Xml.attributes) with Not_found -> None let string_attribute field r = try List.assoc field r.Xml.attributes with Not_found -> eprintf "[Error] missing required attribute '%s' from element '%s'@." field r.Xml.name; assert false let load_result r = match r.Xml.name with | "result" -> let status = string_attribute "status" r in let answer = match status with | "valid" -> Call_provers.Valid | "invalid" -> Call_provers.Invalid | "unknown" -> Call_provers.Unknown ("", None) | "timeout" -> Call_provers.Timeout | "outofmemory" -> Call_provers.OutOfMemory | "failure" -> Call_provers.Failure "" | "highfailure" -> Call_provers.HighFailure | "steplimitexceeded" -> Call_provers.StepLimitExceeded | "stepslimitexceeded" -> Call_provers.StepLimitExceeded | s -> Warning.emit "[Warning] Session.load_result: unexpected status '%s'@." s; Call_provers.HighFailure in let time = try float_of_string (List.assoc "time" r.Xml.attributes) with Not_found -> 0.0 in let steps = try int_of_string (List.assoc "steps" r.Xml.attributes) with Not_found -> -1 in Done { Call_provers.pr_answer = answer; Call_provers.pr_time = time; Call_provers.pr_output = ""; Call_provers.pr_status = Unix.WEXITED 0; Call_provers.pr_steps = steps; Call_provers.pr_model = Model_parser.default_model; } | "undone" -> Interrupted | "unedited" -> Unedited | s -> Warning.emit "[Warning] Session.load_result: unexpected element '%s'@." s; Interrupted let load_option attr g = try Some (List.assoc attr g.Xml.attributes) with Not_found -> None let load_ident elt = let name = string_attribute "name" elt in let label = List.fold_left (fun acc label -> match label with | {Xml.name = "label"} -> let lab = string_attribute "name" label in Ident.Slab.add (Ident.create_label lab) acc | _ -> acc ) Ident.Slab.empty elt.Xml.elements in let preid = try let load_exn attr g = List.assoc attr g.Xml.attributes in let file = load_exn "locfile" elt in let lnum = int_of_string (load_exn "loclnum" elt) in let cnumb = int_of_string (load_exn "loccnumb" elt) in let cnume = int_of_string (load_exn "loccnume" elt) in let pos = Loc.user_position file lnum cnumb cnume in Ident.id_user ~label name pos with Not_found | Invalid_argument _ -> Ident.id_fresh ~label name in Ident.id_register preid type 'key load_ctxt = { old_provers : (Whyconf.prover * int * int * int) Mint.t ; keygen : 'key keygen; } let rec load_goal ctxt parent (acc,n) g = match g.Xml.name with | "goal" -> let gname = load_ident g in let expl = load_option "expl" g in let csum = string_attribute_opt "sum" g in let sum = Opt.map Tc.checksum_of_string csum in let shape = try Tc.shape_of_string (List.assoc "shape" g.Xml.attributes) with Not_found -> Tc.shape_of_string "" in let expanded = bool_attribute "expanded" g false in let mg = raw_add_no_task ~keygen:ctxt.keygen ~expanded parent gname n expl sum shape in List.iter (load_proof_or_transf ctxt mg) g.Xml.elements; mg.goal_verified <- goal_verified mg; (mg::acc,n+1) | "label" -> (acc,n) | s -> Warning.emit "[Warning] Session.load_goal: unexpected element '%s'@." s; (acc,n) and load_proof_or_transf ctxt mg a = match a.Xml.name with | "proof" -> begin let prover = string_attribute "prover" a in try let prover = int_of_string prover in let (p,timelimit,steplimit,memlimit) =Mint.find prover ctxt.old_provers in let res = match a.Xml.elements with | [r] -> load_result r | [] -> Interrupted | _ -> Warning.emit "[Error] Too many result elements@."; raise (LoadError (a,"too many result elements")) in let edit = load_option "edited" a in let edit = match edit with None | Some "" -> None | _ -> edit in let obsolete = bool_attribute "obsolete" a false in let archived = bool_attribute "archived" a false in let timelimit = int_attribute_def "timelimit" a timelimit in let steplimit = int_attribute_def "steplimit" a steplimit in let memlimit = int_attribute_def "memlimit" a memlimit in let limit = { Call_provers.limit_time = timelimit; Call_provers.limit_mem = memlimit; Call_provers.limit_steps = steplimit } in (* if timelimit < 0 then begin eprintf "[Error] incorrect or unspecified timelimit '%i'@." timelimit; raise (LoadError (a,sprintf "incorrect or unspecified timelimit %i" timelimit)) end; *) let (_ : 'a proof_attempt) = add_external_proof ~keygen:ctxt.keygen ~archived ~obsolete ~limit ~edit mg p res in () with Failure _ | Not_found -> Warning.emit "[Error] prover id not listed in header '%s'@." prover; raise (LoadError (a,"prover not listing in header")) end | "transf" -> let trname = string_attribute "name" a in let expanded = bool_attribute "expanded" a false in let mtr = raw_add_transformation ~keygen:ctxt.keygen ~expanded mg trname in mtr.transf_goals <- List.rev (fst (List.fold_left (load_goal ctxt (Parent_transf mtr)) ([],1) a.Xml.elements)); (* already done by raw_add_transformation: Hashtbl.add mg.transformations trname mtr *) (* The attribute "proved" is required but not read *) mtr.transf_verified <- transf_verified mtr | "metas" -> load_metas ctxt mg a; | "label" -> () | s -> Warning.emit "[Warning] Session.load_proof_or_transf: unexpected element '%s'@." s and load_metas ctxt mg a = let hts = Hint.create 10 in let hls = Hint.create 10 in let hpr = Hint.create 10 in let idpos, metas_args, goal = List.fold_left (fun (idpos, metas, goal) a -> match a.Xml.name with | "ts_pos" | "ls_pos" | "pr_pos" -> let name = string_attribute "name" a in let intid = int_attribute "id" a in let library, qualid = List.fold_left (fun (library,qualid) a -> match a.Xml.name with | "ip_library" -> string_attribute "name" a::library, qualid | "ip_qualid" -> library, string_attribute "name" a::qualid | _ -> raise (LoadError(a,"Unexpected element"))) ([],[]) a.Xml.elements in let pos = { ip_library = List.rev library; ip_theory = string_attribute "ip_theory" a; ip_qualid = List.rev qualid; } in let idpos = begin match a.Xml.name with | "ts_pos" -> let arity = int_attribute "arity" a in let tvs = Util.foldi (fun l _ -> (create_tvsymbol (Ident.id_fresh "a"))::l) [] 0 arity in let ts = Ty.create_tysymbol (Ident.id_fresh name) tvs NoDef in Hint.add hts intid ts; let idpos_ts = Mts.add ts pos idpos.idpos_ts in { idpos with idpos_ts = idpos_ts } | "ls_pos" -> (* TODO signature? *) let ls = Term.create_lsymbol (Ident.id_fresh name) [] None in Hint.add hls intid ls; let idpos_ls = Mls.add ls pos idpos.idpos_ls in { idpos with idpos_ls = idpos_ls } | "pr_pos" -> let pr = Decl.create_prsymbol (Ident.id_fresh name) in Hint.add hpr intid pr; let idpos_pr = Mpr.add pr pos idpos.idpos_pr in { idpos with idpos_pr = idpos_pr } | _ -> assert false end in (idpos, metas, goal) | "meta" -> (idpos, a::metas, goal) | "goal" -> (idpos, metas, a::goal) | _ -> raise (LoadError(a,"Unexpected element")) ) (empty_idpos,[],[]) a.Xml.elements in let load_ty a = let newtv = Hint.memo 0 (fun _ -> Ty.ty_var (create_tvsymbol (Ident.id_fresh "a"))) in let rec aux a = match a.Xml.name with | "ty_var" -> newtv (int_attribute "id" a) | "ty_app" -> let intid = int_attribute "id" a in let ts = Hint.find hts intid in Ty.ty_app ts (List.map aux a.Xml.elements) | _ -> raise (LoadError(a,"Unexpected element")) in aux a in let load_meta_args a = try match a.Xml.name with | "meta_arg_ty" -> begin match a.Xml.elements with | [ty] -> MAty (load_ty ty) | _ -> raise (LoadError (a,"This element must contain only one element")) end | "meta_arg_str" -> MAstr (string_attribute "val" a) | "meta_arg_int" -> MAint (int_attribute "val" a) | "meta_arg_ts" -> let intid = int_attribute "id" a in let ts = Hint.find hts intid in MAts ts | "meta_arg_ls" -> let intid = int_attribute "id" a in let ls = Hint.find hls intid in MAls ls | "meta_arg_pr" -> let intid = int_attribute "id" a in let pr = Hint.find hpr intid in MApr pr | _ -> raise (LoadError(a,"Unexpected element")) with Not_found -> raise (LoadError (a,"Unknown id")) in let load_meta metas_args a = let args = List.map load_meta_args a.Xml.elements in Mstr.change (function | None -> Some (Smeta_args.singleton args) | Some s -> Some (Smeta_args.add args s)) (string_attribute "name" a) metas_args in let metas_args = List.fold_left load_meta Mstr.empty metas_args in let expanded = bool_attribute "expanded" a false in let metas = raw_add_metas ~keygen:ctxt.keygen ~expanded mg metas_args idpos in let goal = match goal with | [] -> raise (LoadError (a,"No subgoal for this metas")) | [goal] -> goal | _ -> raise (LoadError (a,"Only one goal can appear in a metas element")) in metas.metas_goal <- List.hd (fst (load_goal ctxt (Parent_metas metas) ([],1) goal)); (* already done by raw_add_transformation: Hashtbl.add mg.transformations trname mtr *) (* The attribute "proved" is required but not read *) metas.metas_verified <- metas_verified metas let load_theory ctxt mf acc th = match th.Xml.name with | "theory" -> let thname = load_ident th in let expanded = bool_attribute "expanded" th false in let csum = string_attribute_opt "sum" th in let checksum = Opt.map Tc.checksum_of_string csum in let mth = raw_add_theory ~keygen:ctxt.keygen ~expanded ~checksum mf thname in mth.theory_goals <- List.rev (fst (List.fold_left (load_goal ctxt (Parent_theory mth)) ([],1) th.Xml.elements)); mth.theory_verified <- theory_verified mth; mth::acc | s -> Warning.emit "[Warning] Session.load_theory: unexpected element '%s'@." s; acc let load_file ~keygen session old_provers f = match f.Xml.name with | "file" -> let ctxt = { old_provers = old_provers ; keygen = keygen } in let fn = string_attribute "name" f in let fmt = load_option "format" f in let expanded = bool_attribute "expanded" f false in let mf = raw_add_file ~keygen:ctxt.keygen ~expanded session fn fmt in mf.file_theories <- List.rev (List.fold_left (load_theory ctxt mf) [] f.Xml.elements); mf.file_verified <- file_verified mf; old_provers | "prover" -> (* The id is just for the session file *) let id = string_attribute "id" f in begin try let id = int_of_string id in let name = string_attribute "name" f in let version = string_attribute "version" f in let altern = string_attribute_def "alternative" f "" in let timelimit = int_attribute_def "timelimit" f 5 in let steplimit = int_attribute_def "steplimit" f 0 in let memlimit = int_attribute_def "memlimit" f 1000 in let p = {C.prover_name = name; prover_version = version; prover_altern = altern} in Mint.add id (p,timelimit,steplimit,memlimit) old_provers with Failure _ -> Warning.emit "[Warning] Session.load_file: unexpected non-numeric prover id '%s'@." id; old_provers end | s -> Warning.emit "[Warning] Session.load_file: unexpected element '%s'@." s; old_provers let load_session ~keygen session xml = match xml.Xml.name with | "why3session" -> let shape_version = int_attribute_def "shape_version" xml 1 in session.session_shape_version <- shape_version; Debug.dprintf debug "[Info] load_session: shape version is %d@\n" shape_version; (* just to keep the old_provers somewhere *) let old_provers = List.fold_left (load_file ~keygen session) Mint.empty xml.Xml.elements in Mint.iter (fun id (p,_,_,_) -> Debug.dprintf debug "prover %d: %a@." id Whyconf.print_prover p; PHprover.replace session.session_prover_ids p id) old_provers; Debug.dprintf debug "[Info] load_session: done@\n" | s -> Warning.emit "[Warning] Session.load_session: unexpected element '%s'@." s exception ShapesFileError of string exception SessionFileError of string module ReadShapes (C:Compress.S) = struct let shape = Buffer.create 97 let read_sum_and_shape ch = let sum = Bytes.create 32 in let nsum = C.input ch sum 0 32 in if nsum = 0 then raise End_of_file; if nsum <> 32 then begin try C.really_input ch sum nsum (32-nsum) with End_of_file -> raise (ShapesFileError ("shapes files corrupted (checksum '" ^ (Bytes.sub_string sum 0 nsum) ^ "' too short), ignored")) end; if try C.input_char ch <> ' ' with End_of_file -> true then raise (ShapesFileError "shapes files corrupted (space missing), ignored"); Buffer.clear shape; try while true do let c = C.input_char ch in if c = '\n' then raise Exit; Buffer.add_char shape c done; assert false with | End_of_file -> raise (ShapesFileError "shapes files corrupted (premature end of file), ignored"); | Exit -> Bytes.unsafe_to_string sum, Buffer.contents shape let use_shapes = ref true let fix_attributes ch name attrs = if name = "goal" then try let sum,shape = read_sum_and_shape ch in let attrs = try let old_sum = List.assoc "sum" attrs in if sum <> old_sum then begin Format.eprintf "old sum = %s ; new sum = %s@." old_sum sum; raise (ShapesFileError "shapes files corrupted (sums do not correspond)") end; attrs with Not_found -> ("sum", sum) :: attrs in ("shape",shape) :: attrs with _ -> use_shapes := false; attrs else attrs let read_xml_and_shapes xml_fn compressed_fn = use_shapes := true; try let ch = C.open_in compressed_fn in let xml = Xml.from_file ~fixattrs:(fix_attributes ch) xml_fn in C.close_in ch; xml, !use_shapes with Sys_error msg -> raise (ShapesFileError ("cannot open shapes file for reading: " ^ msg)) end module ReadShapesNoCompress = ReadShapes(Compress.Compress_none) module ReadShapesCompress = ReadShapes(Compress.Compress_z) let read_file_session_and_shapes dir xml_filename = try let compressed_shape_filename = Filename.concat dir compressed_shape_filename in if Sys.file_exists compressed_shape_filename then if Compress.compression_supported then ReadShapesCompress.read_xml_and_shapes xml_filename compressed_shape_filename else begin Warning.emit "[Warning] could not read goal shapes because \ Why3 was not compiled with compress support@."; Xml.from_file xml_filename, false end else let shape_filename = Filename.concat dir shape_filename in if Sys.file_exists shape_filename then ReadShapesNoCompress.read_xml_and_shapes xml_filename shape_filename else begin Warning.emit "[Warning] could not find goal shapes file@."; Xml.from_file xml_filename, false end with e -> Warning.emit "[Warning] failed to read goal shapes: %s@." (Printexc.to_string e); Xml.from_file xml_filename, false let read_session_with_keys ~keygen dir = if not (Sys.file_exists dir && Sys.is_directory dir) then raise (SessionFileError (Pp.sprintf "%s is not an existing directory" dir)); let xml_filename = Filename.concat dir db_filename in let session = empty_session dir in let use_shapes = (* If the xml is present we read it, otherwise we consider it empty *) if Sys.file_exists xml_filename then try (* Tc.reset_dict (); *) let xml,use_shapes = read_file_session_and_shapes dir xml_filename in try load_session ~keygen session xml.Xml.content; use_shapes with Sys_error msg -> failwith ("Open session: sys error " ^ msg) with | Sys_error msg -> (* xml does not exist yet *) raise (SessionFileError msg) | Xml.Parse_error s -> Warning.emit "XML database corrupted, ignored (%s)@." s; raise (SessionFileError "XML corrupted") else false in session, use_shapes let read_session = read_session_with_keys ~keygen:(fun ?parent:_ () -> ()) (*******************************) (* Session modification *) (* expansion, add childs, ... *) (*******************************) let rec set_goal_expanded g b = g.goal_expanded <- b; if not b then begin PHstr.iter (fun _ tr -> set_transf_expanded tr b) g.goal_transformations; Mmetas_args.iter (fun _ m -> set_metas_expanded m b) g.goal_metas end and set_transf_expanded tr b = tr.transf_expanded <- b; if not b then List.iter (fun g -> set_goal_expanded g b) tr.transf_goals and set_metas_expanded m b = m.metas_expanded <- b; if not b then set_goal_expanded m.metas_goal b let set_theory_expanded t b = t.theory_expanded <- b; if not b then List.iter (fun th -> set_goal_expanded th b) t.theory_goals let set_file_expanded f b = f.file_expanded <- b; if not b then List.iter (fun th -> set_theory_expanded th b) f.file_theories (* add a why file from a session *) (** Read file and sort theories by location *) let read_file env ?format fn = let theories = Env.read_file Env.base_language env ?format fn in let ltheories = Mstr.fold (fun name th acc -> (* Hack : with WP [name] and [th.Theory.th_name.Ident.id_string] *) let th_name = Ident.id_register (Ident.id_derive name th.Theory.th_name) in match th.Theory.th_name.Ident.id_loc with | Some l -> (l,th_name,th)::acc | None -> (Loc.dummy_position,th_name,th)::acc) theories [] in List.sort (fun (l1,_,_) (l2,_,_) -> Loc.compare l1 l2) ltheories,theories let add_file ~keygen env ?format filename = let version = env.session.session_shape_version in let add_goal parent (acc,n) goal = let g = let name,expl,task = Termcode.goal_expl_task ~root:true goal in raw_add_task ~version ~keygen ~expanded:true parent name n expl task in (g::acc,n+1) in let add_theory acc rfile thname theory = let checksum = None (* Some (Tc.theory_checksum theory) *) in let rtheory = raw_add_theory ~keygen ~expanded:true ~checksum rfile thname in let parent = Parent_theory rtheory in let tasks = List.rev (Task.split_theory theory None None) in let goals = fst (List.fold_left (add_goal parent) ([],1) tasks) in rtheory.theory_goals <- List.rev goals; rtheory.theory_verified <- theory_verified rtheory; rtheory.theory_task <- Some theory; rtheory::acc in let add_file session f_name fmt ordered_theories = let rfile = raw_add_file ~keygen ~expanded:true session f_name fmt in let theories = List.fold_left (fun acc (_,thname,th) -> add_theory acc rfile thname th) [] ordered_theories in rfile.file_theories <- List.rev theories; rfile in let fname = Filename.concat env.session.session_dir filename in Debug.dprintf debug "[Session] read file@\n"; let ordered_theories,theories = read_file env.env ?format fname in Debug.dprintf debug "[Session] create tasks@\n"; let file = add_file env.session filename format ordered_theories in let fname = Filename.basename (Filename.chop_extension filename) in env.files <- Mstr.add fname theories env.files; file.file_for_recovery <- Some theories; check_file_verified notify file; file let remove_file file = let s = file.file_parent in PHstr.remove s.session_files file.file_name (***************************) (* transformations *) (***************************) let add_transformation ?(init=notify) ?(notify=notify) ~keygen env_session transfn g goals = let rtransf = raw_add_transformation ~keygen ~expanded:true g transfn in let parent = Parent_transf rtransf in let i = ref 0 in let parent_goal_name = g.goal_name.Ident.id_string in let next_subgoal task = incr i; let gid,expl,_ = Termcode.goal_expl_task ~root:false task in (* Format.eprintf "parent_goal_name = %s@." parent_goal_name; *) let goal_name = (* if expl = "" then *)parent_goal_name ^ "." ^ string_of_int !i (* else string_of_int !i ^ ". " ^ expl *) in let goal_name = Ident.id_register (Ident.id_derive goal_name gid) in (* Format.eprintf "goal_name = %s@." goal_name.Ident.id_string; *) goal_name, expl, task in let add_goal (acc,n) g = let name,expl,task = next_subgoal g in (* Format.eprintf "call raw_add_task with name = %s@." name.Ident.id_string; *) let g = raw_add_task ~version:env_session.session.session_shape_version ~keygen ~expanded:false parent name n expl task in (g::acc,n+1) in let goals = fst (List.fold_left add_goal ([],1) goals) in rtransf.transf_goals <- List.rev goals; rtransf.transf_verified <- transf_verified rtransf; init (Transf rtransf); check_goal_proved notify g; rtransf let remove_transformation ?(notify=notify) t = let g = t.transf_parent in PHstr.remove g.goal_transformations t.transf_name; check_goal_proved notify g let add_registered_transformation ~keygen env_session tr_name g = try Hstr.find g.goal_transformations tr_name with Not_found -> let task = goal_task g in let subgoals = Trans.apply_transform tr_name env_session.env task in add_transformation ~keygen env_session tr_name g subgoals (****************) (** metas *) (****************) (* dead code let task_nb_decl task = Task.task_fold (fun n tdecl -> match tdecl.td_node with Decl _ -> n+1 | _ -> n) 0 task *) let pos_of_metas lms = let restore_path id = let lib,th,qua = Theory.restore_path id in { ip_library = lib; ip_theory = th; ip_qualid = qua } in let add_ts idpos ts = if Mts.mem ts idpos.idpos_ts then idpos else {idpos with idpos_ts = Mts.add ts (restore_path ts.ts_name) idpos.idpos_ts } in let add_ls idpos ls = if Mls.mem ls idpos.idpos_ls then idpos else {idpos with idpos_ls = Mls.add ls (restore_path ls.ls_name) idpos.idpos_ls } in let add_pr idpos pr = if Mpr.mem pr idpos.idpos_pr then idpos else {idpos with idpos_pr = Mpr.add pr (restore_path pr.pr_name) idpos.idpos_pr } in let look_for_ident idpos = function | MAty ty -> ty_s_fold add_ts idpos ty | MAts ts -> add_ts idpos ts | MAls ls -> add_ls idpos ls | MApr pr -> add_pr idpos pr | MAstr _ | MAint _ -> idpos in List.fold_left (fun idpos (_,args) -> List.fold_left look_for_ident idpos args) empty_idpos lms let add_registered_metas ~keygen env added0 g = let added = List.fold_left (fun ma (s,l) -> Mstr.change (function | None -> Some (Smeta_args.singleton l) | Some std -> Some (Smeta_args.add l std)) s ma) Mstr.empty added0 in match Mmetas_args.find_opt added g.goal_metas with | Some metas -> metas | None -> let goal,task0 = Task.task_separate_goal (goal_task g) in let add_meta task (s,l) = let m = Theory.lookup_meta s in Task.add_meta task m l in (* add before the goal *) let task = List.fold_left add_meta task0 added0 in let task = add_tdecl task goal in let idpos = pos_of_metas added0 in let metas = raw_add_metas ~keygen ~expanded:true g added idpos in let goal = raw_add_task ~version:env.session.session_shape_version ~keygen ~expanded:true (Parent_metas metas) g.goal_name 1 (goal_expl_lazy g) task in metas.metas_goal <- goal; metas let remove_metas ?(notify=notify) m = let g = m.metas_parent in g.goal_metas <- Mmetas_args.remove m.metas_added g.goal_metas; check_goal_proved notify g (*****************************************************) (** Prover Loaded **) (*****************************************************) let load_prover eS prover = try PHprover.find eS.loaded_provers prover with Not_found -> let provers = Whyconf.get_provers eS.whyconf in let r = Mprover.find_opt prover provers in let r = match r with | None -> None | Some pr -> let dr = Whyconf.load_driver (Whyconf.get_main eS.whyconf) eS.env pr.Whyconf.driver pr.Whyconf.extra_drivers in Some { prover_config = pr; prover_driver = dr} in PHprover.add eS.loaded_provers prover r; r let unload_provers eS = PHprover.clear eS.loaded_provers let ft_of_th th = let fn = Filename.basename th.theory_parent.file_name in let fn = try Filename.chop_extension fn with Invalid_argument _ -> fn in (fn, th.theory_name.Ident.id_string) let rec ft_of_goal g = match g.goal_parent with | Parent_transf tr -> ft_of_goal tr.transf_parent | Parent_metas ms -> ft_of_goal ms.metas_parent | Parent_theory th -> ft_of_th th let ft_of_pa a = ft_of_goal a.proof_parent (** TODO see with Undone Edited But since it will be perhaps removed... *) let copy_external_proof ?notify ~keygen ?obsolete ?archived ?limit ?edit ?goal ?prover ?attempt_status ?env_session ?session a = let session = match env_session with | Some eS -> Some eS.session | _ -> session in let obsolete = Opt.get_def a.proof_obsolete obsolete in let archived = Opt.get_def a.proof_archived archived in let limit = Opt.get_def a.proof_limit limit in let pas = Opt.get_def a.proof_state attempt_status in let ngoal = Opt.get_def a.proof_parent goal in let nprover = match prover with | None -> a.proof_prover | Some prover -> prover in (* copy or generate the edit file if needed *) let edit = match edit, a.proof_edited_as, session with | Some edit, _, _ -> edit | _, None, _ -> None | _, _, None -> (* In the other case a session is needed *) None | _, Some file, Some session -> assert (file != ""); (* Copy the edited file *) let dir = session.session_dir in let file = Filename.concat dir file in if not (Sys.file_exists file) then None else match prover,goal, ngoal.goal_task, env_session with | None,None,_,_ -> let dst_file = Sysutil.uniquify file in Sysutil.copy_file file dst_file; let dst_file = Sysutil.relativize_filename dir dst_file in Some dst_file | (_, _, None,_)| (_, _, _, None) -> (* In the other cases an env_session and a task are needed *) None | _, _, Some task, Some env_session -> match load_prover env_session nprover with | None -> None | Some prover_conf -> let (fn,tn) = ft_of_goal ngoal in let driver = prover_conf.prover_driver in let dst_file = Driver.file_of_task driver fn tn task in let dst_file = Filename.concat dir dst_file in let dst_file = Sysutil.uniquify dst_file in let old = open_in file in let ch = open_out dst_file in let fmt = formatter_of_out_channel ch in Driver.print_task ~old driver fmt task; close_in old; close_out ch; let dst_file = Sysutil.relativize_filename dir dst_file in Some (dst_file) in add_external_proof ?notify ~keygen ~obsolete ~archived ~limit ~edit ngoal nprover pas exception UnloadableProver of Whyconf.prover let update_edit_external_proof ~cntexample env_session a = let prover_conf = match load_prover env_session a.proof_prover with | Some prover_conf -> prover_conf | None -> raise (UnloadableProver a.proof_prover) in let driver = prover_conf.prover_driver in let goal = goal_task a.proof_parent in let session_dir = env_session.session.session_dir in let file = match a.proof_edited_as with | None -> let (fn,tn) = ft_of_pa a in let file = Driver.file_of_task driver fn tn goal in let file = Filename.concat session_dir file in let file = Sysutil.uniquify file in let file = Sysutil.relativize_filename session_dir file in set_edited_as (Some file) a; if a.proof_state = Unedited then set_proof_state ~notify ~obsolete:a.proof_obsolete ~archived:a.proof_archived Interrupted a; file | Some f -> f in let file = Filename.concat session_dir file in let old = if Sys.file_exists file then begin let backup = file ^ ".bak" in if Sys.file_exists backup then Sys.remove backup; Sys.rename file backup; Some(open_in backup) end else None in let ch = open_out file in let fmt = formatter_of_out_channel ch in Driver.print_task ~cntexample ?old driver fmt goal; Opt.iter close_in old; close_out ch; file let print_attempt_status fmt = function | Scheduled | Running -> pp_print_string fmt "Running" | JustEdited | Interrupted -> pp_print_string fmt "Not yet run" | Unedited -> pp_print_string fmt "Not yet edited" | Done pr -> Call_provers.print_prover_result fmt pr | InternalFailure _ -> pp_print_string fmt "Failure" let print_external_proof fmt p = fprintf fmt "%a - %a (%i, %i, %i)%s%s%s" Whyconf.print_prover p.proof_prover print_attempt_status p.proof_state (p.proof_limit.Call_provers.limit_time) (p.proof_limit.Call_provers.limit_steps) (p.proof_limit.Call_provers.limit_mem) (if p.proof_obsolete then " obsolete" else "") (if p.proof_archived then " archived" else "") (if p.proof_edited_as <> None then " edited" else "") (***********************************************************) (** Reload a session with the current transformation *) (***********************************************************) (** Pairing *) module Goal = struct type 'a t = 'a goal let checksum g = g.goal_checksum let shape g = g.goal_shape let name g = g.goal_name end module AssoGoals = Tc.Pairing(Goal)(Goal) (**********************************) (* merge a file into another *) (**********************************) (* the import_* functions can be used to copy session items from one 'b session into another 'b session. The two sessions will have different keys. This is different from the copy_* functions where we have 'a = 'b. Most import functions import the entire subtree, but do not include the subtree into the parent. For example, [import_theory keygen file theory] will return a new theory whose parent is [file], but it will not modify [file.file_theories] to contain the new theory. This is left to the caller. An exception to this rule is [import_proof_attempt], because of its usage of [add_external_proof]. *) let rec import_theory ~keygen file th = let new_th = raw_add_theory ~keygen ~expanded:th.theory_expanded ~checksum:th.theory_checksum file th.theory_name in let goals = List.map (import_goal ~keygen (Parent_theory new_th)) th.theory_goals in new_th.theory_goals <- goals; new_th and import_goal ~keygen parent g = let new_goal = raw_add_no_task ~keygen ~expanded:g.goal_expanded parent g.goal_name g.goal_number g.goal_expl g.goal_checksum g.goal_shape in PHprover.iter (fun _ v -> import_proof_attempt ~keygen new_goal v) g.goal_external_proofs; PHstr.iter (fun k v -> let tf = import_transf ~keygen new_goal v in PHstr.add new_goal.goal_transformations k tf) g.goal_transformations; new_goal and import_proof_attempt ~keygen goal pa = ignore (add_external_proof ~keygen ~obsolete:pa.proof_obsolete ~archived:pa.proof_archived ~limit:pa.proof_limit ~edit:pa.proof_edited_as goal pa.proof_prover pa.proof_state) and import_transf ~keygen goal tf = let new_tf = raw_add_transformation ~keygen ~expanded:tf.transf_expanded goal tf.transf_name in let goals = List.map (import_goal ~keygen (Parent_transf new_tf)) tf.transf_goals in new_tf.transf_goals <- goals; new_tf let found_obsolete = ref false let found_missed_goals = ref false let found_missed_goals_in_theory = ref false let merge_proof ~keygen obsolete to_goal _ from_proof = let obsolete = obsolete || from_proof.proof_obsolete in found_obsolete := obsolete || ! found_obsolete; ignore (add_external_proof ~keygen ~obsolete ~archived:from_proof.proof_archived ~limit:from_proof.proof_limit ~edit:from_proof.proof_edited_as to_goal from_proof.proof_prover from_proof.proof_state) (* dead code exception MalformedMetas of ident_path *) exception Ts_not_found of tysymbol exception Ls_not_found of lsymbol exception Pr_not_found of prsymbol let merge_metas_in_task ~theories env task from_metas = (* Find in the new task the new symbol (ts,ls,pr) *) (* We order the position bottom up and find the ident as we go through the task *) (* hashtbl that will contain the conversion *) let hts = Hts.create 4 in let hls = Hls.create 4 in let hpr = Hpr.create 10 in let obsolete = ref false in let read_theory ip = if ip.ip_library = [] then Mstr.find ip.ip_theory theories else Env.read_theory env.env ip.ip_library ip.ip_theory in let to_idpos_ts = Mts.fold_left (fun idpos_ts from_ts ip -> try let th = read_theory ip in let to_ts = ns_find_ts th.th_export ip.ip_qualid in Hts.add hts from_ts to_ts; Mts.add to_ts ip idpos_ts with e -> Debug.dprintf debug "[merge metas]@ can't@ find@ ident@ %a@ because@ %a@\n" print_ident_path ip Exn_printer.exn_printer e; idpos_ts ) Mts.empty from_metas.metas_idpos.idpos_ts in let to_idpos_ls = Mls.fold_left (fun idpos_ls from_ls ip -> try let th = read_theory ip in let to_ls = ns_find_ls th.th_export ip.ip_qualid in Hls.add hls from_ls to_ls; Mls.add to_ls ip idpos_ls with e -> Debug.dprintf debug "[merge metas]@ can't@ find@ ident@ %a@ because@ %a@\n" print_ident_path ip Exn_printer.exn_printer e; idpos_ls ) Mls.empty from_metas.metas_idpos.idpos_ls in let to_idpos_pr = Mpr.fold_left (fun idpos_pr from_pr ip -> try let th = read_theory ip in let to_pr = ns_find_pr th.th_export ip.ip_qualid in Hpr.add hpr from_pr to_pr; Mpr.add to_pr ip idpos_pr with e -> Debug.dprintf debug "[merge metas]@ can't@ find@ ident@ %a@ because@ %a" print_ident_path ip Exn_printer.exn_printer e; idpos_pr ) Mpr.empty from_metas.metas_idpos.idpos_pr in let to_idpos = {idpos_ts = to_idpos_ts; idpos_ls = to_idpos_ls; idpos_pr = to_idpos_pr; } in let print_meta fmt (meta_name,meta_args) = fprintf fmt "%s %a" meta_name (Pp.print_list Pp.space Pretty.print_meta_arg) meta_args in (* Now convert the metas to the new symbol *) let add_meta ((metas,task) as acc) meta_name meta_args = let conv_ts ts = Hts.find_exn hts (Ts_not_found ts) ts in let conv_ls ls = Hls.find_exn hls (Ls_not_found ls) ls in let conv_pr pr = Hpr.find_exn hpr (Pr_not_found pr) pr in let map = function | MAty ty -> MAty (Ty.ty_s_map conv_ts ty) | MAts ts -> MAts (conv_ts ts) | MAls ls -> MAls (conv_ls ls) | MApr pr -> MApr (conv_pr pr) | (MAstr _ | MAint _) as m -> m in try let meta = Theory.lookup_meta meta_name in let smeta_args,task = Smeta_args.fold_left (fun ((smeta_args,task) as acc) meta_args -> try let meta_args = List.map map meta_args in Smeta_args.add meta_args smeta_args, Task.add_meta task meta meta_args with | Ts_not_found ts -> obsolete := true; let pos = Mts.find ts from_metas.metas_idpos.idpos_ts in Debug.dprintf debug "Remove the meta %a during merge because \ the type symbol %a can't be found@\n" print_meta (meta_name,meta_args) print_ident_path pos; acc | Ls_not_found ls -> obsolete := true; let pos = Mls.find ls from_metas.metas_idpos.idpos_ls in Debug.dprintf debug "Remove the meta %a during merge because \ the logic symbol %a can't be found@\n" print_meta (meta_name,meta_args) print_ident_path pos; acc | Pr_not_found pr -> obsolete := true; let pos = Mpr.find pr from_metas.metas_idpos.idpos_pr in Debug.dprintf debug "Remove the meta %a during merge because \ the proposition symbol %a can't be found@\n" print_meta (meta_name,meta_args) print_ident_path pos; acc ) (Smeta_args.empty,task) meta_args in (Mstr.add meta_name smeta_args metas,task) with | Theory.UnknownMeta s -> Debug.dprintf debug "Remove a meta during merge: meta %s unknown@\n" s; acc in let goal,task = Task.task_separate_goal task in let metas,task = Mstr.fold_left add_meta (Mstr.empty,task) from_metas.metas_added in Task.add_tdecl task goal,metas,to_idpos,!obsolete (** Release and recover goal task *) let release_task g = Debug.dprintf debug "[Session] release %s@." g.goal_name.id_string; g.goal_task <- None let rec release_sub_tasks g = release_task g; PHstr.iter (fun _ t -> List.iter release_sub_tasks t.transf_goals) g.goal_transformations; Mmetas_args.iter (fun _ t -> release_sub_tasks t.metas_goal) g.goal_metas exception UnrecoverableTask of Ident.ident type 'key update_context = { allow_obsolete_goals : bool; release_tasks : bool; use_shapes_for_pairing_sub_goals : bool; keygen : 'key keygen; keep_unmatched_theories : bool; } let mk_update_context ?(allow_obsolete_goals=false) ?(release_tasks=false) ?(use_shapes_for_pairing_sub_goals=false) ?(keep_unmatched_theories=false) keygen = { allow_obsolete_goals; release_tasks; use_shapes_for_pairing_sub_goals; keygen; keep_unmatched_theories; } let rec recover_sub_tasks ~theories env_session task g = g.goal_task <- Some task; (* Check that the sum and shape don't change (the order is kept) It seems an acceptable limitation. Non-deterministic transformation seems ugly. *) let version = env_session.session.session_shape_version in let sum = Termcode.task_checksum ~version task in let expl = goal_expl_lazy g in let shape = Termcode.t_shape_task ~version ~expl task in if not ((match g.goal_checksum with | None -> false | Some s -> Termcode.equal_checksum sum s) && Termcode.equal_shape shape g.goal_shape) then raise (UnrecoverableTask g.goal_name); PHstr.iter (fun _ t -> let task = goal_task g in let subgoals = Trans.apply_transform t.transf_name env_session.env task in List.iter2 (recover_sub_tasks ~theories env_session) subgoals t.transf_goals) g.goal_transformations; Mmetas_args.iter (fun _ t -> let task,_metas,_to_idpos,_obsolete = merge_metas_in_task ~theories env_session task t in (* It is better to keep the original metas and idpos *) (* If it is obsolete the next task will see it *) recover_sub_tasks ~theories env_session task t.metas_goal ) g.goal_metas let recover_theory_tasks env_session th = let theories = Opt.get_exn NoTask th.theory_parent.file_for_recovery in let theory = Opt.get_exn NoTask th.theory_task in th.theory_checksum <- None (* Some (Tc.theory_checksum theory) *); let tasks = List.rev (Task.split_theory theory None None) in List.iter2 (recover_sub_tasks ~theories env_session) tasks th.theory_goals let rec theory_goal g = match g.goal_parent with | Parent_theory th -> th | Parent_transf t -> theory_goal t.transf_parent | Parent_metas t -> theory_goal t.metas_parent let goal_task_or_recover env_session g = match g.goal_task with | Some task -> task | None -> recover_theory_tasks env_session (theory_goal g); Opt.get g.goal_task (** merge session *) (** ~theories is the current theory library path empty : [] *) let rec merge_any_goal ~ctxt ~theories env obsolete from_goal to_goal = set_goal_expanded to_goal from_goal.goal_expanded; PHprover.iter (merge_proof ~keygen:ctxt.keygen obsolete to_goal) from_goal.goal_external_proofs; PHstr.iter (merge_trans ~ctxt ~theories env to_goal) from_goal.goal_transformations; Mmetas_args.iter (merge_metas ~ctxt ~theories env to_goal) from_goal.goal_metas and merge_trans ~ctxt ~theories env to_goal _ from_transf = try let from_transf_name = from_transf.transf_name in let to_goal_name = to_goal.goal_name in Debug.dprintf debug "[Reload] transformation %s for goal %s @\n" from_transf_name to_goal_name.Ident.id_string; let to_transf = try add_registered_transformation ~keygen:ctxt.keygen env from_transf_name to_goal with exn when not (Debug.test_flag Debug.stack_trace) -> Debug.dprintf debug "[Reload] transformation %s produce an error:%a" from_transf_name Exn_printer.exn_printer exn; raise Exit in set_transf_expanded to_transf from_transf.transf_expanded; let associated,detached = Debug.dprintf debug "[Info] associate_subgoals, shape_version = %d@\n" env.session.session_shape_version; AssoGoals.associate ~use_shapes:ctxt.use_shapes_for_pairing_sub_goals from_transf.transf_goals to_transf.transf_goals in List.iter (function | (to_goal, Some (from_goal, obsolete)) -> merge_any_goal ~ctxt ~theories env obsolete from_goal to_goal | (_, None) -> found_missed_goals_in_theory := true) associated; (* TODO: we should copy the goal, using the new type of keys if detached <> [] then to_transf.transf_detached <- Some { detached_goals = detached } *) ignore detached with Exit -> () (* silent failure, not a good thing... *) (** convert the ident from the old task to the ident at the same position in the new task *) and merge_metas_aux ~ctxt ~theories env to_goal _ from_metas = Debug.dprintf debug "[Reload] metas for goal %s@\n" to_goal.goal_name.Ident.id_string; let task,metas,to_idpos,obsolete = merge_metas_in_task ~theories env (goal_task to_goal) from_metas in let to_metas = raw_add_metas ~keygen:ctxt.keygen ~expanded:from_metas.metas_expanded to_goal metas to_idpos in let to_goal = raw_add_task ~version:env.session.session_shape_version ~keygen:ctxt.keygen (Parent_metas to_metas) ~expanded:true to_goal.goal_name 1 (goal_expl_lazy to_goal) task in to_metas.metas_goal <- to_goal; Debug.dprintf debug "[Reload] metas done@\n"; merge_any_goal ~ctxt ~theories env obsolete from_metas.metas_goal to_goal and merge_metas ~ctxt ~theories env to_goal s from_metas = try merge_metas_aux ~ctxt ~theories env to_goal s from_metas with exn -> Debug.dprintf debug "[merge metas] error %a during merge, metas removed@\n" Exn_printer.exn_printer exn exception OutdatedSession let merge_theory ~ctxt ~theories env from_th to_th = found_missed_goals_in_theory := false; set_theory_expanded to_th from_th.theory_expanded; let get_goal_name g = try let (_,_,l) = restore_path g.goal_name in String.concat "." l with Not_found -> g.goal_name.Ident.id_string in let from_goals = List.fold_left (fun from_goals g -> Mstr.add (get_goal_name g) g from_goals) Mstr.empty from_th.theory_goals in Debug.dprintf debug "[Theory checksum] theory %s: old sum = %a, new sum = %a@." to_th.theory_name.id_string (Pp.print_option Tc.print_checksum) from_th.theory_checksum (Pp.print_option Tc.print_checksum) to_th.theory_checksum; List.iter (fun to_goal -> try let to_goal_name = get_goal_name to_goal in let from_goal = Mstr.find to_goal_name from_goals in Debug.dprintf debug "[Goal checksum] goal %s: old sum = %a, new sum = %a@." to_goal_name (Pp.print_option Tc.print_checksum) from_goal.goal_checksum (Pp.print_option Tc.print_checksum) to_goal.goal_checksum; let goal_obsolete = match to_goal.goal_checksum, from_goal.goal_checksum with | None, _ -> assert false | Some _, None -> true | Some s1, Some s2 -> not (Tc.equal_checksum s1 s2) in if goal_obsolete then begin Debug.dprintf debug "[Reload] Goal %s.%s has changed@\n" to_th.theory_name.Ident.id_string to_goal.goal_name.Ident.id_string; if not ctxt.allow_obsolete_goals then raise OutdatedSession; found_obsolete := true; end; merge_any_goal ~ctxt ~theories env goal_obsolete from_goal to_goal; if ctxt.release_tasks then release_sub_tasks to_goal with | Not_found when ctxt.allow_obsolete_goals -> found_missed_goals_in_theory := true; if ctxt.release_tasks then release_sub_tasks to_goal | Not_found -> raise OutdatedSession ) to_th.theory_goals; if not (ctxt.use_shapes_for_pairing_sub_goals || !found_missed_goals_in_theory) then begin Debug.dprintf debug "[Session] since shapes were not used for pairing, we compute the \ checksum of the full theory, to estimate the obsolete status for \ goals.@."; let to_checksum = CombinedTheoryChecksum.compute to_th in let same_checksum = match from_th.theory_checksum with | None -> false | Some c -> Tc.equal_checksum c to_checksum in Debug.dprintf debug "[Session] from_checksum = %a, to_checksum = %a@." (Pp.print_option save_checksum) from_th.theory_checksum save_checksum to_checksum; if same_checksum then (* we set all_goals as non obsolete *) theory_iter_proof_attempt set_non_obsolete to_th end; found_missed_goals := !found_missed_goals || !found_missed_goals_in_theory let merge_file ~ctxt ~theories env from_f to_f = Debug.dprintf debug "[Info] merge_file, shape_version = %d@\n" env.session.session_shape_version; set_file_expanded to_f from_f.file_expanded; let from_theories = List.fold_left (fun acc t -> Mstr.add t.theory_name.Ident.id_string t acc) Mstr.empty from_f.file_theories in let find_remove k map = let elt = Mstr.find k map in let acc = Mstr.remove k map in elt, acc in let remaining_theories = List.fold_left (fun acc to_th -> try let from_th, acc = let name = to_th.theory_name.Ident.id_string in find_remove name acc in merge_theory ~ctxt ~theories env from_th to_th; acc with | Not_found when ctxt.allow_obsolete_goals -> acc | Not_found -> raise OutdatedSession ) from_theories to_f.file_theories in if ctxt.keep_unmatched_theories then Mstr.iter (fun _ v -> to_f.file_theories <- (import_theory ~keygen:ctxt.keygen to_f v) :: to_f.file_theories) remaining_theories; Debug.dprintf debug "[Info] merge_file, done@\n" let rec recompute_all_shapes_goal ~release g = let t = goal_task g in let expl = goal_expl_lazy g in g.goal_shape <- Termcode.t_shape_task ~expl t; g.goal_checksum <- Some (Termcode.task_checksum t); if release then release_task g; iter_goal (fun _pa -> ()) (iter_transf (recompute_all_shapes_goal ~release)) (iter_metas (recompute_all_shapes_goal ~release)) g let recompute_all_shapes_theory ~release t = iter_theory (recompute_all_shapes_goal ~release) t let recompute_all_shapes_file ~release f = iter_file (recompute_all_shapes_theory ~release) f let recompute_all_shapes ~release session = session.session_shape_version <- Termcode.current_shape_version; iter_session (recompute_all_shapes_file ~release) session let update_session ~ctxt old_session env whyconf = Debug.dprintf debug "[Info] update_session: shape_version = %d@\n" old_session.session_shape_version; (* AssoGoals.set_use_shapes ctxt.use_shapes_for_pairing_sub_goals; *) let new_session = create_session ~shape_version:old_session.session_shape_version old_session.session_dir in let new_session = { new_session with session_prover_ids = old_session.session_prover_ids } in let will_recompute_shape = old_session.session_shape_version <> Termcode.current_shape_version in let new_env_session = { session = new_session; env = env; whyconf = whyconf; files = Mstr.empty; loaded_provers = PHprover.create 5; } in found_obsolete := false; found_missed_goals := false; let files = PHstr.fold (fun _ old_file acc -> Debug.dprintf debug "[Load] file '%s'@\n" old_file.file_name; let new_file = add_file ~keygen:ctxt.keygen new_env_session ?format:old_file.file_format old_file.file_name in let theories = Opt.get new_file.file_for_recovery in Debug.dprintf debug "[Merge] file '%s'@\n" old_file.file_name; let ctxt = { ctxt with release_tasks = ctxt.release_tasks && (not will_recompute_shape) } in merge_file ~ctxt ~theories new_env_session old_file new_file; let fname = Filename.basename (Filename.chop_extension old_file.file_name) in Mstr.add fname theories acc) old_session.session_files Mstr.empty in new_env_session.files <- files; Debug.dprintf debug "[Info] update_session: done@\n"; let obsolete = if will_recompute_shape then begin Debug.dprintf debug "[Info] update_session: recompute shapes@\n"; recompute_all_shapes ~release:ctxt.release_tasks new_session; true end else !found_obsolete in assert (new_env_session.session.session_shape_version = Termcode.current_shape_version); new_env_session, obsolete, !found_missed_goals (** Copy/Paste *) let rec copy_goal parent from_g = let to_g = { from_g with goal_parent = parent; goal_external_proofs = PHprover.create (PHprover.length from_g.goal_external_proofs); goal_transformations = PHstr.create (PHstr.length from_g.goal_transformations); goal_metas = Mmetas_args.empty; } in PHprover.iter (fun k p -> PHprover.add to_g.goal_external_proofs k (copy_proof to_g p)) from_g.goal_external_proofs; PHstr.iter (fun k t -> PHstr.add to_g.goal_transformations k (copy_transf to_g t)) from_g.goal_transformations; to_g.goal_metas <- Mmetas_args.map (fun m -> copy_metas to_g m) from_g.goal_metas; to_g and copy_proof to_goal from_pa = { from_pa with proof_parent = to_goal} and copy_transf to_goal from_transf = let to_transf = { from_transf with transf_parent = to_goal; transf_goals = [] } in to_transf.transf_goals <- List.map (copy_goal (Parent_transf from_transf)) from_transf.transf_goals; to_transf and copy_metas to_goal from_metas = let to_metas = { from_metas with metas_goal = to_goal; } in to_metas.metas_goal <- copy_goal (Parent_metas to_metas) from_metas.metas_goal; to_metas let copy_proof from_p = copy_proof from_p.proof_parent from_p let copy_transf from_t = copy_transf from_t.transf_parent from_t let copy_metas from_m = copy_metas from_m.metas_parent from_m exception Paste_error let rec add_goal_to_parent ~keygen env from_goal to_goal = set_goal_expanded to_goal from_goal.goal_expanded; PHprover.iter (fun _ pa -> ignore (add_proof_to_goal ~keygen env to_goal pa)) from_goal.goal_external_proofs; PHstr.iter (fun _ t -> ignore (add_transf_to_goal ~keygen env to_goal t)) from_goal.goal_transformations; Mmetas_args.iter (fun _ m -> ignore (add_metas_to_goal ~keygen env to_goal m)) from_goal.goal_metas (** This function is the main difference with merge_metas_aux. It use directly the metas doesn't convert them. *) and add_metas_to_goal ~keygen env to_goal from_metas = let to_metas = raw_add_metas ~keygen ~expanded:from_metas.metas_expanded to_goal from_metas.metas_added from_metas.metas_idpos in let goal,task0 = Task.task_separate_goal (goal_task to_goal) in (* add before the goal *) let task = try Mstr.fold_left (fun task name s -> let m = Theory.lookup_meta name in Smeta_args.fold_left (fun task l -> Task.add_meta task m l) (* TODO: try with *) task s) task0 from_metas.metas_added with exn -> Debug.dprintf debug "[Paste] addition of metas produces an error:%a" Exn_printer.exn_printer exn; raise Paste_error in let task = add_tdecl task goal in let to_goal = raw_add_task ~version:env.session.session_shape_version ~keygen ~expanded:true (Parent_metas to_metas) from_metas.metas_goal.goal_name 1 (goal_expl_lazy from_metas.metas_goal) task in to_metas.metas_goal <- to_goal; add_goal_to_parent ~keygen env from_metas.metas_goal to_goal; to_metas and add_proof_to_goal ~keygen env to_goal from_proof_attempt = copy_external_proof ~keygen ~obsolete:true ~env_session:env ~goal:to_goal from_proof_attempt and add_transf_to_goal ~keygen env to_goal from_transf = let from_transf_name = from_transf.transf_name in let to_goal_name = to_goal.goal_name in Debug.dprintf debug "[Paste] transformation %s for goal %s @\n" from_transf_name to_goal_name.Ident.id_string; let to_transf = try add_registered_transformation ~keygen env from_transf_name to_goal with exn when not (Debug.test_flag Debug.stack_trace) -> Debug.dprintf debug "[Paste] transformation %s produce an error:%a" from_transf_name Exn_printer.exn_printer exn; raise Paste_error in let associated,detached = Debug.dprintf debug "[Info] associate_subgoals, shape_version = %d@\n" env.session.session_shape_version; AssoGoals.associate ~use_shapes:false from_transf.transf_goals to_transf.transf_goals in List.iter (function | (to_goal, Some (from_goal, _obsolete)) -> add_goal_to_parent ~keygen env from_goal to_goal | (_, None) -> () ) associated; (* if detached <> [] then to_transf.transf_detached <- Some { detached_goals = detached }; *) ignore(detached); to_transf let get_project_dir fname = if not (Sys.file_exists fname) then raise Not_found; let d = if Sys.is_directory fname then fname else if Filename.basename fname = db_filename then begin Debug.dprintf debug "Info: found db file '%s'@." fname; Filename.dirname fname end else begin Debug.dprintf debug "Info: found regular file '%s'@." fname; try Filename.chop_extension fname with Invalid_argument _ -> fname^".w3s" end in Debug.dprintf debug "Info: using '%s' as directory for the project@." d; d let key_any = function | File p -> p.file_key | Transf tr -> tr.transf_key | Goal g -> g.goal_key | Proof_attempt p -> p.proof_key | Theory th -> th.theory_key | Metas ms -> ms.metas_key let () = Exn_printer.register (fun fmt exn -> match exn with | NoTask -> Format.fprintf fmt "A goal doesn't contain a task but here it needs one" | OutdatedSession -> Format.fprintf fmt "The session@ is@ outdated@ (not@ in@ sync@ with@ the@ current@ \ file).@ In@ this@ configuration@ it@ is@ forbidden." | UnrecoverableTask id -> Format.fprintf fmt "A@ non-deterministic@ transformation@ is@ used,@ the@ task@ of@ \ the@ goal@ %s@ can't@ be@ recovered." id.id_string | _ -> raise exn) (* Local Variables: compile-command: "unset LANG; make -C ../.. bin/why3ide.byte" End: *) why3-0.88.3/src/session/session_scheduler.mli0000664000175100017510000002663113225666037021762 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** Scheduling operations on sessions and calls to provers *) (** {2 One module for calling callback when it's time to} *) module Todo : sig type ('a,'b) todo val create : 'a -> ('a -> 'b -> 'a) -> ('a -> unit) -> ('a,'b) todo (** create init step callback *) val start : ('a,'b) todo -> unit (** one task is started *) val stop : ('a,'b) todo -> unit (** one task is stopped without information *) val _done : ('a,'b) todo -> 'b -> unit (** one task is stopped with information *) end open Session (** {2 Observers signature} *) module type OBSERVER = sig type key (** type key allowing to uniquely identify an element of of session: a goal, a transformation, a proof attempt, a theory or a file. See type [any] below *) val create: ?parent:key -> unit -> key (** returns a fresh key, a new child of the given parent if any *) val remove: key -> unit (** removes a key *) val reset: unit -> unit (** deletes all keys *) val timeout: ms:int -> (unit -> bool) -> unit (** a handler for functions that must be called after a given time elapsed, in milliseconds. When the given function returns true, it must be rescheduled *) val idle: (unit -> bool) -> unit (** a handler for a delayed function, that can be called when there is nothing else to do. When the given function returns true, it must be rescheduled *) val notify_timer_state : int -> int -> int -> unit (** this function is called when timer state changes. The first arg is the number of tasks waiting. The second arg is the number of scheduled proof tasks. The third arg is the number of running proof tasks *) val init : key -> key any -> unit (** run after the creation *) val notify : key any -> unit (** notify modification of node of the session *) val uninstalled_prover : key env_session -> Whyconf.prover -> Whyconf.prover_upgrade_policy (** When a prover must be called on a task but it is currently not installed, what policy to apply *) end (** {2 Main functor} *) module Make(O: OBSERVER) : sig (** A session, with the environment, and the configuration *) (** {2 Scheduler} *) type t (** the scheduler environment *) val set_maximum_running_proofs : int -> t -> unit val init : int -> t (** [init max] *) (* used by why3session_run, but it should not as it is a low-level scheduler function *) val schedule_any_timeout: t -> (unit -> bool) -> unit (** run it when an action slot/worker/cpu is available. Reschedule it if it return true *) (** {2 Save and load a state} *) val update_session : allow_obsolete:bool -> release:bool -> use_shapes:bool -> 'oldkey session -> Env.env -> Whyconf.config -> O.key env_session * bool * bool (** Same as {!Session.update_session} except initialization is done. *) val add_file : O.key env_session -> ?format:string -> string -> O.key Session.file (** [add_file es f] adds the file with filename [f] in the proof session, the file name must be given relatively to the session dir given to [open_session] *) (** {2 Actions} *) val run_prover : O.key env_session -> t -> context_unproved_goals_only:bool -> cntexample : bool -> limit : Call_provers.resource_limit -> Whyconf.prover -> O.key any -> unit (** [run_prover es sched p a] runs prover [p] on all goals under [a] the proof attempts are only scheduled for running, and they will be started asynchronously when processors are available. ~context_unproved_goals_only indicates if prover must be run on already proved goals or not ~cntexample indicates if prover should be asked to get counter-example model *) val run_external_proof : O.key env_session -> t -> ?cntexample : bool -> ?callback:(O.key proof_attempt -> proof_attempt_status -> unit) -> O.key proof_attempt -> unit (** [run_external_proof es sched ?cntexample ?callback p] reruns an existing proof attempt [p] ~cntexample indicates if prover should be asked to get counter-example model *) type run_external_status = | Starting | MissingProver | MissingFile of string | StatusChange of proof_attempt_status val run_external_proof_v3 : use_steps:bool -> O.key Session.env_session -> t -> O.key Session.proof_attempt -> ?cntexample : bool -> (O.key Session.proof_attempt -> Whyconf.prover -> Call_provers.resource_limit -> Call_provers.prover_result option -> run_external_status -> unit) -> unit (** [run_external_proof_v3 env_session sched pa ?cntexample callback] the callback is applied with [callback pa p limits old_result status]. run_external_proof_v3 don't change the existing proof attempt just can add new by O.uninstalled_prover. Be aware since the session is not modified there is no test to see if the proof_attempt had already been started ?cntexample indicates if prover should be asked to get counter-example model *) val prover_on_goal : O.key env_session -> t -> ?callback:(O.key proof_attempt -> proof_attempt_status -> unit) -> ?cntexample : bool -> limit : Call_provers.resource_limit -> Whyconf.prover -> O.key goal -> unit (** [prover_on_goal es sched ?cntexample ?timelimit p g] same as {!redo_external_proof} but creates or reuses existing proof_attempt ?cntexample indicates if prover should be asked to get counter-example model *) val cancel_scheduled_proofs : t -> unit (** cancels all currently scheduled proof attempts. note that the already running proof attempts are not stopped, the corresponding processes must terminate by their own. *) val transform_goal : O.key env_session -> t -> ?keep_dumb_transformation:bool -> ?callback:(O.key transf option -> unit) -> string -> O.key goal -> unit (** [transform es sched tr g] applies registered transformation [tr] on the given goal. If [keep_dumb_transformation] is false (default) and the transformation gives one task equal to [g] the transformation is not added (the callback is called with None). Otherwise the transformation is added and given to the callback. *) val transform : O.key env_session -> t -> context_unproved_goals_only:bool -> ?callback:(O.key transf option -> unit) -> string -> O.key any -> unit (** [transform es sched tr a] applies registered transformation [tr] on all leaf goals under [a]. [~context_unproved_goals_only] indicates if the transformation must be applied also on alreadt proved goals *) val edit_proof : cntexample:bool -> O.key env_session -> t -> default_editor:string -> O.key proof_attempt -> unit (** edits the given proof attempt using the appropriate editor *) val edit_proof_v3 : cntexample:bool -> O.key env_session -> t -> default_editor:string -> callback:(O.key Session.proof_attempt -> unit) -> O.key proof_attempt -> unit (** edits the given proof attempt using the appropriate editor but don't modify the session *) val cancel : O.key any -> unit (** [cancel a] marks all proofs under [a] as obsolete *) val remove_proof_attempt : O.key proof_attempt -> unit val remove_transformation : O.key transf -> unit val remove_metas : O.key metas -> unit val set_archive : O.key proof_attempt -> bool -> unit val clean : O.key any -> unit (** [clean a] removes failed attempts below [a] where there at least one successful attempt or transformation *) type report = | Result of Call_provers.prover_result * Call_provers.prover_result (** Result(new_result,old_result) *) | CallFailed of exn | Prover_not_installed | Edited_file_absent of string | No_former_result of Call_provers.prover_result val replay : O.key env_session -> t -> obsolete_only:bool -> context_unproved_goals_only:bool -> O.key any -> unit (** [replay es sched ~obsolete_only ~context_unproved_goals_only a] reruns proofs under [a] if [obsolete_only] is set then does not rerun non-obsolete proofs if [context_unproved_goals_only] is set then only rerun proofs whose previous answer was 'valid' *) val check_all: ?release:bool -> (** Can all the goals be released at the end? def: false *) use_steps:bool -> (** Replay use recorded number of proof steps *) ?filter:(O.key proof_attempt -> bool) -> O.key env_session -> t -> callback: ((Ident.ident * Whyconf.prover * Call_provers.resource_limit * report) list -> unit) -> unit (** [check_all session callback] reruns all the proofs of the session, and reports for all proofs the current result and the new one (does not change the session state). When finished, calls the callback with the reports which are 4-uples [(goal name, prover, limits, report)] *) val play_all : O.key env_session -> t -> callback:(unit-> unit) -> limit:Call_provers.resource_limit -> Whyconf.prover list -> unit (** [play_all es sched l] runs every prover of list [l] on all goals and sub-goals of the session, with the given time limit. [callback] is called when all tasks are finished. Useful for benchmarking provers *) val schedule_proof_attempt: cntexample:bool -> limit:Call_provers.resource_limit -> ?old:string -> inplace:bool -> command:string -> driver:Driver.driver -> callback:(Session.proof_attempt_status -> unit) -> t -> Task.task -> unit val convert_unknown_prover : O.key env_session -> unit (** Same as {!Session_tools.convert_unknown_prover} *) val run_strategy_on_goal: ?intermediate_callback: (unit -> unit) -> ?final_callback: (unit -> unit) -> O.key Session.env_session -> t -> Strategy.t -> O.key Session.goal -> unit val run_strategy: O.key Session.env_session -> t -> context_unproved_goals_only:bool -> Strategy.t -> O.key Session.any -> unit end (** A functor (a state is hidden) that provide a working scheduler and which can be used as base for an OBSERVER *) module Base_scheduler (X : sig end) : sig val timeout: ms:int -> (unit -> bool) -> unit val idle: (unit -> bool) -> unit val verbose : bool ref val notify_timer_state : int -> int -> int -> unit (** These functions have the properties required by OBSERVER *) val main_loop : unit -> unit (** [main_loop ()] run the main loop. Run the timeout handler and the the idle handler registered until the two of them are done. Nothing is run until this function is called *) end (* Local Variables: compile-command: "unset LANG; make -C ../.. byte" End: *) why3-0.88.3/src/session/strategy.mli0000664000175100017510000000314613225666037020077 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** {2 User-defined strategies} *) (** A strategy is defined by a program declared under a simple assembly-like form: instructions are indexed by integers starting from 0 (the initial instruction counter). An instruction is either 1) a call to a prover, with given time and mem limits . on success, the program execution ends . on any other result, the program execution continues on the next index 2) a application of a transformation . on success, the execution continues to a explicitly given index . on failure, execution continues on the next index 3) a goto instruction. the execution halts when reaching a non-existing state *) type instruction = | Icall_prover of Whyconf.prover * int * int (** timelimit, memlimit *) | Itransform of string * int (** successor state on success *) | Igoto of int (** goto state *) type t = instruction array why3-0.88.3/src/session/compress.mli0000664000175100017510000000243613225666037020071 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) val compression_supported : bool module type S = sig type out_channel val open_out: string -> out_channel val output_char: out_channel -> char -> unit val output_substring: out_channel -> string -> int -> int -> unit val output_string: out_channel -> string -> unit val close_out: out_channel -> unit type in_channel val open_in: string -> in_channel val input: in_channel -> bytes -> int -> int -> int val really_input: in_channel -> bytes -> int -> int -> unit val input_char: in_channel -> char val close_in: in_channel -> unit end module Compress_z : S module Compress_none : S why3-0.88.3/src/session/termcode.mli0000664000175100017510000000602213225666037020033 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** Explanations *) val arg_extra_expl_prefix : string * Arg.spec * string val goal_expl_task: root:bool -> Task.task -> Ident.ident * string * Task.task val search_labels : (Ident.Slab.t -> 'a list) -> Term.term -> 'a list (* [search_labels callback f] traverses [f] in a top-down manner and calls the [callback] on the label set of all encountered nodes. As soon as the callback returns a non-empty list, the traversal is stopped and that list is returned. Raises exception Exit if the entire term has been traversed. *) (** Shapes *) (* val reset_dict : unit -> unit *) val current_shape_version : int type shape val string_of_shape: shape -> string val shape_of_string: string -> shape val equal_shape: shape -> shape -> bool (* unused val print_shape: Format.formatter -> shape -> unit *) (* val t_shape_buf : ?version:int -> Term.term -> shape *) (** returns the shape of a given term *) val t_shape_task: ?version:int -> expl:string -> Task.task -> shape (** returns the shape of a given task *) (** Checksums *) type checksum val print_checksum: Format.formatter -> checksum -> unit val string_of_checksum: checksum -> string val checksum_of_string: string -> checksum val equal_checksum: checksum -> checksum -> bool val dumb_checksum: checksum val buffer_checksum : Buffer.t -> checksum val task_checksum : ?version:int -> Task.task -> checksum (** Pairing algorithm *) module type S = sig type 'a t val checksum : 'a t -> checksum option val shape : 'a t -> shape val name : 'a t -> Ident.ident end module Pairing(Old: S)(New: S) : sig val associate: use_shapes:bool -> 'a Old.t list -> 'b New.t list -> ('b New.t * ('a Old.t * bool) option) list * 'a Old.t list (** Associate new goals to (possibly) old goals Each new goal is mapped either to - [None]: no old goal associated - [Some (h, false)]: the matching is exact (same checksums) - [Some (h, true)]: inexact matching (thus proofs for the new goal must be assumed obsolete) if [use_shapes] is set, the clever algorithm matching shapes is used, otherwise a simple association in the given order of goals is done. Note: in the output, goals appear in the same order as in [newgoals] the second list returned is the list of non-associated old goals. *) end why3-0.88.3/src/session/strategy.ml0000664000175100017510000000171013225666037017721 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** {2 User-defined strategies} *) type instruction = | Icall_prover of Whyconf.prover * int * int (** timelimit, memlimit *) | Itransform of string * int (** successor state on success *) | Igoto of int (** goto state *) type t = instruction array why3-0.88.3/src/session/session_scheduler.ml0000664000175100017510000010572213225666037021610 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Format open Session let debug = Debug.register_info_flag "scheduler" ~desc:"Print@ debugging@ messages@ about@ scheduling@ of@ prover@ calls@ \ and@ transformation@ applications." let usleep t = ignore (Unix.select [] [] [] t) let default_delay_ms = 100 (* 0.1 seconds *) module Todo = struct type ('a,'b) todo = {mutable todo : int; mutable report : 'a; push_report : 'a -> 'b -> 'a; callback : 'a -> unit} let create init push callback = {todo = 0; report = init; push_report = push; callback = callback} let stop todo = todo.todo <- todo.todo - 1; if todo.todo=0 then todo.callback todo.report let _done todo v = todo.report <- todo.push_report todo.report v; stop todo let start todo = todo.todo <- todo.todo + 1 (** dead code let print todo = dprintf debug "[Sched] todo : %i@." todo.todo *) end (***************************) (* main functor *) (***************************) module type OBSERVER = sig type key val create: ?parent:key -> unit -> key val remove: key -> unit val reset: unit -> unit val timeout: ms:int -> (unit -> bool) -> unit val idle: (unit -> bool) -> unit val notify_timer_state : int -> int -> int -> unit val init : key -> key any -> unit val notify : key any -> unit val uninstalled_prover : key env_session -> Whyconf.prover -> Whyconf.prover_upgrade_policy end module Make(O : OBSERVER) = struct (*************************) (* Scheduler *) (*************************) type action = | Action_proof_attempt of bool * Call_provers.resource_limit * string option * bool * string * Driver.driver * (proof_attempt_status -> unit) * Task.task | Action_delayed of (unit -> unit) type timeout_action = | Check_prover of (proof_attempt_status -> unit) * bool * Call_provers.prover_call | Any_timeout of (unit -> bool) type t = { (* Actions that wait some idle time *) actions_queue : action Queue.t; (** Quota of action slot *) mutable maximum_running_proofs : int; (** Running actions which take one action slot *) mutable running_proofs : int; (** proof attempt that wait some available action slot *) proof_attempts_queue : timeout_action Queue.t; (** timeout handler state *) mutable timeout_handler_activated : bool; mutable timeout_handler_running : bool; (** idle handler state *) mutable idle_handler_activated : bool; } let set_maximum_running_proofs max sched = Prove_client.set_max_running_provers max; (* TODO dequeue actions if maximum_running_proofs increase *) sched.maximum_running_proofs <- max let init max = Debug.dprintf debug "[Sched] init scheduler max=%i@." max; Prove_client.set_max_running_provers max; { actions_queue = Queue.create (); maximum_running_proofs = max; running_proofs = 0; proof_attempts_queue = Queue.create (); timeout_handler_activated = false; timeout_handler_running = false; idle_handler_activated = false } let notify_timer_state t continue = O.notify_timer_state (Queue.length t.actions_queue) (Queue.length t.proof_attempts_queue) t.running_proofs; continue (* timeout handler *) let timeout_handler t = Debug.dprintf debug "[Sched] Timeout handler called@."; assert (not t.timeout_handler_running); t.timeout_handler_running <- true; (* Check if some action ended *) let q = Queue.create () in while not (Queue.is_empty t.proof_attempts_queue) do match Queue.pop t.proof_attempts_queue with | Check_prover (callback,started,call) as c -> begin match Call_provers.query_call call with | Call_provers.NoUpdates -> Queue.add c q | Call_provers.ProverStarted when started -> Queue.add c q (* should not happen *) | Call_provers.ProverStarted -> callback Running; t.running_proofs <- t.running_proofs + 1; Debug.dprintf debug "[Sched] proof attempts started@."; Queue.add (Check_prover (callback,true,call)) q | Call_provers.ProverFinished res -> if started then t.running_proofs <- t.running_proofs - 1; callback (Done res) end | Any_timeout callback as c -> if callback () then Queue.add c q done; Queue.transfer q t.proof_attempts_queue; let continue = if Queue.is_empty t.proof_attempts_queue then begin Debug.dprintf debug "[Sched] Timeout handler stopped@."; false end else true in t.timeout_handler_activated <- continue; t.timeout_handler_running <- false; notify_timer_state t continue let run_timeout_handler t = if t.timeout_handler_activated then () else begin t.timeout_handler_activated <- true; Debug.dprintf debug "[Sched] Timeout handler started@."; O.timeout ~ms:default_delay_ms (fun () -> timeout_handler t) end let schedule_any_timeout t callback = Debug.dprintf debug "[Sched] schedule a new timeout@."; Queue.add (Any_timeout callback) t.proof_attempts_queue; run_timeout_handler t (* idle handler *) let idle_handler t = try if Queue.length t.proof_attempts_queue < 3 * t.maximum_running_proofs then begin match Queue.pop t.actions_queue with | Action_proof_attempt(cntexample,limit, old,inplace,command,driver,callback,goal) -> begin try let call = Driver.prove_task ?old ~cntexample ~inplace ~command ~limit driver goal in let pa = Check_prover (callback,false,call) in Queue.push pa t.proof_attempts_queue; run_timeout_handler t with e when not (Debug.test_flag Debug.stack_trace) -> Format.eprintf "@[Exception raise in Session.idle_handler:@ %a@.@]" Exn_printer.exn_printer e; callback (InternalFailure e) end | Action_delayed callback -> callback () end else usleep (float default_delay_ms /. 1000.); notify_timer_state t true with | Queue.Empty -> t.idle_handler_activated <- false; Debug.dprintf debug "[Sched] idle_handler stopped@."; notify_timer_state t false | e when not (Debug.test_flag Debug.stack_trace) -> Format.eprintf "@[Exception raise in Session.idle_handler:@ %a@.@]" Exn_printer.exn_printer e; eprintf "Session.idle_handler stopped@."; notify_timer_state t false let run_idle_handler t = if t.idle_handler_activated then () else begin t.idle_handler_activated <- true; Debug.dprintf debug "[Sched] idle_handler started@."; O.idle (fun () -> idle_handler t) end (* main scheduling functions *) let cancel_scheduled_proofs t = let new_queue = Queue.create () in try while true do match Queue.pop t.actions_queue with | Action_proof_attempt(_cntexample,_limit, _old,_inplace,_command,_driver,callback,_goal) -> callback Interrupted | Action_delayed _ as a-> Queue.push a new_queue done with Queue.Empty -> Queue.transfer new_queue t.actions_queue; (* NOTE: we cannot cancel proof attempts sent to the server *) (* try while true do let (callback,_,_) = Queue.pop t.proof_attempts_queue in callback Interrupted done with | Queue.Empty -> *) ignore (notify_timer_state t false) let schedule_proof_attempt ~cntexample ~limit ?old ~inplace ~command ~driver ~callback t goal = Debug.dprintf debug "[Sched] Scheduling a new proof attempt (goal : %a)@." (fun fmt g -> Format.pp_print_string fmt (Task.task_goal g).Decl.pr_name.Ident.id_string) goal; callback Scheduled; Queue.push (Action_proof_attempt(cntexample,limit, old,inplace,command,driver,callback,goal)) t.actions_queue; run_idle_handler t let schedule_edition t command filename callback = Debug.dprintf debug "[Sched] Scheduling an edition@."; let call = Call_provers.call_editor ~command filename in callback Running; Queue.add (Check_prover(callback,false,call)) t.proof_attempts_queue; run_timeout_handler t let schedule_delayed_action t callback = Debug.dprintf debug "[Sched] Scheduling a delayed action@."; Queue.push (Action_delayed callback) t.actions_queue; run_idle_handler t (**************************) (* session functions *) (**************************) let notify = O.notify let rec init_any any = O.init (key_any any) any; iter init_any any let init_session session = session_iter init_any session let update_session ~allow_obsolete ~release ~use_shapes old_session env whyconf = O.reset (); let ctxt = Session.mk_update_context ~allow_obsolete_goals:allow_obsolete ~release_tasks:release ~use_shapes_for_pairing_sub_goals:use_shapes O.create in let (env_session,_,_) as res = update_session ~ctxt old_session env whyconf in Debug.dprintf debug "Init_session@\n"; init_session env_session.session; res let add_file env_session ?format f = let mfile = add_file ~keygen:O.create env_session ?format f in let any_file = (File mfile) in init_any any_file; O.notify any_file; mfile (*****************************************************) (* method: run a given prover on each unproved goals *) (*****************************************************) let find_prover eS a = match load_prover eS a.proof_prover with | Some p -> Some (a.proof_prover, p,a) | None -> match O.uninstalled_prover eS a.proof_prover with | Whyconf.CPU_keep -> None | Whyconf.CPU_upgrade new_p -> (* does a proof using new_p already exists ? *) let g = a.proof_parent in begin try let _ = PHprover.find (goal_external_proofs g) new_p in (* yes, then we do nothing *) None with Not_found -> (* we modify the prover in-place *) Session.change_prover a new_p; match load_prover eS new_p with | Some p -> Some (new_p,p,a) | None -> (* should never happen because at loading, config ignores uninstalled prover targets. Nevertheless, we can safely return None. *) None end | Whyconf.CPU_duplicate new_p -> (* does a proof using new_p already exists ? *) let g = a.proof_parent in begin try let _ = PHprover.find (goal_external_proofs g) new_p in (* yes, then we do nothing *) None with Not_found -> (* we duplicate the proof_attempt *) let new_a = copy_external_proof ~notify ~keygen:O.create ~prover:new_p ~env_session:eS a in O.init new_a.proof_key (Proof_attempt new_a); match load_prover eS new_p with | Some p -> Some (new_p,p,new_a) | None -> (* should never happen because at loading, config ignores uninstalled prover targets. Nevertheless, we can safely return None. *) None end (* to avoid corner cases when prover results are obtained very closely to the time or mem limits, we adapt these limits when we replay a proof *) let adapt_limits ~interactive ~use_steps a = let timelimit = (a.proof_limit.Call_provers.limit_time) in let memlimit = (a.proof_limit.Call_provers.limit_mem) in match a.proof_state with | Done { Call_provers.pr_answer = r; Call_provers.pr_time = t; Call_provers.pr_steps = s } -> (* increased time limit is 1 + twice the previous running time, but enforced to remain inside the interval [l,2l] where l is the previous time limit *) let t = truncate (1.0 +. 2.0 *. t) in let increased_time = if interactive then t else max timelimit (min t (2 * timelimit)) in (* increased mem limit is just 1.5 times the previous mem limit *) let increased_mem = if interactive then 0 else 3 * memlimit / 2 in begin match r with | Call_provers.OutOfMemory -> increased_time, memlimit, 0 | Call_provers.Timeout -> timelimit, increased_mem, 0 | Call_provers.Valid -> let steplimit = if use_steps && not a.proof_obsolete then s else 0 in increased_time, increased_mem, steplimit | Call_provers.Unknown _ | Call_provers.StepLimitExceeded | Call_provers.Invalid -> increased_time, increased_mem, 0 | Call_provers.Failure _ | Call_provers.HighFailure -> (* correct ? failures are supposed to appear quickly anyway... *) timelimit, memlimit, 0 end | _ when interactive -> 0, 0, 0 | _ -> timelimit, memlimit, 0 let adapt_limits ~interactive ~use_steps a = let t, m, s = adapt_limits ~interactive ~use_steps a in { Call_provers.limit_time = t; limit_mem = m; limit_steps = s } type run_external_status = | Starting | MissingProver | MissingFile of string | StatusChange of proof_attempt_status exception NoFile of string (* do not modify the proof duration stored in proof sessions if it changed by less than 10% or 0.1s, so as to avoid diff noise in session files *) let group_answer a = match a with | Call_provers.OutOfMemory | Call_provers.Unknown _ | Call_provers.Timeout -> Call_provers.Timeout | _ -> a let fuzzy_proof_time nres ores = match ores, nres with | Done { Call_provers.pr_answer= ansold; Call_provers.pr_time = told }, Done ({ Call_provers.pr_answer= ansnew; Call_provers.pr_time = tnew } as res') when group_answer ansold = group_answer ansnew && tnew >= told *. 0.9 -. 0.1 && tnew <= told *. 1.1 +. 0.1 -> Done { res' with Call_provers.pr_time = told } | _, _ -> nres (** run_external_proof_v3 doesn't modify existing proof attempt, it can just create new one by find_prover *) let run_external_proof_v3 ~use_steps eS eT a ?(cntexample=false) callback = match find_prover eS a with | None -> callback a a.proof_prover Call_provers.empty_limit None Starting; (* nothing to do *) callback a a.proof_prover Call_provers.empty_limit None MissingProver | Some(ap,npc,a) -> callback a ap Call_provers.empty_limit None Starting; let itp = npc.prover_config.Whyconf.interactive in if itp && a.proof_edited_as = None then begin callback a ap Call_provers.empty_limit None (MissingFile "unedited") end else begin let previous_result = a.proof_state in let limit = adapt_limits ~interactive:itp ~use_steps a in let inplace = npc.prover_config.Whyconf.in_place in let command = Whyconf.get_complete_command npc.prover_config ~with_steps:(limit.Call_provers.limit_steps <> Call_provers.empty_limit.Call_provers.limit_steps) in let cb result = let result = fuzzy_proof_time result previous_result in callback a ap limit (match previous_result with Done res -> Some res | _ -> None) (StatusChange result) in try let old = match get_edited_as_abs eS.session a with | None -> None | Some f -> if Sys.file_exists f then Some f else raise (NoFile f) in schedule_proof_attempt ~cntexample ~limit ?old ~inplace ~command ~driver:npc.prover_driver ~callback:cb eT (goal_task_or_recover eS a.proof_parent) with NoFile f -> callback a ap Call_provers.empty_limit None (MissingFile f) end (** run_external_proof_v2 modify the session according to the current state *) let run_external_proof_v2 ~use_steps eS eT a ~cntexample callback = let previous_res = ref (a.proof_state,a.proof_obsolete) in let callback a ap limits previous state = begin match state with | Starting -> previous_res := (a.proof_state,a.proof_obsolete) | MissingFile _ -> set_proof_state ~notify ~obsolete:false ~archived:false Unedited a | StatusChange result -> begin match result with | Interrupted -> let previous_result,obsolete = !previous_res in set_proof_state ~notify ~obsolete ~archived:false previous_result a | _ -> set_proof_state ~notify ~obsolete:false ~archived:false result a end | _ -> () end; callback a ap limits previous state in run_external_proof_v3 ~use_steps eS eT a ~cntexample callback let running = function | Scheduled | Running -> true | Unedited | JustEdited | Interrupted | Done _ | InternalFailure _ -> false let run_external_proof_v2 ~use_steps eS eT a ?(cntexample=false) callback = (* Perhaps the test a.proof_archived should be done somewhere else *) if a.proof_archived || running a.proof_state then () else run_external_proof_v2 ~use_steps eS eT a ~cntexample callback let run_external_proof eS eT ?(cntexample=false) ?callback a = let callback = match callback with | None -> fun _ _ _ _ _ -> () | Some c -> fun a _ _ _ s -> match s with | Starting -> () | MissingProver -> c a Interrupted | MissingFile _ -> c a a.proof_state | StatusChange s -> c a s in run_external_proof_v2 ~use_steps:false eS eT a ~cntexample callback let prover_on_goal eS eT ?callback ?(cntexample=false) ~limit p g = let a = try let a = PHprover.find (goal_external_proofs g) p in set_timelimit (limit.Call_provers.limit_time) a; set_memlimit (limit.Call_provers.limit_mem) a; a with Not_found -> let ep = add_external_proof ~keygen:O.create ~obsolete:false ~archived:false ~limit ~edit:None g p Interrupted in O.init ep.proof_key (Proof_attempt ep); ep in run_external_proof eS eT ~cntexample ?callback a let prover_on_goal_or_children eS eT ~context_unproved_goals_only ~cntexample ~limit p g = goal_iter_leaf_goal ~unproved_only:context_unproved_goals_only (prover_on_goal eS eT ~cntexample ~limit p) g let run_prover eS eT ~context_unproved_goals_only ~cntexample ~limit pr a = match a with | Goal g -> prover_on_goal_or_children eS eT ~context_unproved_goals_only ~cntexample ~limit pr g | Theory th -> List.iter (prover_on_goal_or_children eS eT ~context_unproved_goals_only ~cntexample ~limit pr) th.theory_goals | File file -> List.iter (fun th -> List.iter (prover_on_goal_or_children eS eT ~context_unproved_goals_only ~cntexample ~limit pr) th.theory_goals) file.file_theories | Proof_attempt a -> prover_on_goal_or_children eS eT ~context_unproved_goals_only ~cntexample ~limit pr a.proof_parent | Transf tr -> List.iter (prover_on_goal_or_children eS eT ~context_unproved_goals_only ~cntexample ~limit pr) tr.transf_goals | Metas m -> prover_on_goal_or_children eS eT ~context_unproved_goals_only ~cntexample ~limit pr m.metas_goal (***********************************) (* method: mark proofs as obsolete *) (***********************************) let cancel_proof a = if not a.proof_archived then set_obsolete ~notify a let cancel = iter_proof_attempt cancel_proof (** Set or unset archive *) let set_archive a b = set_archived a b; notify (Proof_attempt a) (*********************************) (* method: check existing proofs *) (*********************************) type report = | Result of Call_provers.prover_result * Call_provers.prover_result | CallFailed of exn | Prover_not_installed | Edited_file_absent of string | No_former_result of Call_provers.prover_result let push_report report (g,p,limits,r) = (goal_name g,p,limits,r)::report let check_external_proof ~use_steps eS eT todo a = let callback a ap limits old s = let g = a.proof_parent in match s with | Starting -> Todo.start todo | MissingFile f -> Todo._done todo (g, ap, limits, Edited_file_absent f) | MissingProver -> Todo._done todo (g, ap, limits, Prover_not_installed) | StatusChange (Scheduled | Running) -> () | StatusChange (Interrupted | Unedited | JustEdited) -> assert false | StatusChange (InternalFailure e) -> Todo._done todo (g, ap, limits, CallFailed e) | StatusChange (Done res) -> let r = match old with | None -> No_former_result res | Some old -> Result (res, old) in Todo._done todo (g, ap, limits, r) in run_external_proof_v2 ~use_steps eS eT a callback let rec goal_iter_proof_attempt_with_release ~release f g = let iter g = goal_iter_proof_attempt_with_release ~release f g in PHprover.iter (fun _ a -> f a) (goal_external_proofs g); PHstr.iter (fun _ t -> List.iter iter t.transf_goals) (goal_transformations g); Mmetas_args.iter (fun _ t -> iter t.metas_goal) (goal_metas g); if release then release_task g let check_all ?(release=false) ~use_steps ?filter eS eT ~callback = Debug.dprintf debug "[Sched] check all@.%a@." print_session eS.session; let todo = Todo.create [] push_report callback in Todo.start todo; let check_top_goal g = let check a = let c = match filter with | None -> true | Some f -> f a in if c then check_external_proof ~use_steps eS eT todo a in goal_iter_proof_attempt_with_release ~release check g in PHstr.iter (fun _ file -> List.iter (fun t -> List.iter check_top_goal t.theory_goals) file.file_theories) eS.session.session_files; Todo.stop todo (**********************************) (* method: replay obsolete proofs *) (**********************************) (* in the default context, a proof should be replayed if . it was successful or . it was just edited *) let proof_should_be_replayed a = match a.proof_state with | Done { Call_provers.pr_answer = Call_provers.Valid } | JustEdited -> true | _ -> false let rec replay_on_goal_or_children eS eT ~obsolete_only ~context_unproved_goals_only g = iter_goal (fun a -> if not obsolete_only || a.proof_obsolete then if not context_unproved_goals_only || proof_should_be_replayed a then run_external_proof eS eT a) (iter_transf (replay_on_goal_or_children eS eT ~obsolete_only ~context_unproved_goals_only) ) (iter_metas (replay_on_goal_or_children eS eT ~obsolete_only ~context_unproved_goals_only) ) g let replay eS eT ~obsolete_only ~context_unproved_goals_only a = match a with | Goal g -> replay_on_goal_or_children eS eT ~obsolete_only ~context_unproved_goals_only g | Theory th -> List.iter (replay_on_goal_or_children eS eT ~obsolete_only ~context_unproved_goals_only) th.theory_goals | File file -> List.iter (fun th -> List.iter (replay_on_goal_or_children eS eT ~obsolete_only ~context_unproved_goals_only) th.theory_goals) file.file_theories | Proof_attempt a -> replay_on_goal_or_children eS eT ~obsolete_only ~context_unproved_goals_only a.proof_parent | Transf tr -> List.iter (replay_on_goal_or_children eS eT ~obsolete_only ~context_unproved_goals_only) tr.transf_goals | Metas m -> replay_on_goal_or_children eS eT ~obsolete_only ~context_unproved_goals_only m.metas_goal (***********************************) (* play all *) (***********************************) let rec play_on_goal_and_children eS eT ~limit todo l g = let limit, auto_proved = PHprover.fold (fun _ pa (limit, _ as acc) -> match pa.proof_edited_as, pa.proof_state with | None, Done { Call_provers.pr_answer = Call_provers.Valid } -> Call_provers.limit_max limit pa.proof_limit, true | _ -> acc) (goal_external_proofs g) (limit, false) in let callback _key status = if not (running status) then Todo._done todo () in if auto_proved then begin List.iter (fun p -> Todo.start todo; (* eprintf "todo increased to %d@." todo.Todo.todo; *) (* eprintf "prover %a on goal %s@." *) (* Whyconf.print_prover p g.goal_name.Ident.id_string; *) prover_on_goal eS eT ~callback ~limit p g) l end; iter_goal (fun _ -> ()) (iter_transf (play_on_goal_and_children eS eT ~limit todo l) ) (iter_metas (play_on_goal_and_children eS eT ~limit todo l) ) g let play_all eS eT ~callback ~limit l = let todo = Todo.create () (fun () _ -> ()) callback in Todo.start todo; PHstr.iter (fun _ file -> List.iter (fun th -> List.iter (play_on_goal_and_children eS eT ~limit todo l) th.theory_goals) file.file_theories) eS.session.session_files; Todo.stop todo (** Transformation *) let transformation_on_goal_aux eS tr keep_dumb_transformation g = let gtask = goal_task_or_recover eS g in let subgoals = Trans.apply_transform tr eS.env gtask in let b = keep_dumb_transformation || match subgoals with | [task] -> not (Task.task_equal task gtask) | _ -> true in if b then let ntr = add_transformation ~init:init_any ~notify ~keygen:O.create eS tr g subgoals in Some ntr else None let transform_goal eS sched ?(keep_dumb_transformation=false) ?callback tr g = schedule_delayed_action sched (fun () -> let ntr = transformation_on_goal_aux eS tr keep_dumb_transformation g in Opt.apply () callback ntr) let transform_goal_or_children ~context_unproved_goals_only eS sched ?callback tr g = goal_iter_leaf_goal ~unproved_only:context_unproved_goals_only (transform_goal eS sched ~keep_dumb_transformation:false ?callback tr) g let rec transform eS sched ~context_unproved_goals_only ?callback tr a = match a with | Goal g | Proof_attempt {proof_parent = g} -> transform_goal_or_children ~context_unproved_goals_only eS sched ?callback tr g | _ -> iter (transform ~context_unproved_goals_only eS sched ?callback tr) a (*****************************) (* method: edit current goal *) (*****************************) let edit_proof_v3 ~cntexample eS sched ~default_editor callback a = match find_prover eS a with | None -> (* nothing to do TODO: report an non replayable proof if some option is set *) () | Some(_,npc,a) -> let editor = match npc.prover_config.Whyconf.editor with | "" -> default_editor | s -> try let ed = Whyconf.editor_by_id eS.whyconf s in String.concat " "(ed.Whyconf.editor_command :: ed.Whyconf.editor_options) with Not_found -> default_editor in let file = update_edit_external_proof ~cntexample eS a in Debug.dprintf debug "[Editing] goal %s with command '%s' on file %s@." (goal_name a.proof_parent).Ident.id_string editor file; schedule_edition sched editor file (fun res -> callback a res) let edit_proof ~cntexample eS sched ~default_editor a = (* check that the state is not Scheduled or Running *) if a.proof_archived || running a.proof_state then () (* info_window `ERROR "Edition already in progress" *) else let callback a res = match res with | Done {Call_provers.pr_answer = Call_provers.Unknown ("", _)} -> set_proof_state ~notify ~obsolete:true ~archived:false JustEdited a | _ -> set_proof_state ~notify ~obsolete:false ~archived:false res a in edit_proof_v3 ~cntexample eS sched ~default_editor callback a let edit_proof_v3 ~cntexample eS sched ~default_editor ~callback a = let callback a res = match res with | Done {Call_provers.pr_answer = Call_provers.Unknown ("", _)} -> callback a | _ -> () in edit_proof_v3 ~cntexample eS sched ~default_editor callback a (*************) (* removing *) (*************) let remove_proof_attempt (a:O.key proof_attempt) = O.remove a.proof_key; let notify = (notify : O.key notify) in remove_external_proof ~notify a let remove_transformation t = O.remove t.transf_key; remove_transformation ~notify t let remove_metas t = O.remove t.metas_key; remove_metas ~notify t (* a proof is removable if . it is not in progress and . it is obsolete or not successful *) let proof_removable a = match a.proof_state with | Scheduled | Running -> false | Done pr -> a.proof_obsolete || pr.Call_provers.pr_answer <> Call_provers.Valid | Unedited | JustEdited | Interrupted | InternalFailure _ -> true let rec clean = function | Goal g when Opt.inhabited (goal_verified g) -> iter_goal (fun a -> if proof_removable a then remove_proof_attempt a) (fun t -> if not (Opt.inhabited t.transf_verified) then remove_transformation t else transf_iter clean t) (fun m -> if not (Opt.inhabited m.metas_verified) then remove_metas m else metas_iter clean m) g | Goal g -> (* don't iter on proof_attempt if the goal is not proved *) iter_goal (fun _ -> ()) (transf_iter clean) (metas_iter clean) g | Proof_attempt a -> clean (Goal a.proof_parent) | any -> iter clean any (**** convert ***) let convert_unknown_prover = Session_tools.convert_unknown_prover ~keygen:O.create open Strategy let rec exec_strategy ~todo es sched pc strat g = if pc < 0 || pc >= Array.length strat then (* halt the strategy *) Todo._done todo () else match Array.get strat pc with | Icall_prover(p,timelimit,memlimit) -> let callback _pa res = match res with | Scheduled | Running -> (* nothing to do yet *) () | Done { Call_provers.pr_answer = Call_provers.Valid } -> (* proof succeeded, nothing more to do *) Todo._done todo () | Interrupted | InternalFailure _ | Done _ -> (* proof did not succeed, goto to next step *) let callback () = exec_strategy ~todo es sched (pc+1) strat g in schedule_delayed_action sched callback | Unedited | JustEdited -> (* should not happen *) assert false in let limit = { Call_provers.empty_limit with Call_provers.limit_time = timelimit; limit_mem = memlimit} in prover_on_goal es sched ~callback ~limit p g | Itransform(trname,pcsuccess) -> let callback ntr = match ntr with | None -> (* transformation failed *) let callback () = exec_strategy ~todo es sched (pc+1) strat g in schedule_delayed_action sched callback | Some tr -> List.iter (fun g -> Todo.start todo; let callback () = exec_strategy ~todo es sched pcsuccess strat g in schedule_delayed_action sched callback ) tr.transf_goals; Todo._done todo () in transform_goal es sched ~callback trname g | Igoto pc -> exec_strategy ~todo es sched pc strat g let run_strategy_on_goal ?(intermediate_callback=fun () -> ()) ?(final_callback=fun () -> ()) es sched strat g = let todo = Todo.create () (fun () -> intermediate_callback) final_callback in Todo.start todo; let callback () = exec_strategy ~todo es sched 0 strat g in schedule_delayed_action sched callback let run_strategy_on_goal_or_children ~context_unproved_goals_only eS sched strat g = goal_iter_leaf_goal ~unproved_only:context_unproved_goals_only (run_strategy_on_goal eS sched strat) g let rec run_strategy eS sched ~context_unproved_goals_only strat a = match a with | Goal g | Proof_attempt {proof_parent = g} -> run_strategy_on_goal_or_children ~context_unproved_goals_only eS sched strat g | _ -> iter (run_strategy ~context_unproved_goals_only eS sched strat) a end module Base_scheduler (X : sig end) = (struct let idle_handler = ref None let timeout_handler = ref None let verbose = ref true let idle f = match !idle_handler with | None -> idle_handler := Some f; | Some _ -> failwith "Replay.idle: already one handler installed" let timeout ~ms f = match !timeout_handler with | None -> timeout_handler := Some(float ms /. 1000.0 ,f); | Some _ -> failwith "Replay.timeout: already one handler installed" let notify_timer_state w s r = if !verbose then Printf.eprintf "Progress: %d/%d/%d \r%!" w s r let main_loop () = let last = ref (Unix.gettimeofday ()) in try while true do let time = Unix.gettimeofday () -. !last in (* attempt to run timeout handler *) let timeout = match !timeout_handler with | None -> false | Some(ms,f) -> if time > ms then let b = f () in if b then true else begin timeout_handler := None; true end else false in if timeout then last := Unix.gettimeofday () else (* attempt to run the idle handler *) match !idle_handler with | None -> begin let ms = match !timeout_handler with | None -> raise Exit | Some(ms,_) -> ms in usleep (ms -. time) end | Some f -> let b = f () in if b then () else begin idle_handler := None; end done with Exit -> () end) (* Local Variables: compile-command: "unset LANG; make -C ../.. bin/why3ide.byte" End: *) why3-0.88.3/src/session/termcode.ml0000664000175100017510000006523613225666037017676 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) open Term (*******************************) (* explanations *) (*******************************) let expl_prefixes = ref ["expl:"] let arg_extra_expl_prefix = ("--extra-expl-prefix", Arg.String (fun s -> expl_prefixes := s :: !expl_prefixes), " register s as an additional prefix for VC explanations") let collect_expls lab = Ident.Slab.fold (fun lab acc -> let lab = lab.Ident.lab_string in let rec aux l = match l with | [] -> acc | p :: r -> try let s = Strings.remove_prefix p lab in s :: acc with Not_found -> aux r in aux !expl_prefixes) lab [] let concat_expls = function | [] -> None | [l] -> Some l | l :: ls -> Some (l ^ " (" ^ String.concat ". " ls ^ ")") let search_labels callback = let rec aux acc f = if f.t_ty <> None then acc else if Ident.Slab.mem Split_goal.stop_split f.Term.t_label then acc else let res = callback f.Term.t_label in if res = [] then match f.t_node with | Term.Ttrue | Term.Tfalse | Term.Tapp _ -> acc | Term.Tbinop (Term.Timplies, _, f) -> aux acc f | Term.Tlet _ | Term.Tcase _ | Term.Tquant (Term.Tforall, _) -> Term.t_fold aux acc f | _ -> raise Exit else if acc = [] then res else raise Exit in aux [] let get_expls_fmla = let search = search_labels collect_expls in fun f -> try search f with Exit -> [] let goal_expl_task ~root task = let gid = (Task.task_goal task).Decl.pr_name in let info = let res = get_expls_fmla (Task.task_goal_fmla task) in concat_expls (if res <> [] && not root then res else collect_expls gid.Ident.id_label) in let info = match info with | Some i -> i | None -> "" in gid, info, task (* {2 ident dictionaries for shapes} *) (* let dict_table = Hashtbl.create 17 let dict_count = ref 0 let reverse_ident_table = Hashtbl.create 17 let reverse_dict_count = ref 0 let reset_dict () = Hashtbl.clear dict_table; Hashtbl.clear reverse_ident_table; dict_count := 0; reverse_dict_count := 0 *) (* {3 direct table to read shapes from strings} *) (* let get_name s b i = try while !i < String.length s do match String.get s !i with | ')' -> incr i; raise Exit | c -> incr i; Buffer.add_char b c done; invalid_arg "Termcode.get_name: missing closing parenthesis" with Exit -> let id = Buffer.contents b in Hashtbl.add dict_table !dict_count id; (* Format.eprintf "%d -> %s@." !dict_count id; *) incr dict_count; id let get_num s n i = try while !i < String.length s do match String.get s !i with | ')' -> incr i; raise Exit | '0'..'9' as c -> incr i; n := !n * 10 + (Char.code c - Char.code '0') | _ -> invalid_arg "Termcode.get_num: decimal digit expected" done; invalid_arg "Termcode.get_num: missing closing parenthesis" with Exit -> try Hashtbl.find dict_table !n with Not_found -> invalid_arg ("Termcode.get_num: invalid ident number " ^ string_of_int !n) *) (* let get_id s i = if !i >= String.length s then invalid_arg "Termcode.get_id: missing closing parenthesis"; match String.get s !i with | '0'..'9' as c -> let n = ref (Char.code c - Char.code '0') in incr i; get_num s n i | ')' -> invalid_arg "Termcode.get_id: unexpected closing parenthesis" | c -> let b = Buffer.create 17 in Buffer.add_char b c; incr i; get_name s b i *) (* let store_id s i = let b = Buffer.create 17 in try while !i < String.length s do match String.get s !i with | ')' -> incr i; raise Exit | c -> incr i; Buffer.add_char b c done; invalid_arg "Termcode.store_id: missing closing parenthesis" with Exit -> let id = Buffer.contents b in try let n = Hashtbl.find reverse_ident_table id in string_of_int n with Not_found -> Hashtbl.add reverse_ident_table id !reverse_dict_count; incr reverse_dict_count; id *) (* {2 Shapes} *) type shape = string let string_of_shape s = s (* try let l = String.length s in let r = Buffer.create l in let i = ref 0 in while !i < l do match String.get s !i with | '(' -> Buffer.add_char r '('; incr i; Buffer.add_string r (store_id s i); Buffer.add_char r ')' | c -> Buffer.add_char r c; incr i done; Buffer.contents r with e -> Format.eprintf "Error while reading shape [%s]@." s; raise e *) let shape_of_string s = s (* try let l = String.length s in let r = Buffer.create l in let i = ref 0 in while !i < l do match String.get s !i with | '(' -> incr i; Buffer.add_string r (get_id s i) | c -> Buffer.add_char r c; incr i done; Buffer.contents r with e -> Format.eprintf "Error while reading shape [%s]@." s; raise e *) (* tests let _ = reset_dict () ; shape_of_string "a(b)cde(0)" let _ = reset_dict () ; shape_of_string "a(bc)d(e)f(1)g(0)h" let _ = reset_dict () ; shape_of_string "(abc)(def)(1)(0)(1)" let _ = reset_dict () ; shape_of_string "(abcde)(fghij)(1)(0)(1)" *) let equal_shape (x:string) y = x = y (* unused let print_shape fmt s = Format.pp_print_string fmt (string_of_shape s) *) let debug = Debug.register_info_flag "session_pairing" ~desc:"Print@ debugging@ messages@ about@ reconstruction@ of@ \ session@ trees@ after@ modification@ of@ source@ files." let current_shape_version = 4 type shape_version = SV1 | SV2 | SV3 (* similarity code of terms, or of "shapes" example: shape(forall x:int, x * x >= 0) = Forall(Int,App(infix_gteq,App(infix_st,Tvar 0,Tvar 0),Const(0))) i.e: de bruijn indexes, first-order term *) let tag_and = 'A' let tag_app = 'a' let tag_case = 'C' let tag_const = 'c' let tag_exists = 'E' let tag_eps = 'e' let tag_forall = 'F' let tag_false = 'f' let tag_impl = 'I' let tag_if = 'i' let tag_let = 'L' let tag_not = 'N' let tag_or = 'O' let tag_iff = 'q' let tag_true = 't' let tag_var = 'V' let tag_wild = 'w' let tag_as = 'z' let shape_buffer = Buffer.create 17 let push s = Buffer.add_string shape_buffer s; if Buffer.length shape_buffer >= 256 then raise Exit let pushc c = Buffer.add_char shape_buffer c; if Buffer.length shape_buffer >= 256 then raise Exit let ident h id = let x = try Ident.Mid.find id !h with Not_found -> let s = id.Ident.id_string in h := Ident.Mid.add id s !h; s in push x let vs_rename_alpha c h vs = incr c; let s = string_of_int !c in h := Ident.Mid.add vs.vs_name s !h let vl_rename_alpha c h vl = List.iter (vs_rename_alpha c h) vl let rec pat_rename_alpha c h p = match p.pat_node with | Pvar v -> vs_rename_alpha c h v | Pas (p, v) -> vs_rename_alpha c h v; pat_rename_alpha c h p | Por (p, _) -> pat_rename_alpha c h p | _ -> Term.pat_fold (fun () -> pat_rename_alpha c h) () p (* let id_string_shape id = push id let ident_shape id = id_string_shape id.Ident.id_string *) open Number let integer_const_shape = function | IConstDec s -> push s | IConstHex s -> push "0x"; push s | IConstOct s -> push "0o"; push s | IConstBin s -> push "0b"; push s let real_const_shape = function | RConstDec (i,f,None) -> push i; push "."; push f | RConstDec (i,f,Some e) -> push i; push "."; push f; push "e"; push e | RConstHex (i,f,Some e) -> push "0x"; push i; push "."; push f; push "p"; push e | RConstHex (i,f,None) -> push "0x"; push i; push "."; push f let const_shape c = match c with | ConstInt c -> integer_const_shape c | ConstReal c -> real_const_shape c let rec pat_shape c m p : 'a = match p.pat_node with | Pwild -> pushc tag_wild | Pvar _ -> pushc tag_var | Papp (f, l) -> pushc tag_app; ident m f.ls_name; List.iter (pat_shape c m) l | Pas (p, _) -> pat_shape c m p; pushc tag_as | Por (p, q) -> pat_shape c m q; pushc tag_or; pat_shape c m p let rec t_shape ~version c m t = let fn = t_shape ~version c m in match t.t_node with | Tconst c -> pushc tag_const; const_shape c | Tvar v -> pushc tag_var; ident m v.vs_name | Tapp (s,l) -> pushc tag_app; ident m s.ls_name; List.iter fn l | Tif (f,t1,t2) -> begin match version with | SV1 | SV2 -> pushc tag_if; fn f; fn t1; fn t2 | SV3 -> pushc tag_if; fn t2; fn t1; fn f end | Tcase (t1,bl) -> let br_shape b = let p,t2 = t_open_branch b in match version with | SV1 | SV2 -> pat_shape c m p; pat_rename_alpha c m p; t_shape ~version c m t2 | SV3 -> pat_rename_alpha c m p; t_shape ~version c m t2; pat_shape c m p in begin match version with | SV1 | SV2 -> pushc tag_case; fn t1; List.iter br_shape bl | SV3 -> pushc tag_case; List.iter br_shape bl; fn t1 end | Teps b -> pushc tag_eps; let u,f = t_open_bound b in vs_rename_alpha c m u; t_shape ~version c m f | Tquant (q,b) -> let vl,triggers,f1 = t_open_quant b in vl_rename_alpha c m vl; (* argument first, intentionally, to give more weight on A in forall x,A *) t_shape ~version c m f1; let hq = match q with Tforall -> tag_forall | Texists -> tag_exists in pushc hq; List.iter (fun trigger -> List.iter (fun t -> t_shape ~version c m t) trigger) triggers | Tbinop (o,f,g) -> (* g first, intentionally, to give more weight on B in A->B *) fn g; let tag = match o with | Tand -> tag_and | Tor -> tag_or | Timplies -> tag_impl | Tiff -> tag_iff in pushc tag; fn f | Tlet (t1,b) -> let u,t2 = t_open_bound b in vs_rename_alpha c m u; begin match version with | SV1 -> pushc tag_let; fn t1; t_shape ~version c m t2 | SV2 | SV3 -> (* t2 first, intentionally *) t_shape ~version c m t2; pushc tag_let; fn t1 end | Tnot f -> begin match version with | SV1 | SV2 -> fn f; pushc tag_not | SV3 -> pushc tag_not; fn f end | Ttrue -> pushc tag_true | Tfalse -> pushc tag_false let t_shape_task ~version ~expl t = Buffer.clear shape_buffer; begin match version with | SV1 | SV2 -> () | SV3 -> push expl end; let f = Task.task_goal_fmla t in let () = try t_shape ~version (ref (-1)) (ref Ident.Mid.empty) f with Exit -> () in Buffer.contents shape_buffer (* let time = ref 0.0 *) let t_shape_task ?(version=current_shape_version) ~expl t = let version = match version with | 1 -> SV1 | 2 -> SV2 | 3 | 4 -> SV3 | _ -> assert false in (* let tim = Unix.gettimeofday () in *) let s = t_shape_task ~version ~expl t in (* let tim = Unix.gettimeofday () -. tim in time := !time +. tim; Format.eprintf "[Shape times] %f/%f@." tim !time; *) s (* Checksums *) type checksum = string let print_checksum = Format.pp_print_string let string_of_checksum x = x let checksum_of_string x = x let equal_checksum x y = (x : checksum) = y let dumb_checksum = "" let buffer_checksum b = let s = Buffer.contents b in Digest.to_hex (Digest.string s) type checksum_version = CV1 | CV2 module Checksum = struct let char (_,_,_,buf) c = Buffer.add_char buf c let int (_,_,_,buf as b) i = char b 'i'; Buffer.add_string buf (string_of_int i) let raw_string (_,_,_,buf) s = Buffer.add_string buf s let string (_,_,_,buf as b) s = char b '"'; Buffer.add_string buf (String.escaped s); char b '"' let option e b = function None -> char b 'n' | Some x -> char b 's'; e b x let list e b l = char b '['; List.iter (e b) l; char b ']' let ident_v1, clear_ident_v1 = let hident = Ident.Hid.create 17 in let c = ref 0 in (fun b id -> int b (try Ident.Hid.find hident id with Not_found -> incr c; Ident.Hid.add hident id !c; !c)), (fun () -> Ident.Hid.clear hident; c := 0) let ident_v2 (_,c,m,_ as b) id = let i = match Ident.Mid.find_opt id !m with | Some i -> i | None -> incr c; m := Ident.Mid.add id !c !m; !c in int b i let ident (v,_,_,_ as b) id = match v with | CV1 -> ident_v1 b id | CV2 -> ident_v2 b id (* let _integer_constant b c = Number.print_integer_constant Format.str_formatter c; let s = Format.flush_str_formatter () in string b s *) let integer_const b = function | IConstDec s -> raw_string b s | IConstHex s -> raw_string b "0x"; raw_string b s | IConstOct s -> raw_string b "0o"; raw_string b s | IConstBin s -> raw_string b "0b"; raw_string b s let real_const b = function | RConstDec (i,f,None) -> raw_string b i; raw_string b "."; raw_string b f | RConstDec (i,f,Some e) -> raw_string b i; raw_string b "."; raw_string b f; raw_string b "e"; raw_string b e | RConstHex (i,f,Some e) -> raw_string b "0x"; raw_string b i; raw_string b "."; raw_string b f; raw_string b "p"; raw_string b e | RConstHex (i,f,None) -> raw_string b "0x"; raw_string b i; raw_string b "."; raw_string b f let const b c = match c with | ConstInt c -> integer_const b c | ConstReal c -> real_const b c let tvsymbol b tv = ident b tv.Ty.tv_name let rec ty b t = match t.Ty.ty_node with | Ty.Tyvar tv -> char b 'v'; tvsymbol b tv | Ty.Tyapp (ts, tyl) -> char b 'a'; ident b ts.Ty.ts_name; list ty b tyl let vsymbol (v,_,_,_ as b) vs = match v with | CV1 -> ty b vs.vs_ty | CV2 -> ident b vs.vs_name; ty b vs.vs_ty (* start: _ V ident a o *) let rec pat b p = match p.pat_node with | Pwild -> char b '_' | Pvar vs -> char b 'v'; vsymbol b vs | Papp (f, l) -> char b 'a'; ident b f.ls_name; list pat b l | Pas (p, vs) -> char b 's'; pat b p; vsymbol b vs | Por (p, q) -> char b 'o'; pat b p; pat b q (* start: c V v i m e F E A O I q l n t f *) let rec term b t = match t.t_node with | Tconst c -> const b c | Tvar v -> char b 'v'; ident b v.vs_name | Tapp (s, l) -> char b 'a'; ident b s.ls_name; list term b l | Tif (f, t1, t2) -> char b 'i'; term b f; term b t1; term b t2 | Tcase (t1, bl) -> let branch b br = let p, t2 = t_open_branch br in pat b p; term b t2 in char b 'm'; term b t1; list branch b bl | Teps bf -> let vs, f = t_open_bound bf in char b 'e'; vsymbol b vs; term b f | Tquant (q, bf) -> let vl, triggers, f1 = t_open_quant bf in char b (match q with Tforall -> 'F' | Texists -> 'E'); list vsymbol b vl; list (list term) b triggers; term b f1 | Tbinop (o, f, g) -> let tag = match o with | Tand -> 'A' | Tor -> 'O' | Timplies -> 'I' | Tiff -> 'q' in char b tag; term b f; term b g | Tlet (t1, bt) -> let vs, t2 = t_open_bound bt in char b 'l'; vsymbol b vs; term b t1; term b t2 | Tnot f -> char b 'n'; term b f | Ttrue -> char b 't' | Tfalse -> char b 'f' let tysymbol b ts = ident b ts.Ty.ts_name; list tvsymbol b ts.Ty.ts_args; match ts.Ty.ts_def with | Ty.NoDef -> char b 'n' | Ty.Alias x -> char b 's'; ty b x | Ty.Range _ -> char b 'r' (* FIXME *) | Ty.Float _ -> char b 'f' (* FIXME *) let lsymbol b ls = ident b ls.ls_name; list ty b ls.ls_args; option ty b ls.ls_value; list tvsymbol b (Ty.Stv.elements ls.ls_opaque); int b ls.ls_constr (* start: T G F D R L I P (C M) *) let decl b d = match d.Decl.d_node with | Decl.Dtype ts -> char b 'T'; tysymbol b ts | Decl.Ddata ddl -> let constructor b (ls, l) = lsymbol b ls; list (option lsymbol) b l in let data_decl b (ts, cl) = tysymbol b ts; list constructor b cl in char b 'D'; list data_decl b ddl | Decl.Dparam ls -> char b 'R'; lsymbol b ls | Decl.Dlogic ldl -> let logic_decl b (ls, defn) = lsymbol b ls; let vl, t = Decl.open_ls_defn defn in list vsymbol b vl; term b t in char b 'L'; list logic_decl b ldl | Decl.Dind (s, idl) -> let clause b (pr, f) = ident b pr.Decl.pr_name; term b f in let ind_decl b (ls, cl) = lsymbol b ls; list clause b cl in char b 'I'; char b (match s with Decl.Ind -> 'i' | Decl.Coind -> 'c'); list ind_decl b idl | Decl.Dprop (k,n,t) -> let tag = match k with | Decl.Plemma -> "PL" | Decl.Paxiom -> "PA" | Decl.Pgoal -> "PG" | Decl.Pskip -> "PS" in string b tag; ident b n.Decl.pr_name; term b t let meta_arg_type b = function | Theory.MTty -> char b 'y' | Theory.MTtysymbol -> char b 't' | Theory.MTlsymbol -> char b 'l' | Theory.MTprsymbol -> char b 'p' | Theory.MTstring -> char b 's' | Theory.MTint -> char b 'i' let meta b m = string b m.Theory.meta_name; list meta_arg_type b m.Theory.meta_type; char b (if m.Theory.meta_excl then 't' else 'f') let meta_arg b = function | Theory.MAty t -> char b 'y'; ty b t | Theory.MAts ts -> char b 't'; ident b ts.Ty.ts_name | Theory.MAls ls -> char b 'l'; ident b ls.ls_name | Theory.MApr pr -> char b 'p'; ident b pr.Decl.pr_name | Theory.MAstr s -> char b 's'; string b s | Theory.MAint i -> char b 'i'; int b i let rec tdecl b d = match d.Theory.td_node with | Theory.Decl d -> decl b d | Theory.Use th -> char b 'U'; ident b th.Theory.th_name; list string b th.Theory.th_path; string b (theory_v2 th) | Theory.Clone (th, _) -> char b 'C'; ident b th.Theory.th_name; list string b th.Theory.th_path | Theory.Meta (m, mal) -> char b 'M'; meta b m; list meta_arg b mal and theory_v2_aux t = let c = ref 0 in let m = ref Ident.Mid.empty in let b = Buffer.create 8192 in List.iter (tdecl (CV2,c,m,b)) t.Theory.th_decls; let dnew = Digest.string (Buffer.contents b) in Digest.to_hex dnew and theory_v2 = let table = Ident.Wid.create 17 in fun t -> try Ident.Wid.find table t.Theory.th_name with Not_found -> let v = theory_v2_aux t in Ident.Wid.set table t.Theory.th_name v; v (* not used anymore let theory ~version t = match version with | CV1 -> assert false | CV2 -> theory_v2 t *) let task_v1 = let c = ref 0 in let m = ref Ident.Mid.empty in let b = Buffer.create 8192 in fun t -> Task.task_iter (tdecl (CV1,c,m,b)) t; clear_ident_v1 (); let dnew = Digest.string (Buffer.contents b) in Buffer.clear b; Digest.to_hex dnew let task_v2 = let c = ref 0 in let m = ref Ident.Mid.empty in let b = Buffer.create 8192 in let task_hd t (cold,mold,dold) = c := cold; m := mold; tdecl (CV2,c,m,b) t.Task.task_decl; Buffer.add_string b (Digest.to_hex dold); let dnew = Digest.string (Buffer.contents b) in Buffer.clear b; let mnew = match t.Task.task_decl.Theory.td_node with | Theory.Decl { Decl.d_news = s } -> Ident.Sid.fold (fun id a -> Ident.Mid.add id (Ident.Mid.find id !m) a) s mold | _ -> !m in !c, mnew, dnew in let tr = Trans.fold task_hd (0, Ident.Mid.empty, Digest.string "") in fun t -> let _,_,dnew = Trans.apply tr t in Digest.to_hex dnew let task ~version t = match version with | CV1 -> task_v1 t | CV2 -> task_v2 t end (* let time = ref 0.0 *) let task_checksum ?(version=current_shape_version) t = let version = match version with | 1 | 2 | 3 -> CV1 | 4 -> CV2 | _ -> assert false in (* let tim = Unix.gettimeofday () in *) let s = Checksum.task ~version t in (* let tim = Unix.gettimeofday () -. tim in time := !time +. tim; Format.eprintf "[Checksum times] %f/%f@." tim !time; *) s (* not used anymore let theory_checksum ?(version=current_shape_version) t = let version = match version with | 1 | 2 | 3 -> CV1 | 4 -> CV2 | _ -> assert false in Checksum.theory ~version t *) (*************************************************************) (* Pairing of new and old subgoals *) (*************************************************************) (* we have an ordered list of new subgoals newgoals = [g1; g2; g3; ...] and a list of old subgoals oldgoals = [h1 ; h2 ; ... ] we build a list [g1, None; g2, Some (h3, false); g3, Some (h2, true); ...] where each new goal is mapped either to - None: no pairing at all - Some (h, false): exact matching (equal checksums) - Some (h, true): inexact matching (goal obsolete) *) module type S = sig type 'a t val checksum : 'a t -> checksum option val shape : 'a t -> string val name : 'a t -> Ident.ident end module Pairing(Old: S)(New: S) = struct let rec lcp n s1 s2 = if String.length s1 <= n || String.length s2 <= n then n else if s1.[n] = s2.[n] then lcp (n+1) s1 s2 else n let lcp = lcp 0 open Ident type goal_index = Old of int | New of int type ('a,'b) goal_table = { table_old : 'a Old.t array; table_new : 'b New.t array; } (* doubly linked lists; left and right bounds point to themselves *) type node = { mutable prev: node; shape: string; elt: goal_index; mutable valid: bool; mutable next: node; } let mk_node table g = let s = match g with | Old g -> Old.shape table.table_old.(g) | New g -> New.shape table.table_new.(g) in let rec n = { prev = n; shape = s; elt = g; next = n; valid = true } in n let rec iter_pairs f = function | [] | [_] -> () | x :: (y :: _ as l) -> f x y; iter_pairs f l let build_list = iter_pairs (fun x y -> x.next <- y; y.prev <- x) let remove x = x.valid <- false; let p = x.prev and n = x.next in if p == x then n.prev <- n (* left bound *) else if n == x then p.next <- p (* right bound *) else begin p.next <- n; n.prev <- p end (* priority queues for pairs of nodes *) module E = struct type t = int * (node * node) let compare (v1, _) (v2, _) = Pervasives.compare v2 v1 end module PQ = Pqueue.Make(E) let dprintf = Debug.dprintf debug let associate oldgoals newgoals = let table = { table_old = Array.of_list oldgoals; table_new = Array.of_list newgoals; } in (* set up an array [result] containing the solution [new_goal_index g] returns the index of goal [g] in that array *) let new_goal_index = Hid.create 17 in let result = let make i newg = Hid.add new_goal_index (New.name newg) i; (newg, None) in Array.mapi make table.table_new in let new_goal_index newg = try Hid.find new_goal_index (New.name newg) with Not_found -> assert false in (* phase 1: pair goals with identical checksums *) let old_checksums = Hashtbl.create 17 in let old_goals_without_checksum = let acc =ref [] in for oldg = 0 to Array.length table.table_old - 1 do match Old.checksum table.table_old.(oldg) with | None -> acc := mk_node table (Old oldg) :: !acc | Some s -> Hashtbl.add old_checksums s oldg done; !acc in let newgoals = let acc = ref old_goals_without_checksum in for newi = 0 to Array.length table.table_new - 1 do try let newg = table.table_new.(newi) in match New.checksum newg with | None -> raise Not_found | Some c -> let oldi = Hashtbl.find old_checksums c in let oldg = table.table_old.(oldi) in Hashtbl.remove old_checksums c; result.(new_goal_index newg) <- (newg, Some (oldg, false)) with Not_found -> acc := mk_node table (New newi) :: !acc done; !acc in let add _ oldg acc = mk_node table (Old oldg) :: acc in let allgoals = Hashtbl.fold add old_checksums newgoals in Hashtbl.clear old_checksums; (* phase 2: pair goals according to shapes *) let compare e1 e2 = Pervasives.compare e1.shape e2.shape in let allgoals = List.sort compare allgoals in build_list allgoals; if allgoals <> [] then begin let dummy = let n = List.hd allgoals (* safe *) in 0, (n, n) in let pq = PQ.create ~dummy in let add x y = match x.elt, y.elt with | Old _, New _ | New _, Old _ -> PQ.add pq (lcp x.shape y.shape, (x, y)) | Old _, Old _ | New _, New _ -> () in iter_pairs add allgoals; (* FIXME: exit earlier, as soon as we get min(old,new) pairs *) while not (PQ.is_empty pq) do let _, (x, y) = PQ.extract_min pq in if x.valid && y.valid then begin let o, n = match x.elt, y.elt with | New n, Old o | Old o, New n -> o, n | _ -> assert false in dprintf "[assoc] new pairing@."; let newg = table.table_new.(n) in let oldg = table.table_old.(o) in result.(new_goal_index newg) <- newg, Some (oldg, true); if x.prev != x && y.next != y then add x.prev y.next; remove x; remove y end done end; let detached = List.fold_left (fun acc x -> if x.valid then match x.elt with | Old g -> table.table_old.(g) :: acc | New _ -> acc else acc) [] allgoals in Debug.dprintf debug "[assoc] %d detached goals@." (List.length detached); Array.to_list result, detached let simple_associate oldgoals newgoals = let rec aux acc o n = match o,n with | old, [] -> acc,old | [], n :: rem_n -> aux ((n,None)::acc) [] rem_n | o :: rem_o, n :: rem_n -> aux ((n,Some(o,true))::acc) rem_o rem_n in aux [] oldgoals newgoals let associate ~use_shapes = if use_shapes then associate else simple_associate end why3-0.88.3/src/session/compress_none.ml0000664000175100017510000000252313225666037020734 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) #13 "src/session/compress_none.ml" let compression_supported = false module type S = sig type out_channel val open_out: string -> out_channel val output_char: out_channel -> char -> unit val output_substring: out_channel -> string -> int -> int -> unit val output_string: out_channel -> string -> unit val close_out: out_channel -> unit type in_channel val open_in: string -> in_channel val input: in_channel -> bytes -> int -> int -> int val really_input: in_channel -> bytes -> int -> int -> unit val input_char: in_channel -> char val close_in: in_channel -> unit end module Compress_none = Pervasives module Compress_z = Pervasives why3-0.88.3/src/session/strategy_parser.mll0000664000175100017510000001135713225666037021461 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) { open Session open Strategy exception SyntaxError of string let error f = Printf.kbprintf (fun b -> let s = Buffer.contents b in Buffer.clear b; raise (SyntaxError s)) (Buffer.create 1024) f type label = { mutable defined: int option; temporary: int; } type 'a code = { env: 'a Session.env_session; mutable instr: instruction array; mutable next: int; labels: (string, label) Hashtbl.t; (* label name -> label *) mutable temp: int; } let create_code env = let h = Hashtbl.create 17 in Hashtbl.add h "exit" { defined = Some (-1); temporary = 0 }; { env = env; instr = Array.make 10 (Igoto 0); next = 0; temp = 1; labels = h; } let enlarge_code code = let old = code.instr in let n = Array.length old in code.instr <- Array.make (2 * n) (Igoto 0); Array.blit old 0 code.instr 0 n let add_instr code i = let n = code.next in if n = Array.length code.instr then enlarge_code code; code.instr.(n) <- i; code.next <- n + 1 let temp code = let t = code.temp in code.temp <- t + 1; t let define_label code l = let n = code.next in try let lab = Hashtbl.find code.labels l in if lab.defined = None then lab.defined <- Some n else error "duplicate label %s" l with Not_found -> let lab = { defined = Some n; temporary = temp code } in Hashtbl.add code.labels l lab let find_label code l = try let lab = Hashtbl.find code.labels l in lab.temporary with Not_found -> let t = temp code in Hashtbl.add code.labels l { defined = None; temporary = t }; t let prover code p = try let fp = Whyconf.parse_filter_prover p in Whyconf.filter_one_prover code.env.whyconf fp with | Whyconf.ProverNotFound _ -> error "Prover %S not installed or not configured" p | Whyconf.ProverAmbiguity _ -> error "Prover description %s is ambiguous" p let integer msg s = try int_of_string s with Failure _ -> error "unable to parse %s argument '%s'" msg s let transform code t = try ignore (Trans.lookup_transform t code.env.Session.env) with Trans.UnknownTrans _ -> try ignore (Trans.lookup_transform_l t code.env.Session.env) with Trans.UnknownTrans _-> error "transformation %S is unknown" t } let space = [' ' '\t' '\r' '\n'] let ident = [^ ' ' '\t' '\r' '\n' ':' '#']+ let integer = ['0'-'9']+ let goto = 'g' | "goto" let call = 'c' | "call" let transform = 't' | "transform" rule scan code = parse | space+ { scan code lexbuf } | '#' [^ '\n']* ('\n' | eof) { scan code lexbuf } | ident as id ':' { define_label code id; scan code lexbuf } | goto space+ (ident as id) { add_instr code (Igoto (find_label code id)); scan code lexbuf } | call space+ (ident as p) space+ (integer as t) space+ (integer as m) { let p = prover code p in let t = integer "timelimit" t in if t <= 0 then error "timelimit %d is invalid" t; let m = integer "memlimit" m in if m <= 0 then error "memlimit %d is invalid" m; add_instr code (Icall_prover (p.Whyconf.prover, t, m)); scan code lexbuf } | transform space+ (ident as t) space+ (ident as l) { transform code t; add_instr code (Itransform (t, find_label code l)); scan code lexbuf } | _ as c { let i = Lexing.lexeme_start lexbuf in error "syntax error on character '%c' at position %d" c i } | eof { () } { let parse env s = let code = create_code env in scan code (Lexing.from_string s); let label = Array.make code.temp 0 in let fill name lab = match lab.defined with | None -> error "label '%s' is undefined" name | Some n -> label.(lab.temporary) <- n in Hashtbl.iter fill code.labels; let solve = function | Icall_prover _ as i -> i | Itransform (t, n) -> Itransform (t, label.(n)) | Igoto n -> Igoto label.(n) in Array.map solve (Array.sub code.instr 0 code.next) } why3-0.88.3/src/session/xml.mll0000664000175100017510000001332013225666037017033 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) { type attributes = (string * string) list type element = { name : string; attributes : (string * string) list; elements : element list; } let mk_element name attrs elems = { name = name; attributes = attrs; elements = List.rev elems; } type t = { version : string; encoding : string; doctype : string; dtd : string; content : element; } let buf = Buffer.create 17 let rec pop_all group_stack element_stack = match group_stack with | [] -> element_stack | (elem,att,elems)::g -> let e = mk_element elem att element_stack in pop_all g (e::elems) exception Parse_error of string let parse_error s = raise (Parse_error s) let debug = Debug.register_info_flag "xml" ~desc:"Print@ the@ XML@ parser@ debugging@ messages." } let space = [' ' '\t' '\r' '\n'] let digit = ['0'-'9'] let letter = ['a'-'z' 'A'-'Z'] let ident = (letter | digit | '_') + let sign = '-' | '+' let integer = sign? digit+ let mantissa = ['e''E'] sign? digit+ let real = sign? digit* '.' digit* mantissa? let escape = ['\\''"''n''t''r'] rule xml_prolog fixattrs = parse | space+ { xml_prolog fixattrs lexbuf } | "" { xml_doctype fixattrs "1.0" "" lexbuf } | "" { xml_doctype fixattrs "1.0" "" lexbuf } | "'])* "?>" { Debug.dprintf debug "[Xml warning] prolog ignored@."; xml_doctype fixattrs "1.0" "" lexbuf } | _ { parse_error "wrong prolog" } and xml_doctype fixattrs version encoding = parse | space+ { xml_doctype fixattrs version encoding lexbuf } | "']* ">" { match elements fixattrs [] [] lexbuf with | [x] -> { version = version; encoding = encoding; doctype = doctype; dtd = ""; content = x; } | _ -> parse_error "there should be exactly one root element" } | _ { parse_error "wrong DOCTYPE" } and elements fixattrs group_stack element_stack = parse | space+ { elements fixattrs group_stack element_stack lexbuf } | '<' (ident as elem) { attributes fixattrs group_stack element_stack elem [] lexbuf } | "' { match group_stack with | [] -> Debug.dprintf debug "[Xml warning] unexpected closing Xml element `%s'@." celem; elements fixattrs group_stack element_stack lexbuf | (elem,att,stack)::g -> if celem <> elem then Debug.dprintf debug "[Xml warning] Xml element `%s' closed by `%s'@." elem celem; let e = mk_element elem att element_stack in elements fixattrs g (e::stack) lexbuf } | '<' { Debug.dprintf debug "[Xml warning] unexpected '<'@."; elements fixattrs group_stack element_stack lexbuf } | eof { match group_stack with | [] -> element_stack | (elem,_,_)::_ -> Debug.dprintf debug "[Xml warning] unclosed Xml element `%s'@." elem; pop_all group_stack element_stack } | _ as c { parse_error ("invalid element starting with " ^ String.make 1 c) } and attributes fixattrs groupe_stack element_stack elem acc = parse | space+ { attributes fixattrs groupe_stack element_stack elem acc lexbuf } | (ident as key) space* '=' { let v = value lexbuf in attributes fixattrs groupe_stack element_stack elem ((key,v)::acc) lexbuf } | '>' { let acc = fixattrs elem acc in elements fixattrs ((elem,acc,element_stack)::groupe_stack) [] lexbuf } | "/>" { let acc = fixattrs elem acc in let e = mk_element elem acc [] in elements fixattrs groupe_stack (e::element_stack) lexbuf } | _ as c { parse_error ("'>' expected, got " ^ String.make 1 c) } | eof { parse_error "unclosed element, `>' expected" } and value = parse | space+ { value lexbuf } | '"' { Buffer.clear buf; string_val lexbuf } | _ as c { parse_error ("invalid value starting with " ^ String.make 1 c) } | eof { parse_error "unterminated keyval pair" } and string_val = parse | '"' { Buffer.contents buf } | "<" { Buffer.add_char buf '<'; string_val lexbuf } | ">" { Buffer.add_char buf '>'; string_val lexbuf } | """ { Buffer.add_char buf '"'; string_val lexbuf } | "'" { Buffer.add_char buf '\''; string_val lexbuf } | "&" { Buffer.add_char buf '&'; string_val lexbuf } | [^ '"'] as c { Buffer.add_char buf c; string_val lexbuf } | eof { parse_error "unterminated string" } { let from_file ?(fixattrs=fun _ a -> a) f = let c = open_in f in let lb = Lexing.from_channel c in let t = xml_prolog fixattrs lb in close_in c; t } why3-0.88.3/src/session/session_tools.mli0000664000175100017510000000323213225666037021134 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University *) (* *) (* This software is distributed under the terms of the GNU Lesser *) (* General Public License version 2.1, with the special exception *) (* on linking described in file LICENSE. *) (* *) (********************************************************************) (** Generic tools that can be applied on sessions *) open Session val unknown_to_known_provers : Whyconf.config_prover Whyconf.Mprover.t -> Whyconf.prover -> Whyconf.Mprover.key list * Whyconf.Mprover.key list * Whyconf.Mprover.key list (** return others, same name, same version *) val convert_unknown_prover : keygen:'a keygen -> 'a env_session -> unit (** try to add new proof_attempt with known provers for all proof attempt with unknown provers *) val filter_proof_attempt : ?notify:'key notify -> ('key proof_attempt -> bool) -> 'key session -> unit (** remove all the proof attempts that do not satisfy the given predicate *) val transform_proof_attempt : ?notify:'key notify -> keygen:'key keygen -> 'key env_session -> string -> unit (** replace all the proof attempts of the given session by the application of the given registered transformation followed by a proof_attempt with the same prover and time limit (but undone) *) why3-0.88.3/src/server/0000775000175100017510000000000013225666037015351 5ustar guillaumeguillaumewhy3-0.88.3/src/server/writebuf.c0000664000175100017510000000435613225666037017354 0ustar guillaumeguillaume/********************************************************************/ /* */ /* The Why3 Verification Platform / The Why3 Development Team */ /* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University */ /* */ /* This software is distributed under the terms of the GNU Lesser */ /* General Public License version 2.1, with the special exception */ /* on linking described in file LICENSE. */ /* */ /********************************************************************/ #include #include #include #include #include "writebuf.h" pwritebuf init_writebuf(int capacity) { pwritebuf buf = (pwritebuf) malloc(sizeof(t_writebuf)); buf->data = NULL; buf->len = 0; buf->pointer = 0; buf->is_writing = false; buf->writequeue = init_queue(capacity); return buf; } char* prepare_write(pwritebuf b, int* size) { assert (can_write(b)); assert (has_write_data(b)); b->is_writing = true; *size = b->len - b->pointer; return (b->data + b->pointer); } void have_written(pwritebuf b, int size) { assert (b->is_writing); assert (b->pointer + size <= b->len); b->is_writing = false; if (b->pointer + size < b->len) { b->pointer += size; } else { free(b->data); b->pointer = 0; if (!queue_is_empty(b->writequeue)) { b->data = queue_pop(b->writequeue); b->len = strlen(b->data); } else { b->data = NULL; b->len = 0; } } } bool can_write(pwritebuf b) { return (!b->is_writing); } bool has_write_data(pwritebuf b) { return (b->data != NULL); } void push_write_data(pwritebuf b, char* data) { if (has_write_data (b)) { queue_push(b->writequeue, (void*) data); } else { b->data = data; b->pointer = 0; b->len = strlen(data); } } //delete all data associated with the buffer void free_writebuf(pwritebuf b) { free(b->data); while (!queue_is_empty(b->writequeue)) { free(queue_pop(b->writequeue)); } free_queue(b->writequeue); free(b); } why3-0.88.3/src/server/queue.c0000664000175100017510000000410613225666037016642 0ustar guillaumeguillaume/********************************************************************/ /* */ /* The Why3 Verification Platform / The Why3 Development Team */ /* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University */ /* */ /* This software is distributed under the terms of the GNU Lesser */ /* General Public License version 2.1, with the special exception */ /* on linking described in file LICENSE. */ /* */ /********************************************************************/ #include #include #include "queue.h" #include "string.h" void simple_push(pqueue q, void* elt); void resize_queue(pqueue q); pqueue init_queue(unsigned int capacity) { assert (capacity > 0); pqueue res = (pqueue) malloc(sizeof(t_queue)); res->capacity = capacity; res->len = 0; res->pointer = 0; res->data = (void**) malloc(sizeof(void*) * capacity); return res; } void* queue_pop(pqueue q) { void* tmp; assert (q->len > 0); tmp = q->data[q->pointer]; q->len--; q->pointer = (q->pointer + 1) % q->capacity; return tmp; } void simple_push(pqueue q, void* elt) { q->data[(q->pointer + q->len) % q->capacity] = elt; q->len++; } void resize_queue(pqueue q) { unsigned int old_cap, new_cap, old_p, new_p; old_cap = q->capacity; old_p = q->pointer; new_cap = 2 * old_cap; new_p = new_cap - old_cap + old_p; q->data = (void**) realloc(q->data, sizeof(void*) * new_cap); memcpy(q->data + new_p, q->data + old_p, sizeof(void*) * (old_cap - old_p)); q->capacity = new_cap; q->pointer = new_p; } void queue_push(pqueue q, void* elt) { if (q->len == q->capacity) { resize_queue(q); } simple_push(q, elt); } bool queue_is_empty(pqueue q) { return (q->len == 0); } unsigned int queue_length(pqueue q) { return (q->len); } void free_queue(pqueue q) { assert(queue_is_empty (q)); free(q->data); free(q); } why3-0.88.3/src/server/options.c0000664000175100017510000000471013225666037017212 0ustar guillaumeguillaume/********************************************************************/ /* */ /* The Why3 Verification Platform / The Why3 Development Team */ /* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University */ /* */ /* This software is distributed under the terms of the GNU Lesser */ /* General Public License version 2.1, with the special exception */ /* on linking described in file LICENSE. */ /* */ /********************************************************************/ #include #include #include #include #include "options.h" int parallel = 1; char* basename = NULL; bool logging = false; bool single_client = false; void parse_options(int argc, char **argv) { static struct option long_options[] = { /* These options set a flag. */ {"socket", required_argument, 0, 's'}, {"logging", no_argument, 0, 'l'}, {"single-client", no_argument, 0, 'i'}, {0, 0, 0, 0} }; while (1) { int option_index = 0; char c = 0; c = getopt_long (argc, argv, "j:s:", long_options, &option_index); /* Detect the end of the options. */ if (c == -1) break; switch (c) { case 0: /* The case where a long option has been detected for --socket should be handled like the short option, as a NULL value was given for the corresponding flag in long_options. */ exit (1); case 'i': single_client = true; break; case 'j': errno = 0; parallel = strtol(optarg, NULL, 10); if (errno == EINVAL) { printf("-j requires a number\n"); exit(1); } if (parallel <= 0 ) { printf("-j requires a positive number\n"); exit(1); } break; case 'l': logging = true; break; case 's': basename = optarg; break; case '?': /* getopt_long already printed an error message. */ exit (1); default: exit (1); } } if (optind < argc) { printf("extra arguments, stopping\n"); exit(1); } if (basename == NULL) { printf("need to specify a socket name using --socket\n"); exit(1); } } why3-0.88.3/src/server/readbuf.h0000664000175100017510000000355613225666037017143 0ustar guillaumeguillaume/**************************************************************************/ /* */ /* The Why3 Verification Platform / The Why3 Development Team */ /* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University */ /* */ /* This software is distributed under the terms of the GNU Lesser */ /* General Public License version 2.1, with the special exception */ /* on linking described in file LICENSE. */ /* */ /**************************************************************************/ #ifndef READBUF_H #define READBUF_H #include // Implement a read buffer, which is intended to be used for read/ReadFile // operations. Before doing a read of bytes, call with // as argument. After the read, register the number of bytes read using // . You can then inspect the read buffer and call "have taken" to // indicate how many bytes have been taken out. typedef struct { char* data; size_t len; size_t capacity; } t_readbuf, *preadbuf; // return a read buf of initial capacity preadbuf init_readbuf(size_t capacity); // return a pointer to a memory region which is unused and can act as a buffer // for a read operation reading up to size bytes char* prepare_read(preadbuf b, size_t size); //notify the buffer that bytes have been read void have_read(preadbuf b, size_t size); // allow the readbuf to delete the first byte of the buffer void have_taken(preadbuf b, size_t size); // allow the readbuf to all of the buffer void clear_readbuf(preadbuf b); // free the memory associated with the buffer void free_readbuf(preadbuf b); #endif why3-0.88.3/src/server/request.h0000664000175100017510000000276413225666037017223 0ustar guillaumeguillaume/**************************************************************************/ /* */ /* The Why3 Verification Platform / The Why3 Development Team */ /* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University */ /* */ /* This software is distributed under the terms of the GNU Lesser */ /* General Public License version 2.1, with the special exception */ /* on linking described in file LICENSE. */ /* */ /**************************************************************************/ #ifndef REQUEST_H #define REQUEST_H #include typedef struct { int key; char* id; int timeout; int memlimit; bool usestdin; char* cmd; // the command to execute int numargs; // the length of the following array char** args; // the arguments of the process to run (not including the command) } request, *prequest; //given a buffer str_req of meaningful data up to , parse the client data //and create a prequest object. Return NULL if there is a parse error. The //prequest object's field is set to the value of argument . prequest parse_request(char* str_req, int len, int key); //debug code void print_request(prequest r); //does *not* free the id of the request void free_request(prequest r); #endif why3-0.88.3/src/server/README.server0000664000175100017510000000663613225666037017551 0ustar guillaumeguillaumeThis is a VC server for Why3. It implements the following functionalities: * wait for connections on a unix domain socket (unix) or named pipe (windows) for clients * clients can send requests for a process to spawn, including timeout/memory limit * server will send back a filename containing the output of the process, as well as the time taken and the exit code Command line options ==================== -j the maximum number of processes to spawn in parallel --socket the name of the socket or named pipe Protocol ========= A client request is a single line which looks like this: commandkind;payload Where commandkind is a simple string and payload is a semicolon-separated list. There are currently three possible commands. The first command looks like this: run;id;timeout;memlimit;cmd;arg1;arg2;...;argn So the commandstring is "run". All items are separated by semicolons, and must not contain semicolons themselves (but may contain spaces). Their meaning is the following: id - a (ideally) unique identifier which identifies the request timeout - the allowed CPU time in seconds for this command; this must be number, 0 for unlimited memlimit - the allowed consumed memory for this command this must be number, 0 for unlimited cmd - the name of the executable to run arg(i) - the commandline arguments of the command to run The server does not acknowledge the receipt of this message. However, it will run the executable with its arguments and time/memory limit. When the executable has started, the server sends a message like this to the client who sent the 'run' request: S;id Character "S" followed by semi-colon to indicate that the request is started. When the executable has terminated, the server sends a message like this to the client who sent the 'run' request: F;id;exitcode;time;timeout;file Their meaning is the following: F - single F character indicating the task is finished id - the identifier of the request to which this answer belongs exitcode - the exitcode of the executed program time - the time taken by the executed program timeout - 0 for regular exit or crash, 1 for program interrupt through timeout file - the path to a file which contains the stdout and stderr of the executed program The second command is very similar: runstdin;id;timeout;memlimit;cmd;arg1;arg2;...;argn;filename The meaning of this command is identical to the "run" command, with the difference that an extra filename is given as the last argument to the command. This filename is not passed to the command as a commandline argument, instead it is "piped" into the stdin of the command. The third commmand is like this: parallel;num So the commandstring is "parallel". 'num' is a number greater or equal to 1. When this command is received, the server will allow to run up to 'num' processes in parallel from now on. Later 'parallel' commands can increase or decrease this number. There is no server answer to this command. There are two separate implementations on linux and windows, but both are very similar in structure and share some code (but should share much more). They are both essentially a single-threaded event loop, where the possible events are incoming clients, read/write operations on sockets, and terminating child processes. Lists of child processes and connected clients are maintained. why3-0.88.3/src/server/request.c0000664000175100017510000000757013225666037017216 0ustar guillaumeguillaume/********************************************************************/ /* */ /* The Why3 Verification Platform / The Why3 Development Team */ /* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University */ /* */ /* This software is distributed under the terms of the GNU Lesser */ /* General Public License version 2.1, with the special exception */ /* on linking described in file LICENSE. */ /* */ /********************************************************************/ #include #include #include #include "request.h" #include "options.h" #include "logging.h" //count the semicolons in , up to int count_semicolons(char* buf, int len); //in , starting from index and up to index , search for a //semicolon. If a semicolon is found at index i, copy the substring from // to , that is, excluding the semicolon, into , which //will be allocated to contain that much space + a null terminator. //If no semicolon is found, the part of starting from up to //is copied instead, and a null terminator added. int copy_up_to_semicolon(char* buf, int begin, int len, char** result); int count_semicolons(char* buf, int len) { int cnt = 0; int i = 0; for (i = 0; i < len; i++) { if (buf[i] == ';') { cnt++; } } return cnt; } int copy_up_to_semicolon(char* buf, int begin, int len, char** result) { int i; for (i = begin; i < len; i++) { if (buf[i] == ';') { break; } } (*result) = (char*) malloc(sizeof(char) * (i - begin + 1)); memcpy((*result), buf + begin, i - begin); (*result)[i - begin] = '\0'; if (i == len) { return 0; } else { return i + 1; } } prequest parse_request(char* str_req, int len, int key) { int numargs, semic, parallel_arg; int i = 0; int pos = 0; prequest req; char* tmp; bool runstdin = false; log_msg("received query"); log_msg_len(str_req, len); semic = count_semicolons(str_req, len); if (semic == 0) { return NULL; } // might be a 'parallel' command if (semic == 1) { pos = copy_up_to_semicolon (str_req, pos, len, &tmp); if (strncmp(tmp, "parallel", pos) == 0) { free(tmp); pos = copy_up_to_semicolon (str_req, pos, len, &tmp); parallel_arg = atoi(tmp); if (parallel_arg >= 1) { parallel = parallel_arg; } } free(tmp); return NULL; } numargs = semic - 4; if (numargs < 0) { return NULL; } pos = copy_up_to_semicolon(str_req, pos, len, &tmp); if (strncmp(tmp, "run", pos) != 0) { if (strncmp(tmp, "runstdin", pos) == 0) { runstdin = true; } else { free(tmp); return NULL; } } free(tmp); req = (prequest) malloc(sizeof(request)); req->key = key; req->numargs = numargs; req->usestdin = runstdin; pos = copy_up_to_semicolon(str_req, pos, len, &(req->id)); pos = copy_up_to_semicolon(str_req, pos, len, &tmp); req->timeout = atoi(tmp); free(tmp); pos = copy_up_to_semicolon(str_req, pos, len, &tmp); req->memlimit = atoi(tmp); free(tmp); pos = copy_up_to_semicolon(str_req, pos, len, &(req->cmd)); req->args = (char**)malloc(sizeof(char*) * (numargs)); for (i = 0; i < numargs; i++) { pos = copy_up_to_semicolon(str_req, pos, len, &(req->args[i])); } return req; } void print_request(prequest r) { int i; if (r) { printf("%s %d %d %s", r->id, r->timeout, r->memlimit, r->cmd); for (i = 0; i < r->numargs; i++) { printf(" %s", r->args[i]); } } else { printf(""); } } void free_request(prequest r) { int i; free(r->cmd); for (i = 0;i < r->numargs; i++) { free(r->args[i]); } free(r->args); free(r); } why3-0.88.3/src/server/arraylist.c0000664000175100017510000000434513225666037017535 0ustar guillaumeguillaume/********************************************************************/ /* */ /* The Why3 Verification Platform / The Why3 Development Team */ /* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University */ /* */ /* This software is distributed under the terms of the GNU Lesser */ /* General Public License version 2.1, with the special exception */ /* on linking described in file LICENSE. */ /* */ /********************************************************************/ #include #include #include "arraylist.h" #define INVALID_INDEX (-1) int list_lookup_index(plist l, int key); void list_resize(plist l); plist init_list(int capacity) { plist result; result = (plist) malloc (sizeof(t_list)); result->capacity = capacity; result->len = 0; result->key = (int*) malloc(sizeof(int) * capacity); result->data = (void**) malloc(sizeof(void*) * capacity); return result; } bool list_is_empty(plist l) { return (l->len == 0); } int list_lookup_index(plist l, int key) { int i; for (i = 0; i < l->len; i++) { if (l->key[i] == key) { return i; } } return INVALID_INDEX; } void* list_lookup(plist l, int key) { int i = list_lookup_index(l, key); if (i == INVALID_INDEX) { return NULL; } else { return l->data[i]; } } void list_remove(plist l, int key) { int i = list_lookup_index(l, key); if (i != INVALID_INDEX) { assert (!list_is_empty(l)); l->len--; l->key[i] = l->key[l->len]; l->data[i] = l->data[l->len]; } } void free_list(plist l) { assert (list_is_empty(l)); free(l->data); free(l->key); free(l); } void list_resize(plist l) { int newcap = l->capacity * 2; l->capacity = newcap; l->key = (int*) realloc(l->key, sizeof(int) * newcap); l->data = (void**) realloc(l->data, sizeof(void*) * newcap); } void list_append(plist l, int key, void* elt) { if (l->len == l->capacity) { list_resize(l); } l->key[l->len] = key; l->data[l->len] = elt; l->len++; } int list_length(plist l) { return l->len; } why3-0.88.3/src/server/logging.h0000664000175100017510000000164213225666037017153 0ustar guillaumeguillaume/**************************************************************************/ /* */ /* The Why3 Verification Platform / The Why3 Development Team */ /* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University */ /* */ /* This software is distributed under the terms of the GNU Lesser */ /* General Public License version 2.1, with the special exception */ /* on linking described in file LICENSE. */ /* */ /**************************************************************************/ #ifndef LOGGING_H #define LOGGING_H void init_logging(); void log_msg(char* s); void log_msg_len(char* s, int len); void logging_shutdown(char* s); #endif why3-0.88.3/src/server/cpulimit-win.c0000664000175100017510000001502213225666037020136 0ustar guillaumeguillaume/********************************************************************/ /* */ /* The Why3 Verification Platform / The Why3 Development Team */ /* Copyright 2010-2018 -- Inria - CNRS - Paris-Sud University */ /* */ /* This software is distributed under the terms of the GNU Lesser */ /* General Public License version 2.1, with the special exception */ /* on linking described in file LICENSE. */ /* */ /********************************************************************/ /* $Id: cpulimit-win.c,v 1.3 2009-12-09 08:28:00 nrousset Exp $ */ #ifdef _WIN32 #include #include #include #include #include static void ErrorReport(char *function) { char *message; DWORD error = GetLastError(); FormatMessage( FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM, NULL, error, MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (LPTSTR) &message, 0, NULL ); printf("Fatal: %s failed with error %ld: %s", function, error, message); LocalFree(message); } static PROCESS_INFORMATION pi; static HANDLE ghJob; void terminates(void) { TerminateProcess(pi.hProcess, 10); CloseHandle(pi.hProcess); CloseHandle(pi.hThread); CloseHandle(ghJob); } BOOL WINAPI ConsoleHandler(DWORD CEvent) { /* switch(CEvent) { case CTRL_C_EVENT: case CTRL_BREAK_EVENT: case CTRL_CLOSE_EVENT: case CTRL_LOGOFF_EVENT: case CTRL_SHUTDOWN_EVENT:*/ printf("Got signal from console: killing subprocess\n"); fflush(stdout); terminates(); return TRUE; } int main(int argc, char *argv[]) { STARTUPINFO si; FILETIME ft_start, ft_stop, ft_system, ft_user; ULARGE_INTEGER ull_start, ull_stop, ull_system, ull_user; double cpu_time, wall_time; int i,showtime,hidetime; unsigned ex; unsigned long s = 0; // length of args after concat char * p; // command line parameter long long time_limit_seconds=0,memory_limit_MiB=0; unsigned error = 0; JOBOBJECT_EXTENDED_LIMIT_INFORMATION limits; ghJob = CreateJobObject(NULL,NULL); if(!ghJob) ErrorReport("CreateJobObject"); ZeroMemory(&si, sizeof(si)); si.cb = sizeof(si); ZeroMemory(&pi, sizeof(pi)); SetConsoleCtrlHandler(&ConsoleHandler,TRUE); if (argc<5) error=1; else { time_limit_seconds = strtol (argv[1], &p, 10); if (*p!='\0') error=1; memory_limit_MiB = strtol (argv[2], &p, 10); if (*p!='\0') error=1; showtime = !strncmp("-s",argv[3],3); hidetime = !strncmp("-h",argv[3],3); } if (error || !(showtime || hidetime)) { fprintf(stderr, "usage: %s