why3-1.2.1/0000755000175100017510000000000013555524613013152 5ustar guillaumeguillaumewhy3-1.2.1/.merlin.in0000644000175100017510000000122113555524575015051 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/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/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@ @LABLGTKPKG@ @META_OCAMLGRAPH@ @JSOFOCAMLPKG@ why3-1.2.1/share/0000755000175100017510000000000013555524575014263 5ustar guillaumeguillaumewhy3-1.2.1/share/why3session.dtd0000644000175100017510000000366713555524575017272 0ustar guillaumeguillaume why3-1.2.1/share/provers-detection-data.conf0000644000175100017510000004023313555524575021517 0ustar guillaumeguillaume[ATP alt-ergo] name = "Alt-Ergo" exec = "alt-ergo" exec = "alt-ergo-2.3.0" exec = "alt-ergo-2.2.0" exec = "alt-ergo-2.1.0" exec = "alt-ergo-2.0.0" version_switch = "-version" version_regexp = "^\\([0-9.]+\\)$" version_ok = "2.3.0" version_ok = "2.2.0" version_ok = "2.1.0" version_ok = "2.0.0" version_bad = "1.30" version_bad = "1.01" version_bad = "0.99.1" version_bad = "0.95.2" command = "%e -timelimit %t %f" command_steps = "%e -steps-bound %S %f" driver = "alt_ergo" editor = "altgr-ergo" use_at_auto_level = 1 # CVC4 version >= 1.6, with counterexamples [ATP cvc4-ce] name = "CVC4" alternative = "counterexamples" exec = "cvc4" exec = "cvc4-1.6" exec = "cvc4-1.7" version_switch = "--version" version_regexp = "This is CVC4 version \\([^ \n\r]+\\)" version_ok = "1.6" version_ok = "1.7" driver = "cvc4_16_counterexample" # --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" # CVC4 version >= 1.6 [ATP cvc4] name = "CVC4" exec = "cvc4" exec = "cvc4-1.6" exec = "cvc4-1.7" version_switch = "--version" version_regexp = "This is CVC4 version \\([^ \n\r]+\\)" version_ok = "1.6" version_ok = "1.7" driver = "cvc4_16" # --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=%t000 --lang=smt2 %f" command_steps = "%e --stats --rlimit=%S --lang=smt2 %f" use_at_auto_level = 1 # CVC4 version = 1.5, with counterexamples [ATP cvc4-ce] name = "CVC4" alternative = "counterexamples" exec = "cvc4" exec = "cvc4-1.5" version_switch = "--version" version_regexp = "This is CVC4 version \\([^ \n\r]+\\)" version_ok = "1.5" driver = "cvc4_15_counterexample" # --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" # CVC4 version 1.5 [ATP cvc4] 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=%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=%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=%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.6.0, with counterexamples and incremental usage [ATP z3-ce] name = "Z3" alternative = "counterexamples" exec = "z3" exec = "z3-4.8.6" exec = "z3-4.8.5" exec = "z3-4.8.4" exec = "z3-4.8.3" exec = "z3-4.8.1" exec = "z3-4.7.1" 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.8.6" version_ok = "4.8.5" version_ok = "4.8.4" version_ok = "4.8.3" version_ok = "4.8.1" version_ok = "4.7.1" version_ok = "4.6.0" version_ok = "4.5.0" version_old = "4.4.1" version_old = "4.4.0" driver = "z3_440_counterexample" # -t sets the time limit per query command = "%e -smt2 -t:%t000 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.4.0, with BV support [ATP z3] name = "Z3" exec = "z3" exec = "z3-4.8.6" exec = "z3-4.8.5" exec = "z3-4.8.4" exec = "z3-4.8.3" exec = "z3-4.8.1" exec = "z3-4.7.1" 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.8.6" version_ok = "4.8.5" version_ok = "4.8.4" version_ok = "4.8.3" version_ok = "4.8.1" version_ok = "4.7.1" 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 -T:%t 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-nobv] name = "Z3" alternative = "noBV" exec = "z3" exec = "z3-4.8.6" exec = "z3-4.8.5" exec = "z3-4.8.4" exec = "z3-4.8.3" exec = "z3-4.8.1" exec = "z3-4.7.1" 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.8.6" version_ok = "4.8.5" version_ok = "4.8.4" version_ok = "4.8.3" version_ok = "4.8.1" version_ok = "4.7.1" 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 -T:%t 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_old = "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" [ITP coq] name = "Coq" support_library = "%l/coq/version" exec = "coqtop" version_switch = "-v" version_regexp = "The Coq Proof Assistant, version \\([^ \n]+\\)" version_ok = "^8\.9\.[0-1]$" version_ok = "^8\.8\.[0-2]$" version_ok = "^8\.7\.[0-2]$" version_ok = "8.6.1" version_ok = "8.6" version_old = "^8\.5pl[1-3]$" version_old = "8.5" command = "%e -batch -R %l/coq Why3 -l %f" driver = "coq" editor = "coqide" [ITP pvs] name = "PVS" support_library = "%l/pvs/version" exec = "pvs" version_switch = "-version" version_regexp = "PVS Version \\([^ \n]+\\)" version_ok = "6.0" version_bad = "^[0-5]\..+$" command = "%l/why3-call-pvs %l/pvs 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 = "2018" version_bad = "2017" version_bad = "2016-1" command = "%e why3 -b %f" driver = "isabelle2018" 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 = "2018" version_bad = "2016-1" 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 -R %l/coq Why3 %f" [editor proofgeneral-coq] name = "Emacs/ProofGeneral/Coq" command = "emacs --eval \"(setq coq-load-path '((\\\"%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-1.2.1/share/zsh/0000755000175100017510000000000013555524575015067 5ustar guillaumeguillaumewhy3-1.2.1/share/zsh/_why30000644000175100017510000001140013555524575016037 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-1.2.1/share/strategies.conf0000644000175100017510000000175713555524575017316 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 = "Auto Level 0" desc = "Simple@ automatic@ run@ of@ main@ provers" shortcut = "b" code = " start: c Alt-Ergo,1.01, 1 1000 c CVC4,1.4, 1 1000 c Z3,4.4.1, 1 1000 t split_goal_wp start c Alt-Ergo,1.01, 10 4000 c CVC4,1.4, 10 4000 c Z3,4.4.1, 10 4000" [strategy] name = "Auto Level 1" desc = "Automatic@ run@ of@ provers@ and@ most@ useful@ transformations" code = " start: c Alt-Ergo,1.01, 1 1000 c CVC4,1.4, 1 1000 c Z3,4.4.1, 1 1000 next: t split_goal_wp start c Alt-Ergo,1.01, 5 2000 c CVC4,1.4, 5 2000 c Z3,4.4.1, 5 2000 t introduce_premises afterintro g inline afterintro: t split_goal_wp start inline: t inline_goal afterinline g longtime afterinline: t split_goal_wp start longtime: c Alt-Ergo,1.01, 30 4000 c CVC4,1.4, 30 4000 c Z3,4.4.1, 30 4000" why3-1.2.1/share/latex/0000755000175100017510000000000013555524575015400 5ustar guillaumeguillaumewhy3-1.2.1/share/latex/why3lang.sty0000644000175100017510000000261313555524575017677 0ustar guillaumeguillaume \RequirePackage{listings} \RequirePackage{amssymb} \lstdefinelanguage{why3} { basicstyle=\ttfamily,% morekeywords=[1]{abstract,absurd,alias,any,assert,assume,at,axiom,break,by,% check,clone,coinductive,constant,continue,diverges,do,done,downto,% else,end,ensures,exception,exists,export,false,for,forall,fun,% function,ghost,goal,if,import,in,inductive,invariant,label,lemma,% let,loop,match,meta,module,mutable,not,old,% predicate,private,pure,raise,raises,reads,rec,ref,requires,result,return,% returns,scope,so,then,theory,to,true,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-1.2.1/share/vim/0000755000175100017510000000000013555524575015056 5ustar guillaumeguillaumewhy3-1.2.1/share/vim/ftdetect/0000755000175100017510000000000013555524575016660 5ustar guillaumeguillaumewhy3-1.2.1/share/vim/ftdetect/why3.vim0000644000175100017510000000006413555524575020267 0ustar guillaumeguillaumeau BufRead,BufNewFile *.why,*.mlw set filetype=why3 why3-1.2.1/share/vim/syntax/0000755000175100017510000000000013555524575016404 5ustar guillaumeguillaumewhy3-1.2.1/share/vim/syntax/why3.vim0000644000175100017510000002061213555524575020014 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,whyScopeContents,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=whyKeyChar start="(" matchgroup=whyKeyChar end=")" contains=ALLBUT,@whyContained,whyParenErr syn region whyEncl transparent matchgroup=whyKeyChar start="{" matchgroup=whyKeyChar end="}" contains=ALLBUT,@whyContained,whyBraceErr syn region whyEncl transparent start="\[" end="\]" contains=ALLBUT,@whyContained,whyBrackErr " Comments syn region whyComment start="(\*" end="\*)" contains=whyComment,whyTodo syn match whyOperator "(\*)" 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 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=whyModuleContents syn region whyModule matchgroup=whyKeyword start="\" matchgroup=whyModSpec end="\<\u\(\w\|'\)*\>" contains=@whyAllErrs,whyComment skipwhite skipempty nextgroup=whyModuleContents syn region whyScope matchgroup=whyKeyword start="\" matchgroup=whyModSpec end="\<\u\(\w\|'\)*\>" contains=@whyAllErrs,whyComment,whyImport skipwhite skipempty nextgroup=whyModuleContents syn region whyModuleContents start="" 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 syn keyword whyExport contained export syn keyword whyImport contained import syn region whyNone matchgroup=whyKeyword start="\" matchgroup=whyModSpec end="\<\(\u\(\w\|'\)*\.\)*\u\(\w\|'\)*\>" contains=@whyAllErrs,whyComment syn region whyNone matchgroup=whyKeyword start="\<\(axiom\|lemma\|goal\)\>" 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 abstract any break continue syn keyword whyKeyword exception fun ghost label syn keyword whyKeyword model mutable partial private syn keyword whyKeyword raise rec return 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 alias assert assume check diverges ensures invariant syn keyword whySpec pure raises reads requires returns variant writes at old 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\|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 whyScopeSync grouphere whyScope "\" syn sync match whyScopeSync groupthere whyScope "\" " 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 Operator HiLink whyAnyVar Operator HiLink whyOperator Operator 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-1.2.1/share/whyitp/0000755000175100017510000000000013555524575015607 5ustar guillaumeguillaumewhy3-1.2.1/share/whyitp/README0000644000175100017510000000044113555524575016466 0ustar guillaumeguillaumeTo use Proof General with Why3ITP add the following lines in your .emacs after the line loading proof-general itself. (autoload 'whyitp-mode "(MY_PATH_TO_WHY3)/share/whyitp/whyitp.el" "Major mode for Why3 ITP." t) (setq auto-mode-alist (cons '("\\.whyitp" . whyitp-mode) auto-mode-alist))why3-1.2.1/share/whyitp/whyitp.el0000644000175100017510000000525213555524575017461 0ustar guillaumeguillaume(eval-and-compile (require 'proof-site) ; compilation for whyitp (proof-ready-for-assistant 'whyitp)) (require 'proof) (defun set-vars () "configure Proof General scripting for Why3ITP" (setq proof-terminal-string "\n" ;; TODO se mettre d'accord sur un proof terminal proof-script-comment-start "(*" proof-script-comment-end "*)" proof-showproof-command "g\n" proof-undo-n-times-cmd "pg_repeat undo %s;" proof-auto-multiple-files nil ;; no multiple files )) (defun set-shell-vars() "configure Proof General shell for Why3ITP" (setq proof-shell-start-goals-regexp "====================== Task =====================" proof-shell-restart-cmd "r\n" proof-shell-end-goals-regexp "=================================================" proof-shell-quit-cmd "q\n" proof-shell-annotated-prompt-regexp "^> " proof-shell-error-regexp "\\*\\*\\*\\|^.*Error:\\|^uncaught exception \\|^Exception- " proof-shell-init-cmd "fun pg_repeat f 0 = () | pg_repeat f n = (f(); pg_repeat f (n-1));")) (defun set-prog-name () (setq proof-prog-name (concat "why3shell " (replace-regexp-in-string ".whyitp" ".why" (buffer-file-name ()))))) (define-derived-mode whyitp-mode proof-mode "Why3ITP script" nil (set-vars) (set-prog-name) (proof-config-done)) (define-derived-mode whyitp-shell-mode proof-shell-mode "Why3ITP shell" nil (set-shell-vars) (proof-shell-config-done)) (define-derived-mode whyitp-response-mode proof-response-mode "Why3ITP response" nil (proof-response-config-done)) (define-derived-mode whyitp-goals-mode proof-goals-mode "Why3ITP goals" nil (proof-goals-config-done)) ;; redo "undo" and "go to" proof general command for why3itp (defun proof-undo-last-successful-command () (interactive) (let (lastspan) ;; (save-excursion ;; (unless (proof-locked-region-empty-p) (if (setq lastspan (span-at-before (proof-unprocessed-begin) 'type)) (progn (goto-char (span-start lastspan)) (proof-goto-point)) (error "Nothing to undo!")))) (defun proof-goto-point () "Undo last successful command at end of locked region." (interactive) (when proof-shell-busy (proof-interrupt-process) (proof-shell-wait)) (if (not (proof-shell-live-buffer)) (proof-shell-start) ;; start if not running ;; otherwise clear context (proof-script-remove-all-spans-and-deactivate) (proof-shell-clear-state) (with-current-buffer proof-shell-buffer (delete-region (point-min) (point-max))) (proof-minibuffer-cmd "r\n") (when proof-shell-busy (proof-shell-wait)) (proof-assert-until-point))) (provide 'whyitp) why3-1.2.1/share/emacs/0000755000175100017510000000000013555524575015353 5ustar guillaumeguillaumewhy3-1.2.1/share/emacs/why3.el0000644000175100017510000001511413555524575016571 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 `(,(why3-regexp-opt '("invariant" "variant" "diverges" "requires" "ensures" "pure" "returns" "raises" "reads" "writes" "alias" "assert" "assume" "check")) . font-lock-type-face) `(,(why3-regexp-opt '("use" "clone" "scope" "import" "export" "coinductive" "inductive" "external" "constant" "function" "predicate" "val" "exception" "axiom" "lemma" "goal" "type" "mutable" "abstract" "private" "any" "match" "let" "rec" "in" "if" "then" "else" "begin" "end" "while" "for" "to" "downto" "do" "done" "loop" "absurd" "ghost" "partial" "raise" "ref" "return" "break" "continue" "try" "with" "theory" "uses" "module" "fun" "at" "old" "true" "false" "forall" "exists" "label" "by" "so" "meta" "as")) . 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 (let ((st (make-syntax-table))) ; identifiers (modify-syntax-entry ?' "w" st) (modify-syntax-entry ?_ "w" st) ; strings (modify-syntax-entry ?\" "\"" st) ; comments (modify-syntax-entry ?\( "()1n" st) (modify-syntax-entry ?\) ")(4n" st) (modify-syntax-entry ?* ". 23" st) st) "Syntax table for why3-mode") ;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)))))) (defconst why3--syntax-propertize (syntax-propertize-rules ; attributes: [@foo] ("\\(\\[\\)@[^]]*\\(]\\)" (1 "!]") (2 "![")) ; star: (*) ("\\((\\)\\*\\()\\)" (1 "()") (2 ")(")) )) ;; setting the mode (defun why3-mode () "Major mode for editing Why3 programs. \\{why3-mode-map}" (interactive) (kill-all-local-variables) ; hilight (set-syntax-table why3-mode-syntax-table) (set (make-local-variable 'font-lock-defaults) '(why3-font-lock-keywords)) (set (make-local-variable 'font-lock-multiline) t) ; 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) "*)") (setq-local syntax-propertize-function why3--syntax-propertize) ; 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-1.2.1/share/lang/0000755000175100017510000000000013555524575015204 5ustar guillaumeguillaumewhy3-1.2.1/share/lang/why3.lang0000644000175100017510000002052213555524575016742 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-1.2.1/src/trywhy3/README.md0000644000175100017510000000540213555524575016661 0ustar guillaumeguillaumeInstructions to build TryWhy3 ----------------------------- * Install Ace - get the sources of Ace and put them in directory `src/trywhy3/` cd src/trywhy3 git clone git://github.com/ajaxorg/ace-builds.git - copy the `mode-why3.js` file to the `ace-builds/src-min-noconflict/` directory: cp mode-why3.js ace-builds/src-min-noconflict * Install Alt-Ergo - get the sources of Alt-Ergo 2.0 and put them in directory `src/trywhy3/`, e.g., in `src/trywhy3/alt-ergo/` cd src/trywhy3 wget http://alt-ergo.ocamlpro.com/http/alt-ergo-2.0.0/alt-ergo-2.0.0.tar.gz tar xzf alt-ergo-2.0.0.tar.gz mv alt-ergo-2.0.0 alt-ergo - apply the patch `alt-ergo.patch` cd alt-ergo patch -p1 < ../alt-ergo.patch - compile Alt-Ergo ./configure make byte * If necessary, change the following line of `Makefile.in` to point to Alt-Ergo sources ALTERGODIR=src/trywhy3/alt-ergo * [optional] If you want to build a standalone trywhy3 that can be run without a web server, the example files must be present at compile time. See the step 'To add predefined examples' in the 'customization' section below and populate the `examples/` directory of the trywhy3 source directory accordingly *before* building trywhy3. * Compile with make trywhy3 * You can build a package with make trywhy3_package this creates a tarball containing a directory `trywhy3/` which you can put on a web server. You may want to add a symbolic link from `index.html` to `trywhy3.html` (or rename the file). Customization ------------- * Install a file `trywhy3_help.html` that will be shown when clicking the help button. * To change the theme used by the ace editor widget, add the relevant `theme-*.js` file to the `ace-builds/src-min-noconflict/` directory and update the variable definition at the top of the `trywhy3.html` file. * To change the look and feel of the rest of the application, edit the file `trywhy3_custom.css`. * To add some predefined examples, put some `.mlw` or `.why` files in the `examples/` subdirectory and generate an index as follows: cp some_file.mlw examples/ cd examples/ ../gen_index.sh *.mlw > index.txt * [optional] If you want trywhy3 to only use its embedded files, change the variable declaration `var load_embedded_files = false;` to `var load_embedded_files = true;` in the header section of `trywhy3.html`. Note that this is the default behavior when `trywhy3.html` is opened from a `file://` URL rather than a `http(s)://` URL, regardless of the value of the `load_embedded_files` variable. why3-1.2.1/src/trywhy3/style.css0000644000175100017510000000727213555524575017263 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-1.2.1/src/trywhy3/gen_index.sh0000755000175100017510000000047213555524575017703 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-1.2.1/src/trywhy3/trywhy3.html0000644000175100017510000001712113555524575017722 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-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 the file LICENSE.

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

why3-1.2.1/src/trywhy3/.merlin0000644000175100017510000000002713555524575016667 0ustar guillaumeguillaumePKG ocplib-simplex REC why3-1.2.1/src/printer/0000755000175100017510000000000013555524575015433 5ustar guillaumeguillaumewhy3-1.2.1/src/printer/yices.ml0000644000175100017510000002624213555524575017107 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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.negative_int_support = Number.Number_custom "(- 0 %a)"; 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.negative_real_support = Number.Number_custom "(- 0 %a)"; 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, _, _) -> 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-1.2.1/src/printer/gappa.ml0000644000175100017510000004460013555524575017061 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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" (op_prefix "-"); real_minus := find_th env "real" "Real" (op_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.negative_int_support = Number.Number_custom "-%a"; 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.negative_real_support = Number.Number_custom "-%a"; 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 -> asprintf "%a" (Number.print number_format) c | Tapp (ls, [{ t_node = Tconst c}]) when ls_equal ls !int_minus || ls_equal ls !real_minus -> asprintf "-%a" (Number.print number_format) c | 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", [op_infix "<="], [ PatApp (["real"], "Abs", ["abs"], [ PatApp (["real"], "Real", [op_infix "-"], [ PatHole 0; PatHole 1])]); PatApp (["real"], "Real", [op_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, _, _) -> 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-1.2.1/src/printer/alt_ergo.mli0000644000175100017510000000130713555524575017733 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/printer/mathematica.ml0000644000175100017510000004531713555524575020254 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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" (op_prefix "-"); real_minus := find_th env "real" "Real" (op_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.negative_int_support = Number.Number_default; 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.negative_real_support = Number.Number_default; 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 -> asprintf "%a" print_const c | Tapp(ls, [{ t_node = Tconst c}]) when ls_equal ls !int_minus || ls_equal ls !real_minus -> asprintf "-%a" print_const c | _ -> raise Not_found let rel_error_pat = PatApp (["real"], "Real", [op_infix "<="], [ PatApp (["real"], "Abs", ["abs"], [ PatApp (["real"], "Real", [op_infix "-"], [ PatHole 0; PatHole 1])]); PatApp (["real"], "Real", [op_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, _, _) -> 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-1.2.1/src/printer/simplify.mli0000644000175100017510000000130713555524575017773 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/printer/cvc3.mli0000644000175100017510000000130713555524575016775 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/printer/gappa.mli0000644000175100017510000000130713555524575017227 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/printer/isabelle.ml0000644000175100017510000004307313555524575017554 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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.negative_int_support = Number.Number_unsupported; 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.negative_real_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" 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 use T 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.Use 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-1.2.1/src/printer/smtv1.ml0000644000175100017510000002331713555524575017045 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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.negative_int_support = Number.Number_default; 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.negative_real_support = Number.Number_default; 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, _, _) -> 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-1.2.1/src/printer/smtv2.ml0000644000175100017510000006647213555524575017057 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 Wstdlib 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." let debug_incremental = Debug.register_info_flag "force_incremental" ~desc:"Force@ incremental@ mode@ for@ smtv2@ provers" (** 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"; "rem"; "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"; (* Counterexamples specific keywords *) "model"; ] in let san = sanitizer char_to_alpha char_to_alnumus in create_ident_printer bls ~sanitizer:san type version = V20 | V26 type info = { info_syn : syntax_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; mutable list_projs : Ident.ident Mstr.t; mutable list_field_def: Ident.ident Mstr.t; info_version : version; meta_model_projection : Sls.t; meta_record_def : Sls.t; mutable list_records : ((string * string) list) Mstr.t; (* For algebraic type counterexamples: constructors with no arguments can be misunderstood for variables *) mutable noarg_constructors: string list; info_cntexample_need_push : bool; info_cntexample: bool; info_incremental: bool; info_set_incremental: bool; mutable info_labels: Sattr.t Mstr.t; mutable incr_list: (prsymbol * term) list; } 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 s -> begin match info.info_version with | V20 -> unsupported "smtv2: you must encode type polymorphism" | V26 -> fprintf fmt "%s" (id_unique info.info_printer s.tv_name) end | 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 collect_model_ls info ls = if Sls.mem ls info.meta_model_projection then info.list_projs <- Mstr.add (sprintf "%a" (print_ident info) ls.ls_name) ls.ls_name info.list_projs; if Sls.mem ls info.meta_record_def then info.list_field_def <- Mstr.add (sprintf "%a" (print_ident info) ls.ls_name) ls.ls_name info.list_field_def; if ls.ls_args = [] && (relevant_for_counterexample ls.ls_name) then let t = t_app ls [] ls.ls_value in info.info_model <- add_model_element (t_attr_set ?loc:ls.ls_name.id_loc ls.ls_name.id_attrs t) info.info_model let number_format = { Number.long_int_support = true; Number.extra_leading_zeros_support = false; Number.negative_int_support = Number.Number_default; 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.negative_real_support = Number.Number_default; 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 check_for_counterexample t 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) -> 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 ) *) | [] -> let str_ls = sprintf "%a" (print_ident info) ls.ls_name in let cur_var = info.info_labels in let new_var = update_info_labels str_ls cur_var t ls in let () = info.info_labels <- new_var in 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 attrs = (* match vc_term_info.vc_func_name with | None -> *) ls.ls_name.id_attrs (* | Some _ -> model_trace_for_postcondition ~attrs:ls.ls_name.id_attrs info.info_vc_term *) in let _t_check_pos = t_attr_set ~loc attrs 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 check_for_counterexample f 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 match ls.ls_args with (* only in SMTLIB 2.5 | [] -> fprintf fmt "@[(declare-const %a %a)@]@\n@\n" (print_ident info) ls.ls_name (print_type_value info) ls.ls_value *) | _ -> 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 info = (* Prints the content of info.info_model *) let info_model = info.info_model in if not (S.is_empty info_model) && info.info_cntexample then begin let model_map = S.fold (fun f acc -> let s = asprintf "%a" (print_fmla info) f in Mstr.add s f acc) info_model 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 Mstr.empty (* TODO factor out print_prop ? *) let print_prop info fmt pr f = fprintf fmt "@[;; %s@\n(assert@ %a)@]@\n@\n" pr.pr_name.id_string (* FIXME? collisions *) (print_fmla info) f let add_check_sat info fmt = if info.info_cntexample && info.info_cntexample_need_push then fprintf fmt "@[(push)@]@\n"; fprintf fmt "@[(check-sat)@]@\n"; (* unfortunately we can't do that unconditionally, since it will make CVC4 fail and immediately exit if last answer was not 'unknown' *) (* fprintf fmt "@[(get-info :reason-unknown)@]@\n"; *) if info.info_cntexample then fprintf fmt "@[(get-model)@]@\n" let rec property_on_incremental2 _ f = match f.t_node with | Tquant _ -> true | Teps _ -> true | _ -> Term.t_fold property_on_incremental2 false f let property_on_incremental2 f = property_on_incremental2 false f (* TODO if the property doesnt begin with quantifier, then we print it first. Else, we print it afterwards. *) let print_incremental_axiom info fmt = let l = info.incr_list in List.iter (fun (pr, f) -> if not (property_on_incremental2 f) then print_prop info fmt pr f; ) l; add_check_sat info fmt; List.iter (fun (pr, f) -> if property_on_incremental2 f then print_prop info fmt pr f) l; add_check_sat info fmt let print_prop_decl vc_loc args info fmt k pr f = match k with | Paxiom -> if info.info_incremental then info.incr_list <- (pr, f) :: info.incr_list else print_prop info fmt pr 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; add_check_sat info fmt; (* If in incremental mode, we empty the list of axioms we stored *) if info.info_incremental then print_incremental_axiom info fmt; let model_list = print_info_model info in args.printer_mapping <- { lsymbol_m = args.printer_mapping.lsymbol_m; vc_term_loc = vc_loc; queried_terms = model_list; list_projections = info.list_projs; list_fields = info.list_field_def; Printer.list_records = info.list_records; noarg_constructors = info.noarg_constructors; set_str = info.info_labels; } | Plemma -> assert false let print_constructor_decl info fmt (ls,args) = let field_names = (match args with | [] -> fprintf fmt "(%a)" (print_ident info) ls.ls_name; let cons_name = sprintf "%a" (print_ident info) ls.ls_name in info.noarg_constructors <- cons_name :: info.noarg_constructors; [] | _ -> fprintf fmt "@[(%a@ " (print_ident info) ls.ls_name; let field_names, _ = List.fold_left2 (fun (acc, i) ty pr -> let field_name = match pr with | Some pr -> let field_name = sprintf "%a" (print_ident info) pr.ls_name in fprintf fmt "(%s" field_name; let trace_name = try let attr = Sattr.choose (Sattr.filter (fun l -> Strings.has_prefix "model_trace:" l.attr_string) pr.ls_name.id_attrs) in Strings.remove_prefix "model_trace:" attr.attr_string with Not_found -> "" in (field_name, trace_name) | None -> let field_name = sprintf "%a_proj_%d" (print_ident info) ls.ls_name i in (* FIXME: is it possible to generate 2 same value with _proj_ inside it ? Need sanitizing and uniquifying ? *) fprintf fmt "(%s" field_name; (field_name, "") in fprintf fmt " %a)" (print_type info) ty; (field_name :: acc, succ i)) ([], 1) ls.ls_args args in fprintf fmt ")@]"; List.rev field_names) in if Strings.has_prefix "mk " ls.ls_name.id_string then begin info.list_records <- Mstr.add (sprintf "%a" (print_ident info) ls.ls_name) field_names info.list_records; end 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_data_def info fmt (ts,cl) = if ts.ts_args <> [] then let args = List.map (fun arg -> arg.tv_name) ts.ts_args in fprintf fmt "@[(par (%a) (%a))@]" (print_list space (print_ident info)) args (print_list space (print_constructor_decl info)) cl else fprintf fmt "@[(%a)@]" (print_list space (print_constructor_decl info)) cl let print_sort_decl info fmt (ts,_) = fprintf fmt "@[(%a %d)@]" (print_ident info) ts.ts_name (List.length ts.ts_args) let print_decl vc_loc 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 -> begin match info.info_version with | V20 -> fprintf fmt "@[(declare-datatypes ()@ (%a))@]@\n" (print_list space (print_data_decl info)) dl | V26 -> fprintf fmt "@[(declare-datatypes (%a)@ (%a))@,@]" (print_list space (print_sort_decl info)) dl (print_list space (print_data_def info)) dl end | 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 args info fmt k pr f let set_produce_models fmt info = if info.info_cntexample then fprintf fmt "(set-option :produce-models true)@\n" let set_incremental fmt info = if info.info_set_incremental then fprintf fmt "(set-option :incremental true)@\n" let meta_counterexmp_need_push = Theory.register_meta_excl "counterexample_need_smtlib_push" [Theory.MTstring] ~desc:"Internal@ use@ only" let meta_incremental = Theory.register_meta_excl "meta_incremental" [Theory.MTstring] ~desc:"Internal@ use@ only" let print_task version args ?old:_ fmt task = let cntexample = Prepare_for_counterexmp.get_counterexmp task in let incremental = let incr_meta = Task.find_meta_tds task meta_incremental in not (Theory.Stdecl.is_empty incr_meta.Task.tds_set) in let incremental = Debug.test_flag debug_incremental || incremental in let need_push = let need_push_meta = Task.find_meta_tds task meta_counterexmp_need_push in not (Theory.Stdecl.is_empty need_push_meta.Task.tds_set) 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_rliteral = Printer.get_rliteral_map task; info_model = S.empty; info_in_goal = false; info_vc_term = vc_info; info_printer = ident_printer (); list_projs = Mstr.empty; list_field_def = Mstr.empty; info_version = version; meta_model_projection = Task.on_tagged_ls Theory.meta_projection task; meta_record_def = Task.on_tagged_ls Theory.meta_record task; list_records = Mstr.empty; noarg_constructors = []; info_cntexample_need_push = need_push; info_cntexample = cntexample; info_incremental = incremental; (* info_set_incremental add the incremental option to the header. It is not needed for some provers *) info_labels = Mstr.empty; info_set_incremental = not need_push && incremental; incr_list = []; } in print_prelude fmt args.prelude; set_produce_models fmt info; set_incremental fmt info; 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 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 V20) ~desc:"Printer@ for@ the@ SMTlib@ version@ 2@ format." let () = register_printer "smtv2.6" (print_task V26) ~desc:"Printer@ for@ the@ SMTlib@ version@ 2.6@ format." why3-1.2.1/src/printer/cvc3.ml0000644000175100017510000002546013555524575016632 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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.negative_int_support = Number.Number_default; 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.negative_real_support = Number.Number_default; 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, _, _) -> 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-1.2.1/src/printer/coq.ml0000644000175100017510000010623113555524575016552 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 syntax_arguments s f fmt l = let sl = Strings.split ' ' s in pp_open_box fmt 1; print_list space (fun fmt s -> syntax_arguments s f fmt l) fmt sl; pp_close_box fmt () 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 "@[<2>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 protect_on ?(boxed=false) x s = if x then "@[<1>(" ^^ s ^^ ")@]" else if not boxed then "@[" ^^ s ^^ "@]" else s let rec print_type info fmt ty = print_ty false info fmt ty and print_op_type info fmt ty = print_ty true info fmt ty and print_ty op 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 op info fmt ty | _ -> fprintf fmt "(%a)%%type" (print_list star (print_op_type info)) tl end | Tyapp (ts, [l;r]) when ts_equal ts ts_func -> fprintf fmt (protect_on op "%a ->@ %a") (print_op_type info) l (print_type info) r | Tyapp (ts, tl) -> begin match query_syntax info.info_syn ts.ts_name with | Some s -> syntax_arguments s (print_op_type info) fmt tl | None -> begin match tl with | [] -> (print_ts_real info) fmt ts | l -> fprintf fmt (protect_on op "%a%a") (print_ts_real info) ts (print_list_pre space (print_op_type 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 match fs.ls_value with | None -> true | Some v -> inspect v (** Patterns, terms, and formulas *) let lparen_r fmt () = fprintf fmt "@[<1>(" let rparen_r fmt () = fprintf fmt ")@]" let print_paren_r f = print_list_delim ~start:lparen_r ~stop:rparen_r ~sep:comma f let arrow fmt () = fprintf fmt " ->@ " let print_arrow_list fmt x = print_list_suf arrow fmt x let rec print_pattern info fmt p = print_pat false info fmt p and print_pat op info fmt p = match p.pat_node with | Pwild -> fprintf fmt "_" | Pvar v -> print_vs fmt v | Pas (p,v) -> fprintf fmt (protect_on op "%a as %a") (print_pat true info) p print_vs v | Por (p,q) -> fprintf fmt (protect_on op "%a|%a") (print_pat true info) p (print_pat true info) q | Papp (cs,pl) when is_fs_tuple cs -> print_paren_r (print_pat false info) fmt pl | Papp (cs,pl) -> begin match query_syntax info.info_syn cs.ls_name with | Some s -> syntax_arguments s (print_pat true info) fmt pl | _ when pl = [] -> print_ls_real info fmt cs | _ -> fprintf fmt (protect_on op "%a@ %a") (print_ls_real info) cs (print_list space (print_pat true info)) pl end let print_vsty info fmt v = fprintf fmt "@[<1>(%a:@,%a)@]" print_vs v (print_type info) v.vs_ty let print_binop fmt = function | Tand -> fprintf fmt "/\\" | Tor -> fprintf fmt "\\/" | Timplies -> fprintf fmt "->" | Tiff -> fprintf fmt "<->" (* [opl] means that there is no delimiter on the left of the term, so parentheses should be put around the term if it does not start with a delimiter; [opr] is similar, but on the right of the term *) let rec print_term info fmt t = print_tnode false false info fmt t and print_opl_term info fmt f = print_tnode true false info fmt f and print_opr_term info fmt t = print_tnode false true info fmt t and print_tnode ?(boxed=false) 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.negative_int_support = Number.Number_custom "(-%a)%%Z"; 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.negative_real_support = Number.Number_custom "(-%a)%%R"; 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 | 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_term info) t2; forget_var v | Tcase (t,bl) -> fprintf fmt "@[match %a with@,%a@,end@]" (print_term info) t (print_list pp_print_cut (print_tbranch info)) bl | Teps _ -> let vl,_,t0 = t_open_lambda t in if vl = [] then unsupportedTerm t "???" 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 (protect_on (opl || opr) "%a@ %a") (print_opr_term info) l (print_opl_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 (protect_on (opl || opr) "%a@ %a") (print_ls_real info) fs (print_list space (print_opr_term info)) tl else fprintf fmt (protect_on (opl || opr) "@[%a%a@] :@ %a") (print_ls_real info) fs (print_list_pre space (print_opr_term info)) tl (print_type info) (t_type t) end | Tquant (Tforall,fq) -> let vl,_tl,f = t_open_quant fq in fprintf fmt (protect_on ~boxed opr "@[<2>forall %a@],@ %a") (print_list space (print_vsty info)) vl (print_tnode ~boxed:true false false 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_term info fmt f | v::vr -> fprintf fmt "exists %a:@,%a,@ %a" print_vs v (print_type info) v.vs_ty aux vr in fprintf fmt (protect_on opr "%a") aux vl; List.iter forget_var vl | Ttrue -> fprintf fmt "True" | Tfalse -> fprintf fmt "False" | Tbinop (b,f1,f2) -> (match b with | Tand | Tor -> fprintf fmt (protect_on (opl || opr) "%a %a@ %a") (print_opr_term info) f1 print_binop b (print_opl_term info) f2 | Timplies -> (* implication has so low a precedence that its rhs does not need protection *) fprintf fmt (protect_on ~boxed (opl || opr) "%a ->@ %a") (print_opr_term info) f1 (print_tnode ~boxed:true false false info) f2 | Tiff -> fprintf fmt (protect_on (opl || opr) "%a <->@ %a") (print_opr_term info) f1 (print_opl_term info) f2) | Tnot f -> fprintf fmt "~ %a" (print_tnode true true info) f | Tif (f1,f2,f3) -> fprintf fmt (protect_on opr "if %a then@ %a@ else@ %a") (print_term info) f1 (print_term info) f2 (print_term info) f3 and print_tbranch info fmt br = let p,t = t_open_branch br in fprintf fmt "@[<4>| %a =>@ %a@]" (print_pattern info) p (print_term info) t; Svs.iter forget_var p.pat_vars (** Declarations *) let print_constr info ts fmt (cs,_) = fprintf fmt "@[<4>| %a : %a%a%a@]" print_ls cs (print_arrow_list (print_op_type 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 need_intros fmla = match fmla.t_node with | Tlet _ | Tquant(Tforall,_) | Tbinop(Timplies, _, _) -> true | _ -> false let intros fmt fmla = fprintf fmt "@[intros%a.@]" (do_intros 1) fmla let print_empty_proof fmt def = match def with | Some (_params,fmla) -> fprintf fmt "Proof.@\n"; if need_intros fmla then intros fmt fmla; fprintf fmt "@\n@\nQed.@\n" | None -> fprintf fmt "Proof.@\n@\nDefined.@\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 f -> fprintf fmt "@[(* Why3 %a *)@]@\n" (fun fmt f -> intros fmt 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@[<2>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_type 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@[<2>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 "@[<2>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 "@[<2>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_type 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@[<2>Variable %a: %a%a%a.@]@\n@\n" print_ls ls (print_params info ~whytypes:true) all_ty_params (print_arrow_list (print_op_type 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_term info) e; List.iter forget_var vl | _ -> fprintf fmt "(* Why3 goal *)@\n@[Definition @[%a%a@] :@ @[%a%a.@]@]@\n%a@\n" print_ls ls (print_tv_binders info ~whytypes:true ~implicit:true) all_ty_params (print_arrow_list (print_op_type 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_op_type 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@[@[<4>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_term 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%a@\n" name (print_tv_binders info ~whytypes:true ~implicit:true) all_ty_params (print_term info) def_formula (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_term 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 "@[<2>Fixpoint ") ~stop:(fun fmt () -> fprintf fmt ".@]@\n") ~sep:(fun fmt () -> fprintf fmt "@]@\n@[<2>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_term 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_op_type 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@[<2>%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" 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_term info) f | _ -> fprintf fmt "(* Why3 goal *)@\n@[%s @[%a%a@] :@ @[%a.@]@]@\n%a@\n" stt print_pr pr (print_tv_binders info ~whytypes:true ~implicit:true) params (print_term 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_term 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 use T 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.Use 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-1.2.1/src/printer/why3printer.mli0000644000175100017510000000130713555524575020435 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/printer/smtv2.mli0000644000175100017510000000130713555524575017212 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/printer/coq.mli0000644000175100017510000000155013555524575016721 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/printer/simplify.ml0000644000175100017510000001505513555524575017627 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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.negative_int_support = Number.Number_default; 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.negative_real_support = Number.Number_default; 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, _, _) -> 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-1.2.1/src/printer/cntexmp_printer.mli0000644000175100017510000000352713555524575021366 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 Wstdlib 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 : 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 add_model_element: Term.term -> S.t -> S.t (* val model_trace_for_postcondition: attrs:Ident.Sattr.t -> vc_term_info -> Ident.Sattr.t *) val check_enter_vc_term: Term.term -> bool -> vc_term_info -> unit val check_exit_vc_term: Term.term -> bool -> vc_term_info -> unit val update_info_labels: string -> Sattr.t Mstr.t -> Term.term -> Term.lsymbol -> Sattr.t Mstr.t val check_for_counterexample: Term.term -> bool (* Check if a term should be added for counterexample analysis *) why3-1.2.1/src/printer/alt_ergo.ml0000644000175100017510000004473413555524575017575 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 Wstdlib 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_attrs : 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; mutable list_projs: Ident.ident Mstr.t; mutable list_field_def: Ident.ident Mstr.t; meta_model_projection: Sls.t; meta_record_def : Sls.t; info_cntexample: bool } let ident_printer () = let bls = [ "abs_int"; "abs_real"; "ac"; "and"; "array"; "as"; "axiom"; "bitv"; "bool"; "case_split"; "check"; "cut"; "distinct"; "else"; "end"; "exists"; "extends"; "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"; "theory"; "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_attr fmt l = fprintf fmt "\"%s\"" l.attr_string let print_ident_attr info fmt id = if info.info_show_attrs then fprintf fmt "%s %a" (id_unique info.info_printer id) (print_list space print_attr) (Sattr.elements id.id_attrs) 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 Sls.mem ls info.meta_model_projection then info.list_projs <- Mstr.add (sprintf "%a" (print_ident info) ls.ls_name) ls.ls_name info.list_projs; if ls.ls_args = [] && relevant_for_counterexample ls.ls_name then let t = t_app ls [] ls.ls_value in info.info_model <- add_model_element (t_attr_set ?loc:ls.ls_name.id_loc ls.ls_name.id_attrs 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 check_for_counterexample t 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.negative_int_support = Number.Number_default; 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.negative_real_support = Number.Number_default; 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 attrs = (*match vc_term_info.vc_func_name with | None ->*) ls.ls_name.id_attrs (*| Some _ -> model_trace_for_postcondition ~attrs:ls.ls_name.id_attrs info.info_vc_term *) in let _t_check_pos = t_attr_set ~loc attrs 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 check_for_counterexample f 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_attrs then match Sattr.elements f.t_attrs with | [] -> print_fmla_node info fmt f | l -> fprintf fmt "(%a : %a)" (print_list colon print_attr) 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_attr 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 info = (* Prints the content of info.info_model *) let info_model = info.info_model in if not (S.is_empty info_model) && info.info_cntexample then begin let model_map = S.fold (fun f acc -> let s = asprintf "%a" (print_fmla info) f in Mstr.add s f acc) info_model 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 Mstr.empty let print_prop_decl vc_loc 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 info in args.printer_mapping <- { lsymbol_m = args.printer_mapping.lsymbol_m; vc_term_loc = vc_loc; queried_terms = model_list; list_projections = info.list_projs; list_fields = info.list_field_def; list_records = Mstr.empty; noarg_constructors = []; set_str = Mstr.empty}; fprintf fmt "@[goal %a :@ %a@]@\n" (print_ident info) pr.pr_name (print_fmla info) f | Plemma -> assert false let print_prop_decl vc_loc 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 args info fmt k pr f; forget_tvs info) let print_decl vc_loc 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 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_attrs"] -> 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_attrs = 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; list_projs = Mstr.empty; list_field_def = Mstr.empty; meta_model_projection = Task.on_tagged_ls Theory.meta_projection task; meta_record_def = Task.on_tagged_ls Theory.meta_record task; info_cntexample = cntexample; } 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 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-1.2.1/src/printer/cntexmp_printer.ml0000644000175100017510000001217213555524575021211 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 Wstdlib 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_attrs = b.t_attrs) 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 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 attributes + 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 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 && Sattr.mem Ity.annot_attr t.t_attrs then begin vc_term_info.vc_inside <- true; vc_term_info.vc_loc <- t.t_loc end let check_exit_vc_term t in_goal info = (* Check whether the term triggering VC is exited. *) if in_goal && Sattr.mem Ity.annot_attr t.t_attrs then begin info.vc_inside <- false; end (* This is used to update info_labels of info in the printer. This takes the label informations present in the term and add a location to help pretty printing the counterexamples. This also takes the information for if_branching "branch_id=" used by API users. *) let update_info_labels lsname cur_attrs t ls = let cur_l = match Mstr.find lsname cur_attrs with | exception Not_found -> Sattr.empty | s -> s in let updated_attr_labels = (* Change attributes labels with "at:" to located "at:[label]:loc:filename:line" *) Sattr.fold (fun attr acc -> if Strings.has_prefix "at:" attr.attr_string then let (f, l, _, _) = match t.t_loc with | None -> Loc.get (Opt.get_def Loc.dummy_position ls.ls_name.id_loc) | Some loc -> Loc.get loc in let attr = create_attribute (attr.attr_string ^ ":loc:" ^ f ^ ":" ^ (string_of_int l)) in Sattr.add attr acc else if Strings.has_prefix "branch_id=" attr.attr_string then Sattr.add attr acc else acc ) (Sattr.union t.t_attrs ls.ls_name.id_attrs) cur_l in Mstr.add lsname updated_attr_labels cur_attrs let check_for_counterexample t = let is_app t = match t.t_node with | Tapp (ls, []) -> not (Sattr.mem proxy_attr ls.ls_name.id_attrs) | _ -> false in not (Sattr.mem proxy_attr t.t_attrs) && t.t_loc <> None && (is_app t) why3-1.2.1/src/printer/pvs.ml0000644000175100017510000007612713555524575016612 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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_attr _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_attrs with | _ -> print_tnode opl opr info fmt t and print_lrfmla opl opr info fmt f = match f.t_attrs 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.negative_int_support = Number.Number_default; 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.negative_real_support = Number.Number_default; 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" 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 use T 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.Use 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-1.2.1/src/printer/smtv1.mli0000644000175100017510000000130713555524575017211 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/printer/why3printer.ml0000644000175100017510000003436213555524575020273 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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"; "scope"; "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_attr = Pretty.print_attr let print_attrs = print_iter1 Sattr.iter space print_attr let print_ident_attrs fmt id = if not (Sattr.is_empty id.id_attrs) then fprintf fmt "@ %a" print_attrs id.id_attrs let rec print_term fmt t = print_lterm 0 fmt t and print_lterm pri fmt t = if Sattr.is_empty t.t_attrs then print_tnode pri fmt t else fprintf fmt (protect_on (pri > 0) "%a %a") print_attrs t.t_attrs (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) "fun %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 = Sattr.mem Term.asym_split f1.t_attrs 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_attrs 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_attrs 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_attrs 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_attrs 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_attrs 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_attrs 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_attrs 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_attrs 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_attrs 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_attrs 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_attrs 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_ty fmt (ts1,ty2) = fprintf fmt "type %a%a = %a" print_ts ts1 (print_list_pre space print_tv) ts1.ts_args print_ty ty2; forget_tvs () 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) -> let tm = Mts.fold (fun x y a -> (x,y)::a) sm.sm_ts [] in let ym = Mts.fold (fun x y a -> (x,y)::a) sm.sm_ty [] 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%a *)@]" print_qt th (print_list_suf comma print_inst_ts) tm (print_list_suf comma print_inst_ty) ym (print_list_suf comma print_inst_ls) lm (print_list_suf 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-1.2.1/src/util/0000755000175100017510000000000013555524575014725 5ustar guillaumeguillaumewhy3-1.2.1/src/util/pqueue.mli0000644000175100017510000000531313555524575016736 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 implements a priority queue based on a minimal binary heap. The heap is implemented as a dynamic array, taken from the module vector. *) (** This is a contribution by Aymeric Walch. *) (*@ use Order *) (*@ use Bag *) module Make (X: sig type t val dummy : t (*@ function cmp : t -> t -> int *) (*@ axiom is_pre_order: Order.is_pre_order cmp *) val compare : t -> t -> int (*@ r = compare x y ensures r = cmp x y *) end) : sig type elt = X.t type t (*@ ephemeral *) (*@ mutable model bag : X.t bag *) (*@ invariant card bag <= Sys.max_array_length *) (*@ predicate mem (x: elt) (h: t) := nb_occ x h.bag > 0 *) val create : unit -> t (*@ h = create () ensures h.bag = empty_bag *) val is_empty : t -> bool (*@ b = is_empty h ensures b <-> h.bag = empty_bag *) val size : t -> int (* x = size h ensures x = card h.bag *) (*@ function minimum: t -> elt *) (*@ predicate is_minimum (x: elt) (h: t) := mem x h && forall e. mem e h -> X.cmp x e <= 0 *) (*@ axiom min_def: forall h. 0 < card h.bag -> is_minimum (minimum h) h *) val find_min : t -> elt option (*@ r = find_min h ensures match r with | None -> card h.bag = 0 | Some x -> card h.bag > 0 && x = minimum h *) exception Empty val find_min_exn : t -> elt (*@ x = find_min_exn h raises Empty -> card h.bag = 0 ensures card h.bag > 0 && x = minimum h *) val delete_min_exn : t -> unit (*@ delete_min_exn h modifies h raises Empty -> card h.bag = 0 && h.bag = old h.bag ensures (old h).bag = add (minimum (old h)) h.bag *) val extract_min_exn : t -> elt (*@ x = extract_min_exn h modifies h raises Empty -> card h.bag = 0 && h.bag = old h.bag ensures x = minimum (old h) ensures (old h).bag = add x h.bag *) val insert : elt -> t -> unit (*@ insert x h checks card h.bag < Sys.max_array_length modifies h ensures h.bag = add x (old h).bag *) end why3-1.2.1/src/util/extmap.ml0000644000175100017510000005341113555524575016561 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 contains: 'a t -> key -> bool 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: invalid function parameter" 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 contains m x = mem x m 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-1.2.1/src/util/pqueue.ml0000644000175100017510000000640113555524575016564 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 is automatically extracted from why3/examples/util/PQueue_impl.mlw *) (** This is a contribution by Aymeric Walch. *) module Make(X: sig type t val dummy : t val compare : t -> t -> int end) = struct type elt = X.t type t = X.t Vector.t let create (_: unit) : t = Vector.create ?capacity:(Some 0) ~dummy:X.dummy let is_empty (h: t) : bool = Vector.is_empty h let size (h: t) : int = Vector.length h exception Empty let find_min_exn (h: t) : X.t = begin if Vector.is_empty h then begin raise Empty end; Vector.get h 0 end let find_min (h: t) : X.t option = if Vector.is_empty h then begin None end else begin Some (Vector.get h 0) end let rec move_down (a: X.t Vector.t) (i: int) (x: X.t) : unit = let n = Vector.length a in let q = if n = 1 then begin (-1) end else begin (n - 2) / 2 end in if i <= q then begin let j = let j1 = (2 * i) + 1 in if ((j1 + 1) < n) && ((X.compare (Vector.get a (j1 + 1)) (Vector.get a j1)) < 0) then begin j1 + 1 end else begin j1 end in if (X.compare (Vector.get a j) x) < 0 then begin begin let o = Vector.get a j in Vector.set a i o; move_down a j x end end else begin Vector.set a i x end end else begin Vector.set a i x end let extract_min_exn (h: t) : X.t = begin try let x = Vector.pop h in let n = Vector.length h in if not (n = 0) then begin let min = Vector.get h 0 in begin move_down h 0 x; min end end else begin x end with | Vector.Empty -> raise Empty end let delete_min_exn (h: t) : unit = ignore (extract_min_exn h) let rec move_up (a: X.t Vector.t) (i: int) (x: X.t) : unit = if i = 0 then begin Vector.set a i x end else begin let j = (i - 1) / 2 in let y = Vector.get a j in if (X.compare y x) > 0 then begin begin Vector.set a i y; move_up a j x end end else begin Vector.set a i x end end let insert (x: X.t) (h: t) : unit = begin if (size h) = Sys.max_array_length then begin raise (Invalid_argument "") end; let n = Vector.length h in if n = 0 then begin Vector.push h x end else begin let j = (n - 1) / 2 in let y = Vector.get h j in if (X.compare y x) > 0 then begin begin Vector.push h y; move_up h j x end end else begin Vector.push h x end end end end why3-1.2.1/src/util/json_parser.mly0000644000175100017510000000352413555524575020001 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 is extracted/adapted from the code found in the book Real World Ocaml by Yaron Minsky, Anil Madhavapeddy, and Jason Hickey. Their 'unlicence' allows it. *) (* A JSON text can actually be any JSON value *) %start value %token INT %token FLOAT %token STRING %token TRUE %token FALSE %token NULL %token LEFTBRC RIGHTBRC %token LEFTSQ %token RIGHTSQ %token COLON %token COMMA %token EOF %% json_object: | EOF { Json_base.Null } | LEFTBRC RIGHTBRC { Json_base.Null } (* Left recursive rule are more efficient *) | LEFTBRC members RIGHTBRC { Json_base.Record (Json_base.convert_record (List.rev $2)) } members: | json_pair { [ $1 ] } | members COMMA json_pair { $3 :: $1 } array: | LEFTSQ RIGHTSQ { Json_base.List [] } | LEFTSQ elements RIGHTSQ { Json_base.List (List.rev $2) } elements: | value { [$1] } | elements COMMA value { $3 :: $1 } json_pair: | STRING COLON value { ($1, $3) } value: | STRING { Json_base.String $1 } | INT { Json_base.Int $1 } | FLOAT { Json_base.Float $1 } | json_object { $1 } | array { $1 } | TRUE { Json_base.Bool true} | FALSE { Json_base.Bool false } | NULL { Json_base.Null } why3-1.2.1/src/util/json_base.mli0000644000175100017510000000615413555524575017401 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 characters escaped in JSON 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 a floating point number *) val standard_float : Format.formatter -> float -> unit (* print a float in a format that cannot be mistaken for an integer (this makes communication with other tools easier). *) 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. *) val convert_record : (string * 'a) list -> 'a Wstdlib.Mstr.t (* 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 = | Record of json Wstdlib.Mstr.t | Proj of json Wstdlib.Mstr.t | List of json list | String of string | Int of int | Float of float | Bool of bool | Null val print_json : Format.formatter -> json -> unit (** Convenience function that returns a field/part of json_value or return Not_found if not present *) (* Get json fields. Return Not_found if no fields or field missing *) val get_field: json -> string -> json val get_string: json -> string val get_int: json -> int val get_list: json -> json list val get_float: json -> float val get_bool: json -> bool val get_bool_opt: json -> bool -> bool (* To parse a json value, use file Json_parser and function json_object. See end of session/Json_util.ml for an example use. val parse : string -> value *) why3-1.2.1/src/util/exthtbl.mli0000644000175100017510000000462613555524575017112 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/util/strings.ml0000644000175100017510000000612413555524575016753 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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. *) (* *) (********************************************************************) (* Replace with Char.uppercase_ascii as soon as we can assume OCaml version at least 4.03.0 *) let char_is_uppercase c = c = Char.uppercase c let lowercase = String.lowercase 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 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 sl = String.length s in let l = String.length pref in let rec aux i = i >= l || (s.[i] = pref.[i] && aux (i+1)) in sl >= l && aux 0 let remove_prefix pref s = let sl = String.length s in let l = String.length pref in if sl < 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 (sl - l) let has_suffix suff s = let sl = String.length s in let l = String.length suff in let rec aux i = i >= l || (s.[sl - l + i] = suff.[i] && aux (i+1)) in sl >= l && aux 0 let remove_suffix suff s = let sl = String.length s in let l = String.length suff in if sl < l then raise Not_found else for i = 0 to l - 1 do if s.[sl - l + i] <> suff.[i] then raise Not_found done; String.sub s 0 (sl - l) 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 why3-1.2.1/src/util/pp.mli0000644000175100017510000001034013555524575016045 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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. *) (* *) (********************************************************************) (** Helpers for formatted pretty-printing *) open Format type 'a pp = formatter -> 'a -> unit val print_option : 'a pp -> 'a option pp val print_option_or_default : string -> 'a pp -> 'a option pp val print_list_pre : unit pp -> 'a pp -> 'a list pp val print_list_suf : unit pp -> 'a pp -> 'a list pp val print_list : unit pp -> 'a pp -> 'a list pp val print_list_or_default : string -> unit pp -> 'a pp -> 'a list pp val print_list_par : (formatter -> unit -> 'a) -> 'b pp -> 'b list pp val print_list_next : unit pp -> (bool -> 'a pp) -> 'a list pp val print_list_delim : start:unit pp -> stop:unit pp -> sep:unit pp -> 'b pp -> 'b list pp val print_pair_delim : unit pp -> unit pp -> unit pp -> 'a pp -> 'b pp -> ('a * 'b) pp (** [print_pair_delim left_delim middle_delim right_delim] *) val print_pair : 'a pp -> 'b pp -> ('a * 'b) pp val print_iter1 : (('a -> unit) -> 'b -> unit) -> unit pp -> 'a pp -> 'b pp val print_iter2: (('a -> 'b -> unit) -> 'c -> unit) -> unit pp -> unit pp -> 'a pp -> 'b pp -> 'c pp (** [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) -> unit pp -> (formatter -> 'a -> 'b -> unit) -> 'c pp (** [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 : unit pp val alt : unit pp val alt2 : unit pp val newline : unit pp val newline2 : unit pp val dot : unit pp val comma : unit pp val star : unit pp val simple_comma : unit pp val semi : unit pp val colon : unit pp val underscore : unit pp val slash : unit pp val equal : unit pp val arrow : unit pp val lbrace : unit pp val rbrace : unit pp val lsquare : unit pp val rsquare : unit pp val lparen : unit pp val rparen : unit pp val lchevron : unit pp val rchevron : unit pp val nothing : 'a pp val string : string pp val float : float pp val int : int pp val constant_string : string -> unit pp val formatted : formatter -> formatted -> unit val constant_formatted : formatted -> unit pp val print0 : unit pp val hov : int -> 'a pp -> 'a pp val indent : int -> 'a pp -> 'a pp (** add the indentation at the first line *) val add_flush : 'a pp -> 'a pp val asd : 'a pp -> 'a pp (** 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 -> (formatter -> unit) -> string -> out_channel val print_in_file : ?margin:int -> (formatter -> unit) -> string -> unit val print_list_opt : unit pp -> (formatter -> 'a -> bool) -> formatter -> 'a list -> bool val string_of : ?max_boxes:int -> 'a pp -> 'a -> string val string_of_wnl : 'a pp -> 'a -> string (** same as {!string_of} but without newline *) val wnl : formatter -> unit val sprintf : ('b, formatter, unit, string) Pervasives.format4 -> 'b val sprintf_wnl : ('b, formatter, unit, string) Pervasives.format4 -> 'b val html_char : char pp val html_string : string pp (** formats the string by escaping special HTML characters quote, double quote, <, > and & *) module Ansi : sig val set_column : formatter -> int -> unit end type formatter = Format.formatter why3-1.2.1/src/util/number.mli0000644000175100017510000001264313555524575016726 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 (** General functions for representations of numeric values *) exception InvalidConstantLiteral of int * string type integer_literal = private | IConstRaw of BigInt.t | IConstDec of string | IConstHex of string | IConstOct of string | IConstBin of string type integer_constant = { ic_negative : bool; ic_abs : integer_literal; } type real_literal = private | RConstDec of string * string * string option (* int / frac / exp *) | RConstHex of string * string * string option (** If you want to write the constant 1/3 you need to use the division function from the real theory *) type real_constant = { rc_negative : bool; rc_abs : real_literal; } type constant = | ConstInt of integer_constant | ConstReal of real_constant val is_negative : constant -> bool val int_literal_dec : string -> integer_literal val int_literal_hex : string -> integer_literal val int_literal_oct : string -> integer_literal val int_literal_bin : string -> integer_literal (** 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 int_literal_raw : BigInt.t -> integer_literal val int_const_of_int : int -> integer_constant val int_const_of_big_int : BigInt.t -> integer_constant val const_of_int : int -> constant val const_of_big_int : BigInt.t -> constant val real_const_dec : string -> string -> string option -> real_literal (** [real_const_dec integer_part decimal_part exp] return the real that corresponds to "integer_part.decimal_part * 10^exp". By default exp is 0. *) val real_const_hex : string -> string -> string option -> real_literal (** Pretty-printing *) 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 'a negative_format = ((Format.formatter->'a->unit)->'a->unit, Format.formatter,unit) format type number_support = { long_int_support : bool; extra_leading_zeros_support : bool; negative_int_support : (integer_literal negative_format) number_support_kind; 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; negative_real_support : (real_literal negative_format) number_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. REQUIRES [i] non-negative *) (** Range checking *) val to_small_integer : integer_literal -> int (* may raise invalid_argument *) val compute_int_literal : integer_literal -> BigInt.t val compute_int_constant : integer_constant -> BigInt.t type int_range = { ir_lower : BigInt.t; ir_upper : BigInt.t; } val create_range : BigInt.t -> BigInt.t -> int_range 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_literal val compute_float : real_literal -> 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_literal -> float_format -> unit (** [check_float c fp] is the same as [compute_float c fp] but does not return any value. *) why3-1.2.1/src/util/loc.mli0000644000175100017510000000456413555524575016216 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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. *) (* *) (********************************************************************) (** Source locations *) open Format (** {2 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 (** {2 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 (** {2 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 (** {2 located error 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-1.2.1/src/util/vector.ml0000644000175100017510000001251413555524575016564 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 is automatically extracted from why3/examples/util/Vector_impl.mlw *) type 'a t = { dummy: 'a; mutable size: int; mutable data: ('a array); } let create ?capacity:(capacity: (int) option) ~dummy:(dummy: 'a) : 'a t = let capacity1 = begin match capacity with | None -> 0 | Some c -> c end in { dummy = dummy; size = 0; data = (Array.make capacity1 dummy) } let make ?dummy:(dummy: 'a option) (n: int) (x: 'a) : 'a t = let dummy1 = begin match dummy with | None -> x | Some d -> d end in { dummy = dummy1; size = n; data = (Array.make n x) } let init ~dummy:(dummy: 'a) (n: int) (f: (int) -> 'a) : 'a t = let a = make n dummy in begin let o = n - 1 in let o1 = 0 in for i1 = o1 to o do (a.data).(i1) <- (f i1) done; a end let length (a: 'a t) : int = a.size let get (a: 'a t) (i2: int) : 'a = (a.data).(i2) let set (a: 'a t) (n: int) (x: 'a) : unit = (a.data).(n) <- x let unsafe_resize (a: 'a t) (n: int) : unit = let n_old = Array.length (a.data) in begin if n <= (a.size) then begin if n < (n_old / 4) then begin let o = Array.sub (a.data) 0 n in a.data <- o end else begin Array.fill (a.data) n ((a.size) - n) (a.dummy) end end else begin if n > n_old then begin let n_div2 = n / 2 in let nqt = if n_div2 >= n_old then begin if (Sys.max_array_length / 2) >= n_div2 then begin n end else begin Sys.max_array_length end end else begin if (Sys.max_array_length / 2) >= n_old then begin 2 * n_old end else begin Sys.max_array_length end end in let aqt = Array.make nqt (a.dummy) in begin Array.blit (a.data) 0 aqt 0 (a.size); a.data <- aqt end end end; a.size <- n end let resize (a: 'a t) (n: int) : unit = begin if not ((0 <= n) && (n <= Sys.max_array_length)) then begin raise (Invalid_argument "") end; unsafe_resize a n end let clear (a: 'a t) : unit = unsafe_resize a 0 let is_empty (a: 'a t) : bool = (length a) = 0 let sub (a: 'a t) (ofs: int) (n: int) : 'a t = { dummy = (a.dummy); size = n; data = (Array.sub (a.data) ofs n) } let fill (a: 'a t) (ofs: int) (n: int) (x: 'a) : unit = Array.fill (a.data) ofs n x let blit (a1: 'a t) (ofs1: int) (a2: 'a t) (ofs2: int) (n: int) : unit = Array.blit (a1.data) ofs1 (a2.data) ofs2 n let append (a1: 'a t) (a2: 'a t) : 'a t = let n1 = length a1 in let n2 = length a2 in let a = make (n1 + n2) (a1.dummy) in begin blit a1 0 a 0 n1; blit a2 0 a n1 n2; a end let merge_right (a1: 'a t) (a2: 'a t) : unit = let n1 = length a1 in let n2 = length a2 in let size = n1 + n2 in begin unsafe_resize a1 size; blit a2 0 a1 n1 n2; clear a2 end let copy (a1: 'a t) : 'a t = { dummy = (a1.dummy); size = (a1.size); data = (Array.copy (a1.data)) } let push (a: 'a t) (x: 'a) : unit = let n = a.size in begin unsafe_resize a (n + 1); (a.data).(n) <- x end exception Empty let pop (a: 'a t) : 'a = let n = (length a) - 1 in begin if n < 0 then begin raise Empty end; let r = (a.data).(n) in begin unsafe_resize a n; r end end let pop_opt (a: 'a t) : 'a option = let n = (length a) - 1 in if n < 0 then begin None end else begin let r = (a.data).(n) in begin unsafe_resize a n; Some r end end let top (a: 'a t) : 'a = let n = length a in (a.data).((n - 1)) let top_opt (a: 'a t) : 'a option = let n = length a in if n = 0 then begin None end else begin Some ((a.data).((n - 1))) end let fold_left (a: 'a t) (f: 'b -> ('a -> 'b)) (acc: 'b) : 'b = let r = ref acc in begin let o = (length a) - 1 in let o1 = 0 in for i2 = o1 to o do let o2 = (f (!r)) (get a i2) in r := o2 done; !r end let fold_right (a: 'a t) (f: 'a -> ('b -> 'b)) (acc: 'b) : 'b = let n = length a in let r = ref acc in begin let o = 0 in let o1 = n - 1 in for i3 = o1 downto o do let o2 = (f (get a i3)) (!r) in r := o2 done; !r end let map ~dummy:(dummy: 'b) (a: 'a t) (f: 'a -> 'b) : 'b t = let n = length a in let a_new = make n dummy in begin let o = n - 1 in let o1 = 0 in for i4 = o1 to o do let x = get a i4 in (a_new.data).(i4) <- (f x) done; a_new end let mapi ~dummy:(dummy: 'b) (a: 'a t) (f: (int) -> ('a -> 'b)) : 'b t = let n = length a in let a_new = make n dummy in begin let o = n - 1 in let o1 = 0 in for i5 = o1 to o do let x = get a i5 in (a_new.data).(i5) <- ((f i5) x) done; a_new end let iteri f a = for i = 0 to length a - 1 do f i (get a i) done let iter f a = for i = 0 to length a - 1 do f (get a i) done why3-1.2.1/src/util/plugin.ml0000644000175100017510000000434113555524575016557 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/util/util.ml0000644000175100017510000000420713555524575016237 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/util/hashcons.ml0000644000175100017510000000362013555524575017066 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/util/weakhtbl.mli0000644000175100017510000000403213555524575017230 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/util/wstdlib.mli0000644000175100017510000000374113555524575017105 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/util/bigInt.mli0000644000175100017510000000413213555524575016644 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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. *) (* *) (********************************************************************) (** Wrapper for big nums, implemented either with OCaml's [Nums] or [ZArith] *) 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-1.2.1/src/util/plugin.mli0000644000175100017510000000273313555524575016733 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/util/opt.mli0000644000175100017510000000303013555524575016226 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/util/strings.mli0000644000175100017510000000470213555524575017124 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 lowercase : string -> string val capitalize : string -> string val uncapitalize : string -> string (** {2 Other useful functions on strings} *) val char_is_uppercase : char -> bool 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 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] *) val has_suffix : string -> string -> bool (** [has_suffix suff s] returns true if s [s] ends with suffix [suff] *) val remove_suffix : string -> string -> string (** [remove_suffix suff s] removes the suffix [suff] from [s]. Raises [Not_found] if [s] does not end with [suff] *) val ends_with : string -> string -> bool (** test if a string ends with another *) why3-1.2.1/src/util/util.mli0000644000175100017510000000523213555524575016407 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/util/print_tree.mli0000644000175100017510000000351713555524575017611 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/util/extset.mli0000644000175100017510000001531513555524575016751 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 *) val contains: t -> elt -> bool (** [contains s x] is the same as [mem x s]. *) val add_left: t -> elt -> t (** [add_left s x] is the same as [add x s]. *) val remove_left: t -> elt -> t (** [remove_left s x] is the same as [remove x s]. *) val print: (Format.formatter -> elt -> unit) -> Format.formatter -> t -> unit 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-1.2.1/src/util/rc.mll0000644000175100017510000002736213555524575016051 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 Wstdlib 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 | '"' | '\\' | '\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 | ('"' | '\\' | '\r' | '\t') -> Bytes.set s' !n '\\'; incr n | _ -> () end; Bytes.set s' !n (match c with '\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-1.2.1/src/util/exn_printer.ml0000644000175100017510000000243013555524575017613 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/util/debug_optim.ml0000644000175100017510000000261613555524575017562 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 Parsetree open Ast_mapper open Asttypes open Longident let ast_mapper argv = { Ast_mapper.default_mapper with expr = fun mapper expr -> match expr with | { pexp_desc = Pexp_apply ({ pexp_desc = Pexp_ident { txt = Ldot (Lident "Debug", "dprintf")}}, flag :: _args) } as app -> let open Ast_helper in Exp.ifthenelse (Exp.apply (Exp.ident { txt = Ldot (Lident "Debug", "test_flag"); loc = Location.none (*TODO*) }) [flag]) app None | other -> default_mapper.expr mapper other; } let () = register "Debug hook" ast_mapper why3-1.2.1/src/util/json_base.ml0000644000175100017510000000654313555524575017232 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 Wstdlib let string fmt s = let b = Buffer.create (2 * String.length s) in Buffer.add_char b '"'; let i = ref 0 in while !i <= String.length s -1 do (match s.[!i] with | '"' -> Buffer.add_string b "\\\"" | '\\' -> Buffer.add_string b "\\\\" | '/' -> Buffer.add_string b "\\/" | '\b' -> Buffer.add_string b "\\b" | c when c = Char.chr 12 -> Buffer.add_string b "\\f" | '\n' -> Buffer.add_string b "\\n" | '\r' -> Buffer.add_string b "\\r" | '\t' -> Buffer.add_string b "\\t" | c -> Buffer.add_char b c); i := !i + 1 done; Buffer.add_char b '"'; fprintf fmt "%s" (Buffer.contents b) let int fmt d = fprintf fmt "%d" d let bool fmt b = fprintf fmt "%b" b let standard_float fmt f = fprintf fmt "%f" f let float fmt f = fprintf fmt "%g" f let print_json_field key value_pr fmt value = fprintf fmt "%a : %a " string key value_pr value let list pr fmt l = if l = [] then 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 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 (* Convert a list of bindings into a map *) let convert_record l = List.fold_left (fun m (k, x) -> Mstr.add k x m) Mstr.empty l type json = | Record of json Mstr.t | Proj of json Mstr.t | List of json list | String of string | Int of int | Float of float | Bool of bool | Null let rec print_json fmt v = match v with | Record r -> map_bindings (fun x -> x) print_json fmt (Mstr.bindings r) | Proj p -> map_bindings (fun x -> x) print_json fmt (Mstr.bindings p) | List l -> list print_json fmt l | String s -> string fmt s | Int i -> int fmt i | Float f -> float fmt f | Bool b -> bool fmt b | Null -> fprintf fmt "null" (* Get json fields. Return Not_found if no fields or field missing *) let get_field j s = match j with | Record r -> Mstr.find s r | _ -> raise Not_found let get_string j = match j with | String s -> s | _ -> raise Not_found let get_int j = match j with | Int n -> n | _ -> raise Not_found let get_list j = match j with | List l -> l | _ -> raise Not_found let get_float j = match j with | Float f -> f | _ -> raise Not_found let get_bool j = match j with | Bool b -> b | _ -> raise Not_found let get_bool_opt j def = match j with | Bool b -> b | _ -> def why3-1.2.1/src/util/vector.mli0000644000175100017510000003362113555524575016737 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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. *) (* *) (********************************************************************) (** Vectors (aka resizable arrays, growing arrays, dynamic arrays, etc.) This module implements arrays that automatically expand as necessary. Its implementation uses a traditional array and replaces it with a larger array when needed (and elements are copied from the old array to the new one). The current implementation doubles the capacity when growing the array (and shrinks it whenever the number of elements comes to one fourth of the capacity). The unused part of the internal array is filled with a dummy value, which is user-provided at creation time (and referred to below as ``the dummy value''). Consequently, vectors do not retain pointers to values that are not used anymore after a shrinking. Vectors provide an efficient implementation of stacks, with a better locality of reference than list-based implementations (such as standard library {!Stack}). A stack interface is provided, similar to that of {!Stack} (though {!Vector.push} have arguments in the other way round). Inserting [n] elements with {!Vector.push} has overall complexity O(n) i.e. each insertion has amortized constant time complexity. *) (*@ use List *) (*@ use Seq *) type 'a t (** The polymorphic type of vectors. This is a mutable data type. *) (*@ ephemeral *) (*@ mutable model view: 'a seq *) (*@ invariant length view <= Sys.max_array_length *) (** {2 Operations proper to vectors, or with a different type and/or semantics than those of module [Array]} *) val create: ?capacity:int -> dummy:'a -> 'a t (** [create] returns a fresh vector of length [0]. All the elements of this new vector are initially physically equal to [dummy] (in the sense of the [==] predicate). When [capacity] is omitted, it defaults to 0. *) (*@ a = create ?capacity ~dummy requires let capacity = match capacity with | None -> 0 | Some c -> to_int c in 0 <= capacity <= Sys.max_array_length ensures length a.view = 0 *) val make: ?dummy:'a -> int -> 'a -> 'a t (** [make dummy n x] returns a fresh vector of length [n] with all elements initialized with [x]. If [dummy] is omitted, [x] is also used as a dummy value for this vector. *) (*@ a = make ?dummy n x requires 0 <= n <= Sys.max_array_length ensures length a.view = n ensures forall i: integer. 0 <= i < n -> a.view[i] = x *) val init: dummy:'a -> int -> (int -> 'a) -> 'a t (** [init n f] returns a fresh vector of length [n], with element number [i] initialized to the result of [f i]. In other terms, [init n f] tabulates the results of [f] applied to the integers [0] to [n-1]. Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length]. *) (*@ a = init ~dummy n f requires 0 <= n <= Sys.max_array_length ensures length a.view = n ensures forall i: int. 0 <= i < n -> a.view[i] = f i *) val resize: 'a t -> int -> unit (** [resize a n] sets the length of vector [a] to [n]. The elements that are no longer part of the vector, if any, are internally replaced by the dummy value of vector [a], so that they can be garbage collected when possible. Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length]. *) (*@ resize a n checks 0 <= n <= Sys.max_array_length modifies a ensures length a.view = n ensures forall i. 0 <= i < min (length (old a.view)) n -> a.view[i] = (old a.view)[i] *) (** {2 Array interface} *) val clear: 'a t -> unit (** Discard all elements from a vector. This is equivalent to setting the size to 0 with [resize]. *) (*@ clear a modifies a ensures length a.view = 0 *) val is_empty: 'a t -> bool (** Return [true] if the given vector is empty, [false] otherwise. *) (*@ r = is_empty a ensures r <-> length a.view = 0 *) val length: 'a t -> int (** Return the length (number of elements) of the given vector. Note: the number of memory words occupied by the vector can be larger. *) (*@ n = length a ensures n = length a.view *) val get: 'a t -> int -> 'a (** [get a n] returns the element number [n] of vector [a]. The first element has number [0]. The last element has number [length a - 1]. Raise [Invalid_argument "Vector.get"] if [n] is outside the range [0] to [length a - 1]. *) (*@ x = get a i requires 0 <= i < length a.view ensures x = a.view[i] *) val set: 'a t -> int -> 'a -> unit (** [set a n x] modifies aector [a] in place, replacing element number [n] with [x]. Raise [Invalid_argument "Vector.set"] if [n] is outside the range 0 to [length a - 1]. *) (*@ set a i x requires 0 <= i < length a.view modifies a ensures length a.view = length (old a).view ensures a.view[i] = x ensures forall j. 0 <= j < length a.view -> j <> i -> a.view[j] = (old a).view[j] *) val sub: 'a t -> int -> int -> 'a t (** [sub a start len] returns a fresh vector of length [len], containing the elements number [start] to [start + len - 1] of vector [a]. *) (*@ r = sub a ofs n requires 0 <= ofs /\ 0 <= n /\ ofs + n <= length a.view ensures length r.view = n ensures forall i. 0 <= i < n -> r.view[i] = a.view[ofs + i] *) val fill : 'a t -> int -> int -> 'a -> unit (** [fill a ofs len x] modifies the vector [a] in place, storing [x] in elements number [ofs] to [ofs + len - 1]. Raise [Invalid_argument "Vector.fill"] if [ofs] and [len] do not designate a valid subvector of [a]. *) (*@ fill a ofs n x requires 0 <= ofs /\ 0 <= n /\ ofs + n <= length a.view modifies a ensures forall i. (0 <= i < ofs \/ ofs + n <= i < length a.view) -> a.view[i] = (old a).view[i] ensures forall i. ofs <= i < ofs + n -> a.view[i] = x *) val blit : 'a t -> int -> 'a t -> int -> int -> unit (** [blit a1 o1 a2 o2 len] copies [len] elements from vector [a1], starting at element number [o1], to vector [a2], starting at element number [o2]. It works correctly even if [a1] and [a2] are the same vector, and the source and destination chunks overlap. Raise [Invalid_argument "Vector.blit"] if [o1] and [len] do not designate a valid subvector of [a1], or if [o2] and [len] do not designate a valid subvector of [a2]. *) (*@ blit a1 ofs1 a2 ofs2 n requires 0 <= n requires 0 <= ofs1 /\ ofs1 + n <= length a1.view requires 0 <= ofs2 /\ ofs2 + n <= length a2.view modifies a2 ensures forall i. (0 <= i < ofs2 \/ ofs2 + n <= i < length a2.view) -> a2.view[i] = (old a2).view[i] ensures forall i. ofs2 <= i < ofs2 + n -> a2.view[i] = (old a1).view[ofs1 + i - ofs2] *) val append: 'a t -> 'a t -> 'a t (** [append a1 a2] returns a fresh vector containing the concatenation of the elements of [a1] and [a2]. It works correctly even if [a1] and [a2] are the same vector. *) (*@ a3 = append a1 a2 requires length a1.view + length a2.view <= Sys.max_array_length ensures length a3.view = length a1.view + length a2.view ensures forall i. 0 <= i < length a1.view -> a3.view[i] = a1.view[i] ensures forall i. 0 <= i < length a2.view -> a3.view[length a1.view + i] = a2.view[i] *) val merge_right: 'a t -> 'a t -> unit (** [merge_right a1 a2] moves all elements of [a2] to the end of [a1]. Empties [a2]. Assumes [a1] and [a2] to be disjoint. *) (*@ merge_right a1 a2 requires length a1.view + length a2.view <= Sys.max_array_length modifies a1, a2 ensures length a2.view = 0 ensures length a1.view = length (old a1).view + length (old a2).view ensures forall i. 0 <= i < length (old a1).view -> a1.view[i] = (old a1).view[i] ensures forall i. 0 <= i < length (old a2).view -> a1.view[length (old a1).view + i] = (old a2).view[i] *) (* requires disjoint a1 a2 FIXME: disjoint is undefined *) val map : dummy:'b -> 'a t -> ('a -> 'b) -> 'b t (** [map f a] applies function [f] to all the elements of [a], and builds a fresh vector with the results returned by [f]. Note: the dummy value of the returned vector is obtained by applying [f] to the dummy value of [a]. If this is not what you want, first create a new vector and then fill it with the value [f (get a 0)], [f (get a 1)], etc. *) (*@ a2 = map ~dummy a1 f ensures length a2.view = length a1.view ensures forall i. 0 <= i < length a1.view -> a2.view[i] = f a1.view[i] *) val mapi : dummy:'b -> 'a t -> (int -> 'a -> 'b) -> 'b t (** Same as {!Vector.map}, but the function is applied to the index of the element as first argument, and the element itself as second argument. Note: the dummy value of the returned vector is obtained by applying [f 0] to the dummy value of [a]. *) (*@ a2 = mapi ~dummy a1 f ensures length a2.view = length a1.view ensures forall i: int. 0 <= i < length a1.view -> a2.view[i] = f i a1.view[i] *) val copy: 'a t -> 'a t (** [copy a] returns a copy of [a], that is, a fresh vector containing the same elements as [a]. *) (*@ a2 = copy a1 ensures length a2.view = length a1.view ensures forall i. 0 <= i < length a1.view -> a2.view[i] = a1.view[i] *) val fold_left : 'b t -> ('a -> 'b -> 'a) -> 'a -> 'a (** [fold_left f x a] computes [f (... (f (f x (get a 0)) (get a 1)) ...) (get a (n-1))], where [n] is the length of the vector [a]. *) (*@ r = fold_left a f acc ensures r = Seq.fold_left f acc a.view *) val fold_right : 'b t -> ('b -> 'a -> 'a) -> 'a -> 'a (** [fold_right f a x] computes [f (get a 0) (f (get a 1) ( ... (f (get a (n-1)) x) ...))], where [n] is the length of the vector [a]. *) (*@ r = fold_right a f acc ensures r = Seq.fold_right f a.view acc *) val iter : ('a -> unit) -> 'a t -> unit (** [iter f a] applies function [f] in turn to all the elements of [a]. It is equivalent to [f (get a 0); f (get a 1); ...; f (get a (length a - 1))]. *) (*@ iter f a equivalent "for i = 0 to length a - 1 do f (get a i) done" *) (* equivalent {| for i = 0 to length a - 1 do f (get a i) done |} equivalent ( for i = 0 to length a - 1 do f (get a i) done ) equivalent to begin for i = 0 to length a - 1 do f (get a i) done end *) val iteri : (int -> 'a -> unit) -> 'a t -> unit (** Same as {!Vector.iter}, but the function is applied to the index of the element as first argument, and the element itself as second argument. *) (*@ iteri f a equivalent "for i = 0 to length a - 1 do f i (get a i) done" *) (** {2 Stack interface} Contrary to standard library's {Stack}, module {Vector} uses less space (between N and 2N words, instead of 3N) and has better data locality. *) val push: 'a t -> 'a -> unit (** [push a x] appends [x] at the end of vector [a], i.e., increases the size of [a] by one and stores [x] at the rightmost position. Note: the order of the arguments is not that of {!Stack.push}. *) (*@ push a x requires length a.view < Sys.max_array_length modifies a ensures length a.view = length (old a.view) + 1 ensures a.view[length a.view - 1] = x ensures forall i. 0 <= i < length (old a.view) -> a.view[i] = (old a).view[i] *) exception Empty val pop: 'a t -> 'a (** [pop a] removes and returns the rightmost element in vector [a], or raises [Empty] if the stack is empty. *) (*@ x = pop a modifies a raises Empty -> length a.view = length (old a).view = 0 ensures length a.view = length (old a).view - 1 ensures x = (old a).view[length a.view] ensures forall i. 0 <= i < length a.view -> a.view[i] = (old a).view[i] *) val pop_opt: 'a t -> 'a option (** similar to [pop], but with an option instead of an exception *) (*@ r = pop_opt a modifies a ensures match r with | None -> length a.view = length (old a).view = 0 | Some x -> length a.view = length (old a).view - 1 /\ x = (old a).view[length a.view] /\ forall i. 0 <= i < length a.view -> a.view[i] = (old a).view[i] *) val top: 'a t -> 'a (** [top a] returns the rightmost element in vector [a], or raises [Empty] if the vector is empty. *) (*@ x = top a requires 0 < length a.view ensures x = a.view[length a.view - 1] *) val top_opt: 'a t -> 'a option (** similar to [top], but with an option instead of an exception *) (*@ r = top_opt a ensures match r with | None -> length a.view = 0 | Some x -> x = a.view[length a.view - 1] *) (** {2 Conversions to/from arrays and lists} *) (* val to_list : 'a t -> 'a list (** [to_list a] returns the list of all the elements of [a]. *) val of_list: dummy:'a -> 'a list -> 'a t (** [of_list dummy l] returns a fresh vector containing the elements of [l]. *) val to_array: 'a t -> 'a array (** [to_array a] returns the array of all the elements of [a]. *) val of_array: dummy:'a -> 'a array -> 'a t (** [of_array dummy a] returns a fresh vector containing the elements of [a]. *) *) (** {2 Only if you know what you are doing...} *) (* val unsafe_resize: 'a t -> int -> unit val unsafe_get : 'a t -> int -> 'a val unsafe_set : 'a t -> int -> 'a -> unit *) why3-1.2.1/src/util/print_tree.ml0000644000175100017510000000576413555524575017446 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/util/cmdline.mli0000644000175100017510000000163513555524575017050 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/util/wstdlib.ml0000644000175100017510000000531213555524575016730 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/util/exthtbl.ml0000644000175100017510000000400713555524575016732 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/util/bigInt.ml0000644000175100017510000000373713555524575016505 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/util/hashcons.mli0000644000175100017510000000525313555524575017243 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/util/sysutil.ml0000644000175100017510000001213613555524575016776 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 write_file f c = let oc = open_out f in output_string oc c; close_out oc 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 let concat f1 f2 = if Filename.is_relative f2 then Filename.concat f1 f2 else f2 let system_independent_path_of_file f = let rec aux acc f = 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 b::acc else if f=d then (* we are at the root *) acc else let b = Filename.basename f in aux (b::acc) d in aux [] f (* 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 system_dependent_absolute_path dir p = let rec file_of_path l = match l with | [] -> "" | [x] -> x | x::l -> Filename.concat x (file_of_path l) in let f = file_of_path p in Filename.concat dir f let relativize_filename base f = let rec aux abs ab af = match ab,af with | x::rb, y::rf when x=y -> aux (x::abs) rb rf | _ -> let rec aux2 abs rel p = match p with | [] -> rel | x::rb -> (if x = Filename.current_dir_name then aux2 abs rel rb else if x = Filename.parent_dir_name then match abs with | x::rem -> aux2 rem (x::rel) rb | [] -> aux2 [] rel rb else aux2 (x::abs) (Filename.parent_dir_name::rel) rb) in aux2 abs af ab in aux [] (system_independent_path_of_file base) (system_independent_path_of_file 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-1.2.1/src/util/warning.mli0000644000175100017510000000202713555524575017076 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/util/lexlib.mll0000644000175100017510000001052313555524575016713 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 let char_for_backslash = function | 'n' -> '\n' | 't' -> '\t' | c -> c } let newline = '\r'* '\n' rule utf8_tail b n = parse | eof { false } | ['\128'-'\191'] as c { Buffer.add_char b c; n == 1 || utf8_tail b (n - 1) lexbuf } | _ { false } and comment = parse | "(*)" { comment lexbuf } | "*)" { () } | "(*" { comment lexbuf; comment lexbuf } | newline { new_line lexbuf; comment lexbuf } | eof { raise Not_found } | _ { comment lexbuf } and string buf = parse | "\"" { Buffer.contents buf } | "\\" newline { new_line lexbuf; string_skip_spaces buf lexbuf } | "\\" (_ as c) { Buffer.add_char buf (char_for_backslash c); string buf lexbuf } | newline { new_line lexbuf; Buffer.add_char buf '\n'; string buf lexbuf } | eof { raise Not_found } | _ as c { Buffer.add_char buf c; string buf lexbuf } and string_skip_spaces buf = parse | [' ' '\t']* { string buf lexbuf } { exception UnterminatedComment exception UnterminatedString exception IllegalCharacter of string let () = Exn_printer.register (fun fmt e -> match e with | UnterminatedComment -> Format.fprintf fmt "unterminated comment" | UnterminatedString -> Format.fprintf fmt "unterminated string" | IllegalCharacter s -> Format.fprintf fmt "illegal character %s" s | _ -> raise e) let loc lb = Loc.extract (lexeme_start_p lb, lexeme_end_p lb) let comment lexbuf = let start = loc lexbuf in try comment lexbuf with Not_found -> raise (Loc.Located (start, UnterminatedComment)) let string lexbuf = let start = loc lexbuf in try string (Buffer.create 128) lexbuf with Not_found -> raise (Loc.Located (start, UnterminatedString)) 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 backjump lexbuf chars = if chars < 0 || chars > lexbuf.lex_curr_pos - lexbuf.lex_start_pos then invalid_arg "Lexlib.backjump"; let pos = lexbuf.lex_curr_p in lexbuf.lex_curr_pos <- lexbuf.lex_curr_pos - chars; lexbuf.lex_curr_p <- { pos with pos_cnum = 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 let illegal_character c lexbuf = let loc = loc lexbuf in let b = Buffer.create 2 in Buffer.add_char b c; let n = match c with | '\000'..'\127' -> 0 | '\192'..'\223' -> 1 | '\224'..'\239' -> 2 | '\240'..'\247' -> 3 | _ -> -1 in if n <> 0 && (n == -1 || not (utf8_tail b n lexbuf)) then begin (* invalid encoding, convert the first character to a utf8 one *) Buffer.reset b; let c = Char.code c in Buffer.add_char b (Char.chr (0xC0 lor (c lsr 6))); Buffer.add_char b (Char.chr (c land 0xBF)); end; (* TODO: check that the buffer does not hold a utf8 character in one of the invalid ranges *) raise (Loc.Located (loc, IllegalCharacter (Buffer.contents b))) } why3-1.2.1/src/util/cmdline.ml0000644000175100017510000000630513555524575016676 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/util/exn_printer.mli0000644000175100017510000000220713555524575017766 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/util/extset.ml0000644000175100017510000001006713555524575016577 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 val contains: t -> elt -> bool val add_left: t -> elt -> t val remove_left: t -> elt -> t val print: (Format.formatter -> elt -> unit) -> Format.formatter -> t -> unit 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 let contains = M.contains let add_left s e = M.add e () s let remove_left s e = M.remove e s let print print_elt fmt s = if is_empty s then Format.fprintf fmt "{}" else begin Format.fprintf fmt "@[{ "; Pp.print_iter1 iter Pp.comma print_elt fmt s; Format.fprintf fmt "}@]" end end module type OrderedType = Set.OrderedType module Make(Ord: OrderedType) = MakeOfMap(Extmap.Make(Ord)) why3-1.2.1/src/util/json_lexer.mll0000644000175100017510000000521213555524575017603 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 open Lexing open Json_parser } let int = '-'? ['0'-'9'] ['0'-'9']* let digit = ['0'-'9'] let frac = '.' digit* let exp = ['e' 'E'] ['-' '+']? digit+ let float = digit* frac? exp? let white = [' ' '\t']+ let newline = '\r' | '\n' | "\r\n" let name = ['a'-'z' 'A'-'Z' '_'] ['a'-'z' 'A'-'Z' '0'-'9' '_']* let hexadigit = ['0'-'9' 'a'-'f' 'A'-'F'] rule read = parse | white { read lexbuf } | newline { new_line lexbuf; read lexbuf } | int { INT (int_of_string (Lexing.lexeme lexbuf)) } | float { FLOAT (float_of_string (Lexing.lexeme lexbuf)) } | "true" { TRUE } | "false" { FALSE } | "null" { NULL } | '"' { read_string (Buffer.create 17) lexbuf } | '{' { LEFTBRC } | '}' { RIGHTBRC } | '[' { LEFTSQ } | ']' { RIGHTSQ } | ':' { COLON } | ',' { COMMA } | _ { raise (SyntaxError ("Unexpected char: " ^ Lexing.lexeme lexbuf)) } | eof { EOF } and read_string buf = parse | '"' { STRING (Buffer.contents buf) } | '\\' '"' { Buffer.add_char buf '"'; read_string buf lexbuf } | '\\' '/' { Buffer.add_char buf '/'; read_string buf lexbuf } | '\\' '\\' { Buffer.add_char buf '\\'; read_string buf lexbuf } | '\\' 'b' { Buffer.add_char buf '\b'; read_string buf lexbuf } | '\\' 'f' { Buffer.add_char buf '\012'; read_string buf lexbuf } | '\\' 'n' { Buffer.add_char buf '\n'; read_string buf lexbuf } | '\\' 'r' { Buffer.add_char buf '\r'; read_string buf lexbuf } | '\\' 't' { Buffer.add_char buf '\t'; read_string buf lexbuf } | '\\' 'u' '0' '0' (hexadigit hexadigit as s) { Buffer.add_char buf (Char.chr (int_of_string ("0x" ^ s))); read_string buf lexbuf } | [^ '"' '\\']+ { Buffer.add_string buf (Lexing.lexeme lexbuf); read_string buf lexbuf } | _ { raise (SyntaxError ("Illegal string character: " ^ (Buffer.contents buf) ^ Lexing.lexeme lexbuf)) } | eof { raise (SyntaxError ("String is not terminated")) } why3-1.2.1/src/util/warning.ml0000644000175100017510000000215013555524575016722 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 pp_set_margin fmt 1000000000; pp_open_box fmt 0; let handle fmt = pp_print_flush fmt (); !hook ?loc (Buffer.contents b) in kfprintf handle fmt p why3-1.2.1/src/util/debug.mli0000644000175100017510000000630213555524575016517 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/util/rc.mli0000644000175100017510000001745713555524575016052 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 -> Wstdlib.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-1.2.1/src/util/number.ml0000644000175100017510000004377313555524575016565 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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_literal = | IConstRaw of BigInt.t | IConstDec of string | IConstHex of string | IConstOct of string | IConstBin of string type integer_constant = { ic_negative : bool; ic_abs : integer_literal; } type real_literal = | RConstDec of string * string * string option (* int / frac / exp *) | RConstHex of string * string * string option type real_constant = { rc_negative : bool; rc_abs : real_literal; } type constant = | ConstInt of integer_constant | ConstReal of real_constant let is_negative c = match c with | ConstInt i -> i.ic_negative | ConstReal r -> r.rc_negative 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_literal_dec s = check_integer_literal 10 is_dec s; IConstDec s let int_literal_hex s = check_integer_literal 16 is_hex s; IConstHex s let int_literal_oct s = check_integer_literal 8 is_oct s; IConstOct s let int_literal_bin s = check_integer_literal 2 is_bin s; IConstBin s let int_literal_raw i = assert (BigInt.ge i BigInt.zero); IConstRaw i let int_const_of_big_int n = let neg, n = if BigInt.ge n BigInt.zero then false, n else true, BigInt.minus n in { ic_negative = neg; ic_abs = IConstRaw n } let int_const_of_int n = int_const_of_big_int (BigInt.of_int n) let const_of_big_int n = ConstInt (int_const_of_big_int n) let const_of_int n = const_of_big_int (BigInt.of_int n) 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_literal c = match c with | IConstRaw i -> i | 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 compute_int_constant c = let a = compute_int_literal c.ic_abs in if c.ic_negative then BigInt.minus a else a let to_small_integer i = match i with | IConstRaw i -> BigInt.to_int i | IConstDec s -> int_of_string s | IConstHex s -> int_of_string ("0x"^s) | IConstOct s -> int_of_string ("0o"^s) | IConstBin s -> int_of_string ("0b"^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 'a negative_format = ((Format.formatter->'a->unit)->'a->unit,Format.formatter,unit) format type number_support = { long_int_support : bool; extra_leading_zeros_support : bool; negative_int_support : (integer_literal negative_format) number_support_kind; 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; negative_real_support : (real_literal negative_format) number_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_int_literal support fmt = function | IConstRaw i -> print_dec_int support fmt (BigInt.to_string i) | IConstDec i -> print_dec_int support fmt i | IConstHex i -> print_hex_int support fmt i | IConstOct i -> print_oct_int support fmt i | IConstBin i -> print_bin_int support fmt i let print_real_literal support fmt = function | RConstDec (i, f, e) -> print_dec_real support fmt i f e | RConstHex (i, f, e) -> print_hex_real support fmt i f e let print_int_constant support fmt i = if i.ic_negative then check_support support.negative_int_support (Some "(- %a)") (fun def n -> fprintf fmt def (print_int_literal support) n) (fun _ -> assert false) i.ic_abs else fprintf fmt "%a" (print_int_literal support) i.ic_abs let print_real_constant support fmt r = if r.rc_negative then check_support support.negative_real_support (Some "(- %a)") (fun def n -> fprintf fmt def (print_real_literal support) n) (fun _ -> assert false) r.rc_abs else fprintf fmt "%a" (print_real_literal support) r.rc_abs let print support fmt = function | ConstInt i -> print_int_constant support fmt i | ConstReal r -> print_real_constant support fmt r 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 = euclidean_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; } let create_range lo hi = { ir_lower = lo; ir_upper = hi; } exception OutOfRange of integer_constant let check_range c {ir_lower = lo; ir_upper = hi} = let cval = compute_int_literal c.ic_abs in let cval = if c.ic_negative then BigInt.minus cval else cval 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_literal 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 full_support = { long_int_support = true; extra_leading_zeros_support = true; negative_int_support = Number_default; dec_int_support = Number_default; hex_int_support = Number_default; oct_int_support = Number_default; bin_int_support = Number_default; def_int_support = Number_default; negative_real_support = Number_default; dec_real_support = Number_default; hex_real_support = Number_default; frac_real_support = Number_default; def_real_support = Number_default; } (* let print_integer_literal 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_literal 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_unsigned_constant fmt = function | ConstInt c -> print_integer_literal fmt c | ConstReal c -> print_real_literal fmt c let print_constant fmt c = if c.is_positive then print_unsigned_constant fmt c.abs_value else fprintf fmt "-%a" print_unsigned_constant c.abs_value *) 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_literal full_support) c | OutOfRange c -> fprintf fmt "Integer literal %a is out of range" (print_int_constant full_support) c | _ -> raise exn) let print_constant = print full_support why3-1.2.1/src/util/weakhtbl.ml0000644000175100017510000001377113555524575017071 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/util/sysutil.mli0000644000175100017510000000647513555524575017160 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 (* [write_file f c] writes the content [c] into the file [f] *) val write_file : string -> string -> 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 concat : string -> string -> string (** like [Filename.concat] but returns only second string when it is already absolute *) val system_independent_path_of_file : string -> string list (** [system_independent_path_of_file filename] return the access path of [filename], in a system-independent way *) val system_dependent_absolute_path : string -> string list -> string (** [system_dependent_absolute_path d p] returns the system-dependent absolute path for the abstract path [p] relative to directory [d] *) val relativize_filename : string -> string -> string list (** [relativize_filename base filename] returns an access path for filename [filename] relatively to [base]. The [filename] is split into path components using the system-dependent calls to [Filename.dirname] and [Filename.basename]. OBSOLETE COMMENT? [base] should not contain occurrences of "." and "..", which can be removed by calling first [normalize_filename]. FIXME: this function does not handle symbolic links properly *) val uniquify : string -> string (** find filename that doesn't exist based on the given filename. Be careful the file can be taken after the return of this function. *) why3-1.2.1/src/util/lists.mli0000644000175100017510000000615313555524575016573 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 map_filter : ('a -> 'b option) -> 'a list -> 'b list 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-1.2.1/src/util/pp.ml0000644000175100017510000001535513555524575015707 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 type 'a pp = formatter -> 'a -> unit 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_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_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 slash 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 = (* useless: this is the same as Format.asprintf *) 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-1.2.1/src/util/extmap.mli0000644000175100017510000003215613555524575016735 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 list of bindings. *) val contains: 'a t -> key -> bool (** [contains m x] is the same as [mem x m]. *) val domain : 'a t -> unit t (** [domain m] returns the set of keys of bindings in [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-1.2.1/src/util/loc.ml0000644000175100017510000000771013555524575016041 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/util/lexlib.mli0000644000175100017510000000210713555524575016707 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 comment : Lexing.lexbuf -> unit val string : Lexing.lexbuf -> string val update_loc : Lexing.lexbuf -> string option -> int -> int -> unit val backjump : Lexing.lexbuf -> int -> unit val remove_leading_plus : string -> string val remove_underscores : string -> string val illegal_character : char -> Lexing.lexbuf -> 'a why3-1.2.1/src/util/debug.ml0000644000175100017510000001510313555524575016345 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 = { flag_name : string; mutable flag_value : bool } 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 = { flag_name = s; flag_value = 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.flag_value,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.flag_value let test_noflag s = not s.flag_value let set_flag s = s.flag_value <- true let unset_flag s = s.flag_value <- false let toggle_flag s = s.flag_value <- not s.flag_value 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.flag_value then begin if timestamp.flag_value then Format.fprintf !formatter "<%f,%s>" (Unix.gettimeofday () -. time_start) flag.flag_name else Format.fprintf !formatter "<%s>" flag.flag_name; 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 ()) (* top-level code disabled because issue #383 and nobody knows why this code was for (** 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-1.2.1/src/util/lists.ml0000644000175100017510000000730013555524575016415 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 map_filter f l = List.fold_right (fun e l -> match f e with Some e -> e :: l | None -> l) l [] 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-1.2.1/src/util/opt.ml0000644000175100017510000000341413555524575016063 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/0000755000175100017510000000000013555524575015763 5ustar guillaumeguillaumewhy3-1.2.1/src/transform/eliminate_literal.mli0000644000175100017510000000134713555524575022156 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/destruct.ml0000644000175100017510000004316113555524575020157 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 Trans open Args_wrapper open Generic_arg_trans_utils (** This file contains transformations with arguments that eliminates logic connectors (instantiate, destruct, destruct_term). *) (** Explanation *) (* Explanation for destruct premises *) let destruct_expl = "destruct premise" let is_lsymbol t = match t.t_node with | Tapp (_, []) -> true | _ -> false let create_constant ?name ty = let name = Opt.get_def "x" name in let fresh_name = Ident.id_fresh name in let ls = create_lsymbol fresh_name [] (Some ty) in (ls, create_param_decl ls) let chose_next_name names = match names with | hd :: tl -> (Some hd, tl) | [] -> (None, []) let rec return_list ~names list_types type_subst = match list_types with | [] -> (names, []) | hd :: tl -> let (name, names) = chose_next_name names in let ty = Ty.ty_inst type_subst hd in let (names, res) = return_list ~names tl type_subst in (names, create_constant ?name ty :: res) let my_ls_app_inst ls ty = match ls.ls_value, ty with | Some _, None -> raise (PredicateSymbolExpected ls) | None, Some _ -> raise (FunctionSymbolExpected ls) | Some vty, Some ty -> Ty.ty_match Ty.Mtv.empty vty ty | None, None -> Ty.Mtv.empty let rec build_decls ~names cls x = match cls with | [] -> [] | (cs, _) :: tl -> let type_subst = my_ls_app_inst cs x.t_ty in let (names, l) = return_list ~names cs.ls_args type_subst in let teqx = (t_app cs (List.map (fun x -> t_app_infer (fst x) []) l) x.t_ty) in let ht = t_equ x teqx in let h = Decl.create_prsymbol (gen_ident "h") in let new_hyp = Decl.create_prop_decl Decl.Paxiom h ht in ((List.map snd l) @ [new_hyp]) :: build_decls ~names tl x (* Enumerate all constants of a term *) let rec compounds_of acc (t: term) = match t.t_node with | Tapp (ls, _) -> Term.t_fold compounds_of (Term.Sls.add ls acc) t | _ -> Term.t_fold compounds_of acc t (* This tactic acts on a term of algebraic type. It introduces one new goal per constructor of the type and introduce corresponding variables. It also introduce the equality between the term and its destruction in the context. When replace is set to true, a susbtitution is done when x is an lsymbol. *) let destruct_term ?names replace (x: term) : Task.task tlist = let names = Opt.get_def [] names in (* Shortcut function *) let add_decl_list task l = List.fold_left (fun task d -> Task.add_decl task d) task l in (* Shortcut used for map *) let add_decl d task = Task.add_decl task d in let ty = x.t_ty in match ty with | None -> raise (Cannot_infer_type "destruct") | Some ty -> begin match ty.Ty.ty_node with | Ty.Tyvar _ -> raise (Cannot_infer_type "destruct") | Ty.Tyapp (ts, _) -> (* This records the constants that the destructed terms is defined with (in order not to generate the equality before their definition). *) let ls_of_x = compounds_of Term.Sls.empty x in (* [ls_of_x] is the set of constants used in the term definition. Each time we encounter one, we remove it from the Sls. When there are none left, we can put the definition of equality for the destructed term. [r] are the new declarations made by the destruction. [defined] records is set to true when the definitions have been added [task_list] is the tasks under construction *) let trans = fold_map (fun t ((ls_of_x, r, defined), task_list) -> match t.Task.task_decl.Theory.td_node with | Theory.Decl d -> begin match d.d_node with (* TODO not necessary to check this first: can be optimized *) | _ when (not defined) && Term.Sls.is_empty ls_of_x -> if r = [] then ((ls_of_x, r, defined), List.map (add_decl d) task_list) else ((ls_of_x, [], true), let add_r = List.fold_left (fun acc_task_list task -> List.fold_left (fun acc_task_list ldecl -> (add_decl_list task ldecl) :: acc_task_list) acc_task_list r) [] task_list in List.map (add_decl d) add_r) | Dlogic dls -> let ls_of_x = List.fold_left (fun acc (ls, _) -> Term.Sls.remove ls acc) ls_of_x dls in ((ls_of_x, r, defined), List.map (add_decl d) task_list) | Dparam ls -> let ls_of_x = Term.Sls.remove ls ls_of_x in ((ls_of_x, r, defined), List.map (add_decl d) task_list) | Dind (_, ils) -> let ls_of_x = List.fold_left (fun acc (ls, _) -> Term.Sls.remove ls acc) ls_of_x ils in ((ls_of_x, r, defined), List.map (add_decl d) task_list) | Ddata dls -> begin try let cls = List.assoc ts dls in let r = build_decls ~names cls x in ((ls_of_x, r, defined), List.map (add_decl d) task_list) with Not_found -> ((ls_of_x, r, defined), List.map (add_decl d) task_list) end | Dprop (Pgoal, _, _) -> ((ls_of_x, r, defined), List.map (add_decl d) task_list) | _ -> ((ls_of_x, r, defined), List.map (add_decl d) task_list) end | _ -> ((ls_of_x, r, defined), List.map (fun task -> Task.add_tdecl task t.Task.task_decl) task_list) ) (ls_of_x, [], false) [None] in if replace && is_lsymbol x then compose_l trans (singleton (Subst.subst [x])) else trans end (** [expand p] returns a list of triples [(bindings, equalities, term)], where 1. [bindings] map pattern variables in [p] to term variables in [term] 2. [equalities] contain equalities between pattern variables from [as] patterns, term variables, and terms 3. [term] corresponds to [p] under [bindings] and [equalities] *) let rec expand (p:pattern) : ((vsymbol option * lsymbol) list * (vsymbol * lsymbol * term) list * term) list = match p.pat_node with | Pwild -> let ls = let id = Ident.id_fresh "_" in create_lsymbol id [] (Some p.pat_ty) in [[None, ls], [], t_app ls [] ls.ls_value] | Pvar v -> let ls = let id = Ident.id_clone v.vs_name in create_lsymbol id [] (Some p.pat_ty) in [[Some v, ls], [], t_app ls [] ls.ls_value] | Papp (ls, args) -> let rec aux args = match args with | [] -> [[], [], []] (* really. *) | arg::args' -> let for_args' (x, eqs, t) (x', eqs', l) = x@x', eqs@eqs', t::l in let for_arg l' arg = List.map (for_args' arg) l' in List.flatten (List.map (for_arg (aux args')) (expand arg)) in let for_arg (bds, eqs, args) = bds, eqs, t_app ls args (Some p.pat_ty) in List.map for_arg (aux args) | Por (p1, p2) -> expand p1 @ expand p2 | Pas (p, v) -> let ls = let id = Ident.id_clone v.vs_name in create_lsymbol id [] (Some p.pat_ty) in let for_t (bds, eqs, t) = let eqs' = eqs@[(v, ls, t)] in let t' = t_app ls [] ls.ls_value in bds, eqs', t' in List.map for_t (expand p) (* Type used to tag new declarations inside the destruct function. *) type is_destructed = | Axiom_term of term | Param of Decl.decl | Goal_term of term (* [destruct_fmla ~decl_name t]: This destroys a headterm and generate an appropriate lists of goals/declarations that can be used by decl_goal_l. [recursive] when false, disallow the recursive calls to destruct_fmla In this function, we use "parallel" to refer to elements of the topmost list which are eventually converted to disjoint tasks. *) let destruct_fmla ~recursive (t: term) = (* Standard way to know that a lsymbol is a constructor TODO ? *) let is_constructor l = l.ls_constr <> 0 in (* Main recursive function: [toplevel] when true, removing implications is allowed. Become false as soon as we destruct non-implication construct *) let rec destruct_fmla ~toplevel (t: term) = let destruct_fmla_exception ~toplevel t = if not recursive then [[Axiom_term t]] else match destruct_fmla ~toplevel t with | exception _ -> [[Axiom_term t]] | l -> l in match t.t_node with | Tbinop (Tand, t1, t2) -> let l1 = destruct_fmla_exception ~toplevel:false t1 in let l2 = destruct_fmla_exception ~toplevel:false t2 in (* For each parallel branch of l1 we have to append *all* parallel branch of l2 which are not new goals. In case of new goals, we are not allowed to use the left/right conclusions to prove the goal. Example: H: (A -> (B /\ C) /\ (C -> A) Goal g: C *) (* TODO efficiency: this is not expected to work on very large terms with tons of Tand/Tor. *) List.fold_left (fun par_acc seq_list1 -> List.fold_left (fun par_acc seq_list2 -> par_acc @ [seq_list1 @ seq_list2]) par_acc l2 ) [] l1 | Tbinop (Tor, t1, t2) -> let l1 = destruct_fmla_exception ~toplevel:false t1 in let l2 = destruct_fmla_exception ~toplevel:false t2 in (* The two branch are completely disjoint. We just concatenate them to ensure they are done in parallel *) l1 @ l2 | Tbinop (Timplies, t1, t2) when toplevel -> (* The premises is converted to a goal. The rest is recursively destructed in parallel. *) let l2 = destruct_fmla_exception ~toplevel t2 in [Goal_term t1] :: l2 | Tquant (Texists, tb) -> let (vsl, tr, te) = Term.t_open_quant tb in begin match vsl with | x :: tl -> let ls = create_lsymbol (Ident.id_clone x.vs_name) [] (Some x.vs_ty) in let tx = fs_app ls [] x.vs_ty in let x_decl = create_param_decl ls in (try let part_t = t_subst_single x tx te in let new_t = t_quant_close Texists tl tr part_t in (* The recursive call is done after new symbols are introduced so we readd the new decls to every generated list. *) let l_t = destruct_fmla_exception ~toplevel:false new_t in List.map (fun x -> Param x_decl :: x) l_t with | Ty.TypeMismatch (ty1, ty2) -> raise (Arg_trans_type ("destruct_exists", ty1, ty2))) | [] -> raise (Arg_trans ("destruct_exists")) end (* Beginning of cases for injection transformation. With C1, C2 constructors, simplify H: C1 ?a = C1 ?b into ?a = ?b and remove trivial hypothesis of the form H: C1 <> C2. *) | Tapp (ls, [{t_node = Tapp (cs1, l1); _}; {t_node = Tapp (cs2, l2); _}]) when ls_equal ls ps_equ && is_constructor cs1 && is_constructor cs2 -> (* Cs1 [l1] = Cs2 [l2] *) if ls_equal cs1 cs2 then (* Create new hypotheses for equalities of l1 and l2 *) try [List.map2 (fun x1 x2 -> let equal_term = t_app_infer ps_equ [x1; x2] in Axiom_term equal_term) l1 l2] with | _ -> [[Axiom_term t]] else (* TODO Replace the hypothesis by False or manage to remove the goal. *) [[Axiom_term t_false]] | Tnot {t_node = Tapp (ls, [{t_node = Tapp (cs1, _); _}; {t_node = Tapp (cs2, _); _}]); _} when ls_equal ls ps_equ && is_constructor cs1 && is_constructor cs2 -> (* Cs1 [l1] = Cs2 [l2] *) if ls_equal cs1 cs2 then [[Axiom_term t]] else (* The hypothesis is trivial because Cs1 <> Cs2 thus useless *) [[]] | Tif (t1, t2, t3) -> let ts2 = destruct_fmla_exception ~toplevel:false t2 |> List.map (fun ts -> Axiom_term t1 :: ts) in let ts3 = destruct_fmla_exception ~toplevel:false t3 |> List.map (fun ts -> Axiom_term (t_not t1) :: ts) in ts2 @ ts3 | Tcase (t, tbs) when toplevel -> let for_branch tb = let pat, rhs = t_open_branch tb in let for_expansion (bds, eqs, t') = let mvs = let for_binding acc vls = match vls with | Some v, ls -> Mvs.add v (t_app ls [] ls.ls_value) acc | None, _ -> acc in List.fold_left for_binding Mvs.empty bds in let mvs = let for_eq acc (vs, ls, _) = Mvs.add vs (t_app ls [] ls.ls_value) acc in List.fold_left for_eq mvs eqs in let for_rhs rhs' = let mk_const (_, ls) = Param (create_param_decl ls) in let mk_eq_axiom (_, ls, t) = Param (create_logic_decl [make_ls_defn ls [] t]) in List.map mk_const bds @ List.map mk_eq_axiom eqs @ [Axiom_term (t_equ t t')] @ rhs' in t_subst mvs rhs |> destruct_fmla_exception ~toplevel:false |> List.map for_rhs in List.map for_expansion (expand pat) in List.map for_branch tbs |> List.flatten |> List.flatten | _ -> raise (Arg_trans ("destruct")) in destruct_fmla ~toplevel:true t (* Destruct the head term of an hypothesis if it is either conjunction, disjunction or exists *) let destruct ~recursive pr : Task.task tlist = let create_destruct_axiom t = let new_pr = create_prsymbol (Ident.id_clone pr.pr_name) in create_prop_decl Paxiom new_pr t in let create_destruct_goal t = let new_pr = create_prsymbol (gen_ident "G") in create_goal ~expl:destruct_expl new_pr t in decl_goal_l (fun d -> match d.d_node with | Dprop (Paxiom, dpr, ht) when Ident.id_equal dpr.pr_name pr.pr_name -> let decl_list = destruct_fmla ~recursive ht in List.map (fun l -> List.map (fun x -> match x with | Axiom_term t -> Normal_decl (create_destruct_axiom t) | Param d -> Normal_decl d | Goal_term t -> Goal_decl (create_destruct_goal t) ) l) decl_list | _ -> [[Normal_decl d]]) None (* from task [delta, name:forall x.A |- G, build the task [delta,name:forall x.A,name':A[x -> t]] |- G] When [rem] is true, the general hypothesis is removed. *) let instantiate ~rem (pr: Decl.prsymbol) lt = let r = ref [] in decl (fun d -> match d.d_node with | Dprop (pk, dpr, ht) when Ident.id_equal dpr.pr_name pr.pr_name && pk <> Pgoal -> let t_subst = subst_forall_list ht lt in let new_pr = create_prsymbol (gen_ident "Hinst") in let new_decl = create_prop_decl pk new_pr t_subst in r := [new_decl]; (* We remove the original hypothesis only if [rem] is set *) if rem then [] else [d] | Dprop (Pgoal, _, _) -> !r @ [d] | _ -> [d]) None let () = wrap_and_register ~desc:"instantiate generates a new hypothesis with quantified variables of prop replaced with terms" "instantiate" (Tprsymbol (Ttermlist Ttrans)) (instantiate ~rem:false) let () = wrap_and_register ~desc:"instantiate generates a new hypothesis with quantified variables of prop replaced with terms. Also remove the old hypothesis." "inst_rem" (Tprsymbol (Ttermlist Ttrans)) (instantiate ~rem:true) let () = wrap_and_register ~desc:"destruct destructs the head logic constructor of hypothesis name (/\\, \\/, -> or <->).\nTo destruct a literal of algebraic type, use destruct_term." "destruct" (Tprsymbol Ttrans_l) (destruct ~recursive:false) let () = wrap_and_register ~desc:"destruct recursively destructs the head logic constructor of hypothesis name (/\\, \\/, -> or <->).\nTo destruct a literal of algebraic type, use destruct_term." "destruct_rec" (Tprsymbol Ttrans_l) (destruct ~recursive:true) let () = wrap_and_register ~desc:"destruct as an algebraic type. Option using can be used to name elements created by destruct_term" "destruct_term" (Tterm (Topt ("using", Tidentlist Ttrans_l))) (fun t names -> destruct_term ?names false t) let () = wrap_and_register ~desc:"destruct as an algebraic type and substitute the definition if an lsymbol was provided. Option using can be used to name elements created by destruct_term_subst" "destruct_term_subst" (Tterm (Topt ("using", Tidentlist Ttrans_l))) (fun t names -> destruct_term ?names true t) why3-1.2.1/src/transform/filter_trigger.ml0000644000175100017510000000524413555524575021332 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/lift_epsilon.ml0000644000175100017510000000601313555524575021004 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/simplify_array.mli0000644000175100017510000000130713555524575021521 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/intro_projections_counterexmp.ml0000644000175100017510000002124113555524575024520 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 is_proj_for_array_attr proj_name = match Str.search_forward (Str.regexp "'First\\|'Last") proj_name 0 with | _ -> true | exception Not_found -> false (* (* 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 *) 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 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 = (* Handle the case of predicates *) if term.t_ty = None then Term.t_iff t_new_constant term else 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_attr = ls.ls_name.id_attrs in let const_attr = append_to_model_element_name ~attrs:const_attr ~to_append:proj_name in (* Note that this location can now be None *) let const_loc = 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_fresh ~attrs:const_attr ?loc:const_loc const_name 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 ~attrs:projection.ls_name.id_attrs 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 an attribute "model_projected", otherwise returns []. There can be more projections for ls_projected. For each projection f the declarations include: - declaration of new constant with attributes of ls_projected, attribute "model" a nd attribute "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 attribute symbol that should be projected *) if not (Sattr.mem Ident.model_projected_attr ls_projected.ls_name.id_attrs) then (* ls_projected has not an attribute "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 (* [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 Theory.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@ attribute@ [%@model_projected]@ and@ projecting@ f@ \ for@ p@ creates@ declaration@ of@ new@ constant@ c@ with@ \ attribute@ [%@model]@ and@ an@ axiom@ c = f p." why3-1.2.1/src/transform/intro_vc_vars_counterexmp.ml0000644000175100017510000003223213555524575023626 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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." (* 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_attr l = attr_equal l Ity.annot_attr || attr_equal l model_vc_post_attr 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 Sattr.exists is_model_vc_attr t.t_attrs then begin vc_loc := t.t_loc; { vc_inside = true; vc_loc = t.t_loc; vc_pre_or_post = Sattr.mem model_vc_post_attr t.t_attrs } end else info (* 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 && Sattr.equal x.pre_attrs y.pre_attrs let hash p = Exthtbl.hash p end) let same_line_loc loc1 loc2 = match loc1, loc2 with | Some loc1, Some loc2 -> let (f1, l1, _, _) = Loc.get loc1 in let (f2, l2, _, _) = Loc.get loc2 in f1 = f2 && l1 = l2 | _ -> false let same_line_locs loc1 ls = let is_same = match ls.id_loc with | Some loc when same_line_loc (Some loc) loc1 -> true | _ -> false in is_same || Sattr.exists (fun x -> let loc = extract_written_loc x in same_line_loc loc loc1) ls.id_attrs let add_model_trace_attr name attrs = if Sattr.exists is_model_trace_attr attrs then attrs else let mt_attr = create_attribute ("model_trace:" ^ name) in Sattr.add mt_attr attrs (* 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_attr @param vc_loc is the location of the vc_attr (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 when not (same_line_locs info.vc_loc ls) -> (* variable inside the term T that triggers VC. If the variable should be in counterexample, introduce new constant in location loc with all attributes necessary for collecting it for counterexample and make it equal to the variable *) if relevant_for_counterexample ls then begin let const_attr = ls.id_attrs in let const_name = ls.id_string^"_vc_constant" in let axiom_name = ls.id_string^"_vc_axiom" in let labels_attr = Sattr.filter (fun x -> Strings.has_prefix "at:" x.attr_string) t.t_attrs in let const_attr = Sattr.union const_attr labels_attr in let const_attr = add_model_trace_attr ls.id_string const_attr in (* Create a new id here to check the couple name, location. *) let id_new = Ident.id_user ~attrs:const_attr 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 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_attr_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_attr, 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_attr @param vc_loc is the location of the vc_attr (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_attr_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 attribute, we have to allow it to be printed but it won't be available after its substitution *) (* preserve attributes and location of f *) let f = t_attr_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 Printf.sprintf "%s:%d:%d:%d" file line col1 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-1.2.1/src/transform/encoding_guards_full.ml0000644000175100017510000002603413555524575022477 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 Wstdlib 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-1.2.1/src/transform/instantiate_predicate.ml0000644000175100017510000001015513555524575022662 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/encoding_sort.ml0000644000175100017510000001315213555524575021154 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/eliminate_let.ml0000644000175100017510000000277313555524575021141 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 t = match t.t_node with | Tlet (t1,tb) when (if t.t_ty = None then pred else func) -> let t1 = elim_t func pred t1 in elim_t func pred (t_open_bound_with t1 tb) | _ -> t_map (elim_t func pred) t let eliminate_let_term = Trans.rewrite (elim_t true false) None let eliminate_let_fmla = Trans.rewrite (elim_t false true) None let eliminate_let = Trans.rewrite (elim_t true true) 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-1.2.1/src/transform/simplify_formula.ml0000644000175100017510000002142313555524575021700 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 attrset = Sattr.of_list [Term.asym_split] let rec fmla_simpl f = let f = if Sattr.disjoint f.t_attrs attrset then f else t_attr_set ?loc:f.t_loc (Sattr.diff f.t_attrs attrset) 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_attr_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 ~keep_model_vars sign f = function | [] -> [], f | vs::l -> let vsl, f = fmla_quant ~keep_model_vars sign f l in if keep_model_vars && has_a_model_attr vs.vs_name then vs::vsl, f else if t_v_occurs vs f = 0 then vsl, f else 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 ~keep_model_vars 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 ~keep_model_vars sign f' vsl in let f' = fmla_remove_quant ~keep_model_vars f' in t_attr_copy f (t_quant k (close vsl [] f')) | _ -> Term.t_map (fmla_remove_quant ~keep_model_vars) 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 ~keep_model_vars:false) None let simplify_trivial_wp_quantification = Trans.rewrite (fmla_remove_quant ~keep_model_vars:true) 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 ~keep_model_vars:false 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_attr_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-1.2.1/src/transform/filter_trigger.mli0000644000175100017510000000130713555524575021477 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/reflection.ml0000644000175100017510000007544613555524575020467 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 Ty open Decl open Ident open Task open Args_wrapper open Generic_arg_trans_utils exception NoReification let debug_reification = Debug.register_info_flag ~desc:"Reification" "reification" let debug_refl = Debug.register_info_flag ~desc:"Reflection transformations" "reflection" let expl_reification_check = Ident.create_attribute "expl:reification check" type reify_env = { kn: known_map; store: (vsymbol * int) Mterm.t; fr: int; subst: term Mvs.t; lv: vsymbol list; var_maps: ty Mvs.t; (* type of values pointed by each map*) crc_map: Coercion.t; ty_to_map: vsymbol Mty.t; env: Env.env; interps: Sls.t; (* functions that were inverted*) task: Task.task; bound_vars: Svs.t; (* bound variables, do not map them in a var map*) bound_fr: int; (* separate, negative index for bound vars*) } let init_renv kn crc lv env task = { kn=kn; store = Mterm.empty; fr = 0; subst = Mvs.empty; lv = lv; var_maps = Mvs.empty; crc_map = crc; ty_to_map = Mty.empty; env = env; interps = Sls.empty; task = task; bound_vars = Svs.empty; bound_fr = -1; } let rec reify_term renv t rt = let is_pvar p = match p.pat_node with Pvar _ -> true | _ -> false in let rec use_interp t = let r = match t.t_node with | Tconst _ -> true | Tvar _ -> false | Tapp (ls, []) -> begin match find_logic_definition renv.kn ls with | None -> false | Some ld -> let _,t = open_ls_defn ld in use_interp t end | Tapp (_, _) -> true | _ -> false in Debug.dprintf debug_reification "use_interp %a: %b@." Pretty.print_term t r; r in let add_to_maps renv vyl = let var_maps, ty_to_map = List.fold_left (fun (var_maps, ty_to_map) vy -> if Mty.mem vy.vs_ty ty_to_map then (Mvs.add vy vy.vs_ty var_maps, ty_to_map) else (Mvs.add vy vy.vs_ty var_maps, Mty.add vy.vs_ty vy ty_to_map)) (renv.var_maps, renv.ty_to_map) (List.map (fun t -> match t.t_node with Tvar vy -> vy | _ -> assert false) vyl) in { renv with var_maps = var_maps; ty_to_map = ty_to_map } in let open Theory in let th_list = Env.read_theory renv.env ["list"] "List" in let ty_list = ns_find_ts th_list.th_export ["list"] in let compat_h t rt = match t.t_node, rt.t_node with | Tapp (ls1,_), Tapp(ls2, _) -> ls_equal ls1 ls2 | Tquant (Tforall, _), Tquant (Tforall, _) | Tquant (Texists, _), Tquant (Texists, _)-> true | _ -> false in let is_eq_true t = match t.t_node with | Tapp (eq, [_; tr]) when ls_equal eq ps_equ && t_equal tr t_bool_true -> true | _ -> false in let lhs_eq_true t = match t.t_node with | Tapp (eq, [t; tr]) when ls_equal eq ps_equ && t_equal tr t_bool_true -> t | _ -> assert false in let rec invert_nonvar_pat vl (renv:reify_env) (p,f) t = Debug.dprintf debug_reification "invert_nonvar_pat p %a f %a t %a@." Pretty.print_pat p Pretty.print_term f Pretty.print_term t; if is_eq_true f && not (is_eq_true t) then invert_nonvar_pat vl renv (p, lhs_eq_true f) t else match p.pat_node, f.t_node, t.t_node with | Pwild , _, _ | Pvar _,_,_ when t_equal_nt_na f t -> Debug.dprintf debug_reification "case equal@."; renv, t | Papp (cs, pl), _,_ when compat_h f t && Svs.for_all (fun v -> t_v_occurs v f = 1) p.pat_vars && List.for_all is_pvar pl (* could remove this with a bit more work in term reconstruction *) -> Debug.dprintf debug_reification "case app@."; let rec rt_of_var svs f t v (renv, acc) = assert (not (Mvs.mem v acc)); Debug.dprintf debug_reification "rt_of_var %a %a@." Pretty.print_vs v Pretty.print_term f; if t_v_occurs v f = 1 && Svs.for_all (fun v' -> vs_equal v v' || t_v_occurs v' f = 0) svs then let renv, rt = invert_pat vl renv (pat_var v, f) t in renv, Mvs.add v rt acc else match f.t_node, t.t_node with | Tapp(ls1, la1), Tapp(ls2, la2) when ls_equal ls1 ls2 -> let rec aux la1 la2 = match la1, la2 with | f'::l1, t'::l2 -> if t_v_occurs v f' = 1 then rt_of_var svs f' t' v (renv, acc) else aux l1 l2 | _ -> assert false in aux la1 la2 | Tquant (Tforall, tq1), Tquant (Tforall, tq2) | Tquant (Texists, tq1), Tquant (Texists, tq2) -> let _, _, t1 = t_open_quant tq1 in let vl, _, t2 = t_open_quant tq2 in let bv = List.fold_left Svs.add_left renv.bound_vars vl in let renv = { renv with bound_vars = bv } in rt_of_var svs t1 t2 v (renv, acc) | _ -> raise NoReification in let rec check_nonvar f t = match f.t_node, t.t_node with | Tapp (ls1, la1), Tapp (ls2, la2) -> if Svs.for_all (fun v -> t_v_occurs v f = 0) p.pat_vars then (if not (ls_equal ls1 ls2) then raise NoReification); if ls_equal ls1 ls2 then List.iter2 check_nonvar la1 la2; | Tapp (ls,_), Tconst _ -> (* reject constants that do not match the definitions of logic constants*) if Svs.for_all (fun v -> t_v_occurs v f = 0) p.pat_vars then match find_logic_definition renv.kn ls with | None -> raise NoReification | Some ld -> let v,f = open_ls_defn ld in assert (v = []); check_nonvar f t else () | Tconst (Number.ConstInt c1), Tconst (Number.ConstInt c2) -> let open Number in if not (BigInt.eq (compute_int_constant c1) (compute_int_constant c2)) then raise NoReification | _ -> () (* FIXME add more failure cases if needed *) in check_nonvar f t; let renv, mvs = Svs.fold (rt_of_var p.pat_vars f t) p.pat_vars (renv, Mvs.empty) in let lrt = List.map (function | {pat_node = Pvar v} -> Mvs.find v mvs | _ -> assert false) pl in renv, t_app cs lrt (Some p.pat_ty) | Pvar v, Tapp (ls1, la1), Tapp(ls2, la2) when ls_equal ls1 ls2 && t_v_occurs v f = 1 -> Debug.dprintf debug_reification "case app_var@."; let renv, rt = List.fold_left2 (fun (renv, acc) f t -> if acc = None then if t_v_occurs v f > 0 then let renv, rt = (invert_pat vl renv (p, f) t) in renv, Some rt else renv, acc else (assert (t_v_occurs v f = 0); renv, acc)) (renv,None) la1 la2 in renv, Opt.get rt | Pvar v, Tquant(Tforall, tq1), Tquant(Tforall, tq2) | Pvar v, Tquant(Texists, tq1), Tquant(Texists, tq2) when t_v_occurs v f = 1 -> Debug.dprintf debug_reification "case quant_var@."; let _,_,t1 = t_open_quant tq1 in let vl,_,t2 = t_open_quant tq2 in let bv = List.fold_left Svs.add_left renv.bound_vars vl in let renv = { renv with bound_vars = bv } in invert_nonvar_pat vl renv (p, t1) t2 | Por (p1, p2), _, _ -> Debug.dprintf debug_reification "case or@."; begin try invert_pat vl renv (p1, f) t with NoReification -> invert_pat vl renv (p2, f) t end | Pvar _, Tvar _, Tvar _ | Pvar _, Tvar _, Tapp (_, []) | Pvar _, Tvar _, Tconst _ -> Debug.dprintf debug_reification "case vars@."; (renv, t) | Pvar _, Tapp (ls, _hd::_tl), _ -> Debug.dprintf debug_reification "case interp@."; invert_interp renv ls t | Papp (cs, [{pat_node = Pvar v}]), Tvar v', Tconst _ when vs_equal v v' -> Debug.dprintf debug_reification "case var_const@."; renv, t_app cs [t] (Some p.pat_ty) | Papp (cs, [{pat_node = Pvar _}]), Tapp(ls, _hd::_tl), _ when use_interp t (*FIXME*) -> Debug.dprintf debug_reification "case interp_var@."; let renv, rt = invert_interp renv ls t in renv, (t_app cs [rt] (Some p.pat_ty)) | Papp _, Tapp (ls1, _), Tapp(ls2, _) -> Debug.dprintf debug_reification "head symbol mismatch %a %a@." Pretty.print_ls ls1 Pretty.print_ls ls2; raise NoReification | _ -> raise NoReification and invert_var_pat vl (renv:reify_env) (p,f) t = Debug.dprintf debug_reification "invert_var_pat p %a f %a t %a@." Pretty.print_pat p Pretty.print_term f Pretty.print_term t; match p.pat_node, f.t_node with | Papp (_, [{pat_node = Pvar v1}]), Tapp (ffa,[{t_node = Tvar vy}; {t_node = Tvar v2}]) | Pvar v1, Tapp (ffa,[{t_node = Tvar vy}; {t_node = Tvar v2}]) when ty_equal v1.vs_ty ty_int && Svs.mem v1 p.pat_vars && vs_equal v1 v2 && ls_equal ffa fs_func_app && List.exists (fun vs -> vs_equal vs vy) vl (*FIXME*) -> Debug.dprintf debug_reification "case var@."; let rty = (Some p.pat_ty) in let app_pat trv = match p.pat_node with | Papp (cs, _) -> t_app cs [trv] rty | Pvar _ -> trv | _ -> assert false in let rec rm t = let t = match t.t_node with | Tapp (f,tl) -> t_app f (List.map rm tl) t.t_ty | Tvar _ | Tconst _ -> t | Tif (f,t1,t2) -> t_if (rm f) (rm t1) (rm t2) | Tbinop (op,f1,f2) -> t_binary op (rm f1) (rm f2) | Tnot f1 -> t_not (rm f1) | Ttrue | Tfalse -> t | _ -> t (* FIXME some cases missing *) in t_attr_set ?loc:t.t_loc Sattr.empty t in let t = rm t in (* remove attributes to identify terms modulo attributes *) if Mterm.mem t renv.store then begin Debug.dprintf debug_reification "%a exists@." Pretty.print_term t; (renv, app_pat (t_nat_const (snd (Mterm.find t renv.store)))) end else begin Debug.dprintf debug_reification "%a is new@." Pretty.print_term t; let bound = match t.t_node with | Tvar v -> Svs.mem v renv.bound_vars | _ -> false in let renv, i= if bound then let i = renv.bound_fr in { renv with bound_fr = i-1 }, i else let vy = Mty.find vy.vs_ty renv.ty_to_map in let fr = renv.fr in let store = Mterm.add t (vy, fr) renv.store in { renv with store = store; fr = fr + 1 }, fr in let const = Number.(ConstInt (int_const_of_int i)) in (renv, app_pat (t_const const Ty.ty_int)) end | _ -> raise NoReification and invert_pat vl renv (p,f) t = if (oty_equal f.t_ty t.t_ty) then try invert_nonvar_pat vl renv (p,f) t with NoReification -> invert_var_pat vl renv (p,f) t else begin try let crc = Coercion.find renv.crc_map (Opt.get t.t_ty) (Opt.get f.t_ty) in let apply_crc t ls = t_app_infer ls [t] in let crc_t = List.fold_left apply_crc t crc in assert (oty_equal f.t_ty crc_t.t_ty); invert_pat vl renv (p,f) crc_t with Not_found -> Debug.dprintf debug_reification "type mismatch between %a and %a@." Pretty.print_ty (Opt.get f.t_ty) Pretty.print_ty (Opt.get t.t_ty); raise NoReification end and invert_interp renv ls (t:term) = let ld = try Opt.get (find_logic_definition renv.kn ls) with Invalid_argument _ -> Debug.dprintf debug_reification "did not find def of %a@." Pretty.print_ls ls; raise NoReification in let vl, f = open_ls_defn ld in Debug.dprintf debug_reification "invert_interp ls %a t %a@." Pretty.print_ls ls Pretty.print_term t; invert_body { renv with interps = Sls.add ls renv.interps } ls vl f t and invert_body renv ls vl f t = match f.t_node with | Tvar v when vs_equal v (List.hd vl) -> renv, t | Tif (f, th, el) when t_equal th t_bool_true && t_equal el t_bool_false -> invert_body renv ls vl f t | Tcase (x, bl) -> (match x.t_node with | Tvar v when vs_equal v (List.hd vl) -> () | _ -> Debug.dprintf debug_reification "not matching on first param@."; raise NoReification); Debug.dprintf debug_reification "case match@."; let rec aux invert = function | [] -> raise NoReification | tb::l -> try invert vl renv (t_open_branch tb) t with NoReification -> Debug.dprintf debug_reification "match failed@."; aux invert l in (try aux invert_nonvar_pat bl with NoReification -> aux invert_var_pat bl) | Tapp (ls', _) -> Debug.dprintf debug_reification "case app@."; invert_interp renv ls' t | _ -> Debug.dprintf debug_reification "function body not handled@."; Debug.dprintf debug_reification "f: %a@." Pretty.print_term f; raise NoReification and invert_ctx_interp renv ls t l g = let ld = try Opt.get (find_logic_definition renv.kn ls) with Invalid_argument _ -> Debug.dprintf debug_reification "did not find def of %a@." Pretty.print_ls ls; raise NoReification in let vl, f = open_ls_defn ld in Debug.dprintf debug_reification "invert_ctx_interp ls %a @." Pretty.print_ls ls; let renv = { renv with interps = Sls.add ls renv.interps } in invert_ctx_body renv ls vl f t l g and invert_ctx_body renv ls vl f t l g = match f.t_node with | Tcase ({t_node = Tvar v}, [tbn; tbc] ) when vs_equal v (List.hd vl) -> let ty_g = g.vs_ty in let ty_list_g = ty_app ty_list [ty_g] in if (not (ty_equal ty_list_g l.vs_ty)) then (Debug.dprintf debug_reification "bad type for context interp function@."; raise NoReification); let nil = ns_find_ls th_list.th_export ["Nil"] in let cons = ns_find_ls th_list.th_export ["Cons"] in let (pn, fn) = t_open_branch tbn in let (pc, fc) = t_open_branch tbc in begin match pn.pat_node, fn.t_node, pc.pat_node, fc.t_node with | Papp(n, []), Tapp(eq'', [{t_node=Tapp(leq,{t_node = Tvar g'}::_)};btr'']), Papp (c, [{pat_node = Pvar hdl};{pat_node = Pvar tll}]), Tbinop(Timplies, {t_node=(Tapp(eq, [({t_node = Tapp(leq', _)} as thd); btr]))}, {t_node = (Tapp(eq', [({t_node = Tapp(ls', {t_node = Tvar tll'}::{t_node=Tvar g''}::_)} as ttl); btr']))}) when ls_equal n nil && ls_equal c cons && ls_equal ls ls' && vs_equal tll tll' && vs_equal g' g'' && ls_equal leq leq' && List.mem g' vl && not (Mvs.mem tll (t_vars thd)) && not (Mvs.mem hdl (t_vars ttl)) && ls_equal eq ps_equ && ls_equal eq' ps_equ && ls_equal eq'' ps_equ && t_equal btr t_bool_true && t_equal btr' t_bool_true && t_equal btr'' t_bool_true -> Debug.dprintf debug_reification "reifying goal@."; let (renv, rg) = invert_interp renv leq t in let renv = { renv with subst = Mvs.add g rg renv.subst } in Debug.dprintf debug_reification "filling context@."; let rec add_to_ctx (renv, ctx) e = try match e.t_node with | Teps _ -> (renv, ctx) | Tbinop (Tand,e1,e2) -> add_to_ctx (add_to_ctx (renv, ctx) e1) e2 | _ -> let (renv,req) = invert_interp renv leq e in (renv,(t_app cons [req; ctx] (Some ty_list_g))) with | NoReification -> renv,ctx in let renv, ctx = task_fold (fun (renv,ctx) td -> match td.td_node with | Decl {d_node = Dprop (Paxiom, _, e)} -> add_to_ctx (renv, ctx) e | Decl {d_node = Dlogic [ls, ld]} when ls.ls_args = [] -> add_to_ctx (renv, ctx) (ls_defn_axiom ld) | _-> renv,ctx) (renv, (t_app nil [] (Some ty_list_g))) renv.task in { renv with subst = Mvs.add l ctx renv.subst } | _ -> Debug.dprintf debug_reification "unhandled interp structure@."; raise NoReification end | Tif (c, th, el) when t_equal th t_bool_true && t_equal el t_bool_false -> invert_ctx_body renv ls vl c t l g | _ -> Debug.dprintf debug_reification "not a match on list@."; raise NoReification in Debug.dprintf debug_reification "reify_term t %a rt %a@." Pretty.print_term t Pretty.print_term rt; if not (oty_equal t.t_ty rt.t_ty) then (Debug.dprintf debug_reification "reification type mismatch %a %a@." Pretty.print_ty (Opt.get t.t_ty) Pretty.print_ty (Opt.get rt.t_ty); raise NoReification); match t.t_node, rt.t_node with | _, Tapp(interp, {t_node = Tvar vx}::vyl) when List.mem vx renv.lv && List.for_all (fun t -> match t.t_node with | Tvar vy -> List.mem vy renv.lv | _ -> false) vyl -> Debug.dprintf debug_reification "case interp@."; let renv = add_to_maps renv vyl in let renv, x = invert_interp renv interp t in { renv with subst = Mvs.add vx x renv.subst } | Tapp(eq, [t1; t2]), Tapp (eq', [rt1; rt2]) when ls_equal eq ps_equ && ls_equal eq' ps_equ && oty_equal t1.t_ty rt1.t_ty && oty_equal t2.t_ty rt2.t_ty -> Debug.dprintf debug_reification "case eq@."; reify_term (reify_term renv t1 rt1) t2 rt2 | _, Tapp(eq,[{t_node=Tapp(interp, {t_node = Tvar l}::{t_node = Tvar g}::vyl)}; tr]) when ls_equal eq ps_equ && t_equal tr t_bool_true && ty_equal (ty_app ty_list [g.vs_ty]) l.vs_ty && List.mem l renv.lv && List.mem g renv.lv && List.for_all (fun t -> match t.t_node with | Tvar vy -> List.mem vy renv.lv | _ -> false) vyl -> Debug.dprintf debug_reification "case context@."; let renv = add_to_maps renv vyl in invert_ctx_interp renv interp t l g | Tbinop(Tiff,t,{t_node=Ttrue}), Tapp(eq,[{t_node=Tapp(interp, {t_node = Tvar f}::vyl)}; tr]) when ls_equal eq ps_equ && t_equal tr t_bool_true && t.t_ty=None -> Debug.dprintf debug_reification "case interp_fmla@."; Debug.dprintf debug_reification "t %a rt %a@." Pretty.print_term t Pretty.print_term rt; let renv = add_to_maps renv vyl in let renv, rf = invert_interp renv interp t in { renv with subst = Mvs.add f rf renv.subst } | _ -> Debug.dprintf debug_reification "no reify_term match@."; Debug.dprintf debug_reification "lv = [%a]@." (Pp.print_list Pp.space Pretty.print_vs) renv.lv; raise NoReification let build_vars_map renv prev = Debug.dprintf debug_reification "building vars map@."; let subst, prev = Mvs.fold (fun vy ty_vars (subst, prev) -> Debug.dprintf debug_reification "creating var map %a@." Pretty.print_vs vy; let ly = create_fsymbol (Ident.id_fresh vy.vs_name.id_string) [] ty_vars in let y = t_app ly [] (Some ty_vars) in let d = create_param_decl ly in let prev = Task.add_decl prev d in Mvs.add vy y subst, prev) renv.var_maps (renv.subst, prev) in let prev, mapdecls = Mvs.fold (fun vy _ (prev,prs) -> Debug.dprintf debug_reification "checking %a@." Pretty.print_vs vy; let vs = Mty.find vy.vs_ty renv.ty_to_map in if vs_equal vy vs then prev,prs else begin Debug.dprintf debug_reification "aliasing %a and %a@." Pretty.print_vs vy Pretty.print_vs vs; let y = Mvs.find vy subst in let z = Mvs.find vs subst in let et = t_equ y z in let pr = create_prsymbol (Ident.id_fresh "map_alias") in let d = create_prop_decl Paxiom pr et in Task.add_decl prev d, pr::prs end) renv.var_maps (prev, []) in if not (List.for_all (fun v -> Mvs.mem v subst) renv.lv) then (Debug.dprintf debug_reification "vars not matched: %a@." (Pp.print_list Pp.space Pretty.print_vs) (List.filter (fun v -> not (Mvs.mem v subst)) renv.lv); raise (Arg_error "vars not matched")); Debug.dprintf debug_reification "all vars matched@."; let prev, defdecls = Mterm.fold (fun t (vy,i) (prev,prs) -> let y = Mvs.find vy subst in let et = t_equ (t_app fs_func_app [y; t_nat_const i] t.t_ty) t in Debug.dprintf debug_reification "%a %d = %a@." Pretty.print_vs vy i Pretty.print_term t; let s = Format.sprintf "y_val%d" i in let pr = create_prsymbol (Ident.id_fresh s) in let d = create_prop_decl Paxiom pr et in Task.add_decl prev d, pr::prs) renv.store (prev,[]) in subst, prev, mapdecls, defdecls let build_goals do_trans renv prev mapdecls defdecls subst env lp g rt = Debug.dprintf debug_refl "building goals@."; let inst_rt = t_subst subst rt in Debug.dprintf debug_refl "reified goal instantiated@."; let inst_lp = List.map (t_subst subst) lp in Debug.dprintf debug_refl "premises instantiated@."; let hr = create_prsymbol (id_fresh "HR") in let d_r = create_prop_decl Paxiom hr inst_rt in let pr = create_prsymbol (id_fresh "GR" ~attrs:(Sattr.singleton expl_reification_check)) in let d = create_prop_decl Pgoal pr g in let task_r = Task.add_decl (Task.add_decl prev d_r) d in Debug.dprintf debug_refl "building cut indication rt %a g %a@." Pretty.print_term rt Pretty.print_term g; let compute_hyp_few pr = Compute.normalize_hyp_few None (Some pr) env in let compute_in_goal = Compute.normalize_goal_transf_all env in let ltask_r = try let ci = match (rt.t_node, g.t_node) with | (Tapp(eq, rh::rl), Tapp(eq', h::l)) when ls_equal eq eq' -> List.fold_left2 (fun ci st rst -> t_and ci (t_equ (t_subst subst rst) st)) (t_equ (t_subst subst rh) h) l rl | _,_ when g.t_ty <> None -> t_equ (t_subst subst rt) g | _ -> raise Not_found in Debug.dprintf debug_refl "cut ok@."; Trans.apply (Cut.cut ci (Some "interp")) task_r with Arg_trans _ | TypeMismatch _ | Not_found -> Debug.dprintf debug_refl "no cut found@."; if do_trans then let g, prev = task_separate_goal task_r in let prev = Sls.fold (fun ls t -> Task.add_meta t Compute.meta_rewrite_def [Theory.MAls ls]) renv.interps prev in let t = Task.add_tdecl prev g in let t = Trans.apply (compute_hyp_few hr) t in match t with | [t] -> let rewrite = Apply.rewrite_list false true (mapdecls@defdecls) (Some hr) in Trans.apply rewrite t | [] -> [] | _ -> assert false else [task_r] in let lt = List.map (fun ng -> Task.add_decl prev (create_prop_decl Pgoal (create_prsymbol (id_fresh "G")) ng)) inst_lp in let lt = if do_trans then Lists.apply (Trans.apply compute_in_goal) lt else lt in Debug.dprintf debug_refl "done@."; ltask_r@lt let reflection_by_lemma pr env : Task.task Trans.tlist = Trans.store (fun task -> let kn = task_known task in let g, prev = Task.task_separate_goal task in let g = Apply.term_decl g in Debug.dprintf debug_refl "start@."; let l = let kn' = task_known prev in (* TODO Do we want kn here ? *) match find_prop_decl kn' pr with | (_, t) -> t | exception Not_found -> raise (Arg_error "lemma not found") in let (lp, lv, llet, rt) = Apply.intros l in if llet <> [] then begin (* TODO handle lets *) Debug.dprintf debug_refl "let in procedure postcondition@."; raise NoReification end; let nt = Args_wrapper.build_naming_tables task in let crc = nt.Trans.coercion in let renv = reify_term (init_renv kn crc lv env prev) g rt in let subst, prev, mds, dds = build_vars_map renv prev in build_goals true renv prev mds dds subst env lp g rt) open Expr open Ity open Wstdlib open Mlinterp exception ReductionFail of reify_env let reflection_by_function do_trans s env = Trans.store (fun task -> Debug.dprintf debug_refl "reflection_f start@."; let kn = task_known task in let nt = Args_wrapper.build_naming_tables task in let crc = nt.Trans.coercion in let g, prev = Task.task_separate_goal task in let g = Apply.term_decl g in let ths = Task.used_theories task in let o = Mid.fold (fun _ th o -> try let pmod = Pmodule.restore_module th in let rs = Pmodule.ns_find_rs pmod.Pmodule.mod_export [s] in if o = None then Some (pmod, rs) else (let es = Format.sprintf "module or function %s found twice" s in raise (Arg_error es)) with Not_found -> o) ths None in let (_pmod, rs) = if o = None then (let es = Format.sprintf "Symbol %s not found@." s in raise (Arg_error es)) else Opt.get o in let lpost = List.map open_post rs.rs_cty.cty_post in if List.exists (fun pv -> pv.pv_ghost) rs.rs_cty.cty_args then (Debug.dprintf debug_refl "ghost parameter@."; raise (Arg_error "function has ghost parameters")); Debug.dprintf debug_refl "building module map@."; let mm = Mid.fold (fun id th acc -> try let pm = Pmodule.restore_module th in Mstr.add id.id_string pm acc with Not_found -> acc) ths Mstr.empty in Debug.dprintf debug_refl "module map built@."; let args = List.map (fun pv -> pv.pv_vs) rs.rs_cty.cty_args in let rec reify_post = function | [] -> Debug.dprintf debug_refl "no postcondition reifies@."; raise NoReification | (vres, p)::t -> begin try Debug.dprintf debug_refl "new post@."; Debug.dprintf debug_refl "post: %a, %a@." Pretty.print_vs vres Pretty.print_term p; let (lp, lv, llet, rt) = Apply.intros p in if llet <> [] then begin (* TODO handle lets *) Debug.dprintf debug_refl "let in procedure postcondition@."; raise NoReification end; let lv = lv @ args in let renv = reify_term (init_renv kn crc lv env prev) g rt in Debug.dprintf debug_refl "computing args@."; let vars = List.fold_left (fun vars (vs, t) -> if List.mem vs args then begin Debug.dprintf debug_refl "value of term %a for arg %a@." Pretty.print_term t Pretty.print_vs vs; Mid.add vs.vs_name (value_of_term kn t) vars end else vars) Mid.empty (Mvs.bindings renv.subst) in Debug.dprintf debug_refl "evaluating@."; let res = try term_of_value (Mlinterp.interp env mm rs vars) with Raised (xs,_,cs) -> Format.eprintf "Raised %s %a@." (xs.xs_name.id_string) (Pp.print_list Pp.semi Expr.print_rs) cs; raise (ReductionFail renv) in Debug.dprintf debug_refl "res %a@." Pretty.print_term res; let rinfo = {renv with subst = Mvs.add vres res renv.subst} in rinfo, lp, lv, rt with NoReification -> reify_post t end in try let rinfo, lp, _lv, rt = reify_post lpost in let lp = (rs.rs_cty.cty_pre)@lp in let subst, prev, mds, dds = build_vars_map rinfo prev in build_goals do_trans rinfo prev mds dds subst env lp g rt with ReductionFail renv -> (* proof failed, show reification context for debugging *) let _, prev, _, _ = build_vars_map renv prev in let fg = create_prsymbol (id_fresh "Failure") in let df = create_prop_decl Pgoal fg t_false in [Task.add_decl prev df] ) let () = wrap_and_register ~desc:"reflection_l attempts to prove the goal by reflection using the lemma prop" "reflection_l" (Tprsymbol Tenvtrans_l) reflection_by_lemma let () = wrap_and_register ~desc:"reflection_f attempts to prove the goal by reflection using the contract of the program function f" "reflection_f" (Tstring Tenvtrans_l) (reflection_by_function true) let () = wrap_and_register ~desc:"reflection_f attempts to prove the goal by reflection using the contract of the program function f, does not automatically perform transformations afterward. Use for debugging." "reflection_f_nt" (Tstring Tenvtrans_l) (reflection_by_function false) (* Local Variables: compile-command: "unset LANG; make -C ../.." End: *) why3-1.2.1/src/transform/subst.mli0000644000175100017510000000205313555524575017626 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 subst_filtered : subst_proxy:bool -> (Term.lsymbol -> bool) -> Task.task Trans.trans (* [subst_filtered subst_proxy p]: substitute only lsymbol chosen by [p]. If [subst_proxy] is true, allow the substitution of proxy symbols into non-proxy symbols. *) val subst : Term.term list -> Task.task Trans.trans val subst_all : Task.task Trans.trans why3-1.2.1/src/transform/encoding_guards.ml0000644000175100017510000001422313555524575021452 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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_attr_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_attr_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_attr_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_attr_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_attr_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 () = Wstdlib.Hstr.replace Encoding.ft_enco_poly "guards" (fun _ -> Trans.compose guards monomorphise_task) why3-1.2.1/src/transform/eliminate_let.mli0000644000175100017510000000155313555524575021305 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/prepare_for_counterexmp.mli0000644000175100017510000000207113555524575023423 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/eliminate_unknown_types.ml0000644000175100017510000000611213555524575023267 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 Theory open Ty let debug = Debug.register_info_flag "eliminate_unknown_types" ~desc:"Print@ debugging@ messages@ of@ the@ eliminate_unknown_types@ transformation." let syntactic_transform transf = Trans.on_meta Printer.meta_syntax_type (fun metas -> let symbols = List.fold_left (fun acc meta_arg -> match meta_arg with | [MAts ts; MAstr _; MAint _] -> Sts.add ts acc | _ -> assert false) Sts.empty metas in transf (fun ts -> Sts.exists (ts_equal ts) symbols)) let remove_terms keep = let keep_ls ls = (* check that we want to keep all the types occurring in the type of ls *) List.for_all (fun ty -> ty_s_all keep ty) ls.ls_args && begin match ls.ls_value with | Some ty -> ty_s_all keep ty | None -> true (* bool are kept by default *) end in let keep_term (t:term) = t_s_all (fun ty -> ty_s_all keep ty) (fun _ -> true) t && begin match t.t_ty with | Some t -> ty_s_all keep t | None -> true end in Trans.decl (fun d -> match d.d_node with | Dtype ty when not (keep ty) -> if Debug.test_flag debug then Format.printf "remove@ type@ %a@." Pretty.print_ty_decl ty; [] | Ddata l when List.exists (fun (t,_) -> not (keep t)) l -> if Debug.test_flag debug then Format.printf "remove@ data@ %a@." Pretty.print_data_decl (List.hd l); [] | Dparam l when not (keep_ls l) -> if Debug.test_flag debug then Format.printf "remove@ param@ %a@." Pretty.print_ls l; [] | Dlogic l when List.exists (fun (l,_) -> not (keep_ls l)) l -> if Debug.test_flag debug then Format.printf "remove@ logic@ %a@." Pretty.print_logic_decl (List.hd l); [] | Dprop (Pgoal,pr,t) when not (keep_term t) -> if Debug.test_flag debug then Format.printf "change@ goal@ %a@." Pretty.print_term t; [create_prop_decl Pgoal pr t_false] | Dprop (_,_,t) when not (keep_term t) -> if Debug.test_flag debug then Format.printf "remove@ prop@ %a@." Pretty.print_term t; [] | _ -> [d]) None let () = Trans.register_transform "eliminate_unknown_types" (syntactic_transform remove_terms) ~desc:"Remove@ types@ unknown@ to@ the@ prover@ and@ terms@ referring@ to@ them@." why3-1.2.1/src/transform/eliminate_symbol.ml0000644000175100017510000000336013555524575021653 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 Theory let meta_elim_ls = register_meta "ls:eliminate" [MTlsymbol] ~desc:"Removes@ any@ expression@ containing@ a@ specific@ lsymbol." let eliminate_symbol _env = Trans.on_tagged_ls meta_elim_ls (fun ls_elim -> let elim_ls ls = Sls.exists (ls_equal ls) ls_elim in let rec elim (t:term) = match t.t_node with | Tvar _ | Tconst _ | Ttrue | Tfalse -> false | Tapp (ls,_) when elim_ls ls -> true | _ -> t_any elim t in Trans.decl (fun d -> match d.d_node with | Dparam l when (elim_ls l) -> [] | Dlogic l when List.exists (fun (l,def) -> elim_ls l || let _,t = open_ls_defn def in elim t) l -> [] | Dprop (Pgoal,pr,t) when (elim t) -> [create_prop_decl Pgoal pr t_false] | Dprop (_,_,t) when (elim t) -> [] | _ -> [d]) None) let () = Trans.register_env_transform "eliminate_symbol" eliminate_symbol ~desc:"Eliminate@ tagged@ symbol." why3-1.2.1/src/transform/induction.mli0000644000175100017510000000130713555524575020463 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/encoding_sort.mli0000644000175100017510000000130713555524575021324 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/eliminate_inductive.ml0000644000175100017510000000452413555524575022343 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 ~keep_model_vars:false (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-1.2.1/src/transform/encoding_tags.ml0000644000175100017510000001427213555524575021127 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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_attr_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_attr_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_attr_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_attr_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_attr_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 () = Wstdlib.Hstr.replace Encoding.ft_enco_poly "tags" (fun _ -> Trans.compose tags monomorphise_task) why3-1.2.1/src/transform/libencoding.ml0000644000175100017510000002535413555524575020603 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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) let ls_of_const_format = Number.({ long_int_support = true; extra_leading_zeros_support = false; negative_int_support = Number_unsupported; dec_int_support = Number_default; hex_int_support = Number_unsupported; oct_int_support = Number_unsupported; bin_int_support = Number_unsupported; def_int_support = Number_unsupported; negative_real_support = Number_unsupported; dec_real_support = Number_unsupported; hex_real_support = Number_unsupported; frac_real_support = Number_custom (PrintFracReal ("%s", "%sx%s", "%s_%s")); def_real_support = Number_unsupported; }) (* convert a constant to a functional symbol of type ty_base *) let ls_of_const = Hty.memo 3 (fun ty_base -> let cst = Wstdlib.Hstr.memo 63 (fun s -> let s = "const_" ^ s in create_fsymbol (id_fresh s) [] ty_base) in Hterm.memo 63 (fun t -> match t.t_node with | Tconst c -> cst (Pp.string_of_wnl (Number.print ls_of_const_format) c) | _ -> assert false)) (* unprotected and unprotecting idents *) let unprotected_attr = Ident.create_attribute "encoding:unprotected" let unprotecting_attr = Ident.create_attribute "encoding:unprotecting" let id_unprotected n = id_fresh ~attrs:(Sattr.singleton unprotected_attr) n let id_unprotecting n = id_fresh ~attrs:(Sattr.singleton unprotecting_attr) n let is_protected_id id = not (Sattr.mem unprotected_attr id.id_attrs) let is_protecting_id id = not (Sattr.mem unprotecting_attr id.id_attrs) 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_attr_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 = Wstdlib.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 \"encoding: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-1.2.1/src/transform/encoding_guards_full.mli0000644000175100017510000000130713555524575022644 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/reduction_engine.ml0000644000175100017510000011413213555524575021640 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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_attr_copy orig v = match v with | Int _ -> v | Term t -> Term (t_attr_copy orig t) let ls_minus = ref ps_equ (* temporary *) let term_of_value v = match v with | Term t -> t | Int n -> t_bigint_const n exception NotNum let big_int_of_const c = match c with | Number.ConstInt i -> Number.compute_int_constant 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", [], [ Ident.op_infix "+", None, eval_int_op BigInt.add simpl_add; Ident.op_infix "-", None, eval_int_op BigInt.sub simpl_sub; Ident.op_infix "*", None, eval_int_op BigInt.mul simpl_mul; Ident.op_prefix "-", Some ls_minus, eval_int_uop BigInt.minus; Ident.op_infix "<", None, eval_int_rel BigInt.lt; Ident.op_infix "<=", None, eval_int_rel BigInt.le; Ident.op_infix ">", None, eval_int_rel BigInt.gt; Ident.op_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 is of 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 (value). 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 attribute and loc copy *) } (* This global variable is used to approximate a count of the elementary simplifications that are done during normalization. This is used for transformation step. *) let rec_step_limit = ref 0 exception NoMatch of (term * term * term option) option exception NoMatchpat of (pattern * pattern) option let rec pattern_renaming (bound_vars, mt) p1 p2 = match p1.pat_node, p2.pat_node with | Pwild, Pwild -> (bound_vars, mt) | Pvar v1, Pvar v2 -> begin try let mt = Ty.ty_match mt v1.vs_ty v2.vs_ty in let bound_vars = Mvs.add v2 v1 bound_vars in (bound_vars, mt) with | Ty.TypeMismatch _ -> raise (NoMatchpat (Some (p1, p2))) end | Papp (ls1, tl1), Papp (ls2, tl2) when ls_equal ls1 ls2 -> List.fold_left2 pattern_renaming (bound_vars, mt) tl1 tl2 | Por (p1a, p1b), Por (p2a, p2b) -> let (bound_vars, mt) = pattern_renaming (bound_vars, mt) p1a p2a in pattern_renaming (bound_vars, mt) p1b p2b | Pas (p1, v1), Pas (p2, v2) -> begin try let mt = Ty.ty_match mt v1.vs_ty v2.vs_ty in let bound_vars = Mvs.add v2 v1 bound_vars in pattern_renaming (bound_vars, mt) p1 p2 with | Ty.TypeMismatch _ -> raise (NoMatchpat (Some (p1, p2))) end | _ -> raise (NoMatchpat (Some (p1, p2))) let first_order_matching (vars : Svs.t) (largs : term list) (args : term list) : Ty.ty Ty.Mtv.t * substitution = let rec loop bound_vars ((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 bound_vars sigma r1 r2 else raise (NoMatch (Some (t1, t2, Some t))) with Not_found -> try let ts = Ty.ty_match mt vs.vs_ty (t_type t2) in let fv2 = t_vars t2 in if Mvs.is_empty (Mvs.set_inter bound_vars fv2) then loop bound_vars (ts,Mvs.add vs t2 mv) r1 r2 else raise (NoMatch (Some (t1, t2, None))) with Ty.TypeMismatch _ -> raise (NoMatch (Some (t1, t2, None))) end | Tapp(ls1,args1) -> begin match t2.t_node with | Tapp(ls2,args2) when ls_equal ls1 ls2 -> let mt, mv = loop bound_vars 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 (Some (t1, t2, None))) end | _ -> raise (NoMatch (Some (t1, t2, None))) end | Tquant (q1, bv1) -> begin match t2.t_node with | Tquant (q2, bv2) when q1 = q2 -> let (vl1, _tl1, term1) = t_open_quant bv1 in let (vl2, _tl2, term2) = t_open_quant bv2 in let (bound_vars, term1, mt) = try List.fold_left2 (fun (bound_vars, term1, mt) e1 e2 -> let mt = Ty.ty_match mt e1.vs_ty e2.vs_ty in let bound_vars = Mvs.add e2 e1 bound_vars in (bound_vars,term1, mt)) (bound_vars,term1, mt) vl1 vl2 with Invalid_argument _ | Ty.TypeMismatch _ -> raise (NoMatch (Some (t1,t2,None))) in loop bound_vars (mt, mv) (term1 :: r1) (term2 :: r2) | _ -> raise (NoMatch (Some (t1, t2, None))) end | Tbinop (b1, t1_l, t1_r) -> begin match t2.t_node with | Tbinop (b2, t2_l, t2_r) when b1 = b2 -> loop bound_vars (mt, mv) (t1_l :: t1_r :: r1) (t2_l :: t2_r :: r2) | _ -> raise (NoMatch (Some (t1, t2, None))) end | Tif (t11, t12, t13) -> begin match t2.t_node with | Tif (t21, t22, t23) -> loop bound_vars (mt, mv) (t11 :: t12 :: t13 :: r1) (t21 :: t22 :: t23 :: r2) | _ -> raise (NoMatch (Some (t1, t2, None))) end | Tlet (td1, tb1) -> begin match t2.t_node with | Tlet (td2, tb2) -> let (v1, tl1) = t_open_bound tb1 in let (v2, tl2) = t_open_bound tb2 in let mt = try Ty.ty_match mt v1.vs_ty v2.vs_ty with Ty.TypeMismatch _ -> raise (NoMatch (Some (t1,t2, None))) in let bound_vars = Mvs.add v2 v1 bound_vars in loop bound_vars (mt, mv) (td1 :: tl1 :: r1) (td2 :: tl2 :: r2) | _ -> raise (NoMatch (Some (t1, t2, None))) end | Tcase (ts1, tbl1) -> begin match t2.t_node with | Tcase (ts2, tbl2) -> begin try let (bound_vars, mt, l1, l2) = List.fold_left2 (fun (bound_vars, mt, l1, l2) tb1 tb2 -> let (p1, tb1) = t_open_branch tb1 in let (p2, tb2) = t_open_branch tb2 in let bound_vars, mt = pattern_renaming (bound_vars, mt) p1 p2 in (bound_vars,mt, tb1 :: l1, tb2 :: l2) ) (bound_vars,mt, ts1 :: r1, ts2 :: r2) tbl1 tbl2 in loop bound_vars (mt,mv) l1 l2 with Invalid_argument _ -> raise (NoMatch (Some (t1, t2, None))) end | _ -> raise (NoMatch (Some (t1, t2, None))) end | Teps tb1 -> begin match t2.t_node with | Teps tb2 -> let (v1, td1) = t_open_bound tb1 in let (v2, td2) = t_open_bound tb2 in let mt = try Ty.ty_match mt v1.vs_ty v2.vs_ty with Ty.TypeMismatch _ -> raise (NoMatch (Some (t1,t2,None))) in let bound_vars = Mvs.add v2 v1 bound_vars in loop bound_vars (mt, mv) (td1 :: r1) (td2 :: r2) | _ -> raise (NoMatch (Some (t1, t2, None))) end | Tnot t1 -> begin match t2.t_node with | Tnot t2 -> loop bound_vars sigma (t1 :: r1) (t2 :: r2) | _ -> raise (NoMatch (Some (t1, t2, None))) end | Tvar v1 -> begin match t2.t_node with | Tvar v2 -> begin try if vs_equal v1 (Mvs.find v2 bound_vars) then loop bound_vars sigma r1 r2 else raise (NoMatch (Some (t1, t2, None))) with Not_found -> assert false end | _ -> raise (NoMatch (Some (t1, t2, None))) end | (Tconst _ | Ttrue | Tfalse) when t_equal t1 t2 -> loop bound_vars sigma r1 r2 | Tconst _ | Ttrue | Tfalse -> raise (NoMatch (Some (t1, t2, None))) end | _ -> raise (NoMatch None) in loop Mvs.empty (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 None) 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 } -> incr(rec_step_limit); { value_stack = st ; cont_stack = (Keval(t2,sigma),t_attr_copy orig t2) :: rem } | Term { t_node = Tfalse } -> incr(rec_step_limit); { value_stack = st ; cont_stack = (Keval(t3,sigma),t_attr_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 -> incr(rec_step_limit); { value_stack = Term (t_attr_copy orig b0) :: st; cont_stack = rem } | _ -> { value_stack = Term (t_attr_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 -> incr(rec_step_limit); let t1 = term_of_value t1 in { value_stack = st; cont_stack = (Keval(t2, Mvs.add v t1 sigma), t_attr_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 -> incr(rec_step_limit); { value_stack = Term (t_attr_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 -> incr(rec_step_limit); { value_stack = Term (t_attr_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_attr_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_attr_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 "@]@."; *) incr(rec_step_limit); { value_stack = st; cont_stack = (Keval(t,mv''), t_attr_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_attr_copy orig (t_case u tbls)) :: st; cont_stack = cont; } and reduce_eval st t ~orig sigma rem = let orig = t_attr_copy orig t in match t.t_node with | Tvar v -> begin try let t = Mvs.find v sigma in incr(rec_step_limit); { value_stack = Term (t_attr_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_attr_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_attr_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_attr_copy t (t_eps_close fc2 tq) in { value_stack = rem_st; cont_stack = (Keval(body,Mvs.add vh t2 Mvs.empty), t_attr_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_attr_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_attr_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_attr_copy teq (t_app ps_equ [lhs;tr] None) in t_attr_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_attr_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_attr_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 incr(rec_step_limit); { value_stack = rem_st; cont_stack = (Keval(rhs,mv),orig) :: rem_cont; } with Irreducible -> { value_stack = Term (t_attr_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_attr_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 incr(rec_step_limit); { value_stack = Term (t_attr_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 incr(rec_step_limit); { value_stack = Term (t_attr_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 let () = incr(rec_step_limit) in { value_stack = Term (t_attr_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_constant i1) (Number.compute_int_constant i2) in incr(rec_step_limit); { value_stack = Term (t_attr_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 let () = incr(rec_step_limit) in { value_stack = st; cont_stack = (Keval(t,sigma),orig) :: cont; } else { value_stack = Term (t_attr_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 -> incr(rec_step_limit); { value_stack = Term (t_attr_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_attr_copy orig t)) :: st; cont_stack = rem; } (** iterated reductions *) let normalize ?step_limit ~limit engine t0 = rec_step_limit := 0; 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 begin match step_limit with | None -> let c = reduce engine c in many_steps c (n+1) | Some step_limit -> if !rec_step_limit >= step_limit then reconstruct c else let c = reduce engine c in many_steps c (n+1) end 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 (quantified variables not appearing could be removed and those appearing on right hand side cannot be guessed during rewriting). *) 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-1.2.1/src/transform/apply.ml0000644000175100017510000005151413555524575017450 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 Trans open Term open Decl open Theory open Task open Args_wrapper open Reduction_engine open Generic_arg_trans_utils (** This file contains transformations with arguments that acts on specific declarations to refine them (rewrite, replace, apply, unfold...) *) let debug_matching = Debug.register_info_flag "print_match" ~desc:"Print@ terms@ that@ were@ not@ successfully@ matched@ by@ ITP@ tactic@ apply." (* One only need to change the following parameter values to change the explanation given to *new* goals introduced by transformation of this file. *) (* Subgoals generated by using [apply] *) let apply_subgoals = "apply premises" (* Subgoals generated by using [rewrite] *) let rewrite_subgoals = "rewrite premises" (* Equality hypothesis generated by using [replace] *) let replace_hypothesis = "equality hypothesis" (* Do as intros: introduce all premises of hypothesis pr and return a triple (goal, list_premises, binded variables) *) let intros f = let rec intros_aux lp lv llet f = match f.t_node with | Tbinop (Timplies, f1, f2) -> intros_aux (f1 :: lp) lv llet f2 | Tquant (Tforall, fq) -> let vsl, _, fs = t_open_quant fq in intros_aux lp (lv @ vsl) llet fs | Tlet (t, tb) -> let vs, t2 = t_open_bound tb in intros_aux lp lv ((vs, t) :: llet) t2 | _ -> (lp, lv, llet, f) in intros_aux [] [] [] f let term_decl d = match d.td_node with | Decl ({d_node = Dprop (_pk, _pr, t)}) -> t | _ -> raise (Arg_trans "term_decl") (* [with_terms subst_ty subst lv wt]: Takes the list of variables in lv that are not part of the substitution and try to match them with the list of values from wt (ordered). *) (* TODO we could use something simpler than first_order_matching here. *) let with_terms ~trans_name subst_ty subst lv withed_terms = Debug.dprintf debug_matching "Calling with_terms@."; (* Get the list of variables of lv that are not in subst. *) let lv, slv = List.fold_left (fun (acc, accs) v -> match (Mvs.find v subst) with | _ -> acc, accs | exception Not_found -> t_var v :: acc, Svs.add v accs) ([], Svs.empty) lv in let lv = List.rev lv in (* Length checking for nice errors *) let diff = Svs.cardinal slv - List.length withed_terms in match diff with | _ when diff < 0 -> Debug.dprintf debug_matching "Too many withed terms@."; raise (Arg_trans (trans_name ^ ": the last " ^ string_of_int (-diff) ^ " terms in with are useless")) | _ when diff > 0 -> Debug.dprintf debug_matching "Not enough withed terms@."; raise (Arg_trans_missing (trans_name ^ ": there are " ^ string_of_int diff ^ " terms missing:", slv)) | _ (* when diff = 0 *) -> let new_subst_ty, new_subst = (* TODO Here we match on a list of variable against a list of terms. It is probably possible to use a simplified version. But don't forget to unify type variables. (Same comment as at top of this function) *) try first_order_matching slv lv withed_terms with | Reduction_engine.NoMatch (Some (t1, t2, None)) -> Debug.dprintf debug_matching "Term %a and %a can not be matched. Failure in matching@." Pretty.print_term t1 Pretty.print_term t2; raise (Arg_trans_term2 (trans_name^":matching", t1, t2)) | Reduction_engine.NoMatch (Some (t1, t2, Some t3)) -> Debug.dprintf debug_matching "Term %a and %a can not be matched. %a already matched with %a@." Pretty.print_term t1 Pretty.print_term t2 Pretty.print_term t1 Pretty.print_term t3; raise (Arg_trans_term3 (trans_name^":matching", t1, t2, t3)) | Reduction_engine.NoMatchpat (Some (p1, p2)) -> Debug.dprintf debug_matching "Term %a and %a can not be matched. Failure in matching@." Pretty.print_pat p1 Pretty.print_pat p2; raise (Arg_trans_pattern (trans_name, p1, p2)) | Reduction_engine.NoMatch None -> Debug.dprintf debug_matching "with_terms: No match@."; raise (Arg_trans trans_name) in let subst_ty = Ty.Mtv.union (fun _x y z -> if Ty.ty_equal y z then Some y else raise (Arg_trans_type (trans_name ^ ": ", y, z))) subst_ty new_subst_ty in let subst = Mvs.union (fun _x y z -> if Term.t_equal_nt_na y z then Some y else raise (Arg_trans_term2 (trans_name ^ ": ", y, z))) subst new_subst in subst_ty, subst (* This function first try to match left_term and right_term with a substitution on lv/slv. It then tries to fill the holes with the list of withed_terms. trans_name is used for nice error messages. Errors are returned when the size of withed_terms is incorrect. *) let matching_with_terms ~trans_name lv llet_vs left_term right_term withed_terms = let slv = List.fold_left (fun acc v -> Svs.add v acc) llet_vs lv in let (subst_ty, subst) = try first_order_matching slv [left_term] [right_term] with | Reduction_engine.NoMatch (Some (t1, t2, None)) -> Debug.dprintf debug_matching "Term %a and %a can not be matched. Failure in matching@." Pretty.print_term t1 Pretty.print_term t2; raise (Arg_trans_term2 (trans_name^":no_match", t1, t2)) | Reduction_engine.NoMatch (Some (t1, t2, Some t3)) -> Debug.dprintf debug_matching "Term %a and %a can not be matched. %a already matched with %a@." Pretty.print_term t1 Pretty.print_term t2 Pretty.print_term t1 Pretty.print_term t3; raise (Arg_trans_term3 (trans_name^":no_match", t1, t2, t3)) | Reduction_engine.NoMatchpat (Some (p1, p2)) -> Debug.dprintf debug_matching "Term %a and %a can not be matched. Failure in matching@." Pretty.print_pat p1 Pretty.print_pat p2; raise (Arg_trans_pattern (trans_name, p1, p2)) | Reduction_engine.NoMatch None -> raise (Arg_trans trans_name) in let subst_ty, subst = let withed_terms = match withed_terms with None -> [] | Some l -> l in with_terms ~trans_name subst_ty subst lv withed_terms in subst_ty, subst let generate_new_subgoals ~subst_ty ~subst llet lp = let new_lets, new_goals = List.fold_left (fun (new_lets, new_goals) (v,t) -> match Mvs.find v subst with | t' -> (* [v -> t'] appears in subst. So we want to create two new goals: G1: t = t' G2: h *) let t' = t_ty_subst subst_ty subst t' in let t = t_ty_subst subst_ty subst t in (new_lets, (t_equ t' t) :: new_goals) | exception Not_found -> ((v,t) :: new_lets, new_goals) ) ([], []) llet in let add_lets_subst new_goals h = let h = t_ty_subst subst_ty subst h in let freevars = t_freevars Mvs.empty h in let h = List.fold_left (fun h (v, t) -> if Mvs.mem v freevars then let t = t_ty_subst subst_ty subst t in t_let t (t_close_bound v h) else h) h (List.rev new_lets) in h :: new_goals in List.fold_left add_lets_subst new_goals lp (* Apply: 1) takes the hypothesis and introduce parts of it to keep only the last element of the implication. It gathers the premises and variables in a list. 2) try to find a good substitution for the list of variables so that last element of implication is equal to the goal. 3) generate new goals corresponding to premises with variables instantiated with values found in 2). *) let apply pr withed_terms : Task.task Trans.tlist = Trans.store (fun task -> let kn = task_known task in let g, task = Task.task_separate_goal task in let g = term_decl g in let t = match find_prop_decl kn pr with | (_, t) -> t | exception Not_found -> raise (Arg_pr_not_found pr) in let (lp, lv, llet, nt) = intros t in let llet_vs = List.fold_left (fun acc (vs, _) -> Svs.add vs acc) Svs.empty llet in match matching_with_terms ~trans_name:"apply" lv llet_vs nt g withed_terms with | exception e -> raise e | subst_ty, subst -> let inst_nt = t_ty_subst subst_ty subst nt in (* Safety guard: we check that the goal was indeed the instantiated hypothesis *) if (Term.t_equal_nt_na inst_nt g) then let new_goals = generate_new_subgoals ~subst ~subst_ty llet lp in let create_goal h = let pr = create_prsymbol (gen_ident ?loc:g.t_loc "G") in Task.add_decl task (create_goal ~expl:apply_subgoals pr h) in List.map create_goal new_goals else (* This should never happen *) assert false ) let replace rev f1 f2 t = match rev with | true -> replace_in_term f1 f2 t | false -> replace_in_term f2 f1 t (* - If f1 unifiable to t with substitution s then return s.f2 and replace every occurences of s.f1 with s.f2 in the rest of the term - Else call recursively on subterms of t *) (* If a substitution s is found then new premises are computed as e -> s.e *) let replace_subst lp lv llet f1 f2 withed_terms t = (* is_replced is common to the whole execution of replace_subst. Once an occurence is found, it changes to Some (s) so that only one instanciation is rewrritten during execution *) let rec replace is_replaced f1 f2 t : _ * Term.term = match is_replaced with | Some(subst_ty,subst) -> is_replaced, replace_in_term (t_ty_subst subst_ty subst f1) (t_ty_subst subst_ty subst f2) t | None -> begin (* Generate the list of variables that are here from let bindings *) let llet_svs = List.fold_left (fun acc (v, _) -> Svs.add v acc) Svs.empty llet in (* Catch any error from first_order_matching or with_terms. *) match matching_with_terms ~trans_name:"rewrite" lv llet_svs f1 t (Some withed_terms) with | exception _e -> Term.t_map_fold (fun is_replaced t -> replace is_replaced f1 f2 t) is_replaced t | subst_ty, subst -> let sf1 = t_ty_subst subst_ty subst f1 in if (Term.t_equal_nt_na sf1 t) then Some (subst_ty, subst), t_ty_subst subst_ty subst f2 else t_map_fold (fun is_replaced t -> replace is_replaced f1 f2 t) is_replaced t end in let is_replaced, t = replace None f1 f2 t in match is_replaced with | None -> raise (Arg_trans "rewrite: no term matching the given pattern") | Some(subst_ty,subst) -> let new_goals = generate_new_subgoals ~subst ~subst_ty llet lp in (new_goals, t) let rewrite_in rev with_terms h h1 = let found_eq = (* Used to find the equality we are rewriting on *) (* TODO here should fold with a boolean stating if we found equality yet to not go through all possible hypotheses *) Trans.fold_decl (fun d acc -> match d.d_node with | Dprop (Paxiom, pr, t) when Ident.id_equal pr.pr_name h.pr_name -> let lp, lv, llet, f = intros t in let t1, t2 = (match f.t_node with | Tapp (ls, [t1; t2]) when ls_equal ls ps_equ -> (* Support to rewrite from the right *) if rev then (t1, t2) else (t2, t1) | Tbinop (Tiff, t1, t2) -> (* Support to rewrite from the right *) if rev then (t1, t2) else (t2, t1) | _ -> raise (Arg_bad_hypothesis ("rewrite", f))) in Some (lp, lv, llet, t1, t2) | _ -> acc) None in (* Return instantiated premises and the hypothesis correctly rewritten *) let lp_new found_eq = match found_eq with | None -> raise (Arg_error "rewrite") (* Should not happen *) | Some (lp, lv, llet, t1, t2) -> Trans.fold_decl (fun d acc -> match d.d_node with | Dprop (p, pr, t) when (Ident.id_equal pr.pr_name h1.pr_name && (p = Paxiom || p = Pgoal)) -> let lp, new_term = replace_subst lp lv llet t1 t2 with_terms t in Some (lp, create_prop_decl p pr new_term) | _ -> acc) None in (* Pass the premises as new goals. Replace the former toberewritten hypothesis to the new rewritten one *) let recreate_tasks lp_new = match lp_new with | None -> raise (Arg_trans "recreate_tasks") | Some (lp, new_term) -> let trans_rewriting = Trans.decl (fun d -> match d.d_node with | Dprop (p, pr, _t) when (Ident.id_equal pr.pr_name h1.pr_name && (p = Paxiom || p = Pgoal)) -> [new_term] | _ -> [d]) None in let list_par = List.map (fun e -> Trans.decl (fun d -> match d.d_node with | Dprop (p, pr, _t) when (Ident.id_equal pr.pr_name h1.pr_name && p = Paxiom) -> [d] | Dprop (Pgoal, _, _) -> [create_goal ~expl:rewrite_subgoals (Decl.create_prsymbol (gen_ident "G")) e] | _ -> [d] ) None) lp in Trans.par (trans_rewriting :: list_par) in (* Composing previous functions *) Trans.bind (Trans.bind found_eq lp_new) recreate_tasks let rewrite_list opt rev hl h1 = let found_decl = fold_decl (fun d (ok,acc) -> if ok then (ok,acc) else match d.d_node with | Dprop (p, pr, t) when (Ident.id_equal pr.pr_name h1.pr_name && (p = Paxiom || p = Pgoal)) -> (true,Some (p,pr,t)) | _ -> (ok, acc)) (false, None) in let found_term = Trans.bind found_decl (fun (_, od) -> Trans.store (fun _ -> match od with | Some (_,_,t) -> ([],t) | None -> raise (Arg_error "rewrite"))) in let do_h h (lp, term) = (* Used to find the equality we are rewriting on *) (* TODO here should fold with a boolean stating if we found equality yet to not go through all possible hypotheses *) fold_decl (fun d ((acclp,accterm) as acc) -> match d.d_node with | Dprop (Paxiom, pr, t) when Ident.id_equal pr.pr_name h.pr_name -> let lp, lv, llet, f = intros t in let t1, t2 = (match f.t_node with | Tapp (ls, [t1; t2]) when ls_equal ls ps_equ -> (* Support to rewrite from the right *) if rev then (t1, t2) else (t2, t1) | Tbinop (Tiff, t1, t2) -> (* Support to rewrite from the right *) if rev then (t1, t2) else (t2, t1) | _ -> raise (Arg_bad_hypothesis ("rewrite", f))) in let new_lp, new_term = if opt then try replace_subst lp lv llet t1 t2 [] accterm with Arg_trans _ -> acc else replace_subst lp lv llet t1 t2 [] accterm in new_lp@acclp, new_term | _ -> acc) (lp, term) in let do_all = List.fold_left (fun acc h -> Trans.bind acc (do_h h)) found_term hl in (* Pass the premises as new goals. Replace the former toberewritten hypothesis to the new rewritten one *) let recreate_tasks (lp, term) = let trans_rewriting = Trans.decl (fun d -> match d.d_node with | Dprop (p, pr, _t) when (Ident.id_equal pr.pr_name h1.pr_name && (p = Paxiom || p = Pgoal)) -> [create_prop_decl p pr term] | _ -> [d]) None in let list_par = List.map (fun e -> Trans.decl (fun d -> match d.d_node with | Dprop (p, pr, _t) when (Ident.id_equal pr.pr_name h1.pr_name && p = Paxiom) -> [d] | Dprop (Pgoal, _, _) -> [create_goal ~expl:rewrite_subgoals (Decl.create_prsymbol (gen_ident "G")) e] | _ -> [d] ) None) lp in Trans.par (trans_rewriting :: list_par) in Trans.bind do_all recreate_tasks let find_target_prop h : prsymbol trans = Trans.store (fun task -> match h with | Some pr -> pr | None -> Task.task_goal task) let rewrite with_terms rev h h1 = let with_terms = match with_terms with | None -> [] | Some l -> l in Trans.bind (find_target_prop h1) (rewrite_in (not rev) with_terms h) let rewrite_list rev opt hl h1 = Trans.bind (find_target_prop h1) (rewrite_list opt (not rev) hl) let detect_prop_list pr k hl = match hl with | None -> k = Pgoal | Some [] -> (* Should not be able to parse the empty list *) raise (Arg_trans "replace") | Some hl -> ((List.exists (fun h -> Ident.id_equal pr.pr_name h.pr_name) hl) && (k = Paxiom || k = Pgoal)) (* Replace occurences of t1 with t2 in h. When h is None, the default is to replace in the goal. *) let replace t1 t2 hl = if not (Ty.ty_equal (t_type t1) (t_type t2)) then raise (Arg_trans_term2 ("replace", t1, t2)) else (* Create a new goal for equality of the two terms *) let pr_goal = create_prsymbol (gen_ident "G") in let eq_goal_term = t_app_infer ps_equ [t1; t2] in let ng = create_goal ~expl:replace_hypothesis pr_goal eq_goal_term in let ng = Trans.goal (fun _ _ -> [ng]) in let g = Trans.decl (fun d -> match d.d_node with | Dprop (p, pr, t) when detect_prop_list pr p hl -> [create_prop_decl p pr (replace true t1 t2 t)] | _ -> [d]) None in Trans.par [g; ng] let t_replace_app unf ls_defn t = let (vl, tls) = ls_defn in match t.t_node with | Tapp (ls, tl) when ls_equal unf ls -> let add (mt,mv) x y = Ty.ty_match mt x.vs_ty (t_type y), Mvs.add x y mv in let mtv,mvs = List.fold_left2 add (Ty.Mtv.empty,Mvs.empty) vl tl in let mtv = Ty.oty_match mtv tls.t_ty t.t_ty in t_ty_subst mtv mvs tls | _ -> t let rec t_ls_replace ls ls_defn t = t_replace_app ls ls_defn (t_map (t_ls_replace ls ls_defn) t) let unfold unf hl = let r = ref None in Trans.decl (fun d -> match d.d_node with (* Do not work on mutually recursive functions *) | Dlogic [(ls, ls_defn)] when ls_equal ls unf -> r := Some (open_ls_defn ls_defn); [d] | Dprop (k, pr, t) when detect_prop_list pr k hl -> begin match !r with | None -> [d] | Some ls_defn -> let t = t_ls_replace unf ls_defn t in let new_decl = create_prop_decl k pr t in [new_decl] end | _ -> [d]) None let () = wrap_and_register ~desc:"sort declarations" "sort" (Ttrans) sort let () = wrap_and_register ~desc:"unfold ls [in] pr: unfold logic symbol ls in list of hypothesis pr. The argument in is optional: by default unfold in the goal." (* TODO *) "unfold" (Tlsymbol (Topt ("in", Tprlist Ttrans))) unfold let () = wrap_and_register ~desc:"replace [in] replaces occcurences of term1 by term2 in prop name. If no list is given, replace in the goal." "replace" (Tterm (Tterm (Topt ("in", Tprlist Ttrans_l)))) replace let _ = wrap_and_register ~desc:"rewrite [<-] [in] [with] rewrites equality defined in name into name2 using exactly all terms of the list as instance for what cannot be deduced directly" "rewrite" (Toptbool ("<-",(Tprsymbol (Topt ("in", Tprsymbol (Topt ("with", Ttermlist Ttrans_l))))))) (fun rev h h1opt term_list -> rewrite term_list rev h h1opt) let _ = wrap_and_register ~desc:"rewrite_list [<-] [?] [in] rewrites equalities defined in into name2. If [?] is set, each of the rewrites is optional." "rewrite_list" (Toptbool ("<-", (Tprlist (Toptbool ("?", Topt ("in", Tprsymbol Ttrans_l)))))) (fun rev hl opt h1opt -> rewrite_list rev opt hl h1opt) let () = wrap_and_register ~desc:"apply [with] applies prop to the goal and \ uses the list of terms to instantiate the variables that are not found." "apply" (Tprsymbol (Topt ("with", Ttermlist Ttrans_l))) (fun x y -> apply x y) why3-1.2.1/src/transform/split_goal.ml0000644000175100017510000005317213555524575020462 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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; cpos_split : bool; cneg_split : bool; asym_split : bool; intro_mode : bool; comp_match : known_map option; } let stop f = Sattr.mem Term.stop_split f.t_attrs let asym f = Sattr.mem Term.asym_split f.t_attrs let case_split = Ident.create_attribute "case_split" let case f = Sattr.mem case_split f.t_attrs let compiled = Ident.create_attribute "split_goal: compiled match" let unstop f = t_attr_set ?loc:f.t_loc (Sattr.remove stop_split f.t_attrs) 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) (* monoid law. *) let (++) a b = match a, b with | _, Unit | Zero _, _ -> a | Unit, _ | _, Zero _ -> b | 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 (~-) = t_attr_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 | x :: q -> let m = n + degree x in (m <= 1 && trivial m q) | [] -> true 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 ps_csp sp = { sp with cpos_split = false } in let ng_csp sp = { sp with cneg_split = false } in let no_csp sp = { sp with cpos_split = false; cneg_split = false } in let in_csp sp = { sp with cpos_split = sp.cneg_split; cneg_split = sp.cpos_split } 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_attr_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 | Tbinop (Tiff,_,_) | Tif _ | Tcase _ | Tquant _ when sp.intro_mode -> let df = drop_byso f in ret !+f !+df f df 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 split_core sp f1 else let (&&&) f1 f2 = - t_and f1 f2 in let rc = split_core (no_csp sp) 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 rc = split_core (ps_csp sp) 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 [sf2.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 split_core sp f1 else let rc = split_core (no_csp sp) in 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 sp2 = ng_csp sp in let sp1 = in_csp sp2 in let sf1 = split_core sp1 f1 and sf2 = split_core sp2 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 = [sf2.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 rc = split_core (ng_csp sp) 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 rc = split_core (no_csp sp) in 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 rc = split_core (no_csp sp) in 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 = split_core (in_csp sp) f1 in let (!) = alias f1 t_not in let (|>) zero = map (fun t -> !+(t_attr_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 = split_core sp 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 rc = match bl with | [_] -> split_core sp | _ -> split_core (no_csp sp) in 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, rc 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 Sattr.mem compiled f.t_attrs then (* keep the attributes for single-case match *) let attrs = match bl with | [_] -> Sattr.remove case_split (Sattr.remove compiled f.t_attrs) | _ -> Sattr.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_attr_set ?loc:f.t_loc attrs (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_attr_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 rc (- Pattern.compile_bare ~mk_case ~mk_let [t] bl) 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 = split_core sp 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 = sp.cpos_split; cneg = sp.cneg_split } 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; cpos_split = true; cneg_split = true; asym_split = true; intro_mode = false; 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; intro_mode = true; 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_all_full = prep_all full_proof let split_all_right = prep_all right_proof let split_premise_full = prep_premise full_proof let split_premise_right = prep_premise right_proof 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." why3-1.2.1/src/transform/eliminate_unknown_lsymbols.ml0000644000175100017510000000543613555524575023777 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 Theory open Task let debug = Debug.register_info_flag "eliminate_unknown_lsymbols" ~desc:"Print@ debugging@ messages@ of@ the@ eliminate_unknown_types@ transformation." 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 | Tvar _ | Tconst _ | Tapp(_,[]) | Ttrue | Tfalse -> t | Tapp (ls,_) when keep ls -> t_map abstract t | Tlet _ | Tnot _ | Tbinop _ | Tif _ -> t_map abstract t | _ -> if Debug.test_flag debug then Format.printf "eliminate@ %a@." Pretty.print_term t; let (ls, tabs) = try Hterm.find term_table t with Not_found -> let ls = create_lsymbol (Ident.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 let syntactic_transform transf = Trans.bind (Trans.fold (fun hd acc -> match hd.task_decl.td_node with | Decl { d_node = Dlogic ((ls,_def)::[]) } -> Sls.add ls acc | _ -> acc) Sls.empty) (fun decl -> Trans.on_meta Printer.meta_syntax_logic (fun metas -> let symbols = List.fold_left (fun acc meta_arg -> match meta_arg with | [Theory.MAls ls; Theory.MAstr _; Theory.MAint _] -> Sls.add ls acc | _ -> assert false) decl metas in let keep ls = Sls.exists (ls_equal ls) symbols in Trans.compose (transf keep) (Trans.decl (fun d -> match d.d_node with | Dparam l when not (keep l || l.ls_args = []) -> [] | _ -> [d]) None))) let () = Trans.register_transform "eliminate_unknown_lsymbols" (syntactic_transform abstraction) ~desc:"Abstract@ applications@ of@ non-built-in@ symbols@ with@ \ constants.@ Used@ by@ the@ Gappa@ pretty-printer." why3-1.2.1/src/transform/abstraction.ml0000644000175100017510000000323713555524575020633 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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_nt_na.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_attr_set Sattr.empty t in let (ls, tabs) = try Hterm_nt_na.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_nt_na.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-1.2.1/src/transform/reflection.mli0000644000175100017510000000157313555524575020626 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 NoReification val reflection_by_lemma: Decl.prsymbol -> Env.env -> Task.task Trans.tlist val reflection_by_function: bool -> string -> Env.env -> Task.task Trans.tlist why3-1.2.1/src/transform/ind_itp.mli0000644000175100017510000000141713555524575020117 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 revert_tr_symbol: Args_wrapper.symbol list -> Task.task Trans.trans why3-1.2.1/src/transform/encoding_tags_full.mli0000644000175100017510000000130713555524575022315 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/args_wrapper.mli0000644000175100017510000001305013555524575021161 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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. *) (* *) (********************************************************************) (** Pre-processing of transformations with arguments, including parsing and typing in the context of a task.*) open Task (** {2 context for parsing/typing transformation arguments} *) exception Parse_error of string exception Arg_expected of string * string exception Arg_theory_not_found of string exception Arg_expected_none of string exception Arg_pr_not_found of Decl.prsymbol exception Arg_qid_not_found of Ptree.qualid exception Arg_error of string exception Arg_parse_type_error of Loc.position * string * exn exception Unnecessary_arguments of string list val build_naming_tables : Task.task -> Trans.naming_table (** builds a naming tabl from a task, suitable for both parsing/typing transformation arguments and for printing the task, with coherent identifiers names. *) type symbol = | Tstysymbol of Ty.tysymbol | Tsprsymbol of Decl.prsymbol | Tslsymbol of Term.lsymbol val find_symbol : string -> Trans.naming_table -> symbol (** {2 transformation types} transformations with argument are themselves given types to control the interpretation of their raw string arguments. The type [trans_typ] of such transformations is elegantly defined as a GADT *) type (_, _) trans_typ = | Ttrans : ((task Trans.trans), task) trans_typ (** transformation with no argument, and exactly one resulting task *) | Ttrans_l : ((task Trans.tlist), task list) trans_typ (** transformation with no argument, and many resulting tasks *) | Tenvtrans : (Env.env -> (task Trans.trans), task) trans_typ (** transformation with no argument but depending on the environment, and exactly one resulting task *) | Tenvtrans_l : (Env.env -> (task Trans.tlist), task list) trans_typ (** transformation with no argument but depending on the environment, and many resulting tasks *) | Tstring : ('a, 'b) trans_typ -> ((string -> 'a), 'b) trans_typ (** transformation with a string as argument *) | Tint : ('a, 'b) trans_typ -> ((int -> 'a), 'b) trans_typ (** transformation with an integer argument *) | Tty : ('a, 'b) trans_typ -> ((Ty.ty -> 'a), 'b) trans_typ (** transformation with a Why3 type as argument *) | Ttysymbol : ('a, 'b) trans_typ -> ((Ty.tysymbol -> 'a), 'b) trans_typ (** transformation with a Why3 type symbol as argument *) | Tprsymbol : ('a, 'b) trans_typ -> ((Decl.prsymbol -> 'a), 'b) trans_typ (** transformation with a Why3 proposition symbol as argument *) | Tprlist : ('a, 'b) trans_typ -> ((Decl.prsymbol list -> 'a), 'b) trans_typ (** transformation with a list of Why3 proposition symbols as argument. The symbols must be separated by commas *) | Tlsymbol : ('a, 'b) trans_typ -> ((Term.lsymbol -> 'a), 'b) trans_typ (** transformation with a Why3 logic symbol as argument *) | Tsymbol : ('a, 'b) trans_typ -> ((symbol -> 'a), 'b) trans_typ (** transformation with a Why3 symbol as argument, either a type symbol, a logic symbol or a proposotion symbol *) | Tlist : ('a, 'b) trans_typ -> ((symbol list -> 'a), 'b) trans_typ (** transformation with a list Why3 symbol as argument, either a type symbol, a logic symbol or a proposotion symbol. The symbols must be separated by commas *) | Tidentlist : ('a, 'b) trans_typ -> ((string list -> 'a), 'b) trans_typ (** transformation with a list of identifiers as argument. The identifiers do not need to exist in the task, typically they could be fresh symbols *) | Ttermlist : ('a, 'b) trans_typ -> ((Term.term list -> 'a), 'b) trans_typ (** transformation with a list of terms as argument. *) | Tterm : ('a, 'b) trans_typ -> ((Term.term -> 'a), 'b) trans_typ (** transformation with a Why3 term as argument *) | Tformula : ('a, 'b) trans_typ -> ((Term.term -> 'a), 'b) trans_typ (** transformation with a Why3 formula as argument *) | Ttheory : ('a, 'b) trans_typ -> ((Theory.theory -> 'a), 'b) trans_typ (** transformation with a Why3 theory name as argument *) | Topt : string * ('a -> 'c, 'b) trans_typ -> (('a option -> 'c), 'b) trans_typ (** transformation with an optional argument. The first string is the keyword introducing that optional argument*) | Toptbool : string * ('a, 'b) trans_typ -> (bool -> 'a, 'b) trans_typ (** transformation with an optional boolean argument. The first string is the keyword for that optional argument, its presence meaning "true" *) (** {2 parsing and typing of arguments} the functions below wrap arguments of transformations, turning string arguments into arguments of proper types. arguments of type term of formula are parsed and typed, name resolution using the proper naming table. *) val wrap_l : ('a, task list) trans_typ -> 'a -> Trans.trans_with_args_l val wrap : ('a, task) trans_typ -> 'a -> Trans.trans_with_args val wrap_and_register : desc:Pp.formatted -> string -> ('a, 'b) trans_typ -> 'a -> unit why3-1.2.1/src/transform/induction.ml0000644000175100017510000004163313555524575020320 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 open Args_wrapper let attr_ind = create_attribute "induction" (* let desc_attrs = [attr_ind, ("Make the induction on the tagged 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 = Wstdlib.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_tagged qvl = List.filter (fun v -> Sattr.mem attr_ind v.vs_name.id_attrs) 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 taggedvl 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 taggedvl <> [] then Svsl.add taggedvl 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_tagged 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." let induction_on_hyp ls = Trans.compose (Ind_itp.revert_tr_symbol [Tslsymbol ls]) (Trans.store induction_ty_lex) let () = wrap_and_register ~desc:"induction_arg_ty_lex performs induction_ty_lex on ls." "induction_arg_ty_lex" (Tlsymbol Ttrans_l) induction_on_hyp (***************************************************************************) (********************** INDUCTION TACTIC FOR INTEGERS **********************) (*************************** WITH LEX. ORDER ***************************) (***************************************************************************) (* induction_int_lex : induction tactic for ordered int tuples. No heuristic is provided. Use attributes. 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 tagged variables (for induction variables), and the rest of the quantified variables after the last tagged 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_tagged 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 = Sattr.filter (fun v -> v.attr_string = "induction") v.vs_name.id_attrs in if not (Sattr.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_tagged 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 [Ident.op_infix "<="] in let lt_int = ns_find_ls th_int.th_export [Ident.op_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." *) why3-1.2.1/src/transform/cut.ml0000644000175100017510000001723513555524575017120 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 Ty open Generic_arg_trans_utils open Args_wrapper (** This file contains transformations with arguments that adds/removes declarations from the context *) (* Explanation for assert and cut *) let assert_expl = "asserted formula" (* From task [delta |- G] , build the tasks [delta, t | - G] and [delta] |- t] *) let cut t name = let name = match name with | Some name -> name | None -> "h" in let h = Decl.create_prsymbol (gen_ident name) in let g_t = create_goal ~expl:assert_expl h t in let h_t = Decl.create_prop_decl Decl.Paxiom h t in let goal_cut = Trans.goal (fun _ _ -> [g_t]) in let goal = Trans.add_decls [h_t] in Trans.par [goal; goal_cut] (* From task [delta |- G] , build the tasks [delta] |- t] and [delta, t | - G] *) let assert_tac t name = let name = match name with | Some name -> name | None -> "h" in let h = Decl.create_prsymbol (gen_ident name) in let g_t = create_goal ~expl:assert_expl h t in let h_t = Decl.create_prop_decl Decl.Paxiom h t in let goal_cut = Trans.goal (fun _ _ -> [g_t]) in let goal = Trans.add_decls [h_t] in Trans.par [goal_cut; goal] (* from task [delta, name1, name2, ... namen |- G] build the task [delta |- G] *) let remove_list name_list = Trans.decl (fun d -> match d.d_node with | Dprop (k, pr, _) when (k != Pgoal && List.exists (fun x -> match x with | Tsprsymbol x -> Ident.id_equal pr.pr_name x.pr_name | _ -> false ) name_list) -> [] | Dparam ls when (List.exists (fun x -> match x with | Tslsymbol x -> Ident.id_equal ls.ls_name x.ls_name | _ -> false ) name_list) -> [] | Dlogic dl when (* also remove all dependant recursive declarations (as expected) *) List.exists (fun (ls, _) -> List.exists (fun x -> match x with | Tslsymbol x -> Ident.id_equal ls.ls_name x.ls_name | _ -> false ) name_list) dl -> [] | Dind il when (* also remove all dependant inductive declarations (as expected) *) List.exists (fun (ls, _) -> List.exists (fun x -> match x with | Tslsymbol x -> Ident.id_equal ls.ls_name x.ls_name | _ -> false ) name_list) (snd il) -> [] | Dtype ty when (List.exists (fun x -> match x with | Tstysymbol x -> Ident.id_equal ty.ts_name x.ts_name | _ -> false ) name_list) -> [] | Ddata tyl when (* also remove all dependant recursive declarations (as expected) *) List.exists (fun (ty, _) -> List.exists (fun x -> match x with | Tstysymbol x -> Ident.id_equal ty.ts_name x.ts_name | _ -> false ) name_list) tyl -> [] | _ -> [d]) None (* from task [delta, name1, name2, ... namen |- G] build the task [name1, name2, ... namen |- G] *) let clear_but (l: prsymbol list) local_decls = Trans.decl (fun d -> match d.d_node with | Dprop (Paxiom, pr, _t) when List.mem pr l -> [d] | Dprop (Paxiom, _pr, _t) when List.exists (fun x -> Decl.d_equal x d) local_decls -> [] | _ -> [d]) None let clear_but (l: prsymbol list) = Trans.bind get_local (clear_but l) let use_th th = Trans.store Task.(function | Some { task_decl = { Theory.td_node = Theory.Decl d }; task_prev = prev } -> add_decl (use_export prev th) d | _ -> assert false) (*Trans.add_tdecls [Theory.create_use th]*) (* Equivalent of Coq pose (x := term). Adds a new constant of appropriate type and an hypothesis x = term. This function returns the declarations of hypothesis and constant. *) let pose (clear: bool) (name: string) (t: term) = let ty = Term.t_type t in let ls = Term.create_lsymbol (gen_ident name) [] (Some ty) in let ls_term = Term.t_app_infer ls [] in let new_constant = Decl.create_param_decl ls in let pr = create_prsymbol (gen_ident "H") in (* hyp = [pr : ls = t] *) let hyp = Decl.create_prop_decl Paxiom pr (Term.t_app_infer ps_equ [ls_term;t]) in let trans_new_task = if clear then Trans.add_decls [new_constant] else Trans.add_decls [new_constant; hyp] in (* Note that sort is necessary *and* the complexity is probably the same as if we use a function Trans.prepend_decl (which will be linear in the size of the task. Sort should be too). *) Trans.compose trans_new_task (Trans.compose sort (Trans.store (fun task -> ((hyp, new_constant, ls_term), task)))) (* Sometimes it is useful to hide part of a term (actually to pose a constant equal to a term). It may also help provers to completely remove reference to stuff *) let hide (clear: bool) (name: string) (t: term) = let replace_all hyp new_constant ls_term = Trans.decl (fun d -> match d.d_node with | _ when (Decl.d_equal d hyp || Decl.d_equal d new_constant) -> [d] | Dprop (p, pr, t1) -> let new_decl = create_prop_decl p pr (replace_in_term t ls_term t1) in [new_decl] | _ -> [d]) None in Trans.bind_comp (pose clear name t) (fun (hyp,new_constant,ls_term) -> replace_all hyp new_constant ls_term) let () = wrap_and_register ~desc:"clear all axioms but the hypothesis argument" "clear_but" (Tprlist Ttrans) clear_but let () = wrap_and_register ~desc:"cut [name] makes a cut with hypothesis 'name: term'" "cut" (Tformula (Topt ("as",Tstring Ttrans_l))) cut let () = wrap_and_register ~desc:"cut [name] makes an assert with hypothesis 'name: term'" "assert" (Tformula (Topt ("as",Tstring Ttrans_l))) assert_tac let () = wrap_and_register ~desc:"remove : removes a list of hypothesis given by their names separated with ','. Example: remove_list a,b,c " "remove" (Tlist Ttrans) (fun l -> remove_list l) let () = wrap_and_register ~desc:"use_th imports the theory" "use_th" (Ttheory Ttrans) use_th let pose (name: string) (t: term) = Trans.bind (pose false name t) (fun (_, task) -> Trans.store (fun _ -> task)) let () = wrap_and_register ~desc:"pose adds a new constant equal to " "pose" (Tstring (Tterm Ttrans)) pose let () = wrap_and_register ~desc:"hide adds a new constant equal to and replace everywhere the term with the new constant." "hide" (Tstring (Tterm Ttrans)) (hide false) let () = wrap_and_register ~desc:"hide and clear adds a new constant which replaces all occurences of ." "hide_and_clear" (Tstring (Tterm Ttrans)) (hide true) why3-1.2.1/src/transform/encoding_twin.mli0000644000175100017510000000130713555524575021316 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/generic_arg_trans_utils.mli0000644000175100017510000000516613555524575023372 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 exception Arg_trans of string exception Arg_trans_decl of (string * Theory.tdecl list) exception Arg_trans_term of (string * term) exception Arg_trans_term2 of (string * term * term) exception Arg_trans_term3 of (string * term * term * term) exception Arg_trans_pattern of (string * pattern * pattern) exception Arg_trans_type of (string * Ty.ty * Ty.ty) exception Arg_trans_missing of (string * Svs.t) exception Arg_bad_hypothesis of (string * term) exception Cannot_infer_type of string exception Unnecessary_terms of term list val gen_ident : ?attrs:Ident.Sattr.t -> ?loc:Loc.position -> string -> Ident.preid val replace_in_term: term -> term -> term -> term val subst_quant: quant -> term_quant -> term -> term (* Transform the term (exists v, f) into f[x/v] *) val subst_exist: term -> term -> term (* Transform the term (forall v, f) into f[x/v] *) val subst_forall: term -> term -> term (* TODO remove subst_forall and subst_exist *) (* Same as subst_forall with a list of term *) val subst_forall_list: term -> term list -> term (* Returns the list of local declarations *) val get_local: Decl.decl list Trans.trans val get_local_task: Task.task -> Decl.decl list (* Returns same list of declarations but reorganized with constant/type definitions defined before axioms *) val sort: Task.task Trans.trans (*************************) (* Substitution of terms *) (*************************) type term_subst = term Mterm.t val replace_subst: term_subst -> Term.term -> Term.term val replace_decl: term_subst -> Decl.decl -> Decl.decl val replace_tdecl: term_subst -> Theory.tdecl -> Theory.tdecl (************************) (* Explanation handling *) (************************) (* This function creates a goal with an explanation. The term on which this is applied should not contain any explanation itself (otherwise both would appear in the ide). *) val create_goal: expl:string -> Decl.prsymbol -> Term.term -> Decl.decl why3-1.2.1/src/transform/apply.mli0000644000175100017510000000305113555524575017612 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 intros: Term.term -> Term.term list * Term.vsymbol list * (Term.vsymbol * Term.term) list * Term.term (* intros returns a tuple containing: - list of premises of the term, - list of universally quantified variables at head of the terms, - list of let-binding at head of the term, - the term without premises/let-binding and forall variables at head. *) val rewrite_list: bool -> bool -> Decl.prsymbol list -> Decl.prsymbol option -> Task.task list Trans.trans (* [rewrite_list with_terms rev opt hl h1] @param opt: If set, all the rewritings are optional @param rev: If set, all the rewritings are from right to left @param hl: list of rewrite hypothesis @param h1: hypothesis to rewrite in *) val term_decl: Theory.tdecl -> Term.term (* Return the term associated to a prop declaration or raise an error in every other cases *) why3-1.2.1/src/transform/encoding_tags_full.ml0000644000175100017510000001072213555524575022145 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 Wstdlib 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-1.2.1/src/transform/reduction_engine.mli0000644000175100017510000000674413555524575022022 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 : ?step_limit:int -> 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. parameter [step_limit] provides a maximum number of steps on reductions that would change the term even after reconstruction. *) open Term exception NoMatch of (term * term * term option) option (** [NoMatch (t1, t2, t3)] Cannot match [t1] with [t2]. If [t3] exists then [t1] is already matched with [t3]. *) exception NoMatchpat of (pattern * pattern) option type substitution = term Mvs.t val first_order_matching: Svs.t -> term list -> term list -> Ty.ty Ty.Mtv.t * substitution why3-1.2.1/src/transform/eliminate_algebraic.mli0000644000175100017510000000264613555524575022436 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/args_wrapper.ml0000644000175100017510000005115613555524575021021 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 open Ty open Term open Trans open Ident open Theory open Decl exception Parse_error of string exception Arg_expected of string * string exception Arg_theory_not_found of string exception Arg_expected_none of string exception Arg_qid_not_found of Ptree.qualid exception Arg_pr_not_found of prsymbol exception Arg_error of string let () = Exn_printer.register (fun fmt e -> match e with | Parse_error s -> Format.fprintf fmt "Parsing error: %s" s | Arg_expected (ty, s) -> Format.fprintf fmt "Argument expected of type: %s\n Argument given: %s" ty s | Arg_theory_not_found s -> Format.fprintf fmt "Theory not found %s" s | Arg_expected_none s -> Format.fprintf fmt "Argument expected of type %s. None were given." s | _ -> raise e) open Wstdlib (* Use symb to encapsulate ids into correct categories of symbols *) type symb = | Ts of tysymbol | Ls of lsymbol | Pr of prsymbol (* [add_unsafe s id tables] Add (s, id) to tables without any checking. *) let add_unsafe (s: string) (id: symb) (tables: naming_table) : naming_table = match id with | Ts ty -> {tables with namespace = {tables.namespace with ns_ts = Mstr.add s ty tables.namespace.ns_ts}; } | Ls ls -> {tables with namespace = {tables.namespace with ns_ls = Mstr.add s ls tables.namespace.ns_ls}; } | Pr pr -> {tables with namespace = {tables.namespace with ns_pr = Mstr.add s pr tables.namespace.ns_pr}; } let id_unique tables id = id_unique_attr tables.printer id (* Adds symbols that are introduced to a constructor *) let constructor_add (cl: constructor list) tables : naming_table = List.fold_left (fun tables ((ls, cl): constructor) -> let tables = List.fold_left (fun tables (cs: lsymbol option) -> match cs with | Some cs -> let id = cs.ls_name in let s = id_unique tables id in add_unsafe s (Ls cs) tables | None -> tables) tables cl in let id = ls.ls_name in let s = id_unique tables id in add_unsafe s (Ls ls) tables) tables cl (* Add symbols that are introduced by an inductive *) let ind_decl_add il tables = List.fold_left (fun tables ((pr, _): prsymbol * term) -> let id = pr.pr_name in let s = id_unique tables id in add_unsafe s (Pr pr) tables) il tables (* [add d printer tables] Adds all new declaration of symbol inside d to tables. It uses printer to give them a unique name and also register these new names in printer *) let add (d: decl) (tables: naming_table): naming_table = match d.d_node with | Dtype ty -> (* only current symbol is new in the declaration (see create_ty_decl) *) let id = ty.ts_name in let s = id_unique tables id in add_unsafe s (Ts ty) tables | Ddata dl -> (* first part is new. Also only first part of each constructor seem new (see create_data_decl) *) List.fold_left (fun tables (dd: data_decl) -> let id = (fst dd).ts_name in let s = id_unique tables id in let tables = add_unsafe s (Ts (fst dd)) tables in constructor_add (snd dd) tables) tables dl | Dparam ls -> (* Only one lsymbol which is new *) let id = ls.ls_name in let s = id_unique tables id in add_unsafe s (Ls ls) tables | Dlogic lsd -> (* Only first part of logic_decl is new (see create_logic) *) List.fold_left (fun tables ((ls,_): logic_decl) -> let id = ls.ls_name in let s = id_unique tables id in add_unsafe s (Ls ls) tables) tables lsd | Dind (_is, il) -> (* Every symbol is new except symbol inside terms (see create_ind_decl) *) List.fold_left (fun tables ((ls,ind): ind_decl) -> let id = ls.ls_name in let s = id_unique tables id in let tables = add_unsafe s (Ls ls) tables in ind_decl_add tables ind) tables il | Dprop (_, pr, _) -> (* Only pr is new in Dprop (see create_prop_decl) *) let id = pr.pr_name in let s = id_unique tables id in add_unsafe s (Pr pr) tables (* Takes the set of meta defined in the tasks and build the coercions from it. TODO we could have a set of coercions in the task ? Same problem for naming table ? *) let build_coercion_map km_meta = try let crc_set = Theory.Mmeta.find Theory.meta_coercion km_meta in let crc_map = Stdecl.fold (fun elem crc_map -> match elem.Theory.td_node with | Meta (m,([MAls ls] as _al)) when meta_equal m Theory.meta_coercion -> Coercion.add crc_map ls | _ -> crc_map) crc_set.tds_set Coercion.empty in crc_map with | Not_found -> Coercion.empty let build_naming_tables task : naming_table = let isanitizer = None (* sanitizer do not seem to be necessary *) in let lsanitize = sanitizer char_to_lalpha char_to_alnumus in let pr = create_ident_printer Pretty.why3_keywords ?sanitizer:isanitizer in let apr = create_ident_printer Pretty.why3_keywords ~sanitizer:lsanitize in let km = Task.task_known task in let km_meta = Task.task_meta task in let tables = { namespace = empty_ns; known_map = km; coercion = Coercion.empty; printer = pr; aprinter = apr; } in (* We want conflicting names to be named as follows: names closer to the goal should be named with lowest disambiguation numbers. This only works for things defined in .why/.mlw because things added by the user are renamed on the fly. *) (* TODO:imported theories should be added in the namespace too *) let tables = Task.task_fold (fun t d -> match d.td_node with Decl d -> add d t | _ -> t) tables task in let crc_map = build_coercion_map km_meta in {tables with coercion = crc_map} (************* wrapper *************) type symbol = | Tstysymbol of Ty.tysymbol | Tsprsymbol of Decl.prsymbol | Tslsymbol of Term.lsymbol type (_, _) trans_typ = | Ttrans : ((task trans), task) trans_typ | Ttrans_l : ((task tlist), task list) trans_typ | Tenvtrans : (Env.env -> (task trans), task) trans_typ | Tenvtrans_l : (Env.env -> (task tlist), task list) trans_typ | Tstring : ('a, 'b) trans_typ -> ((string -> 'a), 'b) trans_typ | Tint : ('a, 'b) trans_typ -> ((int -> 'a), 'b) trans_typ | Tty : ('a, 'b) trans_typ -> ((ty -> 'a), 'b) trans_typ | Ttysymbol : ('a, 'b) trans_typ -> ((tysymbol -> 'a), 'b) trans_typ | Tprsymbol : ('a, 'b) trans_typ -> ((Decl.prsymbol -> 'a), 'b) trans_typ | Tprlist : ('a, 'b) trans_typ -> ((Decl.prsymbol list -> 'a), 'b) trans_typ | Tlsymbol : ('a, 'b) trans_typ -> ((Term.lsymbol -> 'a), 'b) trans_typ | Tsymbol : ('a, 'b) trans_typ -> ((symbol -> 'a), 'b) trans_typ | Tlist : ('a, 'b) trans_typ -> ((symbol list -> 'a), 'b) trans_typ | Tidentlist : ('a, 'b) trans_typ -> ((string list -> 'a), 'b) trans_typ | Ttermlist : ('a, 'b) trans_typ -> ((term list -> 'a), 'b) trans_typ | Tterm : ('a, 'b) trans_typ -> ((term -> 'a), 'b) trans_typ | Tformula : ('a, 'b) trans_typ -> ((term -> 'a), 'b) trans_typ | Ttheory : ('a, 'b) trans_typ -> ((Theory.theory -> 'a), 'b) trans_typ | Topt : string * ('a -> 'c, 'b) trans_typ -> (('a option -> 'c), 'b) trans_typ | Toptbool : string * ('a, 'b) trans_typ -> (bool -> 'a, 'b) trans_typ let find_pr q tables = Theory.ns_find_pr tables.namespace (Typing.string_list_of_qualid q) let find_ts q tables = Theory.ns_find_ts tables.namespace (Typing.string_list_of_qualid q) let find_ls q tables = Theory.ns_find_ls tables.namespace (Typing.string_list_of_qualid q) let find_symbol q tables = try Tsprsymbol (find_pr q tables) with | Not_found -> try Tslsymbol (find_ls q tables) with | Not_found -> try Tstysymbol (find_ts q tables) with | Not_found -> raise (Arg_qid_not_found q) let type_ptree ~as_fmla t tables = let km = tables.known_map in let ns = tables.namespace in let crc = tables.coercion in if as_fmla then Typing.type_fmla_in_namespace ns km crc t else Typing.type_term_in_namespace ns km crc t exception Arg_parse_type_error of Loc.position * string * exn let parse_and_type ~as_fmla s task = try let lb = Lexing.from_string s in let t = Lexer.parse_term lb in let t = type_ptree ~as_fmla:as_fmla t task in t with | Loc.Located (loc, e) -> raise (Arg_parse_type_error (loc, s, e)) let parse_and_type_list ~as_fmla s task = try let lb = Lexing.from_string s in let t_list = Lexer.parse_term_list lb in let t_list = List.map (fun t -> type_ptree ~as_fmla:as_fmla t task) t_list in t_list with | Loc.Located (loc, e) -> raise (Arg_parse_type_error (loc, s, e)) let parse_qualid s = try let lb = Lexing.from_string s in Lexer.parse_qualid lb with | Loc.Located (loc, e) -> raise (Arg_parse_type_error (loc, s, e)) let parse_list_qualid s = try let lb = Lexing.from_string s in Lexer.parse_list_qualid lb with | Loc.Located (loc, e) -> raise (Arg_parse_type_error (loc, s, e)) let parse_list_ident s = try let lb = Lexing.from_string s in Lexer.parse_list_ident lb with | Loc.Located (loc, e) -> raise (Arg_parse_type_error (loc, s, e)) let build_error s e = let loc = Loc.user_position "" 0 0 (String.length s - 1) in raise (Arg_parse_type_error (loc, s, e)) let parse_int s = try int_of_string s with Failure _ -> build_error s (Parse_error "int expected") let parse_theory env s = try let path, name = match Strings.split '.' s with | [name] -> [],name | path::[name] -> let path = Strings.split '/' path in path, name | _ -> build_error s (Parse_error "Ill-formed theory name") in Env.read_theory env path name with _ -> build_error s (Parse_error "Theory not found") let trans_typ_tail: type a b c. (a -> b, c) trans_typ -> (b, c) trans_typ = fun t -> match t with | Tint t -> t | Tty t -> t | Ttysymbol t -> t | Tprsymbol t -> t | Tprlist t -> t | Tlsymbol t -> t | Tsymbol t -> t | Tlist t -> t | Tterm t -> t | Tstring t -> t | Tformula t -> t | Ttheory t -> t | Ttermlist t -> t | Tidentlist t -> t | _ -> assert false type _ trans_typ_is_l = Yes : (task list) trans_typ_is_l | No : task trans_typ_is_l let rec is_trans_typ_l: type a b. (a, b) trans_typ -> b trans_typ_is_l = fun t -> match t with | Tenvtrans -> No | Ttrans -> No | Tenvtrans_l -> Yes | Ttrans_l -> Yes | Tint t -> is_trans_typ_l t | Tstring t -> is_trans_typ_l t | Tty t -> is_trans_typ_l t | Ttysymbol t -> is_trans_typ_l t | Tprsymbol t -> is_trans_typ_l t | Tprlist t -> is_trans_typ_l t | Tlsymbol t -> is_trans_typ_l t | Tsymbol t -> is_trans_typ_l t | Tlist t -> is_trans_typ_l t | Tterm t -> is_trans_typ_l t | Tidentlist t -> is_trans_typ_l t | Ttermlist t -> is_trans_typ_l t | Tformula t -> is_trans_typ_l t | Ttheory t -> is_trans_typ_l t | Topt (_,t) -> is_trans_typ_l t | Toptbool (_,t) -> is_trans_typ_l t let rec string_of_trans_typ : type a b. (a, b) trans_typ -> string = fun t -> match t with | Ttrans -> "task" | Ttrans_l -> "list task" | Tenvtrans -> "env -> task" | Tenvtrans_l -> "env -> list task" | Tint _ -> "int" | Tstring _ -> "string" | Tty _ -> "type" | Ttysymbol _ -> "tysymbol" | Tprsymbol _ -> "prsymbol" | Tprlist _ -> "list prsymbol" | Tlsymbol _ -> "lsymbol" | Tsymbol _ -> "symbol" | Tlist _ -> "list symbol" | Tterm _ -> "term" | Tformula _ -> "formula" | Tidentlist _ -> "list ident" | Ttermlist _ -> "list term" | Ttheory _ -> "theory" | Topt (s,t) -> "?" ^ s ^ (string_of_trans_typ t) | Toptbool (s,_) -> "?" ^ s ^ ":bool" let rec print_type : type a b. Format.formatter -> (a, b) trans_typ -> unit = fun fmt t -> match t with | Ttrans -> Format.fprintf fmt "task" | Ttrans_l -> Format.fprintf fmt "list task" | Tenvtrans -> Format.fprintf fmt "env -> task" | Tenvtrans_l -> Format.fprintf fmt "env -> list task" | Tint t -> Format.fprintf fmt "integer -> %a" print_type t | Tstring t -> Format.fprintf fmt "string -> %a" print_type t | Tty t -> Format.fprintf fmt "type -> %a" print_type t | Ttysymbol t -> Format.fprintf fmt "type_symbol -> %a" print_type t | Tprsymbol t -> Format.fprintf fmt "prsymbol -> %a" print_type t | Tprlist t -> Format.fprintf fmt "list prsymbol -> %a" print_type t | Tlsymbol t -> Format.fprintf fmt "lsymbol -> %a" print_type t | Tsymbol t -> Format.fprintf fmt "symbol -> %a" print_type t | Tlist t -> Format.fprintf fmt "list symbol -> %a" print_type t | Tterm t -> Format.fprintf fmt "term -> %a" print_type t | Tformula t -> Format.fprintf fmt "formula -> %a" print_type t | Tidentlist t -> Format.fprintf fmt "list ident -> %a" print_type t | Ttermlist t -> Format.fprintf fmt "list term -> %a" print_type t | Ttheory t -> Format.fprintf fmt "theory -> %a" print_type t | Topt (s,t) -> Format.fprintf fmt "?%s -> %a" s print_type t | Toptbool (s,t) -> Format.fprintf fmt "?%s:bool -> %a" s print_type t exception Unnecessary_arguments of string list let rec wrap_to_store : type a b. (a, b) trans_typ -> a -> string list -> Env.env -> naming_table -> task -> b = fun t f l env tables task -> match t, l with | Ttrans, []-> apply f task | Ttrans_l, [] -> apply f task | Tenvtrans, [] -> apply (f env) task | Tenvtrans_l, [] -> apply (f env) task | Ttrans, _ -> raise (Unnecessary_arguments l) | Ttrans_l, _ -> raise (Unnecessary_arguments l) | Tenvtrans, _ -> raise (Unnecessary_arguments l) | Tenvtrans_l, _ -> raise (Unnecessary_arguments l) | Tint t', s :: tail -> let arg = parse_int s in wrap_to_store t' (f arg) tail env tables task | Tstring t', s :: tail -> wrap_to_store t' (f s) tail env tables task | Tformula t', s :: tail -> let te = parse_and_type ~as_fmla:true s tables in wrap_to_store t' (f te) tail env tables task | Tterm t', s :: tail -> let te = parse_and_type ~as_fmla:false s tables in wrap_to_store t' (f te) tail env tables task | Tty t', _s :: tail -> let ty = Ty.ty_int in (* TODO: parsing + typing of s *) wrap_to_store t' (f ty) tail env tables task | Ttysymbol t', _s :: tail -> let tys = Ty.ts_int in (* TODO: parsing + typing of s *) wrap_to_store t' (f tys) tail env tables task | Tprsymbol t', s :: tail -> let q = parse_qualid s in let pr = try (find_pr q tables) with | Not_found -> raise (Arg_qid_not_found q) in wrap_to_store t' (f pr) tail env tables task | Tprlist t', s :: tail -> let pr_list = parse_list_qualid s in let pr_list = List.map (fun id -> try find_pr id tables with | Not_found -> raise (Arg_qid_not_found id)) pr_list in wrap_to_store t' (f pr_list) tail env tables task | Tlsymbol t', s :: tail -> let q = parse_qualid s in let pr = try (find_ls q tables) with | Not_found -> raise (Arg_qid_not_found q) in wrap_to_store t' (f pr) tail env tables task | Tsymbol t', s :: tail -> let q = parse_qualid s in let symbol = find_symbol q tables in wrap_to_store t' (f symbol) tail env tables task | Tlist t', s :: tail -> let pr_list = parse_list_qualid s in let pr_list = List.map (fun id -> find_symbol id tables) pr_list in wrap_to_store t' (f pr_list) tail env tables task | Ttheory t', s :: tail -> let th = parse_theory env s in wrap_to_store t' (f th) tail env tables task | Tidentlist t', s :: tail -> let list = List.map (fun id -> id.Ptree.id_str) (parse_list_ident s) in wrap_to_store t' (f list) tail env tables task | Ttermlist t', s :: tail -> let term_list = parse_and_type_list ~as_fmla:false s tables in wrap_to_store t' (f term_list) tail env tables task | Topt (optname, t'), s :: s' :: tail when s = optname -> begin match t' with | Tint t' -> let arg = Some (parse_int s') in wrap_to_store t' (f arg) tail env tables task | Tprsymbol t' -> let q = parse_qualid s' in let arg = try Some (find_pr q tables) with | Not_found -> raise (Arg_qid_not_found q) in wrap_to_store t' (f arg) tail env tables task | Tsymbol t' -> let q = parse_qualid s' in let arg = Some (find_symbol q tables) in wrap_to_store t' (f arg) tail env tables task | Tformula t' -> let arg = Some (parse_and_type ~as_fmla:true s' tables) in wrap_to_store t' (f arg) tail env tables task | Tterm t' -> let arg = Some (parse_and_type ~as_fmla:false s' tables) in wrap_to_store t' (f arg) tail env tables task | Ttheory t' -> let arg = Some (parse_theory env s') in wrap_to_store t' (f arg) tail env tables task | Tstring t' -> let arg = Some s' in wrap_to_store t' (f arg) tail env tables task | Tprlist t' -> let pr_list = parse_list_qualid s' in let pr_list = List.map (fun id -> try find_pr id tables with | Not_found -> raise (Arg_qid_not_found id)) pr_list in let arg = Some pr_list in wrap_to_store t' (f arg) tail env tables task | Ttermlist t' -> let term_list = parse_and_type_list ~as_fmla:false s' tables in wrap_to_store t' (f (Some term_list)) tail env tables task | Tidentlist t' -> let list = List.map (fun id -> id.Ptree.id_str) (parse_list_ident s') in wrap_to_store t' (f (Some list)) tail env tables task | _ -> raise (Arg_expected (string_of_trans_typ t', s')) end | Topt (_, t'), _ -> wrap_to_store (trans_typ_tail t') (f None) l env tables task | Toptbool (optname, t'), s :: tail when s = optname -> wrap_to_store t' (f true) tail env tables task | Toptbool (_, t'), _ -> wrap_to_store t' (f false) l env tables task | _, [] -> raise (Arg_expected_none (string_of_trans_typ t)) let wrap_l : type a. (a, task list) trans_typ -> a -> trans_with_args_l = fun t f l env tables -> Trans.store (wrap_to_store t f l env tables) let wrap : type a. (a, task) trans_typ -> a -> trans_with_args = fun t f l env tables -> Trans.store (wrap_to_store t f l env tables) let wrap_any : type a b. (a, b) trans_typ -> a -> string list -> Env.env -> Trans.naming_table -> b trans = fun t f l env tables -> Trans.store (wrap_to_store t f l env tables) (* the one in Scanf is awfully broken with respect to backslashes *) let format_from_string s fmt = Scanf.sscanf_format (Printf.sprintf "%S" s) fmt (fun s -> s) let wrap_and_register : type a b. desc:Pp.formatted -> string -> (a, b) trans_typ -> a -> unit = fun ~desc name t f -> (* "%@\n" is escaped on purpose *) let type_desc = Format.asprintf "type: %a%@\n" print_type t in let type_desc = format_from_string type_desc Pp.empty_formatted in let desc = type_desc ^^ desc in let trans = wrap_any t f in match is_trans_typ_l t with | Yes -> Trans.register_transform_with_args_l ~desc name trans | No -> Trans.register_transform_with_args ~desc name trans let find_symbol s tables = find_symbol (parse_qualid s) tables why3-1.2.1/src/transform/encoding_select.ml0000644000175100017510000000736213555524575021452 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 Wstdlib 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-1.2.1/src/transform/libencoding.mli0000644000175100017510000000525713555524575020754 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/close_epsilon.mli0000644000175100017510000000226513555524575021331 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/encoding_tags.mli0000644000175100017510000000130713555524575021273 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/case.ml0000644000175100017510000001476313555524575017243 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 Ident open Ty open Decl open Args_wrapper open Generic_arg_trans_utils (** This file contains transformation with arguments that acts directly on a logic connector for intro (case, or_intro, intros, exists) *) (** Explanations *) (* Explanation for [left]/[right] *) let left_case_expl = "left case" let right_case_expl = "right case" (* Explanation for [case] *) let true_case_expl = "true case" let false_case_expl = "false case" (* Add an explanation attribute to a goal *) let create_goal_trans ~expl = Trans.goal (fun pr g -> [create_goal ~expl pr g]) (* From task [delta |- G] and term t, build the tasks: [delta, t] |- G] and [delta, not t | - G] *) let case t name = let name = match name with | Some name -> name | None -> "h" in let h = Decl.create_prsymbol (gen_ident name) in let hnot = Decl.create_prsymbol (gen_ident name) in let t_not_decl = Decl.create_prop_decl Decl.Paxiom hnot (Term.t_not t) in let t_decl = Decl.create_prop_decl Decl.Paxiom h t in let left_trans = Trans.compose (create_goal_trans ~expl:true_case_expl) (Trans.add_decls [t_decl]) in let right_trans = Trans.compose (create_goal_trans ~expl:false_case_expl) (Trans.add_decls [t_not_decl]) in Trans.par [left_trans; right_trans] let or_intro (left: bool) : Task.task Trans.trans = Trans.decl (fun d -> match d.d_node with | Dprop (Pgoal, pr, t) -> begin match t.t_node with | Tbinop (Tor, t1, t2) -> if left then [create_goal ~expl:left_case_expl pr t1] else [create_goal ~expl:right_case_expl pr t2] | _ -> [d] end | _ -> [d]) None let exists_aux g x = let t = subst_exist g x in let pr_goal = create_prsymbol (gen_ident "G") in let new_goal = Decl.create_prop_decl Decl.Pgoal pr_goal t in [new_goal] (* From task [delta |- exists x. G] and term t, build the task [delta |- G[x -> t]]. Return an error if x and t are not unifiable. *) let exists x = Trans.goal (fun _ g -> exists_aux g x) (* TODO temporary *) let rec intros list_name pr f = if list_name = [] then [create_prop_decl Pgoal pr f] else match f.t_node with | Tbinop (Timplies,f1,f2) -> (* f is going to be removed, preserve its attributes and location in f2 *) let f2 = t_attr_copy f f2 in let name, tl = match list_name with | [] -> assert false | "" :: tl -> "H", tl | name :: tl -> name, tl in let id = create_prsymbol (id_fresh name) in let d = create_prop_decl Paxiom id f1 in d :: intros tl pr f2 | Tquant (Tforall,fq) -> let vsl,_trl,f_t = t_open_quant fq in let intro_var name subst vs = let ls = create_lsymbol name [] (Some vs.vs_ty) in Mvs.add vs (fs_app ls [] vs.vs_ty) subst, create_param_decl ls in (* TODO clarify this: We iterate on both the list of names given by the user and the list of variables bounded by the forall. The two lists can have different sizes and this solution is ugly. Should use a List function instead. *) let rec subst_decls (subst, decls) list_name vsl = match list_name, vsl with | [], _ -> (subst, decls, vsl, []) | _, [] -> (subst, decls, [], list_name) | name :: list_name, var :: vsl -> let name = if name = "" then id_clone var.vs_name else id_fresh name in let subst, decl = intro_var name subst var in subst_decls (subst, decl :: decls) list_name vsl in let subst, decls, vsl, list_name = subst_decls (Mvs.empty, []) list_name vsl in if vsl = [] then let f = t_attr_copy f (t_subst subst f_t) in (List.rev decls) @ intros list_name pr f else let f = t_quant Tforall (t_close_quant vsl [] (t_subst subst f_t)) in (List.rev decls) @ intros list_name pr f | Tlet (t,fb) -> let vs,f = t_open_bound fb in let name = List.hd list_name in let ls = create_lsymbol (id_fresh 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 (List.tl list_name) pr f (* Intentionnaly do not fail when too many arguments are given *) | _ -> [create_prop_decl Pgoal pr f] let intros list_name 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 list_name pr (t_ty_subst subst Mvs.empty f) (* TODO solve this inefficiency *) let rec create_list n = if n <= 0 then [] else "" :: create_list (n-1) (* TODO inefficient create_list *) let introduce_premises n = Trans.goal (intros (create_list n)) let intros_list l = Trans.goal (intros l) let () = wrap_and_register ~desc:"case [name] generates hypothesis 'name: term' in a first goal and 'name: ~ term' in a second one." "case" (Tformula (Topt ("as",Tstring Ttrans_l))) case let () = wrap_and_register ~desc:"left transform a disjunctive goal A \\/ B into A" "left" (Ttrans) (or_intro true) let () = wrap_and_register ~desc:"right transform a disjunctive goal A \\/ B into B" "right" (Ttrans) (or_intro false) let () = wrap_and_register ~desc:"exists substitutes the existentially quantified variable with the given term" "exists" (Tterm Ttrans) exists let () = wrap_and_register ~desc:"intros n introduces the first n quantified variables and hypotheses" "intros_n" (Tint Ttrans) introduce_premises let () = wrap_and_register ~desc:"intros id1,id2,...,idk introduces quantified variables and hypotheses using the given identifiers names" "intros" (Tidentlist Ttrans) intros_list why3-1.2.1/src/transform/compute.ml0000644000175100017510000001334613555524575020000 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 Reduction_engine open Args_wrapper 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_attr = Ident.create_attribute "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.Sattr.mem rule_attr pr.pr_name.Ident.id_attrs || Ident.Sattr.mem rule_attr t.t_attrs -> (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_hyp_or_goal ?pr_norm ?step_limit engine : Task.task Trans.tlist = let step_limit = if step_limit = None then Some !compute_max_steps else step_limit in Trans.decl_l (fun d -> match d.d_node with | Dprop (Pgoal, pr, t) when pr_norm = None -> let t = normalize ?step_limit ~limit:!compute_max_steps engine t in begin match t.t_node with | Ttrue -> [] | _ -> let d = Decl.create_prop_decl Pgoal pr t in [[d]] end | Dprop (k, pr, t) when Opt.fold (fun _ -> pr_equal pr) false pr_norm -> let t = normalize ?step_limit:step_limit ~limit:!compute_max_steps engine t in let d = Decl.create_prop_decl k pr t in [[d]] | _ -> [[d]]) None let craft_engine p env prs task = let km = Task.task_known task in collect_rules p env km prs task let collect_rules_trans p env : Reduction_engine.engine Trans.trans = Trans.on_tagged_pr meta_rewrite (fun prs -> if p.compute_defs then Trans.store (craft_engine p env prs) else Trans.on_tagged_ls meta_rewrite_def (fun lss -> let p = { p with compute_def_set = lss } in Trans.store (craft_engine p env prs) )) let normalize_goal_transf ?pr_norm ?step_limit p env : 'a Trans.trans = let tr = collect_rules_trans p env in Trans.on_meta_excl meta_compute_max_steps (function | None -> Trans.bind tr (fun engine -> normalize_hyp_or_goal ?pr_norm ?step_limit engine) | Some [Theory.MAint n] -> compute_max_steps := n; Trans.bind tr (fun engine -> normalize_hyp_or_goal ?pr_norm ?step_limit engine) | _ -> 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" let normalize_hyp step_limit pr_norm env = let p = { compute_defs = true; compute_builtin = true; compute_def_set = Term.Mls.empty; } in normalize_goal_transf ?pr_norm ?step_limit p env let () = wrap_and_register ~desc:"experimental: Takes a prsymbol and reduce \ one \"elementary\" step." "step" (Topt ("in", Tprsymbol Tenvtrans_l)) (normalize_hyp (Some 1)) let () = wrap_and_register ~desc:"experimental: Same as step except that it \ reduces the given number of steps." "steps" (Tint (Topt ("in", Tprsymbol Tenvtrans_l))) (fun n -> normalize_hyp (Some n)) let () = wrap_and_register ~desc:"Performs@ possible@ computations@ in@ given \ hypothesis@ including@ by@ declared@ rewrite@ rules" "compute_hyp" (Topt ("in", Tprsymbol Tenvtrans_l)) (normalize_hyp None) let normalize_hyp_few step_limit pr_norm env = let p = { compute_defs = false; compute_builtin = true; compute_def_set = Term.Mls.empty; } in normalize_goal_transf ?pr_norm ?step_limit p env let () = wrap_and_register ~desc:"Performs@ possible@ computations@ in@ given \ hypothesis@ using@ specified@ rules" "compute_hyp_specified" (Topt ("in", Tprsymbol Tenvtrans_l)) (normalize_hyp_few None) why3-1.2.1/src/transform/eliminate_literal.ml0000644000175100017510000002160513555524575022004 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 = ir.Number.ir_lower in let hi = 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_bigint_const lo in let b_term = t_bigint_const hi 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 let add_decl t d = try Task.add_decl t d with UnknownIdent _ -> t in (*FIXME*) (known_lit, List.fold_left 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 let m_string = Format.asprintf "%a" (Number.print_in_base 16 None) m in let e_string = Format.asprintf "%a" (Number.print_in_base 10 None) e in let e_val = Number.real_const_hex m_string "" (Some e_string) in let max_term = t_const Number.(ConstReal { rc_negative = false ; rc_abs = e_val }) 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 [op_infix "<="] in let th = Env.read_theory env ["real"] "Real" in let le_real = ns_find_ls th.th_export [op_infix "<="] in let neg_real = ns_find_ls th.th_export [op_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." (* simple transformation that just replace negative constants by application of 'prefix -' to positive constant *) open Number let rec replace_negative_constants neg_int neg_real t = match t.t_ty, t.t_node with | (Some ty), (Tconst (ConstInt c)) -> if c.ic_negative && ty_equal ty ty_int then t_app neg_int [t_const (ConstInt { c with ic_negative = false }) ty_int] (Some ty_int) else t | (Some ty), (Tconst (ConstReal c)) -> if c.rc_negative && ty_equal ty ty_real then t_app neg_real [t_const (ConstReal { c with rc_negative = false }) ty_real] (Some ty_real) else t | _ -> t_map (replace_negative_constants neg_int neg_real) t let eliminate_negative_constants env = (* FIXME: int.Int should be imported in the task *) let th = Env.read_theory env ["int"] "Int" in let neg_int = ns_find_ls th.th_export [op_prefix "-"] in let th = Env.read_theory env ["real"] "Real" in let neg_real = ns_find_ls th.th_export [op_prefix "-"] in Trans.rewrite (replace_negative_constants neg_int neg_real) None let () = Trans.register_env_transform "eliminate_negative_constants" eliminate_negative_constants ~desc:"Eliminate@ negative@ constants" why3-1.2.1/src/transform/discriminate.ml0000644000175100017510000003316613555524575021001 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 Wstdlib 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) = let f = t_ty_subst tvar Mvs.empty f in let f = t_app_map (find_logic env) f in 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_right Sty.add tyl s 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-1.2.1/src/transform/inlining.mli0000644000175100017510000000524113555524575020277 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/eliminate_inductive.mli0000644000175100017510000000153413555524575022512 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/intro_vc_vars_counterexmp.mli0000644000175100017510000000456313555524575024005 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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, attribute "model_trace:*", and either attribute "model" or "model_projected". This means that all variables that should be collected for counterexample will marked by model attributes. If the term triggering VC is postcondition of a function, appends to the attribute "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 attributes ("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-1.2.1/src/transform/smoke_detector.mli0000644000175100017510000000141013555524575021471 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/eliminate_epsilon.ml0000644000175100017510000002250713555524575022023 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 of Ty.ty (* 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 v.vs_ty | 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 ty = 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 let id_canonical = let ht = Ty.Hty.create 3 in fun ty -> try Ty.Hty.find ht ty with Not_found -> let res = id_canonical ty in Ty.Hty.add ht ty res; res let poly_id_canonical = id_canonical (Ty.ty_var (Ty.tv_of_string "a")) 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_attr_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_attr_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 ty -> let ld, ax, cs = if Ty.ty_closed ty then id_canonical ty else poly_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_attr_copy t0 t | Teps _ -> let vl,tr,t = t_open_lambda t0 in let acc, t = lift_f el acc t in let acc, tr = Lists.map_fold_left (Lists.map_fold_left (lift_f el)) acc tr in acc, t_attr_copy t0 (t_lambda vl tr 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-1.2.1/src/transform/eliminate_if.ml0000644000175100017510000001336113555524575020746 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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_attr_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_t_eps t = match t.t_node with | Tif (f,t1,t2) when t.t_ty <> None -> let z = create_vsymbol (id_fresh "if_term") (t_type t) in let tz = t_var z in let f = elim_f (fun f -> f) f in let f1 = t_equ tz (elim_t_eps t1) in let f2 = t_equ tz (elim_t_eps t2) in t_attr_copy t (t_eps_close z (t_if f f1 f2)) | _ -> TermTF.t_map elim_t_eps (elim_f (fun f -> f)) t and elim_f contF f = match f.t_node with | Tapp _ -> contF (TermTF.t_map_cont elim_t elim_f (fun f -> f) f) | Tlet _ | Tcase _ -> contF (TermTF.t_map elim_t_eps (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-1.2.1/src/transform/detect_polymorphism.mli0000644000175100017510000000136513555524575022565 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/smoke_detector.ml0000644000175100017510000000367713555524575021341 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/abstraction.mli0000644000175100017510000000227113555524575021001 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/detect_polymorphism.ml0000644000175100017510000001061413555524575022411 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 <> [] && ts.Ty.ts_def = Ty.NoDef && 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 "|sts|=%d |sls|=%d |spr|=%d@." (Ty.Sts.cardinal ign_ts) (Term.Sls.cardinal ign_ls) (Spr.cardinal ign_pr); Debug.dprintf debug "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 "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: DO NOT TEST the goal. This requires skolemizing type variables in the goal _before_ eliminate_epsilon in the transformation chain, to avoid producing polymorphic identities in monomorphic tasks *) 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-1.2.1/src/transform/simplify_array.ml0000644000175100017510000000271213555524575021351 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/prop_curry.ml0000644000175100017510000000233213555524575020521 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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_attr_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-1.2.1/src/transform/compute.mli0000644000175100017510000000216213555524575020143 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 val normalize_goal_transf_all : Env.env -> Task.task Trans.tlist val normalize_goal_transf_few : Env.env -> Task.task Trans.tlist val normalize_hyp : int option -> Decl.prsymbol option -> Env.env -> Task.task Trans.tlist val normalize_hyp_few : int option -> Decl.prsymbol option -> Env.env -> Task.task Trans.tlist why3-1.2.1/src/transform/ind_itp.ml0000644000175100017510000002624613555524575017755 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 Generic_arg_trans_utils open Args_wrapper (** This file contains the transformation with arguments 'induction on integer' *) (** Explanation *) (* Explanation for induction base goal of induction tactic *) let base_case_expl = "base case" (* Explanation for recursive case *) let rec_case_expl = "recursive case" (* Documentation of induction: From task [delta, x: int, delta'(x) |- G(x)], variable x and term bound, builds the tasks: [delta, x: int, x <= bound, delta'(x) |- G(x)] and [delta, x: int, x > bound, (forall n, n < x -> delta'(n) -> G(n)), delta'(x) |- G(x)] x cannot occur in delta as it can only appear after its declaration (by construction of the task). Also, G is not part of delta'. In practice we are "chosing" delta'. The minimal set delta' such that this transformation is correct is Min_d = {H | x *directly* appears in H} € delta'. (1) Adding any declarations to delta' should be safe(2). In practice, we define delta' iterately beginning with the goal (upward) and adding any hypothesis that contains symbols defined in a set S. Algorithm used: S : symbol set = {x} union {symbol_appearing_in goal} delta' : list decl = {} For decl from goal to x_declaration do if ((symbol_appearing_in decl) intersect S) != {} then add decl to delta' add (symbol_appearing_in decl) to S else () done (1) One may be convinced of this because it is possible to make a lemma of the form "forall x: int. Min_d(x) -> G(x)" with appropriate abstract constant symbol for every other constant (added in the context). One can then apply an induction on this reduced example and apply this lemma on the initial case. (This is an argument for the "reduction of context stuff" not a claim that the induction is correct) (2) If it does not talk about x, we will have to prove it (unchanged) to be able to use it in the recursive part. So it should not change the provability. *) let is_good_type t ty = try (Term.t_ty_check t (Some ty); true) with | _ -> false (* Reverts a declaration d to a goal g *) let revert g d : Term.term = match d.d_node with | Dtype _ -> raise (Arg_trans "revert: cannot revert type") | Ddata _ -> raise (Arg_trans "revert: cannot revert type") | Dparam ls -> (try let new_ident = Ident.id_fresh ls.ls_name.Ident.id_string in let new_var = Term.create_vsymbol new_ident (Opt.get ls.Term.ls_value) in let g = t_replace (t_app_infer ls []) (t_var new_var) g in t_forall_close [new_var] [] g with | _ -> raise (Arg_trans ("revert: cannot revert:" ^ ls.ls_name.Ident.id_string))) (* TODO extend this *) | Dlogic _ -> raise (Arg_trans "revert: cannot revert logic decls") | Dind _ -> raise (Arg_trans "revert: cannot revert induction decls") | Dprop (k, _pr, t) when k <> Pgoal -> Term.t_implies t g | Dprop (Pgoal, _, _) -> raise (Arg_trans "revert: cannot revert goal") | _ -> raise (Arg_trans "revert: please report") (* Transformation to use fold_map only on declarations. *) let fold_map f init = Trans.fold_map (fun thd (acc, task) -> match thd.Task.task_decl.Theory.td_node with | Theory.Use _ | Theory.Clone _ | Theory.Meta _ -> (acc, Task.add_tdecl task thd.Task.task_decl) | Theory.Decl d -> f d (acc, task)) init None (* Takes a list of prop l and a goal g and reverts the list of prop to the goal g *) let revert_list (l: decl list) g = List.fold_left revert g l (* Go through a term and collect constants *) let add_ls_term s t = let rec my_fold s t = match t.t_node with | Tapp (ls, []) -> Sls.add ls s | _ -> Term.t_fold my_fold s t in my_fold s t let add_lsymbol s (ls_def: Decl.ls_defn) = let _vsl, t = Decl.open_ls_defn ls_def in add_ls_term s t (* This collects the constant lsymbols appearing in a decl. It is useful to have dependencies during induction. We want to generalize all decls that contain some lsymbols (the one which appears in the goal or the symbol on which we do the induction. *) let collect_lsymbol s (d: decl) = match d.d_node with | Dtype _ | Ddata _ -> (* can be ignored. TODO to check. *) s | Dparam ls -> Sls.add ls s | Dlogic logic_list -> List.fold_left (fun s (ls, ls_def) -> add_lsymbol (Sls.add ls s) ls_def) s logic_list | Dind (_sign, ind_list) -> List.fold_left (fun s (ls, pr_term_list) -> let s = Sls.add ls s in List.fold_left (fun s (_pr, t) -> add_ls_term s t) s pr_term_list) s ind_list | Dprop (_k, _pr, t) -> add_ls_term s t (* [depends dep d]: returns true if there is a constant that is both in dep and used in the declaration d. *) let depends dep d = let new_set = collect_lsymbol Sls.empty d in if Sls.equal (Sls.inter dep new_set) Sls.empty then false else true (* TODO Do a transformation as a fold that reverts automatically dependencies but that could be used elsewhere instead of all those adhoc functions. *) let revert_tr prlist lslist = fold_map (fun d ((acc, dep), task) -> match d.d_node with | Dparam ls when (depends dep d || List.exists (fun ls1 -> ls_equal ls ls1) lslist) -> ((d :: acc, Sls.add ls dep), task) | Dprop (k, pr1, _) when k != Pgoal && (depends dep d || List.exists (fun pr -> pr_equal pr pr1) prlist) -> ((d :: acc, dep), task) | Dprop (k, pr1, g) when k = Pgoal -> begin match acc with | [] -> raise (Arg_trans "prsymbol not found") | drevlist -> let new_goal = Decl.create_prop_decl k pr1 (revert_list drevlist g) in (([], Sls.empty), Task.add_decl task new_goal) end | _ -> ((acc, dep), Task.add_decl task d) ) ([], Sls.empty) let revert_tr_symbol symbol_list = (* Order does not matter *) let rec convert_list pr_acc ls_acc symbollist = match symbollist with | [] -> (pr_acc, ls_acc) | Tsprsymbol pr :: tl -> convert_list (pr :: pr_acc) ls_acc tl | Tslsymbol ls :: tl -> convert_list pr_acc (ls :: ls_acc) tl | Tstysymbol _ :: _tl -> raise (Arg_trans "Tysymbol should not appear here. Please report") in let (prlist, lslist) = convert_list [] [] symbol_list in revert_tr prlist lslist (* s is a set of variables, g is a term. If d contains one of the elements of s then all variables of d are added to s and the declaration is prepended to g. *) let revert_chosen_decls (g, s) (d: decl) = let d_set = collect_lsymbol Sls.empty d in let interp = Sls.inter s d_set in if Sls.equal interp Sls.empty then (g, s) else (revert g d, Sls.union s d_set) (* Build a term that generalizes all the declarations that were given in l and that contains at least one of the variables in the set s. Actually, only revert what is necessary to build a correct term. *) let revert_chosen_decls_list s (l: decl list) (g: decl) (t: term) = (* The goal is a special case, we collect its variable independantly *) let s = collect_lsymbol s g in fst (List.fold_left revert_chosen_decls (t, s) l) let induction x bound env = (* Default bound is 0 if not given *) let bound = match bound with | None -> Term.t_nat_const 0 | Some bound -> bound in (* Checking the type of the argument of the tactic *) if (not (is_good_type x Ty.ty_int) || not (is_good_type bound Ty.ty_int)) then raise (Arg_trans "induction"); (* Loading of needed symbols from int theory *) let th = Env.read_theory env ["int"] "Int" in let le_int = Theory.ns_find_ls th.Theory.th_export [Ident.op_infix "<="] in let lt_int = Theory.ns_find_ls th.Theory.th_export [Ident.op_infix "<"] in (* Symbol associated to term x *) let lsx = match x.t_node with | Tapp (lsx, []) -> lsx | _ -> raise (Arg_trans "induction") in (* Transformation used for the init case *) let init_trans = Trans.decl (fun d -> match d.d_node with | Dprop (Pgoal, pr, t) -> let nt = Term.t_app_infer le_int [x; bound] in let d = create_goal ~expl:base_case_expl pr t in let pr_init = create_prop_decl Paxiom (Decl.create_prsymbol (gen_ident "Init")) nt in [pr_init; d] | _ -> [d]) None in (* Transformation used for the recursive case *) let rec_trans = let x_is_passed = ref false in let delta' = ref [] in Trans.decl (fun d -> match d.d_node with | Dparam ls when (Term.ls_equal lsx ls) -> (x_is_passed := true; [d]) | Dprop (Pgoal, pr, t) -> if not (!x_is_passed) then raise (Arg_trans "induction") else let t_delta' = revert_chosen_decls_list (Sls.add lsx Sls.empty) !delta' d t in let n = Term.create_vsymbol (Ident.id_fresh "n") Ty.ty_int in (* t_delta' = forall n, n < x -> t_delta'[x <- n] *) let t_delta' = t_forall_close [n] [] (t_implies (Term.t_app_infer lt_int [t_var n; x]) (t_replace x (t_var n) t_delta')) in (* x_gt_bound = bound < x *) let x_gt_bound_t = t_app_infer lt_int [bound; x] in let x_gt_bound = create_prop_decl Paxiom (Decl.create_prsymbol (gen_ident "Init")) x_gt_bound_t in let rec_pr = create_prsymbol (gen_ident "Hrec") in let hrec = create_prop_decl Paxiom rec_pr t_delta' in let d = create_goal ~expl:rec_case_expl pr t in [x_gt_bound; hrec; d] | Dprop (_p, _pr, _t) -> if !x_is_passed then begin delta' := d :: !delta'; (* d [x <- x] *) [d] end else [d] | Dind _ | Dlogic _ | Dtype _ | Ddata _ -> if !x_is_passed then raise (Arg_trans "induction Dlogic") (* TODO we need to add Dlogic and Dind here. The problem is that we cannot easily put them into the recursive hypothesis. So, for now, we do not allow them. If x does not occur in the Dlogic/Dind, a workaround is to use the "sort" tactic. *) else [d] | Dparam _ls -> if !x_is_passed then begin delta' := d :: !delta'; [d] end else [d] ) None in Trans.par [init_trans; rec_trans] let () = wrap_and_register ~desc:"induction [from] performs a strong induction on int term1 from int term2. term2 is optional and default to 0." "induction" (Tterm (Topt ("from", Tterm Tenvtrans_l))) induction let () = wrap_and_register ~desc:"revert puts list back in the goal." "revert" (Tlist Ttrans) revert_tr_symbol why3-1.2.1/src/transform/eliminate_definition.ml0000644000175100017510000002715313555524575022504 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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." (***** {2 Bisection} ********) open Task open Theory type rem = { rem_pr : Spr.t; rem_ls : Sls.t; rem_ts : Sts.t } type bisect_step = | BSdone of rem | BSstep of rem * (bool -> bisect_step) 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 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 (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 rem) (* let bisect f task = let rec run = function | BSdone r -> r | BSstep (rem,c) -> let t = elim_task task rem in 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-1.2.1/src/transform/destruct.mli0000644000175100017510000000214313555524575020323 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 destruct: recursive:bool -> Decl.prsymbol -> Task.task Trans.tlist (** [destruct ~recursive H]: On an axiom, destruct the head term of an hypothesis if it is either conjunction, disjunction or exists. If [recursive] is true, the term is recursively traversed which lead to more splitting. Efficiency: This is not optimized to be used on very big/deep disjunctions/conjunctions mixed. *) why3-1.2.1/src/transform/matching.ml0000644000175100017510000012570513555524575020121 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 exception NoMatch of term * term (* Utility to remove bool/prop coercions. (matching is done modulo those) *) let rec remove_bp = function | {t_node = Tapp(ls,[t;tt])} when ls_equal ls ps_equ && t_equal_nt_na tt t_bool_true -> remove_bp t | {t_node = Tif (t,tt,tf)} when t_equal_nt_na tt t_bool_true && t_equal_nt_na tf t_bool_false -> remove_bp t | t -> t (* Term matching: Find an extension of the type+term substitution [mty,mv] such that [tp[mty,mv]=tm] and such that the extension does not pick terms with free variables in [bnd]. Fail if the extension does not exists. [bnd] is used internally to prevent matching from selecting terms with variables bound to an inner quantifier. *) let rec matching bnd mty mv tp tm = let fail () = raise (NoMatch (tp,tm)) in let tp, tm = remove_bp tp, remove_bp tm in match tp.t_node, tm.t_node with | Tvar vp, _ -> (* Cast prop to bool as variable must be bool-typed. *) let tmf = match tm.t_ty with | Some _ -> tm | None -> t_if tm t_bool_true t_bool_false in begin match Mvs.find vp mv with (* FIXME? If term have distinct attributes/triggers, only the attributes/triggers coming from the first match are kept. *) | tb -> if t_equal_nt_na (remove_bp tb) tm then mty, mv else fail () | exception Not_found -> match oty_match mty tp.t_ty tmf.t_ty with | mty -> if Mvs.set_disjoint bnd (t_vars tm) then mty, Mvs.add vp tmf mv else fail () | exception TypeMismatch _ -> fail () end | (Tconst _ | Ttrue | Tfalse), _ when t_equal_nt_na tp tm -> mty, mv | Tapp (lsp,lp), Tapp (lsm,lm) when ls_equal lsp lsm -> let mty = try oty_match mty tp.t_ty tm.t_ty with TypeMismatch _ -> fail () in List.fold_left2 (fun (mty,mv) tp tm -> matching bnd mty mv tp tm) (mty,mv) lp lm | Tif (tpb,tpt,tpe), Tif (tmb,tmt,tme) -> let mty, mv = matching bnd mty mv tpb tmb in let mty, mv = matching bnd mty mv tpt tmt in matching bnd mty mv tpe tme | Tbinop (bp,tp_l,tp_r), Tbinop (bm,tm_l,tm_r) when bp = bm -> let mty, mc = matching bnd mty mv tp_l tm_l in matching bnd mty mc tp_r tm_r | Tnot tp, Tnot tm -> matching bnd mty mv tp tm | Tlet (tpd,tpv), Tlet (tmd,tmv) -> let mty, mv = matching bnd mty mv tpd tmd in let vsp, tpv = t_open_bound tpv in let vsm, tmv = t_open_bound tmv in let mty, mv = matching (Svs.add vsm bnd) mty (Mvs.add vsp (t_var vsm) mv) tpv tmv in mty, Mvs.remove vsp mv | Tcase (tps,lbrp), Tcase (tms,lbrm) -> let mty, mv = matching bnd mty mv tps tms in let rec pat_matching bnd mv pp pm = match pp.pat_node, pm.pat_node with | Pwild, Pwild -> bnd, mv | Pvar vsp, Pvar vsm -> Svs.add vsm bnd, Mvs.add vsp (t_var vsm) mv | Papp (lsp,lpp), Papp (lsm,lpm) when ls_equal lsp lsm -> List.fold_left2 (fun (bnd,mv) pp pm -> pat_matching bnd mv pp pm) (bnd,mv) lpp lpm | Por (pp_l,pp_r), Por (pm_l,pm_r) -> let bnd, mv = pat_matching bnd mv pp_l pm_l in pat_matching bnd mv pp_r pm_r | Pas (pp,vsp), Pas (pm,vsm) -> pat_matching (Svs.add vsm bnd) (Mvs.add vsp (t_var vsm) mv) pp pm | _ -> fail () in let fn (mty,mv) brp brm = let pp, tp = t_open_branch brp in let pm, tm = t_open_branch brm in let bnd, mv = pat_matching bnd mv pp pm in let mty, mv = matching bnd mty mv tp tm in mty, Svs.fold Mvs.remove pp.pat_vars mv in List.fold_left2 fn (mty,mv) lbrp lbrm | Teps tpb, Teps tmb -> let vsp, tpb = t_open_bound tpb in let vsm, tmb = t_open_bound tmb in let mty = try ty_match mty vsp.vs_ty vsm.vs_ty with TypeMismatch _ -> fail () in let mty, mv = matching (Svs.add vsm bnd) mty (Mvs.add vsp (t_var vsm) mv) tpb tmb in mty, Mvs.remove vsp mv | Tquant (qp,tpq), Tquant (qm,tmq) when qp = qm -> let vlp, _, tpq = t_open_quant tpq in let vlm, _, tmq = t_open_quant tmq in let bnd, mty, mv = try List.fold_left2 (fun (bnd,mty,mv) vsp vsm -> let mty = ty_match mty vsp.vs_ty vsm.vs_ty in Svs.add vsm bnd, mty, Mvs.add vsp (t_var vsm) mv) (bnd,mty,mv) vlp vlm with Invalid_argument _ | TypeMismatch _ -> fail () in let mty, mv = matching bnd mty mv tpq tmq in mty, List.fold_left (fun mv vsp -> Mvs.remove vsp mv) mv vlp | _ -> fail () (* Root term matching: [bnd] empty. *) let matching mty mv tp tm = matching Svs.empty mty mv tp tm (* From now on: compiled matching. Provide a mean to convert term patterns into matching scripts. Also provide a mean to group matching scripts as scripts matching multiple patterns at once. The grouping script may be more efficient than running the scripts one-by-one, as common prefixes of the matching scripts are all executed as the same time. *) (* Term constructions on which matching scripts may switch: If several matching scripts choose to test different constructions, the correct one is found before resuming the execution of the corresponding scripts. *) type construction = | Crigid of vsymbol | Cbound of int | Cconst of term | Capp of lsymbol | Cif | Clet | Ccase of int | Ceps | Cquant of quant * int | Cbinop of binop | Cnot module C = struct type t = construction let compare t1 t2 = let (--) = Pervasives.compare in match t1, t2 with | Crigid vs1, Crigid vs2 -> vs_compare vs1 vs2 | Cbound n1, Cbound n2 | Ccase n1, Ccase n2 -> n1 -- n2 | Cconst t1, Cconst t2 -> (* FIXME? is there a better way to achieve attribute-independent comparison ? (Note that terms are not nested here, so that code actually works) *) t_compare (t_attr_set Sattr.empty t1) (t_attr_set Sattr.empty t2) | Capp ls1, Capp ls2 -> ls_compare ls1 ls2 | Cquant (q1,n1), Cquant (q2,n2) -> let c = q1 -- q2 in if c <> 0 then c else n1 -- n2 | Cbinop b1, Cbinop b2 -> b1 -- b2 | Cif, Cif | Clet, Clet | Ceps, Ceps | Cnot, Cnot -> 0 | Crigid _, _ -> -1 | _, Crigid _ -> 1 | Cbound _, _ -> -1 | _, Cbound _ -> 1 | Cconst _, _ -> -1 | _, Cconst _ -> 1 | Capp _, _ -> -1 | _, Capp _ -> 1 | Cif, _ -> -1 | _, Cif -> 1 | Clet, _ -> -1 | _, Clet -> 1 | Ccase _, _ -> -1 | _, Ccase _ -> 1 | Ceps, _ -> -1 | _, Ceps -> 1 | Cquant _, _ -> -1 | _, Cquant _ -> 1 | Cbinop _, _ -> -1 | _, Cbinop _ -> 1 end module MC = Extmap.Make(C) (* Same construction for types (type matching can be necessary) *) type ty_construction = | TyCrigid of tvsymbol | TyCapp of tysymbol module Cty = struct type t = ty_construction let compare ty1 ty2 = match ty1, ty2 with | TyCrigid tv1, TyCrigid tv2 -> tv_compare tv1 tv2 | TyCapp ts1, TyCapp ts2 -> ts_compare ts1 ts2 | TyCrigid _, _ -> -1 | _, TyCrigid _ -> 1 end module MCty = Extmap.Make(Cty) (* Same construction for patterns *) type pat_construction = | PatCwild | PatCvar | PatCapp of lsymbol | PatCor | PatCas module Cpat = struct type t = pat_construction let compare p1 p2 = match p1, p2 with | PatCapp ls1, PatCapp ls2 -> ls_compare ls1 ls2 | PatCwild, PatCwild | PatCvar, PatCvar | PatCor, PatCor | PatCas, PatCas -> 0 | PatCwild, _ -> -1 | _, PatCwild -> 1 | PatCvar, _ -> -1 | _, PatCvar -> 1 | PatCapp _, _ -> -1 | _, PatCapp _ -> 1 | PatCor, _ -> -1 | _, PatCor -> 1 end module MCpat = Extmap.Make(Cpat) (* Instructions of matching scripts, operating on matching state (defined later because it contains the remaining instructions). type ['i] is int list for practical purposes, but is a different type during compilation of patterns. The list represents: . For pattern constructions: variables, constants, applications, and epsilons, it may be [0] or []. The first say that type should be stored when term is analysed, the second say it should not. . For quantifier pattern: it gives the list of positions (starting from 0) of variables whose types should be stored when quantifier is analyzed. . For type applications patterns: it gives the list of positions (starting from 0) of type arguments which should be stored when type application is analyzed. In other cases, it must be [] (types in other term positions are entirely determined by those at those chosen locations) *) type 'i instruction = (* Pop term at top of term stack and check it against the given construction. If successful, push the fragment on the term stack in the order they are found in the term, and push the types references by the ['i] argument to type stack if pertinent. *) | Fragment of 'i * construction (* Transfer term at top of term stack to the match stack. Push its types to type stack if ['i] says so. *) | Store of 'i (* Analog of [Fragment] for pattern stack. Types never need to be stored as they are determined from the case-construction from which the pattern comes from. *) | FragmentPat of pat_construction (* Analog of [Fragment] for type stack, except only the types selected by the ['i] arguments are pushed. *) | FragmentTy of 'i * ty_construction (* Analog of [Store] for types. *) | StoreTv (* Pop the top of match stack, and match it to the given matching variable. If a matching already exists, test for equality. *) | Subst of vsymbol (* Analog of [Subst] for types. *) | SubstTv of tvsymbol (* Check that the matching of given variable does not contains any bound variable. *) | Occurs of vsymbol (* Do nothing. Should not occur in normal proof scripts. This was introduced to represent the first instruction of an empty script, which was pertinent for representing non-deterministic splitting of execution. *) | Nop module IL = struct type t = int list let compare = Pervasives.compare end module MIL = Extmap.Make(IL) (* Note: this module only compare instruction modulo compatibility. *) module Instr = struct type t = int list instruction let compare i1 i2 = match i1, i2 with | Fragment _, Fragment _ -> 0 | FragmentPat _, FragmentPat _ -> 0 | FragmentTy _, FragmentTy _ -> 0 | Store l1, Store l2 -> IL.compare l1 l2 | StoreTv, StoreTv | Nop, Nop -> 0 | (Subst vs1, Subst vs2 | Occurs vs1, Occurs vs2) -> vs_compare vs1 vs2 | SubstTv tv1, SubstTv tv2 -> tv_compare tv1 tv2 | Fragment _, _ -> -1 | _, Fragment _ -> 1 | Store _, _ -> -1 | _, Store _ -> 1 | FragmentPat _, _ -> -1 | _, FragmentPat _ -> 1 | FragmentTy _, _ -> -1 | _, FragmentTy _ -> 1 | StoreTv, _ -> -1 | _, StoreTv -> 1 | Subst _, _ -> -1 | _, Subst _ -> 1 | SubstTv _, _ -> -1 | _, SubstTv _ -> 1 | Occurs _, _ -> -1 | _, Occurs _ -> 1 end module MInstr = Extmap.Make(Instr) (* Type of a matching script where patterns are identified by 'id (the 'id should be comparable, to break ties with the highest-matching pattern) [highest_id] represent the identifiant of the highest-'id pattern that may be matched with this script, [straight_code] the code common for all patterns, and [code_branch] a non-deterministic execution point. *) type 'id code_point = { highest_id : 'id; straight_code : int list instruction list; branch : 'id code_branch; } (* Represent non-deterministic branching in matching scripts. Respectively represents: . Stop: no branching, the scripts merely stops normally and accepts. . Fork: incompatible branching: propose several scripts which starts by incompatible instructions. . Switch[...]: compatible branching. The next scripts starts by compatible instructions, so only one of them may succeed, and it can be identified directly. For the term/types variant, the list of position can represent an immediate incompatibility, which is handled immediately by the second map level. *) and 'id code_branch = | Stop | Fork of 'id code_point MInstr.t | Switch of 'id code_point MIL.t MC.t | SwitchTy of 'id code_point MIL.t MCty.t | SwitchPat of 'id code_point MCpat.t (* State of matching engine. *) type 'id matching_state = { (* Term stack: represent the parts of the original term that have yet to be analyzed.*) mutable term_stack : term list; (* Match stack: represent the parts of the original term that were at the position of a matching variable. *) mutable match_stack : term list; (* Type stack/type match stack: type version. *) mutable ty_stack : ty list; mutable ty_match_stack : ty list; (* Pat stack: pat version. *) mutable pat_stack : pattern list; (* type/term match: found matches. *) mutable type_match : ty Mtv.t; mutable term_match : term Mvs.t; (* Binding levels: [bound_levels] identify bound variables to integers, which identify the moment they were introduced. The levels starts from 0 and are allocated successively, using [bind_level]. *) mutable bind_level : int; mutable bound_levels : int Mvs.t; (* Remaining execution script. *) code_loc : 'id code_point; } (*(* Debug. *) let pp_tc fmt = let (!) s = Format.fprintf fmt s in function | Crigid vs -> !"R %a" Pretty.print_vs vs | Cbound n -> !"B %d" n | Cconst t -> !"C %a" Pretty.print_term t | Capp ls -> !"A %a" Pretty.print_ls ls | Cif -> !"IF" | Clet -> !"LET" | Ccase n -> !"CASE %d" n | Ceps -> !"EPS" | Cquant (q,n) -> !"%a %d" Pretty.print_quant q n | Cbinop b -> !"%a" (Pretty.print_binop ~asym:false) b | Cnot -> !"NOT" let pp_tyc fmt = let (!) s = Format.fprintf fmt s in function | TyCrigid tv -> !"R %a" Pretty.print_tv tv | TyCapp ts -> !"A %a" Pretty.print_ts ts let pp_pat fmt = let (!) s = Format.fprintf fmt s in function | PatCwild -> !"_" | PatCvar -> !"V" | PatCapp ls -> !"A %a" Pretty.print_ls ls | PatCor -> !"|" | PatCas -> !"AS" let pp_instr fmt = let (!) s = Format.fprintf fmt s in let (!!) s fmt = Format.fprintf fmt s in let pl = Pp.print_list Pp.space !!"%d" in function | Fragment (l,c) -> !"FT [%a] [%a]" pl l pp_tc c | Store l -> !"SVS [%a]" pl l | FragmentPat c -> !"FP [%a]" pp_pat c | FragmentTy (l,c) -> !"FTY [%a] [%a]" pl l pp_tyc c | StoreTv -> !"STV" | Subst vs -> !"SuVS %a" Pretty.print_vs vs | SubstTv tv -> !"SuTV %a" Pretty.print_tv tv | Occurs vs -> !"OCC %a" Pretty.print_vs vs | Nop -> !"NOP" let pp_instrs = Pp.print_list Pp.semi pp_instr let rec pp_code ipp fmt cp = Format.fprintf fmt "Id: %a|" ipp cp.highest_id; pp_instrs fmt cp.straight_code; pp_branch ipp fmt cp.branch and pp_branch ipp fmt = let pp_code = pp_code ipp in let (!) s = Format.fprintf fmt s in let (!!) s fmt = Format.fprintf fmt s in let pl = Pp.print_list Pp.space !!"%d" in let pp_mil fmt m = MIL.iter (fun l cp -> !!"[<%a>|%a]" fmt pl l pp_code cp) m in function | Stop -> !"MATCH"; | Fork m -> !"FORK["; MInstr.iter (fun i cp -> !"[<%a>|%a]" pp_instr i pp_code cp) m; !"]" | Switch mc -> !"SWITCH"; MC.iter (fun c mil -> !"[<%a>|FORK[%a]]" pp_tc c pp_mil mil) mc | SwitchTy mc -> !"SWITCHTY"; MCty.iter (fun c mil -> !"[<%a>|FORK[%a]]" pp_tyc c pp_mil mil) mc | SwitchPat mc -> !"SWITCHPAT"; MCpat.iter (fun c cp -> !"[<%a>|%a]" pp_pat c pp_code cp) mc*) (* Utilities to update matching state. *) let ms_bind ms vs = ms.bound_levels <- Mvs.add vs ms.bind_level ms.bound_levels; ms.bind_level <- ms.bind_level + 1 let drop ms f lis locs = let rec aux acc cur lim locs = function | [] -> assert false | el :: lis -> if cur = lim then let acc = f el :: acc in match locs with | [] -> acc | lim :: q -> aux acc (cur+1) lim q lis else aux acc (cur+1) lim locs lis in match locs with | [] -> () | lim :: q -> ms.ty_stack <- aux ms.ty_stack 0 lim q lis let ms_tyl ms tyl locs = drop ms (fun x -> x) tyl locs let ms_quant ms vl tm locs = ms.term_stack <- tm :: ms.term_stack; List.iter (ms_bind ms) vl; drop ms (fun vs -> vs.vs_ty) vl locs let add_dty ms t = function | [] -> () | _ -> ms.ty_stack <- (Opt.get_def ty_bool t.t_ty) :: ms.ty_stack (* Update the matching state by running a single instruction. Returns true if successful, false if the instruction fails. *) let instr ms = function | Fragment (l,c) -> let t = match ms.term_stack with | [] -> assert false | x :: q -> ms.term_stack <- q; remove_bp x in begin match t.t_node, c with | Tvar vsm, Crigid vsp when vs_equal vsm vsp -> add_dty ms t l; true | Tvar vsm, Cbound n -> begin match Mvs.find vsm ms.bound_levels with | m -> n = m && (add_dty ms t l; true) | exception Not_found -> false end | (Tconst _ | Ttrue | Tfalse), Cconst tp when t_equal (t_attr_set Sattr.empty t) (t_attr_set Sattr.empty tp) -> add_dty ms t l; true | Tapp (lsm,tl), Capp lsp when ls_equal lsm lsp -> ms.term_stack <- List.rev_append tl ms.term_stack; add_dty ms t l; true | Tif (tmb,tmt,tme), Cif -> ms.term_stack <- tme :: tmt :: tmb :: ms.term_stack; true | Tlet (tmd,tmb), Clet -> let vsm, tmb = t_open_bound tmb in ms_bind ms vsm; ms.term_stack <- tmb :: tmd :: ms.term_stack; true | Tcase (tcs,brl), Ccase n -> List.length brl = n && begin ms.term_stack <- tcs :: ms.term_stack; let pr br = let pat, tbr = t_open_branch br in ms.term_stack <- tbr :: ms.term_stack; ms.pat_stack <- pat :: ms.pat_stack in List.iter pr brl; true end | Teps tmb, Ceps -> let vsm, tmb = t_open_bound tmb in ms_bind ms vsm; ms.term_stack <- tmb :: ms.term_stack; add_dty ms t l; true | Tquant (qm,tmq), Cquant (qp,np) when qm = qp -> let vl, _, tmq = t_open_quant tmq in List.length vl = np && (ms_quant ms vl tmq l; true) | Tbinop (bm,tml,tmr), Cbinop bp when bm = bp -> ms.term_stack <- tmr :: tml :: ms.term_stack; true | Tnot tm, Cnot -> ms.term_stack <- tm :: ms.term_stack; true | _ -> false end | FragmentPat c -> let p = match ms.pat_stack with | [] -> assert false | x :: q -> ms.pat_stack <- q; x in begin match p.pat_node, c with | Pwild, PatCwild -> true | Pvar vs, PatCvar -> ms_bind ms vs; true | Papp (lsm,pml), PatCapp lsp when ls_equal lsm lsp -> ms.pat_stack <- List.rev_append pml ms.pat_stack; true | Por (pm1,pm2), PatCor -> ms.pat_stack <- pm2 :: pm1 :: ms.pat_stack; true | Pas (pm,vs), PatCas -> ms_bind ms vs; ms.pat_stack <- pm :: ms.pat_stack; true | _ -> false end | FragmentTy (l,c) -> let ty = match ms.ty_stack with | [] -> assert false | x :: q -> ms.ty_stack <- q; x in begin match ty.ty_node, c with | Tyvar tvm, TyCrigid tvp when tv_equal tvm tvp -> true | Tyapp (tsm,tyl), TyCapp tsp when ts_equal tsm tsp -> ms_tyl ms tyl l; true | _ -> false end | Store l -> let t = match ms.term_stack with | [] -> assert false | x :: q -> ms.term_stack <- q; remove_bp x in ms.match_stack <- t :: ms.match_stack; add_dty ms t l; true | StoreTv -> let ty = match ms.ty_stack with | [] -> assert false | x :: q -> ms.ty_stack <- q; x in ms.ty_match_stack <- ty :: ms.ty_match_stack; true | Subst vs -> let t = match ms.match_stack with | [] -> assert false | x :: q -> ms.match_stack <- q; x in let t = match t.t_ty with | Some _ -> t | None -> t_if t t_bool_true t_bool_false in begin match Mvs.find vs ms.term_match with | t0 -> t_equal_nt_na t t0 | exception Not_found -> ms.term_match <- Mvs.add vs t ms.term_match; true end | SubstTv tv -> let ty = match ms.ty_match_stack with | [] -> assert false | x :: q -> ms.ty_match_stack <- q; x in begin match Mtv.find tv ms.type_match with | ty0 -> ty_equal ty ty0 | exception Not_found -> ms.type_match <- Mtv.add tv ty ms.type_match; true end | Occurs vs -> let t = Mvs.find vs ms.term_match in Mvs.set_disjoint ms.bound_levels (t_vars t) | Nop -> true (* Lifting to instruction sequences. *) let rec instrs ms = function | [] -> true | x :: q -> instr ms x && instrs ms q (* Full execution of a matching script. *) let run_match (type i) icmp cp mty mv t = let origin = { term_stack = [t]; match_stack = []; ty_stack = []; ty_match_stack = []; pat_stack = []; type_match = mty; term_match = mv; bind_level = 0; bound_levels = Mvs.empty; code_loc = cp } in let module MS = struct let dummy = origin type t = i matching_state let compare t1 t2 = icmp t2.code_loc.highest_id t1.code_loc.highest_id end in let module HMS = Pqueue.Make(MS) in let h = HMS.create () in HMS.insert origin h; let rec run () = match HMS.extract_min_exn h with | ms -> if instrs ms ms.code_loc.straight_code then match ms.code_loc.branch with | Stop -> Some (ms.code_loc.highest_id,ms.type_match,ms.term_match) | Fork cm -> MInstr.iter (fun _ cp -> HMS.insert {ms with code_loc = cp} h) cm; run () | Switch mp -> let t = match ms.term_stack with | [] -> assert false | x :: _ -> remove_bp x in let c = match t.t_node with | Tvar vs -> begin match Mvs.find vs ms.bound_levels with | n -> Cbound n | exception Not_found -> Crigid vs end | (Tconst _ | Ttrue | Tfalse) -> Cconst t | Tapp (ls,_) -> Capp ls | Tif _ -> Cif | Tlet _ -> Clet | Tcase (_,tbr) -> Ccase (List.length tbr) | Teps _ -> Ceps | Tquant (q,tq) -> let vl, _, _ = t_open_quant tq in Cquant (q,List.length vl) | Tbinop (bp,_,_) -> Cbinop bp | Tnot _ -> Cnot in begin match MC.find c mp with | mil -> MIL.iter (fun l cp -> let ms = {ms with code_loc = cp} in if instr ms (Fragment (l,c)) then HMS.insert ms h) mil | exception Not_found -> () end; run () | SwitchTy mp -> let ty = match ms.ty_stack with [] -> assert false | x :: _ -> x in let c = match ty.ty_node with | Tyvar tv -> TyCrigid tv | Tyapp (ts,_) -> TyCapp ts in begin match MCty.find c mp with | mil -> MIL.iter (fun l cp -> let ms = {ms with code_loc = cp} in if instr ms (FragmentTy (l,c)) then HMS.insert ms h) mil | exception Not_found -> () end; run () | SwitchPat mp -> let p = match ms.pat_stack with [] -> assert false | x :: _ -> x in let c = match p.pat_node with | Pwild -> PatCwild | Papp (ls,_) -> PatCapp ls | Por _ -> PatCor | Pas _ -> PatCas | Pvar _ -> PatCvar in begin match MCpat.find c mp with | cp -> if instr ms (FragmentPat c) then HMS.insert {ms with code_loc = cp} h | exception Not_found -> () end; run () else run () | exception HMS.Empty -> None in run () (* Utilities for joining matching scripts. *) (* Default instructions to represent switches. *) let _fragment = Fragment ([],Cif) let _fragment_ty = FragmentTy ([],TyCapp ts_int) let _fragment_pat = FragmentPat PatCwild let id_branch b = match b with | Stop -> Nop | Fork _ -> assert false | Switch _ -> _fragment | SwitchTy _ -> _fragment_ty | SwitchPat _ -> _fragment_pat (* Lifting fragmentation instruction as switch maps. *) let sw_fragment l tc c = MC.singleton tc (MIL.singleton l c) let sw_fragment_ty l tyc c = MCty.singleton tyc (MIL.singleton l c) let sw_fragment_pat pc c = MCpat.singleton pc c (* Join two matching codes as one, matching the reunion of the patterns associated to both codes. *) let join_code_points icmp c1 c2 = let (^) c l = { c with straight_code = l } in let (><) i c = MInstr.singleton i c in let (!!) c = id_branch c.branch> + merge c1 c2 | [], ((i::q) as s) -> + move_in c1 i q (c2^s) | (i::q) as s, [] -> + move_in c2 i q (c1^s) | i1 :: q1, i2 :: q2 -> let r () = zip (i1::acc) q1 q2 in match i1, i2 with | Fragment (l1,tc1), Fragment (l2,tc2) -> if C.compare tc1 tc2 = 0 && IL.compare l1 l2 = 0 then r () else + Switch (merge_s (sw_fragment l1 tc1 (c1^q1)) (sw_fragment l2 tc2 (c2^q2))) | FragmentTy (l1,tyc1), FragmentTy (l2,tyc2) -> if Cty.compare tyc1 tyc2 = 0 && IL.compare l1 l2 = 0 then r () else + SwitchTy (merge_sty (sw_fragment_ty l1 tyc1 (c1^q1)) (sw_fragment_ty l2 tyc2 (c2^q2))) | FragmentPat pc1, FragmentPat pc2 -> if Cpat.compare pc1 pc2 = 0 then r () else + SwitchPat (merge_spat (sw_fragment_pat pc1 (c1^q1)) (sw_fragment_pat pc2 (c2^q2))) | Store l1, Store l2 when IL.compare l1 l2 = 0 -> r () | StoreTv, StoreTv | Nop, Nop -> r () | (Subst vs1, Subst vs2 | Occurs vs1, Occurs vs2) when vs_equal vs1 vs2 -> r () | SubstTv tv1, SubstTv tv2 when tv_equal tv1 tv2 -> r () | _ -> + Fork (merge_fork (i1> Fork (merge_fork m (i> Switch (merge_s mp (sw_fragment l tc (c2^tl))) | SwitchTy mp, FragmentTy (l,tyc) -> SwitchTy (merge_sty mp (sw_fragment_ty l tyc (c2^tl))) | SwitchPat mp, FragmentPat pc -> SwitchPat (merge_spat mp (sw_fragment_pat pc (c2^tl))) | _, _ -> Fork (merge_fork !!c1 (i> Stop | Switch m1, Switch m2 -> Switch (merge_s m1 m2) | SwitchTy m1, SwitchTy m2 -> SwitchTy (merge_sty m1 m2) | SwitchPat m1, SwitchPat m2 -> SwitchPat (merge_spat m1 m2) | Fork m1, Fork m2 -> Fork (merge_fork m1 m2) | Fork m1, _ -> Fork (merge_fork m1 !!c2) | _, Fork m2 -> Fork (merge_fork !!c1 m2) | _, _ -> Fork (merge_fork !!c1 !!c2) and merge_s m1 m2 = MC.union jn m1 m2 and merge_sty m1 m2 = MCty.union jn m1 m2 and merge_spat m1 m2 = MCpat.union jn0 m1 m2 and merge_fork m1 m2 = MInstr.union jn0 m1 m2 and jn0 : 'a. 'a -> 'b -> 'b -> 'b option = fun _ c1 c2 -> Some (join c1 c2) and jn : 'a. 'a -> 'c -> 'c -> 'c option = fun _ mi1 mi2 -> Some (MIL.union jn0 mi1 mi2) in join c1 c2 (* Next: effective compilation of term patterns. *) (* Specific storage of types for matching compilation: graph equipped with an union-find structure to represent known identities, derived from the signature of operators. (ex: if we perform matching on constructor "identity" of type 'a -> 'a, then we can derive than the input and output type are equal. In particular, it is not necessary to perform checks on both) We also store whether the structure of a type node has already been established by the signature (example: if we match over "Nil" of type list 'a, then there is no need to check that the type is indeed list later, since it must be by typing) The most important function in this module is [collect], which collect those informations from a type signature. *) module TyG = struct type ty_vertex = ty_vertex_content ref and ty_vertex_content = | Link of ty_vertex | Root of int * bool * ty_g_node and ty_g_node = | TyVvar of tvsymbol | TyVapp of tysymbol * ty_vertex list (* Create a cascade of cells representing a type. *) let rec create ty = let fresh tyn = ref (Root (0,false,tyn)) in match ty.ty_node with | Tyvar tv -> fresh (TyVvar tv) | Tyapp (ts,tyl) -> fresh (TyVapp (ts,List.map create tyl)) (* Find in union-find. *) let find a = match !a with | Link b -> let rec finda a b = match !b with | Link c -> let r = finda b c in a := Link r; r | Root _ -> b in finda a b | Root _ -> a (* 'unify' the types represented by two cascade of cells, in the sense that sub-cells are identified. This function suppose that the types were already identified as equals by other means (like a typing invariant) *) let rec unify a b = let a, b = find a, find b in if a != b then match !a, !b with | Root (ra,ka,na), Root (rb,kb,nb) -> if ra < rb then begin a := Link b; b := Root (rb,ka||kb,nb); end else begin b := Link a; let ra = if ra = rb then ra + 1 else ra in a := Root (ra,ka||kb,na); end; begin match na, nb with | TyVapp (_, la), TyVapp (_,lb) -> List.iter2 unify la lb | _ -> () end | _ -> assert false (* Given: . [ty] a type . [rigid_tv] a collection of type variables that are rigid in [ty]'s context, equivalently that should be treated as type symbols in the context of [ty] . [reference] a partial map from non-rigid type variables in [ty]'s context to a "canonical" cell that was matched to that variable . [a] a specific representation of a type that can match [ty] for some extension of [reference] mark all the "rigid" cells of a that occurs in ty as known, and extends the reference by the cells that occurs in a for that variables. In case multiple choices are found for a given variable, unify all those choices (including previously present mapping if applicable). *) let rec collect rigid_tv reference ty a = let a = find a in match ty.ty_node, !a with | Tyvar tv, _ when not (Mtv.mem tv rigid_tv) -> begin match Mtv.find tv reference with | b -> unify b a; reference | exception Not_found -> Mtv.add tv a reference end | Tyvar _, Root (ra,_,na) -> a := Root (ra,true,na); reference | Tyapp (_,tyl), Root (ra,_,(TyVapp (_,tyl2) as na)) -> a := Root (ra,true,na); List.fold_left2 (fun reference ty a -> collect rigid_tv reference ty a) reference tyl tyl2 | _ -> assert false end (* Compile a term [tp] as a pattern, for term/type variables not occuring in [rigid_tv]/[rigid_vs]. Those lasts are treated as if they were logical/type symbols in current context. *) let compile rigid_tv rigid_vs tp = (* [code]: accumulate in reverse order the code for matching [tp]. *) let code = ref [] in let emit i = code := i :: !code in (* [ty_roots]: accumulate the type graphs in the order they will be found in the matching state after purely structural matching on the term structure of [tp]. Also accumulate references to change a posteriori [t_code] so that it stores only the needed types. *) let ty_roots = ref [] in let emitr r tyg = ty_roots := (r,tyg) :: !ty_roots in (* [stored_vs]: accumulates the variables in the order they will be found in the matching state after purely structural matching on the term structure of [tp]. *) let stored_vs = ref [] in (* [potential]: accumulates the bound variables that must be checked for absence in the term for each matching variable. Accumulation is done with intersection, since after equality check, only the variables permitted at all occurences may still be there. *) let potential = ref Mvs.empty in let store_vs vs bnd = stored_vs := vs :: !stored_vs; potential := match Mvs.find vs !potential with | b0 -> Mvs.add vs (Mvs.set_inter b0 bnd) !potential | exception Not_found -> Mvs.add vs bnd !potential in (* [blvl]: accumulates the representative level of a bound variable, as it will be accumulated by fragmentation of binding constructs. *) let blvl = ref 0 in let genb () = let l = !blvl in blvl := l + 1; l in (* [reg_vs_tyg]: cache the type graphs for variables. *) let reg_vs_tyg = ref Mvs.empty in let get_tyg vs = try Mvs.find vs !reg_vs_tyg with Not_found -> let ntyg = TyG.create vs.vs_ty in reg_vs_tyg := Mvs.add vs ntyg !reg_vs_tyg; if Mvs.mem vs rigid_vs then ignore (TyG.collect rigid_tv Mtv.empty vs.vs_ty ntyg); ntyg in (* tyg_bool: known type graph for boolean. Used as the type graph for formulas (e.g for prop), which handles the removal of bool/prop conversions. *) let tyg_bool = TyG.create ty_bool in ignore (TyG.collect rigid_tv Mtv.empty ty_bool tyg_bool); (* [structure]: accumulates the initial part of the code, responsible for matching against the structure of [tp]. Argument [bnd] stores the level of currently bound variables. *) let rec structure bnd tp = let tp = remove_bp tp in match tp.t_node with | Tvar vs -> let r = ref false in let tyg = get_tyg vs in if Mvs.mem vs rigid_vs then emit (Fragment ([r],Crigid vs)) else begin match Mvs.find vs bnd with | lvl -> emit (Fragment ([r],Cbound lvl)) | exception Not_found -> store_vs vs bnd; emit (Store [r]) end; emitr r tyg; tyg | (Tconst _ | Ttrue | Tfalse) -> let r = ref false in emit (Fragment ([r],Cconst tp)); begin match tp.t_ty with | None -> tyg_bool | Some ty -> let tyg = TyG.create ty in emitr r tyg; tyg end | Tapp (ls,tl) -> let r = ref false in emit (Fragment ([r],Capp ls)); let tyg, rf = match ls.ls_value with | None -> tyg_bool, Mtv.empty | Some ty -> let tyg = TyG.create (Opt.get tp.t_ty) in let rf = TyG.collect Mtv.empty Mtv.empty ty tyg in emitr r tyg; tyg, rf in let pr rf tp typ = TyG.collect Mtv.empty rf typ (structure bnd tp) in let _ = List.fold_left2 pr rf (List.rev tl) (List.rev ls.ls_args) in tyg | Tif (tpb,tpt,tpe) -> emit (Fragment ([],Cif)); let tyge = structure bnd tpe in let tygt = structure bnd tpt in TyG.unify tyge tygt; TyG.unify tyg_bool (structure bnd tpb); tygt | Tlet (tpd,tpv) -> emit (Fragment ([],Clet)); let vsp, tpv = t_open_bound tpv in let tygv = structure (Mvs.add vsp (genb ()) bnd) tpv in let tygd = structure bnd tpd in let tyg = get_tyg vsp in TyG.unify tygd tyg; tygv | Tcase (tcs,brl) -> emit (Fragment ([],Ccase (List.length brl))); let rec pat_structure bnd patp = let ptyg = TyG.create patp.pat_ty in begin match patp.pat_node with | Pwild -> emit (FragmentPat PatCwild); bnd | Pvar vsp -> emit (FragmentPat PatCvar); TyG.unify ptyg (get_tyg vsp); Mvs.add vsp (genb ()) bnd | Papp (ls,pl) -> emit (FragmentPat (PatCapp ls)); let pr (bnd,rf) pat typ = let bnd, ptyg = pat_structure bnd pat in bnd, TyG.collect Mtv.empty rf typ ptyg in let bs = (bnd,Mtv.empty) in let (bnd,rf) = List.fold_left2 pr bs (List.rev pl) (List.rev ls.ls_args) in let _ = TyG.collect Mtv.empty rf (Opt.get ls.ls_value) ptyg in bnd | Por (p1,p2) -> emit (FragmentPat PatCor); let bnd, ptyg2 = pat_structure bnd p2 in let bnd, ptyg1 = pat_structure bnd p1 in TyG.unify ptyg ptyg1; TyG.unify ptyg ptyg2; bnd | Pas (p,vsp) -> emit (FragmentPat PatCas); let bnd, ptyga = pat_structure (Mvs.add vsp (genb ()) bnd) p in TyG.unify ptyg (get_tyg vsp); TyG.unify ptyg ptyga; bnd end, ptyg in let tyres = ref None in let tycs = ref None in let pr br = let pat, tbr = t_open_branch br in let bnd, ptyg = pat_structure bnd pat in let tyg = structure bnd tbr in begin match !tyres with | None -> tyres := Some tyg | Some tyg0 -> TyG.unify tyg0 tyg end; begin match !tycs with | None -> tycs := Some ptyg | Some tyg0 -> TyG.unify tyg0 ptyg end in List.iter pr (List.rev brl); TyG.unify (Opt.get !tycs) (structure bnd tcs); Opt.get !tyres | Teps tpb -> let vsp, tpb = t_open_bound tpb in let r = ref false in emit (Fragment ([r],Ceps)); let tyg = get_tyg vsp in emitr r tyg; TyG.unify tyg_bool (structure (Mvs.add vsp (genb ()) bnd) tpb); tyg | Tquant (q,tpq) -> let vl, _, tpq = t_open_quant tpq in let fn vs = let r = ref false in emitr r (get_tyg vs); r in let l = List.map fn vl in emit (Fragment (l,Cquant (q,List.length l))); let bnd = List.fold_left (fun bnd vs -> Mvs.add vs (genb ()) bnd) bnd vl in TyG.unify tyg_bool (structure bnd tpq); tyg_bool | Tbinop (bp,t1,t2) -> emit (Fragment ([],Cbinop bp)); TyG.unify tyg_bool (structure bnd t2); TyG.unify tyg_bool (structure bnd t1); tyg_bool | Tnot t -> emit (Fragment ([],Cnot)); TyG.unify tyg_bool (structure bnd t); tyg_bool in let _ = structure Mvs.empty tp in let stored_tv = ref [] in (* [process_ty_root]: accumulates (in [code]) the code responsible for matching the current type root, if there is any. In that case, we assign the root reference a posteriori to signal that the type should have been stored by the initial pass. As a side-effect, this procedure also mark as known the node it matches, so that redundant code is not generated. Also accumulates the stored types variables in [stored_tv]. *) let process_ty_root (r,tyg) = let ty_code = ref [] in let emit i = ty_code := i :: !ty_code in let stv = ref [] in (* [process_tyg]: subroutine of [process_ty_root] that accumulates accumulates in the inverse order with respect to [process_ty_root]. It must be done in that order because we can only decide whether to emit the fragmenting instruction after processing all sub-nodes, whose code occurs later. *) let rec process_tyg tyg = let a = TyG.find tyg in match !a with | TyG.Root (rk,k,n) -> if not k then a := TyG.Root (rk,true,n); begin match n with | TyG.TyVvar tv when Mtv.mem tv rigid_tv -> not k && (emit (FragmentTy ([],TyCrigid tv)); true) | TyG.TyVvar tv -> not k && (stv := tv :: !stv; emit StoreTv; true) | TyG.TyVapp (ts,tygl) -> let pr lis tyg = process_tyg tyg :: lis in let lis = List.fold_left pr [] tygl in (not k || List.exists (fun b -> b) lis) && (emit (FragmentTy (List.rev_map ref lis,TyCapp ts)); true) end | _ -> assert false in if process_tyg tyg then begin code := List.rev_append !ty_code !code; stored_tv := List.rev_append !stv !stored_tv; r := true end in (* Generates code for actually matching variables and checking for occurrences of bound variables. *) List.iter process_ty_root !ty_roots; List.iter (fun tv -> emit (SubstTv tv)) !stored_tv; List.iter (fun vs -> emit (Subst vs)) !stored_vs; Mvs.iter (fun vs bnd -> if not (Mvs.is_empty bnd) then emit (Occurs vs)) !potential; (* Post-processing of code: replace the list of boolean reference by sorted lists of locations for the elements that should be stored. *) let rec compress ind = function | [] -> [] | r :: q -> let cq = compress (ind+1) q in if !r then ind :: cq else cq in let compress l = compress 0 l in let post_process = function | Fragment (l,c) -> Fragment (compress l,c) | Store l -> Store (compress l) | FragmentTy (l,c) -> FragmentTy (compress l,c) | FragmentPat p -> FragmentPat p | StoreTv -> StoreTv | Subst vs -> Subst vs | SubstTv tv -> SubstTv tv | Occurs vs -> Occurs vs | Nop -> Nop in List.rev_map post_process !code let compile id rigid_tv rigid_vs tp = { highest_id = id; straight_code = compile rigid_tv rigid_vs tp; branch = Stop } (*let matching_debug _ = Trans.goal (fun pr t -> Format.printf "Called with %a\n" Pretty.print_term t; let mty = ref Mtv.empty in let mv = ref Mvs.empty in let acc = ref None in let r = ref 0 in let gen () = let u = !r in r := !r + 1; u in let add x = match !acc with | None -> acc := Some x | Some y -> acc := Some (join_code_points Pervasives.compare x y) in let rec agg_term t = match t.t_node with | Tbinop (Tand,a,b) -> agg_term a; agg_term b | _ -> add (compile (gen ()) Mtv.empty Mvs.empty t) in let rec unfold_term t = match t.t_node with | Tquant (_,tq) -> let vl,_,tq = t_open_quant tq in List.iter (fun vs -> if Sattr.mem (create_attribute "rigid") vs.vs_name.id_attrs then begin mv := Mvs.add vs (t_var vs) !mv; mty := Stv.fold (fun tv mty -> Mtv.add tv (ty_var tv) mty ) (ty_freevars Stv.empty vs.vs_ty) !mty end) vl; unfold_term tq | Tapp (_,[a;b]) | Tbinop (_,a,b) -> agg_term a; let acc = Opt.get !acc in Format.printf "CODE: %a@." (pp_code Pp.int) acc; begin match run_match Pervasives.compare acc !mty !mv b with | Some (id,mty,mv) -> Format.printf "Match rule %d@." id; Mtv.iter (fun tv ty -> Format.printf "%a -> %a@." Pretty.print_tv tv Pretty.print_ty ty) mty; Mvs.iter (fun vs t -> Format.printf "%a -> %a@." Pretty.print_vs vs Pretty.print_term t) mv | None -> Format.printf "No Match@." | exception (Assert_failure (file,line,char)) -> Format.printf "fail: %s %d %d@." file line char | exception e -> Format.printf "%s@." (Printexc.to_string e) end | _ -> assert false in unfold_term t; [Decl.create_prop_decl Decl.Pgoal pr t] ) let () = Trans.register_env_transform "a" matching_debug ~desc:"DEBUG"*) why3-1.2.1/src/transform/abstract_quantifiers.ml0000644000175100017510000000253513555524575022537 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 elim_quant pol f = match f.t_node with | Tquant _ -> if pol then t_true else t_false | _ -> try t_map_sign elim_quant pol f with Failure _m -> f let elim_less (d:decl) = match d.d_node with | Dprop (p,_v,t) -> let pol = match p with | Paxiom | Plemma -> true | Pgoal -> false in let t = elim_quant pol t in if p <> Pgoal && t_equal t t_true then [] else [decl_map (fun _ -> t) d] | _ -> [d] let () = Trans.register_transform "abstract_quantifiers" (Trans.decl elim_less None) ~desc:"abstract@ quantifiers@ in@ the@ axioms@ of@ the@ context and the goals@." why3-1.2.1/src/transform/introduction.ml0000644000175100017510000002757113555524575021052 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 stop f = Sattr.mem Term.stop_split f.t_attrs let case_split = Ident.create_attribute "case_split" let case f = Sattr.mem case_split f.t_attrs let meta_intro_ls = Theory.register_meta ~desc:"(internal@ use)@ Preserve@ an@ introduced@ logical@ symbol@ name@ \ after@ generalization." "introduced_lsymbol" [Theory.MTlsymbol] let meta_intro_pr = Theory.register_meta ~desc:"(internal@ use)@ Preserve@ an@ introduced@ proposition@ name@ \ after@ generalization." "introduced_prsymbol" [Theory.MTprsymbol] let apply_prev fn hd = match hd.Task.task_prev with | Some hd -> fn hd | None -> [], None let apply_head fn = function | Some hd -> snd (fn hd) | None -> None let rec dequant pos f = t_attr_copy f (match f.t_node with | _ when stop f -> f | Tbinop (Tand,f1,{ t_node = Tbinop (Tor,_,{ t_node = Ttrue }) }) | Tbinop (Timplies,{ t_node = Tbinop (Tor,_,{ t_node = Ttrue }) },f1) -> dequant pos f1 | Tbinop (Tand,f1,f2) when not pos -> t_and (dequant false f1) (dequant false f2) | Tbinop (Tand,f1,f2) -> t_and (dequant_if_case true f1) (dequant_if_case true f2) | Tbinop (Tor,f1,f2) when pos -> t_or (dequant true f1) (dequant true f2) | Tbinop (Tor,f1,f2) -> t_or (dequant_if_case false f1) (dequant_if_case false f2) | Tbinop (Timplies,f1,f2) when pos -> t_implies (dequant false f1) (dequant true f2) | Tbinop (Timplies,f1,f2) -> t_implies (dequant_if_case true f1) (dequant_if_case false f2) | Tbinop (Tiff,_,_) -> f | Tif (fif,fthen,felse) -> t_if fif (dequant pos fthen) (dequant pos felse) | Tnot f1 -> t_not (dequant (not pos) f1) | Tlet (t,fb) -> let vs, f1 = t_open_bound fb in t_let_close vs t (dequant pos f1) | Tcase (t,bl) -> let branch bf = let pat, f1 = t_open_branch bf in t_close_branch pat (dequant pos f1) in t_case t (List.map branch bl) | Tquant (Tforall,fq) when pos -> let _,_,f1 = t_open_quant fq in dequant true f1 | Tquant (Texists,fq) when not pos -> let _,_,f1 = t_open_quant fq in dequant false f1 | Tquant _ | Ttrue | Tfalse | Tapp _ -> f | Tvar _ | Tconst _ | Teps _ -> raise (FmlaExpected f)) and dequant_if_case pos f = if case f then dequant pos f else f let intro_attr = Ident.create_attribute "introduced" let intro_attrs = Sattr.singleton intro_attr let compat ls vs = ls.ls_args = [] && Opt.equal ty_equal ls.ls_value (Some vs.vs_ty) && Opt.equal Loc.equal ls.ls_name.id_loc vs.vs_name.id_loc && Sattr.equal ls.ls_name.id_attrs (Sattr.add intro_attr vs.vs_name.id_attrs) let ls_of_vs mal vs = match mal with | Theory.MAls ls :: mal when compat ls vs -> ls, mal | _ -> let id = id_clone ~attrs:intro_attrs vs.vs_name in create_fsymbol id [] vs.vs_ty, mal let intro_var (subst, mal) vs = let ls, mal = ls_of_vs mal vs in let subst = Mvs.add vs (fs_app ls [] vs.vs_ty) subst in (subst, mal), create_param_decl ls let get_expls f = Sattr.filter (fun a -> Strings.has_prefix "expl:" a.attr_string) f.t_attrs let rec intros kn pr mal expl f = let fexpl = get_expls f in let expl = if Sattr.is_empty fexpl then expl else fexpl in let move_expl f = if Sattr.is_empty fexpl && not (Sattr.is_empty expl) then t_attr_add (Sattr.min_elt expl) f else f in match f.t_node with (* (f2 \/ True) => _ *) | Tbinop (Timplies,{ t_node = Tbinop (Tor,f2,{ t_node = Ttrue }) },_) when Sattr.mem Term.asym_split f2.t_attrs -> [create_prop_decl Pgoal pr (move_expl f)] | Tbinop (Timplies,f1,f2) -> (* split f1 *) (* f is going to be removed, preserve its attributes and location in f2 *) let f2 = t_attr_copy f f2 in let fl = Split_goal.split_intro_right ?known_map:kn (dequant false f1) in let idx = id_fresh "H" ~attrs:(Sattr.singleton intro_attr) in let add (subst,dl) f = let svs = Mvs.set_diff (t_freevars Mvs.empty f) subst in let subst, dl = Mvs.fold (fun vs _ (subst,dl) -> let (subst,_), d = intro_var (subst, []) vs in subst, d::dl) svs (subst, dl) in (* only reuse the name when fl is a singleton *) let prx = match mal, fl with | Theory.MApr pr :: _, [_] -> pr | _, _ -> create_prsymbol idx in let d = create_prop_decl Paxiom prx (t_subst subst f) in subst, d::dl in (* consume the topmost name *) let mal = match mal with | Theory.MApr _ :: mal -> mal | _ -> mal in let _, fl = List.fold_left add (Mvs.empty, []) fl in List.rev_append fl (intros kn pr mal expl f2) | Tquant (Tforall,fq) -> let vsl,_trl,f_t = t_open_quant fq in let (subst, mal), dl = Lists.map_fold_left intro_var (Mvs.empty, mal) vsl in (* preserve attributes and location of f *) let f = t_attr_copy f (t_subst subst f_t) in dl @ intros kn pr mal expl f | Tlet (t,fb) -> let vs, f = t_open_bound fb in let ls, mal = ls_of_vs mal vs 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 kn pr mal expl f | _ -> [create_prop_decl Pgoal pr (move_expl f)] let intros kn mal 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 let f = t_ty_subst subst Mvs.empty f in let dl = intros kn pr mal Sattr.empty f in Mtv.values decls @ dl let rec introduce hd = match hd.Task.task_decl.Theory.td_node with | Theory.Decl {d_node = Dprop (Pgoal,pr,f)} -> let mal, task = apply_prev introduce hd in let kn = Some (Task.task_known task) in let dl = intros kn (List.rev mal) pr f in [], List.fold_left Task.add_decl task dl | Theory.Meta (m,[ma]) when Theory.meta_equal m meta_intro_ls || Theory.meta_equal m meta_intro_pr -> let mal, task = apply_prev introduce hd in ma::mal, task | Theory.Meta _ -> let mal, task = apply_prev introduce hd in mal, Task.add_tdecl task hd.Task.task_decl | _ -> [], Some hd let intros ?known_map pr f = intros known_map [] pr f let introduce_premises = Trans.store (apply_head introduce) let () = Trans.register_transform "introduce_premises" introduce_premises ~desc:"Introduce@ universal@ quantification@ and@ hypothesis@ in@ the@ \ goal@ into@ constant@ symbol@ and@ axioms." (* In this file t_replace is used to substitute vsymbol with lsymbols. This is done in [set_vs]; but in cases where the attribute is directly on the lsymbol term application (Tapp), the substitution may not work resulting in an error of the transformation. That's why we check for equality modulo attributes and then copy attributes back on the term again. *) let rec t_replace t1 t2 t = if t_equal_nt_na t t1 then t_attr_copy t t2 else t_map (t_replace t1 t2) t let rec generalize hd = match hd.Task.task_decl.Theory.td_node with | Theory.Decl {d_node = Dprop (Pgoal,pr,f)} -> let pl, task = apply_prev generalize hd in if pl = [] then [], Some hd else let expl = get_expls f in let get_vs {ls_name = id; ls_value = oty} = let attrs = Sattr.remove intro_attr id.id_attrs in let id = id_fresh ~attrs ?loc:id.id_loc id.id_string in create_vsymbol id (Opt.get oty) in let set_vs vs ls f = t_replace (t_app ls [] ls.ls_value) (t_var vs) f in let rewind (vl,f) d = match d.d_node with | Dparam ls -> let v = get_vs ls in v::vl, set_vs v ls f | Dlogic [ls,ld] -> let f = t_forall_close vl [] f in let v = get_vs ls in let f = set_vs v ls f in let _, h = Decl.open_ls_defn ld in [], t_let_close v h f | Dprop (Paxiom,_,h) -> let f = t_forall_close vl [] f in [], t_implies h f | _ -> assert false (* never *) in let vl, f = List.fold_left rewind ([],f) pl in let f = t_forall_close vl [] f in let f = if Sattr.is_empty expl then f else t_attr_add (Sattr.min_elt expl) f in [], Task.add_decl task (create_prop_decl Pgoal pr f) | Theory.Decl ({d_node = ( Dparam ({ls_args = []; ls_value = Some _} as ls) | Dlogic [{ls_args = []; ls_value = Some _} as ls, _])} as d) when Sattr.mem intro_attr ls.ls_name.id_attrs -> let pl, task = apply_prev generalize hd in d::pl, Task.add_meta task meta_intro_ls [Theory.MAls ls] | Theory.Decl ({d_node = Dprop (Paxiom, pr, _)} as d) when Sattr.mem intro_attr pr.pr_name.id_attrs -> let pl, task = apply_prev generalize hd in d::pl, Task.add_meta task meta_intro_pr [Theory.MApr pr] (* We only reattach the local premises right before the goal. On the first non-local premise, we ignore the accumulator and return the original task. We make an exception for metas, as they are not checked against the known_map *) | Theory.Meta _ -> let pl, task = apply_prev generalize hd in pl, Task.add_tdecl task hd.Task.task_decl | _ -> [], Some hd let generalize_intro = Trans.store (apply_head generalize) let () = Trans.register_transform "generalize_introduced" generalize_intro ~desc:"Move@ the@ premises@ introduced@ by@ \"introduce_premises\"@ back@ \ into@ the@ goal." (** 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 id = id_clone ~attrs:(Sattr.singleton intro_attr) vs.vs_name in let ls = create_lsymbol id [] (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_attr_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'." let subst_filter ls = Sattr.mem intro_attr ls.ls_name.id_attrs && not (relevant_for_counterexample ls.ls_name) let simplify_intros = Trans.compose introduce_premises (Subst.subst_filtered ~subst_proxy:false subst_filter) let split_vc = Trans.compose_l (Trans.compose generalize_intro Split_goal.split_goal_right) (Trans.singleton simplify_intros) let () = Trans.register_transform_l "split_vc" split_vc ~desc:"The@ recommended@ splitting@ transformation@ to@ apply@ \ on@ VCs@ generated@ by@ WP@ (split_goal_right@ followed@ \ by@ introduce_premises@ followed@ by@ subst_all)." why3-1.2.1/src/transform/eliminate_algebraic.ml0000644000175100017510000005304413555524575022263 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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*theory) 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_right Svs.add vl av in let f1 = rewriteF kn state av sign f1 in (* Preserve attributes and location of f *) t_attr_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." (* Adding meta so that counterexamples consider this new projection as a counterexample projection. This allow counterexamples to appear for these values. *) let add_meta_cnt tsk ls = add_meta tsk meta_projection [MAls ls] 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 = add_meta_cnt tsk ls 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 (Stv.contains 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 | Use {th_decls = [{td_node = Decl ({d_node = Ddata [ts,_]})}]} when is_ts_tuple ts -> state, task | Decl ({ d_node = Ddata [ts,_] } as d) when is_ts_tuple ts -> let th = tuple_theory (List.length ts.ts_args) in let tp_map = Mid.add ts.ts_name (d,th) state.tp_map in { state with tp_map = tp_map }, task | Decl d -> let rstate,rtask = ref state, ref task in let add _ (d,th) () = let t = Opt.get (add_decl None d) in let state,task = comp t (!rstate,!rtask) in let task = add_tdecl task (create_use th) 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 } | [MAstr s] -> raise ( Invalid_argument ( "meta eliminate_algebraic, arg = \"" ^ s ^ "\"")) | l -> raise ( Invalid_argument ( "meta eliminate_algebraic, nb arg = " ^ string_of_int (List.length l) ^ "")) 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-1.2.1/src/transform/eliminate_if.mli0000644000175100017510000000152213555524575021113 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/inlining.ml0000644000175100017510000001034713555524575020131 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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_attr_set ?loc t.t_attrs 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_attr_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_attr_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-1.2.1/src/transform/subst.ml0000644000175100017510000005042413555524575017462 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 Generic_arg_trans_utils open Args_wrapper (* transformations "subst" and "subst_all" *) let debug_subst = Debug.register_flag "subst" ~desc:"debug transformations subst and subst_all" let rec subst_in_term sigma t = match t.t_node with | Tapp(ls,[]) -> begin try Mls.find ls sigma with Not_found -> t end | _ -> t_map (subst_in_term sigma) t let subst_in_def sigma ls (d:ls_defn) = let (vl,t) = open_ls_defn d in make_ls_defn ls vl (subst_in_term sigma t) (* [apply_subst prs sigma] is a transformation that operates on each decls. for each decl: - if d is a prop whose prsymbol belongs to prs, then it is removed - if d is a declaration of a constant symbol in the domain of sigma then it is removed - otherwise d is rewritten using the substitution sigma in [sigma], the right hand sides must not contain any symbols appearing in the left-hand-side *) let _apply_subst ((prs,sigma) : (Spr.t * term Mls.t)) : Task.task Trans.trans = Trans.decl (fun d -> match d.d_node with | Dprop(_k,pr,_t) when Spr.mem pr prs -> [] | Dprop(k,pr,t) -> [create_prop_decl k pr (subst_in_term sigma t)] | Dparam ls -> if Mls.mem ls sigma then [] else [d] | Dlogic ld -> let ld' = List.fold_right (fun (ls,ld) acc -> if Mls.mem ls sigma then acc else (subst_in_def sigma ls ld)::acc) ld [] in begin match ld' with | [] -> [] | _ -> [create_logic_decl ld'] end | Dind ((is: ind_sign), (ind_list: ind_decl list)) -> let ind_list = List.map (fun ((ls: lsymbol), (idl: (prsymbol * term) list)) -> let idl = List.map (fun (pr, t) -> (pr, subst_in_term sigma t)) idl in (ls, idl)) ind_list in [create_ind_decl is ind_list] | Dtype _ | Ddata _ -> [d]) None let apply_subst ((prs,sigma) : (Spr.t * term Mls.t)) (tdl:Theory.tdecl list) : Task.task = let rec aux urg tdl tuc postponed = match urg, tdl with | td::urg, rem -> begin match Task.add_tdecl tuc td with | tuc -> begin match td.td_node with | Decl {d_node = Dprop _} -> aux urg rem tuc postponed | Decl _ -> (* got new symbols: flush postponed *) aux (List.rev_append postponed urg) rem tuc [] | _ -> aux urg rem tuc postponed end | exception _ -> aux urg rem tuc (td::postponed) end | [], ({td_node = Decl d} as td) :: rem -> begin match d.d_node with | Dprop (Pgoal,pr,t) -> if postponed <> [] then raise (Arg_trans "apply_subst failed"); let t = subst_in_term sigma t in let d = create_prop_decl Pgoal pr t in Task.add_decl tuc d | Dprop (_,pr,_) when Spr.mem pr prs -> aux urg rem tuc postponed | Dprop (k,pr,t) -> let t = subst_in_term sigma t in let d = create_prop_decl k pr t in let td = Theory.create_decl d in aux (td::urg) rem tuc postponed | Dparam ls when Mls.mem ls sigma -> aux urg rem tuc postponed | Dparam _ -> aux (td::urg) rem tuc postponed | Dlogic ld -> let ld' = List.fold_right (fun (ls,ld) acc -> if Mls.mem ls sigma then acc else (subst_in_def sigma ls ld) :: acc) ld [] in if ld' = [] then aux urg rem tuc postponed else begin match create_logic_decl ld' with | d -> let td = Theory.create_decl d in aux (td::urg) rem tuc postponed | exception (NoTerminationProof _) -> let urg = List.fold_right (fun (ls,ld) urg -> let nm = ls.ls_name.id_string ^ "'def" in let pr = create_prsymbol (id_fresh nm) in let f = ls_defn_axiom ld in let d = create_prop_decl Paxiom pr f in Theory.create_decl d :: urg) ld' urg in let urg = List.fold_right (fun (ls,_) urg -> let d = create_param_decl ls in Theory.create_decl d :: urg) ld' urg in aux urg rem tuc postponed end | Dind ((is: ind_sign), (ind_list: ind_decl list)) -> let ind_list = List.map (fun ((ls: lsymbol), (idl: (prsymbol * term) list)) -> let idl = List.map (fun (pr, t) -> (pr, subst_in_term sigma t)) idl in (ls, idl)) ind_list in let d = create_ind_decl is ind_list in let td = Theory.create_decl d in aux (td::urg) rem tuc postponed | Dtype _ | Ddata _ -> aux (td::urg) rem tuc postponed end | [], td::rem -> aux (td::urg) rem tuc postponed | [], [] -> assert false in aux [] tdl None [] let rec occurs_in_term ls t = match t.t_node with | Tapp(ls',[]) when ls_equal ls' ls -> true | _ -> t_any (occurs_in_term ls) t (* [true] if [ls] is a proxy symbol *) let ls_is_proxy ls = Sattr.mem proxy_attr ls.ls_name.id_attrs (* [true] if [t] is exactly a proxy symbol *) let t_is_proxy t = match t.t_node with | Tapp (ls, []) -> ls_is_proxy ls | _ -> false (* [find_equalities subst_proxy filter t] searches task [t] for equalities of the form constant = term or term = constant, where constant does not occur in the term. That function returns first the set of prsymbols for the equalities found, and second a map from the lsymbols of the constant to the associated term. That map is normalized in the sense that the terms on the right are fully substituted, for example if the equalities "x=t" and "y=x+u" are found, then the map contains "x -> t" and "y ->t+u". The [filter] function applies a generic filter to the constants that can be taken into consideration. if several equalities occur for the same constant, the first one is considered. [subst_proxy]: If false, we don't register equalities which substitute a proxy variable into a non-proxy variable. *) let find_equalities ~subst_proxy filter = let valid ls = ls.ls_args = [] && ls.ls_constr = 0 && ls.ls_value <> None && List.for_all Ty.ty_closed (Ty.oty_cons ls.ls_args ls.ls_value) && filter ls in let bad_proxy_subst ls t = not subst_proxy && t_is_proxy t && not (ls_is_proxy ls) in let select ls t sigma = let () = Debug.dprintf debug_subst "selected: %a -> %a@." Pretty.print_ls ls Pretty.print_term t in let sigma' = Mls.add ls t Mls.empty in let sigma = Mls.map (subst_in_term sigma') sigma in Mls.add ls t sigma in Trans.fold_decl (fun d ((prs,sigma) as acc) -> match d.d_node with | Dprop (Pgoal, _, _) -> acc | Dprop (_, pr, t) -> begin match t.t_node with | Tapp (ls, [t1; t2]) when ls_equal ls ps_equ -> begin try match t1.t_node with | Tapp (ls, []) when valid ls && not (Mls.mem ls sigma) -> let t2' = subst_in_term sigma t2 in if occurs_in_term ls t2' then raise Exit else if bad_proxy_subst ls t2' then raise Exit else (Spr.add pr prs, select ls t2' sigma) | _ -> raise Exit with Exit -> match t2.t_node with | Tapp (ls, []) when valid ls && not (Mls.mem ls sigma) -> let t1' = subst_in_term sigma t1 in if occurs_in_term ls t1' then acc else if bad_proxy_subst ls t1' then acc else (Spr.add pr prs, select ls t1' sigma) | _ -> acc end | _ -> acc end | Dlogic ld -> List.fold_left (fun ((prs,sigma) as acc) (ls,ld) -> let _, t = open_ls_defn ld in if valid ls && not (Mls.mem ls sigma) then let t' = subst_in_term sigma t in if occurs_in_term ls t' then acc else if bad_proxy_subst ls t' then acc else (prs, select ls t' sigma) else acc) acc ld | Ddata _ | Dtype _ | Dparam _ | Dind _ -> acc) (Spr.empty, Mls.empty) let get_decls = Trans.fold (fun th acc -> th.Task.task_decl :: acc) [] let apply_subst x t = apply_subst x (List.rev (Trans.apply get_decls t)) let subst_filtered ~subst_proxy filter = Trans.bind (find_equalities ~subst_proxy filter) (fun x -> Trans.store (apply_subst x)) let subst_all = subst_filtered ~subst_proxy:false (fun _ -> true) let () = wrap_and_register ~desc:"substitutes with all equalities between a constant and a term" "subst_all" (Ttrans) subst_all let subst tl = let to_subst = List.fold_left (fun acc t -> match t.t_node with | Tapp (ls, []) -> Sls.add ls acc | _ -> raise (Arg_trans "subst: %a is not a constant")) Sls.empty tl in subst_filtered ~subst_proxy:true (fun ls -> Sls.mem ls to_subst) let () = wrap_and_register ~desc:"substitutes with all equalities involving one of the given constants" "subst" (Ttermlist Ttrans) subst (* (* This found any equality which at one side contains a single lsymbol and is local. It gives same output as found_eq. *) let find_eq2 is_local_decl = Trans.fold_decl (fun d acc -> match d.d_node with | Dprop (k, pr, t) when k != Pgoal && is_local_decl d -> begin let acc = (match t.t_node with | Tapp (ls, [t1; t2]) when ls_equal ls ps_equ -> (match t1.t_node, t2.t_node with | Tapp (_, []), _ -> Some (Some pr, t1, t2) | _, Tapp (_, []) -> Some (Some pr, t2, t1) | _ -> acc) | _ -> acc) in acc end | Dlogic [(ls, ld)] when is_local_decl d -> (* Function without arguments *) let vl, e = open_ls_defn ld in if vl = [] then Some (None, t_app_infer ls [], e) else acc | _ -> acc) None let subst_eq found_eq = match found_eq with | None -> raise (Arg_trans "subst_eq") | Some (Some pr_eq, t1, t2) -> begin Trans.decl (fun d -> match d.d_node with (* Remove equality over which we subst *) | Dprop (_k, pr, _t) when pr_equal pr pr_eq -> [] (* Replace in all hypothesis *) | Dprop (kind, pr, t) -> [create_prop_decl kind pr (t_replace t1 t2 t)] | Dlogic ldecl_list -> let ldecl_list = List.map (fun (ls, ls_def) -> let (vl, t) = open_ls_defn ls_def in make_ls_defn ls vl (t_replace t1 t2 t)) ldecl_list in [create_logic_decl ldecl_list] (* TODO unbelievably complex for something that simple... *) | Dind ((is: ind_sign), (ind_list: ind_decl list)) -> let ind_list: ind_decl list = List.map (fun ((ls: lsymbol), (idl: (prsymbol * term) list)) -> let idl = List.map (fun (pr, t) -> (pr, t_replace t1 t2 t)) idl in (ls, idl)) ind_list in [create_ind_decl is ind_list] | Dtype _ | Ddata _ | Dparam _ -> [d]) None end | Some (None, t1, t2) -> begin Trans.decl (fun d -> match d.d_node with | Dlogic [(ls, _ld)] when try (t1 = Term.t_app_infer ls []) with _ -> false -> [] (* Replace in all hypothesis *) | Dprop (kind, pr, t) -> [create_prop_decl kind pr (t_replace t1 t2 t)] | Dlogic ldecl_list -> let ldecl_list = List.map (fun (ls, ls_def) -> let (vl, t) = open_ls_defn ls_def in make_ls_defn ls vl (t_replace t1 t2 t)) ldecl_list in [create_logic_decl ldecl_list] (* TODO unbelievably complex for something that simple... *) | Dind ((is: ind_sign), (ind_list: ind_decl list)) -> let ind_list: ind_decl list = List.map (fun ((ls: lsymbol), (idl: (prsymbol * term) list)) -> let idl = List.map (fun (pr, t) -> (pr, t_replace t1 t2 t)) idl in (ls, idl)) ind_list in [create_ind_decl is ind_list] | Dtype _ | Ddata _ | Dparam _ -> [d]) None end let subst_eq_list (found_eq_list, _) = List.fold_left (fun acc_tr found_eq -> Trans.compose (subst_eq found_eq) acc_tr) Trans.identity found_eq_list let subst_all (is_local_decl: Decl.decl -> bool) = Trans.bind (find_eq2 is_local_decl) subst_eq let return_local_decl task = let decl_list = get_local_task task in let is_local_decl d = List.exists (fun x -> Decl.d_equal d x) decl_list in is_local_decl let return_local_decl = Trans.store return_local_decl let subst_all = Trans.bind return_local_decl subst_all let rec repeat f task = try let new_task = Trans.apply f task in (* TODO this is probably expansive. Use a checksum or an integer ? *) if Task.task_equal new_task task then raise Exit else repeat f new_task with | _ -> task let repeat f = Trans.store (repeat f) let subst_all = repeat subst_all (* TODO implement subst_all as repeat subst ??? *) let () = wrap_and_register ~desc:"substitute all ident equalities and remove them" "subst_all" (Ttrans) subst_all *) (*********) (* Subst *) (*********) (* (* Creation of as structure that associates the replacement of terms as a function of the *) type constant_subst_defining = | Cls of lsymbol | Cpr of prsymbol module Csd = Stdlib.MakeMSHW (struct type t = constant_subst_defining let tag (c: t) = match c with | Cls ls -> ls.ls_name.Ident.id_tag | Cpr pr -> pr.pr_name.Ident.id_tag end) module Mcsd = Csd.M (* We find the hypotheses that have a substitution equality for elements of the to_subst list. We check that we never take more than one equality per lsymbol to substitute. *) let find_eq_aux (to_subst: Term.lsymbol list) = Trans.fold_decl (fun d (acc, used) -> match d.d_node with | Dprop (k, pr, t) when k != Pgoal -> let acc, used = (match t.t_node with | Tapp (ls, [t1; t2]) when ls_equal ls ps_equ -> (* Allow to rewrite from the right *) begin match t1.t_node, t2.t_node with | Tapp (ls, []), _ when List.exists (ls_equal ls) to_subst && (* Check ls is not already taken *) not (List.exists (ls_equal ls) used) -> Mcsd.add (Cpr pr) (t1, t2) acc, ls :: used | _, Tapp (ls, []) when List.exists (ls_equal ls) to_subst && (* Check ls is not already taken *) not (List.exists (ls_equal ls) used) -> Mcsd.add (Cpr pr) (t2, t1) acc, ls :: used | _ -> acc, used end | _ -> acc, used) in acc, used | Dlogic [(ls, ld)] when List.exists (ls_equal ls) to_subst && (* Check ls is not already taken *) not (List.exists (ls_equal ls) used) -> (* Function without arguments *) let vl, e = open_ls_defn ld in if vl = [] then Mcsd.add (Cls ls) (t_app_infer ls [], e) acc, ls :: used else acc, used | _ -> acc, used) (Mcsd.empty,[]) (* Wrap-around function to parse lsymbol instead of terms *) let find_eq to_subst = let to_subst = (List.map (fun t -> match t.t_node with | Tapp (ls, []) -> ls | _ -> raise (Arg_trans "subst_eq")) to_subst) in find_eq_aux to_subst (* This produce an ordered list of tdecl which is the original task minus the hypotheses/constants that were identified for substitution. This shall be done on tdecl. *) let remove_hyp_and_constants (replacing_hyps, used_ls) = (* The task_fold on tdecl is necessary as we *need* all the tdecl (in particular to identify local decls). *) Task.task_fold (fun (subst, list_tdecl) td -> match td.td_node with | Decl d -> begin match d.d_node with | Dprop (kind, pr, _t) when kind != Pgoal && Mcsd.mem (Cpr pr) replacing_hyps -> let from_t, to_t = Mcsd.find (Cpr pr) replacing_hyps in (* TODO find a way to be more efficient than this *) let to_t = Generic_arg_trans_utils.replace_subst subst to_t in Mterm.add from_t to_t subst, list_tdecl | Dlogic [ls, _] when Mcsd.mem (Cls ls) replacing_hyps -> let from_t, to_t = Mcsd.find (Cls ls) replacing_hyps in (* TODO find a way to be more efficient than this *) let to_t = Generic_arg_trans_utils.replace_subst subst to_t in Mterm.add from_t to_t subst, list_tdecl | Dparam ls when List.exists (ls_equal ls) used_ls -> subst, list_tdecl | _ -> subst, (replace_tdecl subst td :: list_tdecl) end | _ -> (subst, td :: list_tdecl) ) (Mterm.empty, []) let remove_hyp_and_constants (replacing_hyps, used_ls) = Trans.store (remove_hyp_and_constants (replacing_hyps, used_ls)) let is_goal td = match td.td_node with | Decl d -> begin match d.d_node with | Dprop (Pgoal, _, _) -> true | _ -> false end | _ -> false (* Use the list of tdecl that should be able to be readded into a task if there was sufficiently few things that were removed to the task. To do this, we use Task.add_tdecl (because we think its the safest). Note that we also try to keep the order of the declarations (because usability). So, each time we add a new declaration, we try to add all the transformations that failed (supposedly because they use a variable declared after it). *) let readd_decls (list_decls, subst: tdecl list * _) = List.fold_left (fun (task_uc, list_to_add) (d: tdecl) -> let d = replace_tdecl subst d in let task_uc, list_to_add = List.fold_left (fun (task_uc, list_to_add) (d: tdecl) -> try let new_task_uc = Task.add_tdecl task_uc d in new_task_uc, list_to_add with (* TODO find all possible exceptions here *) _ -> task_uc, d :: list_to_add) (task_uc, []) list_to_add in (* We always need to add the goal last *) if is_goal d then if list_to_add != [] then raise (Arg_trans_decl ("subst_eq", list_to_add)) else try (Task.add_tdecl task_uc d, []) with (* TODO find all possible exceptions here *) _ -> raise (Arg_trans_decl ("subst_eq", [d])) else try (Task.add_tdecl task_uc d, List.rev list_to_add) with _ -> (task_uc, List.rev (d :: list_to_add))) (None, []) list_decls let readd_decls (subst, list_decls) = let (task, _l) = readd_decls (list_decls, subst) in Trans.return task let find args = Trans.bind (find_eq args) remove_hyp_and_constants let subst args = Trans.bind (find args) readd_decls let () = wrap_and_register ~desc:"remove a literal using an equality on it" "subst" (Ttermlist Ttrans) subst *) why3-1.2.1/src/transform/split_goal.mli0000644000175100017510000000613513555524575020630 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 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_proof_full] works as [split_pos_full] but stops at the [stop_split] attribute 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_proof_right] works as [split_pos_right] but stops at the [stop_split] attribute 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] attribute, stops at the [stop_split] attribute 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] attribute, stops at the [stop_split] attribute 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 why3-1.2.1/src/transform/discriminate.mli0000644000175100017510000000251613555524575021145 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/generic_arg_trans_utils.ml0000644000175100017510000001473313555524575023221 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 Theory exception Arg_trans of string exception Arg_trans_decl of (string * tdecl list) exception Arg_trans_term of (string * term) exception Arg_trans_term2 of (string * term * term) exception Arg_trans_term3 of (string * term * term * term) exception Arg_trans_pattern of (string * pattern * pattern) exception Arg_trans_type of (string * Ty.ty * Ty.ty) exception Arg_trans_missing of (string * Svs.t) exception Arg_bad_hypothesis of (string * term) exception Cannot_infer_type of string exception Unnecessary_terms of term list let gen_ident = Ident.id_fresh let rec t_replace_nt_na t1 t2 t = if t_equal_nt_na t t1 then t2 else t_map (t_replace_nt_na t1 t2) t (* Replace all occurences of f1 by f2 in t *) let replace_in_term = t_replace_nt_na (* TODO be careful with attribute copy in t_map *) let subst_quant c tq x : term = let (vsl, tr, te) = t_open_quant tq in (match vsl with | hdv :: tl -> (try (* TODO this should be refined in the future. In particular, we may want to investigate something more robust with respect to polymorphims. *) let ty_subst, subst = Reduction_engine.first_order_matching (Svs.add hdv Svs.empty) [Term.t_var hdv] [x] in let new_t = t_ty_subst ty_subst subst te in t_quant_close c tl tr new_t with | Ty.TypeMismatch (ty1, ty2) -> raise (Arg_trans_type ("subst_quant", ty1, ty2))) | [] -> failwith "subst_quant: Should not happen, please report") let subst_quant_list quant term_quant list_term : term = let (vsl, triggers, te) = t_open_quant term_quant in (* TODO this create_mvs function should be a fold. It also can and should be removed because we can use first_order_matching on list of terms *) let rec create_mvs list_term vsl acc acc_ty = match list_term, vsl with | t :: lt_tl, v :: vsl_tl -> let (ty_subst, _) = try Reduction_engine.first_order_matching (Svs.add v Svs.empty) [Term.t_var v] [t] with Reduction_engine.NoMatch _e -> raise (Arg_trans (Format.asprintf "cannot match %a with %a" Pretty.print_term (Term.t_var v) Pretty.print_term t)) in create_mvs lt_tl vsl_tl (Mvs.add v t acc) (Ty.Mtv.union (fun _ _ y -> Some y) ty_subst acc_ty) | _ :: _, [] -> raise (Unnecessary_terms list_term) | [], vsl_remaining -> (acc_ty, acc), vsl_remaining in let (ty_subst, m_subst), variables_remaining = try create_mvs list_term vsl Mvs.empty Ty.Mtv.empty with exn -> raise (Arg_trans (Format.asprintf "subst_quant_list: exception %a" Exn_printer.exn_printer exn)) in try let new_t = t_ty_subst ty_subst m_subst te in t_quant_close quant variables_remaining triggers new_t with | Ty.TypeMismatch (ty1, ty2) -> raise (Arg_trans_type ("subst_quant_list", ty1, ty2)) (* Transform the term (exists v, f) into f[x/v] *) let subst_exist t x = match t.t_node with | Tquant (Texists, tq) -> subst_quant Texists tq x | _ -> raise (Arg_trans "subst_exist") (* Transform the term (forall v, f) into f[x/v] *) let subst_forall t x = match t.t_node with | Tquant (Tforall, tq) -> subst_quant Tforall tq x | _ -> raise (Arg_trans "subst_forall") (* Squash forall x y. forall z into forall x y z. Squashing also removes triggers. *) let squash_forall t = let rec squash_forall_aux vl t = match t.t_node with | Tquant (Tforall, tq) -> let (new_v, _, t) = t_open_quant tq in squash_forall_aux (vl @ new_v) t | _ -> t_forall (t_close_quant vl [] t) in squash_forall_aux [] t (* Same as subst_forall but l is a list of term *) let subst_forall_list t l = let t = squash_forall t in match t.t_node with | Tquant (Tforall, tq) -> subst_quant_list Tforall tq l | _ -> raise (Arg_trans "subst_forall_list") (* Returns the list of local declarations as a transformation *) let get_local = Trans.store (fun task -> let local_decls = let ut = Task.used_symbols (Task.used_theories task) in Task.local_decls task ut in local_decls) let get_local_task task = let ut = Task.used_symbols (Task.used_theories task) in Task.local_decls task ut let sort local_decls = let l = ref [] in Trans.decl (fun d -> match d.d_node with | _ when not (List.exists (fun x -> Decl.d_equal x d) local_decls) -> [d] | Dprop (Paxiom, _, _) | Dprop (Plemma, _, _) | Dprop (Pgoal, _, _) -> (* Last element, we concatenate the list of postponed elements *) !l @ [d] | _ -> [d]) None (* TODO is sort really needed ? It looked like it was for subst in some example where I wanted to subst the definition of a logic constant into an equality and it would fail because the equality is defined before the logic definition. This may be solved by current implementation of subst: to be tested. *) let sort = Trans.bind get_local sort (****************************) (* Substitution of terms *) (****************************) type term_subst = term Mterm.t (* Same as replace but for a list of terms at once. Here, a silent assumption is made that any term tried to be replaced is actually a constant. *) let replace_subst (subst: term_subst) t = (* TODO improve efficiency of this ? *) Mterm.fold (fun t_from t_to acc -> t_replace_nt_na t_from t_to acc) subst t let replace_decl (subst: term_subst) (d: decl) = decl_map (replace_subst subst) d let replace_tdecl (subst: term_subst) (td: tdecl) = match td.td_node with | Decl d -> create_decl (replace_decl subst d) | _ -> td (************************) (* Explanation handling *) (************************) let create_goal ~expl pr t = let expl = Ident.create_attribute ("expl:" ^ expl) in let t = Term.t_attr_add expl t in create_prop_decl Pgoal pr t why3-1.2.1/src/transform/lift_epsilon.mli0000644000175100017510000000130713555524575021156 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/instantiate_predicate.mli0000644000175100017510000000130713555524575023032 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/intro_projections_counterexmp.mli0000644000175100017510000000720413555524575024674 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 attributes *) val intro_projections_counterexmp : Env.env -> Task.task Trans.trans (** Transformation that for each declared abstract function or predicate p tagged with attribute "model_projected" creates a declaration of new constant c tagged with attribute "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. 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 tagging projection function by an attribute of the form "model_trace:proj_name". If predicate p has an attribute of the form "model_trace:p_name@*", the constant will have an attribute 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 an attribute 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, attribute and location 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-1.2.1/src/transform/encoding.ml0000644000175100017510000001051213555524575020102 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 Wstdlib 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-1.2.1/src/transform/introduction.mli0000644000175100017510000000246013555524575021211 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 intro_attr : Ident.attribute val intros : ?known_map:Decl.known_map -> Decl.prsymbol -> Term.term -> Decl.decl list (** [intros ?known_map G f] returns the declarations after introducing premises of [goal G : f] *) val introduce_premises : Task.task Trans.trans val simplify_intros: Task.task Trans.trans why3-1.2.1/src/transform/encoding_twin.ml0000644000175100017510000001037113555524575021146 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 Wstdlib 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_h = Hty.create 7 let seen_q = Queue.create () let check_in ty = if not (Hty.mem seen_h ty) then begin Hty.add seen_h ty (); Queue.add ty seen_q end let add_decls tenv decls = let add decls ty = let _,_,defs = Mty.find ty tenv in List.append defs decls in let decls = Queue.fold add decls seen_q in Queue.clear seen_q; Hty.clear seen_h; 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 check_in 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 check_in 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_attr_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_attr_copy t (ps_app ls tl) else t_attr_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-1.2.1/src/transform/prepare_for_counterexmp.ml0000644000175100017510000000407713555524575023262 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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" [Theory.MTstring] ~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.seq [ Introduction.simplify_intros; 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." why3-1.2.1/src/transform/eliminate_epsilon.mli0000644000175100017510000000144613555524575022173 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/encoding_select.mli0000644000175100017510000000165513555524575021622 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/eliminate_definition.mli0000644000175100017510000000323013555524575022643 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 *) type rem = { rem_pr : Decl.Spr.t; rem_ls : Term.Sls.t; rem_ts : Ty.Sts.t } (* unused val bisect : (Task.task -> bool) -> Task.task -> rem (** [bisect test task] return the symbols that can be removed without making the task invalid for the function test. *) *) type bisect_step = | BSdone of rem | BSstep of rem * (bool -> bisect_step) val bisect_step : Task.task -> bisect_step (** Same as before but doing it step by step *) why3-1.2.1/src/transform/induction_pr.mli0000644000175100017510000000130713555524575021164 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/close_epsilon.ml0000644000175100017510000000571213555524575021160 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 | _ -> 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-1.2.1/src/transform/induction_pr.ml0000644000175100017510000002211313555524575021011 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 open Args_wrapper let attr_ind = create_attribute "induction" let attr_inv = create_attribute "inversion" type context = { c_node : context_node; c_attrs : Sattr.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_attrs = term.t_attrs; c_loc = term.t_loc } let make_context_ctx node context = { c_node = node; c_attrs = context.c_attrs; c_loc = context.c_loc } (* Locate induction term in [t]: either leftmost inductive on the implication chain, or the one tagged with [attr]. 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 attr 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 has_attr () = Sattr.mem attr lhs.t_attrs in if find_any || (has_attr ()) 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 (has_attr ()) then (* take first tagged 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 attr 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_attr_set ?loc:ctx.c_loc ctx.c_attrs (t_implies t goal)) | Cforall (vsl, ctx2) -> zip ctx2 (t_attr_set ?loc:ctx.c_loc ctx.c_attrs (t_forall_close vsl [] goal)) | Clet (vs, t, ctx2) -> zip ctx2 (t_attr_set ?loc:ctx.c_loc ctx.c_attrs (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_attr_copy t (t_let t1 (cb vs (aux t2))) | Tquant(Tforall, tq) -> let vsl, tr, t1, cb = t_open_quant_cb tq in t_attr_copy t (t_forall (cb vsl tr (aux t1))) | Tbinop (Timplies, lhs, rhs) -> t_attr_copy t (t_implies (subst true lhs) (aux rhs)) | _ -> subst false t in aux c let induction_l attr induct kn t = let (ctx, (ls, argl, cl), goal) = locate kn attr 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 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 attr 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 attr induct kn f) with Ind_not_found -> [task] end | _ -> assert false let induction_on_hyp attr b h = Trans.compose (Ind_itp.revert_tr_symbol [Tsprsymbol h]) (Trans.store (induction_l attr b)) let () = wrap_and_register ~desc:"induction_arg_pr performs induction_pr on pr." "induction_arg_pr" (Tprsymbol Ttrans_l) (induction_on_hyp attr_ind true) let () = wrap_and_register ~desc:"induction_arg_pr performs inversion_pr on pr." "inversion_arg_pr" (Tprsymbol Ttrans_l) (induction_on_hyp attr_inv false) let () = Trans.register_transform_l "induction_pr" (Trans.store (induction_l attr_ind true)) ~desc:"Generate@ induction@ hypotheses@ for@ goals@ over@ inductive@ predicates." let () = Trans.register_transform_l "inversion_pr" (Trans.store (induction_l attr_inv false)) ~desc:"Invert@ inductive@ predicate." (* Local Variables: compile-command: "unset LANG; make -C ../.. bin/why3.byte" End: *) why3-1.2.1/src/transform/congruence.ml0000644000175100017510000000261513555524575020451 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 congruence pr f = match f.t_node with | Tapp (eq, [{ t_node = Tapp (f1, l1) }; { t_node = Tapp (f2, l2) }]) when ls_equal eq ps_equ && ls_equal f1 f2 -> (* f a1 b1 c1... = f a2 b2 c2... *) let ts = List.map2 t_equ_simp l1 l2 in (* a1 = a2, b1 = b2... *) let goal_of_t t = let pr = create_prsymbol (Ident.id_fresh "G") in [create_prop_decl Pgoal pr t] in List.map goal_of_t ts | _ -> [[create_prop_decl Pgoal pr f]] (* no progress *) let t = Trans.goal_l congruence let () = Trans.register_transform_l "congruence" t ~desc:"Replace@ equality@ between@ two@ results@ of@ a@ function@ by@ equalities@ between@ parameters." why3-1.2.1/src/transform/encoding_guards.mli0000644000175100017510000000130713555524575021622 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/transform/simplify_formula.mli0000644000175100017510000000333013555524575022046 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 : keep_model_vars:bool -> Term.term -> Term.term (** transforms \exists x. x == y /\ F into F[y/x] and \forall x. x <> y \/ F into F[y/x] if [keep_model_vars] is true, then variables that hold an attribute for counterexamples are always kept. *) val simplify_trivial_quantification : Task.task Trans.trans val simplify_trivial_wp_quantification : Task.task Trans.trans (** same as [simplify_trivial_quantification] but keep variables that hold a counterexample attribute *) 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-1.2.1/src/transform/encoding.mli0000644000175100017510000000174113555524575020257 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/ide/0000755000175100017510000000000013555524575014511 5ustar guillaumeguillaumewhy3-1.2.1/src/ide/wserver.mli0000644000175100017510000000723013555524575016713 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 blocking: bool val multiplier: int val main_loop : string option -> int -> (Unix.sockaddr * string list -> string -> string -> Format.formatter -> unit) -> (string -> unit) -> unit (** [main_loop addr port callback stdin_callback] starts an elementary httpd server at port [port] in the current machine. The variable [addr] is [Some the-address-to-use] or [None] for any of the available addresses of the present machine. The port number is any number greater than 1024 (to create a client < 1024, you must be root). At each connection, the function [callback] is called as [callback (addr, request) scr cont fmt] where [addr] is the client identification socket, [request] the browser request, [scr] the script name (extracted from [request]) and [cont] the stdin contents. [fmt] is the formatter where the answer should be written, it must start by a call to [http_header] below. [stdin_callback] is called on any stdin input line received. *) val timeout: ms:int -> (unit -> bool) -> unit (** [timeout ~ms f] registers the function [f] as a function to be called every [ms] milliseconds. The function is called repeatedly until it returns false. the [ms] delay is not strictly guaranteed: it is only a minimum delay between the end of the last call and the beginning of the next call. Several functions can be registered at the same time. *) val idle: prio:int -> (unit -> bool) -> unit (** [idle prio f] registers the function [f] as a function to be called whenever there is nothing else to do. Several functions can be registered at the same time. Several functions can be registered at the same time. Functions registered with higher priority will be called first. *) val http_header : Format.formatter -> string -> unit (** [http answer] sends the http header where [answer] represents the answer status. If empty string, "200 OK" is assumed. *) val encode : string -> string (** [encode s] encodes the string [s] in another string where spaces and special characters are coded. This allows to put such strings in html links . This is the same encoding done by Web browsers in forms. *) val decode : string -> string (** [decode s] does the inverse job than [Wserver.code], restoring the initial string. *) val extract_param : string -> char -> string list -> string (** [extract_param name stopc request] can be used to extract some parameter from a browser [request] (list of strings); [name] is a string which should match the beginning of a request line, [stopc] is a character ending the request line. For example, the string request has been obtained by: [extract_param "GET /" ' ']. Answers the empty string if the parameter is not found. *) val get_request_and_content : char Stream.t -> string list * string val string_of_sockaddr : Unix.sockaddr -> string val sockaddr_of_string : string -> Unix.sockaddr why3-1.2.1/src/ide/index.html0000644000175100017510000000251413555524575016510 0ustar guillaumeguillaume Why3

Editor

Task list

Answer zone

why3-1.2.1/src/ide/resetgc.c0000644000175100017510000000266213555524575016317 0ustar guillaumeguillaume/********************************************************************/ /* */ /* The Why3 Verification Platform / The Why3 Development Team */ /* Copyright 2010-2019 -- 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-1.2.1/src/ide/ide_utils.mli0000644000175100017510000000165313555524575017202 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 History : sig type history val create_history: unit -> history val print_next_command: history -> string option val print_prev_command: history -> string option val add_command: history -> string -> unit end why3-1.2.1/src/ide/ide_utils.ml0000644000175100017510000000415613555524575017032 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 History = struct type 'a hole_list = 'a list * 'a list (* TODO this looks like we can make it more efficient either with imperative feature or by being more clever. With DLlists, we could have added a command in O(1). *) let add e l = match l with | ll, lr -> [], e :: (List.rev ll) @ lr let next l = match l with | ll, [] -> ll, [] | ll, [hd] -> ll, [hd] (* Get acts on the right list so we never empty right list *) | ll, cur :: lr -> cur :: ll, lr let prev l = match l with | hd :: ll, lr -> ll, hd :: lr | [], lr -> [], lr let get l = match l with | _, hd :: _ -> Some hd | _, [] -> None type history = {mutable lc : string hole_list; mutable tr : bool} (* tr is used to know what was the last query from user because cases for the first element of the history and other elements is not the same *) let create_history () : history = {lc = [], []; tr = false} let get_current h = get h.lc let print_next_command h = if h.tr then begin h.lc <- next h.lc; get_current h end else begin let s = get_current h in h.tr <- true; s end let print_prev_command h = if h.tr then begin h.lc <- prev h.lc; get_current h end else None let add_command h e = h.lc <- add e h.lc; h.tr <- false end why3-1.2.1/src/ide/gtkcompat2.ml0000644000175100017510000000150713555524575017121 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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/ide/gtkcompat2.ml" module GSourceView = GSourceView2 let gpango_font_description_from_string = Pango.Font.from_string why3-1.2.1/src/ide/.merlin_save0000644000175100017510000000011513555524575017013 0ustar guillaumeguillaumePKG js_of_ocaml js_of_ocaml.ppx B ../../lib/why3 B ../../src/* S ../../src/* why3-1.2.1/src/ide/gconfig.mli0000644000175100017510000001112113555524575016624 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 task_height : int; mutable font_size : int; mutable current_tab : int; mutable verbose : int; mutable show_full_context : bool; mutable show_attributes : bool; mutable show_coercions : bool; mutable show_locs : bool; mutable show_time_limit : bool; mutable max_boxes : int; mutable allow_source_editing : bool; mutable saving_policy : int; mutable premise_color : string; mutable neg_premise_color : string; mutable goal_color : string; mutable error_color : string; mutable error_color_bg : string; mutable error_line_color : string; mutable iconset : string; 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; } val load_config : Whyconf.config -> Whyconf.config -> unit (** [load_config config original_config] 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 (*******************) (* font size *) (*******************) val add_modifiable_sans_font_view : GObj.misc_ops -> unit val add_modifiable_mono_font_view : GObj.misc_ops -> unit val enlarge_fonts : unit -> unit val reduce_fonts : unit -> unit val set_fonts : unit -> unit (*****************) (* 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 : parent:#GWindow.window_skel -> unit -> unit val show_about_window : parent:#GWindow.window_skel -> unit -> unit val preferences : parent:#GWindow.window_skel -> t -> unit val uninstalled_prover_dialog : parent:#GWindow.window_skel -> callback: (Whyconf.prover -> Whyconf.prover_upgrade_policy -> unit) -> t -> Whyconf.prover -> unit (* 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-1.2.1/src/ide/gconfig.ml0000644000175100017510000013444113555524575016466 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 task_height : int; mutable font_size : int; mutable current_tab : int; mutable verbose : int; mutable show_full_context : bool; mutable show_attributes : bool; mutable show_coercions : bool; mutable show_locs : bool; mutable show_time_limit : bool; mutable max_boxes : int; mutable allow_source_editing : bool; 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 error_color_bg : string; mutable error_line_color : string; mutable iconset : string; (** colors *) mutable config : Whyconf.config; original_config : Whyconf.config; (* mutable altern_provers : altern_provers; *) (* 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; } type ide = { ide_window_width : int; ide_window_height : int; ide_tree_width : int; ide_task_height : int; ide_font_size : int; ide_current_tab : int; ide_verbose : int; ide_show_full_context : bool; ide_show_attributes : bool; ide_show_coercions : bool; ide_show_locs : bool; ide_show_time_limit : bool; ide_max_boxes : int; ide_allow_source_editing : bool; ide_saving_policy : int; ide_premise_color : string; ide_neg_premise_color : string; ide_goal_color : string; ide_error_color : string; ide_error_color_bg : string; ide_error_line_color : string; ide_iconset : 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_task_height = 400; ide_font_size = 10; ide_current_tab = 0; ide_verbose = 0; ide_show_full_context = false; ide_show_attributes = false; ide_show_coercions = true; ide_show_locs = false; ide_show_time_limit = false; ide_max_boxes = 16; ide_allow_source_editing = true; ide_saving_policy = 2; ide_premise_color = "chartreuse"; ide_neg_premise_color = "pink"; ide_goal_color = "gold"; ide_error_color_bg = "yellow"; ide_error_color = "red"; ide_error_line_color = "yellow"; ide_iconset = "fatcow"; 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_task_height = get_int section ~default:default_ide.ide_task_height "task_height"; 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_show_full_context = get_bool section ~default:default_ide.ide_show_full_context "show_full_context"; ide_show_attributes = get_bool section ~default:default_ide.ide_show_attributes "print_attributes"; ide_show_coercions = get_bool section ~default:default_ide.ide_show_attributes "print_coercions"; 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_allow_source_editing = get_bool section ~default:default_ide.ide_allow_source_editing "allow_source_editing"; 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_error_color_bg = get_string section ~default:default_ide.ide_error_color_bg "error_color_bg"; ide_error_line_color = get_string section ~default:default_ide.ide_error_line_color "error_line_color"; ide_iconset = get_string section ~default:default_ide.ide_iconset "iconset"; ide_hidden_provers = get_stringl ~default:default_ide.ide_hidden_provers section "hidden_prover"; } let set_attr_flag = let fl = Debug.lookup_flag "print_attributes" in fun b -> (if b then Debug.set_flag else Debug.unset_flag) fl let set_coercions_flag = let fl = Debug.lookup_flag "print_coercions" 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 = 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_attr_flag ide.ide_show_attributes; set_coercions_flag ide.ide_show_coercions; 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; task_height = ide.ide_task_height; current_tab = ide.ide_current_tab; font_size = ide.ide_font_size; verbose = ide.ide_verbose; show_full_context= ide.ide_show_full_context ; show_attributes = ide.ide_show_attributes ; show_coercions = ide.ide_show_coercions ; show_locs = ide.ide_show_locs ; show_time_limit = ide.ide_show_time_limit; max_boxes = ide.ide_max_boxes; allow_source_editing = ide.ide_allow_source_editing ; 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; error_color_bg = ide.ide_error_color_bg; error_line_color = ide.ide_error_line_color; iconset = ide.ide_iconset; config = config; original_config = original_config; 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; } let save_config t = Debug.dprintf debug "[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 main = get_main config in let main = set_limits main time mem nb in let main = set_default_editor main (Whyconf.default_editor new_main) in let config = set_main config main 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 "task_height" t.task_height 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 "show_full_context" t.show_full_context in let ide = set_bool ide "print_attributes" t.show_attributes in let ide = set_bool ide "print_coercions" t.show_coercions 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_bool ide "allow_source_editing" t.allow_source_editing 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 "error_color_bg" t.error_color_bg in let ide = set_string ide "error_line_color" t.error_line_color in let ide = set_string ide "iconset" t.iconset 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 -> let c = load_config conf base_conf in config := Some c) let save_config () = save_config (config ()) let get_main () = (get_main (config ()).config) (* font size *) let sans_font_family = "Sans" let mono_font_family = "Monospace" let modifiable_sans_font_views : GObj.misc_ops list ref = ref [] let modifiable_mono_font_views : GObj.misc_ops list ref = ref [] let add_modifiable_sans_font_view v = modifiable_sans_font_views := v :: !modifiable_sans_font_views let add_modifiable_mono_font_view v = modifiable_mono_font_views := v :: !modifiable_mono_font_views 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 = Gtkcompat.gpango_font_description_from_string sff in let mf = Gtkcompat.gpango_font_description_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 incr_font_size n = let c = config () in let s = max (c.font_size + n) 4 in c.font_size <- s; s let enlarge_fonts () = change_font (incr_font_size 1) let reduce_fonts () = change_font (incr_font_size (-1)) let set_fonts () = change_font (incr_font_size 0) (* 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 try ( match size with | None -> GdkPixbuf.from_file n | Some s -> GdkPixbuf.from_file_at_size ~width:s ~height:s n ) with _ -> !image_default 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 "[config] reading icons...@?"; load_icon_names (); why_icon := image "logo-why"; resize_images 20; Debug.dprintf debug " done.@." let show_legend_window ~parent () = let dialog = GWindow.dialog ~modal:true ~parent ~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_timeout_obs; i " Time limit reached, obsolete\n"; ib image_outofmemory_obs; i " Out of memory, obsolete\n"; ib image_steplimitexceeded_obs; i " Step limit exceeded, 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 ~parent () = let about_dialog = GWindow.about_dialog ~parent ~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"; "Clément Fumex"; "Léon Gondelman"; "David Hauzar"; "Daisuke Ishii"; "Johannes Kanig"; "Mikhail Mandrykin"; "David Mentré"; "Benjamin Monate"; "Kim Nguyễn"; "Thi-Minh-Tuyen Nguyen"; "Mário Pereira"; "Raphaël Rieu-Helft"; "Simão Melo de Sousa"; "Asma Tafat"; "Piotr Trojanek"; "Makarius Wenzel"; ] ~copyright:"Copyright 2010-2019 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 *) (* source editing allowed *) let source_editing_check = GButton.check_button ~label:"allow editing source files" ~packing:vb#add () ~active:c.allow_source_editing in let (_: GtkSignal.id) = source_editing_check#connect#toggled ~callback: (fun () -> c.allow_source_editing <- not c.allow_source_editing) 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 showfullcontext = GButton.check_button ~label:"show full task context" ~packing:display_options_box#add () ~active:c.show_full_context in let (_ : GtkSignal.id) = showfullcontext#connect#toggled ~callback: (fun () -> c.show_full_context <- not c.show_full_context) in let showattrs = GButton.check_button ~label:"show attributes in formulas" ~packing:display_options_box#add () ~active:c.show_attributes in let (_ : GtkSignal.id) = showattrs#connect#toggled ~callback: (fun () -> c.show_attributes <- not c.show_attributes; set_attr_flag c.show_attributes) in let showcoercions = GButton.check_button ~label:"show coercions in formulas" ~packing:display_options_box#add () ~active:c.show_coercions in let (_ : GtkSignal.id) = showcoercions#connect#toggled ~callback: (fun () -> c.show_coercions <- not c.show_coercions; set_coercions_flag c.show_coercions) 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:"Provers visible in the context menu" ~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.config.default_prover = "") () in let (_ : GtkSignal.id) = b#connect#toggled ~callback:(fun () -> c.config.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.config.default_prover) () in let (_ : GtkSignal.id) = b#connect#toggled ~callback:(fun () -> c.config.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 policies" () 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_remove -> Pp.sprintf_wnl "proofs with %a removed" print_prover p | 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 main = Whyconf.get_main c.config in let editor_entry = GEdit.entry ~text:(default_editor main) ~packing:default_editor_frame#add () in let (_ : GtkSignal.id) = editor_entry#connect#changed ~callback: (fun () -> c.config <- Whyconf.set_main c.config (Whyconf.set_default_editor main 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 ~parent (c : t) = let dialog = GWindow.dialog ~modal:true ~parent ~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); 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 "[config] end of configuration initialization@."*) let uninstalled_prover_dialog ~parent ~callback c unknown = let others,names,versions = Whyconf.unknown_to_known_provers (Whyconf.get_provers c.config) unknown in let dialog = GWindow.dialog ~icon:(!why_icon) ~modal:true ~parent ~title:"Why3: Uninstalled prover" () in let vbox = dialog#vbox 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 let height = parent#misc#allocation.Gtk.height * 3 / 4 in let scrollview = GBin.scrolled_window ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC ~height ~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 (_:GMisc.label) = 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 let (_:GMisc.label) = let text = "WARNING: this policy will not be taken into account immediately \ but only if you replay again the proofs." in GMisc.label ~text ~line_wrap:true ~packing:vbox#add () in let (_:GMisc.label) = let text = "WARNING: do not forget to save preferences to keep this policy in future sessions" in GMisc.label ~text ~line_wrap:true ~packing:vbox#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 choice_keep = GButton.radio_button ~label:"keep proofs as they are, do not try to play them" ~active:true ~packing:box#add () in let choice1 = GButton.radio_button ~label:"move proofs to the selected prover below" ~active:false ~group:choice_keep#group ~packing:box#add () in let choice2 = GButton.radio_button ~label:"duplicate proofs to the selected prover below" ~active:false ~group:choice_keep#group ~packing:box#add () in let choice3 = GButton.radio_button ~label:"remove these proofs from session" ~active:false ~group:choice_keep#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 if versions<>[] || names<>[] then begin choice_keep#set_active false; choice1#set_active true; end else hide_provers(); ignore (choice_keep#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 ())); ignore (choice3#connect#toggled ~callback:(fun () -> choice := 3; hide_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 | 3,_ -> CPU_remove | _ -> assert false in c.config <- set_prover_upgrade_policy c.config unknown policy; let () = callback unknown policy in () (* Local Variables: compile-command: "unset LANG; make -C ../.. bin/why3ide.opt" End: *) why3-1.2.1/src/ide/why3ide.js0000644000175100017510000000555013555524575016430 0ustar guillaumeguillaume function printAnswer (s) { var node = document.createElement("P"); var textnode = document.createTextNode(s); node.appendChild(textnode); document.getElementById('answers').appendChild(node); } function readBody(xhr) { var data; if (!xhr.responseType || xhr.responseType === "text") { data = xhr.responseText; } else if (xhr.responseType === "document") { data = xhr.responseXML; } else { data = xhr.response; } return data; } function interpNotif(n) { if (n != null) { switch (n["notification"]) { case "None": break; case "Initialized" : printAnswer("got initialized: TODO"); break; case "New_node" : /* printAnswer("got new node: nid = " + n.nid + " parent = " + n.parent + " type = " + n.nodetype); */ var pid ='session'; if (n.parent != n.nid) { pid = "nid"+n.parent; } else { var session = document.getElementById(pid); session.innerHTML = ""; } var parent = document.getElementById(pid); var linode = document.createElement("LI"); var textnode = document.createTextNode(n.nodetype + " " + n.name); linode.appendChild(textnode); var ulnode = document.createElement("UL"); ulnode.setAttribute('id',"nid"+n.nid); linode.appendChild(ulnode); parent.appendChild(linode); break; default: printAnswer("unsupported notification: " + n["notification"]); } } } function getNotification () { var req = new XMLHttpRequest(); req.open('GET', 'http://localhost:6789/getNotifications', true); req.onreadystatechange = function (aEvt) { if (req.readyState == XMLHttpRequest.DONE) { if(req.status == 200) { var r = readBody(req); /* printAnswer("r = |" + r + "|"); */ var a = JSON.parse(r); if (a != null) { var l = a.length; /* printAnswer("length = " + l); */ for (var n=0; n < l; n++) interpNotif(a[n]) } } else printAnswer("Erreur " + req.status); } }; req.send(null); } var notifHandler = null; function startNotificationHandler() { if (notifHandler == null) { notifHandler = setInterval(getNotification,1000); } } function stopNotificationHandler() { if (notifHandler != null) { clearInterval(notifHandler); notifHandler = null; } } function sendRequest(r) { var req = new XMLHttpRequest(); req.open('GET', 'http://localhost:6789/request?'+r, true); req.overrideMimeType('text/json'); req.onreadystatechange = function (aEvt) { if (req.readyState == XMLHttpRequest.DONE) { if(req.status == 200) printAnswer("" + readBody(req)); else printAnswer("Erreur " + req.status); } }; req.send(null); } why3-1.2.1/src/ide/why3ide.ml0000644000175100017510000025062313555524575016427 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 Format open Gconfig open Wstdlib open Ide_utils open History open Itp_communication open Gtkcompat external reset_gc : unit -> unit = "ml_reset_gc" let debug = Debug.lookup_flag "ide_info" let debug_stack_trace = Debug.lookup_flag "stack_trace" (***************************) (* Debugging Json protocol *) (***************************) (* TODO remove print_request_json and print_notification_json *) exception Badparsing let print_request_json fmt (r: ide_request) = (try ( let s = Pp.string_of Json_util.print_request r in let x = Json_util.parse_request s in if r = x then () else raise Badparsing) with _ -> Format.eprintf "Bad parsing@."); Json_util.print_request fmt r let print_notification_json fmt (n: notification) = (try ( let x = Json_util.parse_notification (Pp.string_of Json_util.print_notification n) in if n = x then () else raise Badparsing) with _ -> Format.eprintf "Bad parsing@."); Json_util.print_notification fmt n let debug_json = Debug.register_flag "json_proto" ~desc:"Print@ json@ requests@ and@ notifications@" (*******************) (* server protocol *) (*******************) module Protocol_why3ide = struct let debug_proto = Debug.register_flag "ide_proto" ~desc:"Print@ debugging@ messages@ about@ Why3Ide@ protocol@" let print_request_debug r = Debug.dprintf debug_proto "request %a@." print_request r; Debug.dprintf debug_json "%a@." print_request_json r let print_msg_debug m = Debug.dprintf debug_proto "message %a@." print_msg m let print_notify_debug n = Debug.dprintf debug_proto "handling notification %a@." print_notify n; Debug.dprintf debug_json "%a@." print_notification_json n let list_requests: ide_request list ref = ref [] let get_requests () = let n = List.length !list_requests in if n > 0 then Debug.dprintf debug_proto "got %d new requests@." n; let l = List.rev !list_requests in list_requests := []; l let send_request r = print_request_debug r; list_requests := r :: !list_requests let notification_list: notification list ref = ref [] let notify n = (* too early, print when handling notifications print_notify_debug n; *) notification_list := n :: !notification_list let get_notified () = let n = List.length !notification_list in if n > 0 then Debug.dprintf debug_proto "got %d new notifications@." n; let l = List.rev !notification_list in notification_list := []; l end let get_notified = Protocol_why3ide.get_notified let send_request r = Protocol_why3ide.send_request r (****************************************) (* server instance on the GTK scheduler *) (****************************************) (* The gtk scheduler is catching all exceptions avoiding the printing of the backtrace that is normally done by debug option stack_trace. To recover this behavior we catch exceptions ourselves. If "stack_trace" is on, we exit on first exception and print backtrace on standard output otherwise we raise the exception again (with information on error output). *) let backtrace_and_exit f () = try f () with | e -> if Debug.test_flag debug_stack_trace then begin Printexc.print_backtrace stderr; Format.eprintf "exception '%a' was raised in a LablGtk callback.@." Exn_printer.exn_printer e; exit 1 end else begin Format.eprintf "exception '%a' was raised in a LablGtk callback.@." Exn_printer.exn_printer e; Format.eprintf "This should not happen. Please report. @."; raise e end module Scheduler = struct let blocking = false let multiplier = 3 let idle ~prio f = let (_ : GMain.Idle.id) = GMain.Idle.add ~prio (backtrace_and_exit f) in () let timeout ~ms f = let (_ : GMain.Timeout.id) = GMain.Timeout.add ~ms ~callback:(backtrace_and_exit f) in () end module Server = Itp_server.Make (Scheduler) (Protocol_why3ide) (************************) (* parsing command line *) (************************) let files : string Queue.t = Queue.create () let opt_parser = ref None let opt_batch = ref None let spec = [ "-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; "--batch", Arg.String (fun s -> opt_batch := Some s), ""; ] let usage_str = sprintf "Usage: %s [options] [|]..." (Filename.basename Sys.argv.(0)) let env, 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 (********************************) (* Source language highlighting *) (********************************) let (why_lang, any_lang) = let main = Whyconf.get_main gconfig.config in let load_path = Filename.concat (Whyconf.datadir main) "lang" in let languages_manager = GSourceView.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 = 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 (****************************) (* Color handling in source *) (****************************) (* For each view, we have to recreate the tags *) let create_colors v = let premise_tag (v: GSourceView.source_view) = v#buffer#create_tag ~name:"premise_tag" [`BACKGROUND gconfig.premise_color] in let neg_premise_tag (v: GSourceView.source_view) = v#buffer#create_tag ~name:"neg_premise_tag" [`BACKGROUND gconfig.neg_premise_color] in let goal_tag (v: GSourceView.source_view) = v#buffer#create_tag ~name:"goal_tag" [`BACKGROUND gconfig.goal_color] in let error_line_tag (v: GSourceView.source_view) = v#buffer#create_tag ~name:"error_line_tag" [`BACKGROUND gconfig.error_line_color] in let error_tag (v: GSourceView.source_view) = v#buffer#create_tag ~name:"error_tag" [`BACKGROUND gconfig.error_color_bg] in let error_font_tag (v: GSourceView.source_view) = v#buffer#create_tag ~name:"error_font_tag" [`BACKGROUND gconfig.error_color] in let _ : GText.tag = premise_tag v in let _ : GText.tag = neg_premise_tag v in let _ : GText.tag = goal_tag v in let _ : GText.tag = error_line_tag v in let _ : GText.tag = error_tag v in let _ : GText.tag = error_font_tag v in () (* Erase all the source location tags in a source file *) let erase_color_loc (v:GSourceView.source_view) = let buf = v#buffer in buf#remove_tag_by_name "premise_tag" ~start:buf#start_iter ~stop:buf#end_iter; buf#remove_tag_by_name "neg_premise_tag" ~start:buf#start_iter ~stop:buf#end_iter; buf#remove_tag_by_name "goal_tag" ~start:buf#start_iter ~stop:buf#end_iter; buf#remove_tag_by_name "error_tag" ~start:buf#start_iter ~stop:buf#end_iter; buf#remove_tag_by_name "error_line_tag" ~start:buf#start_iter ~stop:buf#end_iter; buf#remove_tag_by_name "error_font_tag" ~start:buf#start_iter ~stop:buf#end_iter (*******************) (* Graphical tools *) (*******************) (* Elements needed for usage of graphical elements *) (* [quit_on_saved] set to true by exit function to delay quiting after Saved notification is received *) let quit_on_saved = ref false (* Exit brutally without asking anything *) let exit_function_unsafe () = send_request Exit_req; GMain.quit () (* Contains quadruples (tab page, source_view, file_has_been_modified, label_of_tab): - tab_page is a unique number for each pages of the notebook - source_view is the graphical element inside a tab - has_been_modified is a reference to a boolean stating if the current tab source has been modified - label_of_tab is the mutable title of the tab *) let source_view_table : (int * GSourceView.source_view * bool ref * GMisc.label) Hstr.t = Hstr.create 14 (* The corresponding file does not have a source view *) exception Nosourceview of string let get_source_view_table (file:string) = match Hstr.find source_view_table file with | v -> v | exception Not_found -> raise (Nosourceview file) (* This returns the source_view of a file *) let get_source_view (file: string) : GSourceView.source_view = match Hstr.find source_view_table file with | (_, v, _, _) -> v | exception Not_found -> raise (Nosourceview file) (* Saving function for sources *) let save_sources () = Hstr.iter (fun k (_n, (s: GSourceView.source_view), b, _l) -> if !b then let text_to_save = s#source_buffer#get_text () in send_request (Save_file_req (k, text_to_save)) ) source_view_table (* True if there exist a file which needs saving *) let files_need_saving () = Hstr.fold (fun _k (_, _, b, _) acc -> !b || acc) source_view_table false (* Ask if the user wants to save session before exit. Exit is then delayed until the [Saved] notification is received *) let exit_function_safe () = send_request Check_need_saving_req let exit_function_handler b = if not b && not (files_need_saving ()) then exit_function_unsafe () else let answer = GToolbox.question_box ~title:"Why3 saving session and files" ~buttons:["Yes"; "No"; "Cancel"] "Do you want to save the session and unsaved files?" in begin match answer with | 1 -> save_sources(); send_request Save_req; quit_on_saved := true | 2 -> exit_function_unsafe () | _ -> () end (* Update name of the tab when the label changes so that it has a * as prefix *) let update_label_change (label: GMisc.label) = let s = label#text in if not (Strings.has_prefix "*" s) then label#set_text ("*" ^ s) (* Update name of the tab when the label is saved. Removes * prefix *) let update_label_saved (label: GMisc.label) = let s = label#text in if (Strings.has_prefix "*" s) then label#set_text (String.sub s 1 (String.length s - 1)) let make_sources_editable b = Hstr.iter (fun _ (_,source_view,_,_) -> source_view#set_editable b; source_view#set_auto_indent b) source_view_table (**********************) (* Graphical elements *) (**********************) let initialization_complete = ref false 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 dir = try Server_utils.get_session_dir ~allow_mkdir:true files with Invalid_argument s -> Format.eprintf "Error: %s@." s; Whyconf.Args.exit_with_usage spec usage_str in Server.init_server gconfig.config env dir; Queue.iter (fun f -> send_request (Add_file_req f)) files; send_request Get_global_infos; Debug.dprintf debug "Init the GTK interface...@?"; ignore (GtkMain.Main.init ()); Debug.dprintf debug " done.@."; Gconfig.init () let window_title = match !opt_batch with | Some _ -> "Why3 Batch Mode" | None -> "Why3 Interactive Proof Session" let main_window : GWindow.window = let w = GWindow.window ~title:window_title () in w#resize ~width:gconfig.window_width ~height:gconfig.window_height; (* callback to record the new size of the main window when changed, so that on restart the window size is the same as the last session *) let (_ : GtkSignal.id) = w#misc#connect#size_allocate ~callback: (fun {Gtk.width=w;Gtk.height=h} -> gconfig.window_height <- h; gconfig.window_width <- w) in w (* the main window contains a vertical box, containing: 1. the menu [menubar] 2. an horizontal box [hb] *) let vbox = GPack.vbox ~packing:main_window#add () let menubar = GMenu.menu_bar ~packing:(vbox#pack ?from:None ?expand:None ?fill:None ?padding:None) () let hb = GPack.hbox ~packing:vbox#add () let accel_group = GtkData.AccelGroup.create () (* context_tools : simplified tools menu for mouse-3 *) let context_tools_menu = GMenu.menu () (****************************) (* actions of the interface *) (****************************) (***********************************) (* connection of actions to signals *) (***********************************) (* File menu signals *) let send_session_config_to_server () = let nb = gconfig.session_nb_processes in send_request (Set_config_param("max_tasks",nb)); let nb = gconfig.session_time_limit in send_request (Set_config_param("timelimit",nb)); let nb = gconfig.session_mem_limit in send_request (Set_config_param("memlimit",nb)) let (_ : GtkSignal.id) = main_window#connect#destroy ~callback:exit_function_safe let (_ : GtkSignal.id) = main_window#event#connect#delete ~callback:(fun _ -> exit_function_safe (); true) (* 2. horizontal box contains: 2.1 TODO: a tool box ? 2.2 a horizontal paned [hp] containing: 2.2.1 a scrolled window to hold the tree view of the session [scrolledview] 2.2.2 a vertical paned containing [vpan222] *) let hp = GPack.paned `HORIZONTAL ~packing:hb#add () (** {2 view for the session tree} *) let scrolled_session_view = let sv = GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ~shadow_type:`ETCHED_OUT ~packing:hp#add () in hp#set_position gconfig.tree_width; let (_ : GtkSignal.id) = sv#misc#connect#size_allocate ~callback: (fun {Gtk.width=w;Gtk.height=_h} -> gconfig.tree_width <- w) in sv (* Vertical pan *) let vpan222 = GPack.paned `VERTICAL ~packing:hp#add () (* the scrolled window 2.2.1 [scrolled_session_view] contains a GTK tree *) (** {3 the model for tree view} *) let cols = new GTree.column_list (* first column: unique id of the object *) let node_id_column = cols#add Gobject.Data.int (* second column: an icon identifying the object: file,theory, goal, transformation *) let icon_column = cols#add Gobject.Data.gobject (* third column: name of the object *) let name_column = cols#add Gobject.Data.string (* fourth column: icon status for the object: proved/unproved, unknown, timeout, etc. *) let status_column = cols#add Gobject.Data.gobject (* fifth column: extra status info: time, obsolete status, limits *) let time_column = cols#add Gobject.Data.string let column_status_title = "Status" let column_time_title = "Time" let column_goals_title = "Theories/Goals" (* first view column: icon and name *) let view_name_column = let v = GTree.view_column ~title:column_goals_title () in (* icon attribute *) let icon_renderer = GTree.cell_renderer_pixbuf [ ] in v#pack icon_renderer ~expand:false; v#add_attribute icon_renderer "pixbuf" icon_column; let name_renderer = GTree.cell_renderer_text [`XALIGN 0.] in v#pack name_renderer; v#add_attribute name_renderer "text" name_column; (* v#set_sizing `AUTOSIZE; *) v#set_resizable true; (* v#set_max_width 1000;*) v (* second view column: status *) let view_status_column = let status_renderer = GTree.cell_renderer_pixbuf [ ] in let v = GTree.view_column ~title:column_status_title ~renderer:(status_renderer, ["pixbuf", status_column]) () in v#set_resizable false; v#set_visible true; v let view_time_column = let renderer = GTree.cell_renderer_text [`XALIGN 0.] in let v = GTree.view_column ~title:column_time_title ~renderer:(renderer, ["text", time_column]) () in v#set_resizable false; v#set_visible true; v let goals_model,goals_view = Debug.dprintf debug "Creating tree model...@?"; let model = GTree.tree_store cols in let view = GTree.view ~model ~packing:scrolled_session_view#add () in let () = view#selection#set_mode (* `SINGLE *) `MULTIPLE in (* let () = view#set_rules_hint true in *) let () = view#set_enable_search false in let _: int = view#append_column view_status_column in let _: int = view#append_column view_name_column in let _: int = view#append_column view_time_column in view#set_expander_column (Some view_name_column); Debug.dprintf debug "done@."; model,view (***********************************) (* Mapping session to the GTK tree *) (***********************************) type pa_status = Controller_itp.proof_attempt_status * bool (* obsolete or not *) (* TODO *) * Call_provers.resource_limit let node_id_type : node_type Hint.t = Hint.create 17 let node_id_proved : bool Hint.t = Hint.create 17 let node_id_pa : pa_status Hint.t = Hint.create 17 let node_id_detached : bool Hint.t = Hint.create 17 let get_node_type id = Hint.find node_id_type id let get_node_proved id = try Hint.find node_id_proved id with Not_found -> false let get_node_id_pa id = Hint.find node_id_pa id let get_obs (pa_st: pa_status) = match pa_st with | _, b, _ -> b let get_proof_attempt (pa_st: pa_status) = match pa_st with | pa, _, _ -> pa let get_node_obs id = get_obs (get_node_id_pa id) let get_node_proof_attempt id = get_proof_attempt (get_node_id_pa id) let get_node_id iter = goals_model#get ~row:iter ~column:node_id_column (* To each node we have the corresponding row_reference *) let node_id_to_gtree : GTree.row_reference Hint.t = Hint.create 42 (* TODO exception for those: *) let get_node_row id = Hint.find node_id_to_gtree id let get_node_detached id = Hint.find node_id_detached id (******************************) (* Initialization of the tree *) (******************************) let remove_tree goals_model = Hint.iter (fun _x i -> try ignore(goals_model#remove (i#iter)) with _ -> ()) node_id_to_gtree let clear_tree_and_table goals_model = remove_tree goals_model; Hint.clear node_id_to_gtree; Hint.clear node_id_type; Hint.clear node_id_proved; Hint.clear node_id_pa; Hint.clear node_id_detached (**************) (* Menu items *) (**************) (* vpan222 contains: 2.2.2.1 a notebook containing view of the current task, source code etc 2.2.2.2 a vertical pan which contains [vbox2222] 2.2.2.2.1 the input field to type commands 2.2.2.2.2 a scrolled window to hold the output of the commands *) (***********************************) (* notebook on the top 2.2.2.1 *) (***********************************) (* notebook is composed of a Task page and several source files pages *) let notebook = GPack.notebook ~packing:vpan222#add () let (_ : GtkSignal.id) = vpan222#set_position gconfig.task_height; notebook#misc#connect#size_allocate ~callback: (fun {Gtk.width=_w;Gtk.height=h} -> gconfig.task_height <- h) (********************************) (* Task view (part of notebook) *) (********************************) let task_view = let label = GMisc.label ~text:"Task" () in let scrolled_task_view = GBin.scrolled_window ~hpolicy: `AUTOMATIC ~vpolicy: `AUTOMATIC ~shadow_type:`ETCHED_OUT ~packing:(fun w -> ignore(notebook#append_page ~tab_label:label#coerce w)) () in GSourceView.source_view ~editable:false ~cursor_visible:false ~show_line_numbers:true ~packing:scrolled_task_view#add () (* Creating a page for source code view *) let create_source_view = (* Counter for pages *) let n = ref 1 in (* Create a page with tabname [f] and buffer equal to [content] in the notebook. Also add a corresponding page in source_view_table. *) let create_source_view f content = if not (Hstr.mem source_view_table f) then begin let label = GMisc.label ~text:(Filename.basename f) () in label#misc#set_tooltip_markup f; let source_page (*, scrolled_source_view*) = !n (* , GPack.vbox ~homogeneous:false ~packing: (fun w -> ignore(notebook#append_page ~tab_label:label#coerce w)) () *) in let scrolled_source_view = GBin.scrolled_window ~hpolicy: `AUTOMATIC ~vpolicy: `AUTOMATIC ~shadow_type:`ETCHED_OUT (* ~packing:scrolled_source_view#add*) ~packing: (fun w -> ignore(notebook#append_page ~tab_label:label#coerce w)) () in let source_view = GSourceView.source_view ~auto_indent:gconfig.allow_source_editing ~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:gconfig.allow_source_editing ~packing:scrolled_source_view#add () in let has_changed = ref false in Hstr.add source_view_table f (source_page, source_view, has_changed, label); n := !n + 1; source_view#source_buffer#begin_not_undoable_action (); source_view#source_buffer#set_text content; source_view#source_buffer#end_not_undoable_action (); (* At initialization, file has not changed. When it changes, changes the name of the tab and update has_changed boolean. *) let (_: GtkSignal.id) = source_view#source_buffer#connect#changed ~callback:(fun () -> try let _source_page, _source_view, has_changed, label = Hstr.find source_view_table f in update_label_change label; has_changed := true; () with Not_found -> () ) in Gconfig.add_modifiable_mono_font_view source_view#misc; source_view#source_buffer#set_language why_lang; (* We have to create the tags for background colors for each view. They are not reusable from the other views. *) create_colors source_view; Gconfig.set_fonts () end in create_source_view (* End of notebook *) (* 2.2.2.2 a vertical pan which contains [vbox2222] 2.2.2.2.1 the input field to type commands [hbox22221] 2.2.2.2.2 a scrolled window to hold the output of the commands [message_zone] *) let vbox2222 = GPack.vbox ~packing:vpan222#add () (* 2.2.2.2.1 Horizontal box [hbox22221] [monitor] number of scheduled/running provers [command_entry] Commands to run on the session *) let hbox22221 = GPack.hbox ~packing:(vbox2222#pack ?from:None ?expand:None ?fill:None ?padding:None) () let monitor = GMisc.label ~text:" 0/0/0" ~width:100 ~xalign:0.0 ~packing:(hbox22221#pack ?from:None ?expand:None ?fill:None ?padding:None) () let command_entry = GEdit.entry ~text:"type commands here" ~packing:hbox22221#add () (* Part 2.2.2.2.2 contains messages returned by the IDE/server *) let messages_notebook = GPack.notebook ~packing:vbox2222#add () let error_page,error_view = let label = GMisc.label ~text:"Messages" () in 0, GPack.vbox ~homogeneous:false ~packing: (fun w -> ignore(messages_notebook#append_page ~tab_label:label#coerce w)) () let log_view = let label = GMisc.label ~text:"Log" () in GPack.vbox ~homogeneous:false ~packing: (fun w -> ignore(messages_notebook#append_page ~tab_label:label#coerce w)) () (* tab 3: edited proof *) let edited_tab = let label = GMisc.label ~text:"Edited proof" () in GPack.vbox ~homogeneous:false ~packing: (fun w -> ignore(messages_notebook#append_page ~tab_label:label#coerce w)) () let scrolled_edited_view = GBin.scrolled_window ~hpolicy: `AUTOMATIC ~vpolicy: `AUTOMATIC ~shadow_type:`ETCHED_OUT ~packing:edited_tab#add () let edited_view = GSourceView.source_view ~editable:false ~show_line_numbers:true ~packing:scrolled_edited_view#add () (* tab 4: prover output *) let output_tab = let label = GMisc.label ~text:"Prover output" () in GPack.vbox ~homogeneous:false ~packing: (fun w -> ignore(messages_notebook#append_page ~tab_label:label#coerce w)) () let scrolled_output_view = GBin.scrolled_window ~hpolicy: `AUTOMATIC ~vpolicy: `AUTOMATIC ~shadow_type:`ETCHED_OUT ~packing:output_tab#add () let output_view = GSourceView.source_view ~editable:false ~show_line_numbers:true ~packing:scrolled_output_view#add () (* tab 5: counterexample *) let counterexample_page,counterexample_tab = let label = GMisc.label ~text:"Counterexample" () in 4, GPack.vbox ~homogeneous:false ~packing: (fun w -> ignore(messages_notebook#append_page ~tab_label:label#coerce w)) () let scrolled_counterexample_view = GBin.scrolled_window ~hpolicy: `AUTOMATIC ~vpolicy: `AUTOMATIC ~shadow_type:`ETCHED_OUT ~packing:counterexample_tab#add () let counterexample_view = GSourceView.source_view ~editable:false ~show_line_numbers:true ~packing:scrolled_counterexample_view#add () (* Allow colors locations on counterexample view *) let () = create_colors counterexample_view let message_zone = let sv = GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ~shadow_type:`ETCHED_OUT ~packing:error_view#add () in GText.view ~editable:false ~cursor_visible:false ~packing:sv#add () let log_zone = let sv = GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ~shadow_type:`ETCHED_OUT ~packing:log_view#add () in GText.view ~editable:false ~cursor_visible:false ~packing:sv#add () (* Create a tag for errors in the message zone. *) let message_zone_error_tag = message_zone#buffer#create_tag ~name:"error_tag" [`BACKGROUND gconfig.error_color_bg; `FOREGROUND gconfig.error_color] (**** Message-zone printing functions *****) let add_to_log = let old = ref None in fun notif_kind s -> let (_,_,_,n) as x = match !old with | Some(line,oldnotif_kind,olds,oldn) when notif_kind = oldnotif_kind && s = olds -> let start = log_zone#buffer#get_iter (`LINE line) in let stop = log_zone#buffer#end_iter in log_zone#buffer#delete ~start ~stop; (line,oldnotif_kind,olds,oldn+1) | _ -> let line = log_zone#buffer#line_count in (line,notif_kind,s,1) in old := Some x; log_zone#buffer#insert ("["^ notif_kind); if n>1 then log_zone#buffer#insert (" (repeated " ^ (string_of_int n) ^ " times)"); log_zone#buffer#insert ("] " ^ s ^ "\n"); log_zone#scroll_to_mark `INSERT let clear_message_zone () = let buf = message_zone#buffer in buf#remove_tag_by_name "error_tag" ~start:buf#start_iter ~stop:buf#end_iter; buf#delete ~start:buf#start_iter ~stop:buf#end_iter (* Function used to print stuff on the message_zone *) let print_message ~kind ~notif_kind fmt = (* TODO: use kasprintf once OCaml 4.03 is used *) Format.kfprintf (fun _ -> let s = flush_str_formatter () in let s = try_convert s in add_to_log notif_kind s; let buf = message_zone#buffer in if kind>0 then begin if Strings.ends_with notif_kind "error" || Strings.ends_with notif_kind "Error" then buf#insert ~tags:[message_zone_error_tag] (s ^ "\n") else buf#insert (s ^ "\n"); messages_notebook#goto_page error_page; end) str_formatter fmt let display_warnings fmt warnings = let nwarn = ref 0 in try Queue.iter (fun (loc,msg) -> if !nwarn = 4 then begin Format.fprintf fmt "[%d more warnings. See stderr for details]@\n" (Queue.length warnings - !nwarn); raise Exit end; incr nwarn; match loc with | None -> Format.fprintf fmt "%s@\n@\n" msg | Some l -> (* scroll_to_loc ~color:error_tag ~yalign:0.5 loc; *) Format.fprintf fmt "%a: %s@\n@\n" Loc.gen_report_position l msg ) warnings; with Exit -> () let display_warnings () = if Queue.is_empty warnings then () else begin print_message ~kind:1 ~notif_kind:"warning" "%a" display_warnings warnings; Queue.clear warnings; end let print_message ~kind ~notif_kind fmt = display_warnings (); print_message ~kind ~notif_kind fmt (**** Monitor *****) let fan = let s = Bytes.of_string "\226\150\129" in let c = Char.code (Bytes.get s 2) in let a = Array.init 8 (fun i -> Bytes.set s 2 (Char.chr (c + i)); Bytes.to_string s) in fun n -> let n = n mod 14 in let n = if n < 0 then n + 14 else n in let n = if n >= 8 then 14 - n else n in a.(n) let update_monitor = let c = ref 0 in fun t s r -> reset_gc (); incr c; let f = if r = 0 then " " else fan !c in let text = Printf.sprintf "%s %d/%d/%d" f t s r in monitor#set_text text (**********************) (* Cursor positioning *) (**********************) (* Current position in the source files *) let current_cursor_loc = ref None let move_to_line ~yalign (v : GSourceView.source_view) line = let line = max 0 (line - 1) 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 (* Scroll to a specific locations *) let scroll_to_loc ~force_tab_switch loc_of_goal = match loc_of_goal with | None -> () | Some loc -> let f, l, _, _ = Loc.get loc in try let (n, v, _, _) = get_source_view_table f in if force_tab_switch then begin Debug.dprintf debug "tab switch to page %d@." n; notebook#goto_page n; end; move_to_line ~yalign:0.0 v l with Nosourceview f -> Debug.dprintf debug "scroll_to_loc: no source know for file %s@." f (* Reposition the cursor to the place it was saved *) let reposition_ide_cursor () = scroll_to_loc ~force_tab_switch:false !current_cursor_loc (* Save the current location of the cursor to be reused after reload *) let save_cursor_loc () = let n = notebook#current_page in let acc = ref None in Hstr.iter (fun k (x, v, _, _) -> if x = n then acc := Some (k, v)) source_view_table; match !acc with | None -> () | Some (cur_file, view) -> (* Get current line *) let line = (view#buffer#get_iter_at_mark `INSERT)#line + 1 in current_cursor_loc := Some (Loc.user_position cur_file line 1 1) (******************) (* Reload actions *) (******************) let reload_unsafe () = save_cursor_loc (); clear_message_zone (); send_request Reload_req let save_and_reload () = save_sources (); reload_unsafe () (****************************) (* command entry completion *) (****************************) let completion_cols = new GTree.column_list let completion_col = completion_cols#add Gobject.Data.string let completion_desc = completion_cols#add Gobject.Data.string let completion_model = GTree.tree_store completion_cols let command_entry_completion : GEdit.entry_completion = GEdit.entry_completion ~model:completion_model ~minimum_key_length:2 ~entry:command_entry () let add_completion_entry (s,desc) = let row = completion_model#append () in completion_model#set ~row ~column:completion_col s; completion_model#set ~row ~column:completion_desc desc let match_function s iter = let candidate = completion_model#get ~row:iter ~column:completion_col in try ignore (Str.search_forward (Str.regexp_string_case_fold s) candidate 0); true with Not_found -> false (* see also init_completion below *) (*********************) (* Terminal history *) (*********************) let list_commands = create_history() let _ = command_entry#event#connect#key_press ~callback:(fun (ev: 'a Gdk.event) -> match GdkEvent.Key.keyval ev with | k when k = GdkKeysyms._Up -> (* Arrow up *) let s = print_next_command list_commands in (match s with | None -> true | Some s -> (command_entry#set_text s; true)) | k when k = GdkKeysyms._Down -> (* Arrow down *) let s = print_prev_command list_commands in (match s with | None -> true | Some s -> (command_entry#set_text s; true)) | k when k = GdkKeysyms._Escape -> goals_view#misc#grab_focus (); true | _ -> false ) let () = send_session_config_to_server () (********************) (* Locations colors *) (********************) let convert_color (color: color): string = match color with | Neg_premise_color -> "neg_premise_tag" | Premise_color -> "premise_tag" | Goal_color -> "goal_tag" | Error_color -> "error_tag" | Error_line_color -> "error_line_tag" | Error_font_color -> "error_font_tag" let color_line ~color loc = let color_line (v:GSourceView.source_view) ~color l = let buf = v#buffer in let top = buf#start_iter in let start = top#forward_lines (l-1) in let stop = start#forward_lines 1 in buf#apply_tag_by_name ~start ~stop color in let f, l, _, _ = Loc.get loc in try let v = get_source_view f in let color = convert_color color in color_line ~color v l with | Nosourceview f -> (* If the file is not present do nothing *) print_message ~kind:0 ~notif_kind:"color_loc" "No source view for file %s" f; Debug.dprintf debug "color_loc: no source view for file %s@." f (* Add a color tag on the right locations on the correct file. If the file was not open yet, nothing is done *) let color_loc ?(ce=false) ~color loc = (* This apply a background [color] on a location given by its file view [v] line [l] beginning char [b] and end char [e]. *) let color_loc (v:GSourceView.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_by_name ~start ~stop color in let f, l, b, e = Loc.get loc in try let v = if ce then counterexample_view else get_source_view f in let color = convert_color color in color_loc ~color v l b e with | Nosourceview f -> (* If the file is not present do nothing *) print_message ~kind:0 ~notif_kind:"color_loc" "No source view for file %s" f; Debug.dprintf debug "color_loc: no source view for file %s@." f (* Erase the colors and apply the colors given by l (which come from the task) to appropriate source files *) let apply_loc_on_source (l: (Loc.position * color) list) = Hstr.iter (fun _ (_, v, _, _) -> erase_color_loc v) source_view_table; List.iter (fun (loc, color) -> color_loc ~color loc) l; let loc_of_goal = (* TODO the last location sent seems more relevant thus the rev. This should be changed, the sent task should contain the information of where to scroll and the list of locations is far too long. *) try Some (List.find (fun (_, color) -> color = Goal_color) (List.rev l)) with Not_found -> None in scroll_to_loc ~force_tab_switch:false (Opt.map fst loc_of_goal) (* Erase the colors and apply the colors given by l (which come from the task) to the counterexample tab *) let apply_loc_on_ce (l: (Loc.position * color) list) = erase_color_loc counterexample_view; List.iter (fun (loc, color) -> color_loc ~ce:true ~color loc) l let collapse_iter iter = let path = goals_model#get_path iter in goals_view#collapse_row path let rec collapse_proven_goals_from_iter iter = let node_id = get_node_id iter in let is_proved = get_node_proved node_id in if is_proved then collapse_iter iter else let n = goals_model#iter_n_children (Some iter) in for i = 0 to (n - 1) do collapse_proven_goals_from_iter (goals_model#iter_children ?nth:(Some i) (Some iter)) done let collapse_proven_goals () = match goals_model#get_iter_first with | None -> () | Some root_iter -> collapse_proven_goals_from_iter root_iter let () = Gconfig.add_modifiable_sans_font_view goals_view#misc; Gconfig.add_modifiable_mono_font_view monitor#misc; Gconfig.add_modifiable_mono_font_view task_view#misc; Gconfig.add_modifiable_mono_font_view edited_view#misc; Gconfig.add_modifiable_mono_font_view output_view#misc; Gconfig.add_modifiable_mono_font_view counterexample_view#misc; Gconfig.add_modifiable_mono_font_view command_entry#misc; Gconfig.add_modifiable_mono_font_view message_zone#misc; task_view#source_buffer#set_language why_lang; counterexample_view#source_buffer#set_language why_lang; Gconfig.set_fonts () (******************) (* actions *) (******************) let get_selected_row_references () = List.map (fun path -> goals_model#get_row_reference path) goals_view#selection#get_selected_rows (**********************) (* Contextual actions *) (**********************) (* goals_view#selection#select_iter only changes the selection for the selection tree, it should also change the cursor of the goal_view. The reason is that the cursor is used for arrow keys moves (not the selected row). *) let select_iter iter = goals_view#selection#select_iter iter; let path = goals_model#get_path iter in goals_view#set_cursor path view_name_column let expand_row () = let rows = get_selected_row_references () in match rows with | [row] -> let path = goals_model#get_path row#iter in goals_view#expand_row path ~all:(goals_view#row_expanded path) | _ -> () let collapse_row () = let rows = get_selected_row_references () in match rows with | [row] -> let path = goals_model#get_path row#iter in goals_view#collapse_row path | _ -> () let move_current_row_selection_to_parent () = let rows = get_selected_row_references () in match rows with | [row] -> begin goals_view#selection#unselect_all (); match goals_model#iter_parent row#iter with | None -> () | Some iter -> select_iter iter end | _ -> () let move_current_row_selection_to_first_child () = let rows = get_selected_row_references () in match rows with | [row] -> let n = goals_model#iter_n_children (Some row#iter) in if n = 0 then () else begin goals_view#selection#unselect_all (); let iter = goals_model#iter_children ?nth:(Some 0) (Some row#iter) in select_iter iter end | _ -> () let move_current_row_selection_to_down () = let rows = get_selected_row_references () in match rows with | [row] -> let path = goals_model#get_path row#iter in GtkTree.TreePath.down path; goals_view#selection#unselect_all (); goals_view#selection#select_path path; goals_view#set_cursor path view_name_column | _ -> () let move_current_row_selection_to_next () = let rows = get_selected_row_references () in match rows with | [row] -> let path = goals_model#get_path row#iter in GtkTree.TreePath.next path; goals_view#selection#unselect_all (); goals_view#selection#select_path path; goals_view#set_cursor path view_name_column | _ -> () let move_to_next_unproven_node_id () = let rows = get_selected_row_references () in match rows with | [row] -> let row_id = get_node_id row#iter in send_request (Get_first_unproven_node row_id) | _ -> () (* unused let rec update_status_column_from_iter cont iter = set_status_column iter; match goals_model#iter_parent iter with | Some p -> update_status_column_from_iter cont p | None -> () *) let clear_command_entry () = command_entry#set_text "" let ide_command_list = ["up", "Select the parent of the current node"; "down", "Select the first child of the current node"; "next", "Select the \"next\" unproved node"; "expand", "Expand the node"; "ex_all", "Expand the node recursively"; "collapse", "Collapse the node"; "list_ide_command", "show this help text"] let ide_command cmd = List.exists (fun x -> fst x = cmd) ide_command_list let interp_ide cmd = match cmd with | "up" -> move_current_row_selection_to_parent () | "down" -> move_current_row_selection_to_first_child () | "next" -> move_to_next_unproven_node_id () | "expand" -> expand_row () | "collapse" -> collapse_row () | "list_ide_command" -> let s = List.fold_left (fun acc x -> (fst x) ^ ": " ^ (snd x) ^ "\n" ^ acc) "" ide_command_list in clear_command_entry (); print_message ~kind:1 ~notif_kind:"Info" "%s" s | _ -> clear_command_entry (); print_message ~kind:1 ~notif_kind:"error" "Error: %s\nPlease report." cmd let interp cmd = (* TODO: do some preprocessing for queries, or leave everything to server ? *) message_zone#buffer#set_text ""; clear_command_entry (); if ide_command cmd then interp_ide cmd else begin let rows = get_selected_row_references () in let ids = match rows with | [] -> [root_node] | _ -> List.map (fun n -> get_node_id n#iter) rows in List.iter (fun id -> send_request (Command_req (id, cmd))) ids; (* clear previous error message if any *) end let (_ : GtkSignal.id) = let callback () = let cmd = command_entry#text in match cmd with | "" -> goals_view#misc#grab_focus () | _ -> begin add_command list_commands cmd; interp cmd end in command_entry#connect#activate ~callback (* remove the helper text from the command entry the first time it gets the focus *) let () = let id = ref None in let callback _ = clear_command_entry (); GtkSignal.disconnect command_entry#as_entry (Opt.get !id); false in id := Some (command_entry#event#connect#focus_in ~callback) let on_selected_row r = try let id = get_node_id r#iter in let typ = get_node_type id in match typ with | NGoal -> let c = gconfig.show_full_context in send_request (Get_task(id,c,true)) | NProofAttempt -> let (pa, _obs, _l) = Hint.find node_id_pa id in let output_text = match pa with | Controller_itp.Done pr -> pr.Call_provers.pr_output | Controller_itp.Undone -> "no result known" | Controller_itp.Detached -> "detached proof attempt: parent goal has no task" | Controller_itp.Interrupted -> "prover run was interrupted" | Controller_itp.Scheduled -> "proof scheduled but not running yet" | Controller_itp.Running -> "prover currently running" | Controller_itp.InternalFailure e -> (Pp.sprintf "internal failure: %a" Exn_printer.exn_printer e) | Controller_itp.Uninstalled _p -> "uninstalled prover" | Controller_itp.Removed _p -> "removed proof attempt" | Controller_itp.UpgradeProver _p -> "upgraded prover" in let output_text = if output_text = "" then "(no output known, you may consider running the prover again)" else output_text in output_view#source_buffer#set_text output_text; edited_view#source_buffer#set_text "(not yet available)"; edited_view#scroll_to_mark `INSERT; counterexample_view#source_buffer#set_text "(not yet available)"; counterexample_view#scroll_to_mark `INSERT; let c = gconfig.show_full_context in send_request (Get_task(id,c,true)) | _ -> let c = gconfig.show_full_context in send_request (Get_task(id,c,true)) with | Not_found -> task_view#source_buffer#set_text "" let (_ : GtkSignal.id) = goals_view#selection#connect#after#changed ~callback: (fun () -> Debug.dprintf debug "running callback of goals_view#selection#connect#after#changed@."; begin match get_selected_row_references () with | [r] -> on_selected_row r; | _ -> () end (* ; command_entry#misc#grab_focus () *)) let (_ : GtkSignal.id) = let callback ev = Debug.dprintf debug "running callback of goals_view#event#connect#button_press@."; let n = GdkEvent.Button.button ev in begin Debug.dprintf debug "button number %d was clicked on the tree view@." n; match n with | 3 -> (* Right click *) let sel = goals_view#selection in let x = int_of_float (GdkEvent.Button.x ev) in let y = int_of_float (GdkEvent.Button.y ev) in begin match goals_view#get_path_at_pos ~x ~y with | Some (path,_,_,_) when not (sel#path_is_selected path) -> sel#unselect_all (); sel#select_path path | _ -> () end; context_tools_menu#popup ~button:3 ~time:(GdkEvent.Button.time ev); true | 1 -> (* Left click *) (* Call get-ce only when clicked on the Status of a proofattempt (which is unproved) *) let x = int_of_float (GdkEvent.Button.x ev) in let y = int_of_float (GdkEvent.Button.y ev) in begin match goals_view#get_path_at_pos ~x ~y with | Some (path,col,_,_) -> if col#title = column_status_title then let node_id = get_node_id (goals_model#get_row_reference path)#iter in let type_id = get_node_type node_id in let proved_id = get_node_proved node_id in if type_id = NProofAttempt && not proved_id then send_request (Command_req (node_id, "get-ce")) | _ -> () end; false | _ -> (* Other buttons *) false end in goals_view#event#connect#button_press ~callback let (_ : GtkSignal.id) = let callback ev = match GdkEvent.Key.keyval ev with | k when k = GdkKeysyms._Return -> command_entry#misc#grab_focus (); true | _ -> false in goals_view#event#connect#key_press ~callback (*********************************) (* 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 ~request = 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 -> request f end | `DELETE_EVENT | `CANCEL -> () end ; d#destroy () (*************************) (* Notification Handling *) (*************************) let treat_message_notification msg = match msg with (* TODO: do something ! *) | Proof_error (_id, s) -> print_message ~kind:1 ~notif_kind:"Proof_error" "%s" s | Transf_error (true, _id, tr_name, _arg, _loc, msg, _doc) -> (* When the error reported by the transformation is fatal, we notify the user with a popup. *) let msg = Format.sprintf "Please report:\nTransformation %s failed: \n%s\n" tr_name msg in GToolbox.message_box ~title:"Why3 fatal error" msg | Transf_error (false, _id, tr_name, arg, loc, msg, doc) -> if arg = "" then print_message ~kind:1 ~notif_kind:"Transformation Error" "%s\nTransformation failed: \n%s\n\n%s" msg tr_name doc else begin let buf = message_zone#buffer in print_message ~kind:1 ~notif_kind:"Transformation Error" "%s\nTransformation failed. \nOn argument: \n%s \n%s\n\n%s" tr_name arg msg doc; (* remove all coloration in message_zone before coloring *) buf#remove_tag_by_name "error_tag" ~start:buf#start_iter ~stop:buf#end_iter; let color = "error_tag" in let _, _, beg_char, end_char = Loc.get loc in let start = buf#start_iter#forward_lines 3 in buf#apply_tag_by_name ~start:(start#forward_chars beg_char) ~stop:(start#forward_chars end_char) color end | Strat_error (_id, s) -> print_message ~kind:1 ~notif_kind:"Strat_error" "%s" s | Replay_Info s -> print_message ~kind:0 ~notif_kind:"Replay_info" "%s" s | Query_Info (_id, s) -> print_message ~kind:1 ~notif_kind:"Query_info" "%s" s | Query_Error (_id, s) -> print_message ~kind:1 ~notif_kind:"Query_error" "%s" s | Information s -> print_message ~kind:1 ~notif_kind:"Information" "%s" s | Task_Monitor (t, s, r) -> update_monitor t s r | Open_File_Error s -> print_message ~kind:0 ~notif_kind:"Open_File_Error" "%s" s | Parse_Or_Type_Error (loc, _rel_loc, s) -> if gconfig.allow_source_editing || !initialization_complete then begin scroll_to_loc ~force_tab_switch:true (Some loc); color_line ~color:Error_line_color loc; color_loc ~color:Error_font_color loc; print_message ~kind:1 ~notif_kind:"Parse_Or_Type_Error" "%s" s end else begin Format.eprintf "%a: %s@." Loc.gen_report_position loc s; exit 1 end | File_Saved f -> begin try let (_source_page, _source_view, b, l) = Hstr.find source_view_table f in b := false; update_label_saved l; print_message ~kind:1 ~notif_kind:"File_Saved" "%s was saved" f with | Not_found -> print_message ~kind:1 ~notif_kind:"File_Saved" "Please report: %s was not found in IDE but was saved in session" f end | Error s -> print_message ~kind:1 ~notif_kind:"General request failure" "%s" s let is_selected_alone id = match get_selected_row_references () with | [r] -> let i = get_node_id r#iter in i = id | _ -> false (**************************) (* Graphical proof status *) (**************************) let image_of_pa_status ~obsolete pa = match pa with | Controller_itp.Undone | Controller_itp.Interrupted -> !image_undone | Controller_itp.Scheduled -> !image_scheduled | Controller_itp.Running -> !image_running | Controller_itp.InternalFailure _e -> !image_failure | Controller_itp.Detached -> !image_undone (* TODO !image_detached *) | Controller_itp.Uninstalled _p -> !image_undone (* TODO !image_uninstalled *) | Controller_itp.Removed _p -> !image_undone (* TODO !image_removed *) | Controller_itp.UpgradeProver _p -> !image_undone | Controller_itp.Done r -> let pr_answer = r.Call_provers.pr_answer in begin match 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 end module S = Session_itp module C = Controller_itp (* Returns true if the current row is an ancestor of the selected row *) let selected_ancestor row = match get_selected_row_references () with | [selected_row] -> not (goals_model#is_ancestor ~iter:row#iter ~descendant:selected_row#iter) | _ -> false let set_status_and_time_column ?limit row = let id = get_node_id row#iter in let proved = get_node_proved id in let detached = get_node_detached id in let image = match get_node_type id with | NRoot -> assert false | NFile | NTheory | NTransformation | NGoal -> if detached then begin goals_model#set ~row:row#iter ~column:time_column "(detached)"; !image_valid_obs end else if proved then begin Debug.dprintf debug "Collapsing row for proved node %d@." id; (* We should only collapse if it does not collapse the selected row because collapsing unselects the focused row in this case. *) if selected_ancestor row then goals_view#collapse_row (goals_model#get_path row#iter); !image_valid end else begin (* goals_view#expand_row (goals_model#get_path row#iter); *) !image_unknown end | NProofAttempt -> let pa = get_node_proof_attempt id in let obs = get_node_obs id in let t = match pa with | C.Done r -> let time = r.Call_provers.pr_time in let steps = r.Call_provers.pr_steps in let s = if gconfig.show_time_limit then match limit with | Some l -> Format.sprintf "%.2f [%d.0]" time (l.Call_provers.limit_time) | None -> Format.sprintf "%.2f" time else Format.sprintf "%.2f" time in if steps >= 0 then Format.sprintf "%s (steps: %d)" s steps else s | C.InternalFailure _ -> "(internal failure)" | C.Interrupted -> "(interrupted)" | C.Undone -> "(undone)" | C.Uninstalled _ -> "(uninstalled prover)" | C.UpgradeProver _ -> "(upgraded prover)" | C.Removed _ -> "(removed prover)" | C.Scheduled -> "(scheduled)" | C.Running -> "(running)" | C.Detached -> "(detached)" in let t = match pa with | C.Scheduled | C.Running -> begin match limit with | Some l -> t ^ Format.sprintf " [limit=%d sec., %d M]" (l.Call_provers.limit_time) (l.Call_provers.limit_mem) | None -> t ^ " [no limit known]" end | _ -> t in let t = if obs then t ^ " (obsolete)" else t in let t = if detached then t ^ " (detached)" else t in goals_model#set ~row:row#iter ~column:time_column t; image_of_pa_status ~obsolete:obs pa in goals_model#set ~row:row#iter ~column:status_column image let new_node ?parent id name typ detached = if not (Hint.mem node_id_to_gtree id) then begin Hint.add node_id_type id typ; Hint.add node_id_detached id detached; (* The tree does not have a root by default so the task is a forest with several root files *) let iter = match parent with | None -> goals_model#append () | Some p -> goals_model#append ~parent:p#iter () in goals_model#set ~row:iter ~column:name_column name; goals_model#set ~row:iter ~column:node_id_column id; goals_model#set ~row:iter ~column:icon_column (match typ with | NGoal -> !image_goal | NRoot | NFile -> !image_file | NTheory -> !image_theory | NTransformation -> !image_transf | NProofAttempt -> !image_prover); let path = goals_model#get_path iter in let new_ref = goals_model#get_row_reference path in Hint.add node_id_to_gtree id new_ref; set_status_and_time_column new_ref; new_ref end else Hint.find node_id_to_gtree id let on_selected_rows ~multiple ~notif_kind ~action f () = match get_selected_row_references () with | [] -> print_message ~kind:1 ~notif_kind "Select at least one node to perform the '%s' action" action | _ :: _ :: _ when not multiple -> print_message ~kind:1 ~notif_kind "Select at most one node to perform the '%s' action" action | l -> List.iter (fun r -> send_request (f (get_node_id r#iter))) l (**************************) (* Helpers for menu items *) (**************************) let remove_mnemonic s = try let j = ref (String.index s '_') in let i = ref 0 in let n = String.length s in let b = Buffer.create n in try while true do Buffer.add_substring b s !i (!j - !i); i := !j + 1; if !i = n then raise Not_found; Buffer.add_char b s.[!i]; incr i; j := String.index_from s !i '_'; done; assert false with Not_found -> Buffer.add_substring b s !i (n - !i); Buffer.contents b with Not_found -> s class menu_factory ~accel_path:menu_path ~accel_group:menu_group menu = object (self) method add_item ?accel_path ?(accel_group=menu_group) ?modi ?key ?(use_mnemonic=true) ?(add_accel=true) ?tooltip ?callback label = let item = GtkMenu.MenuItem.create ~use_mnemonic ~label () in let item = new GMenu.menu_item item in item#misc#show (); menu#append item; if add_accel || accel_path <> None then begin let accel_path = match accel_path with | None -> menu_path ^ (if use_mnemonic then remove_mnemonic label else label) | Some ap -> ap in if add_accel then GtkData.AccelMap.add_entry accel_path ?key ?modi; GtkBase.Widget.set_accel_path item#as_widget accel_path accel_group end; Opt.iter (fun callback -> let _ = item#connect#activate ~callback in ()) callback; Opt.iter item#misc#set_tooltip_markup tooltip; item method add_separator () = let item = GtkMenu.MenuItem.separator_create () in let item = new GMenu.menu_item item in item#misc#show (); menu#append item; () method add_submenu ?use_mnemonic label = let m = GtkMenu.Menu.create [] in let m = new GMenu.menu m in m#misc#show (); let item = self#add_item ?use_mnemonic ~add_accel:false label in item#set_submenu m; m end (*************) (* Main menu *) (*************) let tools_accel_group = GtkData.AccelGroup.create () let factory = new menu_factory ~accel_path:"/" ~accel_group menubar let context_factory = new menu_factory context_tools_menu ~accel_path:"" ~accel_group:tools_accel_group let connect_menu_item i ~callback = let (_ : GtkSignal.id) = i#connect#activate ~callback in () (* "File" menu items *) let file_menu = factory#add_submenu "_File" let file_factory = new menu_factory file_menu ~accel_path:"/File/" ~accel_group let (_: GMenu.menu_item) = file_factory#add_item "Add file to session" ~tooltip:"Insert another file in the current session" ~callback:(fun () -> select_file ~request:(fun f -> send_request (Add_file_req f))) let (_: GMenu.menu_item) = let callback () = Gconfig.preferences ~parent:main_window gconfig; make_sources_editable gconfig.allow_source_editing; send_session_config_to_server () in file_factory#add_item "Preferences" ~tooltip:"Open Preferences Window" ~callback let (_: GMenu.menu_item) = file_factory#add_item "Save session" ~tooltip:"Save the current proof session on disk" ~callback:(fun () -> send_request Save_req) let (_: GMenu.menu_item) = file_factory#add_item "Save files" ~tooltip:"Save the edited source files on disk" ~callback:save_sources let (_: GMenu.menu_item) = file_factory#add_item "_Save session and files" ~modi:[`CONTROL] ~key:GdkKeysyms._S ~tooltip:"Save the current proof session and the source files" ~callback:(fun () -> save_sources(); send_request Save_req) let (_: GMenu.menu_item) = file_factory#add_item "Save all and _Refresh session" ~modi:[`CONTROL] ~key:GdkKeysyms._R ~tooltip:"Save the current proof session and the source files, then refresh the proof session with updated source files." ~callback:save_and_reload let (_: GMenu.menu_item) = file_factory#add_item "_Quit" ~modi:[`CONTROL] ~key:GdkKeysyms._Q ~tooltip:"See the Preferences for setting the policy on automatic file saving at exit." ~callback:exit_function_safe (* "Tools" menu items *) let tools_menu = factory#add_submenu "_Tools" let tools_factory = new menu_factory tools_menu ~accel_path:"/Tools/" ~accel_group:tools_accel_group let strategies_factory = let tools_submenu_strategies = tools_factory#add_submenu "Strategies" in tools_factory#add_separator (); new menu_factory tools_submenu_strategies ~accel_path:"/Tools/Strategies/" ~accel_group:tools_accel_group let provers_factory = let tools_submenu_provers = tools_factory#add_submenu "Provers" in tools_factory#add_separator (); new menu_factory tools_submenu_provers ~accel_path:"/Tools/Provers/" ~accel_group:tools_accel_group (* "View" menu items *) let view_menu = factory#add_submenu "_View" let view_factory = new menu_factory ~accel_path:"/View/" ~accel_group view_menu let (_ : GMenu.menu_item) = view_factory#add_item "Enlarge font" ~modi:[`CONTROL] ~key:GdkKeysyms._plus ~callback:enlarge_fonts let (_ : GMenu.menu_item) = view_factory#add_item "Reduce font" ~modi:[`CONTROL] ~key:GdkKeysyms._minus ~callback:reduce_fonts let (_: GMenu.menu_item) = view_factory#add_item "Collapse proven goals" ~accel_group:tools_accel_group ~key:GdkKeysyms._exclam ~tooltip:"Collapse all the proven nodes under the current node" ~callback:collapse_proven_goals let (_: GMenu.menu_item) = view_factory#add_item "Expand all" ~tooltip:"Expand all nodes of the tree view" ~callback:goals_view#expand_all let (_: GMenu.menu_item) = view_factory#add_item "Collapse current node" ~accel_group:tools_accel_group ~key:GdkKeysyms._minus ~callback:collapse_row let (_: GMenu.menu_item) = view_factory#add_item "Expand current node" ~accel_group:tools_accel_group ~key:GdkKeysyms._plus ~tooltip:"Expand current node, or its children when already expanded" ~callback:expand_row let (_: GMenu.menu_item) = view_factory#add_item "Go to parent node" ~modi:[`CONTROL] ~key:GdkKeysyms._Up ~callback:move_current_row_selection_to_parent let (_: GMenu.menu_item) = view_factory#add_item "Go to first child" ~callback:move_current_row_selection_to_first_child let (_: GMenu.menu_item) = view_factory#add_item "Select next unproven goal" ~modi:[`CONTROL] ~key:GdkKeysyms._Down ~callback:move_to_next_unproven_node_id (* "Help" menu items *) let help_menu = factory#add_submenu "_Help" let help_factory = new menu_factory help_menu ~accel_path:"/Help/" ~accel_group let (_ : GMenu.menu_item) = help_factory#add_item "Legend" ~callback:(show_legend_window ~parent:main_window) let (_ : GMenu.menu_item) = help_factory#add_item "About" ~callback:(show_about_window ~parent:main_window) (*****************************************************************) (* "Tools" submenus for strategies, provers, and transformations *) (*****************************************************************) let string_of_desc desc = let print_trans_desc fmt (x,r) = fprintf fmt "@[%s@\n%a@]" x Pp.formatted r in Glib.Markup.escape_text (Pp.string_of print_trans_desc desc) let parse_shortcut_as_key s = let (key,modi) as r = GtkData.AccelGroup.parse s in begin if key = 0 then Debug.dprintf debug "Shortcut '%s' cannot be parsed as a key@." s else let name = GtkData.AccelGroup.name ~key ~modi in Debug.dprintf debug "Shortcut '%s' parsed as key '%s'@." s name end; r let add_submenu_strategy (shortcut,strategy) = let callback () = Debug.dprintf debug "interp command '%s'@." strategy; interp strategy in let name = String.map (function '_' -> ' ' | c -> c) strategy in let tooltip = "run strategy " ^ strategy ^ " on selected goal" in let accel_path = "/Tools/Strategies/" ^ name in let (key, modi) = parse_shortcut_as_key shortcut in let (_ : GMenu.menu_item) = strategies_factory#add_item name ~use_mnemonic:false ~accel_path ~key ~modi ~tooltip ~callback in let (_ : GMenu.menu_item) = context_factory#add_item name ~use_mnemonic:false ~accel_path ~add_accel:false ~tooltip ~callback in () let add_submenu_prover (shortcut,prover_name,prover_parseable_name) = let callback () = Debug.dprintf debug "interp command '%s'@." prover_parseable_name; interp prover_parseable_name in let tooltip = "run prover " ^ prover_name ^ " on selected goal" in let accel_path = "/Tools/Provers/" ^ prover_name in let (key,modi) = parse_shortcut_as_key shortcut in let (_ : GMenu.menu_item) = provers_factory#add_item prover_name ~use_mnemonic:false ~accel_path ~key ~modi ~tooltip ~callback in if not (List.mem prover_parseable_name gconfig.hidden_provers) then let (_ : GMenu.menu_item) = context_factory#add_item prover_name ~use_mnemonic:false ~accel_path ~add_accel:false ~tooltip ~callback in () let init_completion provers transformations strategies commands = (* add the names of all the the transformations *) List.iter add_completion_entry transformations; (* add the name of the commands *) List.iter (fun s -> add_completion_entry (s,"command")) commands; (* todo: add queries *) (* add provers *) let all_strings = List.fold_left (fun acc (s,_,p) -> Debug.dprintf debug "string for completion: '%s' '%s'@." s p; let acc = (p,"prover") :: acc in if s = "" then acc else (s,"shortcut for prover "^p) :: acc) [] provers in List.iter add_completion_entry all_strings; let provers_sorted = List.sort (fun (_,h1,_) (_,h2,_) -> String.compare (Strings.lowercase h1) (Strings.lowercase h2)) provers in (* Remove counterexample provers from the menu *) let menu_provers = List.filter (fun (_, _, s) -> not (Strings.ends_with s "counterexamples")) provers_sorted in List.iter add_submenu_prover menu_provers; context_factory#add_separator (); let all_strings = List.fold_left (fun acc (shortcut,strategy) -> Debug.dprintf debug "string for completion: '%s' '%s'@." shortcut strategy; let acc = (strategy, "strategy") :: acc in if shortcut = "" then acc else (shortcut, "shortcut for strategy "^strategy) :: acc) [] strategies in List.iter add_completion_entry all_strings; List.iter add_submenu_strategy strategies; command_entry_completion#set_text_column completion_col; (* Adding a column which contains the description of the prover/transformation/strategy. *) let name_renderer = GTree.cell_renderer_text [ ] in name_renderer#set_properties [`BACKGROUND "lightgrey"]; command_entry_completion#pack name_renderer; command_entry_completion#add_attribute name_renderer "text" completion_desc; command_entry_completion#set_match_func match_function; command_entry#set_completion command_entry_completion let () = let transformations = Server_utils.list_transforms () in let add_submenu_transform name filter = let submenu = tools_factory#add_submenu name in let submenu = new menu_factory submenu ~accel_path:("/Tools/" ^ name ^ "/") ~accel_group:tools_accel_group in let iter ((name,_) as desc) = let (_ : GMenu.menu_item) = submenu#add_item (Glib.Markup.escape_text name) ~use_mnemonic:false ~tooltip:(string_of_desc desc) ~callback:(fun () -> interp name) in () in let trans = List.filter filter transformations in List.iter iter trans in add_submenu_transform "Transformations (a-e)" (fun (x,_) -> x < "eliminate"); add_submenu_transform "Transformations (eliminate)" (fun (x,_) -> x >= "eliminate" && x < "eliminatf"); add_submenu_transform "Transformations (e-r)" (fun (x,_) -> x >= "eliminatf" && x < "s"); add_submenu_transform "Transformations (s-z)" (fun (x,_) -> x >= "s"); tools_factory#add_separator () (* complete the tools menu *) let (_ : GMenu.menu_item) = let callback = on_selected_rows ~multiple:false ~notif_kind:"Edit error" ~action:"edit" (fun id -> Command_req (id, "edit")) in tools_factory#add_item "_Edit" ~key:GdkKeysyms._E ~tooltip:"View or edit proof script" ~callback let (_ : GMenu.menu_item) = let callback = on_selected_rows ~multiple:false ~notif_kind:"get-ce error" ~action:"Get Counterexamples" (fun id -> Command_req (id, "get-ce")) in tools_factory#add_item "_Get Counterexamples" ~key:GdkKeysyms._G ~tooltip:"Launch the prover with counterexamples" ~callback let (_ : GMenu.menu_item) = let callback = on_selected_rows ~multiple:false ~notif_kind:"Replay error" ~action:"replay" (fun id -> Command_req (id, "replay")) in tools_factory#add_item "_Replay valid obsolete proofs" ~key:GdkKeysyms._R ~tooltip:"Replay valid obsolete proofs under the current node" ~callback let (_ : GMenu.menu_item) = let callback = on_selected_rows ~multiple:false ~notif_kind:"Replay error" ~action:"replay all" (fun id -> Command_req (id, "replay all")) in tools_factory#add_item "Replay all obsolete proofs" ~tooltip:"Replay all obsolete proofs under the current node" ~callback let (_ : GMenu.menu_item) = let callback = on_selected_rows ~multiple:false ~notif_kind:"Clean error" ~action:"clean" (fun id -> Command_req (id, "clean")) in tools_factory#add_item "_Clean node" ~key:GdkKeysyms._C ~tooltip:"Remove unsuccessful proofs or transformations that are under a proved goal" ~callback let (_ : GMenu.menu_item) = let callback = on_selected_rows ~multiple:true ~notif_kind:"Remove_subtree error" ~action:"remove" (fun id -> Remove_subtree id) in tools_factory#add_item "Remove node" ~key:GdkKeysyms._Delete ~tooltip:"Remove the selected proof attempts or transformations" ~callback let (_ : GMenu.menu_item) = let callback = on_selected_rows ~multiple:true ~notif_kind:"Mark_obsolete error" ~action:"mark obsolete" (fun id -> Command_req (id, "mark")) in tools_factory#add_item "Mark _obsolete" ~key:GdkKeysyms._O ~tooltip:"Mark all proof attempts under the current node as obsolete" ~callback let (_ : GMenu.menu_item) = let callback = on_selected_rows ~multiple:true ~notif_kind:"Interrupt error" ~action:"interrupt" (fun id -> Command_req (id, "interrupt")) in tools_factory#add_item "_Interrupt" ~tooltip:"Stop all running proof attempts" ~callback let (_ : GMenu.menu_item) = let callback = on_selected_rows ~multiple:false ~notif_kind:"Bisect error" ~action:"bisect" (fun id -> Command_req (id, "bisect")) in tools_factory#add_item "_Bisect hypotheses" ~tooltip:"Remove useless hypotheses from a proved goal by bisection" ~callback let () = tools_factory#add_separator () let (_ : GMenu.menu_item) = let callback = on_selected_rows ~multiple:false ~notif_kind:"Focus_req error" ~action:"focus" (fun id -> Command_req (id, "Focus")) in tools_factory#add_item "_Focus" ~tooltip:"Focus view on the current node" ~callback let (_ : GMenu.menu_item) = let callback = fun () -> send_request (Unfocus_req) in tools_factory#add_item "_Unfocus" ~callback let () = tools_factory#add_separator () let copy_item = tools_factory#add_item "Copy node" ~modi:[`CONTROL] ~key:GdkKeysyms._C ~tooltip:"Copy the current node" let paste_item = tools_factory#add_item "Paste node" ~modi:[`CONTROL] ~key:GdkKeysyms._V ~tooltip:"Paste the copied node below the current node" (* complete the contextual menu (but only after provers and strategies, hence the function) *) let complete_context_menu () = context_factory#add_separator (); let (_ : GMenu.menu_item) = let callback = on_selected_rows ~multiple:false ~notif_kind:"Edit error" ~action:"edit" (fun id -> Command_req (id, "edit")) in context_factory#add_item "_Edit" ~accel_path:"/Tools/Edit" ~add_accel:false ~tooltip:"View or edit proof script" ~callback in (); let (_ : GMenu.menu_item) = let callback = on_selected_rows ~multiple:false ~notif_kind:"get-ce error" ~action:"Get Counterexamples" (fun id -> Command_req (id, "get-ce")) in context_factory#add_item "_Get Counterexamples" ~accel_path:"/Tools/Get Counterexamples" ~add_accel:false ~tooltip:"Launch the prover with counterexamples" ~callback in (); let (_ : GMenu.menu_item) = let callback = on_selected_rows ~multiple:false ~notif_kind:"Replay error" ~action:"replay" (fun id -> Command_req (id, "replay")) in context_factory#add_item "_Replay valid obsolete proofs" ~accel_path:"/Tools/Replay valid obsolete proofs" ~add_accel:false ~tooltip:"Replay valid obsolete proofs under the current node" ~callback in (); let (_ : GMenu.menu_item) = let callback = on_selected_rows ~multiple:false ~notif_kind:"Replay error" ~action:"replay all" (fun id -> Command_req (id, "replay all")) in context_factory#add_item "Replay all obsolete proofs" ~accel_path:"/Tools/Replay all obsolete proofs" ~add_accel:false ~tooltip:"Replay all obsolete proofs under the current node" ~callback in (); let (_ : GMenu.menu_item) = let callback = on_selected_rows ~multiple:false ~notif_kind:"Clean error" ~action:"clean" (fun id -> Command_req (id, "clean")) in context_factory#add_item "_Clean node" ~accel_path:"/Tools/Clean node" ~add_accel:false ~tooltip:"Remove unsuccessful proofs or transformations that are under a proved goal" ~callback in (); let (_ : GMenu.menu_item) = let callback = on_selected_rows ~multiple:true ~notif_kind:"Remove_subtree error" ~action:"remove" (fun id -> Remove_subtree id) in context_factory#add_item "Remove node" ~accel_path:"/Tools/Remove node" ~add_accel:false ~tooltip:"Remove the selected proof attempts or transformations" ~callback in (); let (_ : GMenu.menu_item) = let callback = on_selected_rows ~multiple:true ~notif_kind:"Interrupt error" ~action:"interrupt" (fun id -> Command_req (id, "interrupt")) in context_factory#add_item "_Interrupt" ~accel_path:"/Tools/Interrupt" ~add_accel:false ~tooltip:"Stop all running proof attempts" ~callback in () (*************************************) (* Copy paste *) (*************************************) (* Current copied node *) let saved_copy = ref None let copy () = match get_selected_row_references () with | [r] -> let n = get_node_id r#iter in saved_copy := Some n; paste_item#misc#set_sensitive true | _ -> saved_copy := None; paste_item#misc#set_sensitive false let paste () = match get_selected_row_references () with | [r] -> let m = get_node_id r#iter in (match !saved_copy with | Some n -> send_request (Copy_paste (n, m)) | None -> ()) | _ -> () let () = paste_item#misc#set_sensitive false; connect_menu_item copy_item ~callback:copy; connect_menu_item paste_item ~callback:paste (**********************************) (* Notification handling (part 2) *) (**********************************) let check_uninstalled_prover = let uninstalled_prover_seen = Whyconf.Hprover.create 3 in fun p -> if not (Whyconf.Hprover.mem uninstalled_prover_seen p) then begin Whyconf.Hprover.add uninstalled_prover_seen p (); let callback p u = send_request (Set_prover_policy(p,u)) in uninstalled_prover_dialog ~parent:main_window ~callback gconfig p end let treat_notification n = Protocol_why3ide.print_notify_debug n; begin match n with | Reset_whole_tree -> clear_tree_and_table goals_model | Node_change (id, uinfo) -> begin match uinfo with | Proved b -> let old = try let o = Hint.find node_id_proved id in Hint.replace node_id_proved id b; o with Not_found -> Hint.add node_id_proved id b; (* new node, then expand it if not proved *) not b in if old <> b then begin set_status_and_time_column (get_node_row id); Debug.dprintf debug "proved status changed to %b for %d@." b id; if b then begin (* if the node newly proved is selected, then force moving the selection the next unproved goal *) if is_selected_alone id then send_request (Get_first_unproven_node id) end else begin try let row = Hint.find node_id_to_gtree id in let path = row#path in Debug.dprintf debug "Expanding row for unproved node %d@." id; goals_view#expand_to_path path with Not_found -> Debug.dprintf debug "Warning: no gtk row registered for node %d@." id end end | Name_change n -> let row = get_node_row id in goals_model#set ~row:row#iter ~column:name_column n | Proof_status_change (pa, obs, l) -> let r = get_node_row id in Hint.replace node_id_pa id (pa, obs, l); set_status_and_time_column ~limit:l r; match pa with | Controller_itp.Uninstalled p -> check_uninstalled_prover p | _ -> () end | Next_Unproven_Node_Id (asked_id, next_unproved_id) -> if is_selected_alone asked_id then begin (* Unselect the potentially selected goal to avoid having two tasks selected at once when a prover successfully end. To continue the proof, it is better to only have the new goal selected *) goals_view#selection#unselect_all (); let iter = (get_node_row next_unproved_id)#iter in select_iter iter end | New_node (id, parent_id, typ, name, detached) -> begin try let parent = get_node_row parent_id in ignore (new_node ~parent id name typ detached); match typ with | NTransformation -> (* if this new node is a transformation, and its parent goal is selected, then ask for the next goal to prove. *) if is_selected_alone parent_id then send_request (Get_first_unproven_node parent_id) | _ -> () with Not_found -> ignore (new_node id name typ detached) end | Remove id -> (* In the case where id is an ancestor of a selected node, this node will be erased. So we try to select the parent. *) let n = get_node_row id in let is_ancestor = List.exists (fun row -> let row_id = get_node_id row#iter in row_id = id || goals_model#is_ancestor ~iter:n#iter ~descendant:row#iter) (get_selected_row_references ()) in if is_ancestor then (match goals_model#iter_parent n#iter with | None -> goals_view#selection#unselect_all () | Some parent -> goals_view#selection#unselect_all (); select_iter parent (* TODO Go to the next unproved goal ? let parent_id = get_node_id parent in send_request (Get_first_unproven_node parent_id)*)); ignore (goals_model#remove(n#iter)); Hint.remove node_id_to_gtree id; Hint.remove node_id_type id; Hint.remove node_id_proved id; Hint.remove node_id_pa id | Initialized g_info -> initialization_complete := true; main_window#show (); display_warnings (); init_completion g_info.provers g_info.transformations g_info.strategies g_info.commands; complete_context_menu (); Opt.iter select_iter goals_model#get_iter_first | Saved -> print_message ~kind:1 ~notif_kind:"Saved action info" "Session saved."; if !quit_on_saved = true then exit_function_safe () | Saving_needed b -> exit_function_handler b | Message (msg) -> treat_message_notification msg | Task (id, s, list_loc) -> if is_selected_alone id then begin task_view#source_buffer#set_text s; (* Avoid erasing colors at startup when selecting the first node. In all other cases, it should change nothing. *) if list_loc != [] then apply_loc_on_source list_loc; (* scroll to end of text *) task_view#scroll_to_mark `INSERT end | File_contents (file_name, content) -> let content = try_convert content in begin try let (_, sc_view, b, l) = Hstr.find source_view_table file_name in sc_view#source_buffer#begin_not_undoable_action (); sc_view#source_buffer#set_text content; sc_view#source_buffer#end_not_undoable_action (); update_label_saved l; b := false; reposition_ide_cursor () with | Not_found -> create_source_view file_name content end | Source_and_ce (content, list_loc) -> begin messages_notebook#goto_page counterexample_page; counterexample_view#source_buffer#set_text content; apply_loc_on_ce list_loc end | Dead _ -> print_message ~kind:1 ~notif_kind:"Server Dead ?" "Server sent the notification '%a'. Please report." print_notify n end; () (***********************************) (* accel group switching *) (* when entering/leaving tree view *) (***********************************) let () = let (_:GtkSignal.id) = goals_view#event#connect#focus_in ~callback:(fun _ -> main_window#add_accel_group tools_accel_group; true) in let (_:GtkSignal.id) = goals_view#event#connect#focus_out ~callback:(fun _ -> GtkWindow.Window.remove_accel_group main_window#as_window tools_accel_group; true) in () (***************************************************) (* simulate some user actions and take screenshots *) (***************************************************) let batch s = let cmd = ref (Strings.split ';' s) in let last = ref (Sys.time ()) in fun () -> let t = Sys.time () in if not !initialization_complete || t -. !last < 0.2 then true else match !cmd with | c :: tl -> cmd := tl; last := t; begin match Strings.split ' ' c with | [""] -> () | ["down"] -> move_current_row_selection_to_down () | ["next"] -> move_current_row_selection_to_next () | ["view"; "task"] -> notebook#goto_page 0 | ["view"; "source"] -> notebook#goto_page 1 | ["wait"; w] -> let w = int_of_string w in if w > 0 then cmd := Printf.sprintf "wait %d" (w - 1) :: !cmd | "faketype" :: cmd -> let cmd = Strings.join " " cmd in command_entry#misc#grab_focus (); command_entry#set_text cmd | "type" :: cmd -> let cmd = Strings.join " " cmd in command_entry#misc#grab_focus (); add_command list_commands cmd; interp cmd | "snap" :: cmd -> let cmd = Strings.join " " cmd in let cmd = Printf.sprintf "import -window \"%s\" -define png:include-chunk=none %s" window_title cmd in if Sys.command cmd <> 0 then Printf.eprintf "Batch command failed: %s\n%!" cmd | ["save"] -> send_request Save_req | _ -> Printf.eprintf "Unrecognized batch command: %s\n%!" c end; true | _ -> exit_function_unsafe (); false (***********************) (* start the interface *) (***********************) let () = Scheduler.timeout ~ms:Controller_itp.default_delay_ms (fun () -> List.iter treat_notification (get_notified ()); true); main_window#add_accel_group accel_group; main_window#set_icon (Some !Gconfig.why_icon); print_message ~kind:1 ~notif_kind:"Info" "Welcome to Why3 IDE\ntype 'help' for help\n"; begin match !opt_batch with | Some s -> let (_ : GMain.Idle.id) = GMain.Idle.add ~prio:300 (backtrace_and_exit (batch s)) in () | None -> () end; GMain.main () why3-1.2.1/src/ide/why3.css0000644000175100017510000002001313555524575016111 0ustar guillaumeguillaume/****** GLOBAL LAYOUT *********/ body { padding:0; margin:0; font-family: sans-serif; } #why3-main-container { /* Fills the whole window */ display: flex; /* tells the children with flex:i to fill-up the remaining space. non flex children will be sized according to content; */ flex-direction:column; position:absolute; top:0; left:0; right:0; bottom:0; } .why3-widget, .why3-container { /* Make the test non selectable */ -webkit-touch-callout: none; /* iOS Safari */ -webkit-user-select: none; /* Chrome/Safari/Opera */ -khtml-user-select: none; /* Konqueror */ -moz-user-select: none; /* Firefox */ -ms-user-select: none; /* IE/Edge */ user-select: none; /* non-prefixed version, currently not supported by any browser */ cursor:default; } #why3-top-button-bar { width:100%; } .why3-hidden { z-index:-10; position:absolute; top:0; left:0; height:0; width:0; } /**** BUTTON BAR *****/ /* GENERIC PART */ .why3-button-bar { box-sizing:border-box; padding:0; margin:0; } .why3-button-bar > .why3-button-group { position:relative; margin:0; box-sizing:border-box; display:inline-block; vertical-align:top; padding:0; } .why3-button-bar .why3-separator { display:inline-block; } .why3-flushright { position:relative; float:right; } /* SPECIFIC PART */ #why3-select-example { width:20em; } #why3-top-button-bar { height:2em; font-size:14pt; line-height:1.8em; } #why3-top-button-bar .why3-button { font-size:14pt; width:1.8em; display:inline-block; height:1.6em; } /**** END BUTTON BAR ****/ /**** Main view ****/ #why3-main-panel { flex:1; width:100%; padding:0; margin:0; /* align-items:stretch; */ /* ? */ /* elements in that panel are inserted from left to right */ display:flex; flex-direction:row; } /* #why3-main-panel > * { flex-grow: 1; width:auto; height:auto; } */ #why3-resize-bar { flex-basis:10px; flex-grow:0; /* not flex:0, because bar will become totally invisible */ } /* visual changes when mouse cursor is over the vertical resize bar */ #why3-resize-bar:hover { cursor: ew-resize; /* mouse cursor becomes like 'leftrightarrow' */ opacity:0.5; /* bar becomes darker */ border-style:solid; /* ? */ border-width: 2pt; /* ? */ box-sizing:border-box; /* ? */ } /*** LEFT PART: task list ***/ #why3-task-list-container { overflow:visible; /* add a scrollbar if too high to fit in the window */ flex:1; /* proportion of horizontal space taken in the main panel */ /* position:relative; /* ? */ margin:0; /* ? */ padding:0; /* ? */ */ } #why3-task-list { overflow:visible; /* add a scrollbar if too high to fit in the window */ width:100%; height:100%; } /*** RIGHT PART: panel with item added vertically ***/ #why3-right-panel { flex: 2; width:100%; padding:0; margin:0; /* align-items:stretch; */ /* ? */ /* elements in that panel are inserted from top to bottom */ display:flex; flex-direction:column; } #why3-tab-container { flex:1; position:relative; margin:0; padding:0; } #why3-resize-bar2 { flex-basis:10px; flex-grow:0; /* not flex:0 because bar would become totally invisible */ } #why3-form-cont { flex-grow:0; position:relative; margin:0; padding:0; width:100%; } #why3-tab-container2 { flex:1; position:relative; margin:0; padding:0; } /* visual changes when mouse cursor is over the horizaontal resize bar */ #why3-resize-bar2:hover { cursor: ns-resize; /* mouse cursor becomes like 'updownarrow' */ opacity:0.5; /* becomes darker */ border-style:solid; border-width: 2pt; box-sizing:border-box; } #why3-task-viewer-container { flex:1; position:relative; margin:0; padding:0; } #why3-editor { position:absolute; top:0; left:0; bottom:0; right:0; padding:0; margin:0; } /*** TABS ***/ #why3-tab-panel { top:0; bottom:0; left:0; right:0; padding:0; margin:0; } .why3-tab-label { display:inline-block; position:relative; top:1pt; border-radius: 3pt 3pt 0 0; border-width: 1pt 1pt 0 1pt; border-style: solid; height:2em; box-sizing:border-box; line-height:2em; margin: 0.5em 0.5em 0 0.5em; padding: 0 0.5em; z-index:2; } .why3-tab { position:absolute; top:2.5em; bottom:1pt; left:0; right:0; margin:0; padding:0; z-index: 1; padding-top:0.5em; box-sizing:border-box; border-top-style:solid; border-top-width:1pt; } .why3-tab-label.why3-inactive, .why3-tab-label.why3-inactive + .why3-tab { z-index:0; } #why3-task-viewer { width:100%; height:100%; } #why3-editor { overflow:visible; width:100%; height:100%; } #why3-error-container { overflow:visible; width:100%; height:100%; } #why3-log-container { overflow:visible; /* width:100%; */ /* height:100%; */ } /******* CONTEXT MENU *********/ .why3-contextmenu { display:none; position:absolute; border-style:solid; border-width:1pt; box-shadow:0pt 0pt 5pt #333; } .why3-contextmenu { z-index:100; } .why3-contextmenu ul { list-style-type:none; padding:0; margin:0; } .why3-contextmenu li { padding: 0.5em 1em 0.5em 1em; } /******* DIALOGS ****/ #why3-dialog-panel { position:absolute; z-index:100; display:none; top:0; left:0; right:0; bottom:0; justify-content:center; align-items:center; } #why3-dialog-bg { position:absolute; opacity:0.75; top:0; left:0; width:100%; height:100%; z-index:101; } .why3-dialog { z-index:102; flex:0; box-shadow:0pt 0pt 5pt #333; padding: 1em; } #why3-dialog-panel .why3-dialog div.why3-widget { display:none; } #why3-setting-dialog ul { list-style-type:none; } #why3-setting-dialog li { padding:0.5em; } /********** THEMABLE PART, SEE trywhy3_custom.css *************/ #why3-editor { font-size:large; } /* #why3-task-viewer { font-size:large; } */ #why3-task-list ul { list-style-type:none; padding-left:1em; padding-top:0em; } #why3-task-list li { padding-left:0em; padding-top:0em; } /* tasks icons */ .why3-task-pending { color: blue; } .why3-task-valid { color:green; } .why3-task-unknown { color:orange; } .why3-task-selected { background:rgba(250,220,90,0.7); } /* ACE Editor */ .ace_gutter-cell.ace_error { background-image:none !important; } .ace_gutter-cell.ace_error:before { content:"\f057"; font-family: 'FontAwesome', sans-serif; position:absolute; left:0.1em; color:rgba(231,113,116,1); } .ace_gutter-cell.ace_warning { background-image:none !important; } .ace_gutter-cell.ace_warning:before { content:"\f06a"; font-family: 'FontAwesome', sans-serif; position:absolute; left:0.1em; color:rgba(233,150,122,1); } .why3-error { position:absolute; background:rgba(231,113,116,1); z-index:70; } .why3-msg { } .why3-loc-neg-premise { position:absolute; background:rgba(255,128,64,1); z-index:60; } .why3-loc-goal { position:absolute; background:rgba(64,191,255,1); z-index:50; } .why3-loc-premise { position:absolute; background:rgba(100,233,134,1); z-index:40; } .why3-widget { background: #eee; color: #666; border-color: #888; } .why3-widget.why3-inactive { background:#eee; border-color:#eee; color:#aaa; } .why3-button { background-image: linear-gradient(to bottom, #eee, #ccc); border-radius:3pt; border: solid 1pt #aaa; } .why3-button, .why3-icon { color:#333; } .why3-button.why3-inactive, .why3-inactive .why3-icon { color:#aaa; } .why3-contextmenu li:hover, .why3-contextmenu li:hover .why3-icon { color: #eee; background: #222; } why3-1.2.1/src/ide/why3web.ml0000644000175100017510000001162213555524575016435 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 module P = struct let notifications = ref [] let notify n = notifications := n :: ! notifications let get_notifications () = let l = !notifications in notifications := []; List.rev l let requests = ref [] let push_request r = requests := r :: !requests let get_requests () = let l = !requests in requests := []; List.rev l end open Itp_communication open Itp_server module S = Make (Wserver) (P) open Format (* Decode URI *) let decode s = let b = Buffer.create (String.length s) in let i = ref 0 in while !i <= String.length s -1 do (match s.[!i] with (* | '+' -> Buffer.add_string b " " *) | '%' -> begin let a = int_of_string ("0x" ^ (String.sub s (!i + 1) 2)) in i := !i + 2; Buffer.add_char b (char_of_int a); end | a -> Buffer.add_char b a); i := !i + 1; done; Buffer.contents b (* TODO make it cleaner and less inefficient with adapted functions *) let interp_request args = match args with | args when Strings.has_prefix "reload" args -> Reload_req | args when Strings.has_prefix "list-provers" args -> Command_req (root_node,"list-provers") | args when Strings.has_prefix "command=" args -> let com = Strings.remove_prefix "command=" args in (match (Strings.bounded_split ',' com 2) with | n :: com :: [] -> Command_req (int_of_string n, com) | _ -> invalid_arg ("Why3web.interp_request '" ^ args ^ "'")) | args when Strings.has_prefix "gettask_" args -> let c = false in let loc = true in Get_task (int_of_string (Strings.remove_prefix "gettask_" args),c,loc) | _ -> invalid_arg ("Why3web.interp_request '" ^ args ^ "'") let handle_script s args = match s with | "request" -> begin try P.push_request (interp_request args); "{ \"request_received\": \"" ^ args ^ "\" }" with e -> "{ \"request_error\": \"" ^ args ^ "\" ; \"error\": \"" ^ (Pp.sprintf "%a" Exn_printer.exn_printer e) ^ "\" } " end | "getNotifications" -> let n = P.get_notifications () in Pp.sprintf "%a@." Json_util.print_list_notification n | _ -> "bad request" let plist fmt l = List.iter (fun x -> fprintf fmt "'%s'@\n" x) l let string_of_addr addr = match addr with | Unix.ADDR_UNIX s -> s | Unix.ADDR_INET (ie,i) -> (Unix.string_of_inet_addr ie)^":"^string_of_int(i) let handler (addr,req) script cont fmt = eprintf "addr : %s@." (string_of_addr addr); eprintf "req: @[%a@]@." plist req; eprintf "script: `%s'@." script; let cont = decode cont in eprintf "cont: `%s'@." cont; let ans = handle_script script cont in eprintf "answer: `%s'@." ans; Wserver.http_header fmt "HTTP/1.0 200 OK"; fprintf fmt "Access-Control-Allow-Origin: *\n"; fprintf fmt "\n"; (* end of header *) fprintf fmt "%s" ans; fprintf fmt "@." let help () = printf "Available commands:@."; printf "q : quit@." let stdin_handler s = match s with | "?" -> help () | "q" -> exit 0 | _ -> printf "unknown command '%s'@." s (************************) (* parsing command line *) (************************) let files : string Queue.t = Queue.create () let opt_parser = ref None let spec = [ "-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 () = let config, _base_config, env = Whyconf.Args.initialize spec (fun f -> Queue.add f files) usage_str in let dir = try Server_utils.get_session_dir ~allow_mkdir:true files with Invalid_argument s -> Format.eprintf "Error: %s@." s; Whyconf.Args.exit_with_usage spec usage_str in S.init_server config env dir; Queue.iter (fun f -> P.push_request (Add_file_req f)) files; Wserver.main_loop None 6789 handler stdin_handler why3-1.2.1/src/ide/wserver.ml0000644000175100017510000003146713555524575016553 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 blocking = false let multiplier = 3 let hexa_digit x = if x >= 10 then Char.chr (Char.code 'A' + x - 10) else Char.chr (Char.code '0' + x) let hexa_val conf = match conf with '0'..'9' -> Char.code conf - Char.code '0' | 'a'..'f' -> Char.code conf - Char.code 'a' + 10 | 'A'..'F' -> Char.code conf - Char.code 'A' + 10 | _ -> 0 let decode s = let rec need_decode i = if i < String.length s then match s.[i] with '%' | '+' -> true | _ -> need_decode (succ i) else false in let rec compute_len i i1 = if i < String.length s then let i = match s.[i] with '%' when i + 2 < String.length s -> i + 3 | _ -> succ i in compute_len i (succ i1) else i1 in let rec copy_decode_in s1 i i1 = if i < String.length s then let i = match s.[i] with '%' when i + 2 < String.length s -> let v = hexa_val s.[i + 1] * 16 + hexa_val s.[i + 2] in Bytes.set s1 i1 (Char.chr v); i + 3 | '+' -> Bytes.set s1 i1 ' '; succ i | x -> Bytes.set s1 i1 x; succ i in copy_decode_in s1 i (succ i1) else s1 in let rec strip s i1 i2 = if i1 >= i2 then "" else if Bytes.get s i1 = ' ' then strip s (i1 + 1) i2 else if Bytes.get s (i2 - 1) = ' ' then strip s i1 (i2 - 1) else Bytes.sub_string s i1 (i2 - i1) in let strip_heading_and_trailing_spaces s = strip s 0 (Bytes.length s) in if need_decode 0 then let len = compute_len 0 0 in let s1 = Bytes.create len in strip_heading_and_trailing_spaces (copy_decode_in s1 0 0) else s let special = function '\000'..'\031' | '\127'..'\255' | '<' | '>' | '\"' | '#' | '%' | '{' | '}' | '|' | '\\' | '^' | '~' | '[' | ']' | '`' | ';' | '/' | '?' | ':' | '@' | '=' | '&' -> true | _ -> false let encode s = let rec need_code i = if i < String.length s then match s.[i] with ' ' -> true | x -> if special x then true else need_code (succ i) else false in let rec compute_len i i1 = if i < String.length s then let i1 = if special s.[i] then i1 + 3 else succ i1 in compute_len (succ i) i1 else i1 in let rec copy_code_in s1 i i1 = if i < String.length s then let i1 = match s.[i] with ' ' -> Bytes.set s1 i1 '+'; succ i1 | c -> if special c then begin Bytes.set s1 i1 '%'; Bytes.set s1 (i1 + 1) (hexa_digit (Char.code c / 16)); Bytes.set s1 (i1 + 2) (hexa_digit (Char.code c mod 16)); i1 + 3 end else begin Bytes.set s1 i1 c; succ i1 end in copy_code_in s1 (succ i) i1 else s1 in if need_code 0 then let len = compute_len 0 0 in Bytes.to_string (copy_code_in (Bytes.create len) 0 0) else s let nl = "\013\010" let http_header fmt answer = let answer = if answer = "" then "200 OK" else answer in fprintf fmt "HTTP/1.0 %s%s" answer nl let print_exc exc = match exc with Unix.Unix_error (err, fun_name, arg) -> prerr_string "\""; prerr_string fun_name; prerr_string "\" failed"; if String.length arg > 0 then begin prerr_string " on \""; prerr_string arg; prerr_string "\"" end; prerr_string ": "; prerr_endline (Unix.error_message err) | Out_of_memory -> prerr_string "Out of memory\n" | Match_failure (file, first_char, last_char) -> prerr_string "Pattern matching failed, file "; prerr_string file; prerr_string ", chars "; prerr_int first_char; prerr_char '-'; prerr_int last_char; prerr_char '\n' | Assert_failure (file, first_char, last_char) -> prerr_string "Assertion failed, file "; prerr_string file; prerr_string ", chars "; prerr_int first_char; prerr_char '-'; prerr_int last_char; prerr_char '\n' | x -> prerr_string "Uncaught exception: "; prerr_string (Obj.magic (Obj.field (Obj.field (Obj.repr x) 0) 0)); if Obj.size (Obj.repr x) > 1 then begin prerr_char '('; for i = 1 to Obj.size (Obj.repr x) - 1 do if i > 1 then prerr_string ", "; let arg = Obj.field (Obj.repr x) i in if not (Obj.is_block arg) then prerr_int (Obj.magic arg : int) else if Obj.tag arg = 252 then begin prerr_char '\"'; prerr_string (Obj.magic arg : string); prerr_char '\"' end else prerr_char '_' done; prerr_char ')' end; prerr_char '\n' let print_err_exc exc = print_exc exc; flush stderr let case_unsensitive_eq s1 s2 = Why3.Strings.lowercase s1 = Why3.Strings.lowercase s2 let rec extract_param name stop_char = function x :: l -> if String.length x >= String.length name && case_unsensitive_eq (String.sub x 0 (String.length name)) name then let i = let rec loop i = if i = String.length x then i else if x.[i] = stop_char then i else loop (i + 1) in loop (String.length name) in String.sub x (String.length name) (i - String.length name) else extract_param name stop_char l | [] -> "" let get_request strm = let buff = Buffer.create 80 in let rec loop (strm__ : _ Stream.t) = match Stream.peek strm__ with | Some '\010' -> Stream.junk strm__; if Buffer.length buff = 0 then [] else let str = Buffer.contents buff in let () = Buffer.clear buff in str :: loop strm__ | Some '\013' -> Stream.junk strm__; loop strm__ | Some c -> Stream.junk strm__; Buffer.add_char buff c; loop strm__ | _ -> if Buffer.length buff = 0 then [] else [Buffer.contents buff] in loop strm let get_request_and_content strm = let request = get_request strm in let content = match extract_param "content-length: " ' ' request with "" -> "" | x -> String.init (int_of_string x) (fun _ -> let (strm__ : _ Stream.t) = strm in match Stream.peek strm__ with | Some x -> Stream.junk strm__; x | _ -> ' ') in request, content let string_of_sockaddr = function Unix.ADDR_UNIX s -> s | Unix.ADDR_INET (a, _) -> Unix.string_of_inet_addr a let sockaddr_of_string s = Unix.ADDR_UNIX s let treat_connection _tmout callback addr fd fmt = let (request, contents__) = let strm = let c = Bytes.create 1 in Stream.from (fun _ -> if Unix.read fd c 0 1 = 1 then Some (Bytes.get c 0) else None) in get_request_and_content strm in let (script_name, contents__) = match extract_param "GET /" ' ' request with "" -> extract_param "POST /" ' ' request, contents__ | str -> try let i = String.index str '?' in String.sub str 0 i, String.sub str (i + 1) (String.length str - i - 1) with Not_found -> str, "" in if script_name = "robots.txt" then begin http_header fmt ""; fprintf fmt "Content-type: text/plain%s%s" nl nl; fprintf fmt "User-Agent: *%s" nl; fprintf fmt "Disallow: /%s@." nl; eprintf "Robot request@." end else begin try callback (addr, request) script_name contents__ fmt with | Unix.Unix_error (Unix.EPIPE, "write", _) -> () | exc -> print_err_exc exc end (* buffer for storing character read on stdin *) let buf = Bytes.create 256 exception Nothing_to_do let accept_connection delay callback stdin_callback s = (* eprintf "Unix.select...@."; *) let (a,_,_) = Unix.select [s;Unix.stdin] [] [] delay in (* eprintf " done@."; *) if a = [] then raise Nothing_to_do else List.iter (fun a -> if a == s then let (t, addr) = Unix.accept s in eprintf "got a connection@."; Unix.setsockopt t Unix.SO_KEEPALIVE true; let cleanup () = begin try Unix.shutdown t Unix.SHUTDOWN_SEND with _ -> () end; begin try Unix.shutdown t Unix.SHUTDOWN_RECEIVE with _ -> () end; try Unix.close t with _ -> () in let oc = Unix.out_channel_of_descr t in treat_connection delay callback addr t (formatter_of_out_channel oc); close_out oc; eprintf "connection treated@."; cleanup () else if a == Unix.stdin then let n = Unix.read Unix.stdin buf 0 256 in eprintf "got a stdin input@."; stdin_callback (Bytes.sub_string buf 0 (n-1)); eprintf "stdin treated@."; () else assert false) a (* the private list of functions to call on idle, sorted higher priority first. *) let idle_handler : (int * (unit -> bool)) list ref = ref [] (* [insert_idle_handler p f] inserts [f] as a new function to call on idle, with priority [p] *) let insert_idle_handler p f = let rec aux l = match l with | [] -> [p,f] | (p1,_) as hd :: rem -> if p > p1 then (p,f) :: l else hd :: aux rem in idle_handler := aux !idle_handler (* the private list of functions to call on timeout, sorted on earliest trigger time first. *) let timeout_handler : (float * float * (unit -> bool)) list ref = ref [] (* [insert_timeout_handler ms t f] inserts [f] as a new function to call on timeout, with time step of [ms] and first call time as [t] *) let insert_timeout_handler ms t f = let rec aux l = match l with | [] -> [ms,t,f] | (_,t1,_) as hd :: rem -> if t < t1 then (ms,t,f) :: l else hd :: aux rem in timeout_handler := aux !timeout_handler (* public function to register a task to run on idle *) let idle ~(prio:int) f = insert_idle_handler prio f (* public function to register a task to run on timeout *) let timeout ~ms f = assert (ms > 0); let ms = float ms /. 1000.0 in let time = Unix.gettimeofday () in insert_timeout_handler ms (time +. ms) f let main_loop addr_opt port callback stdin_callback = let addr = match addr_opt with Some addr -> begin try Unix.inet_addr_of_string addr with Failure _ -> (Unix.gethostbyname addr).Unix.h_addr_list.(0) end | None -> Unix.inet_addr_any in let s = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in Unix.setsockopt s Unix.SO_REUSEADDR true; Unix.bind s (Unix.ADDR_INET (addr, port)); Unix.listen s 4; Sys.set_signal Sys.sigpipe Sys.Signal_ignore; let tm = Unix.localtime (Unix.time ()) in eprintf "Ready %4d-%02d-%02d %02d:%02d port %d...@." (1900 + tm.Unix.tm_year) (succ tm.Unix.tm_mon) tm.Unix.tm_mday tm.Unix.tm_hour tm.Unix.tm_min port; while true do (* attempt to run the first timeout handler *) let time = Unix.gettimeofday () in match !timeout_handler with | (ms,t,f) :: rem when t <= time -> timeout_handler := rem; let b = f () in let time = Unix.gettimeofday () in if b then insert_timeout_handler ms (ms +. time) f | _ -> (* no idle handler *) (* eprintf "check connection for a some delay@."; *) let delay = match !timeout_handler with | [] -> 0.125 (* 1/8 second by default *) | (_,t,_) :: _ -> t -. time (* or the time left until the next timeout otherwise *) in begin try accept_connection delay callback stdin_callback s with | Nothing_to_do -> begin (* attempt to run the first idle handler *) match !idle_handler with | (p,f) :: rem -> idle_handler := rem; let b = f () in if b then insert_idle_handler p f | [] -> () end | Unix.Unix_error (Unix.ECONNRESET, "accept", _) -> () | Unix.Unix_error ((Unix.EBADF | Unix.ENOTSOCK), "accept", _) as x -> raise x | e -> eprintf "Anomaly: %a@." Why3.Exn_printer.exn_printer e end done why3-1.2.1/src/ide/why3_custom.css0000644000175100017510000000374013555524575017513 0ustar guillaumeguillaume/* You can modify the values below to alter the default look of trywhy3 */ /*** TASKS ***/ /* Color of the icon used to show a task is being proved */ .why3-task-pending { color: blue; } /* Color of the icon used to show a task is proved */ .why3-task-valid { color:green; } /* Color of the icon used to show the status of a task is unproven */ .why3-task-unknown { color:orange; } /* Style used to for selected tasks */ .why3-task-selected { background:rgba(250,220,90,0.7); } /*** EDITOR ***/ /*** Warning: for highlighting properties, do not modify the position or z-index property. You should not use alpha-transparency (either opacity < 1 or rgba colors) since some highlight region overlaps. ***/ #why3-editor { font-size: large; } #why3-task-viewer { font-size: large; } /* Color used to highlight errors in the editor */ .why3-error { background:rgb(231,113,116); } /* Used for messages written in the right pane that are not errors */ .why3-msg { } /* Color used to highlight negative premises of a task in the editor */ .why3-loc-neg-premise { background:rgb(255,128,64); } /* Color used to highlight goals of a task in the editor */ .why3-loc-goal { background:rgb(64,191,255); } /* Color used to highlight premises of a task in the editor */ .why3-loc-premise { background:rgb(100,233,134); } /* Color of the interface */ .why3-widget { background: #eee; color: #666; border-color: #888; } /* Used for insactive widgets and tabs */ .why3-widget.why3-inactive { background:#eee; border-color:#eee; color:#aaa; } /* Style used for buttons */ .why3-button { background-image: linear-gradient(to bottom, #eee 10%, #ccc); border-radius:3pt; border: solid 1pt #aaa; } /* Text color used for icons and buttons */ .why3-button, .why3-icon { color:#333; } /* Highliting used for context menu */ .why3-contextmenu li:hover, .why3-contextmenu li:hover .why3-icon { color: #eee; background: #222; }why3-1.2.1/src/ide/why3_js.ml0000644000175100017510000005460013555524575016436 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 Itp_communication module Js = Js_of_ocaml.Js module JSU = Js_of_ocaml.Js.Unsafe module Dom = Js_of_ocaml.Dom module Form = Js_of_ocaml.Form module Firebug = Js_of_ocaml.Firebug module Dom_html = Js_of_ocaml.Dom_html module XmlHttpRequest = Js_of_ocaml.XmlHttpRequest let log s = ignore (Firebug.console ## log (Js.string s)) let get_opt o = Js.Opt.get o (fun () -> assert false) let check_def s o = Js.Optdef.get o (fun () -> log ("ERROR in check_def(): object " ^ s ^ " is undefined or null"); assert false) let get_global ident = let res : 'a Js.optdef = JSU.(get global) (Js.string ident) in check_def ident res let appendChild o c = ignore (o ## appendChild ( (c :> Dom.node Js.t))) let addMouseEventListener prevent o e f = let cb = Js.wrap_callback (fun (e : Dom_html.mouseEvent Js.t) -> if prevent then ignore (JSU.(meth_call e "preventDefault" [| |])); f e; Js._false) in ignore JSU.(meth_call o "addEventListener" [| inject (Js.string e); inject cb; inject Js._false |]) (**********) module AsHtml = struct include Dom_html.CoerceTo let span e = element e end let select e cls = Dom.list_of_nodeList (e ## querySelectorAll (Js.string cls)) let getElement_exn cast id = Js.Opt.get (cast (Dom_html.getElementById id)) (fun () -> raise Not_found) let getElement cast id = try getElement_exn cast id with Not_found -> log ("ERROR in getElement(): element " ^ id ^ " does not exist or has invalid type"); assert false (**********) module PE = struct let log_panel = getElement AsHtml.div "why3-log-bg" let doc = Dom_html.document let error_container = getElement AsHtml.div "why3-error-container" let print _cls msg = let node = doc##createElement (Js.string "P") in let textnode = doc##createTextNode (Js.string msg) in appendChild node textnode; appendChild log_panel node let log_print_error = print "why3-error" let log_print_msg = print "why3-msg" let error_print_msg s = error_container ##. innerHTML := Js.string s; log_print_msg s end let readBody (xhr: XmlHttpRequest.xmlHttpRequest Js.t) = let data = ref None in data := Some (xhr ##. responseText); match !data with | None -> raise Not_found | Some data -> Js.to_string data module Tabs = struct let () = let tab_groups = select Dom_html.document ".why3-tab-group" in List.iter (fun tab_group -> let labels = select tab_group ".why3-tab-label" in List.iter ( (fun tab -> tab ##. onclick := Dom.handler (fun _ev -> List.iter (fun t -> ignore (t ##. classList ## add (Js.string "why3-inactive"))) labels; tab ##. classList ## remove (Js.string "why3-inactive"); Js._false)) ) labels) tab_groups end module Editor = struct type range type marker let name = ref (Js.string "") let saved = ref false let ace = get_global "ace" let _Range : (int -> int -> int -> int -> range Js.t) Js.constr = let r = JSU.(get (meth_call ace "require" [| inject (Js.string "ace/range") |]) (Js.string "Range")) in check_def "Range" r let editor = let e = JSU.(meth_call ace "edit" [| inject (Js.string "why3-editor") |]) in check_def "why3-editor" e let task_viewer = let e = JSU.(meth_call ace "edit" [| inject (Js.string "why3-task-viewer") |]) in check_def "why3-task-viewer" e let get_session ed = JSU.(meth_call ed "getSession" [| |]) let mk_annotation row col text kind = JSU.(obj [| "row", inject row; "column", inject col; "text", inject text; "type", inject kind |]) let set_annotations l = let a = Array.map (fun (r,c,t,k) -> mk_annotation r c t k) (Array.of_list l) in let a = Js.array a in JSU.(meth_call (get_session editor) "setAnnotations" [| inject a |]) let clear_annotations () = ignore (JSU.(meth_call (get_session editor) "clearAnnotations" [| |])) let _Infinity = get_global "Infinity" let scroll_to_end e = let len : int = JSU.(meth_call (get_session e) "getLength" [| |]) in let last_line = len - 1 in ignore JSU.(meth_call e "gotoLine" [| inject last_line; inject _Infinity; inject Js._false |]) let () = let editor_theme : Js.js_string Js.t = get_global "editor_theme" in let editor_mode : Js.js_string Js.t = get_global "editor_mode" in List.iter (fun e -> ignore (JSU.(meth_call e "setTheme" [| inject editor_theme |])); ignore (JSU.(meth_call (get_session e) "setMode" [| inject editor_mode |])); JSU.(set e (Js.string "$blockScrolling") _Infinity) ) [ editor; task_viewer ]; JSU.(meth_call task_viewer "setReadOnly" [| inject Js._true|]) let undo () = ignore JSU.(meth_call editor "undo" [| |]) let redo () = ignore JSU.(meth_call editor "redo" [| |]) let get_value ?(editor=editor) () : Js.js_string Js.t = JSU.meth_call editor "getValue" [| |] let set_value ~editor (str : Js.js_string Js.t) = ignore JSU.(meth_call editor "setValue" [| inject (str); inject ~-1 |]) let _Range = Js.Unsafe.global##._Range let mk_range l1 c1 l2 c2 = new%js _Range (l1, c1, l2, c2) let set_selection_range r = let selection = JSU.meth_call editor "getSelection" [| |] in ignore JSU.(meth_call selection "setSelectionRange" [| inject r |]) let add_marker cls r : marker = JSU.(meth_call (get_session editor) "addMarker" [| inject r; inject (Js.string cls); inject (Js.string "text") |]) let remove_marker m = ignore JSU.(meth_call (get_session editor) "removeMarker" [| inject m|]) let get_char buffer i = int_of_float (buffer ## charCodeAt(i)) let why3_loc_to_range buffer loc = let goto_line lstop = let rec loop lcur i = if lcur == lstop then i else let c = get_char buffer i in loop (if c == 0 then lcur+1 else lcur) (i+1) in loop 1 0 in let rec convert_range l c i n = if n == 0 then (l, c) else if (get_char buffer i) == 10 then convert_range (l+1) 0 (i+1) (n-1) else convert_range l (c+1) (i+1) (n-1) in let l1, b, e = loc in let c1 = b in let i = goto_line l1 in let l2, c2 = convert_range l1 b (i+b) (e-b) in mk_range (l1-1) c1 (l2-1) c2 let focus e = ignore JSU.(meth_call e "focus" [| |]) let set_on_event e f = ignore JSU.(meth_call editor "on" [| inject (Js.string e); inject f|]) (* let editor_bg = getElement AsHtml.div "why3-editor-bg" let disable () = ignore JSU.(meth_call editor "setReadOnly" [| inject Js._true|]); editor_bg ##. style ##. display := (Js.string "block") let enable () = ignore JSU.(meth_call editor "setReadOnly" [| inject Js._false|]); editor_bg ##. style ##. display := Js.string "none" *) let confirm_unsaved () = if not !saved then Js.to_bool (Dom_html.window ## confirm (Js.string "You have unsaved changes in your editor, proceed anyway ?")) else true end (* TODO This is not necessary yet ???? *) module ContextMenu = struct let task_menu = getElement AsHtml.div "why3-task-menu" let split_menu_entry = getElement AsHtml.li "why3-split-menu-entry" let prove_menu_entry = getElement AsHtml.li "why3-prove-menu-entry" let prove100_menu_entry = getElement AsHtml.li "why3-prove100-menu-entry" let prove1000_menu_entry = getElement AsHtml.li "why3-prove1000-menu-entry" let clean_menu_entry = getElement AsHtml.li "why3-clean-menu-entry" let enabled = ref true let enable () = enabled := true let disable () = enabled := false let show_at x y = if !enabled then begin task_menu ##. style ##. display := Js.string "block"; task_menu ##. style ##. left := Js.string ((string_of_int x) ^ "px"); task_menu ##. style ##. top := Js.string ((string_of_int y) ^ "px") end let hide () = if !enabled then task_menu ##. style ##. display := Js.string "none" (* let add_action b f = b ##. onclick := Dom.handler (fun _ -> hide (); f (); Editor.(focus editor); Js._false) *) let () = addMouseEventListener false task_menu "mouseleave" (fun _ -> hide()) end module ToolBar = struct (* add_action to a button *) let add_action b f = let cb = fun _ -> f (); (* Editor.(focus editor); *) Js._false in b ##. onclick := Dom.handler cb (* Current buttons *) (* TODO rename buttons *) let button_open = getElement AsHtml.button "why3-button-open" let button_save = getElement AsHtml.button "why3-button-save" let button_reload = getElement AsHtml.button "why3-button-undo" let button_redo = getElement AsHtml.button "why3-button-redo" end type httpRequest = | Command of int * string | Get_task of string | Reload let sendRequest r = let xhr = XmlHttpRequest.create () in let onreadystatechange () = if xhr ##. readyState == XmlHttpRequest.DONE then if xhr ##. status == 200 then PE.log_print_msg ("Http request '" ^ r ^ "' returned " ^ readBody xhr) else PE.log_print_msg ("Http request '" ^ r ^ "' failed with status " ^ string_of_int (xhr ##. status)) in xhr ## overrideMimeType (Js.string "text/json"); let _ = xhr ## _open (Js.string "GET") (Js.string ("http://localhost:6789/request?"^r)) Js._true in xhr ##. onreadystatechange := (Js.wrap_callback onreadystatechange); xhr ## send (Js.null) let sendRequest r = match r with | Reload -> sendRequest "reload" | Get_task n -> sendRequest ("gettask_"^n) | Command (n, c) -> sendRequest ("command=" ^ (string_of_int n)^","^c) module Panel = struct let main_panel = getElement AsHtml.div "why3-main-panel" let task_list_container = getElement AsHtml.div "why3-task-list-container" let tab_container = getElement AsHtml.div "why3-tab-container" let resize_bar = getElement AsHtml.div "why3-resize-bar" let reset () = let edit_style = tab_container ##. style in JSU.(set edit_style (Js.string "flexGrow") (Js.string "2")); JSU.(set edit_style (Js.string "flexBasis") (Js.string "")) let () = let mouse_down = ref false in resize_bar ##. onmousedown := Dom.handler (fun _ -> mouse_down := true; Js._false); resize_bar ##. ondblclick := Dom.handler (fun _ -> reset (); Js._false); main_panel ##. onmouseup := Dom.handler (fun _ -> mouse_down := false; Js._false); main_panel ##. onmousemove := Dom.handler (fun e -> if !mouse_down then begin let offset = (e ##. clientX) - (main_panel ##. offsetLeft) in let offset = Js.string ((string_of_int offset) ^ "px") in let edit_style = task_list_container ##. style in JSU.(set edit_style (Js.string "flexGrow") (Js.string "0")); JSU.(set edit_style (Js.string "flexBasis") offset); Js._false end else Js._true) end module TaskList = struct let selected_task = ref "0" let task_list = getElement AsHtml.div "why3-task-list" (* Task list as we get them from the server *) let printed_task_list = Hashtbl.create 16 let print cls msg = task_list ##. innerHTML := (Js.string ("

" ^ msg ^ "

")) let print_error = print "why3-error" let print_msg = print "why3-msg" let mk_li_content id expl = Js.string (Format.sprintf " %s
    " id id expl id id) let attach_to_parent id parent_id expl = let doc = Dom_html.document in let ul = try getElement_exn AsHtml.ul parent_id with Not_found -> let ul = Dom_html.createUl doc in ul ##. id := Js.string parent_id; appendChild task_list ul; ul in let li = Dom_html.createLi doc in li ##. id := Js.string id; appendChild ul li; li ##. innerHTML := mk_li_content id expl let task_selection = Hashtbl.create 17 let is_selected id = Hashtbl.mem task_selection id let select_task id (span: Dom_html.element Js.t) pretty = (span ##. classList) ## add (Js.string "why3-task-selected"); Hashtbl.add task_selection id span; selected_task := id; Editor.set_value ~editor:Editor.task_viewer (Js.string pretty); Editor.scroll_to_end Editor.task_viewer let deselect_task id = try let span= Hashtbl.find task_selection id in (span ##. classList) ## remove (Js.string "why3-task-selected"); Hashtbl.remove task_selection id with Not_found -> () let clear_task_selection () = let l = Hashtbl.fold (fun id _ acc -> id :: acc) task_selection [] in List.iter deselect_task l let clear () = clear_task_selection (); task_list ##. innerHTML := Js.string ""; selected_task := "0"; Hashtbl.clear printed_task_list; Editor.set_value ~editor:Editor.task_viewer (Js.string "") let () = Editor.set_on_event "focus" (Js.wrap_callback clear_task_selection ) let onclick_do_something id = let span = getElement AsHtml.span (id ^ "_container") in span ##. onclick := Dom.handler (fun ev -> let ctrl = Js.to_bool (ev ##. ctrlKey) in if is_selected id then if ctrl then deselect_task id else clear_task_selection () else begin if not ctrl then clear_task_selection (); let pretty = try Hashtbl.find printed_task_list id with Not_found -> (sendRequest (Get_task id); "loading task, please wait") in (* TODO dummy value *) select_task id span pretty end; Js._false); addMouseEventListener true span "contextmenu" (fun e -> clear_task_selection (); let pretty = try Hashtbl.find printed_task_list id with Not_found -> (sendRequest (Get_task id); "") in select_task id span pretty; let x = max 0 ((e ##.clientX) - 2) in let y = max 0 ((e ##.clientY) - 2) in ContextMenu.show_at x y) let update_status st id = try let span_icon = getElement AsHtml.span (id ^ "_icon") in let span_msg = getElement AsHtml.span (id ^ "_msg") in let cls = match st with | `Scheduled -> "fas fa-fw fa-cog why3-task-pending" | `Running -> "fas fa-fw fa-cog fa-spin why3-task-pending" | `Valid -> span_msg ##. innerHTML := Js.string ""; "fas fa-check-circle why3-task-valid" | `Unknown -> "fas fa-question-circle why3-task-unknown" | `Timeout -> "fas fa-clock-o why3-task-unknown" | `Failure -> "fas fa-bomb why3-task-unknown" in span_icon ##. className := Js.string cls with Not_found -> () (* Attach a new node to the task tree if it does not already exists *) let attach_new_node nid parent (_ntype: node_type) name (_detached: bool) = let parent = string_of_int parent in let nid = string_of_int nid in try ignore (getElement_exn AsHtml.ul (nid^"_ul")) with | Not_found -> if nid != parent then attach_to_parent nid (parent^"_ul") name else attach_to_parent nid (parent^"_ul") name let remove_node n = let element = getElement AsHtml.span n in let parent = element ##. parentNode in let parent = Js.Opt.to_option parent in match parent with | None -> failwith "TODO" | Some parent -> Dom.removeChild parent element end let interpNotif (n: notification) = PE.log_print_msg (Format.asprintf "interpNotif: %a@\n@." Itp_communication.print_notify n); match n with | Reset_whole_tree -> TaskList.clear () | Initialized _g -> PE.error_print_msg "Initialized" | New_node (nid, parent, ntype, name, detached) -> TaskList.attach_new_node nid parent ntype name detached; TaskList.onclick_do_something (string_of_int nid); sendRequest (Get_task (string_of_int nid)) | File_contents (_f,_s) -> PE.error_print_msg "Notification File_contents not handled yet" | Source_and_ce _ -> PE.error_print_msg "Notification Source_and_ce not handled yet" | Next_Unproven_Node_Id (_nid1,_nid2) -> PE.error_print_msg "Notification Next_Unproven_Node_Id not handled yet" | Task (nid, task, _list_loc) -> (* TODO add color on sources *) Hashtbl.add TaskList.printed_task_list (string_of_int nid) task | Remove nid -> TaskList.remove_node (string_of_int nid) | Saved -> PE.error_print_msg "Saved" | Saving_needed _b -> PE.error_print_msg "Saving_needed" | Message m -> begin match m with | Proof_error (_nid, s) -> PE.error_print_msg (Format.asprintf "Proof error on selected node: \"%s\"" s) | Transf_error (_b, _ids, _tr, _args, _loc, s, _d) -> PE.error_print_msg (Format.asprintf "Transformation error on selected node: \"%s\"" s) | Strat_error (_nid, s) -> PE.error_print_msg (Format.asprintf "Strategy error on selected node: \"%s\"" s) | Query_Error (_nid, s) -> PE.error_print_msg (Format.asprintf "Query error on selected node: \"%s\"" s) | Query_Info (_nid, s) -> PE.error_print_msg s | Information s -> PE.error_print_msg s | Error s -> PE.error_print_msg (Format.asprintf "Error: \"%s\"" s) | Open_File_Error s -> PE.error_print_msg (Format.asprintf "Error while opening file: \"%s\"" s) | _ -> (); let s = Format.asprintf "%a" Json_util.print_notification n in PE.log_print_msg s end | Dead s -> PE.error_print_msg s | Node_change (nid, up) -> begin match up with | Proved true -> TaskList.update_status `Valid (string_of_int nid) | Proved false -> TaskList.update_status `Unknown (string_of_int nid) | Name_change _n -> assert false (* TODO *) | Proof_status_change (c, _obsolete, _rl) -> begin (* TODO complete other tests *) match c with | Controller_itp.Done pr -> TaskList.update_status Call_provers.(match pr.pr_answer with | Valid -> `Valid | Unknown _ -> `Unknown | Timeout -> `Timeout | _ -> `Failure) (string_of_int nid) | Controller_itp.Running -> TaskList.update_status `Running (string_of_int nid) | Controller_itp.Scheduled -> TaskList.update_status `Scheduled (string_of_int nid) | _ -> TaskList.update_status `Failure (string_of_int nid) end end exception NoNotification let interpNotifications l = match l with | [] -> () | l -> List.iter interpNotif l let getNotification2 () = let xhr = XmlHttpRequest.create () in let onreadystatechange () = if xhr ##. readyState == XmlHttpRequest.DONE then let stat = xhr ##. status in if stat == 200 then let r = readBody xhr in let nl = try Json_util.parse_list_notification r with e -> let s = "ERROR in getNotification2: Json_util.parse_list_notification raised " ^ Printexc.to_string e ^ " on the following notification: " ^ r in log s; PE.log_print_msg s; [] in interpNotifications nl else if stat == 0 then PE.log_print_msg "Why3 Web server not responding (HttpRequest got answer with status 0)" else begin let s = "getNotification2: state changed to unknown status " ^ string_of_int stat in log s; PE.log_print_msg s end in (xhr ##. onreadystatechange := (Js.wrap_callback onreadystatechange)); xhr ## overrideMimeType (Js.string "text/json"); let _ = xhr ## _open (Js.string "GET") (Js.string "http://localhost:6789/getNotifications") Js._true in xhr ## send (Js.null) let notifHandler = ref None let startNotificationHandler () = if (!notifHandler = None) then notifHandler := Some (Dom_html.window ## setInterval (Js.wrap_callback getNotification2) (Js.float 1000.0)) let () = startNotificationHandler () let stopNotificationHandler () = match !notifHandler with | None -> () | Some n -> Dom_html.window ## clearInterval (n); notifHandler := None (* TODO make a module *) (* Form for commands *) let form = getElement AsHtml.form "why3-form" let () = Js.Unsafe.set form "target" "form-answer" let () = form ##. onsubmit := Dom.full_handler (fun _ _ -> let a = Form.get_form_contents form in List.iter (fun x -> match x with | (c, s) when c = "command" -> sendRequest (Command (int_of_string !TaskList.selected_task, s)) | _ -> ()) a; Js._false) let () = ToolBar.(add_action button_open (fun () -> PE.log_print_msg "Open"; startNotificationHandler ())) let () = ToolBar.(add_action button_save (fun () -> PE.log_print_msg "Save"; stopNotificationHandler ())) let () = ToolBar.(add_action button_reload (fun () -> PE.log_print_msg "Reload"; TaskList.clear (); sendRequest Reload)) (* TODO Server handling *) (*let () = Js.Unsafe.global##stopNotificationHandler <- Js.wrap_callback stopNotificationHandler let () = Js.Unsafe.global##startNotificationHandler <- Js.wrap_callback startNotificationHandler *) (* let () = Js.Unsafe.global##sendRequest <- Js.wrap_callback sendRequest *) let () = Js.Unsafe.global##.getNotification1 := Js.wrap_callback getNotification2 (* let () = Js.Unsafe.global## PE.printAnswer1 <- Js.wrap_callback (fun s -> PE.printAnswer s) *) why3-1.2.1/src/ide/why3.html0000644000175100017510000002157113555524575016277 0ustar guillaumeguillaume Why3
    Task tree not loaded yet. You may need to click on the 'reload' button (counterclockwise circular arrow above)
    Task
    No current proof task yet
    Source code
    No source code loaded yet
    Log
    Log
    Error message
    • Split and prove
    • Prove (default)
    • Prove (100 steps)
    • Prove (1000 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-1.2.1/src/ide/gtkcompat3.ml0000644000175100017510000000152413555524575017121 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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/ide/gtkcompat3.ml" module GSourceView = GSourceView3 let gpango_font_description_from_string = GPango.font_description_from_string why3-1.2.1/src/session/0000755000175100017510000000000013555524575015433 5ustar guillaumeguillaumewhy3-1.2.1/src/session/server_utils.mli0000644000175100017510000000745513555524575020677 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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_session_dir : allow_mkdir:bool -> string Queue.t -> string (** [get_session_dir q] analyses the queue of filenames [q] and returns the session directory from it. If the first element of the queue [q] is a directory, it is used as the session dir, and removed from the queue. If it is an existing file, the name obtained by removing the extension is used as the session dir; the file stays in the queue. In the other cases, the function raises [Invalid_arg s] with some appropriate explanation [s]. The so computed session directory is created if it does not exist and [allow_mkdir] is true. *) val set_session_timelimit : int -> unit (** sets the default timelimit in seconds. Initially set to 2. *) val set_session_memlimit : int -> unit (** sets the default mem in Mb. Initially set to 1000. *) (** Simple queries *) (* The id you are trying to use is undefined *) exception Undefined_id of string (* Bad number of arguments *) exception Number_of_arguments type query = | Qnotask of (Controller_itp.controller -> string list -> string) | Qtask of (Controller_itp.controller -> Trans.naming_table -> string list -> string) (* The first argument is not used: these functions are supposed to be given to a Qtask. *) val print_id: 'a -> Trans.naming_table -> string list -> string val search_id: search_both:bool -> 'a -> Trans.naming_table -> string list -> string val list_strategies : Controller_itp.controller -> (string * string) list val list_provers: Controller_itp.controller -> _ -> string val list_transforms: unit -> (string * Pp.formatted) list val list_transforms_query: _ -> _ -> string (* val help_on_queries: Format.formatter -> (string * string * 'a) list -> unit *) val load_strategies: Controller_itp.controller -> unit (** Command line parsing tools *) val return_prover: string -> Whyconf.config -> Whyconf.config_prover option type command = | Transform of string * Trans.gentrans * string list | Prove of Whyconf.config_prover * Call_provers.resource_limit | Strategies of string | Edit of Whyconf.prover | Get_ce | Bisect | Replay of bool | Clean | Mark_Obsolete | Focus_req | Unfocus_req | Help_message of string | Query of string | QError of string | Other of string * string list val interp: (string * query) Wstdlib.Hstr.t -> Controller_itp.controller -> Session_itp.any option -> string -> command (* Find the first unproven goal around the node given. @param always_send: if true then always returns something @param proved : oracle for proved node @param children : returns the list children of a node @param get_parent : returns the parent of a node @param is_goal : answer true iff a given node is a goal @param is_pa : answer true iff a given node is a proof attempt @param node : node_id *) val get_first_unproven_goal_around: always_send:bool -> proved:('a -> bool) -> children:('a -> 'a list) -> get_parent:('a -> 'a option) -> is_goal:('a -> bool) -> is_pa:('a -> bool) -> 'a -> 'a option why3-1.2.1/src/session/session_itp.ml0000644000175100017510000020700213555524575020325 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 Wstdlib module Hprover = Whyconf.Hprover let debug = Debug.register_info_flag "session_itp" ~desc:"Pring@ debugging@ messages@ about@ Why3@ session@ \ creation,@ reading@ and@ writing." let debug_merge = Debug.lookup_flag "session_pairing" let debug_stack_trace = Debug.lookup_flag "stack_trace" type transID = int type proofNodeID = int type proofAttemptID = int type fileID = int let print_proofNodeID fmt id = Format.fprintf fmt "proofNodeID<%d>" id let print_proofAttemptID fmt id = Format.fprintf fmt "proofAttemptID<%d>" id type theory = { theory_name : Ident.ident; mutable theory_goals : proofNodeID list; mutable theory_parent_name : fileID; mutable theory_is_detached : bool; } let theory_name t = t.theory_name let theory_goals t = t.theory_goals type proof_parent = Trans of transID | Theory of theory type proof_attempt_node = { parent : proofNodeID; mutable prover : Whyconf.prover; limit : Call_provers.resource_limit; mutable proof_state : Call_provers.prover_result option; (* None means that the call was not done or never returned *) mutable proof_obsolete : bool; mutable proof_script : string option; (* non empty for external ITP *) } let set_proof_script pa file = assert (pa.proof_script = None); pa.proof_script <- Some file type proof_node = { proofn_name : Ident.ident; proofn_expl : string; proofn_parent : proof_parent; proofn_attempts : proofAttemptID Hprover.t; mutable proofn_transformations : transID list; } type transformation_node = { transf_name : string; transf_args : string list; mutable transf_subtasks : proofNodeID list; transf_parent : proofNodeID; transf_is_detached : bool; } type file_path = string list let string_of_file_path p = String.concat "/" p type file = { file_id : int; mutable file_path : file_path; (* access path to the source, in the normal order i.e. ["..";"foo.mlw"] *) file_format : string option; file_is_detached : bool; mutable file_theories : theory list; } let file_id f = f.file_id let file_path f = f.file_path let file_format f = f.file_format let file_theories f = f.file_theories type any = | AFile of file | ATh of theory | ATn of transID | APn of proofNodeID | APa of proofAttemptID let rec basename p = match p with | [] -> raise Not_found | [f] -> f | _ :: tl -> basename tl let print_file_path fmt p = Format.fprintf fmt "%a" (Pp.print_list Pp.slash Pp.string) p let fprintf_any fmt a = match a with | AFile f -> Format.fprintf fmt "" print_file_path f.file_path | ATh th -> Format.fprintf fmt "" th.theory_name.Ident.id_string | ATn trid -> Format.fprintf fmt "" trid | APn pnid -> Format.fprintf fmt "" pnid | APa paid -> Format.fprintf fmt "" paid module Hpn = Hint module Htn = Hint module Hpan = Hint module Hfile = Hint type session = { proofAttempt_table : proof_attempt_node Hint.t; mutable next_proofAttemptID : int; proofNode_table : proof_node Hint.t; mutable next_proofNodeID : int; trans_table : transformation_node Hint.t; mutable next_transID : int; mutable next_fileID : int; session_dir : string; (** Absolute path *) session_files : file Hfile.t; session_sum_shape_table : (Termcode.checksum * Termcode.shape) Hpn.t; session_prover_ids : int Hprover.t; (* tasks *) session_raw_tasks : Task.task Hpn.t; session_task_tables : Trans.naming_table Hpn.t; (* proved status *) file_state: bool Hfile.t; th_state: bool Ident.Hid.t; tn_state: bool Htn.t; pn_state : bool Hpn.t; } let system_path s f = Sysutil.system_dependent_absolute_path s.session_dir f.file_path let theory_parent s th = Debug.dprintf debug "[Session_itp.theory_parent] th.parent_name = %d@." th.theory_parent_name; Hfile.find s.session_files th.theory_parent_name let session_iter_proof_attempt f s = Hint.iter f s.proofAttempt_table (* This is not needed. Keeping it as information on the structure type tree = { tree_node_id : proofNodeID; tree_goal_name : string; tree_proof_attempts : proof_attempt list; (* proof attempts on this node *) tree_transformations : (transID * string * tree list) list; (* transformations on this node *) } *) (* let rec get_tree s id : tree = let t = Hint.find s.proofNode_table id in let pal = Hprover.fold (fun _ pa acc -> pa.proofa_attempt::acc) t.proofn_attempts [] in let trl = List.map (get_trans s) t.proofn_transformations in { tree_node_id = id; tree_goal_name = t.proofn_name.Ident.id_string; tree_proof_attempts = pal; tree_transformations = trl; } and get_trans s id = let tr = Hint.find s.trans_table id in (id, tr.transf_name, List.map (get_tree s) tr.transf_subtasks) *) (* let get_theories s = Hstr.fold (fun _fn f acc -> let c = List.map (fun th -> (th.theory_name.Ident.id_string, th.theory_goals)) f.file_theories in (f,c) :: acc) s.session_files [] *) let get_files s = s.session_files (* let get_file s name = Hstr.find s.session_files name *) let get_dir s = s.session_dir (* let get_node (s : session) (n : int) = let _ = Hint.find s.proofNode_table n in n let get_trans (s : session) (n : int) = let _ = Hint.find s.trans_table n in n *) (* Generation of new IDs *) let gen_transID (s : session) = let id = s.next_transID in s.next_transID <- id + 1; id let gen_proofNodeID (s : session) = let id = s.next_proofNodeID in s.next_proofNodeID <- id + 1; id let gen_proofAttemptID (s : session) = let id = s.next_proofAttemptID in s.next_proofAttemptID <- id + 1; id let gen_fileID (s : session) = let id = s.next_fileID in s.next_fileID <- id + 1; id (* Get elements of the session tree *) exception BadID let get_proof_attempt_node (s : session) (id : proofAttemptID) = try Hint.find s.proofAttempt_table id with Not_found -> raise BadID let get_proofNode (s : session) (id : proofNodeID) = try Hint.find s.proofNode_table id with Not_found -> raise BadID let get_task s id = Hpn.find s.session_raw_tasks id let get_task_name_table s n = let t = get_task s n in let table = try Hpn.find s.session_task_tables n with Not_found -> let ta = Args_wrapper.build_naming_tables t in Hpn.add s.session_task_tables n ta; ta in t,table let get_transfNode (s : session) (id : transID) = try Hint.find s.trans_table id with Not_found -> raise BadID let get_transformations (s : session) (id : proofNodeID) = (get_proofNode s id).proofn_transformations let get_proof_attempt_ids (s : session) (id : proofNodeID) = (get_proofNode s id).proofn_attempts let get_proof_attempt_parent (s : session) (a : proofAttemptID) = (get_proof_attempt_node s a).parent let get_proof_attempts (s : session) (id : proofNodeID) = Hprover.fold (fun _ a l -> let pa = get_proof_attempt_node s a in pa :: l) (get_proofNode s id).proofn_attempts [] let get_sub_tasks (s : session) (id : transID) = (get_transfNode s id).transf_subtasks let get_transf_args (s : session) (id : transID) = (get_transfNode s id).transf_args let get_transf_name (s : session) (id : transID) = (get_transfNode s id).transf_name let get_proof_name (s : session) (id : proofNodeID) = (get_proofNode s id).proofn_name let get_proof_expl (s : session) (id : proofNodeID) = (get_proofNode s id).proofn_expl let get_proof_parent (s : session) (id : proofNodeID) = (get_proofNode s id).proofn_parent let get_trans_parent (s : session) (id : transID) = (get_transfNode s id).transf_parent let goal_is_detached s pn = try let (_:Task.task) = get_task s pn in false with Not_found -> true let transf_is_detached s tn = (get_transfNode s tn).transf_is_detached let proof_attempt_is_detached s pa = let pa = get_proof_attempt_node s pa in goal_is_detached s pa.parent let is_detached (s: session) (a: any) = match a with | AFile file -> file.file_is_detached | ATh th -> th.theory_is_detached | ATn tn -> transf_is_detached s tn | APn pn -> goal_is_detached s pn | APa pa -> proof_attempt_is_detached s pa let rec get_encapsulating_theory s any = match any with | AFile _f -> assert (false) | ATh th -> th | ATn tn -> let pn_id = get_trans_parent s tn in get_encapsulating_theory s (APn pn_id) | APn pn -> (match get_proof_parent s pn with | Theory th -> th | Trans tn -> get_encapsulating_theory s (ATn tn) ) | APa pa -> let pn = get_proof_attempt_parent s pa in get_encapsulating_theory s (APn pn) let get_encapsulating_file s any = match any with | AFile f -> f | ATh th -> theory_parent s th | _ -> let th = get_encapsulating_theory s any in theory_parent s th (* let set_obsolete s paid b = let pa = get_proof_attempt_node s paid in pa.proof_obsolete <- b *) let check_if_already_exists s pid t args = let sub_transfs = get_transformations s pid in List.exists (fun tr_id -> get_transf_name s tr_id = t && get_transf_args s tr_id = args && not (is_detached s (ATn tr_id))) sub_transfs (* Iterations functions on the session tree *) let rec fold_all_any_of_transn s f acc trid = let tr = get_transfNode s trid in let acc = List.fold_left (fold_all_any_of_proofn s f) acc tr.transf_subtasks in f acc (ATn trid) and fold_all_any_of_proofn s f acc pnid = let pn = get_proofNode s pnid in let acc = List.fold_left (fun acc trid -> fold_all_any_of_transn s f acc trid) acc pn.proofn_transformations in let acc = Hprover.fold (fun _p paid acc -> f acc (APa paid)) pn.proofn_attempts acc in f acc (APn pnid) let fold_all_any_of_theory s f acc th = let acc = List.fold_left (fold_all_any_of_proofn s f) acc th.theory_goals in f acc (ATh th) let fold_all_any_of_file s f acc file = let acc = List.fold_left (fold_all_any_of_theory s f) acc file.file_theories in f acc (AFile file) let fold_all_any s f acc any = match any with | AFile file -> fold_all_any_of_file s f acc file | ATh th -> fold_all_any_of_theory s f acc th | APn pn -> fold_all_any_of_proofn s f acc pn | ATn tn -> fold_all_any_of_transn s f acc tn | APa _ -> f acc any let fold_all_session s f acc = let files = get_files s in Hfile.fold (fun _key file acc -> fold_all_any s f acc (AFile file)) files acc let rec fold_all_sub_goals_of_proofn s f acc pnid = let pn = get_proofNode s pnid in let acc = List.fold_left (fun acc trid -> let tr = get_transfNode s trid in List.fold_left (fold_all_sub_goals_of_proofn s f) acc tr.transf_subtasks) acc pn.proofn_transformations in f acc pn let goal_iter_proof_attempt s f g = fold_all_sub_goals_of_proofn s (fun _ pn -> Hprover.iter (fun _ pa -> let pan = get_proof_attempt_node s pa in f pa pan) pn.proofn_attempts) () g let fold_all_sub_goals_of_theory s f acc th = List.fold_left (fold_all_sub_goals_of_proofn s f) acc th.theory_goals (* let theory_iter_proofn s f th = fold_all_sub_goals_of_theory s (fun _ -> f) () th *) let theory_iter_proof_attempt s f th = fold_all_sub_goals_of_theory s (fun _ pn -> Hprover.iter (fun _ pa -> let pan = get_proof_attempt_node s pa in f pa pan) pn.proofn_attempts) () th let file_iter_proof_attempt s f file = List.iter (theory_iter_proof_attempt s f) (file_theories file) let any_iter_proof_attempt s f any = match any with | AFile file -> file_iter_proof_attempt s f file | ATh th -> theory_iter_proof_attempt s f th | ATn tr -> let subgoals = get_sub_tasks s tr in List.iter (fun g -> goal_iter_proof_attempt s f g) subgoals | APn pn -> goal_iter_proof_attempt s f pn | APa pa -> f pa (get_proof_attempt_node s pa) (**************) (* Copy/Paste *) (**************) let get_any_parent s a = match a with | AFile _f -> None | ATh th -> Some (AFile (theory_parent s th)) | ATn tr -> Some (APn (get_trans_parent s tr)) | APn pn -> (match (get_proofNode s pn).proofn_parent with | Theory th -> Some (ATh th) | Trans tr -> Some (ATn tr)) | APa pa -> Some (APn (get_proof_attempt_node s pa).parent) (* True if bid is an ancestor of aid, false if not *) let rec is_below s (aid: any) (bid: any) = aid = bid || match (get_any_parent s aid) with | None -> false | Some pid -> is_below s pid bid open Format open Ident let print_proof_attempt fmt pa = fprintf fmt "%a tl=%d %a" Whyconf.print_prover pa.prover pa.limit.Call_provers.limit_time (Pp.print_option Call_provers.print_prover_result) pa.proof_state let rec print_proof_node s (fmt: Format.formatter) p = let pn = get_proofNode s p in let sum,_ = Hpn.find s.session_sum_shape_table p in let parent = match pn.proofn_parent with | Theory t -> t.theory_name.id_string | Trans id -> (get_transfNode s id).transf_name in fprintf fmt "@[ Goal %s;@ parent %s;@ sum %s;@ @[[%a]@]@ @[[%a]@]@]" pn.proofn_name.id_string parent (Termcode.string_of_checksum sum) (Pp.print_list Pp.semi print_proof_attempt) (Hprover.fold (fun _key e l -> let e = get_proof_attempt_node s e in e :: l) pn.proofn_attempts []) (Pp.print_list Pp.semi (print_trans_node s)) pn.proofn_transformations and print_trans_node s fmt id = let tn = get_transfNode s id in let args = get_transf_args s id in let name = tn.transf_name in let l = tn.transf_subtasks in let parent = (get_proofNode s tn.transf_parent).proofn_name.id_string in fprintf fmt "@[ Trans %s;@ args %a;@ parent %s;@ [%a]@]" name (Pp.print_list Pp.colon pp_print_string) args parent (Pp.print_list Pp.semi (print_proof_node s)) l let print_theory s fmt th : unit = fprintf fmt "@[ Theory %s;@ [%a]@]" th.theory_name.Ident.id_string (Pp.print_list Pp.semi (fun fmt a -> print_proof_node s fmt a)) th.theory_goals let print_file s fmt (file, thl) = fprintf fmt "@[ File [%a];@ [%a]@]" print_file_path file.file_path (Pp.print_list Pp.semi (print_theory s)) thl let print_s s fmt = fprintf fmt "@[%a@]" (Pp.print_list Pp.semi (print_file s)) let _print_session fmt s = let l = Hfile.fold (fun _ f acc -> (f,f.file_theories) :: acc) (get_files s) [] in fprintf fmt "%a@." (print_s s) l;; let empty_session ?from dir = let prover_ids = match from with | Some v -> v.session_prover_ids | None -> Hprover.create 7 in { proofAttempt_table = Hint.create 97; next_proofAttemptID = 0; proofNode_table = Hint.create 97; next_proofNodeID = 0; trans_table = Hint.create 97; next_transID = 0; next_fileID = 0; session_dir = dir; session_files = Hfile.create 3; session_prover_ids = prover_ids; session_raw_tasks = Hpn.create 97; session_task_tables = Hpn.create 97; session_sum_shape_table = Hpn.create 97; file_state = Hfile.create 3; th_state = Ident.Hid.create 7; tn_state = Htn.create 97; pn_state = Hpn.create 97; } (**************************************************) (* proof node/attempt/transformation manipulation *) (**************************************************) exception AlreadyExist let add_proof_attempt session prover limit state ~obsolete edit parentID = let pn = get_proofNode session parentID in try let _ = Hprover.find pn.proofn_attempts prover in raise AlreadyExist with Not_found -> let id = gen_proofAttemptID session in let pa = { parent = parentID; prover = prover; limit = limit; proof_state = state; proof_obsolete = obsolete; proof_script = edit } in Hprover.add pn.proofn_attempts prover id; Hint.replace session.proofAttempt_table id pa; id let graft_proof_attempt ?file (s : session) (id : proofNodeID) (pr : Whyconf.prover) ~limit = let pn = get_proofNode s id in try let id = Hprover.find pn.proofn_attempts pr in let pa = Hint.find s.proofAttempt_table id in let pa = { pa with limit = limit; proof_state = None; proof_obsolete = false} in (* Hprover.replace pn.proofn_attempts pr id; useless *) Hint.replace s.proofAttempt_table id pa; id with Not_found -> add_proof_attempt s pr limit None ~obsolete:false file id (* [mk_proof_node s n t p id] register in the session [s] a proof node of proofNodeID [id] of parent [p] of task [t] *) let mk_proof_node ~shape_version ~expl (s : session) (n : Ident.ident) (t : Task.task) (parent : proof_parent) (node_id : proofNodeID) = let pn = { proofn_name = n; proofn_expl = expl; proofn_parent = parent; proofn_attempts = Hprover.create 7; proofn_transformations = [] } in Hint.add s.proofNode_table node_id pn; Hpn.add s.session_raw_tasks node_id t; let sum = Termcode.task_checksum ~version:shape_version t in let shape = Termcode.t_shape_task ~version:shape_version ~expl t in Hpn.add s.session_sum_shape_table node_id (sum,shape) let mk_new_proof_node = mk_proof_node ~shape_version:Termcode.current_shape_version let mk_proof_node_no_task (s : session) (n : Ident.ident) (parent : proof_parent) (node_id : proofNodeID) sum shape expl proved = let pn = { proofn_name = n; proofn_expl = expl; proofn_parent = parent; proofn_attempts = Hprover.create 7; proofn_transformations = [] } in Hint.add s.proofNode_table node_id pn; Hpn.add s.session_sum_shape_table node_id (sum,shape); Hint.add s.pn_state node_id proved let mk_new_transf_proof_node (s : session) (parent_name : string) (tid : transID) (index : int) (t : Task.task) = let id = gen_proofNodeID s in let gid,expl,_ = Termcode.goal_expl_task ~root:false t in let goal_name = parent_name ^ "." ^ string_of_int index in let goal_name = Ident.id_register (Ident.id_derive goal_name gid) in mk_new_proof_node ~expl s goal_name t (Trans tid) id; id let mk_transf_node (s : session) (id : proofNodeID) (node_id : transID) (name : string) (args : string list) ~(proved:bool) ~(detached:bool) (pnl : proofNodeID list) = let pn = get_proofNode s id in let tn = { transf_name = name; transf_args = args; transf_subtasks = pnl; transf_parent = id; transf_is_detached = detached; } in Hint.add s.trans_table node_id tn; Htn.add s.tn_state node_id proved; pn.proofn_transformations <- node_id::pn.proofn_transformations let graft_transf (s : session) (id : proofNodeID) (name : string) (args : string list) (tl : Task.task list) = let tid = gen_transID s in let parent_name = (get_proofNode s id).proofn_name.Ident.id_string in let sub_tasks = List.mapi (mk_new_transf_proof_node s parent_name tid) tl in let proved = sub_tasks = [] in mk_transf_node s id tid name args ~proved sub_tasks ~detached:false; tid let update_proof_attempt ?(obsolete=false) notifier s id pr st = try let n = get_proofNode s id in let paid = Hprover.find n.proofn_attempts pr in let pa = get_proof_attempt_node s paid in pa.proof_state <- Some st; pa.proof_obsolete <- obsolete; notifier (APa paid) with | BadID when not (Debug.test_flag debug_stack_trace) -> assert false (* proved status *) let tn_proved s tid = Htn.find_def s.tn_state false tid let pn_proved s pid = Hpn.find_def s.pn_state false pid let th_proved s th = try Hid.find s.th_state th.theory_name with Not_found -> let b = theory_goals th = [] in Hid.add s.th_state th.theory_name b; b let file_proved s f = try Hfile.find s.file_state f.file_id with Not_found -> let b = f.file_theories = [] in Hfile.add s.file_state f.file_id b; b let pa_proved s paid = let pa = get_proof_attempt_node s paid in match pa.proof_state with | None -> false | Some pa -> begin match pa.Call_provers.pr_answer with | Call_provers.Valid -> true | _ -> false end let any_proved s any : bool = match any with | AFile file -> file_proved s file | ATh th -> th_proved s th | ATn tn -> tn_proved s tn | APn pn -> pn_proved s pn | APa pa -> pa_proved s pa (* status update *) type notifier = any -> unit let pa_ok pa = not pa.proof_obsolete && match pa.proof_state with | Some { Call_provers.pr_answer = Call_provers.Valid} -> true | _ -> false (* [update_goal_node c id] update the proof status of node id update is propagated to parents when required. *) let update_file_node notification s f = let ths = f.file_theories in if ths = [] then (* No updates if ths is empty *) () else let proved = List.for_all (fun th -> th.theory_is_detached || th_proved s th) ths in if proved <> file_proved s f then begin Hfile.replace s.file_state f.file_id proved; notification (AFile f); end let update_theory_node notification s th = let goals = theory_goals th in let proved = List.for_all (fun pn -> goal_is_detached s pn || pn_proved s pn) goals in if proved <> th_proved s th then begin Debug.dprintf debug "[Session] setting theory %s to status proved=%b@." th.theory_name.Ident.id_string proved; Hid.replace s.th_state (theory_name th) proved; notification (ATh th); try let p = theory_parent s th in update_file_node notification s p with Not_found when not (Debug.test_flag Debug.stack_trace) -> Format.eprintf "[Fatal] Session_itp.update_theory_node: parent missing@."; assert false end let rec update_goal_node notification s id = let tr_list = get_transformations s id in let pa_list = get_proof_attempts s id in let proved = List.exists (fun tr -> not (transf_is_detached s tr) && tn_proved s tr) tr_list || List.exists (fun pa -> not (goal_is_detached s pa.parent) && pa_ok pa) pa_list in if proved <> pn_proved s id then begin (* too noisy, uncomment if you really need it Debug.dprintf debug "[Session] setting goal node %a to status proved=%b@." print_proofNodeID id proved; *) Hpn.replace s.pn_state id proved; notification (APn id); match get_proof_parent s id with | Trans trans_id -> update_trans_node notification s trans_id | Theory th -> update_theory_node notification s th | exception Not_found when not (Debug.test_flag Debug.stack_trace) -> Format.eprintf "Session_itp.update_goal_node: parent missing@."; Printexc.print_backtrace stderr; assert false end and update_trans_node notification s trid = let proof_list = get_sub_tasks s trid in let proved = List.for_all (fun pn -> goal_is_detached s pn || pn_proved s pn) proof_list in if proved <> tn_proved s trid then begin Htn.replace s.tn_state trid proved; notification (ATn trid); update_goal_node notification s (get_trans_parent s trid) end; (* Specific case in which we *always* need to call notification because transformation are created with proved=true when they don't have subtasks. This means they won't be updated in the next if so the parent goal will never get updated. *) if proof_list = [] then update_goal_node notification s (get_trans_parent s trid) let update_any_node s notification a = match a with | APn id -> update_goal_node notification s id | ATn id -> update_trans_node notification s id | APa _ -> assert false | AFile f -> update_file_node notification s f | ATh th -> update_theory_node notification s th let change_prover notification s id opr npr = try let n = get_proofNode s id in let paid = Hprover.find n.proofn_attempts opr in let pa = get_proof_attempt_node s paid in Hprover.remove n.proofn_attempts opr; pa.prover <- npr; pa.proof_obsolete <- true; Hprover.add n.proofn_attempts npr paid; update_goal_node notification s id with | Not_found -> () | BadID when not (Debug.test_flag debug_stack_trace) -> assert false (* Remove elements of the session tree *) let remove_transformation (s : session) (id : transID) = let nt = get_transfNode s id in Hint.remove s.trans_table id; let pn = get_proofNode s nt.transf_parent in let trans_up = List.filter (fun tid -> tid != id) pn.proofn_transformations in pn.proofn_transformations <- trans_up let remove_proof_attempt (s : session) (id : proofNodeID) (prover : Whyconf.prover) = let pn = get_proofNode s id in let pa = Hprover.find pn.proofn_attempts prover in Hprover.remove pn.proofn_attempts prover; Hint.remove s.proofAttempt_table pa let remove_proof_attempt_pa s (id: proofAttemptID) = let pa = get_proof_attempt_node s id in let pn = pa.parent in let prover = pa.prover in remove_proof_attempt s pn prover let mark_obsolete s (id: proofAttemptID) = let pa = get_proof_attempt_node s id in pa.proof_obsolete <- true exception RemoveError let remove_subtree ~(notification:notifier) ~(removed:notifier) s (n: any) = let remove (n: any) = match n with | ATn tn -> remove_transformation s tn | APa pa -> remove_proof_attempt_pa s pa | AFile f -> Hfile.remove s.session_files f.file_id | APn pn -> let node = Hint.find s.proofNode_table pn in Hint.remove s.proofNode_table pn; begin match node.proofn_parent with | Theory th -> th.theory_goals <- List.filter ((<>) pn) th.theory_goals | Trans tr -> let nt = get_transfNode s tr in nt.transf_subtasks <- List.filter ((<>) pn) nt.transf_subtasks end | ATh th -> let f = theory_parent s th in f.file_theories <- List.filter ((!=) th) f.file_theories in match n with | (AFile _ | APn _ | ATh _) when not (is_detached s n) -> raise RemoveError | _ -> let p = get_any_parent s n in fold_all_any s (fun _ x -> remove x; removed x) () n; Opt.iter (update_any_node s notification) p (****************************) (* session opening *) (****************************) let db_filename = "why3session.xml" let shape_filename = "why3shapes" let compressed_shape_filename = "why3shapes.gz" let session_dir_for_save = ref "." exception LoadError of Xml.element * string exception SessionFileError of string 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 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 default_unknown_result = { Call_provers.pr_answer = Call_provers.Failure ""; Call_provers.pr_time = 0.0; Call_provers.pr_output = ""; Call_provers.pr_status = Unix.WEXITED 0; Call_provers.pr_steps = -1; Call_provers.pr_model = Model_parser.default_model; } 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 "" | "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 { 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" | "unedited" -> default_unknown_result | s -> Warning.emit "[Warning] Session.load_result: unexpected element '%s'@." s; default_unknown_result 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 attrs = List.fold_left (fun acc label -> match label with | {Xml.name = "label"} -> let name = string_attribute "name" label in Ident.Sattr.add (Ident.create_attribute name) acc | _ -> acc ) Ident.Sattr.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 ~attrs name pos with Not_found | Invalid_argument _ -> Ident.id_fresh ~attrs name in Ident.id_register preid (* [load_goal s op p g id] loads the goal of parent [p] from the xml [g] of nodeID [id] into the session [s] *) let rec load_goal session old_provers parent g id = match g.Xml.name with | "goal" -> let gname = load_ident g in (* even if sum and shape are not in the XML file but in the shape file, these attributes are there thanks to ~fixattr on Xml.from_file *) let csum = string_attribute_def "sum" g "" in let sum = Termcode.checksum_of_string csum in let shape = try Termcode.shape_of_string (List.assoc "shape" g.Xml.attributes) with Not_found -> Termcode.shape_of_string "" in let expl = string_attribute_def "expl" g "" in let proved = bool_attribute "proved" g false in mk_proof_node_no_task session gname parent id sum shape expl proved; List.iter (load_proof_or_transf session old_provers id) g.Xml.elements; | "label" -> () | s -> Warning.emit "[Warning] Session.load_goal: unexpected element '%s'@." s (* [load_proof_or_transf s op pid a] load either a proof attempt or a transformation of parent id [pid] from the xml [a] into the session [s] *) and load_proof_or_transf session old_provers pid 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 old_provers in let res = match a.Xml.elements with | [r] -> load_result r | [] -> default_unknown_result | _ -> 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 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 ignore(add_proof_attempt session p limit (Some res) ~obsolete edit pid) 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 rec get_args id = match string_attribute_opt ("arg"^(string_of_int id)) a with | Some arg -> arg :: (get_args (id+1)) | None -> [] in let args = get_args 1 in let tid = gen_transID session in let proved = bool_attribute "proved" a false in let subtasks_ids = List.rev (List.fold_left (fun goals th -> match th.Xml.name with | "goal" -> (gen_proofNodeID session) :: goals | _ -> goals) [] a.Xml.elements) in mk_transf_node session pid tid trname args ~proved subtasks_ids ~detached:true; List.iter2 (load_goal session old_provers (Trans tid)) a.Xml.elements subtasks_ids; | "metas" -> () | "label" -> () | s -> Warning.emit "[Warning] Session.load_proof_or_transf: unexpected element '%s'@." s let load_theory session parent_name old_provers (path,acc) th = match th.Xml.name with | "theory" -> let thname = load_ident th in let goals = List.rev (List.fold_left (fun goals th -> match th.Xml.name with | "goal" -> (gen_proofNodeID session) :: goals | _ -> goals) [] th.Xml.elements) in let mth = { theory_name = thname; theory_is_detached = true; theory_goals = goals; theory_parent_name = parent_name; } in List.iter2 (load_goal session old_provers (Theory mth)) th.Xml.elements goals; let proved = bool_attribute "proved" th false in Hid.add session.th_state thname proved; (path,mth::acc) | "path" -> let fn = string_attribute "name" th in (fn::path,acc) | s -> Warning.emit "[Warning] Session.load_theory: unexpected element '%s'@." s; (path,acc) let load_file session old_provers f = match f.Xml.name with | "file" -> let fn = string_attribute_opt "name" f in let fmt = load_option "format" f in let fid = gen_fileID session in let path,ft = List.fold_left (load_theory session fid old_provers) ([],[]) f.Xml.elements in let path = match path,fn with | [], Some fn -> let l = Sysutil.system_independent_path_of_file fn in Debug.dprintf debug "Loaded path from concrete file name: %a@." print_file_path l; l | [],None -> assert false | p,_ -> List.rev p in let mf = { file_id = fid; file_path = path; file_format = fmt; file_is_detached = true; file_theories = List.rev ft; } in Hfile.add session.session_files fid 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 1 in let memlimit = int_attribute_def "memlimit" f 1000 in let p = {Whyconf.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 build_session (s : session) xml = match xml.Xml.name with | "why3session" -> let shape_version = int_attribute_def "shape_version" xml 1 in 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 s) Mint.empty xml.Xml.elements in Mint.iter (fun id (p,_,_,_) -> Debug.dprintf debug "prover %d: %a@." id Whyconf.print_prover p; Hprover.replace s.session_prover_ids p id) old_provers; Debug.dprintf debug "[Info] load_session: done@\n"; shape_version | s -> Warning.emit "[Warning] Session.load_session: unexpected element '%s'@." s; Termcode.current_shape_version exception ShapesFileError 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 has_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 _ -> has_shapes := false; attrs else attrs let read_xml_and_shapes xml_fn compressed_fn = has_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, !has_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 load_session (dir : string) = let session = empty_session dir in let file = Filename.concat dir db_filename in let shape_version = (* If the xml is present we read it, otherwise we consider it empty *) if Sys.file_exists file then try (* Termcode.reset_dict (); *) let xml,has_shapes = read_file_session_and_shapes dir file in try let shape_version = build_session session xml.Xml.content in if has_shapes then Some shape_version else None 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 None in session, shape_version (* -------------------- merge/update session --------------------------- *) (** Pairing *) module Goal = struct type 'a t = proofNodeID * session let checksum (id,s) = Some (fst (Hpn.find s.session_sum_shape_table id)) let shape (id,s) = snd (Hpn.find s.session_sum_shape_table id) let name (id,s) = (get_proofNode s id).proofn_name end module AssoGoals = Termcode.Pairing(Goal)(Goal) let found_obsolete = ref false let found_detached = ref false (* FIXME: distinguish found_new_goals and found_detached *) let save_detached_proof s parent old_pa_n = let old_pa = old_pa_n in ignore (add_proof_attempt s old_pa.prover old_pa.limit old_pa.proof_state ~obsolete:old_pa.proof_obsolete old_pa.proof_script parent) let rec save_detached_goal old_s s parent detached_goal_id id = let detached_goal = get_proofNode old_s detached_goal_id in let (sum,shape) = Hpn.find old_s.session_sum_shape_table detached_goal_id in mk_proof_node_no_task s detached_goal.proofn_name parent id sum shape detached_goal.proofn_expl false; Hprover.iter (fun _ pa -> let pa = get_proof_attempt_node old_s pa in save_detached_proof s id pa) detached_goal.proofn_attempts; List.iter (save_detached_trans old_s s id) detached_goal.proofn_transformations; let new_trans = (get_proofNode s id) in new_trans.proofn_transformations <- List.rev new_trans.proofn_transformations and save_detached_goals old_s detached_goals_id s parent = List.map (fun detached_goal -> let id = gen_proofNodeID s in save_detached_goal old_s s parent detached_goal id; id) detached_goals_id and save_detached_trans old_s s parent_id old_id = let old_tr = get_transfNode old_s old_id in let name = old_tr.transf_name in let args = old_tr.transf_args in let id = gen_transID s in let subtasks_id = List.map (fun _ -> gen_proofNodeID s) old_tr.transf_subtasks in let proved = subtasks_id = [] in mk_transf_node s parent_id id name args ~proved subtasks_id ~detached:true; List.iter2 (fun pn_id -> save_detached_goal old_s s (Trans id) pn_id) old_tr.transf_subtasks subtasks_id let save_detached_theory parent_name old_s detached_theory s = let goalsID = save_detached_goals old_s detached_theory.theory_goals s (Theory detached_theory) in assert (detached_theory.theory_parent_name = parent_name); detached_theory.theory_goals <- goalsID; detached_theory.theory_is_detached <- true; detached_theory let merge_proof new_s ~goal_obsolete new_goal _ old_pa_n = let old_pa = old_pa_n in let obsolete = goal_obsolete || old_pa.proof_obsolete in found_obsolete := obsolete || !found_obsolete; ignore (add_proof_attempt new_s old_pa.prover old_pa.limit old_pa.proof_state ~obsolete old_pa.proof_script new_goal) exception NoProgress let () = Exn_printer.register (fun fmt e -> match e with | NoProgress -> Format.fprintf fmt "The transformation made no progress.\n" | _ -> raise e) let apply_trans_to_goal ~allow_no_effect s env name args id = let task,table = get_task_name_table s id in let subtasks = Trans.apply_transform_args name env args table task in (* If any generated task is equal to the former task, then we made no progress because we need to prove more lemmas than before *) match subtasks with | [t'] when Task.task_equal t' task && not allow_no_effect -> Debug.dprintf debug "[apply_trans_to_goal] apply_transform made no progress@."; raise NoProgress | _ -> subtasks let add_registered_transformation s env old_tr goal_id = let goal = get_proofNode s goal_id in try (* check if transformation already present with the same parameters. this should always fail and raise Not_found *) let _tr = List.find (fun transID -> (get_transfNode s transID).transf_name = old_tr.transf_name && List.fold_left2 (fun b new_arg old_arg -> new_arg = old_arg && b) true (get_transfNode s transID).transf_args old_tr.transf_args) goal.proofn_transformations in Printexc.print_backtrace stderr; Format.eprintf "[add_registered_transformation] FATAL transformation already present@."; exit 2 with Not_found -> let subgoals = apply_trans_to_goal ~allow_no_effect:true s env old_tr.transf_name old_tr.transf_args goal_id in graft_transf s goal_id old_tr.transf_name old_tr.transf_args subgoals let rec merge_goal ~shape_version env new_s old_s ~goal_obsolete old_goal new_goal_id = Hprover.iter (fun k pa -> let pa = get_proof_attempt_node old_s pa in merge_proof new_s ~goal_obsolete new_goal_id k pa) old_goal.proofn_attempts; List.iter (merge_trans ~shape_version env old_s new_s new_goal_id) old_goal.proofn_transformations; let new_goal_node = get_proofNode new_s new_goal_id in new_goal_node.proofn_transformations <- List.rev new_goal_node.proofn_transformations; update_goal_node (fun _ -> ()) new_s new_goal_id and merge_trans ~shape_version env old_s new_s new_goal_id old_tr_id = let old_tr = get_transfNode old_s old_tr_id in let old_subtasks = List.map (fun id -> id,old_s) old_tr.transf_subtasks in try match (* add_registered_transformation actually apply the transformation. It can fail *) try Some (add_registered_transformation new_s env old_tr new_goal_id) with _ -> None with | Some new_tr_id -> let new_tr = get_transfNode new_s new_tr_id in (* attach the session to the subtasks to be able to instantiate Pairing *) let new_subtasks = List.map (fun id -> id,new_s) new_tr.transf_subtasks in let associated,detached = AssoGoals.associate ~use_shapes:(shape_version <> None) old_subtasks new_subtasks in List.iter (function | ((new_goal_id,_), Some ((old_goal_id,_), goal_obsolete)) -> merge_goal ~shape_version env new_s old_s ~goal_obsolete (get_proofNode old_s old_goal_id) new_goal_id | ((id,s), None) -> Debug.dprintf debug "[merge_trans] missed new subgoal: %s@." (get_proofNode s id).proofn_name.Ident.id_string; found_detached := true) associated; (* save the detached goals *) let detached = List.map (fun (id,_) -> Debug.dprintf debug "[merge_trans] detached subgoal: %s@." (get_proofNode old_s id).proofn_name.Ident.id_string; found_detached := true; id) detached in new_tr.transf_subtasks <- new_tr.transf_subtasks @ save_detached_goals old_s detached new_s (Trans new_tr_id) | None -> Debug.dprintf debug "[Session_itp.merge_trans] transformation failed: %s@." old_tr.transf_name; save_detached_trans old_s new_s new_goal_id old_tr_id; found_detached := true with e when not (Debug.test_flag debug_stack_trace) -> Printexc.print_backtrace stderr; Format.eprintf "[Session_itp.merge_trans] FATAL unexpected exception: %a@." Exn_printer.exn_printer e; exit 2 let merge_theory ~shape_version env old_s old_th s th : unit = let get_goal_name goal_node = let name = goal_node.proofn_name in try let (_,_,l) = Theory.restore_path name in String.concat "." l with Not_found -> name.Ident.id_string in let old_goals_table = Hstr.create 7 in (* populate old_goals_table *) List.iter (fun id -> let pn = get_proofNode old_s id in Hstr.add old_goals_table (get_goal_name pn) id) old_th.theory_goals; let new_goals = ref [] in (* merge goals *) List.iter (fun ng_id -> try let new_goal = get_proofNode s ng_id in (* look for old_goal with matching name *) let new_goal_name = get_goal_name new_goal in let old_id = Hstr.find old_goals_table new_goal_name in let old_goal = get_proofNode old_s old_id in Hstr.remove old_goals_table new_goal_name; let goal_obsolete = let s1 = fst (Hpn.find s.session_sum_shape_table ng_id) in let s2 = fst (Hpn.find old_s.session_sum_shape_table old_id) in Debug.dprintf debug "[merge_theory] goal has checksum@."; not (Termcode.equal_checksum s1 s2) in if goal_obsolete then found_obsolete := true; merge_goal ~shape_version env s old_s ~goal_obsolete old_goal ng_id with | Not_found -> (* if no goal of matching name is found store it to look for matching shape *) new_goals := (ng_id,s) :: !new_goals) th.theory_goals; (* check shapes if no old_goal is found with matching name *) (* attach the session to the subtasks to be able to instantiate Pairing *) let detached_goals = Hstr.fold (fun _key g tl -> (g,old_s) :: tl) old_goals_table [] in let associated,detached = AssoGoals.associate ~use_shapes:(shape_version <> None) detached_goals !new_goals in List.iter (function | ((new_goal_id,_), Some ((old_goal_id,_), goal_obsolete)) -> Debug.dprintf debug "[merge_theory] pairing paired one goal, yeah !@."; merge_goal ~shape_version env s old_s ~goal_obsolete (get_proofNode old_s old_goal_id) new_goal_id | ((id,_), None) -> Debug.dprintf debug "[merge_theory] pairing found missed sub goal: %s@." (get_proofNode s id).proofn_name.Ident.id_string; found_detached := true) associated; (* store the detached goals *) let detached = List.map (fun (a,_) -> a) detached in th.theory_goals <- th.theory_goals @ save_detached_goals old_s detached s (Theory th) (* add a theory and its goals to a session. if a previous theory is provided in merge try to merge the new theory with the previous one *) let make_theory_section ?merge ~detached (s:session) parent_name (th:Theory.theory) : theory = let add_goal = match merge with | Some(_,_,_,Some v) -> fun parent goal id -> let name,expl,task = Termcode.goal_expl_task ~root:true goal in mk_proof_node ~shape_version:v ~expl s name task parent id | _ -> fun parent goal id -> let name,expl,task = Termcode.goal_expl_task ~root:true goal in mk_new_proof_node ~expl s name task parent id in let tasks = Task.split_theory th None None in let goalsID = List.map (fun _ -> gen_proofNodeID s) tasks in let theory = { theory_name = th.Theory.th_name; theory_is_detached = detached; theory_goals = goalsID; theory_parent_name = parent_name; } in let parent = Theory theory in List.iter2 (add_goal parent) tasks goalsID; begin match merge with | Some (old_s, old_th, env, shape_version) -> merge_theory ~shape_version env old_s old_th s theory | _ -> if tasks <> [] then found_detached := true (* should be found_new_goals instead of found_detached *) end; theory (* add a why file to a session *) let add_file_section (s:session) (fn:string) ~file_is_detached (theories:Theory.theory list) format : file = let fn = Sysutil.relativize_filename s.session_dir fn in Debug.dprintf debug "[Session_itp.add_file_section] fn = %a@." print_file_path fn; (* if Hfile.mem s.session_files fn then begin Printexc.print_backtrace stderr; Format.eprintf "[session] FATAL: file %s already in database@." fn; exit 2 end else *) let fid = gen_fileID s in let f = { file_id = fid; file_path = fn; file_format = format; file_is_detached = file_is_detached; file_theories = [] } in Hfile.add s.session_files fid f; let theories = List.map (make_theory_section ~detached:false s fid) theories in f.file_theories <- theories; f (* add a why file to a session and try to merge its theories with the provided ones with matching names *) let merge_file_section ~shape_version ~old_ses ~old_theories ~file_is_detached ~env (s:session) (fn:string) (theories:Theory.theory list) format : unit = Debug.dprintf debug_merge "[Session_itp.merge_file_section] fn = %s@." fn; let f = add_file_section s fn ~file_is_detached [] format in let fid = f.file_id in let theories,detached = let old_th_table = Hstr.create 7 in List.iter (fun th -> Hstr.add old_th_table th.theory_name.Ident.id_string th) old_theories; let add_theory (th: Theory.theory) = (* look for a theory with same name *) let theory_name = th.Theory.th_name.Ident.id_string in try (* if we found one, we remove it from the table and merge it *) let old_th = Hstr.find old_th_table theory_name in Debug.dprintf debug_merge "[Session_itp.merge_file_section] theory found: %s@." theory_name; Hstr.remove old_th_table theory_name; make_theory_section ~detached:false ~merge:(old_ses,old_th,env,shape_version) s fid th with Not_found -> (* if no theory was found we make a new theory section *) Debug.dprintf debug_merge "[Session_itp.merge_file_section] theory NOT FOUND in old session: %s@." theory_name; make_theory_section ~detached:false s fid th in let theories = List.map add_theory theories in (* we save the remaining, detached *) let detached = Hstr.fold (fun _key th tl -> (save_detached_theory fid old_ses th s) :: tl) old_th_table [] in theories, List.rev detached in f.file_theories <- theories @ detached; update_file_node (fun _ -> ()) s f 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 let th = List.sort (fun (l1,_,_) (l2,_,_) -> Loc.compare l1 l2) ltheories in List.map (fun (_,_,a) -> a) th let merge_file ~shape_version env (ses : session) (old_ses : session) file = let format = file_format file in let old_theories = file_theories file in let file_name = Sysutil.system_dependent_absolute_path (get_dir old_ses) (file_path file) in Debug.dprintf debug "merging file %s@." file_name; try let new_theories = read_file env file_name ?format in merge_file_section ses ~shape_version ~old_ses ~old_theories ~file_is_detached:false ~env file_name new_theories format; None with e -> (* TODO: capture only parsing and typing errors *) merge_file_section ses ~shape_version ~old_ses ~old_theories ~file_is_detached:true ~env file_name [] format; Some e let merge_files ~shape_version env (ses:session) (old_ses : session) = Debug.dprintf debug "merging files from old session@."; let errors = Hfile.fold (fun _ f acc -> match merge_file ~shape_version env ses old_ses f with | None -> acc | Some e -> e :: acc) (get_files old_ses) [] in (* recompute shapes if absent or obsolete *) if shape_version <> Some Termcode.current_shape_version then begin Hpn.clear ses.session_sum_shape_table; let version = Termcode.current_shape_version in fold_all_session ses (fun () n -> match n with | APn id -> let sum,shape = try let t = get_task ses id in let _,expl,_ = Termcode.goal_expl_task ~root:false t in let sum = Termcode.task_checksum ~version t in let shape = Termcode.t_shape_task ~version ~expl t in sum, shape with Not_found -> (* detached goal *) Termcode.dumb_checksum, Termcode.shape_of_string "" in Hpn.add ses.session_sum_shape_table id (sum,shape) | _ -> () ) () end; (errors,!found_obsolete,!found_detached) (************************) (* saving state on disk *) (************************) module Mprover = Whyconf.Mprover module PHprover = Whyconf.Hprover open Format let save_string = Pp.html_string type save_ctxt = { prover_ids : int PHprover.t; provers : (int * int * int * int) Mprover.t; ch_shapes : Compress.Compress_z.out_channel; } 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.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.limit.Call_provers.limit_time in let lim_mem = pa.limit.Call_provers.limit_mem in let lim_steps = pa.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 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 opt pr lab fmt = function | None -> () | Some s -> fprintf fmt "@ %s=\"%a\"" lab pr s let opt_string = opt save_string 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.Whyconf.prover_name save_string p.Whyconf.prover_version (fun fmt s -> if s <> "" then fprintf fmt "@ alternative=\"%a\"" save_string s) p.Whyconf.prover_altern mostfrequent_timelimit (opt pp_print_int "steplimit") steplimit mostfrequent_memlimit let save_string_attrib name fmt s = if s <> "" then fprintf fmt "@ %s=\"%a\"" name save_string s let save_option_def name fmt opt = match opt with | None -> () | Some s -> save_string_attrib name fmt s 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 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 | Some result -> save_result fmt result | None -> fprintf fmt "" let save_proof_attempt fmt ((id,tl,sl,ml),a) = fprintf fmt "@\n@[" id (save_int_def "timelimit" tl) (a.limit.Call_provers.limit_time) (save_int_def "steplimit" sl) (a.limit.Call_provers.limit_steps) (save_int_def "memlimit" ml) (a.limit.Call_provers.limit_mem) (save_bool_def "obsolete" false) a.proof_obsolete (save_option_def "edited") a.proof_script; save_status fmt a.proof_state; fprintf fmt "@]" let save_ident fmt id = let n = try let (_,_,l) = Theory.restore_path id in if l = [] then raise Not_found; String.concat "." l with Not_found -> id.Ident.id_string in fprintf fmt "name=\"%a\"" save_string n let rec save_goal s ctxt fmt pnid = let pn = get_proofNode s pnid in fprintf fmt "@\n@[@[@]" save_ident pn.proofn_name (save_string_attrib "expl") pn.proofn_expl (save_bool_def "proved" false) (pn_proved s pnid); let (sum,shape) = Hpn.find s.session_sum_shape_table pnid in Compress.Compress_z.output_string ctxt.ch_shapes (Termcode.string_of_checksum sum); Compress.Compress_z.output_char ctxt.ch_shapes ' '; Compress.Compress_z.output_string ctxt.ch_shapes (Termcode.string_of_shape shape); Compress.Compress_z.output_char ctxt.ch_shapes '\n'; let l = Hprover.fold (fun _ a acc -> let a = get_proof_attempt_node s a in (Mprover.find a.prover ctxt.provers, a) :: acc) pn.proofn_attempts [] in let l = List.sort (fun ((i1,_,_,_),_) ((i2,_,_,_),_) -> compare i1 i2) l in List.iter (save_proof_attempt fmt) l; let l = List.fold_left (fun acc t -> (t,get_transfNode s t) :: acc) [] pn.proofn_transformations in let l = List.sort (fun (_,t1) (_,t2) -> compare t1.transf_name t2.transf_name) l in List.iter (save_trans s ctxt fmt) l; fprintf fmt "@]@\n"; and save_trans s ctxt fmt (tid,t) = let arg_id = ref 0 in let save_arg fmt s = arg_id := !arg_id + 1; fprintf fmt "arg%i=\"%a\"" !arg_id save_string s in fprintf fmt "@\n@[@[@]" save_string t.transf_name (save_bool_def "proved" false) (tn_proved s tid) (Pp.print_list Pp.space save_arg) t.transf_args; List.iter (save_goal s ctxt fmt) t.transf_subtasks; fprintf fmt "@]@\n" let save_theory s ctxt fmt t = (* Saving empty theories takes space in session files. Not saving them should be harmless. *) if t.theory_goals <> [] then begin fprintf fmt "@\n@[@[@]" save_ident t.theory_name (save_bool_def "proved" false) (th_proved s t); List.iter (save_goal s ctxt fmt) t.theory_goals; fprintf fmt "@]@\n    " end let save_file s ctxt fmt _ f = fprintf fmt "@\n@[@[@]" (opt_string "format") f.file_format (save_bool_def "proved" false) (file_proved s f); List.iter (fun s -> fprintf fmt "@\n@[@]" s) f.file_path; List.iter (save_theory s ctxt fmt) f.file_theories; fprintf fmt "@]@\n" let save fname shfname session = let ch = open_out fname in let chsh = Compress.Compress_z.open_out shfname in let fmt = formatter_of_out_channel ch in fprintf fmt "@\n"; fprintf fmt "@\n"; fprintf fmt "@[" Termcode.current_shape_version; 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 Hfile.iter (save_file session ctxt fmt) session.session_files; fprintf fmt "@]@\n"; fprintf fmt "@."; close_out ch; Compress.Compress_z.close_out chsh let save_session (s : session) = let f = Filename.concat s.session_dir db_filename in Sysutil.backup_file f; let fs = Filename.concat s.session_dir shape_filename in Sysutil.backup_file fs; let fz = Filename.concat s.session_dir compressed_shape_filename in Sysutil.backup_file fz; session_dir_for_save := s.session_dir; let fs = if Compress.compression_supported then fz else fs in save f fs s (**********************) (* Edition of session *) (**********************) let find_file_from_path s path = let files = get_files s in let file = Hfile.fold (fun _ f acc -> if f.file_path = path then Some f else acc) files None in match file with | None -> raise Not_found | Some file -> file let rename_file s from_file to_file = let src = Sysutil.relativize_filename s.session_dir from_file in let dst = Sysutil.relativize_filename s.session_dir to_file in let file = find_file_from_path s src in file.file_path <- dst; src,dst why3-1.2.1/src/session/compress_z.ml0000644000175100017510000000342613555524575020156 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/session/json_util.mli0000644000175100017510000000250413555524575020145 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 Itp_communication (** Useful functions for printing *) val convert_node_type_string: node_type -> string (** Print in Json format *) val print_request: Format.formatter -> ide_request -> unit val print_notification: Format.formatter -> notification -> unit val print_list_request: Format.formatter -> ide_request list -> unit val print_list_notification: Format.formatter -> notification list -> unit (** Parse from Json format *) val parse_request: string -> ide_request val parse_notification: string -> notification val parse_list_request: string -> ide_request list val parse_list_notification: string -> notification list why3-1.2.1/src/session/strategy_parser.mli0000644000175100017510000000144613555524575021361 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 : Env.env -> Whyconf.config -> string -> Strategy.t why3-1.2.1/src/session/xml.mli0000644000175100017510000000241313555524575016736 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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-1.2.1/src/session/itp_communication.mli0000644000175100017510000001361013555524575021660 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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. *) (* *) (********************************************************************) (* Name and description *) type transformation = (string * string) type strategy = string type node_ID = int val root_node : node_ID val is_root : node_ID -> bool (* --------------------------- types to be expanded if needed --------------------------------- *) (** Global information known when server process has started and that can be shared with the IDE through communication *) type global_information = { provers : (string * string * string) list; (* (shortcut, human readable name, parseable name) *) transformations : transformation list; strategies : (string * strategy) list; commands : string list (* hidden_provers : string list; *) (* session_time_limit : int; *) (* session_mem_limit : int; *) (* session_nb_processes : int; *) (* session_cntexample : bool; *) (* main_dir : string *) } type message_notification = | Proof_error of node_ID * string | Transf_error of bool * node_ID * string * string * Loc.position * string * string (** Transf_error (is_fatal, nid, trans_with_arg, arg_opt, loc, error_msg, doc_of_transf *) | Strat_error of node_ID * string | Replay_Info of string | Query_Info of node_ID * string | Query_Error of node_ID * string (** General information *) | Information of string (** Number of task scheduled, running, etc *) | Task_Monitor of int * int * int (** A file was read or reloaded and now contains a parsing or typing error. second loc is relative to the session file *) | Parse_Or_Type_Error of Loc.position * Loc.position * string (** [File_Saved f] f was saved *) | File_Saved of string (** An error happened that could not be identified in server *) | Error of string | Open_File_Error of string type node_type = | NRoot | NFile | NTheory | NTransformation | NGoal | NProofAttempt (** Used to give colors to the parts of the source code that corresponds to the following property in the current task. For example, the code corresponding to the goal of the task will have Goal_color in the source code. *) type color = | Neg_premise_color | Premise_color | Goal_color | Error_color | Error_line_color | Error_font_color type update_info = | Proved of bool | Name_change of string | Proof_status_change of Controller_itp.proof_attempt_status * bool (* obsolete or not *) * Call_provers.resource_limit type notification = | Reset_whole_tree | New_node of node_ID * node_ID * node_type * string * bool (** Notification of creation of new_node: New_node (new_node, parent_node, node_type, name, detached). *) | Node_change of node_ID * update_info (** inform that the data of the given node changed *) | Remove of node_ID (** the given node was removed *) | Next_Unproven_Node_Id of node_ID * node_ID (** Next_Unproven_Node_Id (asked_id, next_unproved_id). Returns a node and the next unproven node from this node *) | Initialized of global_information (** initial global data *) | Saving_needed of bool (** the session needs saving when argument is true *) | Saved (** the session was just saved on disk *) | Message of message_notification (** an informative message, can be an error message *) | Dead of string (** server exited *) | Task of node_ID * string * (Loc.position * color) list (** the node_ID's task together with information that allows to color the source code corresponding to different part of the task (premise, goal, etc) *) | File_contents of string * string (** File_contents (filename, contents) *) | Source_and_ce of string * (Loc.position * color) list (** Source interleaved with counterexamples: contents and list color loc *) type ide_request = | Command_req of node_ID * string (* executes the given command on the given node. command is interpreted by Server_utils.interp. This includes calling provers, applying transformations, stategies. *) | Add_file_req of string | Set_config_param of string * int | Set_prover_policy of Whyconf.prover * Whyconf.prover_upgrade_policy | Get_file_contents of string | Get_task of node_ID * bool * bool (** [Get_task(id,b,loc)] requests for the text of the task in node [id]. When [b] is true then the full context is show. When [loc] is false the locations are not returned *) | Remove_subtree of node_ID | Copy_paste of node_ID * node_ID | Save_file_req of string * string (** [Save_file_req(filename, content_of_file)] saves the file *) | Get_first_unproven_node of node_ID | Unfocus_req | Save_req | Reload_req | Check_need_saving_req | Exit_req | Interrupt_req | Get_global_infos val print_request: Format.formatter -> ide_request -> unit val print_msg: Format.formatter -> message_notification -> unit val print_notify: Format.formatter -> notification -> unit why3-1.2.1/src/session/itp_server.ml0000644000175100017510000016671213555524575020164 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 Wstdlib open Session_itp open Controller_itp open Server_utils open Itp_communication (**********************************) (* list unproven goal and related *) (**********************************) (* If the transformation is proved, return acc. Else, return the concatenation of the reversed list of unproven goals below the transformation and acc *) let rec unproven_goals_below_tn cont acc tn = let s = cont.controller_session in if tn_proved s tn then acc (* we ignore "dead" goals *) else let sub_tasks = get_sub_tasks s tn in List.fold_left (unproven_goals_below_pn cont) acc sub_tasks (* Same as unproven_goals_below_tn; note that if goal is not proved and there is no transformation, goal is returned (else it is not) *) and unproven_goals_below_pn cont acc goal = let s = cont.controller_session in if pn_proved s goal then acc (* we ignore "dead" transformations *) else match get_transformations s goal with | [] -> goal :: acc | tns -> List.fold_left (unproven_goals_below_tn cont) acc tns (* Same as unproven_goals_below_tn *) let unproven_goals_below_th cont acc th = let s = cont.controller_session in if th_proved s th then acc else let goals = theory_goals th in List.fold_left (unproven_goals_below_pn cont) acc goals (* Same as unproven_goals_below_tn *) let unproven_goals_below_file cont file = let s = cont.controller_session in if file_proved s file then [] else let theories = file_theories file in List.fold_left (unproven_goals_below_th cont) [] theories let unproven_goals_below_id cont id = match id with | APn pnid -> [pnid] | APa panid -> let ses = cont.controller_session in [get_proof_attempt_parent ses panid] | ATn tn -> List.rev (unproven_goals_below_tn cont [] tn) | AFile file -> List.rev (unproven_goals_below_file cont file) | ATh th -> List.rev (unproven_goals_below_th cont [] th) (****** Exception handling *********) let p s id = let _,tables = Session_itp.get_task_name_table s id in (* We use snapshots of printers to avoid registering new values inside it only for exception messages. *) let pr = Ident.duplicate_ident_printer tables.Trans.printer in let apr = Ident.duplicate_ident_printer tables.Trans.aprinter in (Pretty.create pr apr pr pr false) let print_opt_type ~print_type fmt t = match t with | None -> Format.fprintf fmt "bool" | Some t -> print_type fmt t (* Exception reporting *) (* TODO remove references to id.id_string in this function *) let bypass_pretty s id = let module P = (val (p s id)) in begin fun fmt exn -> match exn with | Ty.TypeMismatch (t1,t2) -> fprintf fmt "Type mismatch between %a and %a" P.print_ty t1 P.print_ty t2 | Ty.BadTypeArity ({Ty.ts_args = []} as ts, _) -> fprintf fmt "Type symbol %a expects no arguments" P.print_ts ts | Ty.BadTypeArity (ts, app_arg) -> let i = List.length ts.Ty.ts_args in fprintf fmt "Type symbol %a expects %i argument%s but is applied to %i" P.print_ts ts i (if i = 1 then "" else "s") app_arg | Ty.DuplicateTypeVar tv -> fprintf fmt "Type variable %a is used twice" P.print_tv tv | Ty.UnboundTypeVar tv -> fprintf fmt "Unbound type variable: %a" P.print_tv tv | Ty.UnexpectedProp -> fprintf fmt "Unexpected propositional type" | Term.BadArity ({Term.ls_args = []} as ls, _) -> fprintf fmt "%s %a expects no arguments" (if ls.Term.ls_value = None then "Predicate" else "Function") P.print_ls ls | Term.BadArity (ls, app_arg) -> let i = List.length ls.Term.ls_args in fprintf fmt "%s %a expects %i argument%s but is applied to %i" (if ls.Term.ls_value = None then "Predicate" else "Function") P.print_ls ls i (if i = 1 then "" else "s") app_arg | Term.EmptyCase -> fprintf fmt "Empty match expression" | Term.DuplicateVar vs -> fprintf fmt "Variable %a is used twice" P.print_vsty vs | Term.UncoveredVar vs -> fprintf fmt "Variable %a uncovered in \"or\"-pattern" P.print_vsty vs | Term.FunctionSymbolExpected ls -> fprintf fmt "Not a function symbol: %a" P.print_ls ls | Term.PredicateSymbolExpected ls -> fprintf fmt "Not a predicate symbol: %a" P.print_ls ls | Term.ConstructorExpected ls -> fprintf fmt "%s %a is not a constructor" (if ls.Term.ls_value = None then "Predicate" else "Function") P.print_ls ls | Term.TermExpected t -> fprintf fmt "Not a term: %a" P.print_term t | Term.FmlaExpected t -> fprintf fmt "Not a formula: %a" P.print_term t | Pattern.ConstructorExpected (ls,ty) -> fprintf fmt "%s %a is not a constructor of type %a" (if ls.Term.ls_value = None then "Predicate" else "Function") P.print_ls ls P.print_ty ty | Pattern.NonExhaustive pl -> fprintf fmt "Pattern not covered by a match:@\n @[%a@]" P.print_pat (List.hd pl) | Decl.BadConstructor ls -> fprintf fmt "Bad constructor: %a" P.print_ls ls | Decl.BadRecordField ls -> fprintf fmt "Not a record field: %a" P.print_ls ls | Decl.RecordFieldMissing ls -> fprintf fmt "Field %a is missing" P.print_ls ls | Decl.DuplicateRecordField ls -> fprintf fmt "Field %a is used twice in the same constructor" P.print_ls ls | Decl.IllegalTypeAlias ts -> fprintf fmt "Type symbol %a is a type alias and cannot be declared as algebraic" P.print_ts ts | Decl.NonFoundedTypeDecl ts -> fprintf fmt "Cannot construct a value of type %a" P.print_ts ts | Decl.NonPositiveTypeDecl (_ts, ls, ty) -> fprintf fmt "Constructor %a \ contains a non strictly positive occurrence of type %a" P.print_ls ls P.print_ty ty | Decl.InvalidIndDecl (_ls, pr) -> fprintf fmt "Ill-formed inductive clause %a" P.print_pr pr | Decl.NonPositiveIndDecl (_ls, pr, ls1) -> fprintf fmt "Inductive clause %a contains \ a non strictly positive occurrence of symbol %a" P.print_pr pr P.print_ls ls1 | Decl.BadLogicDecl (ls1,ls2) -> fprintf fmt "Ill-formed definition: symbols %a and %a are different" P.print_ls ls1 P.print_ls ls2 | Decl.UnboundVar vs -> fprintf fmt "Unbound variable:\n%a" P.print_vsty vs | Decl.ClashIdent id -> fprintf fmt "Ident %s is defined twice" id.Ident.id_string | Decl.EmptyDecl -> fprintf fmt "Empty declaration" | Decl.EmptyAlgDecl ts -> fprintf fmt "Algebraic type %a has no constructors" P.print_ts ts | Decl.EmptyIndDecl ls -> fprintf fmt "Inductive predicate %a has no constructors" P.print_ls ls | Decl.KnownIdent id -> fprintf fmt "Ident %s is already declared" id.Ident.id_string | Decl.UnknownIdent id -> fprintf fmt "Ident %s is not yet declared" id.Ident.id_string | Decl.RedeclaredIdent id -> fprintf fmt "Ident %s is already declared, with a different declaration" id.Ident.id_string | Decl.NoTerminationProof ls -> fprintf fmt "Cannot prove the termination of %a" P.print_ls ls | _ -> Format.fprintf fmt "Uncaught: %a" Exn_printer.exn_printer exn end let get_exception_message ses id e = let module P = (val (p ses id)) in match e with | Session_itp.NoProgress -> Pp.sprintf "Transformation made no progress\n", Loc.dummy_position, "" | Generic_arg_trans_utils.Arg_trans s -> Pp.sprintf "Error in transformation function: %s \n" s, Loc.dummy_position, "" | Generic_arg_trans_utils.Arg_trans_decl (s, ld) -> Pp.sprintf "Error in transformation %s during inclusion of following declarations:\n%a" s (Pp.print_list (fun fmt () -> Format.fprintf fmt "\n") P.print_tdecl) ld, Loc.dummy_position, "" | Generic_arg_trans_utils.Arg_trans_term (s, t) -> Pp.sprintf "Error in transformation %s during with term:\n %a : %a " s P.print_term t (print_opt_type ~print_type:P.print_ty) t.Term.t_ty, Loc.dummy_position, "" | Generic_arg_trans_utils.Arg_trans_term2 (s, t1, t2) -> Pp.sprintf "Error in transformation %s during unification of following two terms:\n %a : %a \n %a : %a" s P.print_term t1 (print_opt_type ~print_type:P.print_ty) t1.Term.t_ty P.print_term t2 (print_opt_type ~print_type:P.print_ty) t2.Term.t_ty, Loc.dummy_position, "" | Generic_arg_trans_utils.Arg_trans_term3 (s, t1, t2, t3) -> Pp.sprintf "Error in transformation %s during unification of following two terms:\n %a : %a \n %a : %a\n\n%a is already matched with %a" s P.print_term t1 (print_opt_type ~print_type:P.print_ty) t1.Term.t_ty P.print_term t2 (print_opt_type ~print_type:P.print_ty) t2.Term.t_ty P.print_term t1 P.print_term t3, Loc.dummy_position, "" | Generic_arg_trans_utils.Arg_trans_pattern (s, pa1, pa2) -> Pp.sprintf "Error in transformation %s during unification of the following terms:\n %a \n %a" s P.print_pat pa1 P.print_pat pa2, Loc.dummy_position, "" | Generic_arg_trans_utils.Arg_trans_type (s, ty1, ty2) -> Pp.sprintf "Error in transformation %s during unification of the following types:\n %a \n %a" s P.print_ty ty1 P.print_ty ty2, Loc.dummy_position, "" | Generic_arg_trans_utils.Arg_trans_missing (s, svs) -> Pp.sprintf "Error in transformation function: %s %a\n" s (Pp.print_list Pp.space P.print_vs) (Term.Svs.elements svs), Loc.dummy_position, "" | Generic_arg_trans_utils.Arg_bad_hypothesis ("rewrite", _t) -> Pp.sprintf "Not a rewrite hypothesis", Loc.dummy_position, "" | Generic_arg_trans_utils.Cannot_infer_type s -> Pp.sprintf "Error in transformation %s. Cannot infer type of polymorphic element" s, Loc.dummy_position, "" | Args_wrapper.Arg_qid_not_found q -> Pp.sprintf "Following hypothesis was not found: %a \n" Typing.print_qualid q, Loc.dummy_position, "" | Args_wrapper.Arg_pr_not_found pr -> Pp.sprintf "Property not found: %a" P.print_pr pr, Loc.dummy_position, "" | Args_wrapper.Arg_error s -> Pp.sprintf "Transformation raised a general error: %s \n" s, Loc.dummy_position, "" | Args_wrapper.Arg_theory_not_found s -> Pp.sprintf "Theory not found: %s" s, Loc.dummy_position, "" | Args_wrapper.Arg_parse_type_error (loc, arg, e) -> Pp.sprintf "Parsing error: %a" Exn_printer.exn_printer e, loc, arg | Args_wrapper.Unnecessary_arguments l -> Pp.sprintf "First arguments were parsed and typed correctly but the last following are useless:\n%a" (Pp.print_list Pp.newline (fun fmt s -> Format.fprintf fmt "%s" s)) l, Loc.dummy_position, "" | Generic_arg_trans_utils.Unnecessary_terms l -> Pp.sprintf "First arguments were parsed and typed correctly but the last following are useless:\n%a" (Pp.print_list Pp.newline (fun fmt s -> Format.fprintf fmt "%a" P.print_term s)) l, Loc.dummy_position, "" | Args_wrapper.Arg_expected_none s -> Pp.sprintf "An argument was expected of type %s, none were given" s, Loc.dummy_position, "" | e -> (Pp.sprintf "%a" (bypass_pretty ses id) e), Loc.dummy_position, "" module type Protocol = sig val get_requests : unit -> ide_request list val notify : notification -> unit end module Make (S:Controller_itp.Scheduler) (Pr:Protocol) = struct module C = Controller_itp.Make(S) let debug = Debug.register_flag "itp_server" ~desc:"ITP server" let debug_attrs = Debug.register_info_flag "print_model_attrs" ~desc:"Print@ attrs@ of@ identifiers@ and@ expressions@ in prover@ results." (****************) (* Command list *) (****************) let interrupt_query _cont _args = C.interrupt (); "interrupted" let commands_table = Hstr.create 17 let register_command c d f = Hstr.add commands_table c (d,f) let () = List.iter (fun (c,d,f) -> register_command c d f) [ "interrupt", "interrupt all scheduled or running proof tasks", Qnotask interrupt_query; "list-transforms", "list available transformations", Qnotask list_transforms_query; "list-provers", "list available provers", Qnotask list_provers; (* "list-strategies", "list available strategies", list_strategies; *) "print", " print the declaration where was defined", Qtask print_id; "search", " print the declarations where all appears", Qtask (search_id ~search_both:false); "search_all", " print the declarations where one of appears", Qtask (search_id ~search_both:true); (* "r", "reload the session (test only)", test_reload; "s", "save the current session", test_save_session; "ng", "go to the next goal", then_print (move_to_goal_ret_p next_node); "pg", "go to the prev goal", then_print (move_to_goal_ret_p prev_node); "gu", "go to the goal up", then_print (move_to_goal_ret_p zipper_up); "gd", "go to the goal down", then_print (move_to_goal_ret_p zipper_down); "gr", "go to the goal right", then_print (move_to_goal_ret_p zipper_right); "gl", "go to the goal left", then_print (move_to_goal_ret_p zipper_left) *) ] type server_data = { (* task_driver : Driver.driver; *) cont : Controller_itp.controller; send_source: bool; (* If true the server is parametered to send source mlw files as notifications *) global_infos : Itp_communication.global_information; } let server_data = ref None let get_server_data () = match !server_data with | None -> Format.eprintf "get_server_data(): fatal error, server not yet initialized@."; exit 1 | Some x -> x (* fresh gives new fresh "names" for node_ID using a counter. reset resets the counter so that we can regenerate node_IDs as if session was fresh *) let reset, fresh = let count = ref 0 in (fun () -> count := 0), fun () -> count := !count + 1; !count let model_any : any Hint.t = Hint.create 17 let any_from_node_ID (nid:node_ID) : any option = try Some (Hint.find model_any nid) with | Not_found -> None let pan_to_node_ID : node_ID Hpan.t = Hpan.create 17 let pn_to_node_ID : node_ID Hpn.t = Hpn.create 17 let tn_to_node_ID : node_ID Htn.t = Htn.create 17 let th_to_node_ID : node_ID Ident.Hid.t = Ident.Hid.create 7 let file_to_node_ID : node_ID Hfile.t = Hfile.create 3 let node_ID_from_pan pan = Hpan.find pan_to_node_ID pan let node_ID_from_pn pn = Hpn.find pn_to_node_ID pn let node_ID_from_tn tn = Htn.find tn_to_node_ID tn let node_ID_from_th th = Ident.Hid.find th_to_node_ID (theory_name th) let node_ID_from_file file = Hfile.find file_to_node_ID (file_id file) let node_ID_from_any any = match any with | AFile file -> node_ID_from_file file | ATh th -> node_ID_from_th th | ATn tn -> node_ID_from_tn tn | APn pn -> node_ID_from_pn pn | APa pan -> node_ID_from_pan pan let remove_any_node_ID any = match any with | AFile file -> let nid = Hfile.find file_to_node_ID (file_id file) in Hint.remove model_any nid; Hfile.remove file_to_node_ID (file_id file) | ATh th -> let nid = Ident.Hid.find th_to_node_ID (theory_name th) in Hint.remove model_any nid; Ident.Hid.remove th_to_node_ID (theory_name th) | ATn tn -> let nid = Htn.find tn_to_node_ID tn in Hint.remove model_any nid; Htn.remove tn_to_node_ID tn | APn pn -> let nid = Hpn.find pn_to_node_ID pn in Hint.remove model_any nid; Hpn.remove pn_to_node_ID pn | APa pa -> let nid = Hpan.find pan_to_node_ID pa in Hint.remove model_any nid; Hpan.remove pan_to_node_ID pa let add_node_to_table node new_id = match node with | AFile file -> Hfile.add file_to_node_ID (file_id file) new_id | ATh th -> Ident.Hid.add th_to_node_ID (theory_name th) new_id | ATn tn -> Htn.add tn_to_node_ID tn new_id | APn pn -> Hpn.add pn_to_node_ID pn new_id | APa pan -> Hpan.add pan_to_node_ID pan new_id (*******************************) (* Compute color for locations *) (*******************************) (* This section is used to get colored source as a function of the task *) exception No_loc_on_goal let get_locations (task: Task.task) = let list = ref [] in let file_cache = Hstr.create 17 in let session_dir = let d = get_server_data () in Session_itp.get_dir d.cont.controller_session in let relativize f = try Hstr.find file_cache f with Not_found -> let path = Sysutil.relativize_filename session_dir f in (* FIXME: this an abusive use of Sysutil.system_dependent_absolute_path *) let g = Sysutil.system_dependent_absolute_path session_dir path in Hstr.replace file_cache f g; g in let color_loc ~color ~loc = let (f,l,b,e) = Loc.get loc in let loc = Loc.user_position (relativize f) l b e in list := (loc, color) :: !list in let rec color_locs ~color formula = Opt.iter (fun loc -> color_loc ~color ~loc) formula.Term.t_loc; Term.t_iter (fun subf -> color_locs ~color subf) formula in let rec color_t_locs ~premise f = match f.Term.t_node with | Term.Tbinop (Term.Timplies,f1,f2) when not premise -> color_t_locs ~premise:true f1; color_t_locs ~premise:false f2 | Term.Tbinop (Term.Tand,f1,f2) when premise -> color_t_locs ~premise f1; color_t_locs ~premise f2 | Term.Tlet (_,fb) -> let _,f1 = Term.t_open_bound fb in color_t_locs ~premise f1 | Term.Tquant (Term.Tforall,fq) when not premise -> let _,_,f1 = Term.t_open_quant fq in color_t_locs ~premise f1 | Term.Tnot f1 when premise && f.Term.t_loc = None -> color_locs ~color:Neg_premise_color f1 | _ when premise -> color_locs ~color:Premise_color f | _ -> color_locs ~color:Goal_color f in let color_goal = function | None -> (* This case can happen when after some transformations: for example, in an assert, the new goal asserted is not tagged with locations *) (* This error is harmless but we want to detect it when debugging. *) if Debug.test_flag Debug.stack_trace then raise No_loc_on_goal | Some loc -> color_loc ~color:Goal_color ~loc in let goal_id : Ident.ident = (Task.task_goal task).Decl.pr_name in color_goal goal_id.Ident.id_loc; let rec scan = function | Some { Task.task_prev = prev; Task.task_decl = { Theory.td_node = Theory.Decl { Decl.d_node = Decl.Dprop (k, _, f) }}} -> begin match k with | Decl.Pgoal -> color_t_locs ~premise:false f | Decl.Paxiom -> color_t_locs ~premise:true f | _ -> assert false end; scan prev | Some { Task.task_prev = prev } -> scan prev | _ -> () in scan task; !list let get_modified_node n = match n with | Reset_whole_tree -> None | New_node (nid, _, _, _, _) -> Some nid | Node_change (nid, _) -> Some nid | Remove nid -> Some nid | Next_Unproven_Node_Id (_, nid) -> Some nid | Initialized _ -> None | Saved | Saving_needed _ -> None | Message _ -> None | Dead _ -> None | Task (nid, _, _) -> Some nid | File_contents _ -> None | Source_and_ce _ -> None type focus = | Unfocused (* We can focus on several nodes at once *) | Focus_on of Session_itp.any list | Wait_focus (* Focus on a node *) let focused_node = ref Unfocused let get_focused_label = ref None let focus_on_loading (f: Task.task -> bool) = focused_node := Wait_focus; get_focused_label := Some f (* TODO *) module P = struct let get_requests = Pr.get_requests (* true if nid is below f_node or does not exists (in which case the notification is a remove). false if not below. *) let is_below s nid f_nodes = let any = any_from_node_ID nid in match any with | None -> true | Some any -> List.exists (Session_itp.is_below s any) f_nodes let notify n = let d = get_server_data() in let s = d.cont.controller_session in match n with | Initialized _ | Saved | Message _ | Dead _ -> Pr.notify n | _ -> begin match !focused_node with | Wait_focus -> () (* Do not notify at all *) | Unfocused -> Pr.notify n | Focus_on f_nodes -> let updated_node = get_modified_node n in match updated_node with | None -> Pr.notify n | Some nid when is_below s nid f_nodes -> Pr.notify n | _ -> () end end (*********************) (* File input/output *) (*********************) let read_and_send f = try let d = get_server_data() in if d.send_source then (* let fn = Sysutil.absolutize_path (Session_itp.get_dir d.cont.controller_session) f in *) let s = Sysutil.file_contents f in P.notify (File_contents (f, s)) with Invalid_argument s -> P.notify (Message (Error s)) let save_file f file_content = try (* let d = get_server_data() in let fn = Sysutil.absolutize_filename (Session_itp.get_dir d.cont.controller_session) f in *) Sysutil.backup_file f; Sysutil.write_file f file_content; P.notify (Message (File_Saved f)) with Invalid_argument s -> P.notify (Message (Error s)) let relativize_location s loc = let f, l, b, e = Loc.get loc in let path = Sysutil.relativize_filename (Session_itp.get_dir s) f in (* FIXME: this an abusive use of Sysutil.system_dependent_absolute_path *) let f = Sysutil.system_dependent_absolute_path "" path in Loc.user_position f l b e let capture_parse_or_type_errors f cont = List.map (function | Loc.Located (loc, e) -> let rel_loc = relativize_location cont.controller_session loc in let s = Format.asprintf "%a: %a" Loc.gen_report_position rel_loc Exn_printer.exn_printer e in (loc, rel_loc, s) | e when not (Debug.test_flag Debug.stack_trace) -> let s = Format.asprintf "%a" Exn_printer.exn_printer e in (Loc.dummy_position, Loc.dummy_position, s) | e -> raise e) (f cont) (* Reload_files that is used even if the controller is not correct. It can be incorrect and end up in a correct state. *) let reload_files cont ~shape_version = capture_parse_or_type_errors (fun c -> try let (_,_) = reload_files ~shape_version c in [] with | Errors_list le -> le) cont let add_file cont ?format fname = capture_parse_or_type_errors (fun c -> try add_file c ?format fname; [] with | Errors_list le -> le) cont (* ----------------------------------- ------------------------------------- *) let get_node_type (node: any) = match node with | AFile _ -> NFile | ATh _ -> NTheory | ATn _ -> NTransformation | APn _ -> NGoal | APa _ -> NProofAttempt let get_node_name (node: any) = let d = get_server_data () in match node with | AFile file -> Session_itp.basename (file_path file) | ATh th -> (theory_name th).Ident.id_string | ATn tn -> let name = get_transf_name d.cont.controller_session tn in let args = get_transf_args d.cont.controller_session tn in let full = String.concat " " (name :: args) in if String.length full >= 40 then String.sub full 0 40 ^ " ..." else full | APn pn -> let name = (get_proof_name d.cont.controller_session pn).Ident.id_string in (* Reduce the name of the goal to the minimum, by taking the part after the last dot: "0" instead of "WP_Parameter.0" for example. *) let name = List.hd (Strings.rev_split '.' name) in let expl = get_proof_expl d.cont.controller_session pn in if expl = "" then name else name ^ " [" ^ expl ^ "]" | APa pa -> let pa = get_proof_attempt_node d.cont.controller_session pa in Pp.string_of Whyconf.print_prover pa.prover let get_node_detached (node: any) = let d = get_server_data () in is_detached d.cont.controller_session node let get_node_proved new_id (node: any) = let d = get_server_data () in let cont = d.cont in let s = cont.controller_session in match node with | AFile file -> P.notify (Node_change (new_id, Proved (file_proved s file))) | ATh th -> P.notify (Node_change (new_id, Proved (th_proved s th))) | ATn tn -> P.notify (Node_change (new_id, Proved (tn_proved s tn))) | APn pn -> P.notify (Node_change (new_id, Proved (pn_proved s pn))) | APa pa -> let pa = get_proof_attempt_node s pa in let obs = pa.proof_obsolete in let limit = pa.limit in let res = match pa.Session_itp.proof_state with | Some pa -> Done pa | _ -> Undone in P.notify (Node_change (new_id, Proof_status_change(res, obs, limit))) (* let get_info_and_type ses (node: any) = match node with | AFile file -> let name = file.file_name in let proved = file_proved cont file in NFile, {name; proved} | ATh th -> let name = (theory_name th).Ident.id_string in let proved = th_proved cont th in NTheory, {name; proved} | ATn tn -> let name = get_transf_name ses tn in let proved = tn_proved cont tn in NTransformation, {name; proved} | APn pn -> let name = (get_proof_name ses pn).Ident.id_string in let proved = pn_proved cont pn in NGoal, {name; proved} | APa pan -> let pa = get_proof_attempt_node ses pan in let name = Pp.string_of Whyconf.print_prover pa.prover in let pr, proved = match pa.Session_itp.proof_state with | Some pr -> Some pr.pr_answer, pr.pr_answer = Valid | None -> None, false in (NProofAttempt (pr, pa.proof_obsolete)), {name; proved} *) let add_focused_node node = match !focused_node with | Focus_on l -> focused_node := Focus_on (node :: l) | _ -> focused_node := Focus_on [node] (* Focus on label: this is used to automatically focus on the first task having a given property (label_detection) in the session tree. To change the property, one need to call function register_label_detection. *) let focus_on_label node = let d = get_server_data () in let session = d.cont.Controller_itp.controller_session in if not (Session_itp.is_detached session node) then match !get_focused_label with | Some label_detection -> (match node with | APn pr_node -> let task = Session_itp.get_task session pr_node in let b = label_detection task in if b then add_focused_node node | _ -> ()) | None -> () (* Create a new node in the_tree, update the tables and send a notification about it *) let new_node ~parent node : node_ID = let new_id = fresh () in Hint.add model_any new_id node; let node_type = get_node_type node in let node_name = get_node_name node in let node_detached = get_node_detached node in add_node_to_table node new_id; (* Specific to auto-focus at initialization of itp_server *) focus_on_label node; begin (* Do not send theories that do not contain any goal *) match node with | ATh th when theory_goals th = [] -> () | _ -> P.notify (New_node (new_id, parent, node_type, node_name, node_detached)); get_node_proved new_id node end; new_id (* Same as new_node but do not return the node. *) let create_node ~parent node = let _: node_ID = new_node ~parent node in () (****************************) (* Iter on the session tree *) (****************************) (* Iter on the session tree with a function [f parent current] with type node_ID -> any -> unit *) let iter_subtree_proof_attempt_from_goal (f: parent:node_ID -> any -> unit) parent id = let d = get_server_data () in Whyconf.Hprover.iter (fun _pa panid -> f ~parent (APa panid)) (get_proof_attempt_ids d.cont.controller_session id) let rec iter_subtree_from_goal (f: parent:node_ID -> any -> unit) parent id = let d = get_server_data () in let ses = d.cont.controller_session in f ~parent (APn id); let nid = node_ID_from_pn id in List.iter (fun trans_id -> iter_subtree_from_trans f nid trans_id) (get_transformations ses id); iter_subtree_proof_attempt_from_goal f nid id and iter_subtree_from_trans (f: parent:node_ID -> any -> unit) parent trans_id = let d = get_server_data () in let ses = d.cont.controller_session in f ~parent (ATn trans_id); let nid = node_ID_from_tn trans_id in List.iter (fun goal_id -> (iter_subtree_from_goal f nid goal_id)) (get_sub_tasks ses trans_id) let iter_subtree_from_theory (f: parent:node_ID -> any -> unit) parent theory_id = f ~parent (ATh theory_id); let nid = node_ID_from_th theory_id in List.iter (iter_subtree_from_goal f nid) (theory_goals theory_id) let iter_subtree_from_file (f: parent:node_ID -> any -> unit) file = f ~parent:root_node (AFile file); let nid = node_ID_from_file file in List.iter (iter_subtree_from_theory f nid) (file_theories file) let iter_on_files ~(on_file: file -> unit) ~(on_subtree: parent:node_ID -> any -> unit) : unit = let d = get_server_data () in let ses = d.cont.controller_session in let files = get_files ses in Hfile.iter (fun _ file -> on_file file; iter_subtree_from_file on_subtree file) files (**********************************) (* Initialization of session tree *) (**********************************) let send_new_subtree_from_trans parent trans_id : unit = iter_subtree_from_trans create_node parent trans_id let send_new_subtree_from_file f = iter_subtree_from_file create_node f let reset_and_send_the_whole_tree (): unit = P.notify Reset_whole_tree; let d = get_server_data () in let ses = d.cont.controller_session in let on_file f = read_and_send (Session_itp.system_path ses f) in iter_on_files ~on_file ~on_subtree:create_node let unfocus () = focused_node := Unfocused; reset_and_send_the_whole_tree () (* -- send the task -- *) let task_of_id d id show_full_context loc = let task,tables = get_task_name_table d.cont.controller_session id in (* This function also send source locations associated to the task *) let loc_color_list = if loc then get_locations task else [] in let task_text = let pr = tables.Trans.printer in let apr = tables.Trans.aprinter in let module P = (val Pretty.create pr apr pr pr false) in Pp.string_of (if show_full_context then P.print_task else P.print_sequent) task in task_text, loc_color_list let create_ce_tab ~print_attrs s res any list_loc = let f = get_encapsulating_file s any in let filename = Session_itp.system_path s f in let source_code = Sysutil.file_contents filename in Model_parser.interleave_with_source ~print_attrs ?start_comment:None ?end_comment:None ?me_name_trans:None res.Call_provers.pr_model ~rel_filename:filename ~source_code:source_code ~locations:list_loc let send_task nid show_full_context loc = let d = get_server_data () in let any = any_from_node_ID nid in match any with | None -> P.notify (Message (Error "Please select a node id")) | Some any -> if Session_itp.is_detached d.cont.controller_session any then match any with | APn _id -> let s = "Goal is detached and cannot be printed" in P.notify (Task (nid, s, [])) | ATh t -> P.notify (Task (nid, "Detached theory " ^ (theory_name t).Ident.id_string, [])) | APa pid -> let pa = get_proof_attempt_node d.cont.controller_session pid in let name = Pp.string_of Whyconf.print_prover pa.prover in let prover_text = "Detached prover\n====================> Prover: " ^ name ^ "\n" in P.notify (Task (nid, prover_text, [])) | AFile f -> P.notify (Task (nid, "Detached file " ^ (basename (file_path f)), [])) | ATn tid -> let name = get_transf_name d.cont.controller_session tid in let args = get_transf_args d.cont.controller_session tid in P.notify (Task (nid, "Detached transformation\n====================> Transformation: " ^ String.concat " " (name :: args) ^ "\n", [])) else match any with | APn id -> let s, list_loc = task_of_id d id show_full_context loc in P.notify (Task (nid, s, list_loc)) | ATh t -> P.notify (Task (nid, "Theory " ^ (theory_name t).Ident.id_string, [])) | APa pid -> let print_attrs = Debug.test_flag debug_attrs in let pa = get_proof_attempt_node d.cont.controller_session pid in let parid = pa.parent in let name = Pp.string_of Whyconf.print_prover pa.prover in let s, old_list_loc = task_of_id d parid show_full_context loc in let prover_text = s ^ "\n====================> Prover: " ^ name ^ "\n" in (* Display the result of the prover *) begin match pa.proof_state with | Some res -> let result = Pp.string_of Call_provers.print_prover_answer res.Call_provers.pr_answer in let ce_result = Pp.string_of (Model_parser.print_model_human ~print_attrs ?me_name_trans:None) res.Call_provers.pr_model in if ce_result = "" then let result_pr = result ^ "\n\n" ^ "The prover did not return counterexamples." in P.notify (Task (nid, prover_text ^ result_pr, old_list_loc)) else begin let result_pr = result ^ "\n\n" ^ "Counterexample suggested by the prover:\n\n" ^ ce_result in let (source_result, list_loc) = create_ce_tab d.cont.controller_session ~print_attrs res any old_list_loc in P.notify (Source_and_ce (source_result, list_loc)); P.notify (Task (nid, prover_text ^ result_pr, old_list_loc)) end | None -> P.notify (Task (nid, "Result of the prover not available.\n", old_list_loc)) end | AFile f -> P.notify (Task (nid, "File " ^ (basename (file_path f)), [])) | ATn tid -> let name = get_transf_name d.cont.controller_session tid in let args = get_transf_args d.cont.controller_session tid in let parid = get_trans_parent d.cont.controller_session tid in let s, list_loc = task_of_id d parid show_full_context loc in P.notify (Task (nid, s ^ "\n====================> Transformation: " ^ String.concat " " (name :: args) ^ "\n", list_loc)) (* -------------------- *) (* True when session differs from the saved session *) let session_needs_saving = ref false (* Add a file into the session when (Add_file_req f) is sent *) (* Note that f is the path from execution directory to the file and fn is the path from the session directory to the file. *) let add_file_to_session cont f = let dir = get_dir cont.controller_session in let fn = Sysutil.relativize_filename dir f in try let (_ : file) = find_file_from_path cont.controller_session fn in P.notify (Message (Information ("File already in session: " ^ f))) with Not_found -> if (Sys.file_exists f) then let l = add_file cont f in let file = find_file_from_path cont.controller_session fn in send_new_subtree_from_file file; read_and_send (Session_itp.system_path cont.controller_session file); begin match l with | [] -> session_needs_saving := true; P.notify (Message (Information "file added in session")) | l -> List.iter (function | (loc,rel_loc,s) -> P.notify (Message (Parse_Or_Type_Error(loc,rel_loc,s)))) l end else P.notify (Message (Open_File_Error ("File not found: " ^ f))) (* ------------ init server ------------ *) let init_server ?(send_source=true) config env f = Debug.dprintf debug "loading session %s@." f; let ses,shape_version = Session_itp.load_session f in Debug.dprintf debug "creating controller@."; let c = create_controller config env ses in let shortcuts = Mstr.fold (fun s p acc -> Whyconf.Mprover.add p s acc) (Whyconf.get_prover_shortcuts config) Whyconf.Mprover.empty in let prover_list = Whyconf.Mprover.fold (fun pr _ acc -> let s = try Whyconf.Mprover.find pr shortcuts with Not_found -> "" in let n = Pp.sprintf "%a" Whyconf.print_prover pr in let p = Pp.sprintf "%a" Whyconf.print_prover_parseable_format pr in (s,n,p) :: acc) (Whyconf.get_provers config) [] in load_strategies c; let transformation_list = List.map (fun (a, b) -> (a, Format.sprintf "@[%(%)@]" b)) (list_transforms ()) in let strategies_list = list_strategies c in let infos = { provers = prover_list; transformations = transformation_list; strategies = strategies_list; commands = Hstr.fold (fun c _ acc -> c :: acc) commands_table [] } in server_data := Some { cont = c; send_source = send_source; global_infos = infos; }; Debug.dprintf debug "reloading source files@."; let d = get_server_data () in let x = reload_files d.cont ~shape_version in reset_and_send_the_whole_tree (); (* After initial sending, we don't check anymore that there is a need to focus on a specific node. *) get_focused_label := None; match x with | [] -> P.notify (Message (Information "Session initialized successfully")) | l -> List.iter (function (loc,rel_loc,s) -> P.notify (Message (Parse_Or_Type_Error(loc,rel_loc,s)))) l (* ----------------- Schedule proof attempt -------------------- *) exception Return (* Callback of a proof_attempt *) let callback_update_tree_proof cont panid pa_status = let ses = cont.controller_session in let node_id = try node_ID_from_pan panid with Not_found -> let parent_id = get_proof_attempt_parent ses panid in let parent = node_ID_from_pn parent_id in new_node ~parent (APa panid) in try begin match pa_status with | UpgradeProver _ -> let n = get_node_name (APa panid) in P.notify (Node_change (node_id, Name_change n)) | Removed _ -> P.notify (Remove node_id); raise Return | Uninstalled _ -> () | Undone | Scheduled | Running | Interrupted | Detached | Done _ | InternalFailure _ -> () end; let pa = get_proof_attempt_node ses panid in let new_status = Proof_status_change (pa_status, pa.proof_obsolete, pa.limit) in P.notify (Node_change (node_id, new_status)) with Return -> () let notify_change_proved c x = try let node_ID = node_ID_from_any x in let b = any_proved c.controller_session x in P.notify (Node_change (node_ID, Proved b)); match x with | APa pa -> let pa = get_proof_attempt_node c.controller_session pa in let res = match pa.Session_itp.proof_state with | None -> Undone | Some r -> Done r in let obs = pa.proof_obsolete in Debug.dprintf debug "[Itp_server.notify_change_proved: obsolete = %b@." obs; let limit = pa.limit in P.notify (Node_change (node_ID, Proof_status_change(res, obs, limit))) | _ -> () with Not_found when not (Debug.test_flag Debug.stack_trace)-> Format.eprintf "Fatal anomaly in Itp_server.notify_change_proved@."; exit 1 let schedule_proof_attempt nid (p: Whyconf.config_prover) limit = let d = get_server_data () in let prover = p.Whyconf.prover in let callback = callback_update_tree_proof d.cont in let any = any_from_node_ID nid in match any with | None -> P.notify (Message (Error "Please select a node id")) | Some any -> let unproven_goals = unproven_goals_below_id d.cont any in List.iter (fun id -> C.schedule_proof_attempt ?save_to:None d.cont id prover ~limit ~callback ~notification:(notify_change_proved d.cont)) unproven_goals let schedule_edition (nid: node_ID) (prover: Whyconf.prover) = let d = get_server_data () in let callback = callback_update_tree_proof d.cont in let any = any_from_node_ID nid in match any with | None -> P.notify (Message (Error "Please select a node id")); | Some any -> try let id = match any with | APn id -> id | APa panid -> get_proof_attempt_parent d.cont.controller_session panid | _ -> raise Not_found in C.schedule_edition d.cont id prover ~callback ~notification:(notify_change_proved d.cont) with Not_found -> P.notify (Message (Error "for edition you must select a proof attempt node")) (* ----------------- Schedule transformation -------------------- *) (* Callback of a transformation. This contains arguments of the transformation only for pretty printing of errors*) let callback_update_tree_transform tr args status = let d = get_server_data () in match status with | TSdone trans_id -> let ses = d.cont.controller_session in let id = get_trans_parent ses trans_id in let nid = node_ID_from_pn id in send_new_subtree_from_trans nid trans_id | TSfailed (_, NoProgress) -> P.notify (Message (Information "The transformation made no progress")) | TSfailed (id, e) -> let doc = try Pp.sprintf "%s\n%a" tr Pp.formatted (Trans.lookup_trans_desc tr) with | _ -> "" in let msg, loc, arg_opt = get_exception_message d.cont.controller_session id e in let tr_applied = tr ^ " " ^ (List.fold_left (fun x acc -> x ^ " " ^ acc) "" args) in P.notify (Message (Transf_error (false, node_ID_from_pn id, tr_applied, arg_opt, loc, msg, doc))) | TSscheduled -> () | TSfatal (id, e) -> let doc = try Pp.sprintf "%s\n%a" tr Pp.formatted (Trans.lookup_trans_desc tr) with | _ -> "" in let msg, loc, arg_opt = get_exception_message d.cont.controller_session id e in let tr_applied = tr ^ " " ^ (List.fold_left (fun x acc -> x ^ " " ^ acc) "" args) in P.notify (Message (Transf_error (true, node_ID_from_pn id, tr_applied, arg_opt, loc, msg, doc))) let apply_transform node_id t args = let d = get_server_data () in let rec apply_transform nid t args = match nid with | APn id -> if Session_itp.is_detached d.cont.controller_session nid then P.notify (Message (Information "Transformation cannot apply on detached node")) else if Session_itp.check_if_already_exists d.cont.controller_session id t args then P.notify (Message (Information "Transformation already applied")) else let callback = callback_update_tree_transform t args in C.schedule_transformation d.cont id t args ~callback ~notification:(notify_change_proved d.cont) | APa panid -> let parent_id = get_proof_attempt_parent d.cont.controller_session panid in apply_transform (APn parent_id) t args | ATn tnid -> let child_ids = get_sub_tasks d.cont.controller_session tnid in List.iter (fun id -> apply_transform (APn id) t args) child_ids | AFile f -> let child_ids = file_theories f in List.iter (fun id -> apply_transform (ATh id) t args) child_ids | ATh th -> let child_ids = theory_goals th in List.iter (fun id -> apply_transform (APn id) t args) child_ids in let nid = any_from_node_ID node_id in match nid with | None -> P.notify (Message (Error "Please select a node id")); | Some nid -> apply_transform nid t args let removed x = let nid = node_ID_from_any x in remove_any_node_ID x; P.notify (Remove nid) let schedule_bisection (nid: node_ID) = let d = get_server_data () in try let id = match any_from_node_ID nid with | Some (APa panid) -> panid | _ -> raise Not_found in let callback_pa = callback_update_tree_proof d.cont in let callback_tr tr args st = callback_update_tree_transform tr args st in C.bisect_proof_attempt d.cont id ~callback_tr ~callback_pa ~notification:(notify_change_proved d.cont) ~removed with Not_found -> P.notify (Message (Information "for bisection please select some proof attempt")) | C.CannotRunBisectionOn _ -> P.notify (Message (Error "for bisection please select a successful proof attempt")) (* ----------------- run strategy -------------------- *) let debug_strat = Debug.register_flag "strategy_exec" ~desc:"Trace strategies execution" let run_strategy_on_task nid s = let d = get_server_data () in let any = any_from_node_ID nid in match any with | None -> P.notify (Message (Error "Please select a node id")); | Some any -> let unproven_goals = unproven_goals_below_id d.cont any in try let (n,_,_,st) = Hstr.find d.cont.controller_strategies s in Debug.dprintf debug_strat "[strategy_exec] running strategy '%s'@." n; let callback sts = Debug.dprintf debug_strat "[strategy_exec] strategy status: %a@." print_strategy_status sts in let callback_pa = callback_update_tree_proof d.cont in let callback_tr tr args st = callback_update_tree_transform tr args st in List.iter (fun id -> C.run_strategy_on_goal d.cont id st ~callback_pa ~callback_tr ~callback ~notification:(notify_change_proved d.cont)) unproven_goals with Not_found -> Debug.dprintf debug_strat "[strategy_exec] strategy '%s' not found@." s (* ----------------- Clean session -------------------- *) let clean nid = let d = get_server_data () in C.clean d.cont ~removed nid let remove_node nid = let d = get_server_data () in let any = any_from_node_ID nid in match any with | None -> P.notify (Message (Error "Please select a node id")) | Some any -> begin try remove_subtree ~notification:(notify_change_proved d.cont) ~removed d.cont any with RemoveError -> (* TODO send an error instead of information *) P.notify (Message (Information "Cannot remove attached proof nodes or theories, and proof_attempt that did not yet return")) end (* ----------------- Save session --------------------- *) let save_session () = let d = get_server_data () in Session_itp.save_session d.cont.controller_session; P.notify Saved (* ----------------- Reload session ------------------- *) let clear_tables () : unit = reset (); Hint.clear model_any; Hpan.clear pan_to_node_ID; Hpn.clear pn_to_node_ID; Htn.clear tn_to_node_ID; Ident.Hid.clear th_to_node_ID; Hfile.clear file_to_node_ID let reload_session () : unit = let d = get_server_data () in (* interrupt all running provers and unfocus before reload *) C.interrupt (); let _old_focus = !focused_node in unfocus (); clear_tables (); let l = reload_files d.cont ~shape_version:(Some Termcode.current_shape_version) in reset_and_send_the_whole_tree (); match l with | [] -> (* TODO: try to restore the previous focus : focused_node := old_focus; *) P.notify (Message (Information "Session refresh successful")) | l -> List.iter (function (loc,rel_loc,s) -> P.notify (Message (Parse_Or_Type_Error(loc,rel_loc,s)))) l let replay ~valid_only nid : unit = let d = get_server_data () in let callback = callback_update_tree_proof d.cont in let final_callback _ lr = P.notify (Message (Replay_Info (Pp.string_of C.replay_print lr))) in (* TODO make replay print *) C.replay ~valid_only ~use_steps:false ~obsolete_only:true d.cont ~callback ~notification:(notify_change_proved d.cont) ~final_callback ~any:nid (* let () = register_command "edit" "remove unsuccessful proof attempts that are below proved goals" (Qtask (fun cont _table _args -> schedule_edition (); "Editor called")) *) (* TODO: should this remove the current selected node ? let () = register_command "remove_node" "removes a proof attempt or a transformation" (Qnotask (fun _cont args -> match args with | [x] clean_session (); "Remove node done")) *) (* ---------------- Mark obsolete ------------------ *) let mark_obsolete n = let d = get_server_data () in C.mark_as_obsolete ~notification:(notify_change_proved d.cont) d.cont n (* ----------------- Get counterexampes ------------ *) let get_ce nid = let d = get_server_data () in let session = d.cont.controller_session in let config = d.cont.controller_config in let any = any_from_node_ID nid in match any with | None -> P.notify (Message (Error "Please select a node id")) | Some (APa panid) -> let pan = Session_itp.get_proof_attempt_node session panid in let filter_prover = Whyconf.mk_filter_prover ~version:pan.prover.Whyconf.prover_version ~altern:"counterexamples" pan.prover.Whyconf.prover_name in begin match Whyconf.filter_one_prover config filter_prover with | config_prover -> (* nid should still exists when scheduling attempt *) let parent_pn = Session_itp.get_proof_attempt_parent session panid in let nid' = node_ID_from_pn parent_pn in remove_node nid; schedule_proof_attempt nid' config_prover pan.limit | exception Whyconf.ProverNotFound (_, fp) -> let msg = Format.asprintf "Counterexamples alternative for prover does \ not exists: %a" Whyconf.print_filter_prover fp in P.notify (Message (Error msg)) end | _ -> P.notify (Message (Error "Please select a proofattempt")) (* ----------------- locate next unproven node -------------------- *) let notify_first_unproven_node d ni = let s = d.cont.controller_session in let any = any_from_node_ID ni in match any with | None -> P.notify (Message (Error "Please select a node id")) | Some any -> let unproven_any = get_first_unproven_goal_around ~always_send:false ~proved:(Session_itp.any_proved s) ~children:(get_undetached_children_no_pa s) ~get_parent:(get_any_parent s) ~is_goal:(fun any -> match any with | APn _ -> true | _ -> false) ~is_pa:(fun any -> match any with | APa _ -> true | _ -> false) any in begin match unproven_any with | None -> () (* If no node is found we don't tell IDE to move *) | Some any -> P.notify (Next_Unproven_Node_Id (ni, node_ID_from_any any)) end (* Check if a request is valid (does not suppose existence of obsolete node_id) *) let request_is_valid r = match r with | Save_req | Check_need_saving_req | Reload_req | Get_file_contents _ | Save_file_req _ | Interrupt_req | Add_file_req _ | Set_config_param _ | Set_prover_policy _ | Exit_req | Get_global_infos | Itp_communication.Unfocus_req -> true | Get_first_unproven_node ni -> Hint.mem model_any ni | Remove_subtree nid -> Hint.mem model_any nid | Copy_paste (from_id, to_id) -> Hint.mem model_any from_id && Hint.mem model_any to_id | Get_task(nid,_,_) -> Hint.mem model_any nid | Command_req (nid, _) -> if not (Itp_communication.is_root nid) then Hint.mem model_any nid else true (* ----------------- treat_request -------------------- *) let treat_request d r = match r with | Get_global_infos -> Debug.dprintf debug "sending initialization infos@."; P.notify (Initialized d.global_infos) | Save_req -> save_session (); session_needs_saving := false | Reload_req -> reload_session (); session_needs_saving := true | Get_first_unproven_node ni -> notify_first_unproven_node d ni | Remove_subtree nid -> remove_node nid; session_needs_saving := true | Copy_paste (from_id, to_id) -> let from_any = any_from_node_ID from_id in let to_any = any_from_node_ID to_id in begin match from_any, to_any with | None, _ | _, None -> P.notify (Message (Error "Please select a node id")); | Some from_any, Some to_any -> begin try C.copy_paste ~notification:(notify_change_proved d.cont) ~callback_pa:(callback_update_tree_proof d.cont) ~callback_tr:(callback_update_tree_transform) d.cont from_any to_any; session_needs_saving := true with C.BadCopyPaste -> P.notify (Message (Error "invalid copy")) end end | Get_file_contents f -> read_and_send f | Save_file_req (name, text) -> save_file name text | Check_need_saving_req -> P.notify (Saving_needed !session_needs_saving) | Get_task(nid,b,loc) -> send_task nid b loc | Interrupt_req -> C.interrupt () | Command_req (nid, cmd) -> let snid = any_from_node_ID nid in begin match interp commands_table d.cont snid cmd with | Transform (s, _t, args) -> apply_transform nid s args; session_needs_saving := true | Query s -> P.notify (Message (Query_Info (nid, s))) | Prove (p, limit) -> schedule_proof_attempt nid p limit; session_needs_saving := true | Strategies st -> run_strategy_on_task nid st; session_needs_saving := true | Edit p -> schedule_edition nid p; session_needs_saving := true | Get_ce -> get_ce nid; session_needs_saving := true | Bisect -> schedule_bisection nid; session_needs_saving := true | Replay valid_only -> replay ~valid_only snid; session_needs_saving := true | Clean -> clean snid; session_needs_saving := true | Mark_Obsolete -> mark_obsolete snid; session_needs_saving := true | Focus_req -> let d = get_server_data () in let s = d.cont.controller_session in let any = any_from_node_ID nid in begin match any with | None -> P.notify (Message (Error "Please select a node id")) | Some any -> let focus_on = match any with | APa pa -> APn (Session_itp.get_proof_attempt_parent s pa) | _ -> any in focused_node := Focus_on [focus_on]; reset_and_send_the_whole_tree () end | Server_utils.Unfocus_req -> unfocus () | Help_message s -> P.notify (Message (Information s)) | QError s -> P.notify (Message (Query_Error (nid, s))) | Other (s, _args) -> P.notify (Message (Information ("Unknown command: "^s))) end | Add_file_req f -> add_file_to_session d.cont f | Set_config_param(s,i) -> begin match s with | "max_tasks" -> Controller_itp.set_session_max_tasks i | "timelimit" -> Server_utils.set_session_timelimit i | "memlimit" -> Server_utils.set_session_memlimit i | _ -> P.notify (Message (Error ("Unknown config parameter "^s))) end | Set_prover_policy(p,u) -> let c = d.cont in Controller_itp.set_session_prover_upgrade_policy c p u | Unfocus_req -> unfocus () | Exit_req -> exit 0 let treat_request r = let d = get_server_data () in (* Check that the request does not refer to obsolete node_ids *) if not (request_is_valid r) then begin (* These errors come from the client-server behavior of itp. They cannot be completely avoided and could be safely ignored. They are ignored if a debug flag is not added. *) if Debug.test_flag Debug.stack_trace then raise Not_found; if Debug.test_flag debug then P.notify (Message (Error (Pp.string_of (fun fmt r -> Format.fprintf fmt "The following request refer to obsolete node_ids:\n %a\n" Itp_communication.print_request r) r))) end else try treat_request d r with | C.TransAlreadyExists (name,args) -> P.notify (Message (Error (Pp.sprintf "Transformation %s with arg [%s] already exists" name args))) | C.GoalNodeDetached _id -> P.notify (Message (Information ("Transformation cannot apply on detached node"))) | e when not (Debug.test_flag Debug.stack_trace)-> P.notify (Message (Error (Pp.sprintf "There was an unrecoverable error during treatment of request:\n %a\nwith exception: %a" print_request r Exn_printer.exn_printer e))) let treat_requests () : bool = List.iter treat_request (P.get_requests ()); true let update_monitor = let tr = ref 0 in let sr = ref 0 in let rr = ref 0 in fun t s r -> if (not (t = !tr && s = !sr && r = !rr)) then begin P.notify (Message (Task_Monitor (t,s,r))); tr := t; sr := s; rr := r end let _ = S.timeout ~ms:default_delay_ms treat_requests; (* S.idle ~prio:1 treat_requests; *) C.register_observer update_monitor end why3-1.2.1/src/session/json_util.ml0000644000175100017510000006700213555524575020000 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 Itp_communication open Controller_itp open Call_provers open Json_base (* TODO match exceptions and complete some cases *) let convert_prover (prefix:string) (p: Whyconf.prover) = [prefix ^ "name", String p.Whyconf.prover_name; prefix ^ "version", String p.Whyconf.prover_version; prefix ^ "altern", String p.Whyconf.prover_altern] let convert_prover_to_json (prefix:string) (p: Whyconf.prover) = Record (convert_record (convert_prover prefix p)) let convert_infos (i: global_information) = let convert_prover (s,h,p) = Record (convert_record ["prover_shortcut", String s; "prover_name", String h; "prover_parseable_name", String p]) in let convert_strategy (s,p) = Record (convert_record ["strategy_shortcut", String s; "strategy_name", String p]) in Record (convert_record ["provers", List (List.map convert_prover i.provers); "transformations", List (List.map (fun (a, b) -> Record (convert_record ["name_t", String a; "desc_t", String b])) i.transformations); "strategies", List (List.map convert_strategy i.strategies); "commands", List (List.map (fun x -> String x) i.commands)]) let convert_prover_answer (pa: prover_answer) = match pa with | Valid -> "Valid","" | Invalid -> "Invalid","" | Timeout -> "Timeout","" | OutOfMemory -> "OutOfMemory","" | StepLimitExceeded -> "StepLimitExceeded","" | Unknown s -> "Unknown",s | Failure s -> "Failure",s | HighFailure -> "HighFailure","" let convert_limit (l: Call_provers.resource_limit) = Record (convert_record ["limit_time", Int l.Call_provers.limit_time; "limit_mem", Int l.Call_provers.limit_mem; "limit_steps", Int l.Call_provers.limit_steps]) let convert_unix_process (ps: Unix.process_status) = match ps with | Unix.WEXITED _ -> String "WEXITED" | Unix.WSIGNALED _ -> String "WSIGNALED" | Unix.WSTOPPED _ -> String "WSTOPPED" let convert_model (m: Model_parser.model) = String (Pp.string_of (* By default, we print attributes in JSON *) (fun fmt m -> Model_parser.print_model ~print_attrs:true fmt m) m) (* TODO pr_model should have a different format *) let convert_proof_result (pr: prover_result) = let (a,s) = convert_prover_answer pr.pr_answer in Record (convert_record ["pr_answer", String a; "pr_answer_arg", String s; "pr_status", convert_unix_process pr.pr_status; "pr_output", String pr.pr_output; "pr_time", Float pr.pr_time; "pr_steps", Int pr.pr_steps; "pr_model", convert_model pr.pr_model]) let convert_proof_attempt (pas: proof_attempt_status) = Record (match pas with | Undone -> convert_record ["proof_attempt", String "Undone"] | Interrupted -> convert_record ["proof_attempt", String "Interrupted"] | Scheduled -> convert_record ["proof_attempt", String "Scheduled"] | Detached -> convert_record ["proof_attempt", String "Detached"] | Running -> convert_record ["proof_attempt", String "Running"] | Done pr -> convert_record ["proof_attempt", String "Done"; "prover_result", convert_proof_result pr] | Controller_itp.InternalFailure e -> convert_record ["proof_attempt", String "InternalFailure"; "exception", String (Pp.string_of Exn_printer.exn_printer e)] | Uninstalled p -> convert_record ["proof_attempt", String "Uninstalled"; "prover", convert_prover_to_json "prover_" p] | Removed p -> convert_record ["proof_attempt", String "Removed"; "prover", convert_prover_to_json "prover_" p] | UpgradeProver p -> convert_record ["proof_attempt", String "UpgradeProver"; "prover", convert_prover_to_json "prover_" p]) let convert_update u = Record (match u with | Proved b -> convert_record ["update_info", String "Proved"; "proved", Bool b] | Name_change n -> convert_record ["update_info", String "Name_change"; "name", String n] | Proof_status_change (pas, b, l) -> convert_record ["update_info", String "Proof_status_change"; "proof_attempt", convert_proof_attempt pas; "obsolete", Bool b; "limit", convert_limit l] ) let convert_notification_constructor n = match n with | Reset_whole_tree -> String "Reset_whole_tree" | New_node _ -> String "New_node" | Node_change _ -> String "Node_change" | Remove _ -> String "Remove" | Next_Unproven_Node_Id (_, _) -> String "Next_Unproven_Node_Id" | Initialized _ -> String "Initialized" | Saved -> String "Saved" | Saving_needed _ -> String "Saving_needed" | Message _ -> String "Message" | Dead _ -> String "Dead" | Task _ -> String "Task" | File_contents _ -> String "File_contents" | Source_and_ce _ -> String "Source_and_ce" let convert_node_type_string nt = match nt with | NRoot -> "NRoot" | NFile -> "NFile" | NTheory -> "NTheory" | NTransformation -> "NTransformation" | NGoal -> "NGoal" | NProofAttempt -> "NProofAttempt" let convert_node_type nt = String (convert_node_type_string nt) let convert_request_constructor (r: ide_request) = match r with | Command_req _ -> String "Command_req" | Add_file_req _ -> String "Add_file_req" | Save_file_req _ -> String "Save_file_req" | Set_config_param _ -> String "Set_config_param" | Set_prover_policy _ -> String "Set_prover_policy" | Get_file_contents _ -> String "Get_file_contents" | Get_task _ -> String "Get_task" | Remove_subtree _ -> String "Remove_subtree" | Copy_paste _ -> String "Copy_paste" | Get_first_unproven_node _ -> String "Get_first_unproven_node" | Unfocus_req -> String "Unfocus_req" | Save_req -> String "Save_req" | Check_need_saving_req -> String "Check_need_saving_req" | Reload_req -> String "Reload_req" | Exit_req -> String "Exit_req" | Interrupt_req -> String "Interrupt_req" | Get_global_infos -> String "Get_global_infos" open Whyconf let convert_policy u = match u with | CPU_remove -> ["policy", String "remove"] | CPU_keep -> ["policy", String "keep"] | CPU_upgrade p -> ["policy", String "upgrade"] @ convert_prover "target_" p | CPU_duplicate p -> ["policy", String "duplicate"] @ convert_prover "target_" p let print_request_to_json (r: ide_request): Json_base.json = let cc = convert_request_constructor in Record ( match r with | Command_req (nid, s) -> convert_record ["ide_request", cc r; "node_ID", Int nid; "command", String s] | Add_file_req f -> convert_record ["ide_request", cc r; "file", String f] | Save_file_req (f,_) -> convert_record ["ide_request", cc r; "file", String f] | Set_config_param(s,n) -> convert_record ["ide_request", cc r; "param", String s; "value", Int n] | Set_prover_policy(p,u) -> convert_record (["ide_request", cc r] @ convert_prover "" p @ convert_policy u) | Get_task(n,b,loc) -> convert_record ["ide_request", cc r; "node_ID", Int n; "full_context", Bool b ; "loc", Bool loc] | Get_file_contents s -> convert_record ["ide_request", cc r; "file", String s] | Remove_subtree n -> convert_record ["ide_request", cc r; "node_ID", Int n] | Copy_paste (from_id, to_id) -> convert_record ["ide_request", cc r; "node_ID1", Int from_id; "node_ID2", Int to_id] | Get_first_unproven_node id -> convert_record ["ide_request", cc r; "node_ID", Int id] | Check_need_saving_req | Unfocus_req | Save_req | Reload_req | Exit_req | Interrupt_req | Get_global_infos -> convert_record ["ide_request", cc r]) let convert_constructor_message (m: message_notification) = match m with | Proof_error _ -> String "Proof_error" | Transf_error _ -> String "Transf_error" | Strat_error _ -> String "Strat_error" | Replay_Info _ -> String "Replay_Info" | Query_Info _ -> String "Query_Info" | Query_Error _ -> String "Query_Error" | Information _ -> String "Information" | Task_Monitor _ -> String "Task_Monitor" | Parse_Or_Type_Error _ -> String "Parse_Or_Type_Error" | Error _ -> String "Error" | Open_File_Error _ -> String "Open_File_Error" | File_Saved _ -> String "File_Saved" let convert_loc (loc: Loc.position) : Json_base.json = let (file, line, col1, col2) = Loc.get loc in Record (convert_record ["file", Json_base.String file; "line", Json_base.Int line; "col1", Json_base.Int col1; "col2", Json_base.Int col2]) let convert_message (m: message_notification) = let cc = convert_constructor_message in Record (match m with | Proof_error (nid, s) -> convert_record ["mess_notif", cc m; "node_ID", Int nid; "error", String s] | Transf_error (is_fatal, nid, tr, arg, loc, s, doc) -> convert_record ["mess_notif", cc m; "is_fatal", Bool is_fatal; "node_ID", Int nid; "tr_name", String tr; "failing_arg", String arg; "loc", convert_loc loc; "error", String s; "doc", String doc] | Strat_error (nid, s) -> convert_record ["mess_notif", cc m; "node_ID", Int nid; "error", String s] | Replay_Info s -> convert_record ["mess_notif", cc m; "replay_info", String s] | Query_Info (nid, s) -> convert_record ["mess_notif", cc m; "node_ID", Int nid; "qinfo", String s] | Query_Error (nid, s) -> convert_record ["mess_notif", cc m; "node_ID", Int nid; "qerror", String s] | Information s -> convert_record ["mess_notif", cc m; "information", String s] | Task_Monitor (n, k, p) -> convert_record ["mess_notif", cc m; "monitor", List [Int n; Int k; Int p]] | Parse_Or_Type_Error (loc, rel_loc,s) -> convert_record ["mess_notif", cc m; "loc", convert_loc loc; "rel_loc", convert_loc rel_loc; "error", String s] | Error s -> convert_record ["mess_notif", cc m; "error", String s] | Open_File_Error s -> convert_record ["mess_notif", cc m; "open_error", String s] | File_Saved s -> convert_record ["mess_notif", cc m; "information", String s]) let convert_color (color: color) : Json_base.json = Json_base.String ( match color with | Neg_premise_color -> "Neg_premise_color" | Premise_color -> "Premise_color" | Goal_color -> "Goal_color" | Error_color -> "Error_color" | Error_line_color -> "Error_line_color" | Error_font_color -> "Error_font_color" ) let convert_loc_color (loc,color: Loc.position * color) : Json_base.json = let loc = convert_loc loc in let color = convert_color color in Record (convert_record ["loc", loc; "color", color]) let convert_list_loc (l: (Loc.position * color) list) : json = let list_of_loc = List.map convert_loc_color l in List list_of_loc exception Notcolor let parse_color (j: json) : color = match j with | String "Neg_premise_color" -> Neg_premise_color | String "Premise_color" -> Premise_color | String "Goal_color" -> Goal_color | String "Error_color" -> Error_color | String "Error_line_color" -> Error_line_color | String "Error_font_color" -> Error_font_color | _ -> raise Notcolor exception Notposition let parse_loc (j: json) : Loc.position = try let file = get_string (get_field j "file") in let line = get_int (get_field j "line") in let col1 = get_int (get_field j "col1") in let col2 = get_int (get_field j "col2") in Loc.user_position file line col1 col2 with Not_found -> raise Notposition let parse_loc_color (j: json): Loc.position * color = try let loc = parse_loc (get_field j "loc") in let color = parse_color (get_field j "color") in (loc, color) with Not_found -> raise Notposition let parse_list_loc (j: json): (Loc.position * color) list = match j with | List l -> List.map parse_loc_color l | _ -> raise Notposition let print_notification_to_json (n: notification): json = let cc = convert_notification_constructor in Record ( match n with | Reset_whole_tree -> convert_record ["notification", cc n] | New_node (nid, parent, node_type, name, detached) -> convert_record ["notification", cc n; "node_ID", Int nid; "parent_ID", Int parent; "node_type", convert_node_type node_type; "name", String name; "detached", Bool detached] | Node_change (nid, update) -> convert_record ["notification", cc n; "node_ID", Int nid; "update", convert_update update] | Remove nid -> convert_record ["notification", cc n; "node_ID", Int nid] | Next_Unproven_Node_Id (from_id, unproved_id) -> convert_record ["notification", cc n; "node_ID1", Int from_id; "node_ID2", Int unproved_id] | Initialized infos -> convert_record ["notification", cc n; "infos", convert_infos infos] | Saved -> convert_record ["notification", cc n] | Saving_needed b -> convert_record ["notification", cc n; "need_saving", Bool b] | Message m -> convert_record ["notification", cc n; "message", convert_message m] | Dead s -> convert_record ["notification", cc n; "message", String s] | Task (nid, s, list_loc) -> convert_record ["notification", cc n; "node_ID", Int nid; "task", String s; "loc_list", convert_list_loc list_loc] | File_contents (f, s) -> convert_record ["notification", cc n; "file", String f; "content", String s] | Source_and_ce (s, list_loc) -> convert_record ["notification", cc n; "content", String s; "loc_list", convert_list_loc list_loc]) let print_notification fmt (n: notification) = Format.fprintf fmt "%a" print_json (print_notification_to_json n) let print_request fmt (r: ide_request) = Format.fprintf fmt "%a" print_json (print_request_to_json r) let print_list_notification fmt (nl: notification list) = Format.fprintf fmt "%a" (Json_base.list print_notification) nl let print_list_request fmt (rl: ide_request list) = Format.fprintf fmt "%a" (Json_base.list print_request) rl exception NotProver let parse_prover_from_json (prefix:string) (j: json) = try let pn = get_string (get_field j (prefix ^ "name")) in let pv = get_string (get_field j (prefix ^ "version")) in let pa = get_string (get_field j (prefix ^ "altern")) in {Whyconf.prover_name = pn; prover_version = pv; prover_altern = pa} with Not_found -> raise NotProver exception NotLimit let parse_limit_from_json (j: json) = try let t = get_int (get_field j "limit_time") in let m = get_int (get_field j "limit_mem") in let s = get_int (get_field j "limit_steps") in {limit_time = t; limit_mem = m; limit_steps = s} with Not_found -> raise NotLimit exception NotRequest of string let parse_request (constr: string) j = match constr with | "Command_req" -> let nid = get_int (get_field j "node_ID") in let s = get_string (get_field j "command") in Command_req (nid, s) | "Get_first_unproven_node" -> let nid = get_int (get_field j "node_ID") in Get_first_unproven_node nid | "Add_file_req" -> let f = get_string (get_field j "file") in Add_file_req f | "Set_config_param" -> let s = get_string (get_field j "param") in let n = get_int (get_field j "value") in Set_config_param(s,n) | "Set_prover_policy" -> let p = parse_prover_from_json "" j in let u = get_string (get_field j "policy") in begin match u with | "keep" -> Set_prover_policy(p,CPU_keep) | "upgrade" -> let p' = parse_prover_from_json "target_" j in Set_prover_policy(p,CPU_upgrade p') | "duplicate" -> let p' = parse_prover_from_json "target_" j in Set_prover_policy(p,CPU_duplicate p') | _ -> raise (NotRequest "") end | "Get_task" -> let n = get_int (get_field j "node_ID") in let b = get_bool_opt (get_field j "full_context") false in let loc = get_bool_opt (get_field j "loc") false in Get_task(n,b,loc) | "Remove_subtree" -> let n = get_int (get_field j "node_ID") in Remove_subtree n | "Copy_paste" -> let from_id = get_int (get_field j "node_ID1") in let to_id = get_int (get_field j "node_ID2") in Copy_paste (from_id, to_id) | "Unfocus_req" -> Unfocus_req | "Interrupt_req" -> Interrupt_req | "Save_req" -> Save_req | "Reload_req" -> Reload_req | "Exit_req" -> Exit_req | _ -> raise (NotRequest "") let parse_request_json (j: json): ide_request = try let constr = get_string (get_field j "ide_request") in parse_request constr j with | _ -> let s =Pp.string_of print_json j in begin Format.eprintf "BEGIN \n %s \nEND\n@." s; raise (NotRequest s); end exception NotNodeType let parse_node_type_from_json j = match j with | String "NRoot" -> NRoot | String "NFile" -> NFile | String "NTheory" -> NTheory | String "NTransformation" -> NTransformation | String "NGoal" -> NGoal | String "NProofAttempt" -> NProofAttempt | _ -> raise NotNodeType let parse_prover_answer a d = match a with | "Valid" -> Valid | "Invalid" -> Invalid | "Timeout" -> Timeout | "OutOfMemory" -> OutOfMemory | "StepLimitExceeded" -> StepLimitExceeded | "Unknown" -> Unknown d | "Failure" -> Failure d | "HighFailure" -> HighFailure | _ -> HighFailure let parse_unix_process j arg = match j with | "WEXITED" -> Unix.WEXITED arg (* TODO dummy value *) | "WSIGNALED" -> Unix.WSIGNALED arg (* TODO dummy value *) | "WSTOPPED" -> Unix.WSTOPPED arg (* TODO dummy value *) | _ -> Unix.WSIGNALED (-1) (* default, should never happen *) let parse_prover_result j = let pr_answer = let arg = try get_string (get_field j "pr_answer_arg") with Not_found -> "" in try parse_prover_answer (get_string (get_field j "pr_answer")) arg with Not_found -> HighFailure in let pr_status_unix = let arg = try get_int (get_field j "pr_status_arg") with Not_found -> (-1) in try parse_unix_process (get_string (get_field j "pr_status")) arg with Not_found -> Unix.WSIGNALED (-1) in let pr_output = try get_string (get_field j "pr_output") with Not_found -> "" in let pr_time = try get_float (get_field j "pr_time") with Not_found -> -1.0 in let pr_steps = try get_int (get_field j "pr_steps") with Not_found -> -1 in let _pr_model = try get_string (get_field j "pr_model") with Not_found -> "" in { pr_answer = pr_answer; pr_status = pr_status_unix; pr_output = pr_output; pr_time = pr_time; pr_steps = pr_steps; pr_model = Model_parser.default_model (* pr_model *)} (* TODO pr_model is a string, should be model *) exception NotProofAttempt let parse_proof_attempt j = let s = get_string (get_field j "proof_attempt") in match s with | "Undone" -> Undone | "Detached" -> Detached | "Interrupted" -> Interrupted | "Scheduled" -> Scheduled | "Running" -> Running | "Done" -> let pr = get_field j "prover_result" in Done (parse_prover_result pr) | "InternalFailure" -> raise NotProofAttempt (* TODO *) | "Uninstalled" -> let p = get_field j "prover" in Uninstalled (parse_prover_from_json "prover_" p) | "UpgradeProver" -> let p = get_field j "prover" in UpgradeProver (parse_prover_from_json "prover_" p) | _ -> raise NotProofAttempt exception NotUpdate let parse_update j = let update = get_string (get_field j "update_info") in match update with | "Proved" -> let b = get_bool (get_field j "proved") in Proved b | "Name_change" -> let n = get_string (get_field j "name") in Name_change n | "Proof_status_change" -> let pas = get_field j "proof_attempt" in let b = get_bool (get_field j "obsolete") in let l = get_field j "limit" in Proof_status_change (parse_proof_attempt pas, b, parse_limit_from_json l) | _ -> raise NotUpdate exception NotInfos of string let parse_infos j = try let pr = get_list (get_field j "provers") in let tr = get_list (get_field j "transformations") in let tr = List.map (fun j -> try get_string (get_field j "name_t"), get_string (get_field j "desc_t") with | _ -> raise (NotInfos "transformations")) tr in let str = get_list (get_field j "strategies") in let com = get_list (get_field j "commands") in {provers = List.map (fun j -> try (get_string (get_field j "prover_shortcut"), get_string (get_field j "prover_name"), get_string (get_field j "prover_parseable_name")) with Not_found -> raise (NotInfos "provers")) pr; transformations = tr; strategies = List.map (fun j -> try (get_string (get_field j "strategy_shortcut"), get_string (get_field j "strategy_name")) with Not_found -> raise (NotInfos "strategies")) str; commands = List.map (fun j -> match j with | String x -> x | _ -> raise (NotInfos "commands")) com} with Not_found -> raise (NotInfos "infos") exception NotMessage let parse_message constr j = match constr with | "Proof_error" -> let nid = get_int (get_field j "node_ID") in let s = get_string (get_field j "error") in Proof_error (nid, s) | "Transf_error" -> let nid = get_int (get_field j "node_ID") in let is_fatal = get_bool (get_field j "is_fatal") in let tr_name = get_string (get_field j "tr_name") in let arg = get_string (get_field j "failing_arg") in let loc = parse_loc (get_field j "loc") in let error = get_string (get_field j "error") in let doc = get_string (get_field j "doc") in Transf_error (is_fatal, nid, tr_name, arg, loc, error, doc) | "Strat_error" -> let nid = get_int (get_field j "node_ID") in let s = get_string (get_field j "error") in Strat_error (nid, s) | "Replay_Info" -> let s = get_string (get_field j "replay_info") in Replay_Info s | "Query_Info" -> let nid = get_int (get_field j "node_ID") in let s = get_string (get_field j "qinfo") in Query_Info (nid, s) | "Query_Error" -> let nid = get_int (get_field j "node_ID") in let s = get_string (get_field j "qerror") in Query_Error (nid, s) | "Information" -> let s = get_string (get_field j "information") in Information s | "Task_Monitor" -> let m = get_list (get_field j "monitor") in begin match m with | Int n :: Int k :: Int p :: [] -> Task_Monitor (n, k, p) | _ -> raise NotMessage end | "Error" -> let s = get_string (get_field j "error") in Error s | "Open_File_Error" -> let s = get_string (get_field j "open_error") in Open_File_Error s | "Parse_Or_Type_Error" -> let loc = parse_loc (get_field j "loc") in let rel_loc = parse_loc (get_field j "rel_loc") in let error = get_string (get_field j "error") in Parse_Or_Type_Error (loc, rel_loc, error) | _ -> raise NotMessage let parse_message j = let constr = get_string (get_field j "mess_notif") in parse_message constr j exception NotNotification of string let parse_notification constr j = match constr with | "Reset_whole_tree" -> Reset_whole_tree | "New_node" -> let nid = get_int (get_field j "node_ID") in let parent = get_int (get_field j "parent_ID") in let node_type = get_field j "node_type" in let name = get_string (get_field j "name") in let detached = get_bool (get_field j "detached") in New_node (nid, parent, parse_node_type_from_json node_type, name, detached) | "Node_change" -> let nid = get_int (get_field j "node_ID") in let update = get_field j "update" in Node_change (nid, parse_update update) | "Remove" -> let nid = get_int (get_field j "node_ID") in Remove nid | "Initialized" -> let infos = get_field j "infos" in Initialized (parse_infos infos) | "Saved" -> Saved | "Message" -> let m = get_field j "message" in Message (parse_message m) | "Dead" -> let s = get_string (get_field j "message") in Dead s | "Task" -> let nid = get_int (get_field j "node_ID") in let s = get_string (get_field j "task") in let l = get_field j "loc_list" in Task (nid, s, parse_list_loc l) | "Next_Unproven_Node_Id" -> let nid1 = get_int (get_field j "node_ID1") in let nid2 = get_int (get_field j "node_ID2") in Next_Unproven_Node_Id (nid1, nid2) | "File_contents" -> let f = get_string (get_field j "file") in let s = get_string (get_field j "content") in File_contents(f,s) | "Source_and_ce" -> let s = get_string (get_field j "content") in let l = get_field j "loc_list" in Source_and_ce(s, parse_list_loc l) | s -> raise (NotNotification (" " ^ s)) let parse_notification_json j = try let constr = get_string (get_field j "notification") in parse_notification constr j with | Not_found -> raise (NotNotification "") let parse_json_object (s: string) = let lb = Lexing.from_string s in let x = Json_parser.value (fun x -> Json_lexer.read x) lb in x let parse_notification (s: string) : notification = let json = parse_json_object s in parse_notification_json json let parse_request (s: string) : ide_request = let json = parse_json_object s in parse_request_json json let parse_list_notification (s: string): notification list = let json = parse_json_object s in match json with | List [Null] -> [] | List l -> List.map parse_notification_json l | _ -> raise (NotNotification "Not list") let parse_list_request (s: string): ide_request list = let json = parse_json_object s in match json with | List l -> List.map parse_request_json l | _ -> raise (NotRequest "Not list") why3-1.2.1/src/session/server_utils.ml0000644000175100017510000005040313555524575020515 0ustar guillaumeguillaume(********************************************************************) (* *) (* The Why3 Verification Platform / The Why3 Development Team *) (* Copyright 2010-2019 -- 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 Wstdlib let debug = Debug.register_flag ~desc:"ITP server" "itp_server" let has_extension f = try let _ = Filename.chop_extension f in true with Invalid_argument _ -> false let get_session_dir ~allow_mkdir files = if Queue.is_empty files then invalid_arg "no files given"; let first = Queue.pop files in let dir = if Sys.file_exists first then if Sys.is_directory first then (* first is a directory *) first else if Filename.basename first = "why3session.xml" then (* first is a session file *) Filename.dirname first else if Queue.is_empty files then (* first was the only file *) let d = try Filename.chop_extension first with Invalid_argument _ -> invalid_arg ("'" ^ first ^ "' has no extension and is not a directory") in Queue.push first files; d else invalid_arg ("'" ^ first ^ "' is not a directory") else (* first does not exist *) if has_extension first then invalid_arg ("file not found: " ^ first) else first in if not (Sys.file_exists dir) then begin if allow_mkdir then Unix.mkdir dir 0o700 else invalid_arg ("session directory '" ^ dir ^ "' not found") end; dir (******************) (* Simple queries *) (******************) (**** interpretation of command-line ****) let sort_pair (x,_) (y,_) = String.compare x y let list_transforms () = let l = List.rev_append (List.rev_append (Trans.list_transforms ()) (Trans.list_transforms_l ())) (List.rev_append (Trans.list_transforms_with_args ()) (Trans.list_transforms_with_args_l ())) in List.sort sort_pair l let list_transforms_query _cont _args = let l = list_transforms () in let print_trans_desc fmt (x,r) = Format.fprintf fmt "@[%s@\n@[%a@]@]" x Pp.formatted r in Pp.string_of (Pp.print_list Pp.newline2 print_trans_desc) l let list_provers cont _args = let l = Whyconf.Hprover.fold (fun p _ acc -> (Pp.sprintf "%a" Whyconf.print_prover p)::acc) cont.Controller_itp.controller_provers [] in let l = List.sort String.compare l in Pp.sprintf "%a" (Pp.print_list Pp.newline Pp.string) l let load_strategies cont = let config = cont.Controller_itp.controller_config in let env = cont.Controller_itp.controller_env in let strategies = Whyconf.get_strategies config in Mstr.iter (fun _ st -> let name = st.Whyconf.strategy_name in try let code = st.Whyconf.strategy_code in let code = Strategy_parser.parse env config code in let shortcut = st.Whyconf.strategy_shortcut in Debug.dprintf debug "[session server info] Strategy '%s' loaded.@." name; Hstr.add cont.Controller_itp.controller_strategies name (name, shortcut, st.Whyconf.strategy_desc, code) with Strategy_parser.SyntaxError msg -> Format.eprintf "Fatal: loading strategy '%s' failed: %s \nSolve this problem in your why3.conf file and retry.@." name msg; exit 1) strategies let list_strategies cont = Hstr.fold (fun _ (name,short,_,_) acc -> (short,name)::acc) cont.Controller_itp.controller_strategies [] let symbol_name s = match s with | Args_wrapper.Tstysymbol ts -> ts.Ty.ts_name | Args_wrapper.Tsprsymbol pr -> pr.Decl.pr_name | Args_wrapper.Tslsymbol ls -> ls.Term.ls_name (* Prints a constructor in a string using the inductive list definition containing the constructor *) let print_constr_string ~print_term ~print_pr il pr = (* The inductive type is an lsymbol: we are sure to get a constructor *) let constr_def = List.fold_left (fun acc (_, ind_decl) -> List.fold_left (fun acc x -> if Decl.pr_equal (fst x) pr then Some x else acc) acc ind_decl) None il in match constr_def with | None -> raise Not_found (* construct was not found: should not happen *) | Some (_, t_def) -> let s = Pp.string_of print_term t_def in Pp.string_of print_pr pr ^ ": " ^ s (* The id you are trying to use is undefined *) exception Undefined_id of string (* Bad number of arguments *) exception Number_of_arguments let print_id s tables = (* let tables = Args_wrapper.build_name_tables task in*) let km = tables.Trans.known_map in let table_id = try Args_wrapper.find_symbol s tables with | Args_wrapper.Arg_parse_type_error _ | Args_wrapper.Arg_qid_not_found _ -> raise (Undefined_id s) in (* Check that the symbol is defined *) let d = (* Not_found should not happend *) Ident.Mid.find (symbol_name table_id) km in (* We use snapshots of printers to avoid registering new value insides it only to print info messages to the user. *) let pr = Ident.duplicate_ident_printer tables.Trans.printer in let apr = Ident.duplicate_ident_printer tables.Trans.aprinter in let module P = (val Pretty.create pr apr pr pr false) in (* Different constructs are printed differently *) match d.Decl.d_node, table_id with | Decl.Dind (_, il), Args_wrapper.Tsprsymbol pr -> print_constr_string ~print_term:P.print_term ~print_pr:P.print_pr il pr | _ -> Pp.string_of P.print_decl d (* searching ids in declarations *) let occurs_in_type id = Ty.ty_s_any (fun ts -> Ident.id_equal ts.Ty.ts_name id) let occurs_in_term id = Term.t_s_any (occurs_in_type id) (fun ls -> Ident.id_equal id ls.Term.ls_name) let occurs_in_constructor id (cs,projs) = Ident.id_equal cs.Term.ls_name id || List.exists (function Some ls -> Ident.id_equal ls.Term.ls_name id | None -> false) projs let occurs_in_defn id (ls,def) = Ident.id_equal ls.Term.ls_name id || let (_vl,t) = Decl.open_ls_defn def in occurs_in_term id t let occurs_in_ind_decl id (_,clauses) = List.exists (fun (pr,t) -> Ident.id_equal id pr.Decl.pr_name || occurs_in_term id t) clauses let occurs_in_decl d id = Decl.(match d.d_node with | Decl.Dtype ts -> Ident.id_equal ts.Ty.ts_name id (* look through ts.ys_def *) | Decl.Ddata dl -> List.exists (fun ((ts,c): data_decl) -> Ident.id_equal ts.Ty.ts_name id || List.exists (occurs_in_constructor id) c) dl | Decl.Dparam ls -> Ident.id_equal ls.Term.ls_name id | Decl.Dlogic dl -> List.exists (occurs_in_defn id) dl | Decl.Dind (_, il) -> List.exists (occurs_in_ind_decl id) il | Dprop ((Paxiom|Plemma), pr, t) -> Ident.id_equal pr.pr_name id || occurs_in_term id t | Dprop _ -> false) let do_search ~search_both km idl = Ident.Mid.fold (fun _ d acc -> if search_both then (if List.exists (occurs_in_decl d) idl then Decl.Sdecl.add d acc else acc) else (if List.for_all (occurs_in_decl d) idl then Decl.Sdecl.add d acc else acc)) km Decl.Sdecl.empty let search ~search_both s tables = let ids = List.rev_map (fun s -> try symbol_name (Args_wrapper.find_symbol s tables) with Args_wrapper.Arg_parse_type_error _ | Args_wrapper.Arg_qid_not_found _ -> raise (Undefined_id s)) s in let l = do_search ~search_both tables.Trans.known_map ids in if Decl.Sdecl.is_empty l then (* In case where search_both is true, this error cannot appear because there is at least one declaration: the definition of the ident. *) Pp.sprintf "No declaration contain all the %d identifiers @[%a@]" (List.length ids) (Pp.print_list Pp.space (fun fmt id -> Pp.string fmt id.Ident.id_string)) ids else let l = Decl.Sdecl.elements l in (* We use snapshots of printers to avoid registering new value insides it only to print info messages to the user. *) let pr = Ident.duplicate_ident_printer tables.Trans.printer in let apr = Ident.duplicate_ident_printer tables.Trans.aprinter in let module P = (val Pretty.create pr apr pr pr false) in Pp.string_of (Pp.print_list Pp.newline2 P.print_decl) l let print_id _cont task args = match args with | [s] -> print_id s task | _ -> raise Number_of_arguments let search_id ~search_both _cont task args = match args with | [] -> raise Number_of_arguments | _ -> search ~search_both args task type query = | Qnotask of (Controller_itp.controller -> string list -> string) | Qtask of (Controller_itp.controller -> Trans.naming_table -> string list -> string) let help_on_queries fmt commands = let l = Hstr.fold (fun c (h,_) acc -> (c,h)::acc) commands [] in let l = List.sort sort_pair l in let p fmt (c,help) = Format.fprintf fmt "%20s : %s" c help in Format.fprintf fmt "%a" (Pp.print_list Pp.newline p) l (* Return the prover corresponding to given name. name is of the form | name | name, version | name, altern | name, version, altern *) let return_prover name config = let fp = Whyconf.parse_filter_prover name in (** all provers that have the name/version/altern name *) let provers = Whyconf.filter_provers config fp in if Whyconf.Mprover.is_empty provers then begin Debug.dprintf debug "Prover corresponding to %s has not been found@." name; None end else Some (snd (Whyconf.Mprover.choose provers)) let session_timelimit = ref 2 let session_memlimit = ref 1000 let set_session_timelimit n = session_timelimit := n let set_session_memlimit n = session_memlimit := n type command_prover = | Bad_Arguments of Whyconf.prover | Not_Prover | Prover of (Whyconf.config_prover * Call_provers.resource_limit) (* Parses the Other command. If it fails to parse it, it answers None otherwise it returns the config of the prover together with the ressource_limit *) let parse_prover_name config name args : command_prover = match (return_prover name config) with | None -> Not_Prover | Some prover_config -> begin let prover = prover_config.Whyconf.prover in try if (List.length args > 2) then Bad_Arguments prover else match args with | [] -> let default_limit = Call_provers.{empty_limit with limit_time = !session_timelimit; limit_mem = !session_memlimit} in Prover (prover_config, default_limit) | [timeout] -> Prover (prover_config, Call_provers.{empty_limit with limit_time = int_of_string timeout; limit_mem = !session_memlimit}) | [timeout; oom ] -> Prover (prover_config, Call_provers.{empty_limit with limit_time = int_of_string timeout; limit_mem = int_of_string oom}) | _ -> Bad_Arguments prover with | Failure _ -> Bad_Arguments prover end (*******************************) (* Prover command line parsing *) (*******************************) (* splits input string [s] into substrings separated by space spaces inside quotes or parentheses are not separator. implemented as a hardcoded automaton: *) let split_args s = let args = ref [] in let par_depth = ref 0 in let b = Buffer.create 17 in let push_arg () = let x = Buffer.contents b in if String.length x > 0 then (args := x :: !args; Buffer.clear b) in let push_char c = Buffer.add_char b c in let state = ref 0 in for i = 0 to String.length s - 1 do let c = s.[i] in match !state, c with | 0,' ' -> if !par_depth > 0 then push_char c else push_arg () | 0,'(' -> incr par_depth; push_char c | 0,')' -> decr par_depth; push_char c | 0,'"' -> state := 1; if !par_depth > 0 then push_char c | 0,_ -> push_char c | 1,'"' -> state := 0; if !par_depth > 0 then push_char c | 1,_ -> push_char c | _ -> assert false done; push_arg (); match List.rev !args with | a::b -> a,b | [] -> "",[] type command = | Transform of string * Trans.gentrans * string list | Prove of Whyconf.config_prover * Call_provers.resource_limit | Strategies of string | Edit of Whyconf.prover | Get_ce | Bisect | Replay of bool | Clean | Mark_Obsolete | Focus_req | Unfocus_req | Help_message of string | Query of string | QError of string | Other of string * string list let query_on_task cont f id args = let _,table = Session_itp.get_task_name_table cont.Controller_itp.controller_session id in try Query (f cont table args) with | Undefined_id s -> QError ("No existing id corresponding to " ^ s) | Number_of_arguments -> QError "Bad number of arguments" let help_message commands_table = Pp.sprintf "Please type a command among the following (automatic completion available)@\n\ @\n\ @ [arguments]@\n\ @ [