diff options
448 files changed, 8776 insertions, 5383 deletions
diff --git a/.gitattributes b/.gitattributes index 742ef27f49..47538be4a3 100644 --- a/.gitattributes +++ b/.gitattributes @@ -54,5 +54,5 @@ tools/CoqMakefile.in whitespace=blank-at-eol # CR is desired for these Windows files. *.bat whitespace=cr-at-eol,blank-at-eol,tab-in-indent -* eol=lf -*.bat eol=crlf +# never do endline conversion +* -text diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index 0f2dd89975..275d6c1ff5 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -30,10 +30,9 @@ # Trick to avoid getting review requests # each time someone adds an overlay -/appveyor.yml @maximedenes -/dev/ci/appveyor.* @maximedenes -/dev/ci/*.bat @maximedenes -# Secondary maintainer @SkySkimmer +/appveyor.yml @coq/ci-maintainers +/dev/ci/appveyor.* @coq/ci-maintainers +/dev/ci/*.bat @coq/ci-maintainers *.nix @coq/nix-maintainers @@ -71,6 +70,8 @@ azure-pipelines.yml @coq/ci-maintainers /man/ @silene # Secondary maintainer @maximedenes +/doc/plugin_tutorial/ @coq/plugin-tutorial-maintainers + ########## Coqchk ########## /checker/ @ppedrot @@ -314,7 +315,7 @@ azure-pipelines.yml @coq/ci-maintainers /test-suite/README.md @gares # Secondary maintainer @SkySkimmer -/test-suite/save-logs @SkySkimmer +/test-suite/report.sh @SkySkimmer /test-suite/complexity/ @herbelin diff --git a/.github/ISSUE_TEMPLATE.md b/.github/ISSUE_TEMPLATE.md index c9cb516cd3..aec6cd0a21 100644 --- a/.github/ISSUE_TEMPLATE.md +++ b/.github/ISSUE_TEMPLATE.md @@ -1,18 +1,11 @@ -<!-- Thank you for your contribution. - Please complete the following information when reporting a bug. --> +<!-- Thank you for reporting a bug to Coq! --> -#### Version - -<!-- You can get this information by running `coqtop -v`. --> - - -#### Operating system +#### Description of the problem +<!-- If you can, it's helpful to provide self-contained example of some code +that reproduces the bug. If not, a link to a larger example is also helpful. --> -#### Description of the problem +#### Coq Version -<!-- It is helpful to provide enough information so that we can reproduce the bug. - In particular, please include a code example which produces it. - If the example is small, you can include it here between ``` ```. - Otherwise, please provide a link to a repository, a gist (https://gist.github.com) - or drag-and-drop a `.zip` archive. --> +<!-- You can get this information by running `coqtop -v`. If relevant, please +also include your operating system. --> diff --git a/.gitignore b/.gitignore index 0411247abf..2e5529ccfb 100644 --- a/.gitignore +++ b/.gitignore @@ -134,7 +134,6 @@ coqpp/coqpp_parse.mli g_*.ml -lib/coqProject_file.ml plugins/ltac/coretactics.ml plugins/ltac/extratactics.ml plugins/ltac/extraargs.ml @@ -150,6 +149,7 @@ kernel/byterun/coq_jumptbl.h kernel/copcodes.ml ide/index_urls.txt .lia.cache +.nia.cache # emacs save files *~ diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 108ecb5a04..a6858c6802 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -151,7 +151,7 @@ after_script: - BIN=$(readlink -f ../_install_ci/bin)/ - LIB=$(readlink -f ../_install_ci/lib/coq)/ - export OCAMLPATH=$(readlink -f ../_install_ci/lib/):"$OCAMLPATH" - - make -j "$NJOBS" BIN="$BIN" LIB="$LIB" all + - make -j "$NJOBS" BIN="$BIN" LIB="$LIB" COQFLAGS="${COQFLAGS}" all artifacts: name: "$CI_JOB_NAME.logs" when: on_failure @@ -174,20 +174,17 @@ after_script: script: - set -e - echo 'start:coq.test' - - make -f Makefile.ci -j "$NJOBS" ${TEST_TARGET} + - make -f Makefile.ci -j "$NJOBS" "${CI_JOB_NAME#*:}" - echo 'end:coq.test' - set +e dependencies: - build:base - variables: &ci-template-vars - TEST_TARGET: "$CI_JOB_NAME" .ci-template-flambda: &ci-template-flambda <<: *ci-template dependencies: - build:edge+flambda variables: - <<: *ci-template-vars OPAM_SWITCH: "edge" OPAM_VARIANT: "+flambda" @@ -248,6 +245,12 @@ build:base+async: COQ_EXTRA_CONF: "-native-compiler yes -coqide opt" COQUSERFLAGS: "-async-proofs on" +build:quick: + <<: *build-template + variables: + COQ_EXTRA_CONF: "-native-compiler no" + QUICK: "1" + windows64: <<: *windows-template variables: @@ -260,6 +263,18 @@ windows32: except: - /^pr-.*$/ +lint: + image: docker:git + stage: test + script: + - apk add bash + - dev/lint-repository.sh + dependencies: [] + before_script: [] + variables: + # we need an unknown amount of history for per-commit linting + GIT_DEPTH: "" + pkg:opam: stage: test # OPAM will build out-of-tree so no point in importing artifacts @@ -273,16 +288,15 @@ pkg:opam: variables: OPAM_SWITCH: edge -pkg:nix: +.nix-template: &nix-template image: nixorg/nix:latest # Minimal NixOS image which doesn't even contain git stage: test variables: # By default we use coq.cachix.org as an extra substituter but this can be overridden EXTRA_SUBSTITUTERS: https://coq.cachix.org - EXTRA_PUBLIC_KEYS: coq.cachix.org-1:Jgt0DwGAUo+wpxCM52k2V+E0hLoOzFPzvg94F65agtI= + EXTRA_PUBLIC_KEYS: coq.cachix.org-1:5QW/wwEnD+l2jvN6QRbRRsa4hBHG3QiQQ26cxu1F5tI= # The following variables should not be overridden GIT_STRATEGY: none - CACHIX_PUBLIC_KEY: cachix.cachix.org-1:eWNHQldwUO7G2VkjpnjDbWwy4KQ/HNxht7H4SSoMckM= NIXOS_PUBLIC_KEY: cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= dependencies: [] # We don't need to download build artifacts @@ -290,8 +304,6 @@ pkg:nix: script: # Use current worktree as tmpdir to allow exporting artifacts in case of failure - export TMPDIR=$PWD - # Install Cachix as documented at https://github.com/cachix/cachix - - nix-env -if https://github.com/cachix/cachix/tarball/master --substituters https://cachix.cachix.org --trusted-public-keys "$CACHIX_PUBLIC_KEY" # We build an expression rather than a direct URL to not be dependent on # the URL location; we are forced to put the public key of cache.nixos.org # because there is no --extra-trusted-public-key option. @@ -302,6 +314,24 @@ pkg:nix: paths: - nix-build-coq.drv-0/*/test-suite/logs +pkg:nix:deploy: + <<: *nix-template + environment: + name: cachix + url: https://coq.cachix.org + before_script: + # Install Cachix as documented at https://github.com/cachix/cachix + - nix-env -iA cachix -f https://cachix.org/api/v1/install + only: + - master + - /^v.*\..*$/ + +pkg:nix: + <<: *nix-template + except: + - master + - /^v.*\..*$/ + doc:refman: <<: *doc-template dependencies: @@ -371,11 +401,11 @@ test-suite:edge+trunk+make: stage: test dependencies: [] script: - - opam switch create 4.08.0 --empty + - opam switch create 4.09.0 --empty - eval $(opam env) - - opam repo add ocaml-pr https://github.com/ocaml/ocaml-pr-repository.git + - opam repo add ocaml-beta https://github.com/ocaml/ocaml-beta-repository.git - opam update - - opam install ocaml-variants=4.08.0 num + - opam install ocaml-variants=4.09.0+trunk num - eval $(opam env) # We avoid problems with warnings: - ./configure -profile devel -warn-error no @@ -395,18 +425,18 @@ test-suite:edge+trunk+dune: stage: test dependencies: [] script: - - opam switch create 4.08.0 --empty + - opam switch create 4.09.0 --empty - eval $(opam env) - - opam repo add ocaml-pr https://github.com/ocaml/ocaml-pr-repository.git + - opam repo add ocaml-beta https://github.com/ocaml/ocaml-beta-repository.git - opam update - - opam install ocaml-variants=4.08.0 num + - opam install ocaml-variants=4.09.0+trunk num - opam pin add dune --dev # ounit lablgtk conf-gtksourceview - opam install dune - eval $(opam env) # We use the release profile to avoid problems with warnings - make -f Makefile.dune trunk - export COQ_UNIT_TEST=noop - - dune runtest --profile=ocaml408 + - dune runtest --profile=ocaml409 variables: OPAM_SWITCH: edge artifacts: @@ -418,6 +448,13 @@ test-suite:edge+trunk+dune: expire_in: 1 week allow_failure: true +test-suite:base+async: + <<: *test-suite-template + dependencies: + - build:base + variables: + COQFLAGS: "-async-proofs on" + validate:base: <<: *validate-template dependencies: @@ -445,93 +482,110 @@ validate:edge+flambda: OPAM_SWITCH: edge OPAM_VARIANT: "+flambda" -ci-aac_tactics: - <<: *ci-template +validate:quick: + <<: *validate-template + dependencies: + - build:quick -ci-bedrock2: - <<: *ci-template - allow_failure: true +# Libraries are by convention the projects that depend on Coq +# but not on its ML API -ci-bignums: +library:ci-bedrock2: <<: *ci-template + allow_failure: true -ci-color: +library:ci-color: <<: *ci-template-flambda -ci-compcert: +library:ci-compcert: <<: *ci-template-flambda -ci-coq_dpdgraph: +library:ci-coquelicot: <<: *ci-template -ci-coquelicot: +library:ci-cross-crypto: <<: *ci-template -ci-cross-crypto: +library:ci-fcsl-pcm: <<: *ci-template -ci-elpi: - <<: *ci-template +library:ci-fiat-crypto: + <<: *ci-template-flambda -ci-equations: - <<: *ci-template +library:ci-fiat-crypto-legacy: + <<: *ci-template-flambda -ci-fcsl-pcm: +library:ci-flocq: <<: *ci-template -ci-fiat-crypto: +library:ci-corn: <<: *ci-template-flambda -ci-fiat-crypto-legacy: +library:ci-geocoq: <<: *ci-template-flambda -ci-fiat-parsers: +library:ci-hott: <<: *ci-template -ci-flocq: +library:ci-iris-lambda-rust: + <<: *ci-template-flambda + +library:ci-math-comp: + <<: *ci-template-flambda + +library:ci-sf: <<: *ci-template -ci-formal-topology: +library:ci-unimath: <<: *ci-template-flambda -ci-geocoq: +library:ci-verdi-raft: <<: *ci-template-flambda -ci-coqhammer: - <<: *ci-template +library:ci-vst: + <<: *ci-template-flambda + +# Plugins are by definition the projects that depend on Coq's ML API -ci-hott: +plugin:ci-aac_tactics: <<: *ci-template -ci-iris-lambda-rust: - <<: *ci-template-flambda +plugin:ci-bignums: + <<: *ci-template -ci-ltac2: +plugin:ci-coq_dpdgraph: <<: *ci-template -ci-math-comp: - <<: *ci-template-flambda +plugin:ci-coqhammer: + <<: *ci-template -ci-mtac2: +plugin:ci-elpi: <<: *ci-template -ci-paramcoq: +plugin:ci-equations: <<: *ci-template -ci-plugin_tutorial: +plugin:ci-fiat-parsers: <<: *ci-template -ci-quickchick: - <<: *ci-template-flambda +plugin:ci-ltac2: + <<: *ci-template -ci-relation-algebra: +plugin:ci-mtac2: <<: *ci-template -ci-sf: +plugin:ci-paramcoq: <<: *ci-template -ci-unimath: - <<: *ci-template-flambda +plugin:plugin-tutorial: + stage: test + dependencies: [] + script: + - ./configure -local -warn-error yes + - make -j "$NJOBS" plugin-tutorial -ci-vst: +plugin:ci-quickchick: <<: *ci-template-flambda + +plugin:ci-relation-algebra: + <<: *ci-template @@ -10,6 +10,7 @@ ## either amend this file and commit it, or contact the coqdev list Abhishek Anand <abhishek.anand.iitg@gmail.com> Abhishek Anand (@brixpro-home) <abhishek.anand.iitg@gmail.com> +Léo Andrès <leo@ndrs.fr> zapashcanon <leo@ndrs.fr> Jim Apple <github.public@jbapple.com> jbapple <github.public@jbapple.com> Bruno Barras <bruno.barras@inria.fr> barras <barras@85f007b7-540e-0410-9357-904b9bb8a0f7> Bruno Barras <bruno.barras@inria.fr> barras-local <barras-local@85f007b7-540e-0410-9357-904b9bb8a0f7> @@ -19,9 +20,11 @@ Yves Bertot <yves.bertot@inria.fr> Yves Bertot <bertot@inria.fr> Yves Bertot <yves.bertot@inria.fr> Yves Bertot <Yves.Bertot@inria.fr> Frédéric Besson <frederic.besson@inria.fr> fbesson <fbesson@85f007b7-540e-0410-9357-904b9bb8a0f7> Siddharth Bhat <siddu.druid@gmail.com> Siddharth <siddu.druid@gmail.com> +Simon Boulier <simon.boulier@ens-rennes.fr> SimonBoulier <simon.boulier@ens-rennes.fr> Pierre Boutillier <pierre.boutillier@ens-lyon.org> pboutill <pboutill@85f007b7-540e-0410-9357-904b9bb8a0f7> Pierre Boutillier <pierre.boutillier@ens-lyon.org> Pierre <pierre.boutillier@ens-lyon.org> Pierre Boutillier <pierre.boutillier@ens-lyon.org> Pierre Boutillier <pierre.boutillier@pps.univ-paris-diderot.fr> +Arthur Charguéraud <arthur@chargueraud.org> charguer <arthur@chargueraud.org> Xavier Clerc <xavier.clerc@inria.fr> xclerc <xclerc@85f007b7-540e-0410-9357-904b9bb8a0f7> Xavier Clerc <xavier.clerc@inria.fr> xclerc <xavier.clerc@inria.fr> Pierre Corbineau <Pierre.Corbineau@NOSPAM@imag.fr> corbinea <corbinea@85f007b7-540e-0410-9357-904b9bb8a0f7> @@ -32,6 +35,7 @@ Maxime Dénès <mail@maximedenes.fr> mdenes <mdenes@85f007b7-540 Maxime Dénès <mail@maximedenes.fr> Maxime Denes <maximedenes@gillespie.inria.fr> Olivier Desmettre <desmettr@gforge> desmettr <desmettr@85f007b7-540e-0410-9357-904b9bb8a0f7> Damien Doligez <doligez@gforge> doligez <doligez@85f007b7-540e-0410-9357-904b9bb8a0f7> +İsmail Dönmez <ismail-s@users.noreply.github.com> Ismail <ismail-s@users.noreply.github.com> Andres Erbsen <andreser@mit.edu> Andres Erbsen <andres@kevix.co> Jim Fehrle <jfehrle@sbcglobal.net> Jim <jfehrle@sbcglobal.net> Jean-Christophe Filliâtre <Jean-Christophe.Filliatre@lri.fr> filliatr <filliatr@85f007b7-540e-0410-9357-904b9bb8a0f7> @@ -63,11 +67,14 @@ Florent Kirchner <fkirchne@gforge> kirchner <kirchner@85f007b7-5 Johannes Kloos <jkloos@mpi-sws.org> jkloos <jkloos@mpi-sws.org> Matej Košík <matej.kosik@inria.fr> Matej Kosik <m4tej.kosik@gmail.com> Matej Košík <matej.kosik@inria.fr> Matej Kosik <matej.kosik@inria.fr> +Ambroise Lafont <chaster_killer@hotmail.fr> amblaf <you@example.com> +Ambroise Lafont <chaster_killer@hotmail.fr> Ambroise <chaster_killer@hotmail.fr> Vincent Laporte <Vincent.Laporte@fondation-inria.fr> Vincent Laporte <Vincent.Laporte@gmail.com> Marc Lasson <marc.lasson@gmail.com> mlasson <marc.lasson@gmail.com> William Lawvere <mundungus.corleone@gmail.com> william-lawvere <mundungus.corleone@gmail.com> Pierre Letouzey <pierre.letouzey@inria.fr> letouzey <letouzey@85f007b7-540e-0410-9357-904b9bb8a0f7> Pierre Letouzey <pierre.letouzey@inria.fr> letouzey <pierre.letouzey@inria.fr> +Xia Li-yao <lysxia@gmail.com> Lysxia <lysxia@gmail.com> Assia Mahboubi <assia.mahboubi@inria.fr> amahboub <amahboub@85f007b7-540e-0410-9357-904b9bb8a0f7> Evgeny Makarov <emakarov@gforge> emakarov <emakarov@85f007b7-540e-0410-9357-904b9bb8a0f7> Gregory Malecha <gmalecha@eecs.harvard.edu> Gregory Malecha <gmalecha@cs.harvard.edu> @@ -88,6 +95,7 @@ Russell O'Connor <roconnor@blockstream.io> roconnor-blockstream <roconno Christine Paulin <cpaulin@gforge> cpaulin <cpaulin@85f007b7-540e-0410-9357-904b9bb8a0f7> Christine Paulin <cpaulin@gforge> mohring <mohring@85f007b7-540e-0410-9357-904b9bb8a0f7> Pierre-Marie Pédrot <pierre-marie.pedrot@inria.fr> ppedrot <ppedrot@85f007b7-540e-0410-9357-904b9bb8a0f7> +Frederic Peschanski <frederic.peschanski@lip6.fr> fredokun <frederic.peschanski@lip6.fr> Clément Pit-Claudel <clement.pitclaudel@live.com> Clément Pit--Claudel <clement.pitclaudel@live.com> Loïc Pottier <pottier@gforge> pottier <pottier@85f007b7-540e-0410-9357-904b9bb8a0f7> Matthias Puech <puech@gforge> puech <puech@85f007b7-540e-0410-9357-904b9bb8a0f7> @@ -98,6 +106,7 @@ Daniel de Rauglaudre <daniel.de_rauglaudre@inria.fr> Daniel De Rauglaudre <ddr@g Yann Régis-Gianas <yrg@pps.univ-paris-diderot.fr> regisgia <regisgia@85f007b7-540e-0410-9357-904b9bb8a0f7> Yann Régis-Gianas <yrg@pps.univ-paris-diderot.fr> Regis-Gianas <yrg@pps.univ-paris-diderot.fr> Clément Renard <clrenard@gforge> clrenard <clrenard@85f007b7-540e-0410-9357-904b9bb8a0f7> +Matthew Ryan <mr_1993@hotmail.co.uk> mrmr1993 <mr_1993@hotmail.co.uk> Claudio Sacerdoti Coen <sacerdot@gforge> sacerdot <sacerdot@85f007b7-540e-0410-9357-904b9bb8a0f7> Kazuhiko Sakaguchi <pi8027@gmail.com> Kazuhiko Sakaguchi <sakaguchi@coins.tsukuba.ac.jp> Vincent Siles <vsiles@gforge> vsiles <vsiles@85f007b7-540e-0410-9357-904b9bb8a0f7> @@ -108,6 +117,7 @@ Matthieu Sozeau <mattam@mattam.org> Matthieu Sozeau <matthieu.soz Matthieu Sozeau <mattam@mattam.org> Matthieu Sozeau <mattam@eduroam-prg-sg-1-46-137.net.univ-paris-diderot.fr> Arnaud Spiwack <arnaud@spiwack.net> aspiwack <aspiwack@85f007b7-540e-0410-9357-904b9bb8a0f7> Paul Steckler <steck@stecksoft.com> Paul Steckler <psteck@mit.edu> +Frank Steffahn <fdsteffahn@gmail.com> staffehn <fdsteffahn@gmail.com> Enrico Tassi <Enrico.Tassi@inria.fr> gareuselesinge <gareuselesinge@85f007b7-540e-0410-9357-904b9bb8a0f7> Enrico Tassi <Enrico.Tassi@inria.fr> Enrico Tassi <enrico.tassi@inria.fr> Enrico Tassi <Enrico.Tassi@inria.fr> Enrico Tassi <gares@fettunta.org> @@ -123,5 +133,8 @@ Théo Zimmermann <theo.zimmermann@univ-paris-diderot.fr> Théo Zimmermann <theo. # Anonymous accounts anonymous < > coq <coq@85f007b7-540e-0410-9357-904b9bb8a0f7> -anonymous < > (no author) <(no author)@85f007b7-540e-0410-9357-904b9bb8a0f7> -anonymous < > serpyc <serpyc@85f007b7-540e-0410-9357-904b9bb8a0f7> + +# Bot accounts + +cvs2svn < > (no author) <(no author)@85f007b7-540e-0410-9357-904b9bb8a0f7> +serpyc-bot < > serpyc <serpyc@85f007b7-540e-0410-9357-904b9bb8a0f7> diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index 02b94f4a8e..0000000000 --- a/.travis.yml +++ /dev/null @@ -1,127 +0,0 @@ -dist: trusty - -# Travis builds are slower using sudo: false (the container-based -# infrastructure) as of March 2017; see -# https://github.com/coq/coq/pull/467 for some discussion. -sudo: required - -# Until Ocaml becomes a language, we set a known one. -language: c - -cache: - directories: - - $HOME/.opam - -before_cache: - - rm -rf ~/.opam/log/ - -env: - global: - - NJOBS=2 - - COMPILER="4.07.0" - - DUNE_VER=".1.2.1" - - FINDLIB_VER=".1.8.0" - - LABLGTK="lablgtk.2.18.6 conf-gtksourceview.2" - - NATIVE_COMP="yes" - - COQ_DEST="-local" - - MAIN_TARGET="world" - -matrix: - include: - - env: - - TEST_TARGET="lint" - install: [] - before_script: [] - addons: - apt: - sources: [] - packages: [] - script: - - dev/lint-repository.sh - - - os: osx - env: - - TEST_TARGET="test-suite" - - NATIVE_COMP="no" - - COQ_DEST="-local" - - EXTRA_OPAM="ounit" - before_install: - - brew update - - brew unlink python - - brew install gnu-time - # only way to continue using OPAM 1.2 - - brew install https://raw.githubusercontent.com/Homebrew/homebrew-core/d156edeeed7291f4bc1e08620b331bbd05d52b78/Formula/opam.rb - - opam init -j "$NJOBS" --compiler="$COMPILER" -n -y - - opam switch "$COMPILER" && opam update - - eval $(opam config env) - - opam config list - - opam install -j "$NJOBS" -y num ocamlfind${FINDLIB_VER} dune${DUNE_VER} ${EXTRA_OPAM} - - opam list - - - if: NOT (type = pull_request) - os: osx - osx_image: xcode7.3 - env: - - TEST_TARGET="" - - NATIVE_COMP="no" - - COQ_DEST="-prefix $PWD/_install_ci" - - EXTRA_CONF="-coqide opt -warn-error yes" - - EXTRA_OPAM="$LABLGTK" - before_install: - - brew update - - brew unlink python - - brew install gnu-time gtk+ expat gtksourceview gdk-pixbuf - # only way to continue using OPAM 1.2 - - brew install https://raw.githubusercontent.com/Homebrew/homebrew-core/d156edeeed7291f4bc1e08620b331bbd05d52b78/Formula/opam.rb - - brew unlink python@2 - - brew install python3 - - pip3 install macpack - - opam init -j "$NJOBS" --compiler="$COMPILER" -n -y - - opam switch "$COMPILER" && opam update - - eval $(opam config env) - - opam config list - - opam install -j "$NJOBS" -y num ocamlfind${FINDLIB_VER} dune${DUNE_VER} ${EXTRA_OPAM} - - opam list - before_deploy: - - dev/build/osx/make-macos-dmg.sh - deploy: - - provider: bintray - user: maximedenes - file: .bintray.json - key: - secure: "gUvXWwWR0gicDqsKOnBfe45taToSFied6gN8tCa5IOtl6E6gFoHoPZ83ZWXQsZP50oMDFS5eji0VQAFGEbOsGrTZaD9Y9Jnu34NND78SWL1tsJ6nHO3aCAoMpB0N3+oRuF6S+9HStU6KXWqgj+GeU4vZ4TOlG01RGctJa6U3vII=" - skip_cleanup: true - on: - all_branches: true - -before_install: -- if [ "$TRAVIS_PULL_REQUEST" != "false" ]; then echo "Tested commit (followed by parent commits):"; git log -1; for commit in `git log -1 --format="%P"`; do echo; git log -1 $commit; done; fi - -script: - -- set -e -- echo 'Testing make clean...' && echo -en 'travis_fold:start:coq.clean\\r' -- make clean # ensure that `make clean` works on a fresh clone -- echo -en 'travis_fold:end:coq.clean\\r' - -- echo 'Configuring Coq...' && echo -en 'travis_fold:start:coq.config\\r' -- ./configure $COQ_DEST -warn-error yes -native-compiler $NATIVE_COMP $EXTRA_CONF -- echo -en 'travis_fold:end:coq.config\\r' - -- echo 'Building Coq...' && echo -en 'travis_fold:start:coq.build\\r' -- make -j $NJOBS $MAIN_TARGET -- echo -en 'travis_fold:end:coq.build\\r' - -- echo 'Running tests...' && echo -en 'travis_fold:start:coq.test\\r' -- if [ -n "$TEST_TARGET" ]; then $TW make -j $NJOBS $TEST_TARGET; fi -- echo -en 'travis_fold:end:coq.test\\r' -- set +e - -# Testing Gitter webhook -notifications: - webhooks: - urls: - - https://webhooks.gitter.im/e/3cdabdec318214c7cd63 - on_success: change # options: [always|never|change] default: always - on_failure: always # options: [always|never|change] default: always - on_start: never # options: [always|never|change] default: always diff --git a/CHANGES.md b/CHANGES.md index d64b5accd7..9d912a63b1 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -22,6 +22,11 @@ Coqide Coqtop +- the use of `coqtop` as a compiler has been deprecated, in favor of + `coqc`. Consequently option `-compile` will stop to be accepted in + the next release. `coqtop` is now reserved to interactive + use. (@ejgallego #9095) + - new option -topfile filename, which will set the current module name (à la -top) based on the filename passed, taking into account the proper -R/-Q options. For example, given -R Foo foolib using @@ -49,6 +54,9 @@ Notations - New command `String Notation` to register string syntax for custom inductive types. +- Various bugs have been fixed (e.g. PR #9214 on removing spurious + parentheses on abbreviations shortening a strict prefix of an application). + Plugins - The quote plugin (https://coq.inria.fr/distrib/V8.8.1/refman/proof-engine/detailed-tactic-examples.html#quote) @@ -75,6 +83,14 @@ Tactics foo : database`). When the database name is omitted, the hint is added to the core database (as previously), but a deprecation warning is emitted. +- There are now tactics in `PreOmega.v` called + `Z.div_mod_to_equations`, `Z.quot_rem_to_equations`, and + `Z.to_euclidean_division_equations` (which combines the `div_mod` + and `quot_rem` variants) which allow `lia`, `nia`, `romega`, etc to + support `Z.div` and `Z.modulo` (`Z.quot` and `Z.rem`, respectively), + by posing the specifying equation for `Z.div` and `Z.modulo` before + replacing them with atoms. + Vernacular commands - `Combined Scheme` can now work when inductive schemes are generated in sort @@ -93,6 +109,19 @@ Vernacular commands - The naming scheme for anonymous binders in a `Theorem` has changed to avoid conflicts with explicitly named binders. +- Computation of implicit arguments now properly handles local definitions in the + binders for an `Instance`. + +- `Declare Instance` now requires an instance name. + +- Option `Refine Instance Mode` has been turned off by default, meaning that + `Instance` no longer opens a proof when a body is provided. + +- `Instance`, when no body is provided, now always opens a proof. This is a + breaking change, as instance of `Instance foo : C.` where `C` is a trivial + class will have to be changed into `Instance foo : C := {}.` or + `Instance foo : C. Proof. Qed.`. + Tools - The `-native-compiler` flag of `coqc` and `coqtop` now takes an argument which can have three values: @@ -135,6 +164,17 @@ Universes for the "Private Polymorphic Universes" option (and Unset it to get the previous behaviour). +Inductives + +- An option and attributes to control the automatic decision to + declare an inductive type as template polymorphic were added. + Warning "auto-template" will trigger when an inductive is + automatically declared template polymorphic without the attribute. + +Funind + +- Inductive types declared by Funind will never be template polymorphic. + Misc - Option "Typeclasses Axioms Are Instances" is deprecated. Use Declare Instance for axioms which should be instances. @@ -142,12 +182,24 @@ Misc SSReflect - New intro patterns: - - temporary introduction: => + - - block introduction: => [^ prefix ] [^~ suffix ] - - fast introduction: => >H - - tactics as views: => /ltac:mytac + - temporary introduction: `=> +` + - block introduction: `=> [^ prefix ] [^~ suffix ]` + - fast introduction: `=> >` + - tactics as views: `=> /ltac:mytac` + - replace hypothesis: `=> {}H` See the reference manual for the actual documentation. +- Clear discipline made consistent across the entire proof language. + Whenever a clear switch `{x..}` comes immediately before an existing proof + context entry (used as a view, as a rewrite rule or as name for a new + context entry) then such entry is cleared too. + + E.g. The following sentences are elaborated as follows (when H is an existing + proof context entry): + - `=> {x..} H` -> `=> {x..H} H` + - `=> {x..} /H` -> `=> /v {x..H}` + - `rewrite {x..} H` -> `rewrite E {x..H}` + Changes from 8.8.2 to 8.9+beta1 =============================== diff --git a/CODE_OF_CONDUCT.md b/CODE_OF_CONDUCT.md index 8eee2009c9..0720cf6210 100644 --- a/CODE_OF_CONDUCT.md +++ b/CODE_OF_CONDUCT.md @@ -78,7 +78,8 @@ affect a person's ability to participate within them. If you believe someone is violating the code of conduct, we ask that you report it by emailing the Coq Code of Conduct enforcement team at -<coq-conduct@inria.fr>. Confidentiality with regard to the reporter of an +<coq-conduct@inria.fr> or, at your discretion, any member of the team. +Confidentiality with regard to the reporter of an incident will be maintained while dealing with it. In particular, you should seek support from the team instead of dealing by @@ -96,6 +97,11 @@ behavior is wrong). We consider short bans to form part of the pedagogical approach, especially when they come with explanatory comments, as this can give some time to the offender to calm down and think about their actions. +The members of the team are currently: + +- Matthieu Sozeau +- Théo Zimmermann + ## Questions? ## If you have questions, feel free to write to <coq-conduct@inria.fr>. diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index de7fb9183c..bb0e388cdd 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -55,7 +55,7 @@ please add an entry to [`dev/doc/critical-bugs`](/dev/doc/critical-bugs). Don't be alarmed if the pull request process takes some time. It can take a few days to get feedback, approval on the final changes, and then a merge. Coq doesn't release new versions very frequently so it can take a few months for your change to land in a released version. That said, you can start using the latest Coq `master` branch to take advantage of all the new features, improvements, and fixes. -Whitespace discipline (do not indent using tabs, no trailing spaces, text files end with newlines) is checked by Travis (using `git diff --check`). We ship a [`dev/tools/pre-commit`](/dev/tools/pre-commit) git hook which fixes these errors at commit time. `configure` automatically sets you up to use it, unless you already have a hook at `.git/hooks/pre-commit`. +Whitespace discipline (do not indent using tabs, no trailing spaces, text files end with newlines) is checked by the `lint` job on GitLab CI (using `git diff --check`). We ship a [`dev/tools/pre-commit`](/dev/tools/pre-commit) git hook which fixes these errors at commit time. `configure` automatically sets you up to use it, unless you already have a hook at `.git/hooks/pre-commit`. Here are a few tags Coq developers may add to your PR and what they mean. In general feedback and requests for you as the pull request author will be in the comments and tags are only used to organize pull requests. @@ -113,9 +113,8 @@ INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS). "./configure -help". The main options accepted are: -prefix <dir> - Binaries, library, man pages and Emacs mode will be respectively - installed in <dir>/bin, <dir>/lib/coq, <dir>/man and - <dir>/lib/emacs/site-lisp + Binaries, library, and man pages will be respectively + installed in <dir>/bin, <dir>/lib/coq, and <dir>/man -bindir <dir> (default: /usr/local/bin) Directory where the binaries will be installed @@ -126,9 +125,6 @@ INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS). -mandir <dir> (default: /usr/local/share/man) Directory where the Coq manual pages will be installed --emacslib <dir> (default: /usr/local/lib/emacs/site-lisp) - Directory where the Coq Emacs mode will be installed - -arch <value> (default is the result of the command "arch") An arbitrary architecture name for your machine (useful when compiling Coq on two different architectures for which the @@ -175,9 +171,9 @@ INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS). it is recommended to compile in parallel, via make -jN where N is your number of cores. -5- You can now install the Coq system. Executables, libraries, manual pages - and emacs mode are copied in some standard places of your system, defined at - configuration time (step 3). Just do +5- You can now install the Coq system. Executables, libraries, and + manual pages are copied in some standard places of your system, + defined at configuration time (step 3). Just do umask 022 make install @@ -61,7 +61,8 @@ FIND_SKIP_DIRS:='(' \ -name 'user-contrib' -o \ -name 'test-suite' -o \ -name '.opamcache' -o \ - -name '.coq-native' \ + -name '.coq-native' -o \ + -name 'plugin_tutorial' \ ')' -prune -o define find @@ -81,7 +82,8 @@ export MLPACKFILES := $(call find, '*.mlpack') export MLGFILES := $(call find, '*.mlg') export CFILES := $(call findindir, 'kernel/byterun', '*.c') -MERLININFILES := $(call find, '.merlin.in') +# NB our find wrapper ignores the test suite +MERLININFILES := $(call find, '.merlin.in') test-suite/unit-tests/.merlin.in export MERLINFILES := $(MERLININFILES:.in=) # NB: The lists of currently existing .ml and .mli files will change @@ -191,7 +193,7 @@ META.coq: META.coq.in # Cleaning ########################################################################### -.PHONY: clean cleankeepvo objclean cruftclean indepclean docclean archclean optclean clean-ide mlgclean depclean cleanconfig distclean voclean timingclean alienclean +.PHONY: clean cleankeepvo objclean cruftclean indepclean docclean archclean optclean plugin-tutorialclean clean-ide mlgclean depclean cleanconfig distclean voclean timingclean alienclean clean: objclean cruftclean depclean docclean camldevfilesclean gramlibclean @@ -237,7 +239,7 @@ docclean: rm -f doc/coq.tex rm -rf doc/sphinx/_build -archclean: clean-ide optclean voclean +archclean: clean-ide optclean voclean plugin-tutorialclean rm -rf _build rm -f $(ALLSTDLIB).* @@ -268,7 +270,7 @@ cleanconfig: distclean: clean cleanconfig cacheclean timingclean voclean: - find theories plugins test-suite \( -name '*.vo' -o -name '*.glob' -o -name "*.cmxs" \ + find theories plugins test-suite \( -name '*.vo' -o -name '*.vio' -o -name '*.glob' -o -name "*.cmxs" \ -o -name "*.native" -o -name "*.cmx" -o -name "*.cmi" -o -name "*.o" \) -exec rm -f {} + find theories plugins test-suite -name .coq-native -empty -exec rm -rf {} + @@ -278,6 +280,9 @@ timingclean: -o -name "time-of-build-before.log" -o -name "time-of-build-after.log" \ -o -name "time-of-build-pretty.log" -o -name "time-of-build-both.log" \) -exec rm -f {} + +plugin-tutorialclean: + +$(MAKE) -C $(PLUGINTUTO) clean + # Ensure that every compiled file around has a known source file. # This should help preventing weird compilation failures caused by leftover # compiled files after deleting or moving some source files. diff --git a/Makefile.build b/Makefile.build index 34d7ce42f7..4f42768227 100644 --- a/Makefile.build +++ b/Makefile.build @@ -57,6 +57,9 @@ TIME_OF_PRETTY_BUILD_EXTRA_FILES ?= - # also output to the command line BEFORE ?= AFTER ?= +# Number of parallel jobs for -schedule-vio2vo +NJOBS ?= 2 + ########################################################################### # Default starting rule ########################################################################### @@ -195,7 +198,7 @@ TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD)) # TIME="%C (%U user, %S sys, %e total, %M maxres)" COQOPTS=$(NATIVECOMPUTE) $(COQWARNERROR) $(COQUSERFLAGS) -BOOTCOQC=$(TIMER) $(COQTOPBEST) -boot $(COQOPTS) -compile +BOOTCOQC=$(TIMER) $(COQTOPBEST) -boot $(COQOPTS) -w -deprecate-compile-arg -compile LOCALINCLUDES=$(addprefix -I ,$(SRCDIRS)) MLINCLUDES=$(LOCALINCLUDES) @@ -543,7 +546,7 @@ $(CSDPCERTBYTE): $(CSDPCERTCMO) VALIDOPTS=$(if $(VERBOSE),,-silent) -o -m -validate: $(CHICKEN) | $(ALLVO) +validate: $(CHICKEN) | $(ALLVO:.$(VO)=.vo) $(SHOW)'COQCHK <theories & plugins>' $(HIDE)$(CHICKEN) -boot $(VALIDOPTS) $(ALLMODS) @@ -779,13 +782,19 @@ $(PLUGMLLIBDFILE).d: $(D_DEPEND_BEFORE_SRC) $(filter plugins/%, $(MLLIBFILES) $( # since they are all mentioned in at least one Declare ML Module in some .v coqlib: theories plugins +ifdef QUICK + $(SHOW)'COQC -schedule-vio2vo $(NJOBS) theories/**.vio plugins/**.vio' + $(HIDE)$(BOOTCOQC:-compile=-schedule-vio2vo) $(NJOBS) \ + $(THEORIESVO) $(PLUGINSVO) +endif + coqlib.timing.diff: theories.timing.diff plugins.timing.diff theories: $(THEORIESVO) plugins: $(PLUGINSVO) -theories.timing.diff: $(THEORIESVO:.vo=.v.timing.diff) -plugins.timing.diff: $(PLUGINSVO:.vo=.v.timing.diff) +theories.timing.diff: $(THEORIESVO:.$(VO)=.v.timing.diff) +plugins.timing.diff: $(PLUGINSVO:.$(VO)=.v.timing.diff) .PHONY: coqlib theories plugins coqlib.timing.diff theories.timing.diff plugins.timing.diff @@ -802,6 +811,10 @@ theories/Init/%.vo theories/Init/%.glob: theories/Init/%.v $(VO_TOOLS_DEP) $(HIDE)rm -f theories/Init/$*.glob $(HIDE)$(BOOTCOQC) $< -noinit -R theories Coq $(TIMING_ARG) $(TIMING_EXTRA) +theories/Init/%.vio: theories/Init/%.v $(VO_TOOLS_DEP) + $(SHOW)'COQC -quick -noinit $<' + $(HIDE)$(BOOTCOQC) $< -noinit -R theories Coq -quick -noglob + # The general rule for building .vo files : %.vo %.glob: %.v theories/Init/Prelude.vo $(VO_TOOLS_DEP) @@ -814,6 +827,10 @@ ifdef VALIDATE || ( RV=$$?; rm -f "$@"; exit $${RV} ) endif +%.vio: %.v theories/Init/Prelude.vio $(VO_TOOLS_DEP) + $(SHOW)'COQC -quick $<' + $(HIDE)$(BOOTCOQC) $< -quick -noglob + %.v.timing.diff: %.v.before-timing %.v.after-timing $(SHOW)PYTHON TIMING-DIFF $< $(HIDE)$(MAKE) --no-print-directory print-pretty-single-time-diff BEFORE=$*.v.before-timing AFTER=$*.v.after-timing TIME_OF_PRETTY_BUILD_FILE="$@" diff --git a/Makefile.ci b/Makefile.ci index 2df6a792b6..b8bff98f5f 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -27,7 +27,6 @@ CI_TARGETS= \ ci-fiat-crypto-legacy \ ci-fiat-parsers \ ci-flocq \ - ci-formal-topology \ ci-geocoq \ ci-coqhammer \ ci-hott \ @@ -37,13 +36,13 @@ CI_TARGETS= \ ci-math-comp \ ci-mtac2 \ ci-paramcoq \ - ci-plugin_tutorial \ ci-quickchick \ ci-relation-algebra \ ci-sf \ ci-simple-io \ ci-tlc \ ci-unimath \ + ci-verdi-raft \ ci-vst .PHONY: ci-all $(CI_TARGETS) @@ -63,8 +62,6 @@ ci-corn: ci-math-classes ci-simple-io: ci-ext-lib ci-quickchick: ci-ext-lib ci-simple-io -ci-formal-topology: ci-corn - # Generic rule, we use make to ease CI integration $(CI_TARGETS): ci-%: +./dev/ci/ci-wrapper.sh $* diff --git a/Makefile.common b/Makefile.common index 9f7ed9d46e..2dced04967 100644 --- a/Makefile.common +++ b/Makefile.common @@ -168,6 +168,8 @@ LINKCMX:=$(CORECMA:.cma=.cmxa) $(STATICPLUGINS:.cmo=.cmx) ALLSTDLIB := test-suite/misc/universes/all_stdlib +PLUGINTUTO := doc/plugin_tutorial + # For emacs: # Local Variables: # mode: makefile diff --git a/Makefile.dev b/Makefile.dev index 9659f602d7..13b85dfad4 100644 --- a/Makefile.dev +++ b/Makefile.dev @@ -63,7 +63,7 @@ revision: coqlight: theories-light tools coqbinaries -states: theories/Init/Prelude.vo +states: theories/Init/Prelude.$(VO) miniopt: $(COQTOPEXE) pluginsopt minibyte: $(COQTOPBYTE) pluginsbyte diff --git a/Makefile.doc b/Makefile.doc index 9e6ec4955a..7ac710b8c9 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -89,6 +89,10 @@ stdlib: \ full-stdlib: \ doc/stdlib/html/index.html doc/stdlib/FullLibrary.ps doc/stdlib/FullLibrary.pdf +.PHONY: plugin-tutorial +plugin-tutorial: states tools + +$(MAKE) COQBIN=$(PWD)/bin/ -C $(PLUGINTUTO) + ###################################################################### ### Implicit rules ###################################################################### @@ -137,7 +141,7 @@ else doc/stdlib/Library.coqdoc.tex: | $(COQDOC) $(THEORIESLIGHTVO) endif $(COQDOC) -q -boot --gallina --body-only --latex --stdout \ - -R theories Coq $(THEORIESLIGHTVO:.vo=.v) >> $@ + -R theories Coq $(THEORIESLIGHTVO:.$(VO)=.v) >> $@ doc/stdlib/Library.dvi: $(DOCCOMMON) doc/stdlib/Library.coqdoc.tex doc/stdlib/Library.tex (cd doc/stdlib;\ diff --git a/Makefile.dune b/Makefile.dune index 22e3271260..ee3e2d6cb7 100644 --- a/Makefile.dune +++ b/Makefile.dune @@ -2,6 +2,7 @@ # Dune Makefile for Coq .PHONY: help voboot states world watch check # Main developer targets +.PHONY: coq coqide coqide-server # Package targets .PHONY: quickbyte quickopt # Partial / quick developer targets .PHONY: test-suite refman-html apidoc release # Accesory targets .PHONY: ocheck trunk ireport clean # Maintenance targets @@ -19,6 +20,10 @@ help: @echo " - watch: build all binaries and libraries [continuous build]" @echo " - check: build all ML files as fast as possible" @echo "" + @echo " - coq: build package Coq [toplevel compilers, tools, stdlib, no GTK]" + @echo " - coqide-server: build package coqide-server [XML protocol language server]" + @echo " - coqide: build package CoqIDE [gtk application]" + @echo "" @echo " - quickbyte: build main ML files [coqtop + plugins + ide + printers] using the bytecode compiler" @echo " - quickopt: build main ML files [coqtop + plugins + ide + printers] using the optimizing compiler" @echo "" @@ -43,6 +48,15 @@ states: voboot world: voboot dune build $(DUNEOPT) @install +coq: voboot + dune build $(DUNEOPT) coq.install + +coqide: voboot + dune build $(DUNEOPT) coqide.install + +coqide-server: voboot + dune build $(DUNEOPT) coqide-server.install + watch: voboot dune build $(DUNEOPT) @install -w @@ -90,11 +104,11 @@ ireport: clean: dune clean -# Other common dev targets +# Other common dev targets: # # dune build coq.install -# dune build ide/coqide.install - +# dune build coqide.install +# # Packaging / OPAM targets: # # dune -p coq @install diff --git a/Makefile.ide b/Makefile.ide index cae77ee348..23ce83d263 100644 --- a/Makefile.ide +++ b/Makefile.ide @@ -70,7 +70,7 @@ SOURCEVIEWSHARE=$(shell pkg-config --variable=prefix gtksourceview-2.0)/share .PHONY: ide-toploop ide-byteloop ide-optloop # target to build CoqIde (native version) and the stuff needed to lauch it -coqide: coqide-files coqide-opt theories/Init/Prelude.vo +coqide: coqide-files coqide-opt theories/Init/Prelude.$(VO) # target to build CoqIde (in native and byte versions), and no more # NB: this target is used in the opam package coq-coqide diff --git a/Makefile.vofiles b/Makefile.vofiles index d0ae317335..d5217ef4b7 100644 --- a/Makefile.vofiles +++ b/Makefile.vofiles @@ -2,14 +2,20 @@ # This file calls [find] and as such is not suitable for inclusion in # the test suite Makefile, unlike Makefile.common. +ifdef QUICK +VO=vio +else +VO=vo +endif + ########################################################################### # vo files ########################################################################### -THEORIESVO := $(patsubst %.v,%.vo,$(shell find theories -type f -name "*.v")) -PLUGINSVO := $(patsubst %.v,%.vo,$(shell find plugins -type f -name "*.v")) +THEORIESVO := $(patsubst %.v,%.$(VO),$(shell find theories -type f -name "*.v")) +PLUGINSVO := $(patsubst %.v,%.$(VO),$(shell find plugins -type f -name "*.v")) ALLVO := $(THEORIESVO) $(PLUGINSVO) -VFILES := $(ALLVO:.vo=.v) +VFILES := $(ALLVO:.$(VO)=.v) ## More specific targets @@ -20,22 +26,27 @@ THEORIESLIGHTVO:= \ # remove .vo, replace theories and plugins by Coq, and replace slashes by dots vo_to_mod = $(subst /,.,$(patsubst theories/%,Coq.%,$(patsubst plugins/%,Coq.%,$(1:.vo=)))) -ALLMODS:=$(call vo_to_mod,$(ALLVO)) +ALLMODS:=$(call vo_to_mod,$(ALLVO:.$(VO)=.vo)) # Converting a stdlib filename into native compiler filenames # Used for install targets -vo_to_cm = $(foreach vo,$(1),$(dir $(vo)).coq-native/$(subst /,_,$(patsubst theories/%,NCoq_%,$(patsubst plugins/%,NCoq_%,$(vo:.vo=.cm*))))) +vo_to_cm = $(foreach vo,$(1),$(dir $(vo)).coq-native/$(subst /,_,$(patsubst theories/%,NCoq_%,$(patsubst plugins/%,NCoq_%,$(vo:.$(VO)=.cm*))))) -vo_to_obj = $(foreach vo,$(1),$(dir $(vo)).coq-native/$(subst /,_,$(patsubst theories/%,NCoq_%,$(patsubst plugins/%,NCoq_%,$(vo:.vo=.o))))) +vo_to_obj = $(foreach vo,$(1),$(dir $(vo)).coq-native/$(subst /,_,$(patsubst theories/%,NCoq_%,$(patsubst plugins/%,NCoq_%,$(vo:.$(VO)=.o))))) + +ifdef QUICK +GLOBFILES:= +else +GLOBFILES:=$(ALLVO:.$(VO)=.glob) +endif -GLOBFILES:=$(ALLVO:.vo=.glob) ifdef NATIVECOMPUTE NATIVEFILES := $(call vo_to_cm,$(ALLVO)) $(call vo_to_obj,$(ALLVO)) else NATIVEFILES := endif -LIBFILES:=$(ALLVO) $(NATIVEFILES) $(VFILES) $(GLOBFILES) +LIBFILES:=$(ALLVO:.$(VO)=.vo) $(NATIVEFILES) $(VFILES) $(GLOBFILES) # For emacs: # Local Variables: @@ -1,19 +1,64 @@ # Coq -[](https://gitlab.com/coq/coq/commits/master) -[](https://travis-ci.org/coq/coq/builds) -[](https://ci.appveyor.com/project/coq/coq/branch/master) -[](https://gitter.im/coq/coq) -[](https://doi.org/10.5281/zenodo.1003420) +[![GitLab][gitlab-badge]][gitlab-link] +[![Azure Pipelines][azure-badge]][azure-link] +[![Appveyor][appveyor-badge]][appveyor-link] +[![Gitter][gitter-badge]][gitter-link] +[![DOI][doi-badge]][doi-link] + +[gitlab-badge]: https://gitlab.com/coq/coq/badges/master/pipeline.svg +[gitlab-link]: https://gitlab.com/coq/coq/commits/master + +[azure-badge]: https://dev.azure.com/coq/coq/_apis/build/status/coq.coq?branchName=master +[azure-link]: https://dev.azure.com/coq/coq/_build/latest?definitionId=1?branchName=master + +[appveyor-badge]: https://ci.appveyor.com/api/projects/status/eln43k05pa2vm908/branch/master?svg=true +[appveyor-link]: https://ci.appveyor.com/project/coq/coq/branch/master + +[gitter-badge]: https://badges.gitter.im/coq/coq.svg +[gitter-link]: https://gitter.im/coq/coq + +[doi-badge]: https://zenodo.org/badge/DOI/10.5281/zenodo.1003420.svg +[doi-link]: https://doi.org/10.5281/zenodo.1003420 Coq is a formal proof management system. It provides a formal language to write mathematical definitions, executable algorithms and theorems together with an environment for semi-interactive development of machine-checked proofs. ## Installation -Download the pre-built packages of the [latest release](https://github.com/coq/coq/releases/latest) for Windows and MacOS; -read the [help page](https://coq.inria.fr/opam/www/using.html) on how to install Coq with OPAM; -or refer to the [`INSTALL` file](INSTALL) for the procedure to install from source. + +[![latest packaged version(s)][repology-badge]][repology-link] + +[![Arch package][arch-badge]][arch-link] +[![Chocolatey package][chocolatey-badge]][chocolatey-link] +[![Homebrew package][homebrew-badge]][homebrew-link] +[![MacPorts package][macports-badge]][macports-link] +[![nixpkgs unstable package][nixpkgs-badge]][nixpkgs-link] + +[repology-badge]: https://repology.org/badge/latest-versions/coq.svg +[repology-link]: https://repology.org/metapackage/coq/versions + +[arch-badge]: https://repology.org/badge/version-for-repo/arch/coq.svg +[arch-link]: https://www.archlinux.org/packages/community/x86_64/coq/ + +[chocolatey-badge]: https://repology.org/badge/version-for-repo/chocolatey/coq.svg +[chocolatey-link]: https://chocolatey.org/packages/Coq + +[homebrew-badge]: https://repology.org/badge/version-for-repo/homebrew/coq.svg +[homebrew-link]: https://formulae.brew.sh/formula/coq + +[macports-badge]: https://repology.org/badge/version-for-repo/macports/coq.svg +[macports-link]: https://www.macports.org/ports.php?by=name&substr=coq + +[nixpkgs-badge]: https://repology.org/badge/version-for-repo/nix_unstable/coq.svg +[nixpkgs-link]: https://nixos.org/nixos/packages.html#coq + +Download the pre-built packages of the [latest release][] for Windows and macOS; +read the [help page][opam-using] on how to install Coq with OPAM; +or refer to the [`INSTALL`](INSTALL) file for the procedure to install from source. + +[latest release]: https://github.com/coq/coq/releases/latest +[opam-using]: https://coq.inria.fr/opam/www/using.html ## Documentation diff --git a/azure-pipelines.yml b/azure-pipelines.yml index e217601ae2..a8b42cc722 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -1,31 +1,78 @@ -pool: - vmImage: 'vs2017-win2016' - -steps: -- checkout: self - fetchDepth: 10 - -# cygwin package list not checked for minimality -- script: | - powershell -Command "(New-Object Net.WebClient).DownloadFile('http://www.cygwin.com/setup-x86_64.exe', 'setup-x86_64.exe')" - SET CYGROOT=C:\cygwin64 - SET CYGCACHE=%CYGROOT%\var\cache\setup - setup-x86_64.exe -qnNdO -R %CYGROOT% -l %CYGCACHE% -s %CYGMIRROR% -P rsync -P patch -P diffutils -P make -P unzip -P m4 -P findutils -P time -P wget -P curl -P git -P mingw64-x86_64-binutils,mingw64-x86_64-gcc-core,mingw64-x86_64-gcc-g++,mingw64-x86_64-pkg-config,mingw64-x86_64-windows_default_manifest -P mingw64-x86_64-headers,mingw64-x86_64-runtime,mingw64-x86_64-pthreads,mingw64-x86_64-zlib -P python - - SET TARGET_ARCH=x86_64-w64-mingw32 - SET CD_MFMT=%cd:\=/% - SET RESULT_INSTALLDIR_CFMT=%CD_MFMT:C:/=/cygdrive/c/% - C:\cygwin64\bin\bash -l %cd%\dev\build\windows\configure_profile.sh - displayName: 'Install cygwin' - env: - CYGMIRROR: "http://mirror.easyname.at/cygwin" - -- script: C:\cygwin64\bin\bash -l %cd%\dev\ci\azure-opam.sh - displayName: 'Install opam' - -- script: C:\cygwin64\bin\bash -l %cd%\dev\ci\azure-build.sh - displayName: 'Build Coq' - -- script: C:\cygwin64\bin\bash -l %cd%\dev\ci\azure-test.sh - displayName: 'Test Coq' +# NB: image names can be found at +# https://docs.microsoft.com/en-us/azure/devops/pipelines/agents/hosted + +variables: + NJOBS: "2" + +jobs: +- job: Windows + pool: + vmImage: 'vs2017-win2016' + + steps: + - checkout: self + fetchDepth: 10 + + # cygwin package list not checked for minimality + - script: | + powershell -Command "(New-Object Net.WebClient).DownloadFile('http://www.cygwin.com/setup-x86_64.exe', 'setup-x86_64.exe')" + SET CYGROOT=C:\cygwin64 + SET CYGCACHE=%CYGROOT%\var\cache\setup + setup-x86_64.exe -qnNdO -R %CYGROOT% -l %CYGCACHE% -s %CYGMIRROR% -P rsync -P patch -P diffutils -P make -P unzip -P m4 -P findutils -P time -P wget -P curl -P git -P mingw64-x86_64-binutils,mingw64-x86_64-gcc-core,mingw64-x86_64-gcc-g++,mingw64-x86_64-pkg-config,mingw64-x86_64-windows_default_manifest -P mingw64-x86_64-headers,mingw64-x86_64-runtime,mingw64-x86_64-pthreads,mingw64-x86_64-zlib -P python + + SET TARGET_ARCH=x86_64-w64-mingw32 + SET CD_MFMT=%cd:\=/% + SET RESULT_INSTALLDIR_CFMT=%CD_MFMT:C:/=/cygdrive/c/% + C:\cygwin64\bin\bash -l %cd%\dev\build\windows\configure_profile.sh + displayName: 'Install cygwin' + env: + CYGMIRROR: "http://mirror.easyname.at/cygwin" + + - script: C:\cygwin64\bin\bash -l %cd%\dev\ci\azure-opam.sh + displayName: 'Install opam' + + - script: C:\cygwin64\bin\bash -l %cd%\dev\ci\azure-build.sh + displayName: 'Build Coq' + + - script: C:\cygwin64\bin\bash -l %cd%\dev\ci\azure-test.sh + displayName: 'Test Coq' + +- job: macOS + pool: + vmImage: 'macOS-10.13' + + steps: + - checkout: self + fetchDepth: 10 + + - script: | + set -e + brew update + brew unlink python + brew install gnu-time opam + + opam init -a -j "$NJOBS" --compiler=$COMPILER + opam switch set $COMPILER + eval $(opam env) + opam update + opam install -j "$NJOBS" num ocamlfind${FINDLIB_VER} ounit + opam list + displayName: 'Install dependencies' + env: + COMPILER: "4.07.1" + FINDLIB_VER: ".1.8.0" + OPAMYES: "true" + + - script: | + set -e + + eval $(opam env) + ./configure -local -warn-error yes -native-compiler no + make -j "$NJOBS" + displayName: 'Build Coq' + + - script: | + eval $(opam env) + make -j "$NJOBS" test-suite + displayName: 'Run Coq Test Suite' diff --git a/checker/check.ml b/checker/check.ml index 30437e8bd0..b2930d9535 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -329,7 +329,7 @@ let intern_from_file (dir, f) = user_err ~hdr:"intern_from_file" (str "The file "++str f++str " contains unfinished tasks"); if opaque_csts <> None then begin - chk_pp (str " (was a vio file) "); + Flags.if_verbose chk_pp (str " (was a vio file) "); Option.iter (fun (_,_,b) -> if not b then user_err ~hdr:"intern_from_file" (str "The file "++str f++str " is still a .vio")) diff --git a/checker/checker.ml b/checker/checker.ml index 167258f8bb..d97ab5409e 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -297,7 +297,7 @@ let explain_exn = function | UnsatisfiedConstraints _ -> str"UnsatisfiedConstraints" | UndeclaredUniverse _ -> str"UndeclaredUniverse")) - | Indtypes.InductiveError e -> + | InductiveError e -> hov 0 (str "Error related to inductive types") (* let ctx = Check.get_env() in hov 0 diff --git a/clib/cSig.mli b/clib/cSig.mli index fb36cc5b51..859018ca4b 100644 --- a/clib/cSig.mli +++ b/clib/cSig.mli @@ -83,6 +83,7 @@ sig val choose: 'a t -> (key * 'a) val split: key -> 'a t -> 'a t * 'a option * 'a t val find: key -> 'a t -> 'a + val find_opt : key -> 'a t -> 'a option val map: ('a -> 'b) -> 'a t -> 'b t val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t end diff --git a/clib/cThread.ml b/clib/cThread.ml index 0b7955aa28..9e0319e8f8 100644 --- a/clib/cThread.ml +++ b/clib/cThread.ml @@ -97,3 +97,13 @@ let thread_friendly_input_value ic = end with Unix.Unix_error _ | Sys_error _ -> raise End_of_file +(* On the ocaml runtime used in some opam-for-windows version the + * [Thread.sigmask] API raises Invalid_argument "not implemented", + * hence we protect the call and turn the exception into a no-op *) +let protect_sigalrm f x = + begin try ignore(Thread.sigmask Unix.SIG_BLOCK [Sys.sigalrm]) + with Invalid_argument _ -> () end; + f x + +let create f x = + Thread.create (protect_sigalrm f) x diff --git a/clib/cThread.mli b/clib/cThread.mli index acc5a60c09..b090479c4c 100644 --- a/clib/cThread.mli +++ b/clib/cThread.mli @@ -26,3 +26,6 @@ val thread_friendly_really_read : thread_ic -> Bytes.t -> off:int -> len:int -> unit val thread_friendly_really_read_line : thread_ic -> string +(* Wrapper around Thread.create that blocks signals such as Sys.sigalrm (used + * for Timeout *) +val create : ('a -> 'b) -> 'a -> Thread.t diff --git a/clib/hMap.ml b/clib/hMap.ml index 9c80398e4d..5d634b7af0 100644 --- a/clib/hMap.ml +++ b/clib/hMap.ml @@ -353,6 +353,12 @@ struct let m = Int.Map.find h s in Map.find k m + let find_opt k s = + let h = M.hash k in + match Int.Map.find_opt h s with + | None -> None + | Some m -> Map.find_opt k m + let get k s = try find k s with Not_found -> assert false let split k s = assert false (** Cannot be implemented efficiently *) diff --git a/clib/int.ml b/clib/int.ml index fa21379565..3924c152d6 100644 --- a/clib/int.ml +++ b/clib/int.ml @@ -41,6 +41,13 @@ struct if i < k then find i l else if i = k then v else find i r + + let rec find_opt i s = match map_prj s with + | MEmpty -> None + | MNode (l, k, v, r, h) -> + if i < k then find_opt i l + else if i = k then Some v + else find_opt i r end module List = struct diff --git a/configure.ml b/configure.ml index 33f76078cf..6f5ade3b9a 100644 --- a/configure.ml +++ b/configure.ml @@ -1001,6 +1001,7 @@ let print_summary () = pr " Architecture : %s\n" arch; if operating_system <> "" then pr " Operating system : %s\n" operating_system; + pr " Sys.os_type : %s\n" Sys.os_type; pr " Coq VM bytecode link flags : %s\n" (String.concat " " vmbyteflags); pr " Other bytecode link flags : %s\n" custom_flag; pr " OCaml version : %s\n" caml_version; diff --git a/default.nix b/default.nix index 89d69cc40f..b65d736d79 100644 --- a/default.nix +++ b/default.nix @@ -23,10 +23,10 @@ { pkgs ? (import (fetchTarball { - url = "https://github.com/NixOS/nixpkgs/archive/958a6c6dd39b0d6628e1408e798a8f1308f2f3e1.tar.gz"; - sha256 = "0vs6k4jn0rbdfzaxmh3xh64q213326680i9g3cjgr7l9y6h6m5sy"; + url = "https://github.com/NixOS/nixpkgs/archive/11cf7d6e1ffd5fbc09a51b76d668ad0858a772ed.tar.gz"; + sha256 = "0zcg4mgfdk3ryiqj1j5iv5bljjvsgi6q6j9z1vkq383c4g4clc72"; }) {}) -, ocamlPackages ? pkgs.ocaml-ng.ocamlPackages_4_06 +, ocamlPackages ? pkgs.ocamlPackages , buildIde ? true , buildDoc ? true , doInstallCheck ? true diff --git a/dev/build/windows/MakeCoq_84pl6_abs_ocaml.bat b/dev/build/windows/MakeCoq_84pl6_abs_ocaml.bat deleted file mode 100644 index 9dbce1920f..0000000000 --- a/dev/build/windows/MakeCoq_84pl6_abs_ocaml.bat +++ /dev/null @@ -1,28 +0,0 @@ -@ECHO OFF
-
-REM ========== COPYRIGHT/COPYLEFT ==========
-
-REM (C) 2016 Intel Deutschland GmbH
-REM Author: Michael Soegtrop
-
-REM Released to the public by Intel under the
-REM GNU Lesser General Public License Version 2.1 or later
-REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html
-
-REM ========== BUILD COQ ==========
-
-call MakeCoq_SetRootPath
-
-call MakeCoq_MinGW.bat ^
- -arch=64 ^
- -mode=absolute ^
- -ocaml=Y ^
- -make=Y ^
- -coqver=8.4pl6 ^
- -destcyg="%ROOTPATH%\cygwin_coq64_84pl6_abs" ^
- -destcoq="%ROOTPATH%\coq64_84pl6_abs"
-
-IF %ERRORLEVEL% NEQ 0 (
- ECHO MakeCoq_84pl6_abs_ocaml.bat failed with error code %ERRORLEVEL%
- EXIT /b %ERRORLEVEL%
-)
diff --git a/dev/build/windows/MakeCoq_85pl2_abs_ocaml.bat b/dev/build/windows/MakeCoq_85pl2_abs_ocaml.bat deleted file mode 100644 index 7faf3e9ce1..0000000000 --- a/dev/build/windows/MakeCoq_85pl2_abs_ocaml.bat +++ /dev/null @@ -1,28 +0,0 @@ -@ECHO OFF
-
-REM ========== COPYRIGHT/COPYLEFT ==========
-
-REM (C) 2016 Intel Deutschland GmbH
-REM Author: Michael Soegtrop
-
-REM Released to the public by Intel under the
-REM GNU Lesser General Public License Version 2.1 or later
-REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html
-
-REM ========== BUILD COQ ==========
-
-call MakeCoq_SetRootPath
-
-call MakeCoq_MinGW.bat ^
- -arch=64 ^
- -mode=absolute ^
- -ocaml=Y ^
- -make=Y ^
- -coqver=8.5pl2 ^
- -destcyg="%ROOTPATH%\cygwin_coq64_85pl2_abs" ^
- -destcoq="%ROOTPATH%\coq64_85pl2_abs"
-
-IF %ERRORLEVEL% NEQ 0 (
- ECHO MakeCoq_85pl2_abs_ocaml.bat failed with error code %ERRORLEVEL%
- EXIT /b %ERRORLEVEL%
-)
diff --git a/dev/build/windows/MakeCoq_85pl3_abs_ocaml.bat b/dev/build/windows/MakeCoq_85pl3_abs_ocaml.bat deleted file mode 100644 index b719b14c53..0000000000 --- a/dev/build/windows/MakeCoq_85pl3_abs_ocaml.bat +++ /dev/null @@ -1,28 +0,0 @@ -@ECHO OFF
-
-REM ========== COPYRIGHT/COPYLEFT ==========
-
-REM (C) 2016 Intel Deutschland GmbH
-REM Author: Michael Soegtrop
-
-REM Released to the public by Intel under the
-REM GNU Lesser General Public License Version 2.1 or later
-REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html
-
-REM ========== BUILD COQ ==========
-
-call MakeCoq_SetRootPath
-
-call MakeCoq_MinGW.bat ^
- -arch=64 ^
- -mode=absolute ^
- -ocaml=Y ^
- -make=Y ^
- -coqver=8.5pl3 ^
- -destcyg="%ROOTPATH%\cygwin_coq64_85pl3_abs" ^
- -destcoq="%ROOTPATH%\coq64_85pl3_abs"
-
-IF %ERRORLEVEL% NEQ 0 (
- ECHO MakeCoq_85pl3_abs_ocaml.bat failed with error code %ERRORLEVEL%
- EXIT /b %ERRORLEVEL%
-)
diff --git a/dev/build/windows/MakeCoq_85pl3_installer.bat b/dev/build/windows/MakeCoq_85pl3_installer.bat deleted file mode 100644 index a9f4e2da2e..0000000000 --- a/dev/build/windows/MakeCoq_85pl3_installer.bat +++ /dev/null @@ -1,26 +0,0 @@ -@ECHO OFF
-
-REM ========== COPYRIGHT/COPYLEFT ==========
-
-REM (C) 2016 Intel Deutschland GmbH
-REM Author: Michael Soegtrop
-
-REM Released to the public by Intel under the
-REM GNU Lesser General Public License Version 2.1 or later
-REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html
-
-REM ========== BUILD COQ ==========
-
-call MakeCoq_SetRootPath
-
-call MakeCoq_MinGW.bat ^
- -arch=64 ^
- -installer=Y ^
- -coqver=8.5pl3 ^
- -destcyg="%ROOTPATH%\cygwin_coq64_85pl3_inst" ^
- -destcoq="%ROOTPATH%\coq64_85pl3_inst"
-
-IF %ERRORLEVEL% NEQ 0 (
- ECHO MakeCoq_85pl3_installer.bat failed with error code %ERRORLEVEL%
- EXIT /b %ERRORLEVEL%
-)
diff --git a/dev/build/windows/MakeCoq_85pl3_installer_32.bat b/dev/build/windows/MakeCoq_85pl3_installer_32.bat deleted file mode 100644 index ef593cc63a..0000000000 --- a/dev/build/windows/MakeCoq_85pl3_installer_32.bat +++ /dev/null @@ -1,26 +0,0 @@ -@ECHO OFF
-
-REM ========== COPYRIGHT/COPYLEFT ==========
-
-REM (C) 2016 Intel Deutschland GmbH
-REM Author: Michael Soegtrop
-
-REM Released to the public by Intel under the
-REM GNU Lesser General Public License Version 2.1 or later
-REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html
-
-REM ========== BUILD COQ ==========
-
-call MakeCoq_SetRootPath
-
-call MakeCoq_MinGW.bat ^
- -arch=32 ^
- -installer=Y ^
- -coqver=8.5pl3 ^
- -destcyg="%ROOTPATH%\cygwin_coq32_85pl3_inst" ^
- -destcoq="%ROOTPATH%\coq32_85pl3_inst"
-
-IF %ERRORLEVEL% NEQ 0 (
- ECHO MakeCoq_85pl3_installer_32.bat failed with error code %ERRORLEVEL%
- EXIT /b %ERRORLEVEL%
-)
diff --git a/dev/build/windows/MakeCoq_86_abs_ocaml.bat b/dev/build/windows/MakeCoq_86_abs_ocaml.bat deleted file mode 100644 index 50483c4d4a..0000000000 --- a/dev/build/windows/MakeCoq_86_abs_ocaml.bat +++ /dev/null @@ -1,10 +0,0 @@ -call MakeCoq_SetRootPath
-
-call MakeCoq_MinGW.bat ^
- -arch=64 ^
- -mode=absolute ^
- -ocaml=Y ^
- -make=Y ^
- -coqver=8.6 ^
- -destcyg=%ROOTPATH%\cygwin_coq64_86_abs ^
- -destcoq=%ROOTPATH%\coq64_86_abs
diff --git a/dev/build/windows/MakeCoq_86_installer.bat b/dev/build/windows/MakeCoq_86_installer.bat deleted file mode 100644 index 263520ff14..0000000000 --- a/dev/build/windows/MakeCoq_86_installer.bat +++ /dev/null @@ -1,8 +0,0 @@ -call MakeCoq_SetRootPath
-
-call MakeCoq_MinGW.bat ^
- -arch=64 ^
- -installer=Y ^
- -coqver=8.6 ^
- -destcyg=%ROOTPATH%\cygwin_coq64_86_inst ^
- -destcoq=%ROOTPATH%\coq64_86_inst
diff --git a/dev/build/windows/MakeCoq_86_installer_32.bat b/dev/build/windows/MakeCoq_86_installer_32.bat deleted file mode 100644 index 14921dd7c3..0000000000 --- a/dev/build/windows/MakeCoq_86_installer_32.bat +++ /dev/null @@ -1,8 +0,0 @@ -call MakeCoq_SetRootPath
-
-call MakeCoq_MinGW.bat ^
- -arch=32 ^
- -installer=Y ^
- -coqver=8.6 ^
- -destcyg=%ROOTPATH%\cygwin_coq32_86_inst ^
- -destcoq=%ROOTPATH%\coq32_86_inst
diff --git a/dev/build/windows/MakeCoq_86beta1_abs_ocaml.bat b/dev/build/windows/MakeCoq_86beta1_abs_ocaml.bat deleted file mode 100644 index 914c332f46..0000000000 --- a/dev/build/windows/MakeCoq_86beta1_abs_ocaml.bat +++ /dev/null @@ -1,10 +0,0 @@ -call MakeCoq_SetRootPath
-
-call MakeCoq_MinGW.bat ^
- -arch=64 ^
- -mode=absolute ^
- -ocaml=Y ^
- -make=Y ^
- -coqver=8.6beta1 ^
- -destcyg=%ROOTPATH%\cygwin_coq64_86beta1_abs ^
- -destcoq=%ROOTPATH%\coq64_86beta1_abs
diff --git a/dev/build/windows/MakeCoq_86beta1_installer.bat b/dev/build/windows/MakeCoq_86beta1_installer.bat deleted file mode 100644 index 76a5bb35ac..0000000000 --- a/dev/build/windows/MakeCoq_86beta1_installer.bat +++ /dev/null @@ -1,8 +0,0 @@ -call MakeCoq_SetRootPath
-
-call MakeCoq_MinGW.bat ^
- -arch=64 ^
- -installer=Y ^
- -coqver=8.6beta1 ^
- -destcyg=%ROOTPATH%\cygwin_coq64_86beta1_inst ^
- -destcoq=%ROOTPATH%\coq64_86beta1_inst
diff --git a/dev/build/windows/MakeCoq_86beta1_installer_32.bat b/dev/build/windows/MakeCoq_86beta1_installer_32.bat deleted file mode 100644 index f53232b651..0000000000 --- a/dev/build/windows/MakeCoq_86beta1_installer_32.bat +++ /dev/null @@ -1,8 +0,0 @@ -call MakeCoq_SetRootPath
-
-call MakeCoq_MinGW.bat ^
- -arch=32 ^
- -installer=Y ^
- -coqver=8.6beta1 ^
- -destcyg=%ROOTPATH%\cygwin_coq32_86beta1_inst ^
- -destcoq=%ROOTPATH%\coq32_86beta1_inst
diff --git a/dev/build/windows/MakeCoq_86git_abs_ocaml.bat b/dev/build/windows/MakeCoq_86git_abs_ocaml.bat deleted file mode 100644 index 99a1f156b0..0000000000 --- a/dev/build/windows/MakeCoq_86git_abs_ocaml.bat +++ /dev/null @@ -1,28 +0,0 @@ -@ECHO OFF
-
-REM ========== COPYRIGHT/COPYLEFT ==========
-
-REM (C) 2016 Intel Deutschland GmbH
-REM Author: Michael Soegtrop
-
-REM Released to the public by Intel under the
-REM GNU Lesser General Public License Version 2.1 or later
-REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html
-
-REM ========== BUILD COQ ==========
-
-call MakeCoq_SetRootPath
-
-call MakeCoq_MinGW.bat ^
- -arch=64 ^
- -mode=absolute ^
- -ocaml=Y ^
- -make=Y ^
- -coqver=git-v8.6 ^
- -destcyg="%ROOTPATH%\cygwin_coq64_86git_abs" ^
- -destcoq="%ROOTPATH%\coq64_86git_abs"
-
-IF %ERRORLEVEL% NEQ 0 (
- ECHO MakeCoq_86git_abs_ocaml.bat failed with error code %ERRORLEVEL%
- EXIT /b %ERRORLEVEL%
-)
diff --git a/dev/build/windows/MakeCoq_86git_abs_ocaml_gtksrc.bat b/dev/build/windows/MakeCoq_86git_abs_ocaml_gtksrc.bat deleted file mode 100644 index 896d1cd633..0000000000 --- a/dev/build/windows/MakeCoq_86git_abs_ocaml_gtksrc.bat +++ /dev/null @@ -1,29 +0,0 @@ -@ECHO OFF
-
-REM ========== COPYRIGHT/COPYLEFT ==========
-
-REM (C) 2016 Intel Deutschland GmbH
-REM Author: Michael Soegtrop
-
-REM Released to the public by Intel under the
-REM GNU Lesser General Public License Version 2.1 or later
-REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html
-
-REM ========== BUILD COQ ==========
-
-call MakeCoq_SetRootPath
-
-call MakeCoq_MinGW.bat ^
- -arch=64 ^
- -mode=absolute ^
- -ocaml=Y ^
- -make=Y ^
- -gtksrc=Y ^
- -coqver=git-v8.6 ^
- -destcyg="%ROOTPATH%\cygwin_coq64_86git_abs_gtksrc" ^
- -destcoq="%ROOTPATH%\coq64_86git_abs_gtksrc"
-
-IF %ERRORLEVEL% NEQ 0 (
- ECHO MakeCoq_86git_abs_ocaml_gtksrc.bat failed with error code %ERRORLEVEL%
- EXIT /b %ERRORLEVEL%
-)
diff --git a/dev/build/windows/MakeCoq_86git_installer.bat b/dev/build/windows/MakeCoq_86git_installer.bat deleted file mode 100644 index c4823103f1..0000000000 --- a/dev/build/windows/MakeCoq_86git_installer.bat +++ /dev/null @@ -1,26 +0,0 @@ -@ECHO OFF
-
-REM ========== COPYRIGHT/COPYLEFT ==========
-
-REM (C) 2016 Intel Deutschland GmbH
-REM Author: Michael Soegtrop
-
-REM Released to the public by Intel under the
-REM GNU Lesser General Public License Version 2.1 or later
-REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html
-
-REM ========== BUILD COQ ==========
-
-call MakeCoq_SetRootPath
-
-call MakeCoq_MinGW.bat ^
- -arch=64 ^
- -installer=Y ^
- -coqver=git-v8.6 ^
- -destcyg="%ROOTPATH%\cygwin_coq64_86git_inst" ^
- -destcoq="%ROOTPATH%\coq64_86git_inst"
-
-IF %ERRORLEVEL% NEQ 0 (
- ECHO MakeCoq_86git_installer.bat failed with error code %ERRORLEVEL%
- EXIT /b %ERRORLEVEL%
-)
diff --git a/dev/build/windows/MakeCoq_86git_installer2.bat b/dev/build/windows/MakeCoq_86git_installer2.bat deleted file mode 100644 index d184f0e30e..0000000000 --- a/dev/build/windows/MakeCoq_86git_installer2.bat +++ /dev/null @@ -1,8 +0,0 @@ -call MakeCoq_SetRootPath
-
-call MakeCoq_MinGW.bat ^
- -arch=64 ^
- -installer=Y ^
- -coqver=git-v8.6 ^
- -destcyg=%ROOTPATH%\cygwin_coq64_86git_inst2 ^
- -destcoq=%ROOTPATH%\coq64_86git_inst2
diff --git a/dev/build/windows/MakeCoq_86git_installer_32.bat b/dev/build/windows/MakeCoq_86git_installer_32.bat deleted file mode 100644 index 19146c96c9..0000000000 --- a/dev/build/windows/MakeCoq_86git_installer_32.bat +++ /dev/null @@ -1,26 +0,0 @@ -@ECHO OFF
-
-REM ========== COPYRIGHT/COPYLEFT ==========
-
-REM (C) 2016 Intel Deutschland GmbH
-REM Author: Michael Soegtrop
-
-REM Released to the public by Intel under the
-REM GNU Lesser General Public License Version 2.1 or later
-REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html
-
-REM ========== BUILD COQ ==========
-
-call MakeCoq_SetRootPath
-
-call MakeCoq_MinGW.bat ^
- -arch=32 ^
- -installer=Y ^
- -coqver=git-v8.6 ^
- -destcyg="%ROOTPATH%\cygwin_coq32_86git_inst" ^
- -destcoq="%ROOTPATH%\coq32_86git_inst"
-
-IF %ERRORLEVEL% NEQ 0 (
- ECHO MakeCoq_86git_installer_32.bat failed with error code %ERRORLEVEL%
- EXIT /b %ERRORLEVEL%
-)
diff --git a/dev/build/windows/MakeCoq_86git_installer_cyglocal.bat b/dev/build/windows/MakeCoq_86git_installer_cyglocal.bat deleted file mode 100755 index cf6cafaa02..0000000000 --- a/dev/build/windows/MakeCoq_86git_installer_cyglocal.bat +++ /dev/null @@ -1,27 +0,0 @@ -@ECHO OFF
-
-REM ========== COPYRIGHT/COPYLEFT ==========
-
-REM (C) 2016 Intel Deutschland GmbH
-REM Author: Michael Soegtrop
-
-REM Released to the public by Intel under the
-REM GNU Lesser General Public License Version 2.1 or later
-REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html
-
-REM ========== BUILD COQ ==========
-
-call MakeCoq_SetRootPath
-
-call MakeCoq_MinGW.bat ^
- -arch=64 ^
- -installer=Y ^
- -coqver=git-v8.6 ^
- -cyglocal=Y ^
- -destcyg="%ROOTPATH%\cygwin_coq64_86git_inst_cyglocal" ^
- -destcoq="%ROOTPATH%\coq64_86git_inst_cyglocal"
-
-IF %ERRORLEVEL% NEQ 0 (
- ECHO MakeCoq_86git_installer_cyglocal.bat failed with error code %ERRORLEVEL%
- EXIT /b %ERRORLEVEL%
-)
diff --git a/dev/build/windows/MakeCoq_86rc1_abs_ocaml.bat b/dev/build/windows/MakeCoq_86rc1_abs_ocaml.bat deleted file mode 100644 index c0669f01d2..0000000000 --- a/dev/build/windows/MakeCoq_86rc1_abs_ocaml.bat +++ /dev/null @@ -1,10 +0,0 @@ -call MakeCoq_SetRootPath
-
-call MakeCoq_MinGW.bat ^
- -arch=64 ^
- -mode=absolute ^
- -ocaml=Y ^
- -make=Y ^
- -coqver=8.6rc1 ^
- -destcyg=%ROOTPATH%\cygwin_coq64_86rc1_abs ^
- -destcoq=%ROOTPATH%\coq64_86rc1_abs
diff --git a/dev/build/windows/MakeCoq_86rc1_installer.bat b/dev/build/windows/MakeCoq_86rc1_installer.bat deleted file mode 100644 index 66234ebbde..0000000000 --- a/dev/build/windows/MakeCoq_86rc1_installer.bat +++ /dev/null @@ -1,8 +0,0 @@ -call MakeCoq_SetRootPath
-
-call MakeCoq_MinGW.bat ^
- -arch=64 ^
- -installer=Y ^
- -coqver=8.6rc1 ^
- -destcyg=%ROOTPATH%\cygwin_coq64_86rc1_inst ^
- -destcoq=%ROOTPATH%\coq64_86rc1_inst
diff --git a/dev/build/windows/MakeCoq_86rc1_installer_32.bat b/dev/build/windows/MakeCoq_86rc1_installer_32.bat deleted file mode 100644 index 96f43e16a5..0000000000 --- a/dev/build/windows/MakeCoq_86rc1_installer_32.bat +++ /dev/null @@ -1,8 +0,0 @@ -call MakeCoq_SetRootPath
-
-call MakeCoq_MinGW.bat ^
- -arch=32 ^
- -installer=Y ^
- -coqver=8.6rc1 ^
- -destcyg=%ROOTPATH%\cygwin_coq32_86rc1_inst ^
- -destcoq=%ROOTPATH%\coq32_86rc1_inst
diff --git a/dev/build/windows/MakeCoq_88git_installer.bat b/dev/build/windows/MakeCoq_88git_installer.bat deleted file mode 100755 index b016fb3891..0000000000 --- a/dev/build/windows/MakeCoq_88git_installer.bat +++ /dev/null @@ -1,27 +0,0 @@ -@ECHO OFF
-
-REM ========== COPYRIGHT/COPYLEFT ==========
-
-REM (C) 2016 Intel Deutschland GmbH
-REM Author: Michael Soegtrop
-
-REM Released to the public by Intel under the
-REM GNU Lesser General Public License Version 2.1 or later
-REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html
-
-REM ========== BUILD COQ ==========
-
-call MakeCoq_SetRootPath
-
-call MakeCoq_MinGW.bat ^
- -arch=64 ^
- -installer=Y ^
- -coqver=git-v8.8 ^
- -destcyg=%ROOTPATH%\cygwin_coq64_88_inst ^
- -destcoq=%ROOTPATH%\coq64_88_inst ^
- -addon=bignums
-
-IF %ERRORLEVEL% NEQ 0 (
- ECHO MakeCoq_88git_installer.bat failed with error code %ERRORLEVEL%
- EXIT /b %ERRORLEVEL%
-)
diff --git a/dev/build/windows/MakeCoq_MinGW.bat b/dev/build/windows/MakeCoq_MinGW.bat index fdbb0eca2b..8489bcfc3a 100755 --- a/dev/build/windows/MakeCoq_MinGW.bat +++ b/dev/build/windows/MakeCoq_MinGW.bat @@ -1,488 +1,488 @@ -@ECHO OFF - -REM ========== COPYRIGHT/COPYLEFT ========== - -REM (C) 2016 Intel Deutschland GmbH -REM Author: Michael Soegtrop - -REM Released to the public by Intel under the -REM GNU Lesser General Public License Version 2.1 or later -REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html - -REM ========== NOTES ========== - -REM For Cygwin setup command line options -REM see https://cygwin.com/faq/faq.html#faq.setup.cli - -REM ========== DEFAULT VALUES FOR PARAMETERS ========== - -REM For a description of all parameters, see ReadMe.txt - -SET BATCHFILE=%~0 -SET BATCHDIR=%~dp0 - -REM see -arch in ReadMe.txt, but values are x86_64 or i686 (not 64 or 32) -SET ARCH=x86_64 - -REM see -mode in ReadMe.txt -SET INSTALLMODE=absolute - -REM see -installer in ReadMe.txt -SET MAKEINSTALLER=N - -REM see -ocaml in ReadMe.txt -SET INSTALLOCAML=N - -REM see -make in ReadMe.txt -SET INSTALLMAKE=N - -REM see -destcyg in ReadMe.txt -SET DESTCYG=C:\bin\cygwin_coq - -REM see -destcoq in ReadMe.txt -SET DESTCOQ=C:\bin\coq - -REM see -setup in ReadMe.txt -SET SETUP=setup-x86_64.exe - -REM see -proxy in ReadMe.txt -IF DEFINED HTTP_PROXY ( - SET PROXY=%HTTP_PROXY:http://=% -) else ( - REM One can't set a variable to empty in DOS, but you can set it to a space this way. - REM The quotes are just there to make the space visible and to protect from "remove trailing spaces". - SET "PROXY= " -) - -REM see -cygrepo in ReadMe.txt -SET CYGWIN_REPOSITORY=http://mirror.easyname.at/cygwin - -REM see -cygcache in ReadMe.txt -SET CYGWIN_LOCAL_CACHE_WFMT=%BATCHDIR%cygwin_cache - -REM see -cyglocal in ReadMe.txt -SET CYGWIN_FROM_CACHE=N - -REM see -cygquiet in ReadMe.txt -SET CYGWIN_QUIET=Y - -REM see -srccache in ReadMe.txt -SET SOURCE_LOCAL_CACHE_WFMT=%BATCHDIR%source_cache - -REM see -coqver in ReadMe.txt -SET COQ_VERSION=8.5pl3 - -REM see -gtksrc in ReadMe.txt -SET GTK_FROM_SOURCES=N - -REM see -threads in ReadMe.txt -SET MAKE_THREADS=8 - -REM see -addon in ReadMe.txt -SET "COQ_ADDONS= " - -REM ========== PARSE COMMAND LINE PARAMETERS ========== - -SHIFT - -:Parse - -IF "%~0" == "-arch" ( - IF "%~1" == "32" ( - SET ARCH=i686 - SET SETUP=setup-x86.exe - ) ELSE ( - IF "%~1" == "64" ( - SET ARCH=x86_64 - SET SETUP=setup-x86_64.exe - ) ELSE ( - ECHO "Invalid -arch, valid are 32 and 64" - GOTO :EOF - ) - ) - SHIFT - SHIFT - GOTO Parse -) - -IF "%~0" == "-mode" ( - IF "%~1" == "mingwincygwin" ( - SET INSTALLMODE=%~1 - ) ELSE ( - IF "%~1" == "absolute" ( - SET INSTALLMODE=%~1 - ) ELSE ( - IF "%~1" == "relocatable" ( - SET INSTALLMODE=%~1 - ) ELSE ( - ECHO "Invalid -mode, valid are mingwincygwin, absolute and relocatable" - GOTO :EOF - ) - ) - ) - SHIFT - SHIFT - GOTO Parse -) - -IF "%~0" == "-installer" ( - SET MAKEINSTALLER=%~1 - CALL :CheckYN -installer %~1 || GOTO ErrorExit - SHIFT - SHIFT - GOTO Parse -) - -IF "%~0" == "-ocaml" ( - SET INSTALLOCAML=%~1 - CALL :CheckYN -installer %~1 || GOTO ErrorExit - SHIFT - SHIFT - GOTO Parse -) - -IF "%~0" == "-make" ( - SET INSTALLMAKE=%~1 - CALL :CheckYN -installer %~1 || GOTO ErrorExit - SHIFT - SHIFT - GOTO Parse -) - -IF "%~0" == "-destcyg" ( - SET DESTCYG=%~1 - SHIFT - SHIFT - GOTO Parse -) - -IF "%~0" == "-destcoq" ( - SET DESTCOQ=%~1 - SHIFT - SHIFT - GOTO Parse -) - -IF "%~0" == "-setup" ( - SET SETUP=%~1 - SHIFT - SHIFT - GOTO Parse -) - -IF "%~0" == "-proxy" ( - SET PROXY=%~1 - SHIFT - SHIFT - GOTO Parse -) - -IF "%~0" == "-cygrepo" ( - SET CYGWIN_REPOSITORY=%~1 - SHIFT - SHIFT - GOTO Parse -) - -IF "%~0" == "-cygcache" ( - SET CYGWIN_LOCAL_CACHE_WFMT=%~1 - SHIFT - SHIFT - GOTO Parse -) - -IF "%~0" == "-cyglocal" ( - SET CYGWIN_FROM_CACHE=%~1 - CALL :CheckYN -cyglocal %~1 || GOTO ErrorExit - SHIFT - SHIFT - GOTO Parse -) - -IF "%~0" == "-cygquiet" ( - SET CYGWIN_QUIET=%~1 - CALL :CheckYN -cygquiet %~1 || GOTO ErrorExit - SHIFT - SHIFT - GOTO Parse -) - -IF "%~0" == "-srccache" ( - SET SOURCE_LOCAL_CACHE_WFMT=%~1 - SHIFT - SHIFT - GOTO Parse -) - -IF "%~0" == "-coqver" ( - SET COQ_VERSION=%~1 - SHIFT - SHIFT - GOTO Parse -) - -IF "%~0" == "-gtksrc" ( - SET GTK_FROM_SOURCES=%~1 - CALL :CheckYN -gtksrc %~1 || GOTO ErrorExit - SHIFT - SHIFT - GOTO Parse -) - -IF "%~0" == "-threads" ( - SET MAKE_THREADS=%~1 - SHIFT - SHIFT - GOTO Parse -) - -IF "%~0" == "-addon" ( - SET "COQ_ADDONS=%COQ_ADDONS% %~1" - SHIFT - SHIFT - GOTO Parse -) - - -IF NOT "%~0" == "" ( - ECHO Install cygwin and download, compile and install OCaml and Coq for MinGW - ECHO !!! Illegal parameter %~0 - ECHO Usage: - ECHO MakeCoq_MinGW - CALL :PrintPars - GOTO :EOF -) - -IF NOT EXIST %SETUP% ( - ECHO The cygwin setup program %SETUP% doesn't exist. You must download it from https://cygwin.com/install.html. - ECHO If the setup is in a different folder, set the full path to %SETUP% using the -setup option. - GOTO :EOF -) - -REM ========== ADJUST PARAMETERS ========== - -IF "%INSTALLMODE%" == "mingwincygwin" ( - SET DESTCOQ=%DESTCYG%\usr\%ARCH%-w64-mingw32\sys-root\mingw -) - -IF "%MAKEINSTALLER%" == "Y" ( - SET INSTALLMODE=relocatable -) - -REM ========== CONFIRM PARAMETERS ========== - -CALL :PrintPars -REM Note: DOS batch replaces variables on parsing, so one can't use a variable just set in an () block -IF "%COQREGTESTING%"=="Y" (GOTO DontAsk) - SET /p ANSWER="Is this correct? y/n " - IF NOT "%ANSWER%"=="y" (GOTO :EOF) -:DontAsk - -REM ========== DERIVED VARIABLES ========== - -SET CYGWIN_INSTALLDIR_WFMT=%DESTCYG% -SET RESULT_INSTALLDIR_WFMT=%DESTCOQ% -SET TARGET_ARCH=%ARCH%-w64-mingw32 -SET BASH=%CYGWIN_INSTALLDIR_WFMT%\bin\bash - -REM Convert pathes to various formats -REM WFMT = windows format (C:\..) Used in this batch file. -REM CFMT = cygwin format (\cygdrive\c\..) Used for Cygwin PATH varible, which is : separated, so C: doesn't work. -REM MFMT = MinGW format (C:/...) Used for the build, because \\ requires escaping. Mingw can handle \ and /. - -SET CYGWIN_INSTALLDIR_MFMT=%CYGWIN_INSTALLDIR_WFMT:\=/% -SET RESULT_INSTALLDIR_MFMT=%RESULT_INSTALLDIR_WFMT:\=/% -SET SOURCE_LOCAL_CACHE_MFMT=%SOURCE_LOCAL_CACHE_WFMT:\=/% - -SET CYGWIN_INSTALLDIR_CFMT=%CYGWIN_INSTALLDIR_MFMT:C:/=/cygdrive/c/% -SET RESULT_INSTALLDIR_CFMT=%RESULT_INSTALLDIR_MFMT:C:/=/cygdrive/c/% -SET SOURCE_LOCAL_CACHE_CFMT=%SOURCE_LOCAL_CACHE_MFMT:C:/=/cygdrive/c/% - -SET CYGWIN_INSTALLDIR_CFMT=%CYGWIN_INSTALLDIR_CFMT:D:/=/cygdrive/d/% -SET RESULT_INSTALLDIR_CFMT=%RESULT_INSTALLDIR_CFMT:D:/=/cygdrive/d/% -SET SOURCE_LOCAL_CACHE_CFMT=%SOURCE_LOCAL_CACHE_CFMT:D:/=/cygdrive/d/% - -SET CYGWIN_INSTALLDIR_CFMT=%CYGWIN_INSTALLDIR_CFMT:E:/=/cygdrive/e/% -SET RESULT_INSTALLDIR_CFMT=%RESULT_INSTALLDIR_CFMT:E:/=/cygdrive/e/% -SET SOURCE_LOCAL_CACHE_CFMT=%SOURCE_LOCAL_CACHE_CFMT:E:/=/cygdrive/e/% - -ECHO CYGWIN INSTALL DIR (WIN) = %CYGWIN_INSTALLDIR_WFMT% -ECHO CYGWIN INSTALL DIR (MINGW) = %CYGWIN_INSTALLDIR_MFMT% -ECHO CYGWIN INSTALL DIR (CYGWIN) = %CYGWIN_INSTALLDIR_CFMT% -ECHO RESULT INSTALL DIR (WIN) = %RESULT_INSTALLDIR_WFMT% -ECHO RESULT INSTALL DIR (MINGW) = %RESULT_INSTALLDIR_MFMT% -ECHO RESULT INSTALL DIR (CYGWIN) = %RESULT_INSTALLDIR_CFMT% - -REM WARNING: Add a space after the = in case you want set this to empty, otherwise the variable will be unset -SET MAKE_OPT=-j %MAKE_THREADS% - -REM ========== DERIVED CYGWIN SETUP OPTIONS ========== - -REM One can't set a variable to empty in DOS, but you can set it to a space this way. -REM The quotes are just there to make the space visible and to protect from "remove trailing spaces". -SET "CYGWIN_OPT= " - -IF "%CYGWIN_FROM_CACHE%" == "Y" ( - SET CYGWIN_OPT= %CYGWIN_OPT% -L -) - -IF "%CYGWIN_QUIET%" == "Y" ( - SET CYGWIN_OPT= %CYGWIN_OPT% -q --no-admin -) - -IF "%GTK_FROM_SOURCES%"=="N" ( - SET CYGWIN_OPT= %CYGWIN_OPT% -P mingw64-%ARCH%-gtk2.0,mingw64-%ARCH%-gtksourceview2.0 -) - -REM Cygwin setup sets proper ACLs (permissions) for folders it CREATES. -REM Otherwise chmod won't work and e.g. the ocaml build will fail. -REM Cygwin setup does not touch the ACLs of existing folders. - -REM Run Cygwin Setup - -SET RUNSETUP=Y -IF EXIST "%CYGWIN_INSTALLDIR_WFMT%\etc\setup\installed.db" ( - SET RUNSETUP=N -) -IF NOT "%CYGWIN_QUIET%" == "Y" ( - SET RUNSETUP=Y -) - -IF "%COQREGTESTING%" == "Y" ( - ECHO "========== REMOVE EXISTING CYGWIN ==========" - DEL /S /F /Q "%CYGWIN_INSTALLDIR_WFMT%" > NUL - SET RUNSETUP=Y -) - -SET "EXTRAPACKAGES= " - -IF NOT "%APPVEYOR%" == "True" ( - SET EXTRAPACKAGES=-P wget,curl,git,gcc-core,gcc-g++,automake1.5 -) - -ECHO "========== INSTALL CYGWIN ==========" - -IF "%RUNSETUP%"=="Y" ( - %SETUP% ^ - --proxy "%PROXY%" ^ - --site "%CYGWIN_REPOSITORY%" ^ - --root "%CYGWIN_INSTALLDIR_WFMT%" ^ - --local-package-dir "%CYGWIN_LOCAL_CACHE_WFMT%" ^ - --no-shortcuts ^ - %CYGWIN_OPT% ^ - -P make,unzip ^ - -P gdb,liblzma5 ^ - -P patch,automake1.14 ^ - -P mingw64-%ARCH%-binutils,mingw64-%ARCH%-gcc-core,mingw64-%ARCH%-gcc-g++,mingw64-%ARCH%-pkg-config,mingw64-%ARCH%-windows_default_manifest ^ - -P mingw64-%ARCH%-headers,mingw64-%ARCH%-runtime,mingw64-%ARCH%-pthreads,mingw64-%ARCH%-zlib ^ - -P libiconv-devel,libunistring-devel,libncurses-devel ^ - -P gettext-devel,libgettextpo-devel ^ - -P libglib2.0-devel,libgdk_pixbuf2.0-devel ^ - -P libfontconfig1 ^ - -P gtk-update-icon-cache ^ - -P libtool,automake ^ - -P intltool ^ - %EXTRAPACKAGES% ^ - || GOTO ErrorExit - - MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build" - MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build\buildlogs" -) - -IF NOT "%CYGWIN_QUIET%" == "Y" ( - REM Like most setup programs, cygwin setup starts the real setup as a separate process, so wait for it. - REM This is not required with the -cygquiet=Y and the resulting --no-admin option. - :waitsetup - tasklist /fi "imagename eq %SETUP%" | find ":" > NUL - IF ERRORLEVEL 1 GOTO waitsetup -) - -ECHO ========== CONFIGURE CYGWIN USER ACCOUNT ========== - -REM In case this batch file is called from a cygwin bash (e.g. a git repo) we need to clear -REM HOME (otherwise we get to the home directory of the other installation) -REM PROFILEREAD (this is set to true if the /etc/profile has been read, which creates user) -SET "HOME=" -SET "PROFILEREAD=" - -copy "%BATCHDIR%\configure_profile.sh" "%CYGWIN_INSTALLDIR_WFMT%\var\tmp" || GOTO ErrorExit -%BASH% --login "%CYGWIN_INSTALLDIR_CFMT%\var\tmp\configure_profile.sh" "%PROXY%" || GOTO ErrorExit - -ECHO ========== BUILD COQ ========== - -MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build" -MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build\patches" - -COPY "%BATCHDIR%\makecoq_mingw.sh" "%CYGWIN_INSTALLDIR_WFMT%\build" || GOTO ErrorExit -COPY "%BATCHDIR%\patches_coq\*.*" "%CYGWIN_INSTALLDIR_WFMT%\build\patches" || GOTO ErrorExit - -%BASH% --login "%CYGWIN_INSTALLDIR_CFMT%\build\makecoq_mingw.sh" || GOTO ErrorExit - -ECHO ========== FINISHED ========== - -GOTO :EOF - -ECHO ========== BATCH FUNCTIONS ========== - -:PrintPars - REM 01234567890123456789012345678901234567890123456789012345678901234567890123456789 - ECHO -arch ^<i686 or x86_64^> Set cygwin, ocaml and coq to 32 or 64 bit - ECHO -mode ^<mingwincygwin = install coq in default cygwin mingw sysroot^> - ECHO ^<absoloute = install coq in -destcoq absulute path^> - ECHO ^<relocatable = install relocatable coq in -destcoq path^> - ECHO -installer^<Y or N^> create a windows installer (will be in /build/coq/dev/nsis) - ECHO -ocaml ^<Y or N^> install OCaml in Coq folder (Y) or just in cygwin folder (N) - ECHO -make ^<Y or N^> install GNU Make in Coq folder (Y) or not (N) - ECHO -destcyg ^<path to cygwin destination folder^> - ECHO -destcoq ^<path to coq destination folder (mode=absoloute/relocatable)^> - ECHO -setup ^<cygwin setup program name^> (auto adjusted to -arch) - ECHO -proxy ^<internet proxy^> - ECHO -cygrepo ^<cygwin download repository^> - ECHO -cygcache ^<local cygwin repository/cache^> - ECHO -cyglocal ^<Y or N^> install cygwin from cache - ECHO -cygquiet ^<Y or N^> install cygwin without user interaction - ECHO -srccache ^<local source code repository/cache^> - ECHO -coqver ^<Coq version to install^> - ECHO -gtksrc ^<Y or N^> build GTK ^(90 min^) or use cygwin version - ECHO -threads ^<1..N^> Number of make threads - ECHO -addon ^<name^> Enable building selected addon (can be repeated) - ECHO( - ECHO See ReadMe.txt for a detailed description of all parameters - ECHO( - ECHO Parameter values (default or currently set): - ECHO -arch = %ARCH% - ECHO -mode = %INSTALLMODE% - ECHO -ocaml = %INSTALLOCAML% - ECHO -installer= %MAKEINSTALLER% - ECHO -make = %INSTALLMAKE% - ECHO -destcyg = %DESTCYG% - ECHO -destcoq = %DESTCOQ% - ECHO -setup = %SETUP% - ECHO -proxy = %PROXY% - ECHO -cygrepo = %CYGWIN_REPOSITORY% - ECHO -cygcache = %CYGWIN_LOCAL_CACHE_WFMT% - ECHO -cyglocal = %CYGWIN_FROM_CACHE% - ECHO -cygquiet = %CYGWIN_QUIET% - ECHO -srccache = %SOURCE_LOCAL_CACHE_WFMT% - ECHO -coqver = %COQ_VERSION% - ECHO -gtksrc = %GTK_FROM_SOURCES% - ECHO -threads = %MAKE_THREADS% - ECHO -addon = %COQ_ADDONS% - GOTO :EOF - -:CheckYN - REM Reset errorlevel to 0 - CMD /c "EXIT /b 0" - IF "%2" == "Y" ( - REM OK Y - ) ELSE IF "%2" == "N" ( - REM OK N - ) ELSE ( - ECHO ERROR Parameter %1 must be Y or N, but is %2 - GOTO ErrorExit - ) - GOTO :EOF - -:ErrorExit - ECHO ERROR MakeCoq_MinGW.bat failed - EXIT /b 1 +@ECHO OFF
+
+REM ========== COPYRIGHT/COPYLEFT ==========
+
+REM (C) 2016 Intel Deutschland GmbH
+REM Author: Michael Soegtrop
+
+REM Released to the public by Intel under the
+REM GNU Lesser General Public License Version 2.1 or later
+REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html
+
+REM ========== NOTES ==========
+
+REM For Cygwin setup command line options
+REM see https://cygwin.com/faq/faq.html#faq.setup.cli
+
+REM ========== DEFAULT VALUES FOR PARAMETERS ==========
+
+REM For a description of all parameters, see ReadMe.txt
+
+SET BATCHFILE=%~0
+SET BATCHDIR=%~dp0
+
+REM see -arch in ReadMe.txt, but values are x86_64 or i686 (not 64 or 32)
+SET ARCH=x86_64
+
+REM see -mode in ReadMe.txt
+SET INSTALLMODE=absolute
+
+REM see -installer in ReadMe.txt
+SET MAKEINSTALLER=N
+
+REM see -ocaml in ReadMe.txt
+SET INSTALLOCAML=N
+
+REM see -make in ReadMe.txt
+SET INSTALLMAKE=N
+
+REM see -destcyg in ReadMe.txt
+SET DESTCYG=C:\bin\cygwin_coq
+
+REM see -destcoq in ReadMe.txt
+SET DESTCOQ=C:\bin\coq
+
+REM see -setup in ReadMe.txt
+SET SETUP=setup-x86_64.exe
+
+REM see -proxy in ReadMe.txt
+IF DEFINED HTTP_PROXY (
+ SET PROXY=%HTTP_PROXY:http://=%
+) else (
+ REM One can't set a variable to empty in DOS, but you can set it to a space this way.
+ REM The quotes are just there to make the space visible and to protect from "remove trailing spaces".
+ SET "PROXY= "
+)
+
+REM see -cygrepo in ReadMe.txt
+SET CYGWIN_REPOSITORY=http://mirror.easyname.at/cygwin
+
+REM see -cygcache in ReadMe.txt
+SET CYGWIN_LOCAL_CACHE_WFMT=%BATCHDIR%cygwin_cache
+
+REM see -cyglocal in ReadMe.txt
+SET CYGWIN_FROM_CACHE=N
+
+REM see -cygquiet in ReadMe.txt
+SET CYGWIN_QUIET=Y
+
+REM see -srccache in ReadMe.txt
+SET SOURCE_LOCAL_CACHE_WFMT=%BATCHDIR%source_cache
+
+REM see -coqver in ReadMe.txt
+SET COQ_VERSION=8.5pl3
+
+REM see -gtksrc in ReadMe.txt
+SET GTK_FROM_SOURCES=N
+
+REM see -threads in ReadMe.txt
+SET MAKE_THREADS=8
+
+REM see -addon in ReadMe.txt
+SET "COQ_ADDONS= "
+
+REM ========== PARSE COMMAND LINE PARAMETERS ==========
+
+SHIFT
+
+:Parse
+
+IF "%~0" == "-arch" (
+ IF "%~1" == "32" (
+ SET ARCH=i686
+ SET SETUP=setup-x86.exe
+ ) ELSE (
+ IF "%~1" == "64" (
+ SET ARCH=x86_64
+ SET SETUP=setup-x86_64.exe
+ ) ELSE (
+ ECHO "Invalid -arch, valid are 32 and 64"
+ GOTO :EOF
+ )
+ )
+ SHIFT
+ SHIFT
+ GOTO Parse
+)
+
+IF "%~0" == "-mode" (
+ IF "%~1" == "mingwincygwin" (
+ SET INSTALLMODE=%~1
+ ) ELSE (
+ IF "%~1" == "absolute" (
+ SET INSTALLMODE=%~1
+ ) ELSE (
+ IF "%~1" == "relocatable" (
+ SET INSTALLMODE=%~1
+ ) ELSE (
+ ECHO "Invalid -mode, valid are mingwincygwin, absolute and relocatable"
+ GOTO :EOF
+ )
+ )
+ )
+ SHIFT
+ SHIFT
+ GOTO Parse
+)
+
+IF "%~0" == "-installer" (
+ SET MAKEINSTALLER=%~1
+ CALL :CheckYN -installer %~1 || GOTO ErrorExit
+ SHIFT
+ SHIFT
+ GOTO Parse
+)
+
+IF "%~0" == "-ocaml" (
+ SET INSTALLOCAML=%~1
+ CALL :CheckYN -installer %~1 || GOTO ErrorExit
+ SHIFT
+ SHIFT
+ GOTO Parse
+)
+
+IF "%~0" == "-make" (
+ SET INSTALLMAKE=%~1
+ CALL :CheckYN -installer %~1 || GOTO ErrorExit
+ SHIFT
+ SHIFT
+ GOTO Parse
+)
+
+IF "%~0" == "-destcyg" (
+ SET DESTCYG=%~1
+ SHIFT
+ SHIFT
+ GOTO Parse
+)
+
+IF "%~0" == "-destcoq" (
+ SET DESTCOQ=%~1
+ SHIFT
+ SHIFT
+ GOTO Parse
+)
+
+IF "%~0" == "-setup" (
+ SET SETUP=%~1
+ SHIFT
+ SHIFT
+ GOTO Parse
+)
+
+IF "%~0" == "-proxy" (
+ SET PROXY=%~1
+ SHIFT
+ SHIFT
+ GOTO Parse
+)
+
+IF "%~0" == "-cygrepo" (
+ SET CYGWIN_REPOSITORY=%~1
+ SHIFT
+ SHIFT
+ GOTO Parse
+)
+
+IF "%~0" == "-cygcache" (
+ SET CYGWIN_LOCAL_CACHE_WFMT=%~1
+ SHIFT
+ SHIFT
+ GOTO Parse
+)
+
+IF "%~0" == "-cyglocal" (
+ SET CYGWIN_FROM_CACHE=%~1
+ CALL :CheckYN -cyglocal %~1 || GOTO ErrorExit
+ SHIFT
+ SHIFT
+ GOTO Parse
+)
+
+IF "%~0" == "-cygquiet" (
+ SET CYGWIN_QUIET=%~1
+ CALL :CheckYN -cygquiet %~1 || GOTO ErrorExit
+ SHIFT
+ SHIFT
+ GOTO Parse
+)
+
+IF "%~0" == "-srccache" (
+ SET SOURCE_LOCAL_CACHE_WFMT=%~1
+ SHIFT
+ SHIFT
+ GOTO Parse
+)
+
+IF "%~0" == "-coqver" (
+ SET COQ_VERSION=%~1
+ SHIFT
+ SHIFT
+ GOTO Parse
+)
+
+IF "%~0" == "-gtksrc" (
+ SET GTK_FROM_SOURCES=%~1
+ CALL :CheckYN -gtksrc %~1 || GOTO ErrorExit
+ SHIFT
+ SHIFT
+ GOTO Parse
+)
+
+IF "%~0" == "-threads" (
+ SET MAKE_THREADS=%~1
+ SHIFT
+ SHIFT
+ GOTO Parse
+)
+
+IF "%~0" == "-addon" (
+ SET "COQ_ADDONS=%COQ_ADDONS% %~1"
+ SHIFT
+ SHIFT
+ GOTO Parse
+)
+
+
+IF NOT "%~0" == "" (
+ ECHO Install cygwin and download, compile and install OCaml and Coq for MinGW
+ ECHO !!! Illegal parameter %~0
+ ECHO Usage:
+ ECHO MakeCoq_MinGW
+ CALL :PrintPars
+ GOTO :EOF
+)
+
+IF NOT EXIST %SETUP% (
+ ECHO The cygwin setup program %SETUP% doesn't exist. You must download it from https://cygwin.com/install.html.
+ ECHO If the setup is in a different folder, set the full path to %SETUP% using the -setup option.
+ GOTO :EOF
+)
+
+REM ========== ADJUST PARAMETERS ==========
+
+IF "%INSTALLMODE%" == "mingwincygwin" (
+ SET DESTCOQ=%DESTCYG%\usr\%ARCH%-w64-mingw32\sys-root\mingw
+)
+
+IF "%MAKEINSTALLER%" == "Y" (
+ SET INSTALLMODE=relocatable
+)
+
+REM ========== CONFIRM PARAMETERS ==========
+
+CALL :PrintPars
+REM Note: DOS batch replaces variables on parsing, so one can't use a variable just set in an () block
+IF "%COQREGTESTING%"=="Y" (GOTO DontAsk)
+ SET /p ANSWER="Is this correct? y/n "
+ IF NOT "%ANSWER%"=="y" (GOTO :EOF)
+:DontAsk
+
+REM ========== DERIVED VARIABLES ==========
+
+SET CYGWIN_INSTALLDIR_WFMT=%DESTCYG%
+SET RESULT_INSTALLDIR_WFMT=%DESTCOQ%
+SET TARGET_ARCH=%ARCH%-w64-mingw32
+SET BASH=%CYGWIN_INSTALLDIR_WFMT%\bin\bash
+
+REM Convert pathes to various formats
+REM WFMT = windows format (C:\..) Used in this batch file.
+REM CFMT = cygwin format (\cygdrive\c\..) Used for Cygwin PATH varible, which is : separated, so C: doesn't work.
+REM MFMT = MinGW format (C:/...) Used for the build, because \\ requires escaping. Mingw can handle \ and /.
+
+SET CYGWIN_INSTALLDIR_MFMT=%CYGWIN_INSTALLDIR_WFMT:\=/%
+SET RESULT_INSTALLDIR_MFMT=%RESULT_INSTALLDIR_WFMT:\=/%
+SET SOURCE_LOCAL_CACHE_MFMT=%SOURCE_LOCAL_CACHE_WFMT:\=/%
+
+SET CYGWIN_INSTALLDIR_CFMT=%CYGWIN_INSTALLDIR_MFMT:C:/=/cygdrive/c/%
+SET RESULT_INSTALLDIR_CFMT=%RESULT_INSTALLDIR_MFMT:C:/=/cygdrive/c/%
+SET SOURCE_LOCAL_CACHE_CFMT=%SOURCE_LOCAL_CACHE_MFMT:C:/=/cygdrive/c/%
+
+SET CYGWIN_INSTALLDIR_CFMT=%CYGWIN_INSTALLDIR_CFMT:D:/=/cygdrive/d/%
+SET RESULT_INSTALLDIR_CFMT=%RESULT_INSTALLDIR_CFMT:D:/=/cygdrive/d/%
+SET SOURCE_LOCAL_CACHE_CFMT=%SOURCE_LOCAL_CACHE_CFMT:D:/=/cygdrive/d/%
+
+SET CYGWIN_INSTALLDIR_CFMT=%CYGWIN_INSTALLDIR_CFMT:E:/=/cygdrive/e/%
+SET RESULT_INSTALLDIR_CFMT=%RESULT_INSTALLDIR_CFMT:E:/=/cygdrive/e/%
+SET SOURCE_LOCAL_CACHE_CFMT=%SOURCE_LOCAL_CACHE_CFMT:E:/=/cygdrive/e/%
+
+ECHO CYGWIN INSTALL DIR (WIN) = %CYGWIN_INSTALLDIR_WFMT%
+ECHO CYGWIN INSTALL DIR (MINGW) = %CYGWIN_INSTALLDIR_MFMT%
+ECHO CYGWIN INSTALL DIR (CYGWIN) = %CYGWIN_INSTALLDIR_CFMT%
+ECHO RESULT INSTALL DIR (WIN) = %RESULT_INSTALLDIR_WFMT%
+ECHO RESULT INSTALL DIR (MINGW) = %RESULT_INSTALLDIR_MFMT%
+ECHO RESULT INSTALL DIR (CYGWIN) = %RESULT_INSTALLDIR_CFMT%
+
+REM WARNING: Add a space after the = in case you want set this to empty, otherwise the variable will be unset
+SET MAKE_OPT=-j %MAKE_THREADS%
+
+REM ========== DERIVED CYGWIN SETUP OPTIONS ==========
+
+REM One can't set a variable to empty in DOS, but you can set it to a space this way.
+REM The quotes are just there to make the space visible and to protect from "remove trailing spaces".
+SET "CYGWIN_OPT= "
+
+IF "%CYGWIN_FROM_CACHE%" == "Y" (
+ SET CYGWIN_OPT= %CYGWIN_OPT% -L
+)
+
+IF "%CYGWIN_QUIET%" == "Y" (
+ SET CYGWIN_OPT= %CYGWIN_OPT% -q --no-admin
+)
+
+IF "%GTK_FROM_SOURCES%"=="N" (
+ SET CYGWIN_OPT= %CYGWIN_OPT% -P mingw64-%ARCH%-gtk2.0,mingw64-%ARCH%-gtksourceview2.0
+)
+
+REM Cygwin setup sets proper ACLs (permissions) for folders it CREATES.
+REM Otherwise chmod won't work and e.g. the ocaml build will fail.
+REM Cygwin setup does not touch the ACLs of existing folders.
+
+REM Run Cygwin Setup
+
+SET RUNSETUP=Y
+IF EXIST "%CYGWIN_INSTALLDIR_WFMT%\etc\setup\installed.db" (
+ SET RUNSETUP=N
+)
+IF NOT "%CYGWIN_QUIET%" == "Y" (
+ SET RUNSETUP=Y
+)
+
+IF "%COQREGTESTING%" == "Y" (
+ ECHO "========== REMOVE EXISTING CYGWIN =========="
+ DEL /S /F /Q "%CYGWIN_INSTALLDIR_WFMT%" > NUL
+ SET RUNSETUP=Y
+)
+
+SET "EXTRAPACKAGES= "
+
+IF NOT "%APPVEYOR%" == "True" (
+ SET EXTRAPACKAGES=-P wget,curl,git,gcc-core,gcc-g++,automake1.5
+)
+
+ECHO "========== INSTALL CYGWIN =========="
+
+IF "%RUNSETUP%"=="Y" (
+ %SETUP% ^
+ --proxy "%PROXY%" ^
+ --site "%CYGWIN_REPOSITORY%" ^
+ --root "%CYGWIN_INSTALLDIR_WFMT%" ^
+ --local-package-dir "%CYGWIN_LOCAL_CACHE_WFMT%" ^
+ --no-shortcuts ^
+ %CYGWIN_OPT% ^
+ -P make,unzip ^
+ -P gdb,liblzma5 ^
+ -P patch,automake1.14 ^
+ -P mingw64-%ARCH%-binutils,mingw64-%ARCH%-gcc-core,mingw64-%ARCH%-gcc-g++,mingw64-%ARCH%-pkg-config,mingw64-%ARCH%-windows_default_manifest ^
+ -P mingw64-%ARCH%-headers,mingw64-%ARCH%-runtime,mingw64-%ARCH%-pthreads,mingw64-%ARCH%-zlib ^
+ -P libiconv-devel,libunistring-devel,libncurses-devel ^
+ -P gettext-devel,libgettextpo-devel ^
+ -P libglib2.0-devel,libgdk_pixbuf2.0-devel ^
+ -P libfontconfig1 ^
+ -P gtk-update-icon-cache ^
+ -P libtool,automake ^
+ -P intltool ^
+ %EXTRAPACKAGES% ^
+ || GOTO ErrorExit
+
+ MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build"
+ MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build\buildlogs"
+)
+
+IF NOT "%CYGWIN_QUIET%" == "Y" (
+ REM Like most setup programs, cygwin setup starts the real setup as a separate process, so wait for it.
+ REM This is not required with the -cygquiet=Y and the resulting --no-admin option.
+ :waitsetup
+ tasklist /fi "imagename eq %SETUP%" | find ":" > NUL
+ IF ERRORLEVEL 1 GOTO waitsetup
+)
+
+ECHO ========== CONFIGURE CYGWIN USER ACCOUNT ==========
+
+REM In case this batch file is called from a cygwin bash (e.g. a git repo) we need to clear
+REM HOME (otherwise we get to the home directory of the other installation)
+REM PROFILEREAD (this is set to true if the /etc/profile has been read, which creates user)
+SET "HOME="
+SET "PROFILEREAD="
+
+copy "%BATCHDIR%\configure_profile.sh" "%CYGWIN_INSTALLDIR_WFMT%\var\tmp" || GOTO ErrorExit
+%BASH% --login "%CYGWIN_INSTALLDIR_CFMT%\var\tmp\configure_profile.sh" "%PROXY%" || GOTO ErrorExit
+
+ECHO ========== BUILD COQ ==========
+
+MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build"
+MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build\patches"
+
+COPY "%BATCHDIR%\makecoq_mingw.sh" "%CYGWIN_INSTALLDIR_WFMT%\build" || GOTO ErrorExit
+COPY "%BATCHDIR%\patches_coq\*.*" "%CYGWIN_INSTALLDIR_WFMT%\build\patches" || GOTO ErrorExit
+
+%BASH% --login "%CYGWIN_INSTALLDIR_CFMT%\build\makecoq_mingw.sh" || GOTO ErrorExit
+
+ECHO ========== FINISHED ==========
+
+GOTO :EOF
+
+ECHO ========== BATCH FUNCTIONS ==========
+
+:PrintPars
+ REM 01234567890123456789012345678901234567890123456789012345678901234567890123456789
+ ECHO -arch ^<i686 or x86_64^> Set cygwin, ocaml and coq to 32 or 64 bit
+ ECHO -mode ^<mingwincygwin = install coq in default cygwin mingw sysroot^>
+ ECHO ^<absoloute = install coq in -destcoq absulute path^>
+ ECHO ^<relocatable = install relocatable coq in -destcoq path^>
+ ECHO -installer^<Y or N^> create a windows installer (will be in /build/coq/dev/nsis)
+ ECHO -ocaml ^<Y or N^> install OCaml in Coq folder (Y) or just in cygwin folder (N)
+ ECHO -make ^<Y or N^> install GNU Make in Coq folder (Y) or not (N)
+ ECHO -destcyg ^<path to cygwin destination folder^>
+ ECHO -destcoq ^<path to coq destination folder (mode=absoloute/relocatable)^>
+ ECHO -setup ^<cygwin setup program name^> (auto adjusted to -arch)
+ ECHO -proxy ^<internet proxy^>
+ ECHO -cygrepo ^<cygwin download repository^>
+ ECHO -cygcache ^<local cygwin repository/cache^>
+ ECHO -cyglocal ^<Y or N^> install cygwin from cache
+ ECHO -cygquiet ^<Y or N^> install cygwin without user interaction
+ ECHO -srccache ^<local source code repository/cache^>
+ ECHO -coqver ^<Coq version to install^>
+ ECHO -gtksrc ^<Y or N^> build GTK ^(90 min^) or use cygwin version
+ ECHO -threads ^<1..N^> Number of make threads
+ ECHO -addon ^<name^> Enable building selected addon (can be repeated)
+ ECHO(
+ ECHO See ReadMe.txt for a detailed description of all parameters
+ ECHO(
+ ECHO Parameter values (default or currently set):
+ ECHO -arch = %ARCH%
+ ECHO -mode = %INSTALLMODE%
+ ECHO -ocaml = %INSTALLOCAML%
+ ECHO -installer= %MAKEINSTALLER%
+ ECHO -make = %INSTALLMAKE%
+ ECHO -destcyg = %DESTCYG%
+ ECHO -destcoq = %DESTCOQ%
+ ECHO -setup = %SETUP%
+ ECHO -proxy = %PROXY%
+ ECHO -cygrepo = %CYGWIN_REPOSITORY%
+ ECHO -cygcache = %CYGWIN_LOCAL_CACHE_WFMT%
+ ECHO -cyglocal = %CYGWIN_FROM_CACHE%
+ ECHO -cygquiet = %CYGWIN_QUIET%
+ ECHO -srccache = %SOURCE_LOCAL_CACHE_WFMT%
+ ECHO -coqver = %COQ_VERSION%
+ ECHO -gtksrc = %GTK_FROM_SOURCES%
+ ECHO -threads = %MAKE_THREADS%
+ ECHO -addon = %COQ_ADDONS%
+ GOTO :EOF
+
+:CheckYN
+ REM Reset errorlevel to 0
+ CMD /c "EXIT /b 0"
+ IF "%2" == "Y" (
+ REM OK Y
+ ) ELSE IF "%2" == "N" (
+ REM OK N
+ ) ELSE (
+ ECHO ERROR Parameter %1 must be Y or N, but is %2
+ GOTO ErrorExit
+ )
+ GOTO :EOF
+
+:ErrorExit
+ ECHO ERROR MakeCoq_MinGW.bat failed
+ EXIT /b 1
diff --git a/dev/build/windows/ReadMe.txt b/dev/build/windows/ReadMe.txt index 93851aeb8d..a392115ea4 100644 --- a/dev/build/windows/ReadMe.txt +++ b/dev/build/windows/ReadMe.txt @@ -369,8 +369,6 @@ Text files patched by the installer: Text files containing the install folder path after install: -./bin/mkcamlp5:LIB=D:/bin/coq64_buildtest_reloc_ocaml20/libocaml/camlp5 -./bin/mkcamlp5.opt:LIB=D:/bin/coq64_buildtest_reloc_ocaml20/libocaml/camlp5 ./libocaml/Makefile.config:PREFIX=D:/bin/coq64_buildtest_reloc_ocaml20 ./libocaml/Makefile.config:LIBDIR=D:/bin/coq64_buildtest_reloc_ocaml20/libocaml ./libocaml/site-lib/findlib/Makefile.config:OCAML_CORE_BIN=/cygdrive/d/bin/coq64_buildtest_reloc_ocaml20/bin @@ -382,8 +380,6 @@ Text files containing the install folder path after install: ./libocaml/topfind: Topdirs.dir_load Format.err_formatter "D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib/findlib/findlib_top.cma"; ./libocaml/topfind:(* #load "D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib/findlib/findlib.cma";; *) ./libocaml/topfind:(* #load "D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib/findlib/findlib_top.cma";; *) -./man/man1/camlp5.1:These files are installed in the directory D:/bin/coq64_buildtest_reloc_ocaml20/libocaml/camlp5. -./man/man1/camlp5.1:D:/bin/coq64_buildtest_reloc_ocaml20/libocaml/camlp5 Binary files containing the build folder path after install: @@ -398,26 +394,6 @@ Binary file ./libocaml/ocamldoc/odoc_info.cma matches Binary files containing the install folder path after install: $ find . -type f -exec grep "coq64_buildtest_reloc_ocaml20" {} /dev/null \; -Binary file ./bin/camlp4.exe matches -Binary file ./bin/camlp4boot.exe matches -Binary file ./bin/camlp4o.exe matches -Binary file ./bin/camlp4o.opt.exe matches -Binary file ./bin/camlp4of.exe matches -Binary file ./bin/camlp4of.opt.exe matches -Binary file ./bin/camlp4oof.exe matches -Binary file ./bin/camlp4oof.opt.exe matches -Binary file ./bin/camlp4orf.exe matches -Binary file ./bin/camlp4orf.opt.exe matches -Binary file ./bin/camlp4r.exe matches -Binary file ./bin/camlp4r.opt.exe matches -Binary file ./bin/camlp4rf.exe matches -Binary file ./bin/camlp4rf.opt.exe matches -Binary file ./bin/camlp5.exe matches -Binary file ./bin/camlp5o.exe matches -Binary file ./bin/camlp5o.opt matches -Binary file ./bin/camlp5r.exe matches -Binary file ./bin/camlp5r.opt matches -Binary file ./bin/camlp5sch.exe matches Binary file ./bin/coqc.exe matches Binary file ./bin/coqchk.exe matches Binary file ./bin/coqdep.exe matches @@ -428,11 +404,7 @@ Binary file ./bin/coqtop.exe matches Binary file ./bin/coqworkmgr.exe matches Binary file ./bin/coq_makefile.exe matches Binary file ./bin/menhir matches -Binary file ./bin/mkcamlp4.exe matches Binary file ./bin/ocaml.exe matches -Binary file ./bin/ocamlbuild.byte.exe matches -Binary file ./bin/ocamlbuild.exe matches -Binary file ./bin/ocamlbuild.native.exe matches Binary file ./bin/ocamlc.exe matches Binary file ./bin/ocamlc.opt.exe matches Binary file ./bin/ocamldebug.exe matches @@ -455,17 +427,6 @@ Binary file ./lib/ide/ide_win32_stubs.o matches Binary file ./lib/lib/clib.a matches Binary file ./lib/lib/clib.cma matches Binary file ./lib/libcoqrun.a matches -Binary file ./libocaml/camlp4/camlp4fulllib.a matches -Binary file ./libocaml/camlp4/camlp4fulllib.cma matches -Binary file ./libocaml/camlp4/camlp4lib.a matches -Binary file ./libocaml/camlp4/camlp4lib.cma matches -Binary file ./libocaml/camlp4/camlp4o.cma matches -Binary file ./libocaml/camlp4/camlp4of.cma matches -Binary file ./libocaml/camlp4/camlp4oof.cma matches -Binary file ./libocaml/camlp4/camlp4orf.cma matches -Binary file ./libocaml/camlp4/camlp4r.cma matches -Binary file ./libocaml/camlp4/camlp4rf.cma matches -Binary file ./libocaml/camlp5/odyl.cma matches Binary file ./libocaml/compiler-libs/ocamlcommon.a matches Binary file ./libocaml/compiler-libs/ocamlcommon.cma matches Binary file ./libocaml/dynlink.cma matches diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index b202635714..2e934ff0c0 100755 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -444,9 +444,6 @@ function load_overlay_data { else export CI_BRANCH="" export CI_PULL_REQUEST="" - # Used when building 8.8.0 with the latest scripts - export TRAVIS_BRANCH="" - export TRAVIS_PULL_REQUEST="" fi for overlay in /build/user-overlays/*.sh; do @@ -691,7 +688,7 @@ function installer_addon_end { # ------------------------------------------------------------------------------ function coq_set_timeouts_1000 { - find . -type f -name '*.v' -print0 | xargs -0 sed -i 's/timeout\s\+[0-9]\+/timeout 1000/' + find . -type f -name '*.v' -print0 | xargs -0 sed -i 's/timeout\s\+[0-9]\+/timeout 1000/g' } ###################### MODULE BUILD FUNCTIONS ##################### @@ -701,7 +698,7 @@ function coq_set_timeouts_1000 { function make_sed { if build_prep https://ftp.gnu.org/gnu/sed/ sed-4.2.2 tar.gz ; then logn configure ./configure - log1 make + log1 make $MAKE_OPT log2 make install log2 make clean build_post @@ -1107,7 +1104,7 @@ function make_ocamlbuild { make_ocaml if build_prep https://github.com/ocaml/ocamlbuild/archive 0.12.0 tar.gz 1 ocamlbuild-0.12.0; then log2 make configure OCAML_NATIVE=true OCAMLBUILD_PREFIX=$PREFIXOCAML OCAMLBUILD_BINDIR=$PREFIXOCAML/bin OCAMLBUILD_LIBDIR=$PREFIXOCAML/lib - log1 make + log1 make $MAKE_OPT log2 make install build_post fi @@ -1634,7 +1631,7 @@ function make_addon_bignums { installer_addon_section bignums "Bignums" "Coq library for fast arbitrary size numbers" "" # To make command lines shorter :-( echo 'COQ_SRC_SUBDIRS:=$(filter-out plugins/%,$(COQ_SRC_SUBDIRS)) plugins/syntax' >> Makefile.coq.local - log1 make all + log1 make $MAKE_OPT all log2 make install build_post fi @@ -1650,7 +1647,7 @@ function make_addon_equations { # Note: PATH is automatically saved/restored by build_prep / build_post PATH=$COQBIN:$PATH logn coq_makefile ${COQBIN}coq_makefile -f _CoqProject -o Makefile - log1 make + log1 make $MAKE_OPT log2 make install build_post fi @@ -1696,7 +1693,7 @@ function make_addon_ltac2 { installer_addon_dependency ltac2 if build_prep_overlay ltac2; then installer_addon_section ltac2 "Ltac-2" "Coq plugin with the Ltac-2 enhanced tactic language" "" - log1 make all + log1 make $MAKE_OPT all log2 make install build_post fi @@ -1709,7 +1706,7 @@ function make_addon_unicoq { if build_prep_overlay unicoq; then installer_addon_section unicoq "Unicoq" "Coq plugin for an enhanced unification algorithm" "" log1 coq_makefile -f Make -o Makefile - log1 make + log1 make $MAKE_OPT log2 make install build_post fi @@ -1724,7 +1721,7 @@ function make_addon_mtac2 { if build_prep_overlay mtac2; then installer_addon_section mtac2 "Mtac-2" "Coq plugin for a typed tactic language for Coq." "" log1 coq_makefile -f _CoqProject -o Makefile - log1 make + log1 make $MAKE_OPT log2 make install build_post fi @@ -1766,7 +1763,7 @@ function make_addon_menhirlib { echo -R . MenhirLib > _CoqProject ls -1 *.v >> _CoqProject log1 coq_makefile -f _CoqProject -o Makefile.coq - log1 make -f Makefile.coq all + log1 make -f Makefile.coq $MAKE_OPT all logn make-install make -f Makefile.coq install build_post fi @@ -1779,10 +1776,10 @@ function make_addon_compcert { make_menhir make_addon_menhirlib installer_addon_dependency_end - if build_prep_overlay CompCert; then + if build_prep_overlay compcert; then installer_addon_section compcert "CompCert" "ATTENTION: THIS IS NOT OPEN SOURCE! CompCert verified C compiler and Clightgen (required for using VST for your own code)" "off" logn configure ./configure -ignore-coq-version -clightgen -prefix "$PREFIXCOQ" -coqdevdir "$PREFIXCOQ/lib/coq/user-contrib/compcert" x86_32-cygwin - log1 make + log1 make $MAKE_OPT log2 make install logn install-license-1 install -D -T "LICENSE" "$PREFIXCOQ/lib/coq/user-contrib/compcert/LICENSE" logn install-license-2 install -D -T "LICENSE" "$PREFIXCOQ/lib/compcert/LICENSE" @@ -1807,8 +1804,8 @@ function install_addon_vst { install_glob "progs" '*.v' "$VSTDEST/progs/" install_glob "progs" '*.c' "$VSTDEST/progs/" install_glob "progs" '*.h' "$VSTDEST/progs/" - install_glob "veric" '*.v' "$VSTDEST/msl/" - install_glob "veric" '*.vo' "$VSTDEST/msl/" + install_glob "veric" '*.v' "$VSTDEST/veric/" + install_glob "veric" '*.vo' "$VSTDEST/veric/" # Install VST documentation files install_glob "." 'LICENSE' "$VSTDEST" @@ -1821,12 +1818,20 @@ function install_addon_vst { install_glob "." '_CoqProject-export' "$VSTDEST/progs" } +function vst_patch_compcert_refs { + find . -type f -name '*.v' -print0 | xargs -0 sed -E -i \ + -e 's/(Require\s+(Import\s+|Export\s+)*)compcert\./\1VST.compcert./g' \ + -e 's/From compcert Require/From VST.compcert Require/g' +} + function make_addon_vst { installer_addon_dependency vst - if build_prep_overlay VST; then + if build_prep_overlay vst; then installer_addon_section vst "VST" "ATTENTION: SOME INCLUDED COMPCERT PARTS ARE NOT OPEN SOURCE! Verified Software Toolchain for verifying C code" "off" - log1 coq_set_timeouts_1000 - log1 make IGNORECOQVERSION=true $MAKE_OPT + # log1 coq_set_timeouts_1000 + log1 vst_patch_compcert_refs + # The usage of the shell variable ARCH in VST collides with the usage in this shellscript + logn make env -u ARCH make IGNORECOQVERSION=true $MAKE_OPT log1 install_addon_vst build_post fi @@ -1851,9 +1856,9 @@ function make_addon_coquelicot { function make_addon_aactactics { installer_addon_dependency aac - if build_prep_overlay aactactics; then + if build_prep_overlay aac_tactics; then installer_addon_section aac "AAC" "Coq plugin for extensible associative and commutative rewriting" "" - log1 make + log1 make $MAKE_OPT log2 make install build_post fi @@ -1894,7 +1899,7 @@ function make_addon_quickchick { installer_addon_dependency_end if build_prep_overlay quickchick; then installer_addon_section quickchick "QuickChick" "Coq plugin for randomized testing and counter example search" "" - log1 make + log1 make $MAKE_OPT log2 make install build_post fi diff --git a/dev/build/windows/patches_coq/VST.patch b/dev/build/windows/patches_coq/VST.patch new file mode 100755 index 0000000000..2c8c46373f --- /dev/null +++ b/dev/build/windows/patches_coq/VST.patch @@ -0,0 +1,15 @@ +diff --git a/Makefile b/Makefile +index 4a119042..fdfac13e 100755 +--- a/Makefile ++++ b/Makefile +@@ -76,8 +76,8 @@ endif + + COMPCERTDIRS=lib common $(ARCHDIRS) cfrontend flocq exportclight $(BACKEND) + +-COMPCERT_R_FLAGS= $(foreach d, $(COMPCERTDIRS), -R $(COMPCERT)/$(d) compcert.$(d)) +-EXTFLAGS= $(foreach d, $(COMPCERTDIRS), -Q $(COMPCERT)/$(d) compcert.$(d)) ++COMPCERT_R_FLAGS= $(foreach d, $(COMPCERTDIRS), -R $(COMPCERT)/$(d) VST.compcert.$(d)) ++EXTFLAGS= $(foreach d, $(COMPCERTDIRS), -Q $(COMPCERT)/$(d) VST.compcert.$(d)) + + # for SSReflect + ifdef MATHCOMP diff --git a/dev/build/windows/patches_coq/camlp4-4.02+6.patch b/dev/build/windows/patches_coq/camlp4-4.02+6.patch deleted file mode 100644 index 0cdb4a929b..0000000000 --- a/dev/build/windows/patches_coq/camlp4-4.02+6.patch +++ /dev/null @@ -1,11 +0,0 @@ ---- camlp4-4.02-6.orig/myocamlbuild.ml 2015-06-17 13:37:36.000000000 +0200 -+++ camlp4-4.02+6/myocamlbuild.ml 2016-10-13 13:57:35.512213600 +0200 -@@ -86,7 +86,7 @@ - let dep = "camlp4"/"boot"/exe in - let cmd = - let ( / ) = Filename.concat in -- "camlp4"/"boot"/exe -+ String.escaped (String.escaped ("camlp4"/"boot"/exe)) - in - (Some dep, cmd) - in diff --git a/dev/build/windows/patches_coq/coq-8.4pl2.patch b/dev/build/windows/patches_coq/coq-8.4pl2.patch deleted file mode 100644 index 45a66d0bfa..0000000000 --- a/dev/build/windows/patches_coq/coq-8.4pl2.patch +++ /dev/null @@ -1,11 +0,0 @@ ---- configure 2014-04-14 22:28:39.174177924 +0200 -+++ configure 2014-04-14 22:29:23.253025166 +0200 -@@ -335,7 +335,7 @@ - MAKEVERSION=`$MAKE -v | head -1 | cut -d" " -f3` - MAKEVERSIONMAJOR=`echo $MAKEVERSION | cut -d. -f1` - MAKEVERSIONMINOR=`echo $MAKEVERSION | cut -d. -f2` -- if [ "$MAKEVERSIONMAJOR" -eq 3 -a "$MAKEVERSIONMINOR" -ge 81 ]; then -+ if [ "$MAKEVERSIONMAJOR" -eq 3 -a "$MAKEVERSIONMINOR" -ge 81 ] || [ "$MAKEVERSIONMAJOR" -ge 4 ] ; then - echo "You have GNU Make $MAKEVERSION. Good!" - else - OK="no"
\ No newline at end of file diff --git a/dev/build/windows/patches_coq/coq-8.4pl6.patch b/dev/build/windows/patches_coq/coq-8.4pl6.patch deleted file mode 100644 index c3b7f8574e..0000000000 --- a/dev/build/windows/patches_coq/coq-8.4pl6.patch +++ /dev/null @@ -1,13 +0,0 @@ -coq-8.4pl6.orig ---- coq-8.4pl6.orig/configure 2015-04-09 15:59:35.000000000 +0200 -+++ coq-8.4pl6//configure 2016-11-09 13:29:42.235319800 +0100 -@@ -309,9 +309,6 @@ - # executable extension - - case "$ARCH,$CYGWIN" in -- win32,yes) -- EXE=".exe" -- DLLEXT=".so";; - win32,*) - EXE=".exe" - DLLEXT=".dll";; diff --git a/dev/build/windows/patches_coq/flexdll-0.34.patch b/dev/build/windows/patches_coq/flexdll-0.34.patch deleted file mode 100644 index 16389baca3..0000000000 --- a/dev/build/windows/patches_coq/flexdll-0.34.patch +++ /dev/null @@ -1,14 +0,0 @@ -reloc.ml ---- orig.flexdll-0.34/reloc.ml 2015-01-22 17:30:07.000000000 +0100 -+++ flexdll-0.34/reloc.ml 2016-10-12 11:59:16.885829700 +0200 -@@ -117,8 +117,8 @@ - - let new_cmdline () = - let rf = match !toolchain with -- | `MSVC | `MSVC64 | `LIGHTLD -> true -- | `MINGW | `MINGW64 | `GNAT | `CYGWIN | `CYGWIN64 -> false -+ | `MSVC | `MSVC64 | `LIGHTLD | `MINGW | `MINGW64 -> true -+ | `GNAT | `CYGWIN | `CYGWIN64 -> false - in - { - may_use_response_file = rf; diff --git a/dev/build/windows/patches_coq/glib-2.46.0.patch b/dev/build/windows/patches_coq/glib-2.46.0.patch deleted file mode 100644 index 9082460bf0..0000000000 --- a/dev/build/windows/patches_coq/glib-2.46.0.patch +++ /dev/null @@ -1,30 +0,0 @@ -diff -u -r glib-2.46.0/gio/glocalfile.c glib-2.46.0.patched/gio/glocalfile.c ---- glib-2.46.0/gio/glocalfile.c 2015-08-27 05:32:26.000000000 +0200 -+++ glib-2.46.0.patched/gio/glocalfile.c 2016-01-27 13:08:30.059736400 +0100 -@@ -2682,7 +2682,10 @@ - (!g_path_is_absolute (filename) || len > g_path_skip_root (filename) - filename)) - wfilename[len] = '\0'; - -- retval = _wstat32i64 (wfilename, &buf); -+ // MSoegtrop: _wstat32i64 is the wrong function for GLocalFileStat = struct _stati64 -+ // The correct function is _wstati64, see https://msdn.microsoft.com/en-us/library/14h5k7ff.aspx -+ // Also _wstat32i64 is a VC function, not a windows SDK function, see https://msdn.microsoft.com/en-us/library/aa273365(v=vs.60).aspx -+ retval = _wstati64 (wfilename, &buf); - save_errno = errno; - - g_free (wfilename); -diff -u -r glib-2.46.0/glib/gstdio.c glib-2.46.0.patched/glib/gstdio.c ---- glib-2.46.0/glib/gstdio.c 2015-02-26 13:57:09.000000000 +0100 -+++ glib-2.46.0.patched/glib/gstdio.c 2016-01-27 13:31:12.708987700 +0100 -@@ -493,7 +493,10 @@ - (!g_path_is_absolute (filename) || len > g_path_skip_root (filename) - filename)) - wfilename[len] = '\0'; - -- retval = _wstat (wfilename, buf); -+ // MSoegtrop: _wstat32i64 is the wrong function for GLocalFileStat = struct _stati64 -+ // The correct function is _wstati64, see https://msdn.microsoft.com/en-us/library/14h5k7ff.aspx -+ // Also _wstat32i64 is a VC function, not a windows SDK function, see https://msdn.microsoft.com/en-us/library/aa273365(v=vs.60).aspx -+ retval = _wstati64 (wfilename, buf); - save_errno = errno; - - g_free (wfilename); diff --git a/dev/build/windows/patches_coq/lablgtk-2.18.3.patch b/dev/build/windows/patches_coq/lablgtk-2.18.3.patch deleted file mode 100644 index 23c303135d..0000000000 --- a/dev/build/windows/patches_coq/lablgtk-2.18.3.patch +++ /dev/null @@ -1,101 +0,0 @@ -diff/patch file created on Wed, Apr 25, 2018 11:08:05 AM with: -difftar-folder.sh ../coq-msoegtrop/dev/build/windows/source_cache/lablgtk-2.18.3.tar.gz lablgtk-2.18.3 1 -TARFILE= ../coq-msoegtrop/dev/build/windows/source_cache/lablgtk-2.18.3.tar.gz -FOLDER= lablgtk-2.18.3 -TARSTRIP= 1 -TARPREFIX= lablgtk-2.18.3/ -ORIGFOLDER= lablgtk-2.18.3.orig ---- lablgtk-2.18.3.orig/configure 2014-10-29 08:51:05.000000000 +0100 -+++ lablgtk-2.18.3/configure 2018-04-25 10:58:54.454501600 +0200 -@@ -2667,7 +2667,7 @@ - fi - - --if test "`$OCAMLFIND printconf stdlib`" != "`$CAMLC -where`"; then -+if test "`$OCAMLFIND printconf stdlib | tr '\\' '/'`" != "`$CAMLC -where | tr '\\' '/'`"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Ignoring ocamlfind" >&5 - $as_echo "$as_me: WARNING: Ignoring ocamlfind" >&2;} - OCAMLFIND=no ---- lablgtk-2.18.3.orig/src/glib.mli 2014-10-29 08:51:06.000000000 +0100 -+++ lablgtk-2.18.3/src/glib.mli 2018-04-25 10:58:54.493555500 +0200 -@@ -75,6 +75,7 @@ - type condition = [ `ERR | `HUP | `IN | `NVAL | `OUT | `PRI] - type id - val channel_of_descr : Unix.file_descr -> channel -+ val channel_of_descr_socket : Unix.file_descr -> channel - val add_watch : - cond:condition list -> callback:(condition list -> bool) -> ?prio:int -> channel -> id - val remove : id -> unit ---- lablgtk-2.18.3.orig/src/glib.ml 2014-10-29 08:51:06.000000000 +0100 -+++ lablgtk-2.18.3/src/glib.ml 2018-04-25 10:58:54.479543500 +0200 -@@ -72,6 +72,8 @@ - type id - external channel_of_descr : Unix.file_descr -> channel - = "ml_g_io_channel_unix_new" -+ external channel_of_descr_socket : Unix.file_descr -> channel -+ = "ml_g_io_channel_unix_new_socket" - external remove : id -> unit = "ml_g_source_remove" - external add_watch : - cond:condition list -> callback:(condition list -> bool) -> ?prio:int -> channel -> id ---- lablgtk-2.18.3.orig/src/Makefile 2014-10-29 08:51:06.000000000 +0100 -+++ lablgtk-2.18.3/src/Makefile 2018-04-25 10:58:54.506522500 +0200 -@@ -461,9 +461,9 @@ - do rm -f "$(BINDIR)"/$$f; done - - lablgtk.cma liblablgtk2$(XA): $(COBJS) $(MLOBJS) -- $(LIBRARIAN) -o lablgtk -oc lablgtk2 $^ $(GTKLIBS) -+ $(LIBRARIAN) -ldopt "-link -Wl,-s" -o lablgtk -oc lablgtk2 $^ $(GTKLIBS) - lablgtk.cmxa: $(COBJS) $(MLOBJS:.cmo=.cmx) -- $(LIBRARIAN) -o lablgtk -oc lablgtk2 $^ $(GTKLIBS) -+ $(LIBRARIAN) -ldopt "-link -Wl,-s" -o lablgtk -oc lablgtk2 $^ $(GTKLIBS) - lablgtk.cmxs: DYNLINKLIBS=$(GTK_LIBS) - - lablgtkgl.cma liblablgtkgl2$(XA): $(GLCOBJS) $(GLMLOBJS) ---- lablgtk-2.18.3.orig/src/ml_glib.c 2014-10-29 08:51:06.000000000 +0100 -+++ lablgtk-2.18.3/src/ml_glib.c 2018-04-25 10:58:54.539535600 +0200 -@@ -25,6 +25,8 @@ - #include <string.h> - #include <locale.h> - #ifdef _WIN32 -+/* to kill a #warning: include winsock2.h before windows.h */ -+#include <winsock2.h> - #include "win32.h" - #include <wtypes.h> - #include <io.h> -@@ -38,6 +40,11 @@ - #include <caml/callback.h> - #include <caml/threads.h> - -+#ifdef _WIN32 -+/* for Socket_val */ -+#include <caml/unixsupport.h> -+#endif -+ - #include "wrappers.h" - #include "ml_glib.h" - #include "glib_tags.h" -@@ -325,14 +332,23 @@ - - #ifndef _WIN32 - ML_1 (g_io_channel_unix_new, Int_val, Val_GIOChannel_noref) -+CAMLprim value ml_g_io_channel_unix_new_socket (value arg1) { -+ return Val_GIOChannel_noref (g_io_channel_unix_new (Int_val (arg1))); -+} - - #else - CAMLprim value ml_g_io_channel_unix_new(value wh) - { - return Val_GIOChannel_noref -- (g_io_channel_unix_new -+ (g_io_channel_win32_new_fd - (_open_osfhandle((long)*(HANDLE*)Data_custom_val(wh), O_BINARY))); - } -+ -+CAMLprim value ml_g_io_channel_unix_new_socket(value wh) -+{ -+ return Val_GIOChannel_noref -+ (g_io_channel_win32_new_socket(Socket_val(wh))); -+} - #endif - - static gboolean ml_g_io_channel_watch(GIOChannel *s, GIOCondition c, diff --git a/dev/build/windows/patches_coq/sed-4.2.2-3.src.patch b/dev/build/windows/patches_coq/sed-4.2.2-3.src.patch index d210a04153..d210a04153 100755..100644 --- a/dev/build/windows/patches_coq/sed-4.2.2-3.src.patch +++ b/dev/build/windows/patches_coq/sed-4.2.2-3.src.patch diff --git a/dev/build/windows/patches_coq/sed-4.2.2.patch b/dev/build/windows/patches_coq/sed-4.2.2.patch index c7ccd53c7f..c7ccd53c7f 100755..100644 --- a/dev/build/windows/patches_coq/sed-4.2.2.patch +++ b/dev/build/windows/patches_coq/sed-4.2.2.patch diff --git a/dev/ci/README-developers.md b/dev/ci/README-developers.md index fa8962a06f..10b4f9b044 100644 --- a/dev/ci/README-developers.md +++ b/dev/ci/README-developers.md @@ -10,18 +10,18 @@ We are currently running tests on the following platforms: - GitLab CI is the main CI platform. It tests the compilation of Coq, of the documentation, and of CoqIDE on Linux with several versions of OCaml and with warnings as errors; it runs the test-suite and - tests the compilation of several external developments. - -- Travis CI is used to test the compilation of Coq and run the test-suite on - macOS. It also runs a linter that checks whitespace discipline. A - [pre-commit hook](../tools/pre-commit) is automatically installed by - `./configure`. It should allow complying with this discipline without pain. + tests the compilation of several external developments. It also runs + a linter that checks whitespace discipline. A [pre-commit + hook](../tools/pre-commit) is automatically installed by + `./configure`. It should allow complying with this discipline + without pain. - AppVeyor is used to test the compilation of Coq and run the test-suite on Windows. - Azure Pipelines is used to test the compilation of Coq and run the - test-suite on Windows. It is expected to replace appveyor eventually. + test-suite on Windows and on macOS. It is expected to replace + appveyor eventually. You can anticipate the results of most of these tests prior to submitting your PR by running GitLab CI on your private branches. To do so follow these steps: diff --git a/dev/ci/appveyor.bat b/dev/ci/appveyor.bat index 85a71baf7f..341b875edc 100644 --- a/dev/ci/appveyor.bat +++ b/dev/ci/appveyor.bat @@ -1,42 +1,42 @@ -REM This script either runs the test suite with OPAM (if USEOPAM is true) or -REM builds the Coq binary packages for windows (if USEOPAM is false). - -if %ARCH% == 32 ( - SET ARCHLONG=i686 - SET CYGROOT=C:\cygwin - SET SETUP=setup-x86.exe -) - -if %ARCH% == 64 ( - SET ARCHLONG=x86_64 - SET CYGROOT=C:\cygwin64 - SET SETUP=setup-x86_64.exe -) - -SET CYGCACHE=%CYGROOT%\var\cache\setup -SET APPVEYOR_BUILD_FOLDER_MFMT=%APPVEYOR_BUILD_FOLDER:\=/% -SET APPVEYOR_BUILD_FOLDER_CFMT=%APPVEYOR_BUILD_FOLDER_MFMT:C:/=/cygdrive/c/% -SET DESTCOQ=C:\coq%ARCH%_inst -SET COQREGTESTING=Y - -if %USEOPAM% == false ( - call %APPVEYOR_BUILD_FOLDER%\dev\build\windows\MakeCoq_MinGW.bat -threads=1 ^ - -arch=%ARCH% -installer=Y -coqver=%APPVEYOR_BUILD_FOLDER_CFMT% ^ - -destcyg=%CYGROOT% -destcoq=%DESTCOQ% -cygcache=%CYGCACHE% ^ - -addon=bignums -make=N ^ - -setup %CYGROOT%\%SETUP% || GOTO ErrorExit - copy "%CYGROOT%\build\coq-local\dev\nsis\*.exe" dev\nsis || GOTO ErrorExit - 7z a coq-opensource-archive-windows-%ARCHLONG%.zip %CYGROOT%\build\tarballs\* || GOTO ErrorExit -) - -if %USEOPAM% == true ( - %CYGROOT%\%SETUP% -qnNdO -R %CYGROOT% -l %CYGCACHE% -s %CYGMIRROR% ^ - -P rsync -P patch -P diffutils -P make -P unzip -P m4 -P findutils -P time - %CYGROOT%/bin/bash -l %APPVEYOR_BUILD_FOLDER%/dev/ci/appveyor.sh || GOTO ErrorExit -) - -GOTO :EOF - -:ErrorExit - ECHO ERROR %0 failed - EXIT /b 1 +REM This script either runs the test suite with OPAM (if USEOPAM is true) or
+REM builds the Coq binary packages for windows (if USEOPAM is false).
+
+if %ARCH% == 32 (
+ SET ARCHLONG=i686
+ SET CYGROOT=C:\cygwin
+ SET SETUP=setup-x86.exe
+)
+
+if %ARCH% == 64 (
+ SET ARCHLONG=x86_64
+ SET CYGROOT=C:\cygwin64
+ SET SETUP=setup-x86_64.exe
+)
+
+SET CYGCACHE=%CYGROOT%\var\cache\setup
+SET APPVEYOR_BUILD_FOLDER_MFMT=%APPVEYOR_BUILD_FOLDER:\=/%
+SET APPVEYOR_BUILD_FOLDER_CFMT=%APPVEYOR_BUILD_FOLDER_MFMT:C:/=/cygdrive/c/%
+SET DESTCOQ=C:\coq%ARCH%_inst
+SET COQREGTESTING=Y
+
+if %USEOPAM% == false (
+ call %APPVEYOR_BUILD_FOLDER%\dev\build\windows\MakeCoq_MinGW.bat -threads=1 ^
+ -arch=%ARCH% -installer=Y -coqver=%APPVEYOR_BUILD_FOLDER_CFMT% ^
+ -destcyg=%CYGROOT% -destcoq=%DESTCOQ% -cygcache=%CYGCACHE% ^
+ -addon=bignums -make=N ^
+ -setup %CYGROOT%\%SETUP% || GOTO ErrorExit
+ copy "%CYGROOT%\build\coq-local\dev\nsis\*.exe" dev\nsis || GOTO ErrorExit
+ 7z a coq-opensource-archive-windows-%ARCHLONG%.zip %CYGROOT%\build\tarballs\* || GOTO ErrorExit
+)
+
+if %USEOPAM% == true (
+ %CYGROOT%\%SETUP% -qnNdO -R %CYGROOT% -l %CYGCACHE% -s %CYGMIRROR% ^
+ -P rsync -P patch -P diffutils -P make -P unzip -P m4 -P findutils -P time
+ %CYGROOT%/bin/bash -l %APPVEYOR_BUILD_FOLDER%/dev/ci/appveyor.sh || GOTO ErrorExit
+)
+
+GOTO :EOF
+
+:ErrorExit
+ ECHO ERROR %0 failed
+ EXIT /b 1
diff --git a/dev/ci/appveyor.sh b/dev/ci/appveyor.sh index 470d07b27d..f26e0904bc 100644 --- a/dev/ci/appveyor.sh +++ b/dev/ci/appveyor.sh @@ -3,14 +3,15 @@ set -e -x APPVEYOR_OPAM_VARIANT=ocaml-variants.4.07.1+mingw64c +NJOBS=2 wget https://github.com/fdopen/opam-repository-mingw/releases/download/0.0.0.2/opam64.tar.xz -O opam64.tar.xz tar -xf opam64.tar.xz bash opam64/install.sh -opam init default -a -y "https://github.com/fdopen/opam-repository-mingw.git#opam2" -c $APPVEYOR_OPAM_VARIANT --disable-sandboxing +opam init default -j $NJOBS -a -y "https://github.com/fdopen/opam-repository-mingw.git#opam2" -c $APPVEYOR_OPAM_VARIANT --disable-sandboxing eval "$(opam env)" -opam install -y num ocamlfind ounit +opam install -j $NJOBS -y num ocamlfind ounit # Full regular Coq Build -cd "$APPVEYOR_BUILD_FOLDER" && ./configure -local && make && make byte # && make -C test-suite all INTERACTIVE= # && make validate +cd "$APPVEYOR_BUILD_FOLDER" && ./configure -local && make -j $NJOBS && make byte -j $NJOBS && make -j $NJOBS -C test-suite all INTERACTIVE= # && make validate diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index e0f4f50fa9..8dee465cf4 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -150,11 +150,11 @@ : "${fiat_crypto_CI_ARCHIVEURL:=${fiat_crypto_CI_GITURL}/archive}" ######################################################################## -# formal-topology +# fiat_crypto_legacy ######################################################################## -: "${formal_topology_CI_REF:=ci}" -: "${formal_topology_CI_GITURL:=https://github.com/bmsherman/topology}" -: "${formal_topology_CI_ARCHIVEURL:=${formal_topology_CI_GITURL}/archive}" +: "${fiat_crypto_legacy_CI_REF:=sp2019latest}" +: "${fiat_crypto_legacy_CI_GITURL:=https://github.com/mit-plv/fiat-crypto}" +: "${fiat_crypto_legacy_CI_ARCHIVEURL:=${fiat_crypto_legacy_CI_GITURL}/archive}" ######################################################################## # coq_dpdgraph @@ -240,13 +240,6 @@ : "${quickchick_CI_ARCHIVEURL:=${quickchick_CI_GITURL}/archive}" ######################################################################## -# plugin_tutorial -######################################################################## -: "${plugin_tutorial_CI_REF:=master}" -: "${plugin_tutorial_CI_GITURL:=https://github.com/ybertot/plugin_tutorials}" -: "${plugin_tutorial_CI_ARCHIVEURL:=${plugin_tutorial_CI_GITURL}/archive}" - -######################################################################## # menhirlib ######################################################################## : "${menhirlib_CI_REF:=master}" @@ -273,3 +266,26 @@ : "${relation_algebra_CI_REF:=master}" : "${relation_algebra_CI_GITURL:=https://github.com/damien-pous/relation-algebra}" : "${relation_algebra_CI_ARCHIVEURL:=${relation_algebra_CI_GITURL}/archive}" + +######################################################################## +# StructTact + InfSeqExt + Cheerios + Verdi + Verdi Raft +######################################################################## +: "${struct_tact_CI_REF:=master}" +: "${struct_tact_CI_GITURL:=https://github.com/uwplse/StructTact}" +: "${struct_tact_CI_ARCHIVEURL:=${struct_tact_CI_GITURL}/archive}" + +: "${inf_seq_ext_CI_REF:=master}" +: "${inf_seq_ext_CI_GITURL:=https://github.com/DistributedComponents/InfSeqExt}" +: "${inf_seq_ext_CI_ARCHIVEURL:=${inf_seq_ext_CI_GITURL}/archive}" + +: "${cheerios_CI_REF:=master}" +: "${cheerios_CI_GITURL:=https://github.com/uwplse/cheerios}" +: "${cheerios_CI_ARCHIVEURL:=${cheerios_CI_GITURL}/archive}" + +: "${verdi_CI_REF:=master}" +: "${verdi_CI_GITURL:=https://github.com/uwplse/verdi}" +: "${verdi_CI_ARCHIVEURL:=${verdi_CI_GITURL}/archive}" + +: "${verdi_raft_CI_REF:=master}" +: "${verdi_raft_CI_GITURL:=https://github.com/uwplse/verdi-raft}" +: "${verdi_raft_CI_ARCHIVEURL:=${verdi_raft_CI_GITURL}/archive}" diff --git a/dev/ci/ci-fiat-crypto-legacy.sh b/dev/ci/ci-fiat-crypto-legacy.sh index 6bf3138346..2af4b58201 100755 --- a/dev/ci/ci-fiat-crypto-legacy.sh +++ b/dev/ci/ci-fiat-crypto-legacy.sh @@ -4,11 +4,11 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" FORCE_GIT=1 -git_download fiat_crypto +git_download fiat_crypto_legacy fiat_crypto_legacy_CI_TARGETS1="print-old-pipeline-lite old-pipeline-lite lite-display" fiat_crypto_legacy_CI_TARGETS2="print-old-pipeline-nobigmem old-pipeline-nobigmem nonautogenerated-specific nonautogenerated-specific-display" -( cd "${CI_BUILD_DIR}/fiat_crypto" && git submodule update --init --recursive && \ +( cd "${CI_BUILD_DIR}/fiat_crypto_legacy" && git submodule update --init --recursive && \ ./etc/ci/remove_autogenerated.sh && \ make ${fiat_crypto_legacy_CI_TARGETS1} && make -j 1 ${fiat_crypto_legacy_CI_TARGETS2} ) diff --git a/dev/ci/ci-fiat-crypto.sh b/dev/ci/ci-fiat-crypto.sh index 7e8013be9b..bba17314f7 100755 --- a/dev/ci/ci-fiat-crypto.sh +++ b/dev/ci/ci-fiat-crypto.sh @@ -10,5 +10,9 @@ git_download fiat_crypto # building the executables. # c.f. https://github.com/coq/coq/pull/8313#issuecomment-416650241 +fiat_crypto_CI_TARGETS1="c-files printlite lite" +fiat_crypto_CI_TARGETS2="print-nobigmem nobigmem" + ( cd "${CI_BUILD_DIR}/fiat_crypto" && git submodule update --init --recursive && \ - ulimit -s 32768 && make new-pipeline c-files ) + ulimit -s 32768 && \ + make ${fiat_crypto_CI_TARGETS1} && make -j 1 ${fiat_crypto_CI_TARGETS2} ) diff --git a/dev/ci/ci-formal-topology.sh b/dev/ci/ci-formal-topology.sh deleted file mode 100755 index 8be5a06ed2..0000000000 --- a/dev/ci/ci-formal-topology.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/usr/bin/env bash - -ci_dir="$(dirname "$0")" -. "${ci_dir}/ci-common.sh" - -git_download formal_topology - -( cd "${CI_BUILD_DIR}/formal_topology" && make ) diff --git a/dev/ci/ci-plugin_tutorial.sh b/dev/ci/ci-plugin_tutorial.sh deleted file mode 100755 index 6c26a71a21..0000000000 --- a/dev/ci/ci-plugin_tutorial.sh +++ /dev/null @@ -1,12 +0,0 @@ -#!/usr/bin/env bash - -ci_dir="$(dirname "$0")" -. "${ci_dir}/ci-common.sh" - -git_download plugin_tutorial - -( cd "${CI_BUILD_DIR}/plugin_tutorial" && \ - pushd tuto0 && make && popd && \ - pushd tuto1 && make && popd && \ - pushd tuto2 && make && popd && \ - pushd tuto3 && make && popd ) diff --git a/dev/ci/ci-verdi-raft.sh b/dev/ci/ci-verdi-raft.sh new file mode 100755 index 0000000000..3bcd52c464 --- /dev/null +++ b/dev/ci/ci-verdi-raft.sh @@ -0,0 +1,24 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +. "${ci_dir}/ci-common.sh" + +git_download struct_tact + +( cd "${CI_BUILD_DIR}/struct_tact" && ./configure && make && make install ) + +git_download inf_seq_ext + +( cd "${CI_BUILD_DIR}/inf_seq_ext" && ./configure && make && make install ) + +git_download cheerios + +( cd "${CI_BUILD_DIR}/cheerios" && ./configure && make && make install ) + +git_download verdi + +( cd "${CI_BUILD_DIR}/verdi" && ./configure && make && make install ) + +git_download verdi_raft + +( cd "${CI_BUILD_DIR}/verdi_raft" && ./configure && make ) diff --git a/dev/ci/ci-wrapper.sh b/dev/ci/ci-wrapper.sh index 12a70176c2..9ca8f76054 100755 --- a/dev/ci/ci-wrapper.sh +++ b/dev/ci/ci-wrapper.sh @@ -6,13 +6,6 @@ set -eo pipefail -function travis_fold { - if [ -n "${TRAVIS}" ]; - then - echo "travis_fold:$1:$2" - fi -} - CI_NAME="$1" CI_SCRIPT="ci-${CI_NAME}.sh" @@ -22,6 +15,5 @@ cd "${DIR}/../.." export TIMED=1 "${DIR}/${CI_SCRIPT}" 2>&1 | tee time-of-build.log -travis_fold 'start' 'coq.test.timing' && echo 'Aggregating timing log...' +echo 'Aggregating timing log...' python ./tools/make-one-time-file.py time-of-build.log -travis_fold 'end' 'coq.test.timing' diff --git a/dev/ci/gitlab.bat b/dev/ci/gitlab.bat index 386a3de204..5f819f31f9 100755 --- a/dev/ci/gitlab.bat +++ b/dev/ci/gitlab.bat @@ -26,12 +26,12 @@ if %ARCH% == 64 ( SET CYGROOT=C:\ci\cygwin%ARCH%
SET DESTCOQ=C:\ci\coq%ARCH%
+SET CYGCACHE=C:\ci\cache\cgwin
CALL :MakeUniqueFolder %CYGROOT% CYGROOT
CALL :MakeUniqueFolder %DESTCOQ% DESTCOQ
powershell -Command "(New-Object Net.WebClient).DownloadFile('http://www.cygwin.com/%SETUP%', '%SETUP%')"
-SET CYGCACHE=%CYGROOT%\var\cache\setup
SET CI_PROJECT_DIR_MFMT=%CI_PROJECT_DIR:\=/%
SET CI_PROJECT_DIR_CFMT=%CI_PROJECT_DIR_MFMT:C:/=/cygdrive/c/%
SET COQREGTESTING=Y
@@ -49,10 +49,9 @@ IF "%WINDOWS%" == "enabled_all_addons" ( -addon=compcert ^
-addon=extlib ^
-addon=quickchick ^
- -addon=coquelicot
- REM addons with build issues
- REM -addon=vst ^
- REM -addon=aactactics ^
+ -addon=coquelicot ^
+ -addon=vst ^
+ -addon=aactactics
) ELSE (
SET "EXTRA_ADDONS= "
)
diff --git a/dev/ci/nix/CoLoR.nix b/dev/ci/nix/CoLoR.nix index 4c5cfd83da..3fcf177aec 100644 --- a/dev/ci/nix/CoLoR.nix +++ b/dev/ci/nix/CoLoR.nix @@ -1,5 +1,5 @@ { bignums }: { - buildInputs = [ bignums ]; + coqBuildInputs = [ bignums ]; } diff --git a/dev/ci/nix/Corn.nix b/dev/ci/nix/Corn.nix index 18c7750279..0d22a6b91b 100644 --- a/dev/ci/nix/Corn.nix +++ b/dev/ci/nix/Corn.nix @@ -1,5 +1,5 @@ { bignums, math-classes }: { - buildInputs = [ bignums math-classes ]; + coqBuildInputs = [ bignums math-classes ]; } diff --git a/dev/ci/nix/GeoCoq.nix b/dev/ci/nix/GeoCoq.nix index a86fb2c44a..45d688285e 100644 --- a/dev/ci/nix/GeoCoq.nix +++ b/dev/ci/nix/GeoCoq.nix @@ -1,5 +1,5 @@ { mathcomp }: { - buildInputs = [ mathcomp ]; + coqBuildInputs = [ mathcomp ]; configure = "./configure.sh"; } diff --git a/dev/ci/nix/README.md b/dev/ci/nix/README.md index 1685b084e9..6f32abef95 100644 --- a/dev/ci/nix/README.md +++ b/dev/ci/nix/README.md @@ -17,3 +17,10 @@ build-system of that project: `configure`, `make`, and `clean`. Therefore, after changing the working directory to the root of the sources of that project, the contents of these variables can be evaluated to respectively set-up, build, and clean the project. + +## Variant: nocoq + +The dependencies of the third-party developments are split into `buildInputs` +and `coqBuildInputs`. The second list gathers the Coq libraries. In case you +only want the non-coq dependencies (because you want to use Coq from your `PATH`), +set the environment variable `NOCOQ` to some non-empty value. diff --git a/dev/ci/nix/default.nix b/dev/ci/nix/default.nix index 4acfae48e4..277e9ee08f 100644 --- a/dev/ci/nix/default.nix +++ b/dev/ci/nix/default.nix @@ -2,7 +2,8 @@ , branch , wd , project ? "xyz" -, bn ? "release" +, withCoq ? true +, bn ? "master" }: with pkgs; @@ -16,6 +17,11 @@ let mathcomp = coqPackages.mathcomp.overrideAttrs (o: { name = "coq-git-mathcomp-git"; src = fetchTarball https://github.com/math-comp/math-comp/archive/master.tar.gz; }); in +let ssreflect = coqPackages.ssreflect.overrideAttrs (o: { + inherit (mathcomp) src; + }); in +let coq-ext-lib = coqPackages.coq-ext-lib; in +let simple-io = coqPackages.simple-io; in let bignums = coqPackages.bignums.overrideAttrs (o: if bn == "release" then {} else if bn == "master" then { src = fetchTarball https://github.com/coq/bignums/archive/master.tar.gz; } else @@ -28,9 +34,17 @@ let math-classes = src = fetchTarball "https://github.com/coq-community/math-classes/archive/master.tar.gz"; }); in -let unicoq = callPackage ./unicoq.nix { inherit coq; }; in +let corn = (coqPackages.corn.override { inherit coq bignums math-classes; }) + .overrideAttrs (o: { + src = fetchTarball "https://github.com/coq-community/corn/archive/master.tar.gz"; + }); in + +let unicoq = callPackage ./unicoq { inherit coq; }; in -let callPackage = newScope { inherit coq mathcomp bignums coqprime math-classes unicoq; }; in +let callPackage = newScope { inherit coq + bignums coq-ext-lib coqprime corn math-classes + mathcomp simple-io ssreflect unicoq; +}; in # Environments for building CI libraries with this Coq let projects = { @@ -45,12 +59,14 @@ let projects = { fiat_crypto = callPackage ./fiat_crypto.nix {}; fiat_crypto_legacy = callPackage ./fiat_crypto_legacy.nix {}; flocq = callPackage ./flocq.nix {}; + formal-topology = callPackage ./formal-topology.nix {}; GeoCoq = callPackage ./GeoCoq.nix {}; HoTT = callPackage ./HoTT.nix {}; math_classes = callPackage ./math_classes.nix {}; mathcomp = {}; mtac2 = callPackage ./mtac2.nix {}; oddorder = callPackage ./oddorder.nix {}; + quickchick = callPackage ./quickchick.nix {}; VST = callPackage ./VST.nix {}; }; in @@ -60,10 +76,16 @@ else let prj = projects."${project}"; in +let inherit (stdenv.lib) optional optionals; in + stdenv.mkDerivation { name = "shell-for-${project}-in-${branch}"; - buildInputs = [ coq ] ++ (prj.buildInputs or []); + buildInputs = + optional withCoq coq + ++ (prj.buildInputs or []) + ++ optionals withCoq (prj.coqBuildInputs or []) + ; configure = prj.configure or "true"; make = prj.make or "make"; diff --git a/dev/ci/nix/fiat_crypto.nix b/dev/ci/nix/fiat_crypto.nix index 7b37e6e8e4..0f0ee91387 100644 --- a/dev/ci/nix/fiat_crypto.nix +++ b/dev/ci/nix/fiat_crypto.nix @@ -1,6 +1,6 @@ { coqprime }: { - buildInputs = [ coqprime ]; + coqBuildInputs = [ coqprime ]; configure = "git submodule update --init --recursive && ulimit -s 32768"; make = "make new-pipeline c-files"; } diff --git a/dev/ci/nix/formal-topology.nix b/dev/ci/nix/formal-topology.nix new file mode 100644 index 0000000000..53b9b1182b --- /dev/null +++ b/dev/ci/nix/formal-topology.nix @@ -0,0 +1,4 @@ +{ corn }: +{ + coqBuildInputs = [ corn ]; +} diff --git a/dev/ci/nix/math_classes.nix b/dev/ci/nix/math_classes.nix index b0fa2fe795..8edc3c8358 100644 --- a/dev/ci/nix/math_classes.nix +++ b/dev/ci/nix/math_classes.nix @@ -1,6 +1,6 @@ { bignums }: { - buildInputs = [ bignums ]; + coqBuildInputs = [ bignums ]; configure = "./configure.sh"; } diff --git a/dev/ci/nix/mtac2.nix b/dev/ci/nix/mtac2.nix index 9a2353c5cf..4acc326c02 100644 --- a/dev/ci/nix/mtac2.nix +++ b/dev/ci/nix/mtac2.nix @@ -1,5 +1,6 @@ { coq, unicoq }: { - buildInputs = [ unicoq ] ++ (with coq.ocamlPackages; [ ocaml findlib camlp5 ]); + buildInputs = with coq.ocamlPackages; [ ocaml findlib camlp5 ]; + coqBuildInputs = [ unicoq ]; configure = "./configure.sh"; } diff --git a/dev/ci/nix/oddorder.nix b/dev/ci/nix/oddorder.nix index 3b8fdbab51..2341bb3173 100644 --- a/dev/ci/nix/oddorder.nix +++ b/dev/ci/nix/oddorder.nix @@ -1,4 +1,4 @@ { mathcomp }: { - buildInputs = [ mathcomp ]; + coqBuildInputs = [ mathcomp ]; } diff --git a/dev/ci/nix/quickchick.nix b/dev/ci/nix/quickchick.nix new file mode 100644 index 0000000000..46bf02ae3c --- /dev/null +++ b/dev/ci/nix/quickchick.nix @@ -0,0 +1,5 @@ +{ ocamlPackages, ssreflect, coq-ext-lib, simple-io }: +{ + buildInputs = with ocamlPackages; [ ocaml findlib ocamlbuild num ]; + coqBuildInputs = [ ssreflect coq-ext-lib simple-io ]; +} diff --git a/dev/ci/nix/shell b/dev/ci/nix/shell index 2e4462ed40..a5f8ee8f54 100755 --- a/dev/ci/nix/shell +++ b/dev/ci/nix/shell @@ -17,4 +17,10 @@ else BN="" fi -nix-shell ./dev/ci/nix/ --show-trace --argstr wd $PWD --argstr branch $BRANCH $PROJECT $BN +if [ "$NOCOQ" ]; then + NOCOQ="--arg withCoq false" +else + NOCOQ="" +fi + +nix-shell ./dev/ci/nix/ --show-trace --argstr wd $PWD --argstr branch $BRANCH $PROJECT $BN $NOCOQ diff --git a/dev/ci/nix/unicoq/META b/dev/ci/nix/unicoq/META new file mode 100644 index 0000000000..30dd8b5559 --- /dev/null +++ b/dev/ci/nix/unicoq/META @@ -0,0 +1,2 @@ +archive(native) = "unicoq.cmxa" +plugin(native) = "unicoq.cmxs" diff --git a/dev/ci/nix/unicoq.nix b/dev/ci/nix/unicoq/default.nix index 093c262cde..36f40dbe33 100644 --- a/dev/ci/nix/unicoq.nix +++ b/dev/ci/nix/unicoq/default.nix @@ -4,8 +4,16 @@ stdenv.mkDerivation { name = "coq${coq.coq-version}-unicoq-0.0-git"; src = fetchTarball https://github.com/unicoq/unicoq/archive/master.tar.gz; + patches = [ ./unicoq-num.patch ]; + buildInputs = [ coq ] ++ (with coq.ocamlPackages; [ ocaml findlib camlp5 num ]); configurePhase = "coq_makefile -f Make -o Makefile"; installFlags = [ "COQLIB=$(out)/lib/coq/${coq.coq-version}/" ]; + + postInstall = '' + install -d $OCAMLFIND_DESTDIR + ln -s $out/lib/coq/${coq.coq-version}/user-contrib/Unicoq $OCAMLFIND_DESTDIR/ + install -m 0644 ${./META} src/unicoq.a $OCAMLFIND_DESTDIR/Unicoq + ''; } diff --git a/dev/ci/nix/unicoq/unicoq-num.patch b/dev/ci/nix/unicoq/unicoq-num.patch new file mode 100644 index 0000000000..6d96d94dfc --- /dev/null +++ b/dev/ci/nix/unicoq/unicoq-num.patch @@ -0,0 +1,44 @@ +commit f29bc64ee3d8b36758d17e1f5d50812e0c93063b +Author: Vincent Laporte <Vincent.Laporte@fondation-inria.fr> +Date: Thu Nov 29 08:59:22 2018 +0000 + + Make explicit dependency to num + +diff --git a/Make b/Make +index 550dc6a..8aa1309 100644 +--- a/Make ++++ b/Make +@@ -9,7 +9,7 @@ src/logger.ml + src/munify.mli + src/munify.ml + src/unitactics.mlg +-src/unicoq.mllib ++src/unicoq.mlpack + theories/Unicoq.v + test-suite/munifytest.v + test-suite/microtests.v +diff --git a/Makefile.local b/Makefile.local +new file mode 100644 +index 0000000..88be365 +--- /dev/null ++++ b/Makefile.local +@@ -0,0 +1 @@ ++CAMLPKGS += -package num +diff --git a/src/unicoq.mllib b/src/unicoq.mllib +deleted file mode 100644 +index 2b84e2d..0000000 +--- a/src/unicoq.mllib ++++ /dev/null +@@ -1,3 +0,0 @@ +-Logger +-Munify +-Unitactics +diff --git a/src/unicoq.mlpack b/src/unicoq.mlpack +new file mode 100644 +index 0000000..2b84e2d +--- /dev/null ++++ b/src/unicoq.mlpack +@@ -0,0 +1,3 @@ ++Logger ++Munify ++Unitactics diff --git a/dev/ci/user-overlays/09263-maximedenes-parsing-state.sh b/dev/ci/user-overlays/09263-maximedenes-parsing-state.sh new file mode 100644 index 0000000000..ebd1b524da --- /dev/null +++ b/dev/ci/user-overlays/09263-maximedenes-parsing-state.sh @@ -0,0 +1,12 @@ +if [ "$CI_PULL_REQUEST" = "9263" ] || [ "$CI_BRANCH" = "parsing-state" ]; then + + mtac2_CI_REF=proof-mode + mtac2_CI_GITURL=https://github.com/maximedenes/Mtac2 + + ltac2_CI_REF=proof-mode + ltac2_CI_GITURL=https://github.com/maximedenes/ltac2 + + equations_CI_REF=proof-mode + equations_CI_GITURL=https://github.com/maximedenes/Coq-Equations + +fi diff --git a/dev/doc/MERGING.md b/dev/doc/MERGING.md index 56fdab0c26..5705857d76 100644 --- a/dev/doc/MERGING.md +++ b/dev/doc/MERGING.md @@ -93,7 +93,7 @@ put the approriate label. Otherwise, they are expected to merge the PR using the When CI has a few failures which look spurious, restarting the corresponding jobs is a good way of ensuring this was indeed the case. -To restart a job on Travis or on AppVeyor, you should connect using your GitHub +To restart a job on AppVeyor, you should connect using your GitHub account; being part of the Coq organization on GitHub should give you the permission to do so. To restart a job on GitLab CI, you should sign into GitLab (this can be done diff --git a/dev/doc/profiling.txt b/dev/doc/profiling.txt index 29e87df6b8..8455d13377 100644 --- a/dev/doc/profiling.txt +++ b/dev/doc/profiling.txt @@ -10,7 +10,7 @@ In Coq source folder: opam switch 4.05.0+trunk+fp ./configure -local -debug make -perf record -g bin/coqtop -compile file.v +perf record -g bin/coqc file.v perf report -g fractal,callee --no-children To profile only part of a file, first load it using @@ -96,7 +96,7 @@ https://github.com/mshinwell/opam-repo-dev ### For memory dump: -CAMLRUNPARAM=T,mj bin/coqtop -compile file.v +CAMLRUNPARAM=T,mj bin/coqc file.v In another terminal: @@ -112,7 +112,7 @@ number of objects and third is the place where the objects where allocated. ### For complete memory graph: -CAMLRUNPARAM=T,gr bin/coqtop -compile file.v +CAMLRUNPARAM=T,gr bin/coqc file.v In another terminal: diff --git a/dev/doc/release-process.md b/dev/doc/release-process.md index b1c111685b..d05b6c8eef 100644 --- a/dev/doc/release-process.md +++ b/dev/doc/release-process.md @@ -4,37 +4,20 @@ - [ ] Create a new issue to track the release process where you can copy-paste the present checklist. -- [ ] Change the version name to the next major version and the magic numbers - (see [#7008](https://github.com/coq/coq/pull/7008/files)). -- [ ] Update the compatibility infrastructure, which consists of doing - the following steps. Note that all but the final step can be - performed automatically by - [`dev/tools/update-compat.py`](/dev/tools/update-compat.py) so - long as you have already updated `coq_version` in - [`configure.ml`](/configure.ml). - + [ ] Add a file `theories/Compat/CoqXX.v` which contains just the header - from [`dev/header.ml`](/dev/header.ml) - + [ ] Add the line `Require Export Coq.Compat.CoqXX.` at the top of - `theories/Compat/CoqYY.v`, where Y.Y is the version prior to X.X. - + [ ] Delete the file `theories/Compat/CoqWW.v`, where W.W is three versions - prior to X.X. - + [ ] Update - [`doc/stdlib/index-list.html.template`](/doc/stdlib/index-list.html.template) - with the deleted/added files. - + [ ] Remove any notations in the standard library which have `compat "W.W"`. - + [ ] Update the type `compat_version` in [`lib/flags.ml`](/lib/flags.ml) by - bumping all the version numbers by one, and update the interpretations - of those flags in [`toplevel/coqargs.ml`](/toplevel/coqargs.ml) and - [`vernac/g_vernac.mlg`](/vernac/g_vernac.mlg). - + [ ] Update the files - [`test-suite/success/CompatCurrentFlag.v`](/test-suite/success/CompatCurrentFlag.v), - [`test-suite/success/CompatPreviousFlag.v`](/test-suite/success/CompatPreviousFlag.v), - and - [`test-suite/success/CompatOldFlag.v`](/test-suite/success/CompatOldFlag.v) - by bumping all version numbers by 1. - + [ ] Decide what to do about all test-suite files which mention `-compat - W.W` or `Coq.Comapt.CoqWW` (which is no longer valid, since we only - keep compatibility against the two previous versions) +- [ ] Change the version name to the next major version and the magic + numbers (see [#7008](https://github.com/coq/coq/pull/7008/files)). + + Additionally, in the same commit, update the compatibility + infrastructure, which consists of invoking + [`dev/tools/update-compat.py`](../tools/update-compat.py) with the + `--master` flag. + + Note that the `update-compat.py` script must be run twice: once + *immediately after* branching with the `--master` flag (which sets + up Coq to support four `-compat` flag arguments), *in the same + commit* as the one that updates `coq_version` in + [`configure.ml`](../../configure.ml), and once again later on before + the next branch point with the `--release` flag (see next section). - [ ] Put the corresponding alpha tag using `git tag -s`. The `VX.X+alpha` tag marks the first commit to be in `master` and not in the branch of the previous version. @@ -43,6 +26,19 @@ release date) and put this information in the milestone (using the description and due date fields). +## Anytime after the previous version is branched off master ## + +- [ ] Update the compatibility infrastructure to the next release, + which consists of invoking + [`dev/tools/update-compat.py`](../tools/update-compat.py) with the + `--release` flag; this sets up Coq to support three `-compat` flag + arguments. To ensure that CI passes, you will have to decide what + to do about all test-suite files which mention `-compat U.U` or + `Coq.Comapt.CoqUU` (which is no longer valid, since we only keep + compatibility against the two previous versions on releases), and + you may have to prepare overlays for projects using the + compatibility flags. + ## About one month before the beta ## - [ ] Create the `X.X.0` milestone and set its due date. diff --git a/dev/doc/versions-history.tex b/dev/doc/versions-history.tex index 8f9c3171da..1c4913d201 100644 --- a/dev/doc/versions-history.tex +++ b/dev/doc/versions-history.tex @@ -271,7 +271,7 @@ Coq ``V7'' archive & August 1999 & new cvs archive based on J.-C. Filliâtre's \ & & \feature{kernel-centric} architecture \\ & & more care for outside readers\\ & & (indentation, ocaml warning protection)\\ -Coq V7.0beta& released 27 December 2000 & \feature{${\cal L}_{\mathit{tac}}$} \\ +Coq V7.0beta& released 27 December 2000 & \feature{${\mathcal{L}}_{\mathit{tac}}$} \\ Coq V7.0beta2& released 2 February 2001\\ Coq V7.0& released 25 April 2001 & \feature{extraction} (version 2) [6-2-2001] \\ diff --git a/dev/lint-repository.sh b/dev/lint-repository.sh index cd09b6d305..f588c20d02 100755 --- a/dev/lint-repository.sh +++ b/dev/lint-repository.sh @@ -4,33 +4,25 @@ # lint-commits.sh seeks to prevent the worsening of already present # problems, such as tab indentation in ml files. lint-repository.sh -# seeks to prevent the (re-)introduction of solved problems, such as -# newlines at the end of .v files. +# also seeks to prevent the (re-)introduction of solved problems, such +# as newlines at the end of .v files. CODE=0 -if [ -n "${TRAVIS_PULL_REQUEST}" ] && [ "${TRAVIS_PULL_REQUEST}" != false ]; -then - # skip PRs from before the linter existed - if [ -z "$(git ls-tree --name-only "${TRAVIS_PULL_REQUEST_SHA}" dev/lint-commits.sh)" ]; - then - 1>&2 echo "Linting skipped: pull request older than the linter." - exit 0 - fi - - # Some problems are too widespread to fix in one commit, but we - # can still check that they don't worsen. - CUR_HEAD=${TRAVIS_COMMIT_RANGE%%...*} - PR_HEAD=${TRAVIS_COMMIT_RANGE##*...} - MERGE_BASE=$(git merge-base "$CUR_HEAD" "$PR_HEAD") - dev/lint-commits.sh "$MERGE_BASE" "$PR_HEAD" || CODE=1 -fi +# We assume that all merge commits are from the main branch +# For Coq it is extremely rare for this assumption to be broken +read -r base < <(git log -n 1 --merges --pretty='format:%H') +head=$(git rev-parse HEAD) + +dev/lint-commits.sh "$base" "$head" || CODE=1 # Check that the files with 'whitespace' gitattribute end in a newline. # xargs exit status is 123 if any file failed the test +echo Checking end of file newlines find . "(" -path ./.git -prune ")" -o -type f -print0 | xargs -0 dev/tools/check-eof-newline.sh || CODE=1 +echo Checking overlays dev/tools/check-overlays.sh || CODE=1 exit $CODE diff --git a/dev/tools/merge-pr.sh b/dev/tools/merge-pr.sh index 5fd8a3b7d9..72e2930386 100755 --- a/dev/tools/merge-pr.sh +++ b/dev/tools/merge-pr.sh @@ -143,7 +143,7 @@ fi # Sanity check: PR has an outdated version of CI BASE_COMMIT=$(echo "$PRDATA" | jq -r '.base.sha') -CI_FILES=(".travis.yml" ".gitlab-ci.yml" "appveyor.yml") +CI_FILES=(".gitlab-ci.yml" "appveyor.yml") if ! git diff --quiet "$BASE_COMMIT" "$LOCAL_BRANCH_COMMIT" -- "${CI_FILES[@]}" then @@ -198,8 +198,26 @@ if [ -z "$(git config user.signingkey)" ]; then warning "gpg will guess a key out of your git config user.* data" fi +# Generate commit message + +info "Fetching review data" +reviews=$(curl -s "$API/pulls/$PR/reviews") +msg="Merge PR #$PR: $TITLE" + +has_state() { + [ "$(jq -rc 'map(select(.user.login == "'"$1"'") | .state) | any(. == "'"$2"'")' <<< "$reviews")" = true ] +} + +for reviewer in $(jq -rc 'map(.user.login) | unique | join(" ")' <<< "$reviews" ); do + if has_state "$reviewer" APPROVED; then + msg=$(printf '%s\n' "$msg" | git interpret-trailers --trailer Reviewed-by="$reviewer") + elif has_state "$reviewer" COMMENTED; then + msg=$(printf '%s\n' "$msg" | git interpret-trailers --trailer Ack-by="$reviewer") + fi +done + info "merging" -git merge -v -S --no-ff FETCH_HEAD -m "Merge PR #$PR: $TITLE" -e +git merge -v -S --no-ff FETCH_HEAD -m "$msg" -e # TODO: improve this check if ! git diff --quiet --diff-filter=A "$REMOTE/$CURRENT_LOCAL_BRANCH" -- dev/ci/user-overlays; then diff --git a/dev/tools/update-compat.py b/dev/tools/update-compat.py index 14094553a2..ff9b32fe78 100755 --- a/dev/tools/update-compat.py +++ b/dev/tools/update-compat.py @@ -1,6 +1,60 @@ #!/usr/bin/env python from __future__ import with_statement -import os, re, sys +import os, re, sys, subprocess + +# When passed `--release`, this script sets up Coq to support three +# `-compat` flag arguments. If executed manually, this would consist +# of doing the following steps: +# +# - Delete the file `theories/Compat/CoqUU.v`, where U.U is four +# versions prior to the new version X.X. After this, there +# should be exactly three `theories/Compat/CoqNN.v` files. +# - Update +# [`doc/stdlib/index-list.html.template`](/doc/stdlib/index-list.html.template) +# with the deleted file. +# - Remove any notations in the standard library which have `compat "U.U"`. +# - Update the type `compat_version` in [`lib/flags.ml`](/lib/flags.ml) by +# bumping all the version numbers by one, and update the interpretations +# of those flags in [`toplevel/coqargs.ml`](/toplevel/coqargs.ml) and +# [`vernac/g_vernac.mlg`](/vernac/g_vernac.mlg). +# +# - Remove the file +# [`test-suite/success/CompatOldOldFlag.v`](/test-suite/success/CompatOldOldFlag.v). +# - Update +# [`test-suite/tools/update-compat/run.sh`](/test-suite/tools/update-compat/run.sh) +# to ensure that it passes `--release` to the `update-compat.py` +# script. + +# When passed the `--master` flag, this script sets up Coq to support +# four `-compat` flag arguments. If executed manually, this would +# consist of doing the following steps: +# +# - Add a file `theories/Compat/CoqXX.v` which contains just the header +# from [`dev/header.ml`](/dev/header.ml) +# - Add the line `Require Export Coq.Compat.CoqXX.` at the top of +# `theories/Compat/CoqYY.v`, where Y.Y is the version prior to X.X. +# - Update +# [`doc/stdlib/index-list.html.template`](/doc/stdlib/index-list.html.template) +# with the added file. +# - Update the type `compat_version` in [`lib/flags.ml`](/lib/flags.ml) by +# bumping all the version numbers by one, and update the interpretations +# of those flags in [`toplevel/coqargs.ml`](/toplevel/coqargs.ml) and +# [`vernac/g_vernac.mlg`](/vernac/g_vernac.mlg). +# - Update the files +# [`test-suite/success/CompatCurrentFlag.v`](/test-suite/success/CompatCurrentFlag.v), +# [`test-suite/success/CompatPreviousFlag.v`](/test-suite/success/CompatPreviousFlag.v), +# and +# [`test-suite/success/CompatOldFlag.v`](/test-suite/success/CompatOldFlag.v) +# by bumping all version numbers by 1. Re-create the file +# [`test-suite/success/CompatOldOldFlag.v`](/test-suite/success/CompatOldOldFlag.v) +# with its version numbers also bumped by 1 (file should have +# been removed before branching; see above). +# - Update +# [`test-suite/tools/update-compat/run.sh`](/test-suite/tools/update-compat/run.sh) +# to ensure that it passes `--master` to the `update-compat.py` +# script. + + # Obtain the absolute path of the script being run. By assuming that # the script lives in dev/tools/, and basing all calls on the path of @@ -11,6 +65,8 @@ ROOT_PATH = os.path.realpath(os.path.join(SCRIPT_PATH, '..', '..')) CONFIGURE_PATH = os.path.join(ROOT_PATH, 'configure.ml') HEADER_PATH = os.path.join(ROOT_PATH, 'dev', 'header.ml') DEFAULT_NUMBER_OF_OLD_VERSIONS = 2 +RELEASE_NUMBER_OF_OLD_VERSIONS = 2 +MASTER_NUMBER_OF_OLD_VERSIONS = 3 EXTRA_HEADER = '\n(** Compatibility file for making Coq act similar to Coq v%s *)\n' FLAGS_MLI_PATH = os.path.join(ROOT_PATH, 'lib', 'flags.mli') FLAGS_ML_PATH = os.path.join(ROOT_PATH, 'lib', 'flags.ml') @@ -18,18 +74,46 @@ COQARGS_ML_PATH = os.path.join(ROOT_PATH, 'toplevel', 'coqargs.ml') G_VERNAC_PATH = os.path.join(ROOT_PATH, 'vernac', 'g_vernac.mlg') DOC_INDEX_PATH = os.path.join(ROOT_PATH, 'doc', 'stdlib', 'index-list.html.template') BUG_4798_PATH = os.path.join(ROOT_PATH, 'test-suite', 'bugs', 'closed', 'bug_4798.v') +BUG_9166_PATH = os.path.join(ROOT_PATH, 'test-suite', 'bugs', 'closed', 'bug_9166.v') +TEST_SUITE_RUN_PATH = os.path.join(ROOT_PATH, 'test-suite', 'tools', 'update-compat', 'run.sh') TEST_SUITE_PATHS = tuple(os.path.join(ROOT_PATH, 'test-suite', 'success', i) for i in ('CompatOldOldFlag.v', 'CompatOldFlag.v', 'CompatPreviousFlag.v', 'CompatCurrentFlag.v')) TEST_SUITE_DESCRIPTIONS = ('current-minus-three', 'current-minus-two', 'current-minus-one', 'current') # sanity check that we are where we think we are assert(os.path.normpath(os.path.realpath(SCRIPT_PATH)) == os.path.normpath(os.path.realpath(os.path.join(ROOT_PATH, 'dev', 'tools')))) assert(os.path.exists(CONFIGURE_PATH)) +BUG_HEADER = r"""(* DO NOT MODIFY THIS FILE DIRECTLY *) +(* It is autogenerated by %s. *) +""" % os.path.relpath(os.path.realpath(__file__), ROOT_PATH) def get_header(): with open(HEADER_PATH, 'r') as f: return f.read() HEADER = get_header() +def break_or_continue(): + msg = 'Press ENTER to continue, or Ctrl+C to break...' + try: + raw_input(msg) + except NameError: # we must be running python3 + input(msg) + +def maybe_git_add(local_path, suggest_add=True, **args): + if args['git_add']: + print("Running 'git add %s'..." % local_path) + retc = subprocess.call(['git', 'add', local_path], cwd=ROOT_PATH) + if retc is not None and retc != 0: + print('!!! Process returned code %d' % retc) + elif suggest_add: + print(r"!!! Don't forget to 'git add %s'!" % local_path) + +def maybe_git_rm(local_path, **args): + if args['git_add']: + print("Running 'git rm %s'..." % local_path) + retc = subprocess.call(['git', 'rm', local_path], cwd=ROOT_PATH) + if retc is not None and retc != 0: + print('!!! Process returned code %d' % retc) + def get_version(cur_version=None): if cur_version is not None: return cur_version with open(CONFIGURE_PATH, 'r') as f: @@ -72,11 +156,56 @@ def get_known_versions(): def get_new_versions(known_versions, **args): if args['cur_version'] in known_versions: assert(known_versions[-1] == args['cur_version']) - assert(len(known_versions) == args['number_of_compat_versions']) - return known_versions + known_versions = known_versions[:-1] assert(len(known_versions) >= args['number_of_old_versions']) return tuple(list(known_versions[-args['number_of_old_versions']:]) + [args['cur_version']]) +def print_diff(olds, news, numch=30): + for ch in range(min(len(olds), len(news))): + if olds[ch] != news[ch]: + print('Character %d differs:\nOld: %s\nNew: %s' % (ch, repr(olds[ch:][:numch]), repr(news[ch:][numch]))) + return + ch = min(len(olds), len(news)) + assert(len(olds) != len(news)) + print('Strings are different lengths:\nOld tail: %s\nNew tail: %s' % (repr(olds[ch:]), repr(news[ch:]))) + +def update_shebang_to_match(contents, new_contents, path): + contents_lines = contents.split('\n') + new_contents_lines = new_contents.split('\n') + if not (contents_lines[0].startswith('#!/') and contents_lines[0].endswith('bash')): + raise Exception('Unrecognized #! line in existing %s: %s' % (os.path.relpath(path, ROOT_PATH), repr(contents_lines[0]))) + if not (new_contents_lines[0].startswith('#!/') and new_contents_lines[0].endswith('bash')): + raise Exception('Unrecognized #! line in new %s: %s' % (os.path.relpath(path, ROOT_PATH), repr(new_contents_lines[0]))) + new_contents_lines[0] = contents_lines[0] + return '\n'.join(new_contents_lines) + +def update_if_changed(contents, new_contents, path, exn_string='%s changed!', suggest_add=False, pass_through_shebang=False, assert_unchanged=False, **args): + if contents is not None and pass_through_shebang: + new_contents = update_shebang_to_match(contents, new_contents, path) + if contents is None or contents != new_contents: + if not assert_unchanged: + print('Updating %s...' % os.path.relpath(path, ROOT_PATH)) + with open(path, 'w') as f: + f.write(new_contents) + maybe_git_add(os.path.relpath(path, ROOT_PATH), suggest_add=suggest_add, **args) + else: + if contents is not None: + print('Unexpected change:\nOld contents:\n%s\n\nNew contents:\n%s\n' % (contents, new_contents)) + print_diff(contents, new_contents) + raise Exception(exn_string % os.path.relpath(path, ROOT_PATH)) + +def remove_if_exists(path, exn_string='%s exists when it should not!', assert_unchanged=False, **args): + if os.path.exists(path): + if not assert_unchanged: + print('Removing %s...' % os.path.relpath(path, ROOT_PATH)) + os.remove(path) + maybe_git_rm(os.path.relpath(path, ROOT_PATH), **args) + else: + raise Exception(exn_string % os.path.relpath(path, ROOT_PATH)) + +def update_file(new_contents, path, **args): + update_if_changed(None, new_contents, path, **args) + def update_compat_files(old_versions, new_versions, assert_unchanged=False, **args): for v in old_versions: if v not in new_versions: @@ -85,6 +214,7 @@ def update_compat_files(old_versions, new_versions, assert_unchanged=False, **ar print('Removing %s...' % compat_file) compat_path = os.path.join(ROOT_PATH, compat_file) os.rename(compat_path, compat_path + '.bak') + maybe_git_rm(compat_file, **args) else: raise Exception('%s exists!' % compat_file) for v, next_v in zip(new_versions, list(new_versions[1:]) + [None]): @@ -95,12 +225,7 @@ def update_compat_files(old_versions, new_versions, assert_unchanged=False, **ar contents = HEADER + (EXTRA_HEADER % v) if next_v is not None: contents += '\nRequire Export Coq.Compat.%s.\n' % version_name_to_compat_name(next_v, ext='') - if not assert_unchanged: - with open(compat_path, 'w') as f: - f.write(contents) - print(r"Don't forget to 'git add %s'!" % compat_file) - else: - raise Exception('%s does not exist!' % compat_file) + update_file(contents, compat_path, exn_string='%s does not exist!', assert_unchanged=assert_unchanged, **args) else: # print('Checking %s...' % compat_file) with open(compat_path, 'r') as f: @@ -116,12 +241,7 @@ def update_compat_files(old_versions, new_versions, assert_unchanged=False, **ar if not contents.startswith(header + '\n'): contents = contents.replace(header, header + '\n') contents = contents.replace(header, '%s\n%s' % (header, line)) - if not assert_unchanged: - print('Updating %s...' % compat_file) - with open(compat_path, 'w') as f: - f.write(contents) - else: - raise Exception('Compat file %s is missing line %s' % (compat_file, line)) + update_file(contents, compat_path, exn_string=('Compat file %%s is missing line %s' % line), assert_unchanged=assert_unchanged, **args) def update_compat_versions_type_line(new_versions, contents, relpath): compat_version_string = ' | '.join(['V%s_%s' % tuple(v.split('.')) for v in new_versions[:-1]] + ['Current']) @@ -173,11 +293,18 @@ def update_add_compat_require(new_versions, contents, relpath): return new_contents def update_parse_compat_version(new_versions, contents, relpath, **args): - line_count = args['number_of_compat_versions']+2 # 1 for the first line, 1 for the invalid flags + line_count = 3 # 1 for the first line, 1 for the invalid flags, and 1 for Current first_line = 'let parse_compat_version = let open Flags in function' - old_function_lines = contents[contents.index(first_line):].split('\n')[:line_count] - if re.match(r'^ \| \([0-9 "\.\|]*\) as s ->$', old_function_lines[-1]) is None: - raise Exception('Could not recognize line %d of parse_compat_version in %s as a list of invalid versions' % (line_count, relpath)) + split_contents = contents[contents.index(first_line):].split('\n') + while True: + cur_line = split_contents[:line_count][-1] + if re.match(r'^ \| \([0-9 "\.\|]*\) as s ->$', cur_line) is not None: + break + elif re.match(r'^ \| "[0-9\.]*" -> V[0-9_]*$', cur_line) is not None: + line_count += 1 + else: + raise Exception('Could not recognize line %d of parse_compat_version in %s as a list of invalid versions (line was %s)' % (line_count, relpath, repr(cur_line))) + old_function_lines = split_contents[:line_count] all_versions = re.findall(r'"([0-9\.]+)"', ''.join(old_function_lines)) invalid_versions = tuple(i for i in all_versions if i not in new_versions) new_function_lines = [first_line] @@ -197,15 +324,6 @@ def check_no_old_versions(old_versions, new_versions, contents, relpath): if V in contents: raise Exception('Unreplaced usage of %s remaining in %s' % (V, relpath)) -def update_if_changed(contents, new_contents, path, assert_unchanged=False, **args): - if contents != new_contents: - if not assert_unchanged: - print('Updating %s...' % os.path.relpath(path, ROOT_PATH)) - with open(path, 'w') as f: - f.write(new_contents) - else: - raise Exception('%s changed!' % os.path.relpath(path, ROOT_PATH)) - def update_flags_mli(old_versions, new_versions, **args): with open(FLAGS_MLI_PATH, 'r') as f: contents = f.read() new_contents = update_compat_versions_type_line(new_versions, contents, os.path.relpath(FLAGS_MLI_PATH, ROOT_PATH)) @@ -238,21 +356,26 @@ def update_flags(old_versions, new_versions, **args): update_coqargs_ml(old_versions, new_versions, **args) update_g_vernac(old_versions, new_versions, **args) -def update_test_suite(new_versions, assert_unchanged=False, test_suite_paths=TEST_SUITE_PATHS, test_suite_descriptions=TEST_SUITE_DESCRIPTIONS, **args): +def update_test_suite(new_versions, assert_unchanged=False, test_suite_paths=TEST_SUITE_PATHS, test_suite_descriptions=TEST_SUITE_DESCRIPTIONS, test_suite_outdated_paths=tuple(), **args): assert(len(new_versions) == len(test_suite_paths)) assert(len(new_versions) == len(test_suite_descriptions)) for i, (v, path, descr) in enumerate(zip(new_versions, test_suite_paths, test_suite_descriptions)): - if not os.path.exists(path): - raise Exception('Could not find existing file %s' % os.path.relpath(path, ROOT_PATH)) + contents = None + suggest_add = False + if os.path.exists(path): + with open(path, 'r') as f: contents = f.read() + else: + suggest_add = True if '%s' in descr: descr = descr % v - with open(path, 'r') as f: contents = f.read() lines = ['(* -*- coq-prog-args: ("-compat" "%s") -*- *)' % v, '(** Check that the %s compatibility flag actually requires the relevant modules. *)' % descr] for imp_v in reversed(new_versions[i:]): lines.append('Import Coq.Compat.%s.' % version_name_to_compat_name(imp_v, ext='')) lines.append('') new_contents = '\n'.join(lines) - update_if_changed(contents, new_contents, path, **args) + update_if_changed(contents, new_contents, path, suggest_add=suggest_add, **args) + for path in test_suite_outdated_paths: + remove_if_exists(path, assert_unchanged=assert_unchanged, **args) def update_doc_index(new_versions, **args): with open(DOC_INDEX_PATH, 'r') as f: contents = f.read() @@ -264,17 +387,48 @@ def update_doc_index(new_versions, **args): new_contents = new_contents.replace(firstline, '\n'.join([firstline] + extra_lines)) update_if_changed(contents, new_contents, DOC_INDEX_PATH, **args) +def update_test_suite_run(**args): + with open(TEST_SUITE_RUN_PATH, 'r') as f: contents = f.read() + new_contents = r'''#!/usr/bin/env bash + +# allow running this script from any directory by basing things on where the script lives +SCRIPT_DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null && pwd )" + +# we assume that the script lives in test-suite/tools/update-compat/, +# and that update-compat.py lives in dev/tools/ +cd "${SCRIPT_DIR}/../../.." +dev/tools/update-compat.py --assert-unchanged %s || exit $? +''' % ' '.join([('--master' if args['master'] else ''), ('--release' if args['release'] else '')]).strip() + update_if_changed(contents, new_contents, TEST_SUITE_RUN_PATH, pass_through_shebang=True, **args) + def update_bug_4789(new_versions, **args): # we always update this compat notation to oldest # currently-supported compat version, which should never be the # current version with open(BUG_4798_PATH, 'r') as f: contents = f.read() - new_contents = r"""Check match 2 with 0 => 0 | S n => n end. + new_contents = BUG_HEADER + r"""Check match 2 with 0 => 0 | S n => n end. Notation "|" := 1 (compat "%s"). Check match 2 with 0 => 0 | S n => n end. (* fails *) """ % new_versions[0] update_if_changed(contents, new_contents, BUG_4798_PATH, **args) +def update_bug_9166(new_versions, **args): + # we always update this compat notation to oldest + # currently-supported compat version, which should never be the + # current version + with open(BUG_9166_PATH, 'r') as f: contents = f.read() + new_contents = BUG_HEADER + r"""Set Warnings "+deprecated". + +Notation bar := option (compat "%s"). + +Definition foo (x: nat) : nat := + match x with + | 0 => 0 + | S bar => bar + end. +""" % new_versions[0] + update_if_changed(contents, new_contents, BUG_9166_PATH, **args) + def update_compat_notations_in(old_versions, new_versions, contents): for v in old_versions: if v not in new_versions: @@ -305,11 +459,26 @@ def parse_args(argv): args = { 'assert_unchanged': False, 'cur_version': None, - 'number_of_old_versions': DEFAULT_NUMBER_OF_OLD_VERSIONS + 'number_of_old_versions': None, + 'master': False, + 'release': False, + 'git_add': False, } + if '--master' not in argv and '--release' not in argv: + print(r'''WARNING: You should pass either --release (sometime before branching) + or --master (right after branching and updating the version number in version.ml)''') + if '--assert-unchanged' not in args: break_or_continue() for arg in argv[1:]: if arg == '--assert-unchanged': args['assert_unchanged'] = True + elif arg == '--git-add': + args['git_add'] = True + elif arg == '--master': + args['master'] = True + if args['number_of_old_versions'] is None: args['number_of_old_versions'] = MASTER_NUMBER_OF_OLD_VERSIONS + elif arg == '--release': + args['release'] = True + if args['number_of_old_versions'] is None: args['number_of_old_versions'] = RELEASE_NUMBER_OF_OLD_VERSIONS elif arg.startswith('--cur-version='): args['cur_version'] = arg[len('--cur-version='):] assert(len(args['cur_version'].split('.')) == 2) @@ -317,10 +486,11 @@ def parse_args(argv): elif arg.startswith('--number-of-old-versions='): args['number_of_old_versions'] = int(arg[len('--number-of-old-versions='):]) else: - print('USAGE: %s [--assert-unchanged] [--cur-version=NN.NN] [--number-of-old-versions=NN]' % argv[0]) + print('USAGE: %s [--assert-unchanged] [--cur-version=NN.NN] [--number-of-old-versions=NN] [--git-add]' % argv[0]) print('') print('ERROR: Unrecognized argument: %s' % arg) sys.exit(1) + if args['number_of_old_versions'] is None: args['number_of_old_versions'] = DEFAULT_NUMBER_OF_OLD_VERSIONS return args if __name__ == '__main__': @@ -331,11 +501,14 @@ if __name__ == '__main__': new_versions = get_new_versions(known_versions, **args) assert(len(TEST_SUITE_PATHS) >= args['number_of_compat_versions']) args['test_suite_paths'] = tuple(TEST_SUITE_PATHS[-args['number_of_compat_versions']:]) + args['test_suite_outdated_paths'] = tuple(TEST_SUITE_PATHS[:-args['number_of_compat_versions']]) args['test_suite_descriptions'] = tuple(TEST_SUITE_DESCRIPTIONS[-args['number_of_compat_versions']:]) update_compat_files(known_versions, new_versions, **args) update_flags(known_versions, new_versions, **args) update_test_suite(new_versions, **args) + update_test_suite_run(**args) update_doc_index(new_versions, **args) update_bug_4789(new_versions, **args) + update_bug_9166(new_versions, **args) update_compat_notations(known_versions, new_versions, **args) display_git_grep(known_versions, new_versions) diff --git a/doc/README.md b/doc/README.md index 3db1261656..c41d269437 100644 --- a/doc/README.md +++ b/doc/README.md @@ -101,18 +101,21 @@ Alternatively, you can use some specific targets: Also note the `-with-doc yes` option of `./configure` to enable the build of the documentation as part of the default make target. -If you're editing Sphinx documentation, set SPHINXWARNERROR to 0 -to avoid treating Sphinx warnings as errors. Otherwise, Sphinx quits -upon detecting the first warning. You can set this on the Sphinx `make` -command line or as an environment variable: - -- `make refman SPHINXWARNERROR=0` - -- ~~~ - export SPHINXWARNERROR=0 - ⋮ - make refman - ~~~ +To build the Sphinx documentation without stopping at the first +warning with the legacy Makefile, set `SPHINXWARNERROR` to 0 as such: + +``` +SPHINXWARNERROR=0 make refman-html +``` + +To do the same with the Dune build system, change the value of the +`SPHINXWARNOPT` variable (default is `-W`). The following will build +the Sphinx documentation without stopping at the first warning, and +store all the warnings in the file `/tmp/warn.log`: + +``` +SPHINXWARNOPT="-w/tmp/warn.log" dune build @refman-html +``` Installation ------------ diff --git a/doc/common/macros.tex b/doc/common/macros.tex index 6a28c5b3d1..927a912fbf 100644 --- a/doc/common/macros.tex +++ b/doc/common/macros.tex @@ -242,7 +242,7 @@ \newcommand{\vref}{\nterm{ref}} \newcommand{\zarithformula}{\nterm{zarith\_formula}} \newcommand{\zarith}{\nterm{zarith}} -\newcommand{\ltac}{\mbox{${\cal L}_{tac}$}} +\newcommand{\ltac}{\mbox{${\mathcal{L}}_{tac}$}} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % \mbox{\sf } series for roman text in maths formulas % @@ -373,15 +373,15 @@ \newcommand{\sumbool}[2]{\{#1\}+\{#2\}} \newcommand{\myifthenelse}[3]{\kw{if} ~ #1 ~\kw{then} ~ #2 ~ \kw{else} ~ #3} \newcommand{\fun}[2]{\item[]{\tt {#1}}. \quad\\ #2} -\newcommand{\WF}[2]{\ensuremath{{\cal W\!F}(#1)[#2]}} -\newcommand{\WFTWOLINES}[2]{\ensuremath{{\cal W\!F}\begin{array}{l}(#1)\\\mbox{}[{#2}]\end{array}}} +\newcommand{\WF}[2]{\ensuremath{{\mathcal{W\!F}}(#1)[#2]}} +\newcommand{\WFTWOLINES}[2]{\ensuremath{{\mathcal{W\!F}}\begin{array}{l}(#1)\\\mbox{}[{#2}]\end{array}}} \newcommand{\WFE}[1]{\WF{E}{#1}} \newcommand{\WT}[4]{\ensuremath{#1[#2] \vdash #3 : #4}} \newcommand{\WTE}[3]{\WT{E}{#1}{#2}{#3}} \newcommand{\WTEG}[2]{\WTE{\Gamma}{#1}{#2}} \newcommand{\WTM}[3]{\WT{#1}{}{#2}{#3}} -\newcommand{\WFT}[2]{\ensuremath{#1[] \vdash {\cal W\!F}(#2)}} +\newcommand{\WFT}[2]{\ensuremath{#1[] \vdash {\mathcal{W\!F}}(#2)}} \newcommand{\WS}[3]{\ensuremath{#1[] \vdash #2 <: #3}} \newcommand{\WSE}[2]{\WS{E}{#1}{#2}} \newcommand{\WEV}[3]{\mbox{$#1[] \vdash #2 \lra #3$}} @@ -427,7 +427,7 @@ \newcommand{\letin}[3]{\kw{let}~#1:=#2~\kw{in}~#3} \newcommand{\subst}[3]{#1\{#2/#3\}} \newcommand{\substs}[4]{#1\{(#2/#3)_{#4}\}} -\newcommand{\Sort}{\mbox{$\cal S$}} +\newcommand{\Sort}{\mbox{$\mathcal{S}$}} \newcommand{\convert}{=_{\beta\delta\iota\zeta\eta}} \newcommand{\leconvert}{\leq_{\beta\delta\iota\zeta\eta}} \newcommand{\NN}{\mathbb{N}} @@ -10,8 +10,10 @@ ; + tools/coqdoc/coqdoc.css (package coq) (source_tree sphinx) - (source_tree tools)) - (action (run sphinx-build -j4 -b html -d sphinx_build/doctrees sphinx sphinx_build/html))) + (source_tree tools) + (env_var SPHINXWARNOPT)) + (action + (run sphinx-build -j4 %{env:SPHINXWARNOPT=-W} -b html -d sphinx_build/doctrees sphinx sphinx_build/html))) (alias (name refman-html) diff --git a/doc/plugin_tutorial/.gitignore b/doc/plugin_tutorial/.gitignore new file mode 100644 index 0000000000..3e4978fac4 --- /dev/null +++ b/doc/plugin_tutorial/.gitignore @@ -0,0 +1,13 @@ +*.ml*.d +*.cm[ixt]* +Makefile.coq* +*~ +*.[ao] +.coqdeps.d +*.vo +*.glob +*.aux +*/*/.merlin + +# by convention g_foo.ml is generated +g_*.ml diff --git a/doc/plugin_tutorial/.travis.yml b/doc/plugin_tutorial/.travis.yml new file mode 100644 index 0000000000..556e0ac45a --- /dev/null +++ b/doc/plugin_tutorial/.travis.yml @@ -0,0 +1,38 @@ +dist: trusty +sudo: required +language: generic + +services: + - docker + +env: + global: + - NJOBS="2" + - CONTRIB_NAME="plugin_tutorials" + matrix: + - COQ_IMAGE="coqorg/coq:dev" + +install: | + # Prepare the COQ container + docker run -d -i --init --name=COQ -v ${TRAVIS_BUILD_DIR}:/home/coq/$CONTRIB_NAME -w /home/coq/$CONTRIB_NAME ${COQ_IMAGE} + docker exec COQ /bin/bash --login -c " + # This bash script is double-quoted to interpolate Travis CI env vars: + echo \"Build triggered by ${TRAVIS_EVENT_TYPE}\" + export PS4='+ \e[33;1m(\$0 @ line \$LINENO) \$\e[0m ' + set -ex # -e = exit on failure; -x = trace for debug + opam list + " +script: +- echo -e "${ANSI_YELLOW}Building $CONTRIB_NAME...${ANSI_RESET}" && echo -en 'travis_fold:start:testbuild\\r' +- | + docker exec COQ /bin/bash --login -c " + export PS4='+ \e[33;1m(\$0 @ line \$LINENO) \$\e[0m ' + set -ex + sudo chown -R coq:coq /home/coq/$CONTRIB_NAME + ( cd tuto0 && make ) + ( cd tuto1 && make ) + ( cd tuto2 && make ) + ( cd tuto3 && make ) + " +- docker stop COQ # optional +- echo -en 'travis_fold:end:testbuild\\r' diff --git a/doc/plugin_tutorial/LICENSE b/doc/plugin_tutorial/LICENSE new file mode 100644 index 0000000000..cf1ab25da0 --- /dev/null +++ b/doc/plugin_tutorial/LICENSE @@ -0,0 +1,24 @@ +This is free and unencumbered software released into the public domain. + +Anyone is free to copy, modify, publish, use, compile, sell, or +distribute this software, either in source code form or as a compiled +binary, for any purpose, commercial or non-commercial, and by any +means. + +In jurisdictions that recognize copyright laws, the author or authors +of this software dedicate any and all copyright interest in the +software to the public domain. We make this dedication for the benefit +of the public at large and to the detriment of our heirs and +successors. We intend this dedication to be an overt act of +relinquishment in perpetuity of all present and future rights to this +software under copyright law. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR +OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, +ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. + +For more information, please refer to <http://unlicense.org> diff --git a/doc/plugin_tutorial/Makefile b/doc/plugin_tutorial/Makefile new file mode 100644 index 0000000000..7f1833fadd --- /dev/null +++ b/doc/plugin_tutorial/Makefile @@ -0,0 +1,21 @@ + +TUTOS:= \ + tuto0 \ + tuto1 \ + tuto2 \ + tuto3 + +all: $(TUTOS) + +.PHONY: $(TUTOS) all + +$(TUTOS): %: + +$(MAKE) -C $@ + +CLEANS:=$(addsuffix -clean, $(TUTOS)) +.PHONY: clean $(CLEANS) + +clean: $(CLEANS) + +%-clean: + +$(MAKE) -C $* clean diff --git a/doc/plugin_tutorial/README.md b/doc/plugin_tutorial/README.md new file mode 100644 index 0000000000..f82edb2352 --- /dev/null +++ b/doc/plugin_tutorial/README.md @@ -0,0 +1,86 @@ +How to write plugins in Coq +=========================== + # Working environment : merlin, tuareg (open question) + + ## OCaml & related tools + + These instructions use [OPAM](http://opam.ocaml.org/doc/Install.html) + +```shell +opam init --root=$PWD/CIW2018 --compiler=4.06.0 -j2 +eval `opam config env --root=$PWD/CIW2018` +opam install camlp5 ocamlfind num # Coq's dependencies +opam install lablgtk # Coqide's dependencies (optional) +opam install merlin # prints instructions for vim and emacs +``` + + ## Coq + +```shell +git clone git@github.com:coq/coq.git +cd coq +./configure -profile devel +make -j2 +cd .. +export PATH=$PWD/coq/bin:$PATH +``` + + ## This tutorial + +```shell +git clone git@github.com:ybertot/plugin_tutorials.git +cd plugin_tutorials/tuto0 +make .merlin # run before opening .ml files in your editor +make # build +``` + + + + # tuto0 : basics of project organization + package a ml4 file in a plugin, organize a `Makefile`, `_CoqProject` + - Example of syntax to add a new toplevel command + - Example of function call to print a simple message + - Example of syntax to add a simple tactic + (that does nothing and prints a message) + - To use it: + +```bash + cd tuto0; make + coqtop -I src -R theories Tuto0 +``` + + In the Coq session type: +```coq + Require Import Tuto0.Loader. HelloWorld. +``` + + # tuto1 : Ocaml to Coq communication + Explore the memory of Coq, modify it + - Commands that take arguments: strings, symbols, expressions of the calculus of constructions + - Commands that interact with type-checking in Coq + - A command that adds a new definition or theorem + - A command that uses a name and exploits the existing definitions + or theorems + - A command that exploits an existing ongoing proof + - A command that defines a new tactic + + Compilation and loading must be performed as for `tuto0`. + + # tuto2 : Ocaml to Coq communication + A more step by step introduction to writing commands + - Explanation of the syntax of entries + - Adding a new type to and parsing to the available choices + - Handling commands that store information in user-chosen registers and tables + + Compilation and loading must be performed as for `tuto1`. + + # tuto3 : manipulating terms of the calculus of constructions + Manipulating terms, inside commands and tactics. + - Obtaining existing values from memory + - Composing values + - Verifying types + - Using these terms in commands + - Using these terms in tactics + - Automatic proofs without tactics using type classes and canonical structures + + compilation and loading must be performed as for `tuto0`. diff --git a/doc/plugin_tutorial/tuto0/Makefile b/doc/plugin_tutorial/tuto0/Makefile new file mode 100644 index 0000000000..e0e197650d --- /dev/null +++ b/doc/plugin_tutorial/tuto0/Makefile @@ -0,0 +1,14 @@ +ifeq "$(COQBIN)" "" + COQBIN=$(dir $(shell which coqtop))/ +endif + +%: Makefile.coq + +Makefile.coq: _CoqProject + $(COQBIN)coq_makefile -f _CoqProject -o Makefile.coq + +tests: all + @$(MAKE) -C tests -s clean + @$(MAKE) -C tests -s all + +-include Makefile.coq diff --git a/doc/plugin_tutorial/tuto0/_CoqProject b/doc/plugin_tutorial/tuto0/_CoqProject new file mode 100644 index 0000000000..76368e3ac7 --- /dev/null +++ b/doc/plugin_tutorial/tuto0/_CoqProject @@ -0,0 +1,10 @@ +-R theories/ Tuto0 +-I src + +theories/Loader.v +theories/Demo.v + +src/tuto0_main.ml +src/tuto0_main.mli +src/g_tuto0.mlg +src/tuto0_plugin.mlpack diff --git a/doc/plugin_tutorial/tuto0/src/dune b/doc/plugin_tutorial/tuto0/src/dune new file mode 100644 index 0000000000..79d561061d --- /dev/null +++ b/doc/plugin_tutorial/tuto0/src/dune @@ -0,0 +1,9 @@ +(library + (name tuto0_plugin) + (public_name coq.plugins.tutorial.p0) + (libraries coq.plugins.ltac)) + +(rule + (targets g_tuto0.ml) + (deps (:pp-file g_tuto0.mlg) ) + (action (run coqpp %{pp-file}))) diff --git a/doc/plugin_tutorial/tuto0/src/g_tuto0.mlg b/doc/plugin_tutorial/tuto0/src/g_tuto0.mlg new file mode 100644 index 0000000000..5c633fe862 --- /dev/null +++ b/doc/plugin_tutorial/tuto0/src/g_tuto0.mlg @@ -0,0 +1,18 @@ +DECLARE PLUGIN "tuto0_plugin" + +{ + +open Pp +open Ltac_plugin + +} + +VERNAC COMMAND EXTEND HelloWorld CLASSIFIED AS QUERY +| [ "HelloWorld" ] -> { Feedback.msg_notice (strbrk Tuto0_main.message) } +END + +TACTIC EXTEND hello_world_tactic +| [ "hello_world" ] -> + { let _ = Feedback.msg_notice (str Tuto0_main.message) in + Tacticals.New.tclIDTAC } +END diff --git a/doc/plugin_tutorial/tuto0/src/tuto0_main.ml b/doc/plugin_tutorial/tuto0/src/tuto0_main.ml new file mode 100644 index 0000000000..93a807a800 --- /dev/null +++ b/doc/plugin_tutorial/tuto0/src/tuto0_main.ml @@ -0,0 +1 @@ +let message = "Hello world!" diff --git a/doc/plugin_tutorial/tuto0/src/tuto0_main.mli b/doc/plugin_tutorial/tuto0/src/tuto0_main.mli new file mode 100644 index 0000000000..846af3ed8c --- /dev/null +++ b/doc/plugin_tutorial/tuto0/src/tuto0_main.mli @@ -0,0 +1 @@ +val message : string diff --git a/doc/plugin_tutorial/tuto0/src/tuto0_plugin.mlpack b/doc/plugin_tutorial/tuto0/src/tuto0_plugin.mlpack new file mode 100644 index 0000000000..73be1bb561 --- /dev/null +++ b/doc/plugin_tutorial/tuto0/src/tuto0_plugin.mlpack @@ -0,0 +1,2 @@ +Tuto0_main +G_tuto0 diff --git a/doc/plugin_tutorial/tuto0/theories/Demo.v b/doc/plugin_tutorial/tuto0/theories/Demo.v new file mode 100644 index 0000000000..bdc61986af --- /dev/null +++ b/doc/plugin_tutorial/tuto0/theories/Demo.v @@ -0,0 +1,8 @@ +From Tuto0 Require Import Loader. + +HelloWorld. + +Lemma test : True. +Proof. +hello_world. +Abort. diff --git a/doc/plugin_tutorial/tuto0/theories/Loader.v b/doc/plugin_tutorial/tuto0/theories/Loader.v new file mode 100644 index 0000000000..7bce38382b --- /dev/null +++ b/doc/plugin_tutorial/tuto0/theories/Loader.v @@ -0,0 +1 @@ +Declare ML Module "tuto0_plugin". diff --git a/doc/plugin_tutorial/tuto1/Makefile b/doc/plugin_tutorial/tuto1/Makefile new file mode 100644 index 0000000000..e0e197650d --- /dev/null +++ b/doc/plugin_tutorial/tuto1/Makefile @@ -0,0 +1,14 @@ +ifeq "$(COQBIN)" "" + COQBIN=$(dir $(shell which coqtop))/ +endif + +%: Makefile.coq + +Makefile.coq: _CoqProject + $(COQBIN)coq_makefile -f _CoqProject -o Makefile.coq + +tests: all + @$(MAKE) -C tests -s clean + @$(MAKE) -C tests -s all + +-include Makefile.coq diff --git a/doc/plugin_tutorial/tuto1/_CoqProject b/doc/plugin_tutorial/tuto1/_CoqProject new file mode 100644 index 0000000000..585d1360be --- /dev/null +++ b/doc/plugin_tutorial/tuto1/_CoqProject @@ -0,0 +1,13 @@ +-R theories Tuto1 +-I src + +theories/Loader.v + +src/simple_check.mli +src/simple_check.ml +src/simple_declare.mli +src/simple_declare.ml +src/simple_print.ml +src/simple_print.mli +src/g_tuto1.mlg +src/tuto1_plugin.mlpack diff --git a/doc/plugin_tutorial/tuto1/src/dune b/doc/plugin_tutorial/tuto1/src/dune new file mode 100644 index 0000000000..cf9c674b14 --- /dev/null +++ b/doc/plugin_tutorial/tuto1/src/dune @@ -0,0 +1,9 @@ +(library + (name tuto1_plugin) + (public_name coq.plugins.tutorial.p1) + (libraries coq.plugins.ltac)) + +(rule + (targets g_tuto1.ml) + (deps (:pp-file g_tuto1.mlg) ) + (action (run coqpp %{pp-file}))) diff --git a/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg b/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg new file mode 100644 index 0000000000..4df284d2d9 --- /dev/null +++ b/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg @@ -0,0 +1,154 @@ +DECLARE PLUGIN "tuto1_plugin" + +{ + +(* If we forget this line and include our own tactic definition using + TACTIC EXTEND, as below, then we get the strange error message + no implementation available for Tacentries, only when compiling + theories/Loader.v +*) +open Ltac_plugin +open Attributes +open Pp +(* This module defines the types of arguments to be used in the + EXTEND directives below, for example the string one. *) +open Stdarg + +} + +VERNAC COMMAND EXTEND HelloWorld CLASSIFIED AS QUERY +| [ "Hello" string(s) ] -> + { Feedback.msg_notice (strbrk "Hello " ++ str s) } +END + +(* reference is allowed as a syntactic entry, but so are all the entries + found the signature of module Prim in file coq/parsing/pcoq.mli *) + +VERNAC COMMAND EXTEND HelloAgain CLASSIFIED AS QUERY +| [ "HelloAgain" reference(r)] -> +(* The function Ppconstr.pr_qualid was found by searching all mli files + for a function of type qualid -> Pp.t *) + { Feedback.msg_notice + (strbrk "Hello again " ++ Ppconstr.pr_qualid r)} +END + +(* According to parsing/pcoq.mli, e has type constr_expr *) +(* this type is defined in pretyping/constrexpr.ml *) +(* Question for the developers: why is the file constrexpr.ml and not + constrexpr.mli --> Easier for packing the software in components. *) +VERNAC COMMAND EXTEND TakingConstr CLASSIFIED AS QUERY +| [ "Cmd1" constr(e) ] -> + { let _ = e in Feedback.msg_notice (strbrk "Cmd1 parsed something") } +END + +(* The next step is to make something of parsed expression. + Interesting information in interp/constrintern.mli *) + +(* There are several phases of transforming a parsed expression into + the final internal data-type (constr). There exists a collection of + functions that combine all the phases *) + +VERNAC COMMAND EXTEND TakingConstr2 CLASSIFIED AS QUERY +| [ "Cmd2" constr(e) ] -> + { let _ = Constrintern.interp_constr + (Global.env()) + (* Make sure you don't use Evd.empty here, as this does not + check consistency with existing universe constraints. *) + (Evd.from_env (Global.env())) e in + Feedback.msg_notice (strbrk "Cmd2 parsed something legitimate") } +END + +(* This is to show what happens when typing in an empty environment + with an empty evd. + Question for the developers: why does "Cmd3 (fun x : nat => x)." + raise an anomaly, not the same error as "Cmd3 (fun x : a => x)." *) + +VERNAC COMMAND EXTEND TakingConstr3 CLASSIFIED AS QUERY +| [ "Cmd3" constr(e) ] -> + { let _ = Constrintern.interp_constr Environ.empty_env + Evd.empty e in + Feedback.msg_notice + (strbrk "Cmd3 accepted something in the empty context")} +END + +(* When adding a definition, we have to be careful that just + the operation of constructing a well-typed term may already change + the environment, at the level of universe constraints (which + are recorded in the evd component). The function + Constrintern.interp_constr ignores this side-effect, so it should + not be used here. *) + +(* Looking at the interface file interp/constrintern.ml4, I lost + some time because I did not see that the "constr" type appearing + there was "EConstr.constr" and not "Constr.constr". *) + +VERNAC COMMAND EXTEND Define1 CLASSIFIED AS SIDEFF +| #[ poly = polymorphic ] [ "Cmd4" ident(i) constr(e) ] -> + { let v = Constrintern.interp_constr (Global.env()) + (Evd.from_env (Global.env())) e in + Simple_declare.packed_declare_definition ~poly i v } +END + +VERNAC COMMAND EXTEND Check1 CLASSIFIED AS QUERY +| [ "Cmd5" constr(e) ] -> + { let v = Constrintern.interp_constr (Global.env()) + (Evd.from_env (Global.env())) e in + let (_, ctx) = v in + let evd = Evd.from_ctx ctx in + Feedback.msg_notice + (Printer.pr_econstr_env (Global.env()) evd + (Simple_check.simple_check1 v)) } +END + +VERNAC COMMAND EXTEND Check2 CLASSIFIED AS QUERY +| [ "Cmd6" constr(e) ] -> + { let v = Constrintern.interp_constr (Global.env()) + (Evd.from_env (Global.env())) e in + let evd, ty = Simple_check.simple_check2 v in + Feedback.msg_notice + (Printer.pr_econstr_env (Global.env()) evd ty) } +END + +VERNAC COMMAND EXTEND Check1 CLASSIFIED AS QUERY +| [ "Cmd7" constr(e) ] -> + { let v = Constrintern.interp_constr (Global.env()) + (Evd.from_env (Global.env())) e in + let (a, ctx) = v in + let evd = Evd.from_ctx ctx in + Feedback.msg_notice + (Printer.pr_econstr_env (Global.env()) evd + (Simple_check.simple_check3 v)) } +END + +(* This command takes a name and return its value. It does less + than Print, because it fails on constructors, axioms, and inductive types. + This should be improved, because the error message is an anomaly. + Anomalies should never appear even when using a command outside of its + intended use. *) +VERNAC COMMAND EXTEND ExamplePrint CLASSIFIED AS QUERY +| [ "Cmd8" reference(r) ] -> + { let env = Global.env() in + let evd = Evd.from_env env in + Feedback.msg_notice + (Printer.pr_econstr_env env evd + (EConstr.of_constr + (Simple_print.simple_body_access (Nametab.global r)))) } +END + +TACTIC EXTEND my_intro +| [ "my_intro" ident(i) ] -> + { Tactics.introduction i } +END + +(* if one write this: + VERNAC COMMAND EXTEND exploreproof CLASSIFIED AS QUERY + it gives an error message that is basically impossible to understand. *) + +VERNAC COMMAND EXTEND ExploreProof CLASSIFIED AS QUERY +| [ "Cmd9" ] -> + { let p = Proof_global.give_me_the_proof () in + let sigma, env = Pfedit.get_current_context () in + let pprf = Proof.partial_proof p in + Feedback.msg_notice + (Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf) } +END diff --git a/doc/plugin_tutorial/tuto1/src/simple_check.ml b/doc/plugin_tutorial/tuto1/src/simple_check.ml new file mode 100644 index 0000000000..1f636c531a --- /dev/null +++ b/doc/plugin_tutorial/tuto1/src/simple_check.ml @@ -0,0 +1,32 @@ +let simple_check1 value_with_constraints = + begin + let evalue, st = value_with_constraints in + let evd = Evd.from_ctx st in +(* This is reverse engineered from vernacentries.ml *) +(* The point of renaming is to make sure the bound names printed by Check + can be re-used in `apply with` tactics that use bound names to + refer to arguments. *) + let j = Termops.on_judgment EConstr.of_constr + (Arguments_renaming.rename_typing (Global.env()) + (EConstr.to_constr evd evalue)) in + let {Environ.uj_type=x}=j in x + end + +let simple_check2 value_with_constraints = + let evalue, st = value_with_constraints in + let evd = Evd.from_ctx st in +(* This version should be preferred if bound variable names are not so + important, you want to really verify that the input is well-typed, + and if you want to obtain the type. *) +(* Note that the output value is a pair containing a new evar_map: + typing will fill out blanks in the term by add evar bindings. *) + Typing.type_of (Global.env()) evd evalue + +let simple_check3 value_with_constraints = + let evalue, st = value_with_constraints in + let evd = Evd.from_ctx st in +(* This version should be preferred if bound variable names are not so + important and you already expect the input to have been type-checked + before. Set ~lax to false if you want an anomaly to be raised in + case of a type error. Otherwise a ReTypeError exception is raised. *) + Retyping.get_type_of ~lax:true (Global.env()) evd evalue diff --git a/doc/plugin_tutorial/tuto1/src/simple_check.mli b/doc/plugin_tutorial/tuto1/src/simple_check.mli new file mode 100644 index 0000000000..bcf1bf56cf --- /dev/null +++ b/doc/plugin_tutorial/tuto1/src/simple_check.mli @@ -0,0 +1,8 @@ +val simple_check1 : + EConstr.constr Evd.in_evar_universe_context -> EConstr.constr + +val simple_check2 : + EConstr.constr Evd.in_evar_universe_context -> Evd.evar_map * EConstr.constr + +val simple_check3 : + EConstr.constr Evd.in_evar_universe_context -> EConstr.constr diff --git a/doc/plugin_tutorial/tuto1/src/simple_declare.ml b/doc/plugin_tutorial/tuto1/src/simple_declare.ml new file mode 100644 index 0000000000..9d10a8ba72 --- /dev/null +++ b/doc/plugin_tutorial/tuto1/src/simple_declare.ml @@ -0,0 +1,24 @@ +(* Ideally coq/coq#8811 would get merged and then this function could be much simpler. *) +let edeclare ident (_, poly, _ as k) ~opaque sigma udecl body tyopt imps hook = + let sigma = Evd.minimize_universes sigma in + let body = EConstr.to_constr sigma body in + let tyopt = Option.map (EConstr.to_constr sigma) tyopt in + let uvars_fold uvars c = + Univ.LSet.union uvars (Vars.universes_of_constr c) in + let uvars = List.fold_left uvars_fold Univ.LSet.empty + (Option.List.cons tyopt [body]) in + let sigma = Evd.restrict_universe_context sigma uvars in + let univs = Evd.check_univ_decl ~poly sigma udecl in + let ubinders = Evd.universe_binders sigma in + let ce = Declare.definition_entry ?types:tyopt ~univs body in + DeclareDef.declare_definition ident k ce ubinders imps ~hook + +let packed_declare_definition ~poly ident value_with_constraints = + let body, ctx = value_with_constraints in + let sigma = Evd.from_ctx ctx in + let k = (Decl_kinds.Global, poly, Decl_kinds.Definition) in + let udecl = UState.default_univ_decl in + let nohook = Lemmas.mk_hook (fun _ x -> ()) in + ignore (edeclare ident k ~opaque:false sigma udecl body None [] nohook) + +(* But this definition cannot be undone by Reset ident *) diff --git a/doc/plugin_tutorial/tuto1/src/simple_declare.mli b/doc/plugin_tutorial/tuto1/src/simple_declare.mli new file mode 100644 index 0000000000..fd74e81526 --- /dev/null +++ b/doc/plugin_tutorial/tuto1/src/simple_declare.mli @@ -0,0 +1,5 @@ +open Names +open EConstr + +val packed_declare_definition : + poly:bool -> Id.t -> constr Evd.in_evar_universe_context -> unit diff --git a/doc/plugin_tutorial/tuto1/src/simple_print.ml b/doc/plugin_tutorial/tuto1/src/simple_print.ml new file mode 100644 index 0000000000..cfc38ff9c9 --- /dev/null +++ b/doc/plugin_tutorial/tuto1/src/simple_print.ml @@ -0,0 +1,17 @@ +(* A more advanced example of how to explore the structure of terms of + type constr is given in the coq-dpdgraph plugin. *) + +let simple_body_access gref = + match gref with + | Globnames.VarRef _ -> + failwith "variables are not covered in this example" + | Globnames.IndRef _ -> + failwith "inductive types are not covered in this example" + | Globnames.ConstructRef _ -> + failwith "constructors are not covered in this example" + | Globnames.ConstRef cst -> + let cb = Environ.lookup_constant cst (Global.env()) in + match Global.body_of_constant_body cb with + | Some(e, _) -> e + | None -> failwith "This term has no value" + diff --git a/doc/plugin_tutorial/tuto1/src/simple_print.mli b/doc/plugin_tutorial/tuto1/src/simple_print.mli new file mode 100644 index 0000000000..254b56ff79 --- /dev/null +++ b/doc/plugin_tutorial/tuto1/src/simple_print.mli @@ -0,0 +1 @@ +val simple_body_access : Names.GlobRef.t -> Constr.constr diff --git a/doc/plugin_tutorial/tuto1/src/tuto1_plugin.mlpack b/doc/plugin_tutorial/tuto1/src/tuto1_plugin.mlpack new file mode 100644 index 0000000000..a797a509e0 --- /dev/null +++ b/doc/plugin_tutorial/tuto1/src/tuto1_plugin.mlpack @@ -0,0 +1,4 @@ +Simple_check +Simple_declare +Simple_print +G_tuto1 diff --git a/doc/plugin_tutorial/tuto1/theories/Loader.v b/doc/plugin_tutorial/tuto1/theories/Loader.v new file mode 100644 index 0000000000..6e8e308b3f --- /dev/null +++ b/doc/plugin_tutorial/tuto1/theories/Loader.v @@ -0,0 +1 @@ +Declare ML Module "tuto1_plugin". diff --git a/doc/plugin_tutorial/tuto2/Makefile b/doc/plugin_tutorial/tuto2/Makefile new file mode 100644 index 0000000000..e0e197650d --- /dev/null +++ b/doc/plugin_tutorial/tuto2/Makefile @@ -0,0 +1,14 @@ +ifeq "$(COQBIN)" "" + COQBIN=$(dir $(shell which coqtop))/ +endif + +%: Makefile.coq + +Makefile.coq: _CoqProject + $(COQBIN)coq_makefile -f _CoqProject -o Makefile.coq + +tests: all + @$(MAKE) -C tests -s clean + @$(MAKE) -C tests -s all + +-include Makefile.coq diff --git a/doc/plugin_tutorial/tuto2/_CoqProject b/doc/plugin_tutorial/tuto2/_CoqProject new file mode 100644 index 0000000000..cf9cb5cc26 --- /dev/null +++ b/doc/plugin_tutorial/tuto2/_CoqProject @@ -0,0 +1,6 @@ +-R theories/ Tuto +-I src + +theories/Test.v +src/demo.mlg +src/demo_plugin.mlpack diff --git a/doc/plugin_tutorial/tuto2/src/.gitignore b/doc/plugin_tutorial/tuto2/src/.gitignore new file mode 100644 index 0000000000..5b1b6a902e --- /dev/null +++ b/doc/plugin_tutorial/tuto2/src/.gitignore @@ -0,0 +1 @@ +/demo.ml diff --git a/doc/plugin_tutorial/tuto2/src/demo.mlg b/doc/plugin_tutorial/tuto2/src/demo.mlg new file mode 100644 index 0000000000..966c05acdc --- /dev/null +++ b/doc/plugin_tutorial/tuto2/src/demo.mlg @@ -0,0 +1,375 @@ +(* -------------------------------------------------------------------------- *) +(* *) +(* Initial ritual dance *) +(* *) +(* -------------------------------------------------------------------------- *) + +DECLARE PLUGIN "demo_plugin" + +(* + Use this macro before any of the other OCaml macros. + + Each plugin has a unique name. + We have decided to name this plugin as "demo_plugin". + That means that: + + (1) If we want to load this particular plugin to Coq toplevel, + we must use the following command. + + Declare ML Module "demo_plugin". + + (2) The above command will succeed only if there is "demo_plugin.cmxs" + in some of the directories that Coq is supposed to look + (i.e. the ones we specified via "-I ..." command line options). + + (3) The file "demo_plugin.mlpack" lists the OCaml modules to be linked in + "demo_plugin.cmxs". + + (4) The file "demo_plugin.mlpack" as well as all .ml, .mli and .mlg files + are listed in the "_CoqProject" file. +*) + +(* -------------------------------------------------------------------------- *) +(* *) +(* How to define a new Vernacular command? *) +(* *) +(* -------------------------------------------------------------------------- *) + +VERNAC COMMAND EXTEND Cmd1 CLASSIFIED AS QUERY +| [ "Cmd1" ] -> { () } +END + +(* + These: + + VERNAC COMMAND EXTEND + + and + + END + + mark the beginning and the end of the definition of a new Vernacular command. + + Cmd1 is a unique identifier (which must start with an upper-case letter) + associated with the new Vernacular command we are defining. + + CLASSIFIED AS QUERY tells Coq that the new Vernacular command: + - changes neither the global environment + - nor does it modify the plugin's state. + + If the new command could: + - change the global environment + - or modify a plugin's state + then one would have to use CLASSIFIED AS SIDEFF instead. + + This: + + [ "Cmd1" ] -> { () } + + defines: + - the parsing rule + - the interpretation rule + + The parsing rule and the interpretation rule are separated by -> token. + + The parsing rule, in this case, is: + + [ "Cmd1" ] + + By convention, all vernacular command start with an upper-case letter. + + The [ and ] characters mark the beginning and the end of the parsing rule. + The parsing rule itself says that the syntax of the newly defined command + is composed from a single terminal Cmd1. + + The interpretation rule, in this case, is: + + { () } + + Similarly to the case of the parsing rule, + { and } characters mark the beginning and the end of the interpretation rule. + In this case, the following Ocaml expression: + + () + + defines the effect of the Vernacular command we have just defined. + That is, it behaves is no-op. +*) + +(* -------------------------------------------------------------------------- *) +(* *) +(* How to define a new Vernacular command with some terminal parameters? *) +(* *) +(* -------------------------------------------------------------------------- *) + +VERNAC COMMAND EXTEND Cmd2 CLASSIFIED AS QUERY +| [ "Cmd2" "With" "Some" "Terminal" "Parameters" ] -> { () } +END + +(* + As shown above, the Vernacular command can be composed from + any number of terminals. + + By convention, each of these terminals starts with an upper-case letter. +*) + +(* -------------------------------------------------------------------------- *) +(* *) +(* How to define a new Vernacular command with some non-terminal parameter? *) +(* *) +(* -------------------------------------------------------------------------- *) + +{ + +open Stdarg + +} + +VERNAC COMMAND EXTEND Cmd3 CLASSIFIED AS QUERY +| [ "Cmd3" int(i) ] -> { () } +END + +(* + This: + + open Stdarg + + is needed as some identifiers in the Ocaml code generated by the + + VERNAC COMMAND EXTEND ... END + + macros are not fully qualified. + + This: + + int(i) + + means that the new command is expected to be followed by an integer. + The integer is bound in the parsing rule to variable i. + This variable i then can be used in the interpretation rule. + + To see value of which Ocaml types can be bound this way, + look at the wit_* function declared in interp/stdarg.mli + (in the Coq's codebase). + + If we drop the wit_ prefix, we will get the token + that we can use in the parsing rule. + That is, since there exists wit_int, we know that + we can write: + + int(i) + + By looking at the signature of the wit_int function: + + val wit_int : int uniform_genarg_type + + we also know that variable i will have the type int. + + The types of wit_* functions are either: + + 'c uniform_genarg_type + + or + + ('a,'b,'c) genarg_type + + In both cases, the bound variable will have type 'c. +*) + +(* -------------------------------------------------------------------------- *) +(* *) +(* How to define a new Vernacular command with variable number of arguments? *) +(* *) +(* -------------------------------------------------------------------------- *) + +VERNAC COMMAND EXTEND Cmd4 CLASSIFIED AS QUERY +| [ "Cmd4" int_list(l) ] -> { () } +END + +(* + This: + + int_list(l) + + means that the new Vernacular command is expected to be followed + by a (whitespace separated) list of integers. + This list of integers is bound to the indicated l. + + In this case, as well as in the cases we point out below, instead of int + in int_list we could use any other supported type, e.g. ident, bool, ... + + To see which other Ocaml type constructors (in addition to list) + are supported, have a look at the parse_user_entry function defined + in grammar/q_util.mlp file. + + E.g.: + - ne_int_list(x) would represent a non-empty list of integers, + - int_list(x) would represent a list of integers, + - int_opt(x) would represent a value of type int option, + - ··· +*) + +(* -------------------------------------------------------------------------- *) +(* *) +(* How to define a new Vernacular command that takes values of a custom type? *) +(* *) +(* -------------------------------------------------------------------------- *) + +{ + +open Ltac_plugin + +} + +(* + If we want to avoid a compilation failure + + "no implementation available for Tacenv" + + then we have to open the Ltac_plugin module. +*) + +(* + Pp module must be opened because some of the macros that are part of the API + do not expand to fully qualified names. +*) + +{ + +type type_5 = Foo_5 | Bar_5 + +} + +(* + We define a type of values that we want to pass to our Vernacular command. +*) + +(* + By default, we are able to define new Vernacular commands that can take + parameters of some of the supported types. Which types are supported, + that was discussed earlier. + + If we want to be able to define Vernacular command that takes parameters + of a type that is not supported by default, we must use the following macro: +*) + +{ + +open Pp + +} + +VERNAC ARGUMENT EXTEND custom5 +| [ "Foo_5" ] -> { Foo_5 } +| [ "Bar_5" ] -> { Bar_5 } +END + +(* + where: + + custom5 + + indicates that, from now on, in our parsing rules we can write: + + custom5(some_variable) + + in those places where we expect user to provide an input + that can be parsed by the parsing rules above + (and interpreted by the interpretations rules above). +*) + +(* Here: *) + +VERNAC COMMAND EXTEND Cmd5 CLASSIFIED AS QUERY +| [ "Cmd5" custom5(x) ] -> { () } +END + +(* + we define a new Vernacular command whose parameters, provided by the user, + can be mapped to values of type_5. +*) + +(* -------------------------------------------------------------------------- *) +(* *) +(* How to give a feedback to the user? *) +(* *) +(* -------------------------------------------------------------------------- *) + +VERNAC COMMAND EXTEND Cmd6 CLASSIFIED AS QUERY +| [ "Cmd6" ] -> { Feedback.msg_notice (Pp.str "Everything is awesome!") } +END + +(* + The following functions: + + - Feedback.msg_info : Pp.t -> unit + - Feedback.msg_notice : Pp.t -> unit + - Feedback.msg_warning : Pp.t -> unit + - Feedback.msg_error : Pp.t -> unit + - Feedback.msg_debug : Pp.t -> unit + + enable us to give user a textual feedback. + + Pp module enable us to represent and construct pretty-printing instructions. + The concepts defined and the services provided by the Pp module are in + various respects related to the concepts and services provided + by the Format module that is part of the Ocaml standard library. +*) + +(* -------------------------------------------------------------------------- *) +(* *) +(* How to implement a Vernacular command with (undoable) side-effects? *) +(* *) +(* -------------------------------------------------------------------------- *) + +{ + +open Summary.Local + +} + +(* + By opening Summary.Local module we shadow the original functions + that we traditionally use for implementing stateful behavior. + + ref + ! + := + + are now shadowed by their counterparts in Summary.Local. *) + +{ + +let counter = ref ~name:"counter" 0 + +} + +VERNAC COMMAND EXTEND Cmd7 CLASSIFIED AS SIDEFF +| [ "Cmd7" ] -> { counter := succ !counter; + Feedback.msg_notice (Pp.str "counter = " ++ Pp.str (string_of_int (!counter))) } +END + +TACTIC EXTEND tactic1 +| [ "tactic1" ] -> { Proofview.tclUNIT () } +END + +(* ---- *) + +{ + +type custom = Foo_2 | Bar_2 + +let pr_custom _ _ _ = function + | Foo_2 -> Pp.str "Foo_2" + | Bar_2 -> Pp.str "Bar_2" + +} + +ARGUMENT EXTEND custom2 PRINTED BY { pr_custom } +| [ "Foo_2" ] -> { Foo_2 } +| [ "Bar_2" ] -> { Bar_2 } +END + +TACTIC EXTEND tactic2 +| [ "tactic2" custom2(x) ] -> { Proofview.tclUNIT () } +END diff --git a/doc/plugin_tutorial/tuto2/src/demo_plugin.mlpack b/doc/plugin_tutorial/tuto2/src/demo_plugin.mlpack new file mode 100644 index 0000000000..4f0b8480b5 --- /dev/null +++ b/doc/plugin_tutorial/tuto2/src/demo_plugin.mlpack @@ -0,0 +1 @@ +Demo diff --git a/doc/plugin_tutorial/tuto2/src/dune b/doc/plugin_tutorial/tuto2/src/dune new file mode 100644 index 0000000000..f2bc405455 --- /dev/null +++ b/doc/plugin_tutorial/tuto2/src/dune @@ -0,0 +1,9 @@ +(library + (name tuto2_plugin) + (public_name coq.plugins.tutorial.p2) + (libraries coq.plugins.ltac)) + +(rule + (targets demo.ml) + (deps (:pp-file demo.mlg) ) + (action (run coqpp %{pp-file}))) diff --git a/doc/plugin_tutorial/tuto2/theories/Test.v b/doc/plugin_tutorial/tuto2/theories/Test.v new file mode 100644 index 0000000000..38e83bfff1 --- /dev/null +++ b/doc/plugin_tutorial/tuto2/theories/Test.v @@ -0,0 +1,19 @@ +Declare ML Module "demo_plugin". + +Cmd1. +Cmd2 With Some Terminal Parameters. +Cmd3 42. +Cmd4 100 200 300 400. +Cmd5 Foo_5. +Cmd5 Bar_5. +Cmd6. +Cmd7. +Cmd7. +Cmd7. + +Goal True. +Proof. + tactic1. + tactic2 Foo_2. + tactic2 Bar_2. +Abort. diff --git a/doc/plugin_tutorial/tuto3/Makefile b/doc/plugin_tutorial/tuto3/Makefile new file mode 100644 index 0000000000..e0e197650d --- /dev/null +++ b/doc/plugin_tutorial/tuto3/Makefile @@ -0,0 +1,14 @@ +ifeq "$(COQBIN)" "" + COQBIN=$(dir $(shell which coqtop))/ +endif + +%: Makefile.coq + +Makefile.coq: _CoqProject + $(COQBIN)coq_makefile -f _CoqProject -o Makefile.coq + +tests: all + @$(MAKE) -C tests -s clean + @$(MAKE) -C tests -s all + +-include Makefile.coq diff --git a/doc/plugin_tutorial/tuto3/_CoqProject b/doc/plugin_tutorial/tuto3/_CoqProject new file mode 100644 index 0000000000..e2a60a430f --- /dev/null +++ b/doc/plugin_tutorial/tuto3/_CoqProject @@ -0,0 +1,12 @@ +-R theories Tuto3 +-I src + +theories/Data.v +theories/Loader.v + +src/tuto_tactic.ml +src/tuto_tactic.mli +src/construction_game.ml +src/construction_game.mli +src/g_tuto3.mlg +src/tuto3_plugin.mlpack diff --git a/doc/plugin_tutorial/tuto3/src/construction_game.ml b/doc/plugin_tutorial/tuto3/src/construction_game.ml new file mode 100644 index 0000000000..9d9f894e18 --- /dev/null +++ b/doc/plugin_tutorial/tuto3/src/construction_game.ml @@ -0,0 +1,186 @@ +open Pp + +let find_reference = Coqlib.find_reference [@ocaml.warning "-3"] + +let example_sort evd = +(* creating a new sort requires that universes should be recorded + in the evd datastructure, so this datastructure also needs to be + passed around. *) + let evd, s = Evd.new_sort_variable Evd.univ_rigid evd in + let new_type = EConstr.mkSort s in + evd, new_type + +let c_one evd = +(* In the general case, global references may refer to universe polymorphic + objects, and their universe has to be made afresh when creating an instance. *) + let gr_S = + find_reference "Tuto3" ["Coq"; "Init"; "Datatypes"] "S" in +(* the long name of "S" was found with the command "About S." *) + let gr_O = + find_reference "Tuto3" ["Coq"; "Init"; "Datatypes"] "O" in + let evd, c_O = Evarutil.new_global evd gr_O in + let evd, c_S = Evarutil.new_global evd gr_S in +(* Here is the construction of a new term by applying functions to argument. *) + evd, EConstr.mkApp (c_S, [| c_O |]) + +let dangling_identity env evd = +(* I call this a dangling identity, because it is not polymorph, but + the type on which it applies is left unspecified, as it is + represented by an existential variable. The declaration for this + existential variable needs to be added in the evd datastructure. *) + let evd, type_type = example_sort evd in + let evd, arg_type = Evarutil.new_evar env evd type_type in +(* Notice the use of a De Bruijn index for the inner occurrence of the + bound variable. *) + evd, EConstr.mkLambda(Names.Name (Names.Id.of_string "x"), arg_type, + EConstr.mkRel 1) + +let dangling_identity2 env evd = +(* This example uses directly a function that produces an evar that + is meant to be a type. *) + let evd, (arg_type, type_type) = + Evarutil.new_type_evar env evd Evd.univ_rigid in + evd, EConstr.mkLambda(Names.Name (Names.Id.of_string "x"), arg_type, + EConstr.mkRel 1) + +let example_sort_app_lambda () = + let env = Global.env () in + let evd = Evd.from_env env in + let evd, c_v = c_one evd in +(* dangling_identity and dangling_identity2 can be used interchangeably here *) + let evd, c_f = dangling_identity2 env evd in + let c_1 = EConstr.mkApp (c_f, [| c_v |]) in + let _ = Feedback.msg_notice + (Printer.pr_econstr_env env evd c_1) in + (* type verification happens here. Type verification will update + existential variable information in the evd part. *) + let evd, the_type = Typing.type_of env evd c_1 in +(* At display time, you will notice that the system knows about the + existential variable being instantiated to the "nat" type, even + though c_1 still contains the meta-variable. *) + Feedback.msg_notice + ((Printer.pr_econstr_env env evd c_1) ++ + str " has type " ++ + (Printer.pr_econstr_env env evd the_type)) + + +let c_S evd = + let gr = find_reference "Tuto3" ["Coq"; "Init"; "Datatypes"] "S" in + Evarutil.new_global evd gr + +let c_O evd = + let gr = find_reference "Tuto3" ["Coq"; "Init"; "Datatypes"] "O" in + Evarutil.new_global evd gr + +let c_E evd = + let gr = find_reference "Tuto3" ["Tuto3"; "Data"] "EvenNat" in + Evarutil.new_global evd gr + +let c_D evd = + let gr = find_reference "Tuto3" ["Tuto3"; "Data"] "tuto_div2" in + Evarutil.new_global evd gr + +let c_Q evd = + let gr = find_reference "Tuto3" ["Coq"; "Init"; "Logic"] "eq" in + Evarutil.new_global evd gr + +let c_R evd = + let gr = find_reference "Tuto3" ["Coq"; "Init"; "Logic"] "eq_refl" in + Evarutil.new_global evd gr + +let c_N evd = + let gr = find_reference "Tuto3" ["Coq"; "Init"; "Datatypes"] "nat" in + Evarutil.new_global evd gr + +let c_C evd = + let gr = find_reference "Tuto3" ["Tuto3"; "Data"] "C" in + Evarutil.new_global evd gr + +let c_F evd = + let gr = find_reference "Tuto3" ["Tuto3"; "Data"] "S_ev" in + Evarutil.new_global evd gr + +let c_P evd = + let gr = find_reference "Tuto3" ["Tuto3"; "Data"] "s_half_proof" in + Evarutil.new_global evd gr + +(* If c_S was universe polymorphic, we should have created a new constant + at each iteration of buildup. *) +let mk_nat evd n = + let evd, c_S = c_S evd in + let evd, c_O = c_O evd in + let rec buildup = function + | 0 -> c_O + | n -> EConstr.mkApp (c_S, [| buildup (n - 1) |]) in + if n <= 0 then evd, c_O else evd, buildup n + +let example_classes n = + let env = Global.env () in + let evd = Evd.from_env env in + let evd, c_n = mk_nat evd n in + let evd, n_half = mk_nat evd (n / 2) in + let evd, c_N = c_N evd in + let evd, c_div = c_D evd in + let evd, c_even = c_E evd in + let evd, c_Q = c_Q evd in + let evd, c_R = c_R evd in + let arg_type = EConstr.mkApp (c_even, [| c_n |]) in + let evd0 = evd in + let evd, instance = Evarutil.new_evar env evd arg_type in + let c_half = EConstr.mkApp (c_div, [|c_n; instance|]) in + let _ = Feedback.msg_notice (Printer.pr_econstr_env env evd c_half) in + let evd, the_type = Typing.type_of env evd c_half in + let _ = Feedback.msg_notice (Printer.pr_econstr_env env evd c_half) in + let proved_equality = + EConstr.mkCast(EConstr.mkApp (c_R, [| c_N; c_half |]), Constr.DEFAULTcast, + EConstr.mkApp (c_Q, [| c_N; c_half; n_half|])) in +(* This is where we force the system to compute with type classes. *) +(* Question to coq developers: why do we pass two evd arguments to + solve_remaining_evars? Is the choice of evd0 relevant here? *) + let evd = Pretyping.solve_remaining_evars + (Pretyping.default_inference_flags true) env evd ~initial:evd0 in + let evd, final_type = Typing.type_of env evd proved_equality in + Feedback.msg_notice (Printer.pr_econstr_env env evd proved_equality) + +(* This function, together with definitions in Data.v, shows how to + trigger automatic proofs at the time of typechecking, based on + canonical structures. + + n is a number for which we want to find the half (and a proof that + this half is indeed the half) +*) +let example_canonical n = + let env = Global.env () in + let evd = Evd.from_env env in +(* Construct a natural representation of this integer. *) + let evd, c_n = mk_nat evd n in +(* terms for "nat", "eq", "S_ev", "eq_refl", "C" *) + let evd, c_N = c_N evd in + let evd, c_F = c_F evd in + let evd, c_R = c_R evd in + let evd, c_C = c_C evd in + let evd, c_P = c_P evd in +(* the last argument of C *) + let refl_term = EConstr.mkApp (c_R, [|c_N; c_n |]) in +(* Now we build two existential variables, for the value of the half and for + the "S_ev" structure that triggers the proof search. *) + let evd, ev1 = Evarutil.new_evar env evd c_N in +(* This is the type for the second existential variable *) + let csev = EConstr.mkApp (c_F, [| ev1 |]) in + let evd, ev2 = Evarutil.new_evar env evd csev in +(* Now we build the C structure. *) + let test_term = EConstr.mkApp (c_C, [| c_n; ev1; ev2; refl_term |]) in +(* Type-checking this term will compute values for the existential variables *) + let evd, final_type = Typing.type_of env evd test_term in +(* The computed type has two parameters, the second one is the proof. *) + let value = match EConstr.kind evd final_type with + | Constr.App(_, [| _; the_half |]) -> the_half + | _ -> failwith "expecting the whole type to be \"cmp _ the_half\"" in + let _ = Feedback.msg_notice (Printer.pr_econstr_env env evd value) in +(* I wish for a nicer way to get the value of ev2 in the evar_map *) + let prf_struct = EConstr.of_constr (EConstr.to_constr evd ev2) in + let the_prf = EConstr.mkApp (c_P, [| ev1; prf_struct |]) in + let evd, the_statement = Typing.type_of env evd the_prf in + Feedback.msg_notice + (Printer.pr_econstr_env env evd the_prf ++ str " has type " ++ + Printer.pr_econstr_env env evd the_statement) diff --git a/doc/plugin_tutorial/tuto3/src/construction_game.mli b/doc/plugin_tutorial/tuto3/src/construction_game.mli new file mode 100644 index 0000000000..1832ed6630 --- /dev/null +++ b/doc/plugin_tutorial/tuto3/src/construction_game.mli @@ -0,0 +1,4 @@ +val dangling_identity : Environ.env -> Evd.evar_map -> Evd.evar_map * EConstr.t +val example_sort_app_lambda : unit -> unit +val example_classes : int -> unit +val example_canonical : int -> unit diff --git a/doc/plugin_tutorial/tuto3/src/dune b/doc/plugin_tutorial/tuto3/src/dune new file mode 100644 index 0000000000..ba6d8b288f --- /dev/null +++ b/doc/plugin_tutorial/tuto3/src/dune @@ -0,0 +1,10 @@ +(library + (name tuto3_plugin) + (public_name coq.plugins.tutorial.p3) + (flags :standard -warn-error -3) + (libraries coq.plugins.ltac)) + +(rule + (targets g_tuto3.ml) + (deps (:pp-file g_tuto3.mlg)) + (action (run coqpp %{pp-file}))) diff --git a/doc/plugin_tutorial/tuto3/src/g_tuto3.mlg b/doc/plugin_tutorial/tuto3/src/g_tuto3.mlg new file mode 100644 index 0000000000..82ba45726e --- /dev/null +++ b/doc/plugin_tutorial/tuto3/src/g_tuto3.mlg @@ -0,0 +1,46 @@ +DECLARE PLUGIN "tuto3_plugin" + +{ + +open Ltac_plugin + +open Construction_game + +(* This one is necessary, to avoid message about missing wit_string *) +open Stdarg + +} + +VERNAC COMMAND EXTEND ShowTypeConstruction CLASSIFIED AS QUERY +| [ "Tuto3_1" ] -> + { let env = Global.env () in + let evd = Evd.from_env env in + let evd, s = Evd.new_sort_variable Evd.univ_rigid evd in + let new_type_2 = EConstr.mkSort s in + let evd, _ = + Typing.type_of (Global.env()) (Evd.from_env (Global.env())) new_type_2 in + Feedback.msg_notice + (Printer.pr_econstr_env env evd new_type_2) } +END + +VERNAC COMMAND EXTEND ShowOneConstruction CLASSIFIED AS QUERY +| [ "Tuto3_2" ] -> { example_sort_app_lambda () } +END + +TACTIC EXTEND collapse_hyps +| [ "pack" "hypothesis" ident(i) ] -> + { Tuto_tactic.pack_tactic i } +END + +(* More advanced examples, where automatic proof happens but + no tactic is being called explicitely. The first one uses + type classes. *) +VERNAC COMMAND EXTEND TriggerClasses CLASSIFIED AS QUERY +| [ "Tuto3_3" int(n) ] -> { example_classes n } +END + +(* The second one uses canonical structures. *) +VERNAC COMMAND EXTEND TriggerCanonical CLASSIFIED AS QUERY +| [ "Tuto3_4" int(n) ] -> { example_canonical n } +END + diff --git a/doc/plugin_tutorial/tuto3/src/tuto3_plugin.mlpack b/doc/plugin_tutorial/tuto3/src/tuto3_plugin.mlpack new file mode 100644 index 0000000000..f4645ad7ed --- /dev/null +++ b/doc/plugin_tutorial/tuto3/src/tuto3_plugin.mlpack @@ -0,0 +1,3 @@ +Construction_game +Tuto_tactic +G_tuto3 diff --git a/doc/plugin_tutorial/tuto3/src/tuto_tactic.ml b/doc/plugin_tutorial/tuto3/src/tuto_tactic.ml new file mode 100644 index 0000000000..8f2c387d09 --- /dev/null +++ b/doc/plugin_tutorial/tuto3/src/tuto_tactic.ml @@ -0,0 +1,143 @@ +open Proofview + +let constants = ref ([] : EConstr.t list) + +(* This is a pattern to collect terms from the Coq memory of valid terms + and proofs. This pattern extends all the way to the definition of function + c_U *) +let collect_constants () = + if (!constants = []) then + let open EConstr in + let open UnivGen in + let find_reference = Coqlib.find_reference [@ocaml.warning "-3"] in + let gr_H = find_reference "Tuto3" ["Tuto3"; "Data"] "pack" in + let gr_M = find_reference "Tuto3" ["Tuto3"; "Data"] "packer" in + let gr_R = find_reference "Tuto3" ["Coq"; "Init"; "Datatypes"] "pair" in + let gr_P = find_reference "Tuto3" ["Coq"; "Init"; "Datatypes"] "prod" in + let gr_U = find_reference "Tuto3" ["Tuto3"; "Data"] "uncover" in + constants := List.map (fun x -> of_constr (constr_of_monomorphic_global x)) + [gr_H; gr_M; gr_R; gr_P; gr_U]; + !constants + else + !constants + +let c_H () = + match collect_constants () with + it :: _ -> it + | _ -> failwith "could not obtain an internal representation of pack" + +let c_M () = + match collect_constants () with + _ :: it :: _ -> it + | _ -> failwith "could not obtain an internal representation of pack_marker" + +let c_R () = + match collect_constants () with + _ :: _ :: it :: _ -> it + | _ -> failwith "could not obtain an internal representation of pair" + +let c_P () = + match collect_constants () with + _ :: _ :: _ :: it :: _ -> it + | _ -> failwith "could not obtain an internal representation of prod" + +let c_U () = + match collect_constants () with + _ :: _ :: _ :: _ :: it :: _ -> it + | _ -> failwith "could not obtain an internal representation of prod" + +(* The following tactic is meant to pack an hypothesis when no other + data is already packed. + + The main difficulty in defining this tactic is to understand how to + construct the input expected by apply_in. *) +let package i = Goal.enter begin fun gl -> + Tactics.apply_in true false i + [(* this means that the applied theorem is not to be cleared. *) + None, (CAst.make (c_M (), + (* we don't specialize the theorem with extra values. *) + Tactypes.NoBindings))] + (* we don't destruct the result according to any intro_pattern *) + None + end + +(* This function is meant to observe a type of shape (f a) + and return the value a. *) + +(* Remark by Maxime: look for destApp combinator. *) +let unpack_type evd term = + let report () = + CErrors.user_err (Pp.str "expecting a packed type") in + match EConstr.kind evd term with + | Constr.App (_, [| ty |]) -> ty + | _ -> report () + +(* This function is meant to observe a type of shape + A -> pack B -> C and return A, B, C + but it is not used in the current version of our tactic. + It is kept as an example. *) +let two_lambda_pattern evd term = + let report () = + CErrors.user_err (Pp.str "expecting two nested implications") in +(* Note that pattern-matching is always done through the EConstr.kind function, + which only provides one-level deep patterns. *) + match EConstr.kind evd term with + (* Here we recognize the outer implication *) + | Constr.Prod (_, ty1, l1) -> + (* Here we recognize the inner implication *) + (match EConstr.kind evd l1 with + | Constr.Prod (n2, packed_ty2, deep_conclusion) -> + (* Here we recognized that the second type is an application *) + ty1, unpack_type evd packed_ty2, deep_conclusion + | _ -> report ()) + | _ -> report () + +(* In the environment of the goal, we can get the type of an assumption + directly by a lookup. The other solution is to call a low-cost retyping + function like *) +let get_type_of_hyp env id = + match EConstr.lookup_named id env with + | Context.Named.Declaration.LocalAssum (_, ty) -> ty + | _ -> CErrors.user_err (let open Pp in + str (Names.Id.to_string id) ++ + str " is not a plain hypothesis") + +let repackage i h_hyps_id = Goal.enter begin fun gl -> + let env = Goal.env gl in + let evd = Tacmach.New.project gl in + let concl = Tacmach.New.pf_concl gl in + let (ty1 : EConstr.t) = get_type_of_hyp env i in + let (packed_ty2 : EConstr.t) = get_type_of_hyp env h_hyps_id in + let ty2 = unpack_type evd packed_ty2 in + let new_packed_type = EConstr.mkApp (c_P (), [| ty1; ty2 |]) in + let open EConstr in + let new_packed_value = + mkApp (c_R (), [| ty1; ty2; mkVar i; + mkApp (c_U (), [| ty2; mkVar h_hyps_id|]) |]) in + Refine.refine ~typecheck:true begin fun evd -> + let evd, new_goal = Evarutil.new_evar env evd + (mkProd (Names.Name.Anonymous, + mkApp(c_H (), [| new_packed_type |]), + Vars.lift 1 concl)) in + evd, mkApp (new_goal, + [|mkApp(c_M (), [|new_packed_type; new_packed_value |]) |]) + end + end + +let pack_tactic i = + let h_hyps_id = (Names.Id.of_string "packed_hyps") in + Proofview.Goal.enter begin fun gl -> + let hyps = Environ.named_context_val (Proofview.Goal.env gl) in + if not (Termops.mem_named_context_val i hyps) then + (CErrors.user_err + (Pp.str ("no hypothesis named" ^ (Names.Id.to_string i)))) + else + if Termops.mem_named_context_val h_hyps_id hyps then + tclTHEN (repackage i h_hyps_id) + (tclTHEN (Tactics.clear [h_hyps_id; i]) + (Tactics.introduction h_hyps_id)) + else + tclTHEN (package i) + (tclTHEN (Tactics.rename_hyp [i, h_hyps_id]) + (Tactics.move_hyp h_hyps_id Logic.MoveLast)) + end diff --git a/doc/plugin_tutorial/tuto3/src/tuto_tactic.mli b/doc/plugin_tutorial/tuto3/src/tuto_tactic.mli new file mode 100644 index 0000000000..dbf6cf48e2 --- /dev/null +++ b/doc/plugin_tutorial/tuto3/src/tuto_tactic.mli @@ -0,0 +1,3 @@ +val two_lambda_pattern : + Evd.evar_map -> EConstr.t -> EConstr.t * EConstr.t * EConstr.t +val pack_tactic : Names.Id.t -> unit Proofview.tactic diff --git a/doc/plugin_tutorial/tuto3/theories/Data.v b/doc/plugin_tutorial/tuto3/theories/Data.v new file mode 100644 index 0000000000..f7395d686b --- /dev/null +++ b/doc/plugin_tutorial/tuto3/theories/Data.v @@ -0,0 +1,73 @@ + + +Inductive pack (A: Type) : Type := + packer : A -> pack A. + +Arguments packer {A}. + +Definition uncover (A : Type) (packed : pack A) : A := + match packed with packer v => v end. + +Notation "!!!" := (pack _) (at level 0, only printing). + +(* The following data is used as material for automatic proofs + based on type classes. *) + +Class EvenNat the_even := {half : nat; half_prop : 2 * half = the_even}. + +Instance EvenNat0 : EvenNat 0 := {half := 0; half_prop := eq_refl}. + +Lemma even_rec n h : 2 * h = n -> 2 * S h = S (S n). +Proof. + intros []. + simpl. rewrite <-plus_n_O, <-plus_n_Sm. + reflexivity. +Qed. + +Instance EvenNat_rec n (p : EvenNat n) : EvenNat (S (S n)) := + {half := S (@half _ p); half_prop := even_rec n (@half _ p) (@half_prop _ p)}. + +Definition tuto_div2 n (p : EvenNat n) := @half _ p. + +(* to be used in the following examples +Compute (@half 8 _). + +Check (@half_prop 8 _). + +Check (@half_prop 7 _). + +and in command Tuto3_3 8. *) + +(* The following data is used as material for automatic proofs + based on canonical structures. *) + +Record S_ev n := Build_S_ev {double_of : nat; _ : 2 * n = double_of}. + +Definition s_half_proof n (r : S_ev n) : 2 * n = double_of n r := + match r with Build_S_ev _ _ h => h end. + +Canonical Structure can_ev_default n d (Pd : 2 * n = d) : S_ev n := + Build_S_ev n d Pd. + +Canonical Structure can_ev0 : S_ev 0 := + Build_S_ev 0 0 (@eq_refl _ 0). + +Lemma can_ev_rec n : forall (s : S_ev n), S_ev (S n). +Proof. +intros s; exists (S (S (double_of _ s))). +destruct s as [a P]. +exact (even_rec _ _ P). +Defined. + +Canonical Structure can_ev_rec. + +Record cmp (n : nat) (k : nat) := + C {h : S_ev k; _ : double_of k h = n}. + +(* To be used in, e.g., + +Check (C _ _ _ eq_refl : cmp 6 _). + +Check (C _ _ _ eq_refl : cmp 7 _). + +*) diff --git a/doc/plugin_tutorial/tuto3/theories/Loader.v b/doc/plugin_tutorial/tuto3/theories/Loader.v new file mode 100644 index 0000000000..1351cff63b --- /dev/null +++ b/doc/plugin_tutorial/tuto3/theories/Loader.v @@ -0,0 +1,3 @@ +From Tuto3 Require Export Data. + +Declare ML Module "tuto3_plugin". diff --git a/doc/plugin_tutorial/tuto3/theories/test.v b/doc/plugin_tutorial/tuto3/theories/test.v new file mode 100644 index 0000000000..43204ddf34 --- /dev/null +++ b/doc/plugin_tutorial/tuto3/theories/test.v @@ -0,0 +1,23 @@ +(* to be used e.g. in : coqtop -I src -R theories Tuto3 < theories/test.v *) + +Require Import Tuto3.Loader. + +(* This should print Type. *) +Tuto3_1. + +(* This should print a term that contains an existential variable. *) +(* And then print the same term, where the variable has been correctly + instantiated. *) +Tuto3_2. + +Lemma tutu x y (A : 0 < x) (B : 10 < y) : True. +Proof. +pack hypothesis A. +(* Hypothesis A should have disappeared and a "packed_hyps" hypothesis + should have appeared, with unreadable content. *) +pack hypothesis B. +(* Hypothesis B should have disappeared *) +destruct packed_hyps as [unpacked_hyps]. +(* Hypothesis unpacked_hyps should contain the previous contents of A and B. *) +exact I. +Qed. diff --git a/doc/sphinx/README.rst b/doc/sphinx/README.rst index a20b74822c..e4f078c1d6 100644 --- a/doc/sphinx/README.rst +++ b/doc/sphinx/README.rst @@ -416,12 +416,12 @@ Omitting annotations DO .. code:: - .. tacv:: assert @form as @intro_pattern + .. tacv:: assert @form as @simple_intropattern DON'T .. code:: - .. tacv:: assert form as intro_pattern + .. tacv:: assert form as simple_intropattern Using the ``.. coqtop::`` directive for syntax highlighting ----------------------------------------------------------- diff --git a/doc/sphinx/README.template.rst b/doc/sphinx/README.template.rst index 11f0cdc008..81f25bf274 100644 --- a/doc/sphinx/README.template.rst +++ b/doc/sphinx/README.template.rst @@ -172,12 +172,12 @@ Omitting annotations DO .. code:: - .. tacv:: assert @form as @intro_pattern + .. tacv:: assert @form as @simple_intropattern DON'T .. code:: - .. tacv:: assert form as intro_pattern + .. tacv:: assert form as simple_intropattern Using the ``.. coqtop::`` directive for syntax highlighting ----------------------------------------------------------- diff --git a/doc/sphinx/addendum/generalized-rewriting.rst b/doc/sphinx/addendum/generalized-rewriting.rst index e468cc63cd..b606fb4dd2 100644 --- a/doc/sphinx/addendum/generalized-rewriting.rst +++ b/doc/sphinx/addendum/generalized-rewriting.rst @@ -714,47 +714,47 @@ following grammar: .. productionlist:: rewriting s, t, u : `strategy` - : | `lemma` - : | `lemma_right_to_left` - : | `failure` - : | `identity` - : | `reflexivity` - : | `progress` - : | `failure_catch` - : | `composition` - : | `left_biased_choice` - : | `iteration_one_or_more` - : | `iteration_zero_or_more` - : | `one_subterm` - : | `all_subterms` - : | `innermost_first` - : | `outermost_first` - : | `bottom_up` - : | `top_down` - : | `apply_hint` - : | `any_of_the_terms` - : | `apply_reduction` - : | `fold_expression` + : `lemma` + : `lemma_right_to_left` + : `failure` + : `identity` + : `reflexivity` + : `progress` + : `failure_catch` + : `composition` + : `left_biased_choice` + : `iteration_one_or_more` + : `iteration_zero_or_more` + : `one_subterm` + : `all_subterms` + : `innermost_first` + : `outermost_first` + : `bottom_up` + : `top_down` + : `apply_hint` + : `any_of_the_terms` + : `apply_reduction` + : `fold_expression` .. productionlist:: rewriting - strategy : "(" `s` ")" + strategy : ( `s` ) lemma : `c` - lemma_right_to_left : "<-" `c` - failure : `fail` - identity : `id` - reflexivity : `refl` - progress : `progress` `s` - failure_catch : `try` `s` - composition : `s` ";" `u` + lemma_right_to_left : <- `c` + failure : fail + identity : id + reflexivity : refl + progress : progress `s` + failure_catch : try `s` + composition : `s` ; `u` left_biased_choice : choice `s` `t` - iteration_one_or_more : `repeat` `s` - iteration_zero_or_more : `any` `s` + iteration_one_or_more : repeat `s` + iteration_zero_or_more : any `s` one_subterm : subterm `s` all_subterms : subterms `s` - innermost_first : `innermost` `s` - outermost_first : `outermost` `s` - bottom_up : `bottomup` `s` - top_down : `topdown` `s` + innermost_first : innermost `s` + outermost_first : outermost `s` + bottom_up : bottomup `s` + top_down : topdown `s` apply_hint : hints `hintdb` any_of_the_terms : terms (`c`)+ apply_reduction : eval `redexpr` @@ -767,7 +767,7 @@ primitive fixpoint operator: .. productionlist:: rewriting try `s` : choice `s` `id` any `s` : fix `u`. try (`s` ; `u`) - repeat `s` : `s` ; `any` `s` + repeat `s` : `s` ; any `s` bottomup s : fix `bu`. (choice (progress (subterms bu)) s) ; try bu topdown s : fix `td`. (choice s (progress (subterms td))) ; try td innermost s : fix `i`. (choice (subterm i) s) diff --git a/doc/sphinx/addendum/implicit-coercions.rst b/doc/sphinx/addendum/implicit-coercions.rst index 64e2d7c4ab..e5b41be691 100644 --- a/doc/sphinx/addendum/implicit-coercions.rst +++ b/doc/sphinx/addendum/implicit-coercions.rst @@ -41,8 +41,8 @@ Formally, the syntax of a classes is defined as: .. productionlist:: class: `qualid` - : | Sortclass - : | Funclass + : Sortclass + : Funclass Coercions @@ -184,10 +184,10 @@ Figure :ref:`vernacular` as follows: \comindex{Hypothesis \mbox{\rm (and coercions)}} .. productionlist:: - assumption : assumption_keyword assums . - assums : simple_assums - : | (simple_assums) ... (simple_assums) - simple_assums : ident ... ident :[>] term + assumption : `assumption_keyword` `assums` . + assums : `simple_assums` + : (`simple_assums`) ... (`simple_assums`) + simple_assums : `ident` ... `ident` :[>] `term` If the extra ``>`` is present before the type of some assumptions, these assumptions are declared as coercions. @@ -203,7 +203,7 @@ grammar of inductive types from Figure :ref:`vernacular` as follows: .. productionlist:: inductive : Inductive `ind_body` with ... with `ind_body` - : | CoInductive `ind_body` with ... with `ind_body` + : CoInductive `ind_body` with ... with `ind_body` ind_body : `ident` [ `binders` ] : `term` := [[|] `constructor` | ... | `constructor` ] constructor : `ident` [ `binders` ] [:[>] `term` ] diff --git a/doc/sphinx/addendum/micromega.rst b/doc/sphinx/addendum/micromega.rst index fd66de427c..b076aac1ed 100644 --- a/doc/sphinx/addendum/micromega.rst +++ b/doc/sphinx/addendum/micromega.rst @@ -38,7 +38,7 @@ The tactics solve propositional formulas parameterized by atomic arithmetic expressions interpreted over a domain :math:`D \in \{\mathbb{Z},\mathbb{Q},\mathbb{R}\}`. The syntax of the formulas is the following: - .. productionlist:: `F` + .. productionlist:: F F : A ∣ P ∣ True ∣ False ∣ F ∧ F ∣ F ∨ F ∣ F ↔ F ∣ F → F ∣ ¬ F A : p = p ∣ p > p ∣ p < p ∣ p ≥ p ∣ p ≤ p p : c ∣ x ∣ −p ∣ p − p ∣ p + p ∣ p × p ∣ p ^ n @@ -145,7 +145,7 @@ weakness, the :tacn:`lia` tactic is using recursively a combination of: + linear *positivstellensatz* refutations; + cutting plane proofs; + case split. - + Cutting plane proofs ~~~~~~~~~~~~~~~~~~~~~~ @@ -250,6 +250,16 @@ obtain :math:`-1`. By Theorem :ref:`Psatz <psatz_thm>`, the goal is valid. .. [#] Support for :g:`nat` and :g:`N` is obtained by pre-processing the goal with the ``zify`` tactic. +.. [#] Support for :g:`Z.div` and :g:`Z.modulo` may be obtained by + pre-processing the goal with the ``Z.div_mod_to_equations`` tactic (you may + need to manually run ``zify`` first). +.. [#] Support for :g:`Z.quot` and :g:`Z.rem` may be obtained by pre-processing + the goal with the ``Z.quot_rem_to_equations`` tactic (you may need to manually + run ``zify`` first). +.. [#] Note that support for :g:`Z.div`, :g:`Z.modulo`, :g:`Z.quot`, and + :g:`Z.rem` may be simultaneously obtained by pre-processing the goal with the + ``Z.to_euclidean_division_equations`` tactic (you may need to manually run + ``zify`` first). .. [#] Sources and binaries can be found at https://projects.coin-or.org/Csdp .. [#] Variants deal with equalities and strict inequalities. .. [#] In practice, the oracle might fail to produce such a refutation. diff --git a/doc/sphinx/addendum/parallel-proof-processing.rst b/doc/sphinx/addendum/parallel-proof-processing.rst index 8b7214e2ab..903ee115c9 100644 --- a/doc/sphinx/addendum/parallel-proof-processing.rst +++ b/doc/sphinx/addendum/parallel-proof-processing.rst @@ -52,7 +52,7 @@ in interactive mode. It is not strictly mandatory in batch mode if it is not the first time the file is compiled and if the file itself did not change. When the proof does not begin with Proof using, the system records in an -auxiliary file, produced along with the `.vo` file, the list of section +auxiliary file, produced along with the ``.vo`` file, the list of section variables used. Automatic suggestion of proof annotations @@ -154,22 +154,22 @@ to a worker process. The threshold can be configured with Batch mode --------------- -When |Coq| is used as a batch compiler by running `coqc` or `coqtop` --compile, it produces a `.vo` file for each `.v` file. A `.vo` file contains, -among other things, theorem statements and proofs. Hence to produce a -.vo |Coq| need to process all the proofs of the `.v` file. +When |Coq| is used as a batch compiler by running ``coqc``, it produces +a ``.vo`` file for each ``.v`` file. A ``.vo`` file contains, among other +things, theorem statements and proofs. Hence to produce a .vo |Coq| +need to process all the proofs of the ``.v`` file. The asynchronous processing of proofs can decouple the generation of a -compiled file (like the `.vo` one) that can be loaded by ``Require`` from the +compiled file (like the ``.vo`` one) that can be loaded by ``Require`` from the generation and checking of the proof objects. The ``-quick`` flag can be -passed to `coqc` or `coqtop` to produce, quickly, `.vio` files. -Alternatively, when using a Makefile produced by `coq_makefile`, +passed to ``coqc`` or ``coqtop`` to produce, quickly, ``.vio`` files. +Alternatively, when using a Makefile produced by ``coq_makefile``, the ``quick`` target can be used to compile all files using the ``-quick`` flag. -A `.vio` file can be loaded using ``Require`` exactly as a `.vo` file but +A ``.vio`` file can be loaded using ``Require`` exactly as a ``.vo`` file but proofs will not be available (the Print command produces an error). Moreover, some universe constraints might be missing, so universes -inconsistencies might go unnoticed. A `.vio` file does not contain proof +inconsistencies might go unnoticed. A ``.vio`` file does not contain proof objects, but proof tasks, i.e. what a worker process can transform into a proof object. @@ -177,52 +177,52 @@ Compiling a set of files with the ``-quick`` flag allows one to work, interactively, on any file without waiting for all the proofs to be checked. -When working interactively, one can fully check all the `.v` files by -running `coqc` as usual. +When working interactively, one can fully check all the ``.v`` files by +running ``coqc`` as usual. -Alternatively one can turn each `.vio` into the corresponding `.vo`. All +Alternatively one can turn each ``.vio`` into the corresponding ``.vo``. All .vio files can be processed in parallel, hence this alternative might be faster. The command ``coqtop -schedule-vio2vo 2 a b c`` can be used to -obtain a good scheduling for two workers to produce `a.vo`, `b.vo`, and -`c.vo`. When using a Makefile produced by `coq_makefile`, the ``vio2vo`` target -can be used for that purpose. Variable `J` should be set to the number +obtain a good scheduling for two workers to produce ``a.vo``, ``b.vo``, and +``c.vo``. When using a Makefile produced by ``coq_makefile``, the ``vio2vo`` target +can be used for that purpose. Variable ``J`` should be set to the number of workers, e.g. ``make vio2vo J=2``. The only caveat is that, while the -.vo files obtained from `.vio` files are complete (they contain all proof +.vo files obtained from ``.vio`` files are complete (they contain all proof terms and universe constraints), the satisfiability of all universe constraints has not been checked globally (they are checked to be consistent for every single proof). Constraints will be checked when -these `.vo` files are (recursively) loaded with ``Require``. +these ``.vo`` files are (recursively) loaded with ``Require``. There is an extra, possibly even faster, alternative: just check the -proof tasks stored in `.vio` files without producing the `.vo` files. This +proof tasks stored in ``.vio`` files without producing the ``.vo`` files. This is possibly faster because all the proof tasks are independent, hence one can further partition the job to be done between workers. The ``coqtop -schedule-vio-checking 6 a b c`` command can be used to obtain a -good scheduling for 6 workers to check all the proof tasks of `a.vio`, -`b.vio`, and `c.vio`. Auxiliary files are used to predict how long a proof +good scheduling for 6 workers to check all the proof tasks of ``a.vio``, +``b.vio``, and ``c.vio``. Auxiliary files are used to predict how long a proof task will take, assuming it will take the same amount of time it took last time. When using a Makefile produced by coq_makefile, the -``checkproofs`` target can be used to check all `.vio` files. Variable `J` +``checkproofs`` target can be used to check all ``.vio`` files. Variable ``J`` should be set to the number of workers, e.g. ``make checkproofs J=6``. As -when converting `.vio` files to `.vo` files, universe constraints are not +when converting ``.vio`` files to ``.vo`` files, universe constraints are not checked to be globally consistent. Hence this compilation mode is only useful for quick regression testing and on developments not making -heavy use of the `Type` hierarchy. +heavy use of the ``Type`` hierarchy. Limiting the number of parallel workers -------------------------------------------- Many |Coq| processes may run on the same computer, and each of them may -start many additional worker processes. The `coqworkmgr` utility lets +start many additional worker processes. The ``coqworkmgr`` utility lets one limit the number of workers, globally. The utility accepts the ``-j`` argument to specify the maximum number of -workers (defaults to 2). `coqworkmgr` automatically starts in the +workers (defaults to 2). ``coqworkmgr`` automatically starts in the background and prints an environment variable assignment like ``COQWORKMGR_SOCKET=localhost:45634``. The user must set this variable in all the shells from which |Coq| processes will be started. If one uses just one terminal running the bash shell, then ``export ‘coqworkmgr -j 4‘`` will do the job. -After that, all |Coq| processes, e.g. `coqide` and `coqc`, will respect the +After that, all |Coq| processes, e.g. ``coqide`` and ``coqc``, will respect the limit, globally. diff --git a/doc/sphinx/addendum/ring.rst b/doc/sphinx/addendum/ring.rst index 99d689132d..8204d93fa7 100644 --- a/doc/sphinx/addendum/ring.rst +++ b/doc/sphinx/addendum/ring.rst @@ -308,13 +308,13 @@ The syntax for adding a new ring is .. productionlist:: coq ring_mod : abstract | decidable `term` | morphism `term` - : | setoid `term` `term` - : | constants [`ltac`] - : | preprocess [`ltac`] - : | postprocess [`ltac`] - : | power_tac `term` [`ltac`] - : | sign `term` - : | div `term` + : setoid `term` `term` + : constants [`ltac`] + : preprocess [`ltac`] + : postprocess [`ltac`] + : power_tac `term` [`ltac`] + : sign `term` + : div `term` abstract declares the ring as abstract. This is the default. diff --git a/doc/sphinx/language/cic.rst b/doc/sphinx/language/cic.rst index cc5d9d6205..67683902cd 100644 --- a/doc/sphinx/language/cic.rst +++ b/doc/sphinx/language/cic.rst @@ -84,7 +84,7 @@ implemented using *algebraic universes*. An algebraic universe :math:`u` is either a variable (a qualified identifier with a number) or a successor of an algebraic universe (an expression :math:`u+1`), or an upper bound of algebraic universes (an -expression :math:`\max(u 1 ,...,u n )`), or the base universe (the expression +expression :math:`\max(u_1 ,...,u_n )`), or the base universe (the expression :math:`0`) which corresponds, in the arity of template polymorphic inductive types (see Section :ref:`well-formed-inductive-definitions`), @@ -117,24 +117,24 @@ the following rules. #. variables, hereafter ranged over by letters :math:`x`, :math:`y`, etc., are terms #. constants, hereafter ranged over by letters :math:`c`, :math:`d`, etc., are terms. #. if :math:`x` is a variable and :math:`T`, :math:`U` are terms then - :math:`∀ x:T,U` (:g:`forall x:T, U` in |Coq| concrete syntax) is a term. - If :math:`x` occurs in :math:`U`, :math:`∀ x:T,U` reads as + :math:`∀ x:T,~U` (:g:`forall x:T, U` in |Coq| concrete syntax) is a term. + If :math:`x` occurs in :math:`U`, :math:`∀ x:T,~U` reads as “for all :math:`x` of type :math:`T`, :math:`U`”. - As :math:`U` depends on :math:`x`, one says that :math:`∀ x:T,U` is + As :math:`U` depends on :math:`x`, one says that :math:`∀ x:T,~U` is a *dependent product*. If :math:`x` does not occur in :math:`U` then - :math:`∀ x:T,U` reads as + :math:`∀ x:T,~U` reads as “if :math:`T` then :math:`U`”. A *non dependent product* can be written: :math:`T \rightarrow U`. #. if :math:`x` is a variable and :math:`T`, :math:`u` are terms then - :math:`λ x:T . u` (:g:`fun x:T => u` + :math:`λ x:T .~u` (:g:`fun x:T => u` in |Coq| concrete syntax) is a term. This is a notation for the - λ-abstraction of λ-calculus :cite:`Bar81`. The term :math:`λ x:T . u` is a function + λ-abstraction of λ-calculus :cite:`Bar81`. The term :math:`λ x:T .~u` is a function which maps elements of :math:`T` to the expression :math:`u`. #. if :math:`t` and :math:`u` are terms then :math:`(t~u)` is a term (:g:`t u` in |Coq| concrete syntax). The term :math:`(t~u)` reads as “t applied to u”. -#. if :g:`x` is a variable, and :math:`t`, :math:`T` and :math:`u` are - terms then :g:`let x:=t:T in u` is +#. if :math:`x` is a variable, and :math:`t`, :math:`T` and :math:`u` are + terms then :math:`\letin{x}{t:T}{u}` is a term which denotes the term :math:`u` where the variable :math:`x` is locally bound to :math:`t` of type :math:`T`. This stands for the common “let-in” construction of functional programs such as ML or Scheme. @@ -145,7 +145,7 @@ the following rules. **Free variables.** The notion of free variables is defined as usual. In the expressions -:g:`λx:T. U` and :g:`∀ x:T, U` the occurrences of :math:`x` in :math:`U` are bound. +:math:`λx:T.~U` and :math:`∀ x:T,~U` the occurrences of :math:`x` in :math:`U` are bound. .. _Substitution: @@ -172,11 +172,11 @@ implicative proposition, to denote :math:`\nat →\Prop` which is the type of unary predicates over the natural numbers, etc. Let us assume that ``mult`` is a function of type :math:`\nat→\nat→\nat` and ``eqnat`` a -predicate of type \nat→\nat→ \Prop. The λ-abstraction can serve to build -“ordinary” functions as in :math:`λ x:\nat.(\kw{mult}~x~x)` (i.e. +predicate of type :math:`\nat→\nat→ \Prop`. The λ-abstraction can serve to build +“ordinary” functions as in :math:`λ x:\nat.~(\kw{mult}~x~x)` (i.e. :g:`fun x:nat => mult x x` in |Coq| notation) but may build also predicates over the natural -numbers. For instance :math:`λ x:\nat.(\kw{eqnat}~x~0)` +numbers. For instance :math:`λ x:\nat.~(\kw{eqnat}~x~0)` (i.e. :g:`fun x:nat => eqnat x 0` in |Coq| notation) will represent the predicate of one variable :math:`x` which asserts the equality of :math:`x` with :math:`0`. This predicate has type @@ -186,7 +186,7 @@ object :math:`P~t` of type :math:`\Prop`, namely a proposition. Furthermore :g:`forall x:nat, P x` will represent the type of functions which associate to each natural number :math:`n` an object of type :math:`(P~n)` and -consequently represent the type of proofs of the formula “:math:`∀ x. P(x`)”. +consequently represent the type of proofs of the formula “:math:`∀ x.~P(x)`”. .. _Typing-rules: @@ -206,7 +206,7 @@ A *local context* is an ordered list of *local declarations* of names which we call *variables*. The declaration of some variable :math:`x` is either a *local assumption*, written :math:`x:T` (:math:`T` is a type) or a *local definition*, written :math:`x:=t:T`. We use brackets to write local contexts. -A typical example is :math:`[x:T;y:=u:U;z:V]`. Notice that the variables +A typical example is :math:`[x:T;~y:=u:U;~z:V]`. Notice that the variables declared in a local context must be distinct. If :math:`Γ` is a local context that declares some :math:`x`, we write :math:`x ∈ Γ`. By writing :math:`(x:T) ∈ Γ` we mean that either :math:`x:T` is an @@ -232,9 +232,9 @@ A *global assumption* will be represented in the global environment as :math:`(c:T)` which assumes the name :math:`c` to be of some type :math:`T`. A *global definition* will be represented in the global environment as :math:`c:=t:T` which defines the name :math:`c` to have value :math:`t` and type :math:`T`. We shall call -such names *constants*. For the rest of the chapter, the :math:`E;c:T` denotes +such names *constants*. For the rest of the chapter, the :math:`E;~c:T` denotes the global environment :math:`E` enriched with the global assumption :math:`c:T`. -Similarly, :math:`E;c:=t:T` denotes the global environment :math:`E` enriched with the +Similarly, :math:`E;~c:=t:T` denotes the global environment :math:`E` enriched with the global definition :math:`(c:=t:T)`. The rules for inductive definitions (see Section @@ -284,14 +284,14 @@ following rules. s \in \Sort c \notin E ------------ - \WF{E;c:T}{} + \WF{E;~c:T}{} .. inference:: W-Global-Def \WTE{}{t}{T} c \notin E --------------- - \WF{E;c:=t:T}{} + \WF{E;~c:=t:T}{} .. inference:: Ax-Prop @@ -328,10 +328,10 @@ following rules. .. inference:: Prod-Prop \WTEG{T}{s} - s \in {\Sort} + s \in \Sort \WTE{\Gamma::(x:T)}{U}{\Prop} ----------------------------- - \WTEG{\forall~x:T,U}{\Prop} + \WTEG{∀ x:T,~U}{\Prop} .. inference:: Prod-Set @@ -339,25 +339,25 @@ following rules. s \in \{\Prop, \Set\} \WTE{\Gamma::(x:T)}{U}{\Set} ---------------------------- - \WTEG{\forall~x:T,U}{\Set} + \WTEG{∀ x:T,~U}{\Set} .. inference:: Prod-Type \WTEG{T}{\Type(i)} \WTE{\Gamma::(x:T)}{U}{\Type(i)} -------------------------------- - \WTEG{\forall~x:T,U}{\Type(i)} + \WTEG{∀ x:T,~U}{\Type(i)} .. inference:: Lam - \WTEG{\forall~x:T,U}{s} + \WTEG{∀ x:T,~U}{s} \WTE{\Gamma::(x:T)}{t}{U} ------------------------------------ - \WTEG{\lb x:T\mto t}{\forall x:T, U} + \WTEG{λ x:T\mto t}{∀ x:T,~U} .. inference:: App - \WTEG{t}{\forall~x:U,T} + \WTEG{t}{∀ x:U,~T} \WTEG{u}{U} ------------------------------ \WTEG{(t\ u)}{\subst{T}{x}{u}} @@ -383,7 +383,7 @@ following rules. .. note:: We may have :math:`\letin{x}{t:T}{u}` well-typed without having - :math:`((λ x:T.u) t)` well-typed (where :math:`T` is a type of + :math:`((λ x:T.~u)~t)` well-typed (where :math:`T` is a type of :math:`t`). This is because the value :math:`t` associated to :math:`x` may be used in a conversion rule (see Section :ref:`Conversion-rules`). @@ -406,18 +406,18 @@ can decide if two programs are *intentionally* equal (one says We want to be able to identify some terms as we can identify the application of a function to a given argument with its result. For -instance the identity function over a given type T can be written -:math:`λx:T. x`. In any global environment :math:`E` and local context +instance the identity function over a given type :math:`T` can be written +:math:`λx:T.~x`. In any global environment :math:`E` and local context :math:`Γ`, we want to identify any object :math:`a` (of type -:math:`T`) with the application :math:`((λ x:T. x) a)`. We define for +:math:`T`) with the application :math:`((λ x:T.~x)~a)`. We define for this a *reduction* (or a *conversion*) rule we call :math:`β`: .. math:: - E[Γ] ⊢ ((λx:T. t) u)~\triangleright_β~\subst{t}{x}{u} + E[Γ] ⊢ ((λx:T.~t)~u)~\triangleright_β~\subst{t}{x}{u} We say that :math:`\subst{t}{x}{u}` is the *β-contraction* of -:math:`((λx:T. t) u)` and, conversely, that :math:`((λ x:T. t) u)` is the +:math:`((λx:T.~t)~u)` and, conversely, that :math:`((λ x:T.~t)~u)` is the *β-expansion* of :math:`\subst{t}{x}{u}`. According to β-reduction, terms of the *Calculus of Inductive @@ -481,7 +481,7 @@ destroyed, this reduction differs from δ-reduction. It is called \WTEG{u}{U} \WTE{\Gamma::(x:=u:U)}{t}{T} -------------- - E[Γ] ⊢ \letin{x}{u}{t}~\triangleright_ζ~\subst{t}{x}{u} + E[Γ] ⊢ \letin{x}{u:U}{t}~\triangleright_ζ~\subst{t}{x}{u} .. _eta-expansion: @@ -490,10 +490,10 @@ destroyed, this reduction differs from δ-reduction. It is called ~~~~~~~~~~~ Another important concept is η-expansion. It is legal to identify any -term :math:`t` of functional type :math:`∀ x:T, U` with its so-called η-expansion +term :math:`t` of functional type :math:`∀ x:T,~U` with its so-called η-expansion .. math:: - λx:T. (t~x) + λx:T.~(t~x) for :math:`x` an arbitrary variable name fresh in :math:`t`. @@ -503,26 +503,26 @@ for :math:`x` an arbitrary variable name fresh in :math:`t`. We deliberately do not define η-reduction: .. math:: - λ x:T. (t~x) \not\triangleright_η t + λ x:T.~(t~x)~\not\triangleright_η~t This is because, in general, the type of :math:`t` need not to be convertible - to the type of :math:`λ x:T. (t~x)`. E.g., if we take :math:`f` such that: + to the type of :math:`λ x:T.~(t~x)`. E.g., if we take :math:`f` such that: .. math:: - f : ∀ x:\Type(2),\Type(1) + f ~:~ ∀ x:\Type(2),~\Type(1) then .. math:: - λ x:\Type(1),(f~x) : ∀ x:\Type(1),\Type(1) + λ x:\Type(1).~(f~x) ~:~ ∀ x:\Type(1),~\Type(1) We could not allow .. math:: - λ x:Type(1),(f x) \triangleright_η f + λ x:\Type(1).~(f~x) ~\triangleright_η~ f - because the type of the reduced term :math:`∀ x:\Type(2),\Type(1)` would not be - convertible to the type of the original term :math:`∀ x:\Type(1),\Type(1).` + because the type of the reduced term :math:`∀ x:\Type(2),~\Type(1)` would not be + convertible to the type of the original term :math:`∀ x:\Type(1),~\Type(1)`. .. _convertibility: @@ -541,10 +541,10 @@ global environment :math:`E` and local context :math:`Γ` iff there exist terms :math:`u_1` and :math:`u_2` such that :math:`E[Γ] ⊢ t_1 \triangleright … \triangleright u_1` and :math:`E[Γ] ⊢ t_2 \triangleright … \triangleright u_2` and either :math:`u_1` and :math:`u_2` are identical, or they are convertible up to η-expansion, -i.e. :math:`u_1` is :math:`λ x:T. u_1'` and :math:`u_2 x` is +i.e. :math:`u_1` is :math:`λ x:T.~u_1'` and :math:`u_2 x` is recursively convertible to :math:`u_1'` , or, symmetrically, -:math:`u_2` is :math:`λx:T. u_2'` -and :math:`u_1 x` is recursively convertible to u_2′ . We then write +:math:`u_2` is :math:`λx:T.~u_2'` +and :math:`u_1 x` is recursively convertible to :math:`u_2'`. We then write :math:`E[Γ] ⊢ t_1 =_{βδιζη} t_2` . Apart from this we consider two instances of polymorphic and @@ -601,8 +601,8 @@ Subtyping rules ------------------- At the moment, we did not take into account one rule between universes -which says that any term in a universe of index i is also a term in -the universe of index i+1 (this is the *cumulativity* rule of |Cic|). +which says that any term in a universe of index :math:`i` is also a term in +the universe of index :math:`i+1` (this is the *cumulativity* rule of |Cic|). This property extends the equivalence relation of convertibility into a *subtyping* relation inductively defined by: @@ -614,25 +614,25 @@ a *subtyping* relation inductively defined by: :math:`E[Γ] ⊢ \Prop ≤_{βδιζη} \Type(i)`, for any :math:`i` #. if :math:`E[Γ] ⊢ T =_{βδιζη} U` and :math:`E[Γ::(x:T)] ⊢ T' ≤_{βδιζη} U'` then - :math:`E[Γ] ⊢ ∀x:T, T′ ≤_{βδιζη} ∀ x:U, U′`. + :math:`E[Γ] ⊢ ∀x:T,~T′ ≤_{βδιζη} ∀ x:U,~U′`. #. if :math:`\ind{p}{Γ_I}{Γ_C}` is a universe polymorphic and cumulative (see Chapter :ref:`polymorphicuniverses`) inductive type (see below) and - :math:`(t : ∀Γ_P ,∀Γ_{\mathit{Arr}(t)}, \Sort)∈Γ_I` + :math:`(t : ∀Γ_P ,∀Γ_{\mathit{Arr}(t)}, S)∈Γ_I` and - :math:`(t' : ∀Γ_P' ,∀Γ_{\mathit{Arr}(t)}', \Sort')∈Γ_I` + :math:`(t' : ∀Γ_P' ,∀Γ_{\mathit{Arr}(t)}', S')∈Γ_I` are two different instances of *the same* inductive type (differing only in universe levels) with constructors .. math:: - [c_1 : ∀Γ_P ,∀ T_{1,1} … T_{1,n_1} , t~v_{1,1} … v_{1,m} ;…; - c_k : ∀Γ_P ,∀ T_{k,1} … T_{k,n_k} ,t~v_{n,1} … v_{n,m} ] + [c_1 : ∀Γ_P ,∀ T_{1,1} … T_{1,n_1} ,~t~v_{1,1} … v_{1,m} ;~…;~ + c_k : ∀Γ_P ,∀ T_{k,1} … T_{k,n_k} ,~t~v_{k,1} … v_{k,m} ] and .. math:: - [c_1 : ∀Γ_P' ,∀ T_{1,1}' … T_{1,n_1}' , t'~v_{1,1}' … v_{1,m}' ;…; - c_k : ∀Γ_P' ,∀ T_{k,1}' … T_{k,n_k}' ,t'~v_{n,1}' … v_{n,m}' ] + [c_1 : ∀Γ_P' ,∀ T_{1,1}' … T_{1,n_1}' ,~t'~v_{1,1}' … v_{1,m}' ;~…;~ + c_k : ∀Γ_P' ,∀ T_{k,1}' … T_{k,n_k}' ,~t'~v_{k,1}' … v_{k,m}' ] respectively then @@ -656,8 +656,8 @@ a *subtyping* relation inductively defined by: .. math:: E[Γ] ⊢ A_i ≤_{βδιζη} A_i' - where :math:`Γ_{\mathit{Arr}(t)} = [a_1 : A_1 ; … ; a_l : A_l ]` and - :math:`Γ_{\mathit{Arr}(t)}' = [a_1 : A_1'; … ; a_l : A_l']`. + where :math:`Γ_{\mathit{Arr}(t)} = [a_1 : A_1 ;~ … ;~a_l : A_l ]` and + :math:`Γ_{\mathit{Arr}(t)}' = [a_1 : A_1';~ … ;~a_l : A_l']`. The conversion rule up to subtyping is now exactly: @@ -677,19 +677,19 @@ The conversion rule up to subtyping is now exactly: form*. There are several ways (or strategies) to apply the reduction rules. Among them, we have to mention the *head reduction* which will play an important role (see Chapter :ref:`tactics`). Any term :math:`t` can be written as -:math:`λ x_1 :T_1 . … λ x_k :T_k . (t_0~t_1 … t_n )` where :math:`t_0` is not an +:math:`λ x_1 :T_1 .~… λ x_k :T_k .~(t_0~t_1 … t_n )` where :math:`t_0` is not an application. We say then that :math:`t_0` is the *head of* :math:`t`. If we assume -that :math:`t_0` is :math:`λ x:T. u_0` then one step of β-head reduction of :math:`t` is: +that :math:`t_0` is :math:`λ x:T.~u_0` then one step of β-head reduction of :math:`t` is: .. math:: - λ x_1 :T_1 . … λ x_k :T_k . (λ x:T. u_0~t_1 … t_n ) \triangleright - λ (x_1 :T_1 )…(x_k :T_k ). (\subst{u_0}{x}{t_1}~t_2 … t_n ) + λ x_1 :T_1 .~… λ x_k :T_k .~(λ x:T.~u_0~t_1 … t_n ) ~\triangleright~ + λ (x_1 :T_1 )…(x_k :T_k ).~(\subst{u_0}{x}{t_1}~t_2 … t_n ) Iterating the process of head reduction until the head of the reduced term is no more an abstraction leads to the *β-head normal form* of :math:`t`: .. math:: - t \triangleright … \triangleright λ x_1 :T_1 . …λ x_k :T_k . (v~u_1 … u_m ) + t \triangleright … \triangleright λ x_1 :T_1 .~…λ x_k :T_k .~(v~u_1 … u_m ) where :math:`v` is not an abstraction (nor an application). Note that the head normal form must not be confused with the normal form since some :math:`u_i` @@ -713,12 +713,12 @@ Formally, we can represent any *inductive definition* as These inductive definitions, together with global assumptions and global definitions, then form the global environment. Additionally, -for any :math:`p` there always exists :math:`Γ_P =[a_1 :A_1 ;…;a_p :A_p ]` such that +for any :math:`p` there always exists :math:`Γ_P =[a_1 :A_1 ;~…;~a_p :A_p ]` such that each :math:`T` in :math:`(t:T)∈Γ_I \cup Γ_C` can be written as: :math:`∀Γ_P , T'` where :math:`Γ_P` is called the *context of parameters*. Furthermore, we must have that each :math:`T` in :math:`(t:T)∈Γ_I` can be written as: :math:`∀Γ_P,∀Γ_{\mathit{Arr}(t)}, S` where -:math:`Γ_{\mathit{Arr}(t)}` is called the *Arity* of the inductive type t and :math:`S` is called -the sort of the inductive type t (not to be confused with :math:`\Sort` which is the set of sorts). +:math:`Γ_{\mathit{Arr}(t)}` is called the *Arity* of the inductive type :math:`t` and :math:`S` is called +the sort of the inductive type :math:`t` (not to be confused with :math:`\Sort` which is the set of sorts). .. example:: @@ -726,8 +726,8 @@ the sort of the inductive type t (not to be confused with :math:`\Sort` which is .. math:: \ind{1}{[\List:\Set→\Set]}{\left[\begin{array}{rcl} - \Nil & : & \forall A:\Set,\List~A \\ - \cons & : & \forall A:\Set, A→ \List~A→ \List~A + \Nil & : & ∀ A:\Set,~\List~A \\ + \cons & : & ∀ A:\Set,~A→ \List~A→ \List~A \end{array} \right]} @@ -771,8 +771,8 @@ the sort of the inductive type t (not to be confused with :math:`\Sort` which is \odd&:&\nat → \Prop \end{array}\right]} {\left[\begin{array}{rcl} \evenO &:& \even~0\\ - \evenS &:& \forall n, \odd~n → \even~(\kw{S}~n)\\ - \oddS &:& \forall n, \even~n → \odd~(\kw{S}~n) + \evenS &:& ∀ n,~\odd~n → \even~(\nS~n)\\ + \oddS &:& ∀ n,~\even~n → \odd~(\nS~n) \end{array}\right]} which corresponds to the result of the |Coq| declaration: @@ -792,7 +792,7 @@ the sort of the inductive type t (not to be confused with :math:`\Sort` which is Types of inductive objects ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have to give the type of constants in a global environment E which +We have to give the type of constants in a global environment :math:`E` which contains an inductive declaration. .. inference:: Ind @@ -820,9 +820,9 @@ contains an inductive declaration. \begin{array}{l} E[Γ] ⊢ \even : \nat→\Prop\\ E[Γ] ⊢ \odd : \nat→\Prop\\ - E[Γ] ⊢ \even\_O : \even~O\\ - E[Γ] ⊢ \even\_S : \forall~n:\nat, \odd~n → \even~(S~n)\\ - E[Γ] ⊢ \odd\_S : \forall~n:\nat, \even~n → \odd~(S~n) + E[Γ] ⊢ \evenO : \even~\nO\\ + E[Γ] ⊢ \evenS : ∀ n:\nat,~\odd~n → \even~(\nS~n)\\ + E[Γ] ⊢ \oddS : ∀ n:\nat,~\even~n → \odd~(\nS~n) \end{array} @@ -842,11 +842,11 @@ Arity of a given sort +++++++++++++++++++++ A type :math:`T` is an *arity of sort* :math:`s` if it converts to the sort :math:`s` or to a -product :math:`∀ x:T,U` with :math:`U` an arity of sort :math:`s`. +product :math:`∀ x:T,~U` with :math:`U` an arity of sort :math:`s`. .. example:: - :math:`A→\Set` is an arity of sort :math:`\Set`. :math:`∀ A:\Prop,A→ \Prop` is an arity of sort + :math:`A→\Set` is an arity of sort :math:`\Set`. :math:`∀ A:\Prop,~A→ \Prop` is an arity of sort :math:`\Prop`. @@ -858,21 +858,21 @@ sort :math:`s`. .. example:: - :math:`A→ Set` and :math:`∀ A:\Prop,A→ \Prop` are arities. + :math:`A→ \Set` and :math:`∀ A:\Prop,~A→ \Prop` are arities. -Type constructor -++++++++++++++++ -We say that T is a *type of constructor of I* in one of the following +Type of constructor ++++++++++++++++++++ +We say that :math:`T` is a *type of constructor of* :math:`I` in one of the following two cases: + :math:`T` is :math:`(I~t_1 … t_n )` -+ :math:`T` is :math:`∀ x:U,T'` where :math:`T'` is also a type of constructor of :math:`I` ++ :math:`T` is :math:`∀ x:U,~T'` where :math:`T'` is also a type of constructor of :math:`I` .. example:: :math:`\nat` and :math:`\nat→\nat` are types of constructor of :math:`\nat`. - :math:`∀ A:Type,\List~A` and :math:`∀ A:Type,A→\List~A→\List~A` are types of constructor of :math:`\List`. + :math:`∀ A:\Type,~\List~A` and :math:`∀ A:\Type,~A→\List~A→\List~A` are types of constructor of :math:`\List`. .. _positivity: @@ -883,7 +883,7 @@ The type of constructor :math:`T` will be said to *satisfy the positivity condition* for a constant :math:`X` in the following cases: + :math:`T=(X~t_1 … t_n )` and :math:`X` does not occur free in any :math:`t_i` -+ :math:`T=∀ x:U,V` and :math:`X` occurs only strictly positively in :math:`U` and the type :math:`V` ++ :math:`T=∀ x:U,~V` and :math:`X` occurs only strictly positively in :math:`U` and the type :math:`V` satisfies the positivity condition for :math:`X`. Strict positivity @@ -895,13 +895,13 @@ cases: + :math:`X` does not occur in :math:`T` + :math:`T` converts to :math:`(X~t_1 … t_n )` and :math:`X` does not occur in any of :math:`t_i` -+ :math:`T` converts to :math:`∀ x:U,V` and :math:`X` does not occur in type :math:`U` but occurs ++ :math:`T` converts to :math:`∀ x:U,~V` and :math:`X` does not occur in type :math:`U` but occurs strictly positively in type :math:`V` + :math:`T` converts to :math:`(I~a_1 … a_m~t_1 … t_p )` where :math:`I` is the name of an inductive declaration of the form .. math:: - \ind{m}{I:A}{c_1 :∀ p_1 :P_1 ,… ∀p_m :P_m ,C_1 ;…;c_n :∀ p_1 :P_1 ,… ∀p_m :P_m ,C_n} + \ind{m}{I:A}{c_1 :∀ p_1 :P_1 ,… ∀p_m :P_m ,~C_1 ;~…;~c_n :∀ p_1 :P_1 ,… ∀p_m :P_m ,~C_n} (in particular, it is not mutually defined and it has :math:`m` parameters) and :math:`X` does not occur in @@ -916,7 +916,7 @@ condition* for a constant :math:`X` in the following cases: + :math:`T=(I~b_1 … b_m~u_1 … u_p)`, :math:`I` is an inductive definition with :math:`m` parameters and :math:`X` does not occur in any :math:`u_i` -+ :math:`T=∀ x:U,V` and :math:`X` occurs only strictly positively in :math:`U` and the type :math:`V` ++ :math:`T=∀ x:U,~V` and :math:`X` occurs only strictly positively in :math:`U` and the type :math:`V` satisfies the nested positivity condition for :math:`X` @@ -930,7 +930,6 @@ condition* for a constant :math:`X` in the following cases: Inductive nattree (A:Type) : Type := | leaf : nattree A | node : A -> (nat -> nattree A) -> nattree A. - End TreeExample. Then every instantiated constructor of ``nattree A`` satisfies the nested positivity condition for ``nattree``: @@ -943,7 +942,7 @@ condition* for a constant :math:`X` in the following cases: + Type ``A → (nat → nattree A) → nattree A`` of constructor ``node`` satisfies the positivity condition for ``nattree`` because: - - ``nattree`` occurs only strictly positively in ``A`` ... (bullet 3) + - ``nattree`` occurs only strictly positively in ``A`` ... (bullet 1) - ``nattree`` occurs only strictly positively in ``nat → nattree A`` ... (bullet 3 + 2) @@ -958,8 +957,8 @@ We shall now describe the rules allowing the introduction of a new inductive definition. Let :math:`E` be a global environment and :math:`Γ_P`, :math:`Γ_I`, :math:`Γ_C` be contexts -such that :math:`Γ_I` is :math:`[I_1 :∀ Γ_P ,A_1 ;…;I_k :∀ Γ_P ,A_k]`, and -:math:`Γ_C` is :math:`[c_1:∀ Γ_P ,C_1 ;…;c_n :∀ Γ_P ,C_n ]`. Then +such that :math:`Γ_I` is :math:`[I_1 :∀ Γ_P ,A_1 ;~…;~I_k :∀ Γ_P ,A_k]`, and +:math:`Γ_C` is :math:`[c_1:∀ Γ_P ,C_1 ;~…;~c_n :∀ Γ_P ,C_n ]`. Then .. inference:: W-Ind @@ -967,7 +966,7 @@ such that :math:`Γ_I` is :math:`[I_1 :∀ Γ_P ,A_1 ;…;I_k :∀ Γ_P ,A_k]`, (E[Γ_P ] ⊢ A_j : s_j )_{j=1… k} (E[Γ_I ;Γ_P ] ⊢ C_i : s_{q_i} )_{i=1… n} ------------------------------------------ - \WF{E;\ind{p}{Γ_I}{Γ_C}}{Γ} + \WF{E;~\ind{p}{Γ_I}{Γ_C}}{Γ} provided that the following side conditions hold: @@ -990,8 +989,8 @@ the Type hierarchy. .. example:: It is well known that the existential quantifier can be encoded as an - inductive definition. The following declaration introduces the second- - order existential quantifier :math:`∃ X.P(X)`. + inductive definition. The following declaration introduces the + second-order existential quantifier :math:`∃ X.P(X)`. .. coqtop:: in @@ -1028,7 +1027,7 @@ in :math:`\Type`. .. flag:: Auto Template Polymorphism This option, enabled by default, makes every inductive type declared - at level :math:`Type` (without annotations or hiding it behind a + at level :math:`\Type` (without annotations or hiding it behind a definition) template polymorphic. This can be prevented using the ``notemplate`` attribute. @@ -1041,6 +1040,12 @@ in :math:`\Type`. enabled it will prevail over automatic template polymorphism and cause an error when using the ``template`` attribute. +.. warn:: Automatically declaring @ident as template polymorphic. + + Warning ``auto-template`` can be used to find which types are + implicitly declared template polymorphic by :flag:`Auto Template + Polymorphism`. + If :math:`A` is an arity of some sort and :math:`s` is a sort, we write :math:`A_{/s}` for the arity obtained from :math:`A` by replacing its sort with :math:`s`. Especially, if :math:`A` is well-typed in some global environment and local @@ -1049,9 +1054,9 @@ Calculus of Inductive Constructions. The following typing rule is added to the theory. Let :math:`\ind{p}{Γ_I}{Γ_C}` be an inductive definition. Let -:math:`Γ_P = [p_1 :P_1 ;…;p_p :P_p ]` be its context of parameters, -:math:`Γ_I = [I_1:∀ Γ_P ,A_1 ;…;I_k :∀ Γ_P ,A_k ]` its context of definitions and -:math:`Γ_C = [c_1 :∀ Γ_P ,C_1 ;…;c_n :∀ Γ_P ,C_n]` its context of constructors, +:math:`Γ_P = [p_1 :P_1 ;~…;~p_p :P_p ]` be its context of parameters, +:math:`Γ_I = [I_1:∀ Γ_P ,A_1 ;~…;~I_k :∀ Γ_P ,A_k ]` its context of definitions and +:math:`Γ_C = [c_1 :∀ Γ_P ,C_1 ;~…;~c_n :∀ Γ_P ,C_n]` its context of constructors, with :math:`c_i` a constructor of :math:`I_{q_i}`. Let :math:`m ≤ p` be the length of the longest prefix of parameters such that the :math:`m` first arguments of all occurrences of all :math:`I_j` in all :math:`C_k` (even the occurrences in the @@ -1071,15 +1076,15 @@ uniform parameters of :math:`Γ_P` . We have: \end{array} \right. ----------------------------- - E[] ⊢ I_j~q_1 … q_r :∀ [p_{r+1} :P_{r+1} ;…;p_p :P_p], (A_j)_{/s_j} + E[] ⊢ I_j~q_1 … q_r :∀ [p_{r+1} :P_{r+1} ;~…;~p_p :P_p], (A_j)_{/s_j} provided that the following side conditions hold: + :math:`Γ_{P′}` is the context obtained from :math:`Γ_P` by replacing each :math:`P_l` that is an arity with :math:`P_l'` for :math:`1≤ l ≤ r` (notice that :math:`P_l` arity implies :math:`P_l'` - arity since :math:`(E[] ⊢ P_l' ≤_{βδιζη} \subst{P_l}{p_u}{q_u}_{u=1\ldots l-1} )`; + arity since :math:`E[] ⊢ P_l' ≤_{βδιζη} \subst{P_l}{p_u}{q_u}_{u=1\ldots l-1}`); + there are sorts :math:`s_i` , for :math:`1 ≤ i ≤ k` such that, for - :math:`Γ_{I'} = [I_1 :∀ Γ_{P'} ,(A_1)_{/s_1} ;…;I_k :∀ Γ_{P'} ,(A_k)_{/s_k}]` + :math:`Γ_{I'} = [I_1 :∀ Γ_{P'} ,(A_1)_{/s_1} ;~…;~I_k :∀ Γ_{P'} ,(A_k)_{/s_k}]` we have :math:`(E[Γ_{I′} ;Γ_{P′}] ⊢ C_i : s_{q_i})_{i=1… n}` ; + the sorts :math:`s_i` are such that all eliminations, to :math:`\Prop`, :math:`\Set` and :math:`\Type(j)`, are allowed @@ -1097,7 +1102,7 @@ replacements of sorts, needed for this derivation, in the parameters that are arities (this is possible because :math:`\ind{p}{Γ_I}{Γ_C}` well-formed implies that :math:`\ind{p}{Γ_{I'}}{Γ_{C'}}` is well-formed and has the same allowed eliminations, where :math:`Γ_{I′}` is defined as above and -:math:`Γ_{C′} = [c_1 :∀ Γ_{P′} ,C_1 ;…;c_n :∀ Γ_{P′} ,C_n ]`). That is, the changes in the +:math:`Γ_{C′} = [c_1 :∀ Γ_{P′} ,C_1 ;~…;~c_n :∀ Γ_{P′} ,C_n ]`). That is, the changes in the types of each partial instance :math:`q_1 … q_r` can be characterized by the ordered sets of arity sorts among the types of parameters, and to each signature is associated a new inductive definition with fresh names. @@ -1199,10 +1204,11 @@ a strongly normalizing reduction, we cannot accept any sort of recursion (even terminating). So the basic idea is to restrict ourselves to primitive recursive functions and functionals. -For instance, assuming a parameter :g:`A:Set` exists in the local context, -we want to build a function length of type :g:`list A -> nat` which computes -the length of the list, such that :g:`(length (nil A)) = O` and :g:`(length -(cons A a l)) = (S (length l))`. We want these equalities to be +For instance, assuming a parameter :math:`A:\Set` exists in the local context, +we want to build a function :math:`\length` of type :math:`\List~A → \nat` which computes +the length of the list, such that :math:`(\length~(\Nil~A)) = \nO` and +:math:`(\length~(\cons~A~a~l)) = (\nS~(\length~l))`. +We want these equalities to be recognized implicitly and taken into account in the conversion rule. From the logical point of view, we have built a type family by giving @@ -1216,22 +1222,22 @@ In case the inductive definition is effectively a recursive one, we want to capture the extra property that we have built the smallest fixed point of this recursive equation. This says that we are only manipulating finite objects. This analysis provides induction -principles. For instance, in order to prove :g:`∀ l:list A,(has_length A l -(length l))` it is enough to prove: +principles. For instance, in order to prove +:math:`∀ l:\List~A,~(\kw{has}\_\kw{length}~A~l~(\length~l))` it is enough to prove: -+ :g:`(has_length A (nil A) (length (nil A)))` -+ :g:`∀ a:A, ∀ l:list A, (has_length A l (length l)) →` - :g:`(has_length A (cons A a l) (length (cons A a l)))` ++ :math:`(\kw{has}\_\kw{length}~A~(\Nil~A)~(\length~(\Nil~A)))` ++ :math:`∀ a:A,~∀ l:\List~A,~(\kw{has}\_\kw{length}~A~l~(\length~l)) →` + :math:`(\kw{has}\_\kw{length}~A~(\cons~A~a~l)~(\length~(\cons~A~a~l)))` -which given the conversion equalities satisfied by length is the same +which given the conversion equalities satisfied by :math:`\length` is the same as proving: -+ :g:`(has_length A (nil A) O)` -+ :g:`∀ a:A, ∀ l:list A, (has_length A l (length l)) →` - :g:`(has_length A (cons A a l) (S (length l)))` ++ :math:`(\kw{has}\_\kw{length}~A~(\Nil~A)~\nO)` ++ :math:`∀ a:A,~∀ l:\List~A,~(\kw{has}\_\kw{length}~A~l~(\length~l)) →` + :math:`(\kw{has}\_\kw{length}~A~(\cons~A~a~l)~(\nS~(\length~l)))` One conceptually simple way to do that, following the basic scheme @@ -1261,7 +1267,7 @@ The |Coq| term for this proof will be written: .. math:: - \Match~m~\with~(c_1~x_{11} ... x_{1p_1} ) ⇒ f_1 | … | (c_n~x_{n1} ... x_{np_n} ) ⇒ f_n \kwend + \Match~m~\with~(c_1~x_{11} ... x_{1p_1} ) ⇒ f_1 | … | (c_n~x_{n1} ... x_{np_n} ) ⇒ f_n~\kwend In this expression, if :math:`m` eventually happens to evaluate to :math:`(c_i~u_1 … u_{p_i})` then the expression will behave as specified in its :math:`i`-th branch @@ -1269,7 +1275,7 @@ and it will reduce to :math:`f_i` where the :math:`x_{i1} …x_{ip_i}` are repla :math:`u_1 … u_{p_i}` according to the ι-reduction. Actually, for type checking a :math:`\Match…\with…\kwend` expression we also need -to know the predicate P to be proved by case analysis. In the general +to know the predicate :math:`P` to be proved by case analysis. In the general case where :math:`I` is an inductively defined :math:`n`-ary relation, :math:`P` is a predicate over :math:`n+1` arguments: the :math:`n` first ones correspond to the arguments of :math:`I` (parameters excluded), and the last one corresponds to object :math:`m`. |Coq| @@ -1303,7 +1309,7 @@ inference rules, we use a more compact notation: .. _Allowed-elimination-sorts: -**Allowed elimination sorts.** An important question for building the typing rule for match is what +**Allowed elimination sorts.** An important question for building the typing rule for :math:`\Match` is what can be the type of :math:`λ a x . P` with respect to the type of :math:`m`. If :math:`m:I` and :math:`I:A` and :math:`λ a x . P : B` then by :math:`[I:A|B]` we mean that one can use :math:`λ a x . P` with :math:`m` in the above match-construct. @@ -1321,7 +1327,7 @@ There is no restriction on the sort of the predicate to be eliminated. [(I~x):A′|B′] ----------------------- - [I:∀ x:A, A′|∀ x:A, B′] + [I:∀ x:A,~A′|∀ x:A,~B′] .. inference:: Set & Type @@ -1341,7 +1347,7 @@ sort :math:`\Prop`. ~ --------------- - [I:Prop|I→Prop] + [I:\Prop|I→\Prop] :math:`\Prop` is the type of logical propositions, the proofs of properties :math:`P` in @@ -1370,7 +1376,7 @@ the proof of :g:`or A B` is not accepted: From the computational point of view, the structure of the proof of :g:`(or A B)` in this term is needed for computing the boolean value. -In general, if :math:`I` has type :math:`\Prop` then :math:`P` cannot have type :math:`I→Set,` because +In general, if :math:`I` has type :math:`\Prop` then :math:`P` cannot have type :math:`I→\Set`, because it will mean to build an informative proof of type :math:`(P~m)` doing a case analysis over a non-computational object that will disappear in the extracted program. But the other way is safe with respect to our @@ -1378,11 +1384,11 @@ interpretation we can have :math:`I` a computational object and :math:`P` a non-computational one, it just corresponds to proving a logical property of a computational object. -In the same spirit, elimination on :math:`P` of type :math:`I→Type` cannot be allowed -because it trivially implies the elimination on :math:`P` of type :math:`I→ Set` by +In the same spirit, elimination on :math:`P` of type :math:`I→\Type` cannot be allowed +because it trivially implies the elimination on :math:`P` of type :math:`I→ \Set` by cumulativity. It also implies that there are two proofs of the same -property which are provably different, contradicting the proof- -irrelevance property which is sometimes a useful axiom: +property which are provably different, contradicting the +proof-irrelevance property which is sometimes a useful axiom: .. example:: @@ -1391,7 +1397,7 @@ irrelevance property which is sometimes a useful axiom: Axiom proof_irrelevance : forall (P : Prop) (x y : P), x=y. The elimination of an inductive definition of type :math:`\Prop` on a predicate -:math:`P` of type :math:`I→ Type` leads to a paradox when applied to impredicative +:math:`P` of type :math:`I→ \Type` leads to a paradox when applied to impredicative inductive definition like the second-order existential quantifier :g:`exProp` defined above, because it gives access to the two projections on this type. @@ -1407,7 +1413,7 @@ this type. I~\kw{is an empty or singleton definition} s ∈ \Sort ------------------------------------- - [I:Prop|I→ s] + [I:\Prop|I→ s] A *singleton definition* has only one constructor and all the arguments of this constructor have type :math:`\Prop`. In that case, there is a @@ -1444,7 +1450,7 @@ corresponding to the :math:`c:C` constructor. .. math:: \begin{array}{ll} \{c:(I~p_1\ldots p_r\ t_1 \ldots t_p)\}^P &\equiv (P~t_1\ldots ~t_p~c) \\ - \{c:\forall~x:T,C\}^P &\equiv \forall~x:T,\{(c~x):C\}^P + \{c:∀ x:T,~C\}^P &\equiv ∀ x:T,~\{(c~x):C\}^P \end{array} We write :math:`\{c\}^P` for :math:`\{c:C\}^P` with :math:`C` the type of :math:`c`. @@ -1463,7 +1469,7 @@ We write :math:`\{c\}^P` for :math:`\{c:C\}^P` with :math:`C` the type of :math: can be represented in abstract syntax as .. math:: - \case(t,P,f 1 | f 2 ) + \case(t,P,f_1 | f_2 ) where @@ -1471,27 +1477,27 @@ We write :math:`\{c\}^P` for :math:`\{c:C\}^P` with :math:`C` the type of :math: :nowrap: \begin{eqnarray*} - P & = & \lambda~l~.~P^\prime\\ + P & = & λ l.~P^\prime\\ f_1 & = & t_1\\ - f_2 & = & \lambda~(hd:\nat)~.~\lambda~(tl:\List~\nat)~.~t_2 + f_2 & = & λ (hd:\nat).~λ (tl:\List~\nat).~t_2 \end{eqnarray*} According to the definition: .. math:: - \{(\kw{nil}~\nat)\}^P ≡ \{(\kw{nil}~\nat) : (\List~\nat)\}^P ≡ (P~(\kw{nil}~\nat)) + \{(\Nil~\nat)\}^P ≡ \{(\Nil~\nat) : (\List~\nat)\}^P ≡ (P~(\Nil~\nat)) .. math:: \begin{array}{rl} - \{(\kw{cons}~\nat)\}^P & ≡\{(\kw{cons}~\nat) : (\nat→\List~\nat→\List~\nat)\}^P \\ - & ≡∀ n:\nat, \{(\kw{cons}~\nat~n) : \List~\nat→\List~\nat)\}^P \\ - & ≡∀ n:\nat, ∀ l:\List~\nat, \{(\kw{cons}~\nat~n~l) : \List~\nat)\}^P \\ - & ≡∀ n:\nat, ∀ l:\List~\nat,(P~(\kw{cons}~\nat~n~l)). + \{(\cons~\nat)\}^P & ≡\{(\cons~\nat) : (\nat→\List~\nat→\List~\nat)\}^P \\ + & ≡∀ n:\nat,~\{(\cons~\nat~n) : (\List~\nat→\List~\nat)\}^P \\ + & ≡∀ n:\nat,~∀ l:\List~\nat,~\{(\cons~\nat~n~l) : (\List~\nat)\}^P \\ + & ≡∀ n:\nat,~∀ l:\List~\nat,~(P~(\cons~\nat~n~l)). \end{array} - Given some :math:`P` then :math:`\{(\kw{nil}~\nat)\}^P` represents the expected type of :math:`f_1` , - and :math:`\{(\kw{cons}~\nat)\}^P` represents the expected type of :math:`f_2`. + Given some :math:`P` then :math:`\{(\Nil~\nat)\}^P` represents the expected type of :math:`f_1` , + and :math:`\{(\cons~\nat)\}^P` represents the expected type of :math:`f_2`. .. _Typing-rule: @@ -1512,7 +1518,7 @@ following typing rule E[Γ] ⊢ \case(c,P,f_1 |… |f_l ) : (P~t_1 … t_s~c) provided :math:`I` is an inductive type in a -definition :math:`\ind{r}{Γ_I}{Γ_C}` with :math:`Γ_C = [c_1 :C_1 ;…;c_n :C_n ]` and +definition :math:`\ind{r}{Γ_I}{Γ_C}` with :math:`Γ_C = [c_1 :C_1 ;~…;~c_n :C_n ]` and :math:`c_{p_1} … c_{p_l}` are the only constructors of :math:`I`. @@ -1527,8 +1533,8 @@ definition :math:`\ind{r}{Γ_I}{Γ_C}` with :math:`Γ_C = [c_1 :C_1 ;…;c_n :C_ E[Γ] ⊢ t : (\List ~\nat) \\ E[Γ] ⊢ P : B \\ [(\List ~\nat)|B] \\ - E[Γ] ⊢ f_1 : {(\kw{nil} ~\nat)}^P \\ - E[Γ] ⊢ f_2 : {(\kw{cons} ~\nat)}^P + E[Γ] ⊢ f_1 : \{(\Nil ~\nat)\}^P \\ + E[Γ] ⊢ f_2 : \{(\cons ~\nat)\}^P \end{array} ------------------------------------------------ E[Γ] ⊢ \case(t,P,f_1 |f_2 ) : (P~t) @@ -1551,7 +1557,7 @@ The ι-contraction of this term is :math:`(f_i~a_1 … a_m )` leading to the general reduction rule: .. math:: - \case((c_{p_i}~q_1 … q_r~a_1 … a_m ),P,f_1 |… |f_n ) \triangleright_ι (f_i~a_1 … a_m ) + \case((c_{p_i}~q_1 … q_r~a_1 … a_m ),P,f_1 |… |f_l ) \triangleright_ι (f_i~a_1 … a_m ) .. _Fixpoint-definitions: @@ -1565,14 +1571,14 @@ concrete syntax for a recursive set of mutually recursive declarations is (with :math:`Γ_i` contexts): .. math:: - \fix~f_1 (Γ_1 ) :A_1 :=t_1 \with … \with~f_n (Γ_n ) :A_n :=t_n + \fix~f_1 (Γ_1 ) :A_1 :=t_1~\with … \with~f_n (Γ_n ) :A_n :=t_n The terms are obtained by projections from this set of declarations and are written .. math:: - \fix~f_1 (Γ_1 ) :A_1 :=t_1 \with … \with~f_n (Γ_n ) :A_n :=t_n \for~f_i + \fix~f_1 (Γ_1 ) :A_1 :=t_1~\with … \with~f_n (Γ_n ) :A_n :=t_n~\for~f_i In the inference rules, we represent such a term by @@ -1580,7 +1586,7 @@ In the inference rules, we represent such a term by \Fix~f_i\{f_1 :A_1':=t_1' … f_n :A_n':=t_n'\} with :math:`t_i'` (resp. :math:`A_i'`) representing the term :math:`t_i` abstracted (resp. -generalized) with respect to the bindings in the context Γ_i , namely +generalized) with respect to the bindings in the context :math:`Γ_i`, namely :math:`t_i'=λ Γ_i . t_i` and :math:`A_i'=∀ Γ_i , A_i`. @@ -1592,7 +1598,7 @@ The typing rule is the expected one for a fixpoint. .. inference:: Fix (E[Γ] ⊢ A_i : s_i )_{i=1… n} - (E[Γ,f_1 :A_1 ,…,f_n :A_n ] ⊢ t_i : A_i )_{i=1… n} + (E[Γ;~f_1 :A_1 ;~…;~f_n :A_n ] ⊢ t_i : A_i )_{i=1… n} ------------------------------------------------------- E[Γ] ⊢ \Fix~f_i\{f_1 :A_1 :=t_1 … f_n :A_n :=t_n \} : A_i @@ -1608,14 +1614,14 @@ instance in the case of natural numbers, a proof of the induction principle of type .. math:: - ∀ P:\nat→\Prop, (P~O)→(∀ n:\nat, (P~n)→(P~(\kw{S}~n)))→ ∀ n:\nat, (P~n) + ∀ P:\nat→\Prop,~(P~\nO)→(∀ n:\nat,~(P~n)→(P~(\nS~n)))→ ∀ n:\nat,~(P~n) can be represented by the term: .. math:: \begin{array}{l} - λ P:\nat→\Prop. λ f:(P~O). λ g:(∀ n:\nat, (P~n)→(P~(S~n))).\\ - \Fix~h\{h:∀ n:\nat, (P~n):=λ n:\nat. \case(n,P,f | λp:\nat. (g~p~(h~p)))\} + λ P:\nat→\Prop.~λ f:(P~\nO).~λ g:(∀ n:\nat,~(P~n)→(P~(\nS~n))).\\ + \Fix~h\{h:∀ n:\nat,~(P~n):=λ n:\nat.~\case(n,P,f | λp:\nat.~(g~p~(h~p)))\} \end{array} Before accepting a fixpoint definition as being correctly typed, we @@ -1632,7 +1638,7 @@ fixpoints is extended and becomes where :math:`k_i` are positive integers. Each :math:`k_i` represents the index of parameter of :math:`f_i` , on which :math:`f_i` is decreasing. Each :math:`A_i` should be a type (reducible to a term) starting with at least :math:`k_i` products -:math:`∀ y_1 :B_1 ,… ∀ y_{k_i} :B_{k_i} , A_i'` and :math:`B_{k_i}` an inductive type. +:math:`∀ y_1 :B_1 ,~… ∀ y_{k_i} :B_{k_i} ,~A_i'` and :math:`B_{k_i}` an inductive type. Now in the definition :math:`t_i`, if :math:`f_j` occurs then it should be applied to at least :math:`k_j` arguments and the :math:`k_j`-th argument should be @@ -1642,23 +1648,23 @@ The definition of being structurally smaller is a bit technical. One needs first to define the notion of *recursive arguments of a constructor*. For an inductive definition :math:`\ind{r}{Γ_I}{Γ_C}`, if the type of a constructor :math:`c` has the form -:math:`∀ p_1 :P_1 ,… ∀ p_r :P_r, ∀ x_1:T_1, … ∀ x_r :T_r, (I_j~p_1 … p_r~t_1 … t_s )`, +:math:`∀ p_1 :P_1 ,~… ∀ p_r :P_r,~∀ x_1:T_1,~… ∀ x_r :T_r,~(I_j~p_1 … p_r~t_1 … t_s )`, then the recursive arguments will correspond to :math:`T_i` in which one of the :math:`I_l` occurs. The main rules for being structurally smaller are the following. Given a variable :math:`y` of an inductively defined type in a declaration -:math:`\ind{r}{Γ_I}{Γ_C}` where :math:`Γ_I` is :math:`[I_1 :A_1 ;…;I_k :A_k]`, and :math:`Γ_C` is -:math:`[c_1 :C_1 ;…;c_n :C_n ]`, the terms structurally smaller than :math:`y` are: +:math:`\ind{r}{Γ_I}{Γ_C}` where :math:`Γ_I` is :math:`[I_1 :A_1 ;~…;~I_k :A_k]`, and :math:`Γ_C` is +:math:`[c_1 :C_1 ;~…;~c_n :C_n ]`, the terms structurally smaller than :math:`y` are: -+ :math:`(t~u)` and :math:`λ x:u . t` when :math:`t` is structurally smaller than :math:`y`. ++ :math:`(t~u)` and :math:`λ x:U .~t` when :math:`t` is structurally smaller than :math:`y`. + :math:`\case(c,P,f_1 … f_n)` when each :math:`f_i` is structurally smaller than :math:`y`. If :math:`c` is :math:`y` or is structurally smaller than :math:`y`, its type is an inductive definition :math:`I_p` part of the inductive declaration corresponding to :math:`y`. Each :math:`f_i` corresponds to a type of constructor - :math:`C_q ≡ ∀ p_1 :P_1 ,…,∀ p_r :P_r , ∀ y_1 :B_1 , … ∀ y_k :B_k , (I~a_1 … a_k )` - and can consequently be written :math:`λ y_1 :B_1' . … λ y_k :B_k'. g_i`. (:math:`B_i'` is + :math:`C_q ≡ ∀ p_1 :P_1 ,~…,∀ p_r :P_r ,~∀ y_1 :B_1 ,~… ∀ y_k :B_k ,~(I~a_1 … a_k )` + and can consequently be written :math:`λ y_1 :B_1' .~… λ y_k :B_k'.~g_i`. (:math:`B_i'` is obtained from :math:`B_i` by substituting parameters for variables) the variables :math:`y_j` occurring in :math:`g_i` corresponding to recursive arguments :math:`B_i` (the ones in which one of the :math:`I_l` occurs) are structurally smaller than y. @@ -1702,7 +1708,7 @@ Let :math:`F` be the set of declarations: The reduction for fixpoints is: .. math:: - (\Fix~f_i \{F\} a_1 …a_{k_i}) \triangleright_ι \subst{t_i}{f_k}{\Fix~f_k \{F\}}_{k=1… n} ~a_1 … a_{k_i} + (\Fix~f_i \{F\}~a_1 …a_{k_i}) ~\triangleright_ι~ \subst{t_i}{f_k}{\Fix~f_k \{F\}}_{k=1… n} ~a_1 … a_{k_i} when :math:`a_{k_i}` starts with a constructor. This last restriction is needed in order to keep strong normalization and corresponds to the reduction @@ -1712,13 +1718,11 @@ possible: .. math:: :nowrap: - {\def\plus{\mathsf{plus}} - \def\tri{\triangleright_\iota} - \begin{eqnarray*} - \plus~(\nS~(\nS~\nO))~(\nS~\nO) & \tri & \nS~(\plus~(\nS~\nO)~(\nS~\nO))\\ - & \tri & \nS~(\nS~(\plus~\nO~(\nS~\nO)))\\ - & \tri & \nS~(\nS~(\nS~\nO))\\ - \end{eqnarray*}} + \begin{eqnarray*} + \plus~(\nS~(\nS~\nO))~(\nS~\nO)~& \trii & \nS~(\plus~(\nS~\nO)~(\nS~\nO))\\ + & \trii & \nS~(\nS~(\plus~\nO~(\nS~\nO)))\\ + & \trii & \nS~(\nS~(\nS~\nO))\\ + \end{eqnarray*} .. _Mutual-induction: @@ -1748,9 +1752,9 @@ reference to the global declaration in the subsequent global environment and local context by explicitly applying this constant to the constant :math:`c'`. -Below, if :math:`Γ` is a context of the form :math:`[y_1 :A_1 ;…;y_n :A_n]`, we write -:math:`∀x:U,\subst{Γ}{c}{x}` to mean -:math:`[y_1 :∀ x:U,\subst{A_1}{c}{x};…;y_n :∀ x:U,\subst{A_n}{c}{x}]` +Below, if :math:`Γ` is a context of the form :math:`[y_1 :A_1 ;~…;~y_n :A_n]`, we write +:math:`∀x:U,~\subst{Γ}{c}{x}` to mean +:math:`[y_1 :∀ x:U,~\subst{A_1}{c}{x};~…;~y_n :∀ x:U,~\subst{A_n}{c}{x}]` and :math:`\subst{E}{|Γ|}{|Γ|c}` to mean the parallel substitution :math:`E\{y_1 /(y_1~c)\}…\{y_n/(y_n~c)\}`. @@ -1760,25 +1764,25 @@ and :math:`\subst{E}{|Γ|}{|Γ|c}` to mean the parallel substitution **First abstracting property:** .. math:: - \frac{\WF{E;c:U;E′;c′:=t:T;E″}{Γ}} - {\WF{E;c:U;E′;c′:=λ x:U. \subst{t}{c}{x}:∀x:U,\subst{T}{c}{x};\subst{E″}{c′}{(c′~c)}} - {\subst{Γ}{c}{(c~c′)}}} + \frac{\WF{E;~c:U;~E′;~c′:=t:T;~E″}{Γ}} + {\WF{E;~c:U;~E′;~c′:=λ x:U.~\subst{t}{c}{x}:∀x:U,~\subst{T}{c}{x};~\subst{E″}{c′}{(c′~c)}} + {\subst{Γ}{c′}{(c′~c)}}} .. math:: - \frac{\WF{E;c:U;E′;c′:T;E″}{Γ}} - {\WF{E;c:U;E′;c′:∀ x:U,\subst{T}{c}{x};\subst{E″}{c′}{(c′~c)}}{Γ{c/(c~c′)}}} + \frac{\WF{E;~c:U;~E′;~c′:T;~E″}{Γ}} + {\WF{E;~c:U;~E′;~c′:∀ x:U,~\subst{T}{c}{x};~\subst{E″}{c′}{(c′~c)}}{\subst{Γ}{c′}{(c′~c)}}} .. math:: - \frac{\WF{E;c:U;E′;\ind{p}{Γ_I}{Γ_C};E″}{Γ}} - {\WFTWOLINES{E;c:U;E′;\ind{p+1}{∀ x:U,\subst{Γ_I}{c}{x}}{∀ x:U,\subst{Γ_C}{c}{x}}; - \subst{E″}{|Γ_I ,Γ_C |}{|Γ_I ,Γ_C | c}} - {\subst{Γ}{|Γ_I ,Γ_C|}{|Γ_I ,Γ_C | c}}} + \frac{\WF{E;~c:U;~E′;~\ind{p}{Γ_I}{Γ_C};~E″}{Γ}} + {\WFTWOLINES{E;~c:U;~E′;~\ind{p+1}{∀ x:U,~\subst{Γ_I}{c}{x}}{∀ x:U,~\subst{Γ_C}{c}{x}};~ + \subst{E″}{|Γ_I ;Γ_C |}{|Γ_I ;Γ_C | c}} + {\subst{Γ}{|Γ_I ;Γ_C|}{|Γ_I ;Γ_C | c}}} One can similarly modify a global declaration by generalizing it over a previously defined constant :math:`c′`. Below, if :math:`Γ` is a context of the form -:math:`[y_1 :A_1 ;…;y_n :A_n]`, we write :math:`\subst{Γ}{c}{u}` to mean -:math:`[y_1 :\subst{A_1} {c}{u};…;y_n:\subst{A_n} {c}{u}]`. +:math:`[y_1 :A_1 ;~…;~y_n :A_n]`, we write :math:`\subst{Γ}{c}{u}` to mean +:math:`[y_1 :\subst{A_1} {c}{u};~…;~y_n:\subst{A_n} {c}{u}]`. .. _Second-abstracting-property: @@ -1786,16 +1790,16 @@ a previously defined constant :math:`c′`. Below, if :math:`Γ` is a context of **Second abstracting property:** .. math:: - \frac{\WF{E;c:=u:U;E′;c′:=t:T;E″}{Γ}} - {\WF{E;c:=u:U;E′;c′:=(\letin{x}{u:U}{\subst{t}{c}{x}}):\subst{T}{c}{u};E″}{Γ}} + \frac{\WF{E;~c:=u:U;~E′;~c′:=t:T;~E″}{Γ}} + {\WF{E;~c:=u:U;~E′;~c′:=(\letin{x}{u:U}{\subst{t}{c}{x}}):\subst{T}{c}{u};~E″}{Γ}} .. math:: - \frac{\WF{E;c:=u:U;E′;c′:T;E″}{Γ}} - {\WF{E;c:=u:U;E′;c′:\subst{T}{c}{u};E″}{Γ}} + \frac{\WF{E;~c:=u:U;~E′;~c′:T;~E″}{Γ}} + {\WF{E;~c:=u:U;~E′;~c′:\subst{T}{c}{u};~E″}{Γ}} .. math:: - \frac{\WF{E;c:=u:U;E′;\ind{p}{Γ_I}{Γ_C};E″}{Γ}} - {\WF{E;c:=u:U;E′;\ind{p}{\subst{Γ_I}{c}{u}}{\subst{Γ_C}{c}{u}};E″}{Γ}} + \frac{\WF{E;~c:=u:U;~E′;~\ind{p}{Γ_I}{Γ_C};~E″}{Γ}} + {\WF{E;~c:=u:U;~E′;~\ind{p}{\subst{Γ_I}{c}{u}}{\subst{Γ_C}{c}{u}};~E″}{Γ}} .. _Pruning-the-local-context: @@ -1810,7 +1814,7 @@ One can consequently derive the following property. .. inference:: First pruning property: - \WF{E;c:U;E′}{Γ} + \WF{E;~c:U;~E′}{Γ} c~\kw{does not occur in}~E′~\kw{and}~Γ -------------------------------------- \WF{E;E′}{Γ} @@ -1820,7 +1824,7 @@ One can consequently derive the following property. .. inference:: Second pruning property: - \WF{E;c:=u:U;E′}{Γ} + \WF{E;~c:=u:U;~E′}{Γ} c~\kw{does not occur in}~E′~\kw{and}~Γ -------------------------------------- \WF{E;E′}{Γ} @@ -1861,10 +1865,10 @@ in the sort :math:`\Set`, which is extended to a domain in any sort: .. inference:: ProdImp E[Γ] ⊢ T : s - s ∈ {\Sort} - E[Γ::(x:T)] ⊢ U : Set + s ∈ \Sort + E[Γ::(x:T)] ⊢ U : \Set --------------------- - E[Γ] ⊢ ∀ x:T,U : Set + E[Γ] ⊢ ∀ x:T,~U : \Set This extension has consequences on the inductive definitions which are allowed. In the impredicative system, one can build so-called *large @@ -1879,15 +1883,15 @@ impredicative system for sort :math:`\Set` become: .. inference:: Set1 - s ∈ \{Prop, Set\} + s ∈ \{\Prop, \Set\} ----------------- - [I:Set|I→ s] + [I:\Set|I→ s] .. inference:: Set2 I~\kw{is a small inductive definition} s ∈ \{\Type(i)\} ---------------- - [I:Set|I→ s] + [I:\Set|I→ s] diff --git a/doc/sphinx/language/coq-library.rst b/doc/sphinx/language/coq-library.rst index 10650af1d1..b82b3b0e80 100644 --- a/doc/sphinx/language/coq-library.rst +++ b/doc/sphinx/language/coq-library.rst @@ -104,18 +104,18 @@ subclass :token:`form` of the syntactic class :token:`term`. The syntax of a nice last column. Or even better, find a proper way to do this! .. productionlist:: - form : True (True) - : | False (False) - : | ~ `form` (not) - : | `form` /\ `form` (and) - : | `form` \/ `form` (or) - : | `form` -> `form` (primitive implication) - : | `form` <-> `form` (iff) - : | forall `ident` : `type`, `form` (primitive for all) - : | exists `ident` [: `specif`], `form` (ex) - : | exists2 `ident` [: `specif`], `form` & `form` (ex2) - : | `term` = `term` (eq) - : | `term` = `term` :> `specif` (eq) + form : True (True) + : False (False) + : ~ `form` (not) + : `form` /\ `form` (and) + : `form` \/ `form` (or) + : `form` -> `form` (primitive implication) + : `form` <-> `form` (iff) + : forall `ident` : `type`, `form` (primitive for all) + : exists `ident` [: `specif`], `form` (ex) + : exists2 `ident` [: `specif`], `form` & `form` (ex2) + : `term` = `term` (eq) + : `term` = `term` :> `specif` (eq) .. note:: @@ -287,13 +287,13 @@ the next section :ref:`specification`): .. productionlist:: specif : `specif` * `specif` (prod) - : | `specif` + `specif` (sum) - : | `specif` + { `specif` } (sumor) - : | { `specif` } + { `specif` } (sumbool) - : | { `ident` : `specif` | `form` } (sig) - : | { `ident` : `specif` | `form` & `form` } (sig2) - : | { `ident` : `specif` & `specif` } (sigT) - : | { `ident` : `specif` & `specif` & `specif` } (sigT2) + : `specif` + `specif` (sum) + : `specif` + { `specif` } (sumor) + : { `specif` } + { `specif` } (sumbool) + : { `ident` : `specif` | `form` } (sig) + : { `ident` : `specif` | `form` & `form` } (sig2) + : { `ident` : `specif` & `specif` } (sigT) + : { `ident` : `specif` & `specif` & `specif` } (sigT2) term : (`term`, `term`) (pair) diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index 376a6b8eed..50a56f1d51 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -25,7 +25,7 @@ expressions. In this sense, the :cmd:`Record` construction allows defining record_keyword : Record | Inductive | CoInductive record_body : `ident` [ `binders` ] [: `sort` ] := [ `ident` ] { [ `field` ; … ; `field` ] }. field : `ident` [ `binders` ] : `type` [ where `notation` ] - : | `ident` [ `binders` ] [: `type` ] := `term` + : `ident` [ `binders` ] [: `type` ] := `term` .. cmd:: Record @ident @binders {? : @sort} := {? @ident} { {*; @ident @binders : @type } } @@ -165,8 +165,8 @@ available: .. productionlist:: terms projection : `term` `.` ( `qualid` ) - : | `term` `.` ( `qualid` `arg` … `arg` ) - : | `term` `.` ( @`qualid` `term` … `term` ) + : `term` `.` ( `qualid` `arg` … `arg` ) + : `term` `.` ( @`qualid` `term` … `term` ) Syntax of Record projections @@ -234,7 +234,8 @@ Primitive Projections extended the Calculus of Inductive Constructions with a new binary term constructor `r.(p)` representing a primitive projection `p` applied to a record object `r` (i.e., primitive projections are always applied). - Even if the record type has parameters, these do not appear at + Even if the record type has parameters, these do not appear + in the internal representation of applications of the projection, considerably reducing the sizes of terms when manipulating parameterized records and type checking time. On the user level, primitive projections can be used as a replacement @@ -818,14 +819,14 @@ together, as well as a means of massive abstraction. .. productionlist:: modules module_type : `qualid` - : | `module_type` with Definition `qualid` := `term` - : | `module_type` with Module `qualid` := `qualid` - : | `qualid` `qualid` … `qualid` - : | !`qualid` `qualid` … `qualid` + : `module_type` with Definition `qualid` := `term` + : `module_type` with Module `qualid` := `qualid` + : `qualid` `qualid` … `qualid` + : !`qualid` `qualid` … `qualid` module_binding : ( [Import|Export] `ident` … `ident` : `module_type` ) module_bindings : `module_binding` … `module_binding` module_expression : `qualid` … `qualid` - : | !`qualid` … `qualid` + : !`qualid` … `qualid` Syntax of modules @@ -1814,10 +1815,10 @@ This syntax extension is given in the following grammar: .. productionlist:: explicit_apps term : @ `qualid` `term` … `term` - : | @ `qualid` - : | `qualid` `argument` … `argument` + : @ `qualid` + : `qualid` `argument` … `argument` argument : `term` - : | (`ident` := `term`) + : (`ident` := `term`) Syntax for explicitly giving implicit arguments diff --git a/doc/sphinx/language/gallina-specification-language.rst b/doc/sphinx/language/gallina-specification-language.rst index 1a33a9a46e..5ecf007eff 100644 --- a/doc/sphinx/language/gallina-specification-language.rst +++ b/doc/sphinx/language/gallina-specification-language.rst @@ -127,43 +127,43 @@ is described in Chapter :ref:`syntaxextensionsandinterpretationscopes`. .. productionlist:: coq term : forall `binders` , `term` - : | fun `binders` => `term` - : | fix `fix_bodies` - : | cofix `cofix_bodies` - : | let `ident` [`binders`] [: `term`] := `term` in `term` - : | let fix `fix_body` in `term` - : | let cofix `cofix_body` in `term` - : | let ( [`name` , … , `name`] ) [`dep_ret_type`] := `term` in `term` - : | let ' `pattern` [in `term`] := `term` [`return_type`] in `term` - : | if `term` [`dep_ret_type`] then `term` else `term` - : | `term` : `term` - : | `term` <: `term` - : | `term` :> - : | `term` -> `term` - : | `term` `arg` … `arg` - : | @ `qualid` [`term` … `term`] - : | `term` % `ident` - : | match `match_item` , … , `match_item` [`return_type`] with + : fun `binders` => `term` + : fix `fix_bodies` + : cofix `cofix_bodies` + : let `ident` [`binders`] [: `term`] := `term` in `term` + : let fix `fix_body` in `term` + : let cofix `cofix_body` in `term` + : let ( [`name` , … , `name`] ) [`dep_ret_type`] := `term` in `term` + : let ' `pattern` [in `term`] := `term` [`return_type`] in `term` + : if `term` [`dep_ret_type`] then `term` else `term` + : `term` : `term` + : `term` <: `term` + : `term` :> + : `term` -> `term` + : `term` `arg` … `arg` + : @ `qualid` [`term` … `term`] + : `term` % `ident` + : match `match_item` , … , `match_item` [`return_type`] with : [[|] `equation` | … | `equation`] end - : | `qualid` - : | `sort` - : | `num` - : | _ - : | ( `term` ) + : `qualid` + : `sort` + : `num` + : _ + : ( `term` ) arg : `term` - : | ( `ident` := `term` ) + : ( `ident` := `term` ) binders : `binder` … `binder` binder : `name` - : | ( `name` … `name` : `term` ) - : | ( `name` [: `term`] := `term` ) - : | ' `pattern` + : ( `name` … `name` : `term` ) + : ( `name` [: `term`] := `term` ) + : ' `pattern` name : `ident` | _ qualid : `ident` | `qualid` `access_ident` sort : Prop | Set | Type fix_bodies : `fix_body` - : | `fix_body` with `fix_body` with … with `fix_body` for `ident` + : `fix_body` with `fix_body` with … with `fix_body` for `ident` cofix_bodies : `cofix_body` - : | `cofix_body` with `cofix_body` with … with `cofix_body` for `ident` + : `cofix_body` with `cofix_body` with … with `cofix_body` for `ident` fix_body : `ident` `binders` [`annotation`] [: `term`] := `term` cofix_body : `ident` [`binders`] [: `term`] := `term` annotation : { struct `ident` } @@ -173,13 +173,13 @@ is described in Chapter :ref:`syntaxextensionsandinterpretationscopes`. equation : `mult_pattern` | … | `mult_pattern` => `term` mult_pattern : `pattern` , … , `pattern` pattern : `qualid` `pattern` … `pattern` - : | @ `qualid` `pattern` … `pattern` - : | `pattern` as `ident` - : | `pattern` % `ident` - : | `qualid` - : | _ - : | `num` - : | ( `or_pattern` , … , `or_pattern` ) + : @ `qualid` `pattern` … `pattern` + : `pattern` as `ident` + : `pattern` % `ident` + : `qualid` + : _ + : `num` + : ( `or_pattern` , … , `or_pattern` ) or_pattern : `pattern` | … | `pattern` @@ -230,7 +230,7 @@ There are three sorts :g:`Set`, :g:`Prop` and :g:`Type`. themselves are typing the proofs. We denote propositions by :production:`form`. This constitutes a semantic subclass of the syntactic class :token:`term`. -- :g:`Set` is is the universe of *program types* or *specifications*. The +- :g:`Set` is the universe of *program types* or *specifications*. The specifications themselves are typing the programs. We denote specifications by :production:`specif`. This constitutes a semantic subclass of the syntactic class :token:`term`. @@ -524,38 +524,38 @@ The Vernacular .. productionlist:: coq decorated-sentence : [ `decoration` … `decoration` ] `sentence` sentence : `assumption` - : | `definition` - : | `inductive` - : | `fixpoint` - : | `assertion` `proof` + : `definition` + : `inductive` + : `fixpoint` + : `assertion` `proof` assumption : `assumption_keyword` `assums`. assumption_keyword : Axiom | Conjecture - : | Parameter | Parameters - : | Variable | Variables - : | Hypothesis | Hypotheses + : Parameter | Parameters + : Variable | Variables + : Hypothesis | Hypotheses assums : `ident` … `ident` : `term` - : | ( `ident` … `ident` : `term` ) … ( `ident` … `ident` : `term` ) + : ( `ident` … `ident` : `term` ) … ( `ident` … `ident` : `term` ) definition : [Local] Definition `ident` [`binders`] [: `term`] := `term` . - : | Let `ident` [`binders`] [: `term`] := `term` . + : Let `ident` [`binders`] [: `term`] := `term` . inductive : Inductive `ind_body` with … with `ind_body` . - : | CoInductive `ind_body` with … with `ind_body` . + : CoInductive `ind_body` with … with `ind_body` . ind_body : `ident` [`binders`] : `term` := : [[|] `ident` [`binders`] [:`term`] | … | `ident` [`binders`] [:`term`]] fixpoint : Fixpoint `fix_body` with … with `fix_body` . - : | CoFixpoint `cofix_body` with … with `cofix_body` . + : CoFixpoint `cofix_body` with … with `cofix_body` . assertion : `assertion_keyword` `ident` [`binders`] : `term` . assertion_keyword : Theorem | Lemma - : | Remark | Fact - : | Corollary | Proposition - : | Definition | Example + : Remark | Fact + : Corollary | Proposition + : Definition | Example proof : Proof . … Qed . - : | Proof . … Defined . - : | Proof . … Admitted . + : Proof . … Defined . + : Proof . … Admitted . decoration : #[ `attributes` ] attributes : [`attribute`, … , `attribute`] attribute : `ident` - :| `ident` = `string` - :| `ident` ( `attributes` ) + : `ident` = `string` + : `ident` ( `attributes` ) .. todo:: This use of … in this grammar is inconsistent What about removing the proof part of this grammar from this chapter diff --git a/doc/sphinx/practical-tools/coq-commands.rst b/doc/sphinx/practical-tools/coq-commands.rst index 9bc67147f7..1b4d2315aa 100644 --- a/doc/sphinx/practical-tools/coq-commands.rst +++ b/doc/sphinx/practical-tools/coq-commands.rst @@ -163,14 +163,14 @@ and ``coqtop``, unless stated otherwise: is equivalent to runningRequire dirpath. :-require dirpath: Load |Coq| compiled library dirpath and import it. This is equivalent to running Require Import dirpath. -:-batch: Exit just after argument parsing. Available for `coqtop` only. -:-compile *file.v*: Compile file *file.v* into *file.vo*. This option +:-batch: Exit just after argument parsing. Available for ``coqtop`` only. +:-compile *file.v*: Deprecated; use ``coqc`` instead. Compile file *file.v* into *file.vo*. This option implies -batch (exit just after argument parsing). It is available only - for `coqtop`, as this behavior is the purpose of `coqc`. -:-compile-verbose *file.v*: Same as -compile but also output the + for `coqtop`, as this behavior is the purpose of ``coqc``. +:-compile-verbose *file.v*: Deprecated. Use ``coqc -verbose``. Same as -compile but also output the content of *file.v* as it is compiled. :-verbose: Output the content of the input file as it is compiled. - This option is available for `coqc` only; it is the counterpart of + This option is available for ``coqc`` only; it is the counterpart of -compile-verbose. :-w (all|none|w₁,…,wₙ): Configure the display of warnings. This option expects all, none or a comma-separated list of warning names or @@ -211,11 +211,11 @@ and ``coqtop``, unless stated otherwise: (to be used by coqdoc, see :ref:`coqdoc`). By default, if *file.v* is being compiled, *file.glob* is used. :-no-glob: Disable the dumping of references for global names. -:-image *file*: Set the binary image to be used by `coqc` to be *file* +:-image *file*: Set the binary image to be used by ``coqc`` to be *file* instead of the standard one. Not of general use. :-bindir *directory*: Set the directory containing |Coq| binaries to be - used by `coqc`. It is equivalent to doing export COQBIN= *directory* - before launching `coqc`. + used by ``coqc``. It is equivalent to doing export COQBIN= *directory* + before launching ``coqc``. :-where: Print the location of |Coq|’s standard library and exit. :-config: Print the locations of |Coq|’s binaries, dependencies, and libraries, then exit. diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index 1071682ead..442077616f 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -41,117 +41,121 @@ mode but it can also be used in toplevel definitions as shown below. .. note:: - - The infix tacticals “… \|\| …”, “… + …”, and “… ; …” are associative. + - The infix tacticals ``… || …`` , ``… + …`` , and ``… ; …`` are associative. - - In :token:`tacarg`, there is an overlap between qualid as a direct tactic - argument and :token:`qualid` as a particular case of term. The resolution is - done by first looking for a reference of the tactic language and if - it fails, for a reference to a term. To force the resolution as a - reference of the tactic language, use the form :g:`ltac:(@qualid)`. To - force the resolution as a reference to a term, use the syntax - :g:`(@qualid)`. + .. example:: - - As shown by the figure, tactical ``\|\|`` binds more than the prefix - tacticals try, repeat, do and abstract which themselves bind more - than the postfix tactical “… ;[ … ]” which binds more than “… ; …”. + If you want that :n:`@tactic__2; @tactic__3` be fully run on the first + subgoal generated by :n:`@tactic__1`, before running on the other + subgoals, then you should not write + :n:`@tactic__1; (@tactic__2; @tactic__3)` but rather + :n:`@tactic__1; [> @tactic__2; @tactic__3 .. ]`. - For instance + - In :token:`tacarg`, there is an overlap between :token:`qualid` as a + direct tactic argument and :token:`qualid` as a particular case of + :token:`term`. The resolution is done by first looking for a reference + of the tactic language and if it fails, for a reference to a term. + To force the resolution as a reference of the tactic language, use the + form :n:`ltac:(@qualid)`. To force the resolution as a reference to a + term, use the syntax :n:`(@qualid)`. - .. coqtop:: in + - As shown by the figure, tactical ``… || …`` binds more than the prefix + tacticals :tacn:`try`, :tacn:`repeat`, :tacn:`do` and :tacn:`abstract` + which themselves bind more than the postfix tactical ``… ;[ … ]`` + which binds at the same level as ``… ; …`` . - try repeat tac1 || tac2; tac3; [tac31 | ... | tac3n]; tac4. + .. example:: - is understood as + :n:`try repeat @tactic__1 || @tactic__2; @tactic__3; [ {+| @tactic } ]; @tactic__4` - .. coqtop:: in + is understood as: - try (repeat (tac1 || tac2)); - ((tac3; [tac31 | ... | tac3n]); tac4). + :n:`((try (repeat (@tactic__1 || @tactic__2)); @tactic__3); [ {+| @tactic } ]); @tactic__4` .. productionlist:: coq expr : `expr` ; `expr` - : | [> `expr` | ... | `expr` ] - : | `expr` ; [ `expr` | ... | `expr` ] - : | `tacexpr3` - tacexpr3 : do (`natural` | `ident`) tacexpr3 - : | progress `tacexpr3` - : | repeat `tacexpr3` - : | try `tacexpr3` - : | once `tacexpr3` - : | exactly_once `tacexpr3` - : | timeout (`natural` | `ident`) `tacexpr3` - : | time [`string`] `tacexpr3` - : | only `selector`: `tacexpr3` - : | `tacexpr2` + : [> `expr` | ... | `expr` ] + : `expr` ; [ `expr` | ... | `expr` ] + : `tacexpr3` + tacexpr3 : do (`natural` | `ident`) `tacexpr3` + : progress `tacexpr3` + : repeat `tacexpr3` + : try `tacexpr3` + : once `tacexpr3` + : exactly_once `tacexpr3` + : timeout (`natural` | `ident`) `tacexpr3` + : time [`string`] `tacexpr3` + : only `selector`: `tacexpr3` + : `tacexpr2` tacexpr2 : `tacexpr1` || `tacexpr3` - : | `tacexpr1` + `tacexpr3` - : | tryif `tacexpr1` then `tacexpr1` else `tacexpr1` - : | `tacexpr1` + : `tacexpr1` + `tacexpr3` + : tryif `tacexpr1` then `tacexpr1` else `tacexpr1` + : `tacexpr1` tacexpr1 : fun `name` ... `name` => `atom` - : | let [rec] `let_clause` with ... with `let_clause` in `atom` - : | match goal with `context_rule` | ... | `context_rule` end - : | match reverse goal with `context_rule` | ... | `context_rule` end - : | match `expr` with `match_rule` | ... | `match_rule` end - : | lazymatch goal with `context_rule` | ... | `context_rule` end - : | lazymatch reverse goal with `context_rule` | ... | `context_rule` end - : | lazymatch `expr` with `match_rule` | ... | `match_rule` end - : | multimatch goal with `context_rule` | ... | `context_rule` end - : | multimatch reverse goal with `context_rule` | ... | `context_rule` end - : | multimatch `expr` with `match_rule` | ... | `match_rule` end - : | abstract `atom` - : | abstract `atom` using `ident` - : | first [ `expr` | ... | `expr` ] - : | solve [ `expr` | ... | `expr` ] - : | idtac [ `message_token` ... `message_token`] - : | fail [`natural`] [`message_token` ... `message_token`] - : | fresh [ `component` … `component` ] - : | context `ident` [`term`] - : | eval `redexpr` in `term` - : | type of `term` - : | constr : `term` - : | uconstr : `term` - : | type_term `term` - : | numgoals - : | guard `test` - : | assert_fails `tacexpr3` - : | assert_succeeds `tacexpr3` - : | `atomic_tactic` - : | `qualid` `tacarg` ... `tacarg` - : | `atom` + : let [rec] `let_clause` with ... with `let_clause` in `atom` + : match goal with `context_rule` | ... | `context_rule` end + : match reverse goal with `context_rule` | ... | `context_rule` end + : match `expr` with `match_rule` | ... | `match_rule` end + : lazymatch goal with `context_rule` | ... | `context_rule` end + : lazymatch reverse goal with `context_rule` | ... | `context_rule` end + : lazymatch `expr` with `match_rule` | ... | `match_rule` end + : multimatch goal with `context_rule` | ... | `context_rule` end + : multimatch reverse goal with `context_rule` | ... | `context_rule` end + : multimatch `expr` with `match_rule` | ... | `match_rule` end + : abstract `atom` + : abstract `atom` using `ident` + : first [ `expr` | ... | `expr` ] + : solve [ `expr` | ... | `expr` ] + : idtac [ `message_token` ... `message_token`] + : fail [`natural`] [`message_token` ... `message_token`] + : fresh [ `component` … `component` ] + : context `ident` [`term`] + : eval `redexpr` in `term` + : type of `term` + : constr : `term` + : uconstr : `term` + : type_term `term` + : numgoals + : guard `test` + : assert_fails `tacexpr3` + : assert_succeeds `tacexpr3` + : `atomic_tactic` + : `qualid` `tacarg` ... `tacarg` + : `atom` atom : `qualid` - : | () - : | `integer` - : | ( `expr` ) + : () + : `integer` + : ( `expr` ) component : `string` | `qualid` message_token : `string` | `ident` | `integer` tacarg : `qualid` - : | () - : | ltac : `atom` - : | `term` + : () + : ltac : `atom` + : `term` let_clause : `ident` [`name` ... `name`] := `expr` context_rule : `context_hyp`, ..., `context_hyp` |- `cpattern` => `expr` - : | `cpattern` => `expr` - : | |- `cpattern` => `expr` - : | _ => `expr` + : `cpattern` => `expr` + : |- `cpattern` => `expr` + : _ => `expr` context_hyp : `name` : `cpattern` - : | `name` := `cpattern` [: `cpattern`] + : `name` := `cpattern` [: `cpattern`] match_rule : `cpattern` => `expr` - : | context [ident] [ `cpattern` ] => `expr` - : | _ => `expr` + : context [`ident`] [ `cpattern` ] => `expr` + : _ => `expr` test : `integer` = `integer` - : | `integer` (< | <= | > | >=) `integer` + : `integer` (< | <= | > | >=) `integer` selector : [`ident`] - : | `integer` - : | (`integer` | `integer` - `integer`), ..., (`integer` | `integer` - `integer`) + : `integer` + : (`integer` | `integer` - `integer`), ..., (`integer` | `integer` - `integer`) toplevel_selector : `selector` - : | all - : | par - : | ! + : all + : par + : ! .. productionlist:: coq top : [Local] Ltac `ltac_def` with ... with `ltac_def` ltac_def : `ident` [`ident` ... `ident`] := `expr` - : | `qualid` [`ident` ... `ident`] ::= `expr` + : `qualid` [`ident` ... `ident`] ::= `expr` .. _ltac-semantics: diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index bffbe3e284..483dbd311d 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -1445,6 +1445,16 @@ section constant. If tactic is ``move`` or ``case`` and an equation :token:`ident` is given, then clear (step 3) for :token:`d_item` is suppressed (see section :ref:`generation_of_equations_ssr`). +Intro patterns (see section :ref:`introduction_ssr`) +and the ``rewrite`` tactic (see section :ref:`rewriting_ssr`) +let one place a :token:`clear_switch` in the middle of other items +(namely identifiers, views and rewrite rules). This can trigger the +addition of proof context items to the ones being explicitly +cleared, and in turn this can result in clear errors (e.g. if the +context item automatically added occurs in the goal). The +relevant sections describe ways to avoid the unintended clear of +context items. + Matching for apply and exact ```````````````````````````` @@ -1559,7 +1569,7 @@ whose general syntax is i_view ::= {? %{%} } /@term %| /ltac:( @tactic ) .. prodn:: - i_pattern ::= @ident %| > @ident %| _ %| ? %| * %| + %| {? @occ_switch } -> %| {? @occ_switch }<- %| [ {?| @i_item } ] %| - %| [: {+ @ident } ] + i_pattern ::= @ident %| > %| _ %| ? %| * %| + %| {? @occ_switch } -> %| {? @occ_switch }<- %| [ {?| @i_item } ] %| - %| [: {+ @ident } ] .. prodn:: i_block ::= [^ @ident ] %| [^~ @ident ] %| [^~ @num ] @@ -1572,6 +1582,9 @@ The :token:`i_pattern`\s can be seen as a variant of *intro patterns* (see :tacn:`intros`:) each performs an introduction operation, i.e., pops some variables or assumptions from the goal. +Simplification items +````````````````````` + An :token:`s_item` can simplify the set of subgoals or the subgoals themselves: + ``//`` removes all the “trivial” subgoals that can be resolved by the @@ -1583,18 +1596,32 @@ An :token:`s_item` can simplify the set of subgoals or the subgoals themselves: ``/= //``, i.e., ``simpl; try done``. -When an :token:`s_item` bears a :token:`clear_switch`, then the +When an :token:`s_item` immediately precedes a :token:`clear_switch`, then the :token:`clear_switch` is executed *after* the :token:`s_item`, e.g., ``{IHn}//`` will solve some subgoals, possibly using the fact ``IHn``, and will erase ``IHn`` from the context of the remaining subgoals. +Views +````` + The first entry in the :token:`i_view` grammar rule, :n:`/@term`, represents a view (see section :ref:`views_and_reflection_ssr`). It interprets the top of the stack with the view :token:`term`. -It is equivalent to ``move/term``. The optional flag ``{}`` can -be used to signal that the :token:`term`, when it is a context entry, -has to be cleared. +It is equivalent to :n:`move/@term`. + +A :token:`clear_switch` that immediately precedes an :token:`i_view` +is complemented with the name of the view if an only if the :token:`i_view` +is a simple proof context entry [#10]_. +E.g. ``{}/v`` is equivalent to ``/v{v}``. +This behavior can be avoided by separating the :token:`clear_switch` +from the :token:`i_view` with the ``-`` intro pattern or by putting +parentheses around the view. + +A :token:`clear_switch` that immediately precedes an :token:`i_view` +is executed after the view application. + + If the next :token:`i_item` is a view, then the view is applied to the assumption in top position once all the previous :token:`i_item` have been performed. @@ -1608,6 +1635,9 @@ Notations can be used to name tactics, for example:: lets one write just ``/myop`` in the intro pattern. Note the scope annotation: views are interpreted opening the ``ssripat`` scope. +Intro patterns +`````````````` + |SSR| supports the following :token:`i_pattern`\s: :token:`ident` @@ -1615,16 +1645,24 @@ annotation: views are interpreted opening the ``ssripat`` scope. a new constant, fact, or defined constant :token:`ident`, respectively. Note that defined constants cannot be introduced when δ-expansion is required to expose the top variable or assumption. -``>``:token:`ident` - pops the first assumption. Type class instances are not considered - as assumptions. - The tactic ``move=> >H`` is equivalent to - ``move=> ? ? H`` with enough ``?`` to name ``H`` the first assumption. - On a goal:: + A :token:`clear_switch` (even an empty one) immediately preceding an + :token:`ident` is complemented with that :token:`ident` if and only if + the identifier is a simple proof context entry [#10]_. + As a consequence by prefixing the + :token:`ident` with ``{}`` one can *replace* a context entry. + This behavior can be avoided by separating the :token:`clear_switch` + from the :token:`ident` with the ``-`` intro pattern. +``>`` + pops every variable occurring in the rest of the stack. + Type class instances are popped even if they don't occur + in the rest of the stack. + The tactic ``move=> >`` is equivalent to + ``move=> ? ?`` on a goal such as:: forall x y, x < y -> G - it names ``H`` the assumption ``x < y``. + A typical use if ``move=>> H`` to name ``H`` the first assumption, + in the example above ``x < y``. ``?`` pops the top variable into an anonymous constant or fact, whose name is picked by the tactic interpreter. |SSR| only generates names that cannot @@ -1707,6 +1745,9 @@ annotation: views are interpreted opening the ``ssripat`` scope. Note that |SSR| does not support the syntax ``(ipat, …, ipat)`` for destructing intro-patterns. +Clear switch +```````````` + Clears are deferred until the end of the intro pattern. .. example:: @@ -1729,6 +1770,9 @@ is performed behind the scenes. Facts mentioned in a clear switch must be valid names in the proof context (excluding the section context). +Branching and destructuring +``````````````````````````` + The rules for interpreting branching and destructing :token:`i_pattern` are motivated by the fact that it would be pointless to have a branching pattern if tactic is a ``move``, and in most of the remaining cases @@ -1753,6 +1797,9 @@ interpretation, e.g.: are all equivalent. +Block introduction +`````````````````` + |SSR| supports the following :token:`i_block`\s: :n:`[^ @ident ]` @@ -3029,13 +3076,22 @@ operation should be performed: pattern. In its simplest form, it is a regular term. If no explicit redex switch is present the rewrite pattern to be matched is inferred from the :token:`r_item`. -+ This optional term, or the :token:`r_item`, may be preceded by an occurrence - switch (see section :ref:`selectors_ssr`) or a clear item - (see section :ref:`discharge_ssr`), - these two possibilities being exclusive. An occurrence switch selects ++ This optional term, or the :token:`r_item`, may be preceded by an + :token:`occ_switch` (see section :ref:`selectors_ssr`) or a + :token:`clear_switch` (see section :ref:`discharge_ssr`), + these two possibilities being exclusive. + + An occurrence switch selects the occurrences of the rewrite pattern which should be affected by the rewrite operation. + A clear switch, even an empty one, is performed *after* the + :token:`r_item` is actually processed and is complemented with the name of + the rewrite rule if an only if it is a simple proof context entry [#10]_. + As a consequence one can + write ``rewrite {}H`` to rewrite with ``H`` and dispose ``H`` immediately + afterwards. + This behavior can be avoided by putting parentheses around the rewrite rule. An :token:`r_item` can be: @@ -3290,10 +3346,6 @@ the rewrite tactic. The effect of the tactic on the initial goal is to rewrite this lemma at the second occurrence of the first matching ``x + y + 0`` of the explicit rewrite redex ``_ + y + 0``. -An empty occurrence switch ``{}`` is not interpreted as a valid occurrence -switch. It has the effect of clearing the :token:`r_item` (when it is the name -of a context entry). - Occurrence selection and repetition ``````````````````````````````````` @@ -5305,7 +5357,7 @@ discharge item see :ref:`discharge_ssr` generalization item see :ref:`structure_ssr` -.. prodn:: i_pattern ::= @ident %| > @ident %| _ %| ? %| * %| + %| {? @occ_switch } -> %| {? @occ_switch } <- %| [ {?| @i_item } ] %| - %| [: {+ @ident } ] +.. prodn:: i_pattern ::= @ident %| > %| _ %| ? %| * %| + %| {? @occ_switch } -> %| {? @occ_switch } <- %| [ {?| @i_item } ] %| - %| [: {+ @ident } ] intro pattern :ref:`introduction_ssr` @@ -5519,3 +5571,5 @@ Settings in the metatheory .. [#9] The current state of the proof shall be displayed by the Show Proof command of |Coq| proof mode. +.. [#10] A simple proof context entry is a naked identifier (i.e. not between + parentheses) designating a context entry that is not a section variable. diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 59602581c7..7eef504ea9 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -33,10 +33,13 @@ extends the folklore notion of tactical) to combine those atomic tactics. This chapter is devoted to atomic tactics. The tactic language will be described in Chapter :ref:`ltac`. +Common elements of tactics +-------------------------- + .. _invocation-of-tactics: Invocation of tactics -------------------------- +~~~~~~~~~~~~~~~~~~~~~ A tactic is applied as an ordinary command. It may be preceded by a goal selector (see Section :ref:`ltac-semantics`). If no selector is @@ -44,9 +47,9 @@ specified, the default selector is used. .. _tactic_invocation_grammar: - .. productionlist:: `sentence` - tactic_invocation : toplevel_selector : tactic. - : |tactic . + .. productionlist:: sentence + tactic_invocation : `toplevel_selector` : `tactic`. + : `tactic`. .. opt:: Default Goal Selector "@toplevel_selector" :name: Default Goal Selector @@ -71,29 +74,31 @@ specified, the default selector is used. Bindings list ~~~~~~~~~~~~~~~~~~~ -Tactics that take a term as argument may also support a bindings list, -so as to instantiate some parameters of the term by name or position. -The general form of a term equipped with a bindings list is ``term with -bindings_list`` where ``bindings_list`` may be of two different forms: +Tactics that take a term as an argument may also support a bindings list +to instantiate some parameters of the term by name or position. +The general form of a term with a bindings list is +:n:`@term with @bindings_list` where :token:`bindings_list` can take two different forms: .. _bindings_list_grammar: - .. productionlist:: `bindings_list` - bindings_list : (ref := `term`) ... (ref := `term`) + .. productionlist:: bindings_list + ref : `ident` + : `num` + bindings_list : (`ref` := `term`) ... (`ref` := `term`) : `term` ... `term` -+ In a bindings list of the form :n:`{* (ref:= term)}`, :n:`ref` is either an ++ In a bindings list of the form :n:`{+ (@ref:= @term)}`, :n:`@ref` is either an :n:`@ident` or a :n:`@num`. The references are determined according to the type of - ``term``. If :n:`ref` is an identifier, this identifier has to be bound in the - type of ``term`` and the binding provides the tactic with an instance for the - parameter of this name. If :n:`ref` is some number ``n``, this number denotes - the ``n``-th non dependent premise of the ``term``, as determined by the type - of ``term``. + :n:`@term`. If :n:`@ref` is an identifier, this identifier has to be bound in the + type of :n:`@term` and the binding provides the tactic with an instance for the + parameter of this name. If :n:`@ref` is a number ``n``, it refers to + the ``n``-th non dependent premise of the :n:`@term`, as determined by the type + of :n:`@term`. .. exn:: No such binder. :undocumented: -+ A bindings list can also be a simple list of terms :n:`{* term}`. ++ A bindings list can also be a simple list of terms :n:`{* @term}`. In that case the references to which these terms correspond are determined by the tactic. In case of :tacn:`induction`, :tacn:`destruct`, :tacn:`elim` and :tacn:`case`, the terms have to @@ -105,6 +110,350 @@ bindings_list`` where ``bindings_list`` may be of two different forms: .. exn:: Not the right number of missing arguments. :undocumented: +.. _intropatterns: + +Intro patterns +~~~~~~~~~~~~~~ + +Intro patterns let you specify the name to assign to variables and hypotheses +introduced by tactics. They also let you split an introduced hypothesis into +multiple hypotheses or subgoals. Common tactics that accept intro patterns +include :tacn:`assert`, :tacn:`intros` and :tacn:`destruct`. + +.. productionlist:: coq + intropattern_list : `intropattern` ... `intropattern` + : `empty` + empty : + intropattern : * + : ** + : `simple_intropattern` + simple_intropattern : `simple_intropattern_closed` [ % `term` ... % `term` ] + simple_intropattern_closed : `naming_intropattern` + : _ + : `or_and_intropattern` + : `equality_intropattern` + naming_intropattern : `ident` + : ? + : ?`ident` + or_and_intropattern : [ `intropattern_list` | ... | `intropattern_list` ] + : ( `simple_intropattern` , ... , `simple_intropattern` ) + : ( `simple_intropattern` & ... & `simple_intropattern` ) + equality_intropattern : -> + : <- + : [= `intropattern_list` ] + or_and_intropattern_loc : `or_and_intropattern` + : `ident` + +Note that the intro pattern syntax varies between tactics. +Most tactics use :n:`@simple_intropattern` in the grammar. +:tacn:`destruct`, :tacn:`edestruct`, :tacn:`induction`, +:tacn:`einduction`, :tacn:`case`, :tacn:`ecase` and the various +:tacn:`inversion` tactics use :n:`@or_and_intropattern_loc`, while +:tacn:`intros` and :tacn:`eintros` use :n:`@intropattern_list`. +The :n:`eqn:` construct in various tactics uses :n:`@naming_intropattern`. + +**Naming patterns** + +Use these elementary patterns to specify a name: + +* :n:`@ident` - use the specified name +* :n:`?` - let Coq choose a name +* :n:`?@ident` - generate a name that begins with :n:`@ident` +* :n:`_` - discard the matched part (unless it is required for another + hypothesis) +* if a disjunction pattern omits a name, such as :g:`[|H2]`, Coq will choose a name + +**Splitting patterns** + +The most common splitting patterns are: + +* split a hypothesis in the form :n:`A /\ B` into two + hypotheses :g:`H1: A` and :g:`H2: B` using the pattern :g:`(H1 & H2)` or + :g:`(H1, H2)` or :g:`[H1 H2]`. + :ref:`Example <intropattern_conj_ex>`. This also works on :n:`A <-> B`, which + is just a notation representing :n:`(A -> B) /\ (B -> A)`. +* split a hypothesis in the form :g:`A \/ B` into two + subgoals using the pattern :g:`[H1|H2]`. The first subgoal will have the hypothesis + :g:`H1: A` and the second subgoal will have the hypothesis :g:`H2: B`. + :ref:`Example <intropattern_disj_ex>` +* split a hypothesis in either of the forms :g:`A /\ B` or :g:`A \/ B` using the pattern :g:`[]`. + +Patterns can be nested: :n:`[[Ha|Hb] H]` can be used to split :n:`(A \/ B) /\ C`. + +Note that there is no equivalent to intro patterns for goals. For a goal :g:`A /\ B`, +use the :tacn:`split` tactic to replace the current goal with subgoals :g:`A` and :g:`B`. +For a goal :g:`A \/ B`, use :tacn:`left` to replace the current goal with :g:`A`, or +:tacn:`right` to replace the current goal with :g:`B`. + +* :n:`( {+, @simple_intropattern}` ) - matches + a product over an inductive type with a + :ref:`single constructor <intropattern_cons_note>`. + If the number of patterns + equals the number of constructor arguments, then it applies the patterns only to + the arguments, and + :n:`( {+, @simple_intropattern} )` is equivalent to :n:`[{+ @simple_intropattern}]`. + If the number of patterns equals the number of constructor arguments plus the number + of :n:`let-ins`, the patterns are applied to the arguments and :n:`let-in` variables. + +* :n:`( {+& @simple_intropattern} )` - matches a right-hand nested term that consists + of one or more nested binary inductive types such as :g:`a1 OP1 a2 OP2 ...` + (where the :g:`OPn` are right-associative). + (If the :g:`OPn` are left-associative, additional parentheses will be needed to make the + term right-hand nested, such as :g:`a1 OP1 (a2 OP2 ...)`.) + The splitting pattern can have more than 2 names, for example :g:`(H1 & H2 & H3)` + matches :g:`A /\ B /\ C`. + The inductive types must have a + :ref:`single constructor with two parameters <intropattern_cons_note>`. + :ref:`Example <intropattern_ampersand_ex>` + +* :n:`[ {+| @intropattern_list} ]` - splits an inductive type that has + :ref:`multiple constructors <intropattern_cons_note>` + such as :n:`A \/ B` + into multiple subgoals. The number of :token:`intropattern_list` must be the same as the number of + constructors for the matched part. +* :n:`[ {+ @intropattern} ]` - splits an inductive type that has a + :ref:`single constructor with multiple parameters <intropattern_cons_note>` + such as :n:`A /\ B` into multiple hypotheses. Use :n:`[H1 [H2 H3]]` to match :g:`A /\ B /\ C`. +* :n:`[]` - splits an inductive type: If the inductive + type has multiple constructors, such as :n:`A \/ B`, + create one subgoal for each constructor. If the inductive type has a single constructor with + multiple parameters, such as :n:`A /\ B`, split it into multiple hypotheses. + +**Equality patterns** + +These patterns can be used when the hypothesis is an equality: + +* :n:`->` - replaces the right-hand side of the hypothesis with the left-hand + side of the hypothesis in the conclusion of the goal; the hypothesis is + cleared; if the left-hand side of the hypothesis is a variable, it is + substituted everywhere in the context and the variable is removed. + :ref:`Example <intropattern_rarrow_ex>` +* :n:`<-` - similar to :n:`->`, but replaces the left-hand side of the hypothesis + with the right-hand side of the hypothesis. +* :n:`[= {*, @intropattern} ]` - If the product is over an equality type, + applies either :tacn:`injection` or :tacn:`discriminate`. + If :tacn:`injection` is applicable, the intropattern + is used on the hypotheses generated by :tacn:`injection`. If the + number of patterns is smaller than the number of hypotheses generated, the + pattern :n:`?` is used to complete the list. + :ref:`Example <intropattern_inj_discr_ex>` + +**Other patterns** + +* :n:`*` - introduces one or more quantified variables from the result + until there are no more quantified variables. + :ref:`Example <intropattern_star_ex>` + +* :n:`**` - introduces one or more quantified variables or hypotheses from the result until there are + no more quantified variables or implications (:g:`->`). :g:`intros **` is equivalent + to :g:`intros`. + :ref:`Example <intropattern_2stars_ex>` + +* :n:`@simple_intropattern_closed {* % @term}` - first applies each of the terms + with the :tacn:`apply ... in` tactic on the hypothesis to be introduced, then it uses + :n:`@simple_intropattern_closed`. + :ref:`Example <intropattern_injection_ex>` + +.. flag:: Bracketing Last Introduction Pattern + + For :n:`intros @intropattern_list`, controls how to handle a + conjunctive pattern that doesn't give enough simple patterns to match + all the arguments in the constructor. If set (the default), |Coq| generates + additional names to match the number of arguments. + Unsetting the option will put the additional hypotheses in the goal instead, behavior that is more + similar to |SSR|'s intro patterns. + + .. deprecated:: 8.10 + +.. _intropattern_cons_note: + +.. note:: + + :n:`A \/ B` and :n:`A /\ B` use infix notation to refer to the inductive + types :n:`or` and :n:`and`. + :n:`or` has multiple constructors (:n:`or_introl` and :n:`or_intror`), + while :n:`and` has a single constructor (:n:`conj`) with multiple parameters + (:n:`A` and :n:`B`). + These are defined in theories/Init/Logic.v. The "where" clauses define the + infix notation for "or" and "and". + + .. coqdoc:: + + Inductive or (A B:Prop) : Prop := + | or_introl : A -> A \/ B + | or_intror : B -> A \/ B + where "A \/ B" := (or A B) : type_scope. + + Inductive and (A B:Prop) : Prop := + conj : A -> B -> A /\ B + where "A /\ B" := (and A B) : type_scope. + +.. note:: + + :n:`intros {+ p}` is not always equivalent to :n:`intros p; ... ; intros p` + if some of the :n:`p` are :g:`_`. In the first form, all erasures are done + at once, while they're done sequentially for each tactic in the second form. + If the second matched term depends on the first matched term and the pattern + for both is :g:`_` (i.e., both will be erased), the first :n:`intros` in the second + form will fail because the second matched term still has the dependency on the first. + +Examples: + +.. _intropattern_conj_ex: + + .. example:: intro pattern for /\\ + + .. coqtop:: reset none + + Goal forall (A: Prop) (B: Prop), (A /\ B) -> True. + + .. coqtop:: out + + intros. + + .. coqtop:: all + + destruct H as (HA & HB). + +.. _intropattern_disj_ex: + + .. example:: intro pattern for \\/ + + .. coqtop:: reset none + + Goal forall (A: Prop) (B: Prop), (A \/ B) -> True. + + .. coqtop:: out + + intros. + + .. coqtop:: all + + destruct H as [HA|HB]. all: swap 1 2. + +.. _intropattern_rarrow_ex: + + .. example:: -> intro pattern + + .. coqtop:: reset none + + Goal forall (x:nat) (y:nat) (z:nat), (x = y) -> (y = z) -> (x = z). + + .. coqtop:: out + + intros * H. + + .. coqtop:: all + + intros ->. + +.. _intropattern_inj_discr_ex: + + .. example:: [=] intro pattern + + The first :n:`intros [=]` uses :tacn:`injection` to strip :n:`(S ...)` from + both sides of the matched equality. The second uses :tacn:`discriminate` on + the contradiction :n:`1 = 2` (internally represented as :n:`(S O) = (S (S O))`) + to complete the goal. + + .. coqtop:: reset none + + Goal forall (n m:nat), (S n) = (S m) -> (S O)=(S (S O)) -> False. + + .. coqtop:: out + + intros *. + + .. coqtop:: all + + intros [= H]. + + .. coqtop:: all + + intros [=]. + +.. _intropattern_ampersand_ex: + + .. example:: (A & B & ...) intro pattern + + .. coqtop:: reset none + + Variables (A : Prop) (B: nat -> Prop) (C: Prop). + + .. coqtop:: out + + Goal A /\ (exists x:nat, B x /\ C) -> True. + + .. coqtop:: all + + intros (a & x & b & c). + +.. _intropattern_star_ex: + + .. example:: * intro pattern + + .. coqtop:: reset out + + Goal forall (A: Prop) (B: Prop), A -> B. + + .. coqtop:: all + + intros *. + +.. _intropattern_2stars_ex: + + .. example:: ** pattern ("intros \**" is equivalent to "intros") + + .. coqtop:: reset out + + Goal forall (A: Prop) (B: Prop), A -> B. + + .. coqtop:: all + + intros **. + + .. example:: compound intro pattern + + .. coqtop:: reset out + + Goal forall A B C:Prop, A \/ B /\ C -> (A -> C) -> C. + + .. coqtop:: all + + intros * [a | (_,c)] f. + all: swap 1 2. + +.. _intropattern_injection_ex: + + .. example:: combined intro pattern using [=] -> and % + + .. coqtop:: reset none + + Require Import Coq.Lists.List. + Section IntroPatterns. + Variables (A : Type) (xs ys : list A). + + .. coqtop:: out + + Example ThreeIntroPatternsCombined : + S (length ys) = 1 -> xs ++ ys = xs. + + .. coqtop:: all + + intros [=->%length_zero_iff_nil]. + + * `intros` would add :g:`H : S (length ys) = 1` + * `intros [=]` would additionally apply :tacn:`injection` to :g:`H` to yield :g:`H0 : length ys = 0` + * `intros [=->%length_zero_iff_nil]` applies the theorem, making H the equality :g:`l=nil`, + which is then applied as for :g:`->`. + + .. coqdoc:: + + Theorem length_zero_iff_nil (l : list A): + length l = 0 <-> l=nil. + + The example is based on `Tej Chajed's coq-tricks <https://github.com/tchajed/coq-tricks/blob/8e6efe4971ed828ac8bdb5512c1f615d7d62691e/src/IntroPatterns.v>`_ + .. _occurrencessets: Occurrence sets and occurrence clauses @@ -113,11 +462,11 @@ Occurrence sets and occurrence clauses An occurrence clause is a modifier to some tactics that obeys the following syntax: - .. productionlist:: `sentence` + .. productionlist:: sentence occurrence_clause : in `goal_occurrences` - goal_occurrences : [`ident` [`at_occurrences`], ... , ident [`at_occurrences`] [|- [* [`at_occurrences`]]]] - :| * |- [* [`at_occurrences`]] - :| * + goal_occurrences : [`ident` [`at_occurrences`], ... , `ident` [`at_occurrences`] [|- [* [`at_occurrences`]]]] + : * |- [* [`at_occurrences`]] + : * at_occurrences : at `occurrences` occurrences : [-] `num` ... `num` @@ -508,10 +857,10 @@ Applying theorems This works as :tacn:`apply ... in` but turns unresolved bindings into existential variables, if any, instead of failing. - .. tacv:: apply {+, @term {? with @bindings_list } } in @ident as @intro_pattern + .. tacv:: apply {+, @term {? with @bindings_list } } in @ident as @simple_intropattern :name: apply ... in ... as - This works as :tacn:`apply ... in` then applies the :token:`intro_pattern` + This works as :tacn:`apply ... in` then applies the :token:`simple_intropattern` to the hypothesis :token:`ident`. .. tacv:: simple apply @term in @ident @@ -525,8 +874,8 @@ Applying theorems Tactic :n:`simple apply @term in @ident` does not either traverse tuples as :n:`apply @term in @ident` does. - .. tacv:: {? simple} apply {+, @term {? with @bindings_list}} in @ident {? as @intro_pattern} - {? simple} eapply {+, @term {? with @bindings_list}} in @ident {? as @intro_pattern} + .. tacv:: {? simple} apply {+, @term {? with @bindings_list}} in @ident {? as @simple_intropattern} + {? simple} eapply {+, @term {? with @bindings_list}} in @ident {? as @simple_intropattern} This summarizes the different syntactic variants of :n:`apply @term in @ident` and :n:`eapply @term in @ident`. @@ -726,149 +1075,17 @@ Managing the local context .. exn:: No such hypothesis: @ident. :undocumented: -.. tacn:: intros @intro_pattern_list +.. tacn:: intros @intropattern_list :name: intros ... - This extension of the tactic :n:`intros` allows to apply tactics on the fly - on the variables or hypotheses which have been introduced. An - *introduction pattern list* :n:`@intro_pattern_list` is a list of - introduction patterns possibly containing the filling introduction - patterns `*` and `**`. An *introduction pattern* is either: - - + a *naming introduction pattern*, i.e. either one of: - - + the pattern :n:`?` - - + the pattern :n:`?ident` - - + an identifier - - + an *action introduction pattern* which itself classifies into: - - + a *disjunctive/conjunctive introduction pattern*, i.e. either one of - - + a disjunction of lists of patterns - :n:`[@intro_pattern_list | ... | @intro_pattern_list]` - - + a conjunction of patterns: :n:`({+, p})` - - + a list of patterns - :n:`({+& p})` - for sequence of right-associative binary constructs - - + an *equality introduction pattern*, i.e. either one of: - - + a pattern for decomposing an equality: :n:`[= {+ p}]` - + the rewriting orientations: :n:`->` or :n:`<-` - - + the on-the-fly application of lemmas: :n:`p{+ %term}` where :n:`p` - itself is not a pattern for on-the-fly application of lemmas (note: - syntax is in experimental stage) - - + the wildcard: :n:`_` - - - Assuming a goal of type :g:`Q → P` (non-dependent product), or of type - :g:`forall x:T, P` (dependent product), the behavior of - :n:`intros p` is defined inductively over the structure of the introduction - pattern :n:`p`: - - Introduction on :n:`?` performs the introduction, and lets Coq choose a fresh - name for the variable; - - Introduction on :n:`?@ident` performs the introduction, and lets Coq choose a - fresh name for the variable based on :n:`@ident`; - - Introduction on :n:`@ident` behaves as described in :tacn:`intro` - - Introduction over a disjunction of list of patterns - :n:`[@intro_pattern_list | ... | @intro_pattern_list ]` expects the product - to be over an inductive type whose number of constructors is `n` (or more - generally over a type of conclusion an inductive type built from `n` - constructors, e.g. :g:`C -> A\/B` with `n=2` since :g:`A\/B` has `2` - constructors): it destructs the introduced hypothesis as :n:`destruct` (see - :tacn:`destruct`) would and applies on each generated subgoal the - corresponding tactic; - - The introduction patterns in :n:`@intro_pattern_list` are expected to consume - no more than the number of arguments of the `i`-th constructor. If it - consumes less, then Coq completes the pattern so that all the arguments of - the constructors of the inductive type are introduced (for instance, the - list of patterns :n:`[ | ] H` applied on goal :g:`forall x:nat, x=0 -> 0=x` - behaves the same as the list of patterns :n:`[ | ? ] H`); - - Introduction over a conjunction of patterns :n:`({+, p})` expects - the goal to be a product over an inductive type :g:`I` with a single - constructor that itself has at least `n` arguments: It performs a case - analysis over the hypothesis, as :n:`destruct` would, and applies the - patterns :n:`{+ p}` to the arguments of the constructor of :g:`I` (observe - that :n:`({+ p})` is an alternative notation for :n:`[{+ p}]`); - - Introduction via :n:`({+& p})` is a shortcut for introduction via - :n:`(p,( ... ,( ..., p ) ... ))`; it expects the hypothesis to be a sequence of - right-associative binary inductive constructors such as :g:`conj` or - :g:`ex_intro`; for instance, a hypothesis with type - :g:`A /\(exists x, B /\ C /\ D)` can be introduced via pattern - :n:`(a & x & b & c & d)`; - - If the product is over an equality type, then a pattern of the form - :n:`[= {+ p}]` applies either :tacn:`injection` or :tacn:`discriminate` - instead of :tacn:`destruct`; if :tacn:`injection` is applicable, the patterns - :n:`{+, p}` are used on the hypotheses generated by :tacn:`injection`; if the - number of patterns is smaller than the number of hypotheses generated, the - pattern :n:`?` is used to complete the list. - - Introduction over ``->`` (respectively over ``<-``) - expects the hypothesis to be an equality and the right-hand-side - (respectively the left-hand-side) is replaced by the left-hand-side - (respectively the right-hand-side) in the conclusion of the goal; - the hypothesis itself is erased; if the term to substitute is a variable, it - is substituted also in the context of goal and the variable is removed too. - - Introduction over a pattern :n:`p{+ %term}` first applies :n:`{+ term}` - on the hypothesis to be introduced (as in :n:`apply {+, term}`) prior to the - application of the introduction pattern :n:`p`; - - Introduction on the wildcard depends on whether the product is dependent or not: - in the non-dependent case, it erases the corresponding hypothesis (i.e. it - behaves as an :tacn:`intro` followed by a :tacn:`clear`) while in the - dependent case, it succeeds and erases the variable only if the wildcard is part - of a more complex list of introduction patterns that also erases the hypotheses - depending on this variable; - - Introduction over :n:`*` introduces all forthcoming quantified variables - appearing in a row; introduction over :n:`**` introduces all forthcoming - quantified variables or hypotheses until the goal is not any more a - quantification or an implication. - - .. example:: - - .. coqtop:: reset all - - Goal forall A B C:Prop, A \/ B /\ C -> (A -> C) -> C. - intros * [a | (_,c)] f. - -.. note:: - - :n:`intros {+ p}` is not equivalent to :n:`intros p; ... ; intros p` - for the following reason: If one of the :n:`p` is a wildcard pattern, it - might succeed in the first case because the further hypotheses it - depends on are eventually erased too while it might fail in the second - case because of dependencies in hypotheses which are not yet - introduced (and a fortiori not yet erased). - -.. note:: - - In :n:`intros @intro_pattern_list`, if the last introduction pattern - is a disjunctive or conjunctive pattern - :n:`[{+| @intro_pattern_list}]`, the completion of :n:`@intro_pattern_list` - so that all the arguments of the i-th constructors of the corresponding - inductive type are introduced can be controlled with the following option: + Introduces one or more variables or hypotheses from the goal by matching the + intro patterns. See the description in :ref:`intropatterns`. - .. flag:: Bracketing Last Introduction Pattern +.. tacn:: eintros @intropattern_list + :name: eintros - Force completion, if needed, when the last introduction pattern is a - disjunctive or conjunctive pattern (on by default). + Works just like :tacn:`intros ...` except that it creates existential variables + for any unresolved variables rather than failing. .. tacn:: clear @ident :name: clear @@ -1057,19 +1274,19 @@ Managing the local context used as a synonym of :tacn:`epose`, i.e. when the :token:`term` does not occur in the goal. -.. tacn:: remember @term as @ident__1 {? eqn:@ident__2 } +.. tacn:: remember @term as @ident__1 {? eqn:@naming_intropattern } :name: remember - This behaves as :n:`set (@ident__1 := @term) in *`, using a logical + This behaves as :n:`set (@ident := @term) in *`, using a logical (Leibniz’s) equality instead of a local definition. - If :n:`@ident__2` is provided, it will be the name of the new equation. + Use :n:`@naming_intropattern` to name or split up the new equation. - .. tacv:: remember @term as @ident__1 {? eqn:@ident__2 } in @goal_occurrences + .. tacv:: remember @term as @ident__1 {? eqn:@naming_intropattern } in @goal_occurrences This is a more general form of :tacn:`remember` that remembers the occurrences of :token:`term` specified by an occurrence set. - .. tacv:: eremember @term as @ident__1 {? eqn:@ident__2 } {? in @goal_occurrences } + .. tacv:: eremember @term as @ident__1 {? eqn:@naming_intropattern } {? in @goal_occurrences } :name: eremember While the different variants of :tacn:`remember` expect that no @@ -1163,16 +1380,16 @@ Controlling the proof flow :name: Proof is not complete. (assert) :undocumented: - .. tacv:: assert @type as @intro_pattern + .. tacv:: assert @type as @simple_intropattern - If :n:`intro_pattern` is a naming introduction pattern (see :tacn:`intro`), + If :n:`simple_intropattern` is an intro pattern (see :ref:`intropatterns`), the hypothesis is named after this introduction pattern (in particular, if - :n:`intro_pattern` is :n:`@ident`, the tactic behaves like - :n:`assert (@ident : @type)`). If :n:`intro_pattern` is an action + :n:`simple_intropattern` is :n:`@ident`, the tactic behaves like + :n:`assert (@ident : @type)`). If :n:`simple_intropattern` is an action introduction pattern, the tactic behaves like :n:`assert @type` followed by the action done by this introduction pattern. - .. tacv:: assert @type as @intro_pattern by @tactic + .. tacv:: assert @type as @simple_intropattern by @tactic This combines the two previous variants of :tacn:`assert`. @@ -1186,7 +1403,7 @@ Controlling the proof flow .. exn:: Variable @ident is already declared. :undocumented: -.. tacv:: eassert @type as @intro_pattern by @tactic +.. tacv:: eassert @type as @simple_intropattern by @tactic :name: eassert While the different variants of :tacn:`assert` expect that no existential @@ -1194,16 +1411,16 @@ Controlling the proof flow This allows not to specify the asserted statement completeley before starting to prove it. -.. tacv:: pose proof @term {? as @intro_pattern} +.. tacv:: pose proof @term {? as @simple_intropattern} :name: pose proof - This tactic behaves like :n:`assert @type {? as @intro_pattern} by exact @term` + This tactic behaves like :n:`assert @type {? as @simple_intropattern} by exact @term` where :token:`type` is the type of :token:`term`. In particular, :n:`pose proof @term as @ident` behaves as :n:`assert (@ident := @term)` - and :n:`pose proof @term as @intro_pattern` is the same as applying the - :token:`intro_pattern` to :token:`term`. + and :n:`pose proof @term as @simple_intropattern` is the same as applying the + :token:`simple_intropattern` to :token:`term`. -.. tacv:: epose proof @term {? as @intro_pattern} +.. tacv:: epose proof @term {? as @simple_intropattern} :name: epose proof While :tacn:`pose proof` expects that no existential variables are generated by @@ -1221,20 +1438,20 @@ Controlling the proof flow This behaves like :n:`enough (@ident : @type)` with the name :token:`ident` of the hypothesis generated by Coq. -.. tacv:: enough @type as @intro_pattern +.. tacv:: enough @type as @simple_intropattern - This behaves like :n:`enough @type` using :token:`intro_pattern` to name or + This behaves like :n:`enough @type` using :token:`simple_intropattern` to name or destruct the new hypothesis. .. tacv:: enough (@ident : @type) by @tactic - enough @type {? as @intro_pattern } by @tactic + enough @type {? as @simple_intropattern } by @tactic This behaves as above but with :token:`tactic` expected to solve the initial goal after the extra assumption :token:`type` is added and possibly destructed. If the - :n:`as @intro_pattern` clause generates more than one subgoal, :token:`tactic` is + :n:`as @simple_intropattern` clause generates more than one subgoal, :token:`tactic` is applied to all of them. -.. tacv:: eenough @type {? as @intro_pattern } {? by @tactic } +.. tacv:: eenough @type {? as @simple_intropattern } {? by @tactic } eenough (@ident : @type) {? by @tactic } :name: eenough; _ @@ -1250,8 +1467,8 @@ Controlling the proof flow subgoals: :g:`U -> T` and :g:`U`. The subgoal :g:`U -> T` comes first in the list of remaining subgoal to prove. -.. tacv:: specialize (@ident {* @term}) {? as @intro_pattern} - specialize @ident with @bindings_list {? as @intro_pattern} +.. tacv:: specialize (@ident {* @term}) {? as @simple_intropattern} + specialize @ident with @bindings_list {? as @simple_intropattern} :name: specialize; _ This tactic works on local hypothesis :n:`@ident`. The @@ -1264,7 +1481,7 @@ Controlling the proof flow uninstantiated arguments are inferred by unification if possible or left quantified in the hypothesis otherwise. With the :n:`as` clause, the local hypothesis :n:`@ident` is left unchanged and instead, the modified hypothesis - is introduced as specified by the :token:`intro_pattern`. The name :n:`@ident` + is introduced as specified by the :token:`simple_intropattern`. The name :n:`@ident` can also refer to a global lemma or hypothesis. In this case, for compatibility reasons, the behavior of :tacn:`specialize` is close to that of :tacn:`generalize`: the instantiated statement becomes an additional premise of @@ -1477,11 +1694,11 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) This is a shortcut for :n:`destruct @term; ...; destruct @term`. - .. tacv:: destruct @term as @disj_conj_intro_pattern + .. tacv:: destruct @term as @or_and_intropattern_loc This behaves as :n:`destruct @term` but uses the names - in :token:`disj_conj_intro_pattern` to name the variables introduced in the - context. The :token:`disj_conj_intro_pattern` must have the + in :token:`or_and_intropattern_loc` to name the variables introduced in the + context. The :token:`or_and_intropattern_loc` must have the form :n:`[p11 ... p1n | ... | pm1 ... pmn ]` with ``m`` being the number of constructors of the type of :token:`term`. Each variable introduced by :tacn:`destruct` in the context of the ``i``-th goal @@ -1491,13 +1708,13 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) pattern (see :tacn:`intros`). This provides a concise notation for chaining destruction of a hypothesis. - .. tacv:: destruct @term eqn:@naming_intro_pattern + .. tacv:: destruct @term eqn:@naming_intropattern :name: destruct ... eqn: This behaves as :n:`destruct @term` but adds an equation between :token:`term` and the value that it takes in each of the possible cases. The name of the equation is specified - by :token:`naming_intro_pattern` (see :tacn:`intros`), + by :token:`naming_intropattern` (see :tacn:`intros`), in particular ``?`` can be used to let Coq generate a fresh name. .. tacv:: destruct @term with @bindings_list @@ -1525,8 +1742,8 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) clause is an occurrence clause whose syntax and behavior is described in :ref:`occurrences sets <occurrencessets>`. - .. tacv:: destruct @term {? with @bindings_list } {? as @disj_conj_intro_pattern } {? eqn:@naming_intro_pattern } {? using @term {? with @bindings_list } } {? in @goal_occurrences } - edestruct @term {? with @bindings_list } {? as @disj_conj_intro_pattern } {? eqn:@naming_intro_pattern } {? using @term {? with @bindings_list } } {? in @goal_occurrences } + .. tacv:: destruct @term {? with @bindings_list } {? as @or_and_intropattern_loc } {? eqn:@naming_intropattern } {? using @term {? with @bindings_list } } {? in @goal_occurrences } + edestruct @term {? with @bindings_list } {? as @or_and_intropattern_loc } {? eqn:@naming_intropattern } {? using @term {? with @bindings_list } } {? in @goal_occurrences } These are the general forms of :tacn:`destruct` and :tacn:`edestruct`. They combine the effects of the ``with``, ``as``, ``eqn:``, ``using``, @@ -1622,11 +1839,11 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) Use in this case the variant :tacn:`elim ... with` below. -.. tacv:: induction @term as @disj_conj_intro_pattern +.. tacv:: induction @term as @or_and_intropattern_loc This behaves as :tacn:`induction` but uses the names in - :n:`@disj_conj_intro_pattern` to name the variables introduced in the - context. The :n:`@disj_conj_intro_pattern` must typically be of the form + :n:`@or_and_intropattern_loc` to name the variables introduced in the + context. The :n:`@or_and_intropattern_loc` must typically be of the form :n:`[ p` :sub:`11` :n:`... p` :sub:`1n` :n:`| ... | p`:sub:`m1` :n:`... p`:sub:`mn` :n:`]` with :n:`m` being the number of constructors of the type of :n:`@term`. Each variable introduced by induction in the context of the i-th goal gets its @@ -1686,8 +1903,8 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) induction y in x |- *. Show 2. -.. tacv:: induction @term with @bindings_list as @disj_conj_intro_pattern using @term with @bindings_list in @goal_occurrences - einduction @term with @bindings_list as @disj_conj_intro_pattern using @term with @bindings_list in @goal_occurrences +.. tacv:: induction @term with @bindings_list as @or_and_intropattern_loc using @term with @bindings_list in @goal_occurrences + einduction @term with @bindings_list as @or_and_intropattern_loc using @term with @bindings_list in @goal_occurrences These are the most general forms of :tacn:`induction` and :tacn:`einduction`. It combines the effects of the with, as, using, and in clauses. @@ -1898,7 +2115,7 @@ and an explanation of the underlying technique. .. exn:: Not the right number of induction arguments. :undocumented: -.. tacv:: functional induction (@qualid {+ @term}) as @disj_conj_intro_pattern using @term with @bindings_list +.. tacv:: functional induction (@qualid {+ @term}) as @simple_intropattern using @term with @bindings_list Similarly to :tacn:`induction` and :tacn:`elim`, this allows giving explicitly the name of the introduced variables, the induction principle, and @@ -2053,18 +2270,18 @@ and an explanation of the underlying technique. .. exn:: goal does not satisfy the expected preconditions. :undocumented: - .. tacv:: injection @term {? with @bindings_list} as {+ @intro_pattern} - injection @num as {+ intro_pattern} - injection as {+ intro_pattern} - einjection @term {? with @bindings_list} as {+ intro_pattern} - einjection @num as {+ intro_pattern} - einjection as {+ intro_pattern} + .. tacv:: injection @term {? with @bindings_list} as {+ @simple_intropattern} + injection @num as {+ simple_intropattern} + injection as {+ simple_intropattern} + einjection @term {? with @bindings_list} as {+ simple_intropattern} + einjection @num as {+ simple_intropattern} + einjection as {+ simple_intropattern} - These variants apply :n:`intros {+ @intro_pattern}` after the call to + These variants apply :n:`intros {+ @simple_intropattern}` after the call to :tacn:`injection` or :tacn:`einjection` so that all equalities generated are moved in - the context of hypotheses. The number of :n:`@intro_pattern` must not exceed + the context of hypotheses. The number of :n:`@simple_intropattern` must not exceed the number of equalities newly generated. If it is smaller, fresh - names are automatically generated to adjust the list of :n:`@intro_pattern` + names are automatically generated to adjust the list of :n:`@simple_intropattern` to the number of new equalities. The original equality is erased if it corresponds to a hypothesis. @@ -2118,10 +2335,10 @@ and an explanation of the underlying technique. This behaves as :n:`inversion` and then erases :n:`@ident` from the context. -.. tacv:: inversion @ident as @intro_pattern +.. tacv:: inversion @ident as @or_and_intropattern_loc - This generally behaves as inversion but using names in :n:`@intro_pattern` - for naming hypotheses. The :n:`@intro_pattern` must have the form + This generally behaves as inversion but using names in :n:`@or_and_intropattern_loc` + for naming hypotheses. The :n:`@or_and_intropattern_loc` must have the form :n:`[p`:sub:`11` :n:`... p`:sub:`1n` :n:`| ... | p`:sub:`m1` :n:`... p`:sub:`mn` :n:`]` with `m` being the number of constructors of the type of :n:`@ident`. Be careful that the list must be of length `m` even if ``inversion`` discards @@ -2153,12 +2370,12 @@ and an explanation of the underlying technique. Goal forall l:list nat, contains0 (1 :: l) -> contains0 l. intros l H; inversion H as [ | l' p Hl' [Heqp Heql'] ]. -.. tacv:: inversion @num as @intro_pattern +.. tacv:: inversion @num as @or_and_intropattern_loc This allows naming the hypotheses introduced by :n:`inversion @num` in the context. -.. tacv:: inversion_clear @ident as @intro_pattern +.. tacv:: inversion_clear @ident as @or_and_intropattern_loc This allows naming the hypotheses introduced by ``inversion_clear`` in the context. Notice that hypothesis names can be provided as if ``inversion`` @@ -2170,7 +2387,7 @@ and an explanation of the underlying technique. Let :n:`{+ @ident}` be identifiers in the local context. This tactic behaves as generalizing :n:`{+ @ident}`, and then performing ``inversion``. -.. tacv:: inversion @ident as @intro_pattern in {+ @ident} +.. tacv:: inversion @ident as @or_and_intropattern_loc in {+ @ident} This allows naming the hypotheses introduced in the context by :n:`inversion @ident in {+ @ident}`. @@ -2180,7 +2397,7 @@ and an explanation of the underlying technique. Let :n:`{+ @ident}` be identifiers in the local context. This tactic behaves as generalizing :n:`{+ @ident}`, and then performing ``inversion_clear``. -.. tacv:: inversion_clear @ident as @intro_pattern in {+ @ident} +.. tacv:: inversion_clear @ident as @or_and_intropattern_loc in {+ @ident} This allows naming the hypotheses introduced in the context by :n:`inversion_clear @ident in {+ @ident}`. @@ -2192,7 +2409,7 @@ and an explanation of the underlying technique. ``inversion`` and then substitutes :n:`@ident` for the corresponding :n:`@@term` in the goal. -.. tacv:: dependent inversion @ident as @intro_pattern +.. tacv:: dependent inversion @ident as @or_and_intropattern_loc This allows naming the hypotheses introduced in the context by :n:`dependent inversion @ident`. @@ -2202,7 +2419,7 @@ and an explanation of the underlying technique. Like ``dependent inversion``, except that :n:`@ident` is cleared from the local context. -.. tacv:: dependent inversion_clear @ident as @intro_pattern +.. tacv:: dependent inversion_clear @ident as @or_and_intropattern_loc This allows naming the hypotheses introduced in the context by :n:`dependent inversion_clear @ident`. @@ -2216,7 +2433,7 @@ and an explanation of the underlying technique. then :n:`@term` must be of type :g:`I:forall (x:T), I x -> s'` where :g:`s'` is the type of the goal. -.. tacv:: dependent inversion @ident as @intro_pattern with @term +.. tacv:: dependent inversion @ident as @or_and_intropattern_loc with @term This allows naming the hypotheses introduced in the context by :n:`dependent inversion @ident with @term`. @@ -2226,7 +2443,7 @@ and an explanation of the underlying technique. Like :tacn:`dependent inversion ... with ...` with but clears :n:`@ident` from the local context. -.. tacv:: dependent inversion_clear @ident as @intro_pattern with @term +.. tacv:: dependent inversion_clear @ident as @or_and_intropattern_loc with @term This allows naming the hypotheses introduced in the context by :n:`dependent inversion_clear @ident with @term`. @@ -2237,7 +2454,7 @@ and an explanation of the underlying technique. It is a very primitive inversion tactic that derives all the necessary equalities but it does not simplify the constraints as ``inversion`` does. -.. tacv:: simple inversion @ident as @intro_pattern +.. tacv:: simple inversion @ident as @or_and_intropattern_loc This allows naming the hypotheses introduced in the context by ``simple inversion``. @@ -3171,7 +3388,7 @@ Automation :name: auto This tactic implements a Prolog-like resolution procedure to solve the - current goal. It first tries to solve the goal using the assumption + current goal. It first tries to solve the goal using the :tacn:`assumption` tactic, then it reduces the goal to an atomic one using intros and introduces the newly generated hypotheses as hints. Then it looks at the list of tactics associated to the head symbol of the goal and @@ -3586,15 +3803,15 @@ The general command to add a hint to some databases :n:`{+ @ident}` is the following. Beware, there is no operator precedence during parsing, one can check with :cmd:`Print HintDb` to verify the current cut expression: - .. productionlist:: `regexp` - e : ident hint or instance identifier - :| _ any hint - :| e\|e′ disjunction - :| e e′ sequence - :| e * Kleene star - :| emp empty - :| eps epsilon - :| ( e ) + .. productionlist:: regexp + e : `ident` hint or instance identifier + : _ any hint + : `e` | `e` disjunction + : `e` `e` sequence + : `e` * Kleene star + : emp empty + : eps epsilon + : ( `e` ) The `emp` regexp does not match any search path while `eps` matches the empty path. During proof search, the path of @@ -4299,15 +4516,15 @@ Automating .. _btauto_grammar: - .. productionlist:: `sentence` - t : x - :∣ true - :∣ false - :∣ orb t1 t2 - :∣ andb t1 t2 - :∣ xorb t1 t2 - :∣ negb t - :∣ if t1 then t2 else t3 + .. productionlist:: sentence + t : `x` + : true + : false + : orb `t` `t` + : andb `t` `t` + : xorb `t` `t` + : negb `t` + : if `t` then `t` else `t` Whenever the formula supplied is not a tautology, it also provides a counter-example. @@ -4343,7 +4560,7 @@ Automating distributivity, constant propagation) and comparing syntactically the results. -.. tacn:: ring_simplify {+ @term} +.. tacn:: ring_simplify {* @term} :name: ring_simplify This tactic applies the normalization procedure described above to @@ -4357,7 +4574,7 @@ the tactic and how to declare new ring structures. All declared field structures can be printed with the ``Print Rings`` command. .. tacn:: field - field_simplify {+ @term} + field_simplify {* @term} field_simplify_eq :name: field; field_simplify; field_simplify_eq diff --git a/doc/sphinx/refman-preamble.sty b/doc/sphinx/refman-preamble.sty index b4fc608e47..8f7b1bb1e8 100644 --- a/doc/sphinx/refman-preamble.sty +++ b/doc/sphinx/refman-preamble.sty @@ -56,27 +56,29 @@ \newcommand{\oddS}{\textsf{odd}_\textsf{S}} \newcommand{\ovl}[1]{\overline{#1}} \newcommand{\Pair}{\textsf{pair}} +\newcommand{\plus}{\mathsf{plus}} \newcommand{\Prod}{\textsf{prod}} \newcommand{\Prop}{\textsf{Prop}} \newcommand{\return}{\kw{return}} \newcommand{\Set}{\textsf{Set}} \newcommand{\si}{\textsf{if}} \newcommand{\sinon}{\textsf{else}} -\newcommand{\Sort}{\cal S} +\newcommand{\Sort}{\mathcal{S}} \newcommand{\Str}{\textsf{Stream}} \newcommand{\Struct}{\kw{Struct}} \newcommand{\subst}[3]{#1\{#2/#3\}} \newcommand{\tl}{\textsf{tl}} \newcommand{\tree}{\textsf{tree}} +\newcommand{\trii}{\triangleright_\iota} \newcommand{\true}{\textsf{true}} \newcommand{\Type}{\textsf{Type}} \newcommand{\unfold}{\textsf{unfold}} \newcommand{\WEV}[3]{\mbox{$#1[] \vdash #2 \lra #3$}} \newcommand{\WEVT}[3]{\mbox{$#1[] \vdash #2 \lra$}\\ \mbox{$ #3$}} -\newcommand{\WF}[2]{{\cal W\!F}(#1)[#2]} +\newcommand{\WF}[2]{{\mathcal{W\!F}}(#1)[#2]} \newcommand{\WFE}[1]{\WF{E}{#1}} -\newcommand{\WFT}[2]{#1[] \vdash {\cal W\!F}(#2)} -\newcommand{\WFTWOLINES}[2]{{\cal W\!F}\begin{array}{l}(#1)\\\mbox{}[{#2}]\end{array}} +\newcommand{\WFT}[2]{#1[] \vdash {\mathcal{W\!F}}(#2)} +\newcommand{\WFTWOLINES}[2]{{\mathcal{W\!F}}\begin{array}{l}(#1)\\\mbox{}[{#2}]\end{array}} \newcommand{\with}{\kw{with}} \newcommand{\WS}[3]{#1[] \vdash #2 <: #3} \newcommand{\WSE}[2]{\WS{E}{#1}{#2}} diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index 47afa5ba0c..ae66791b0c 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -859,41 +859,41 @@ notations are given below. The optional :production:`scope` is described in .. productionlist:: coq notation : [Local] Notation `string` := `term` [`modifiers`] [: `scope`]. - : | [Local] Infix `string` := `qualid` [`modifiers`] [: `scope`]. - : | [Local] Reserved Notation `string` [`modifiers`] . - : | Inductive `ind_body` [`decl_notation`] with … with `ind_body` [`decl_notation`]. - : | CoInductive `ind_body` [`decl_notation`] with … with `ind_body` [`decl_notation`]. - : | Fixpoint `fix_body` [`decl_notation`] with … with `fix_body` [`decl_notation`]. - : | CoFixpoint `cofix_body` [`decl_notation`] with … with `cofix_body` [`decl_notation`]. - : | [Local] Declare Custom Entry `ident`. + : [Local] Infix `string` := `qualid` [`modifiers`] [: `scope`]. + : [Local] Reserved Notation `string` [`modifiers`] . + : Inductive `ind_body` [`decl_notation`] with … with `ind_body` [`decl_notation`]. + : CoInductive `ind_body` [`decl_notation`] with … with `ind_body` [`decl_notation`]. + : Fixpoint `fix_body` [`decl_notation`] with … with `fix_body` [`decl_notation`]. + : CoFixpoint `cofix_body` [`decl_notation`] with … with `cofix_body` [`decl_notation`]. + : [Local] Declare Custom Entry `ident`. decl_notation : [where `string` := `term` [: `scope`] and … and `string` := `term` [: `scope`]]. modifiers : at level `num` : in custom `ident` : in custom `ident` at level `num` - : | `ident` , … , `ident` at level `num` [`binderinterp`] - : | `ident` , … , `ident` at next level [`binderinterp`] - : | `ident` `explicit_subentry` - : | left associativity - : | right associativity - : | no associativity - : | only parsing - : | only printing - : | format `string` + : `ident` , … , `ident` at level `num` [`binderinterp`] + : `ident` , … , `ident` at next level [`binderinterp`] + : `ident` `explicit_subentry` + : left associativity + : right associativity + : no associativity + : only parsing + : only printing + : format `string` explicit_subentry : ident - : | global - : | bigint - : | [strict] pattern [at level `num`] - : | binder - : | closed binder - : | constr [`binderinterp`] - : | constr at level `num` [`binderinterp`] - : | constr at next level [`binderinterp`] - : | custom [`binderinterp`] - : | custom at level `num` [`binderinterp`] - : | custom at next level [`binderinterp`] + : global + : bigint + : [strict] pattern [at level `num`] + : binder + : closed binder + : constr [`binderinterp`] + : constr at level `num` [`binderinterp`] + : constr at next level [`binderinterp`] + : custom [`binderinterp`] + : custom at level `num` [`binderinterp`] + : custom at next level [`binderinterp`] binderinterp : as ident - : | as pattern - : | as strict pattern + : as pattern + : as strict pattern .. note:: No typing of the denoted expression is performed at definition time. Type checking is done only at the time of use of the notation. @@ -1496,12 +1496,13 @@ Numeral notations function returns :g:`None`, or if the interpretation is registered for only non-negative integers, and the given numeral is negative. - .. exn:: @ident should go from Decimal.int to @type or (option @type). Instead of Decimal.int, the types Decimal.uint or Z could be used{? (require BinNums first)}. + + .. exn:: @ident should go from Decimal.int to @type or (option @type). Instead of Decimal.int, the types Decimal.uint or Z could be used (you may need to require BinNums or Decimal first). The parsing function given to the :cmd:`Numeral Notation` vernacular is not of the right type. - .. exn:: @ident should go from @type to Decimal.int or (option Decimal.int). Instead of Decimal.int, the types Decimal.uint or Z could be used{? (require BinNums first)}. + .. exn:: @ident should go from @type to Decimal.int or (option Decimal.int). Instead of Decimal.int, the types Decimal.uint or Z could be used (you may need to require BinNums or Decimal first). The printing function given to the :cmd:`Numeral Notation` vernacular is not of the right type. @@ -1692,13 +1693,13 @@ Tactic notations allow to customize the syntax of tactics. They have the followi tacn : Tactic Notation [`tactic_level`] [`prod_item` … `prod_item`] := `tactic`. prod_item : `string` | `tactic_argument_type`(`ident`) tactic_level : (at level `num`) - tactic_argument_type : ident | simple_intropattern | reference - : | hyp | hyp_list | ne_hyp_list - : | constr | uconstr | constr_list | ne_constr_list - : | integer | integer_list | ne_integer_list - : | int_or_var | int_or_var_list | ne_int_or_var_list - : | tactic | tactic0 | tactic1 | tactic2 | tactic3 - : | tactic4 | tactic5 + tactic_argument_type : `ident` | `simple_intropattern` | `reference` + : `hyp` | `hyp_list` | `ne_hyp_list` + : `constr` | `uconstr` | `constr_list` | `ne_constr_list` + : `integer` | `integer_list` | `ne_integer_list` + : `int_or_var` | `int_or_var_list` | `ne_int_or_var_list` + : `tactic` | `tactic0` | `tactic1` | `tactic2` | `tactic3` + : `tactic4` | `tactic5` .. cmd:: Tactic Notation {? (at level @level)} {+ @prod_item} := @tactic. diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 51f94d7e5a..c33df52038 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -618,5 +618,6 @@ through the <tt>Require Import</tt> command.</p> theories/Compat/Coq87.v theories/Compat/Coq88.v theories/Compat/Coq89.v + theories/Compat/Coq810.v </dd> </dl> diff --git a/doc/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index 827b7c13c1..067af954ad 100644 --- a/doc/tools/coqrst/coqdomain.py +++ b/doc/tools/coqrst/coqdomain.py @@ -1189,7 +1189,6 @@ def setup(app): app.connect('doctree-resolved', CoqtopBlocksTransform.merge_consecutive_coqtop_blocks) # Add extra styles - app.add_stylesheet("fonts.css") app.add_stylesheet("ansi.css") app.add_stylesheet("coqdoc.css") app.add_javascript("notations.js") @@ -5,7 +5,7 @@ (ocamlopt_flags -O3 -unbox-closures)) (ireport (flags :standard -rectypes -w -9-27-40+60) (ocamlopt_flags :standard -O3 -unbox-closures -inlining-report)) - (ocaml408 + (ocaml409 (flags :standard -strict-sequence -strict-formats -short-paths -keep-locs -rectypes -w -9-27+40+60 -warn-error -5 -alert --deprecated))) ; The _ profile could help factoring the above, however it doesn't diff --git a/engine/eConstr.mli b/engine/eConstr.mli index 6532e08e9d..49cbc4d7e5 100644 --- a/engine/eConstr.mli +++ b/engine/eConstr.mli @@ -77,6 +77,9 @@ val to_constr : ?abort_on_undefined_evars:bool -> Evd.evar_map -> t -> Constr.t For getting the evar-normal form of a term with evars see {!Evarutil.nf_evar}. *) +val to_constr_opt : Evd.evar_map -> t -> Constr.t option +(** Same as [to_constr], but returns [None] if some unresolved evars remain *) + val kind_of_type : Evd.evar_map -> t -> (t, t) Term.kind_of_type (** {5 Constructors} *) diff --git a/engine/evd.ml b/engine/evd.ml index 7bc3be87a4..eee2cb700c 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -601,19 +601,19 @@ let is_defined d e = EvMap.mem e d.defn_evars let is_undefined d e = EvMap.mem e d.undf_evars -let existential_value d (n, args) = - let info = find d n in - match evar_body info with - | Evar_defined c -> - instantiate_evar_array info c args - | Evar_empty -> - raise NotInstantiatedEvar +let existential_opt_value d (n, args) = + match EvMap.find_opt n d.defn_evars with + | None -> None + | Some info -> + match evar_body info with + | Evar_defined c -> Some (instantiate_evar_array info c args) + | Evar_empty -> None (* impossible but w/e *) -let existential_value0 = existential_value +let existential_value d ev = match existential_opt_value d ev with + | None -> raise NotInstantiatedEvar + | Some v -> v -let existential_opt_value d ev = - try Some (existential_value d ev) - with NotInstantiatedEvar -> None +let existential_value0 = existential_value let existential_opt_value0 = existential_opt_value @@ -1376,6 +1376,13 @@ module MiniEConstr = struct in UnivSubst.nf_evars_and_universes_opt_subst evar_value (universe_subst sigma) c + let to_constr_opt sigma c = + let evar_value ev = Some (existential_value sigma ev) in + try + Some (UnivSubst.nf_evars_and_universes_opt_subst evar_value (universe_subst sigma) c) + with NotInstantiatedEvar -> + None + let of_named_decl d = d let unsafe_to_named_decl d = d let of_rel_decl d = d diff --git a/engine/evd.mli b/engine/evd.mli index 7560d68805..de73144895 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -689,6 +689,7 @@ module MiniEConstr : sig val of_constr_array : Constr.t array -> t array val to_constr : ?abort_on_undefined_evars:bool -> evar_map -> t -> Constr.t + val to_constr_opt : evar_map -> t -> Constr.t option val unsafe_to_constr : t -> Constr.t val unsafe_to_constr_array : t array -> Constr.t array diff --git a/engine/proofview.ml b/engine/proofview.ml index 8c15579bb0..cf4224bbdb 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -636,7 +636,7 @@ let shelve = let open Proof in Comb.get >>= fun initial -> Comb.set [] >> - InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve")) >> + InfoL.leaf (Info.Tactic (fun _ _ -> Pp.str"shelve")) >> Shelf.modify (fun gls -> gls @ CList.map drop_state initial) let shelve_goals l = @@ -644,7 +644,7 @@ let shelve_goals l = Comb.get >>= fun initial -> let comb = CList.filter (fun g -> not (CList.mem (drop_state g) l)) initial in Comb.set comb >> - InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve_goals")) >> + InfoL.leaf (Info.Tactic (fun _ _ -> Pp.str"shelve_goals")) >> Shelf.modify (fun gls -> gls @ l) (** [depends_on sigma src tgt] checks whether the goal [src] appears @@ -710,7 +710,7 @@ let shelve_unifiable_informative = Pv.get >>= fun initial -> let (u,n) = partition_unifiable initial.solution initial.comb in Comb.set n >> - InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve_unifiable")) >> + InfoL.leaf (Info.Tactic (fun _ _ -> Pp.str"shelve_unifiable")) >> let u = CList.map drop_state u in Shelf.modify (fun gls -> gls @ u) >> tclUNIT u @@ -794,7 +794,7 @@ let goodmod p m = let cycle n = let open Proof in - InfoL.leaf (Info.Tactic (fun () -> Pp.(str"cycle "++int n))) >> + InfoL.leaf (Info.Tactic (fun _ _ -> Pp.(str"cycle "++int n))) >> Comb.modify begin fun initial -> let l = CList.length initial in let n' = goodmod n l in @@ -804,7 +804,7 @@ let cycle n = let swap i j = let open Proof in - InfoL.leaf (Info.Tactic (fun () -> Pp.(hov 2 (str"swap"++spc()++int i++spc()++int j)))) >> + InfoL.leaf (Info.Tactic (fun _ _ -> Pp.(hov 2 (str"swap"++spc()++int i++spc()++int j)))) >> Comb.modify begin fun initial -> let l = CList.length initial in let i = if i>0 then i-1 else i and j = if j>0 then j-1 else j in @@ -819,7 +819,7 @@ let swap i j = let revgoals = let open Proof in - InfoL.leaf (Info.Tactic (fun () -> Pp.str"revgoals")) >> + InfoL.leaf (Info.Tactic (fun _ _ -> Pp.str"revgoals")) >> Comb.modify CList.rev let numgoals = @@ -858,7 +858,7 @@ let give_up = Comb.get >>= fun initial -> Comb.set [] >> mark_as_unsafe >> - InfoL.leaf (Info.Tactic (fun () -> Pp.str"give_up")) >> + InfoL.leaf (Info.Tactic (fun _ _ -> Pp.str"give_up")) >> Giveup.put (CList.map drop_state initial) @@ -1188,9 +1188,9 @@ module Trace = struct let log m = InfoL.leaf (Info.Msg m) let name_tactic m t = InfoL.tag (Info.Tactic m) t - let pr_info ?(lvl=0) info = + let pr_info env sigma ?(lvl=0) info = assert (lvl >= 0); - Info.(print (collapse lvl info)) + Info.(print env sigma (collapse lvl info)) end @@ -1234,7 +1234,7 @@ module V82 = struct let (goalss,evd) = Evd.Monad.List.map tac initgoals_w_state initevd in let sgs = CList.flatten goalss in let sgs = undefined evd sgs in - InfoL.leaf (Info.Tactic (fun () -> Pp.str"<unknown>")) >> + InfoL.leaf (Info.Tactic (fun _ _ -> Pp.str"<unknown>")) >> Pv.set { ps with solution = evd; comb = sgs; } with e when catchable_exception e -> let (e, info) = CErrors.push e in diff --git a/engine/proofview.mli b/engine/proofview.mli index 28e793f0fc..286703c0dc 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -548,7 +548,7 @@ module Trace : sig val log : Proofview_monad.lazy_msg -> unit tactic val name_tactic : Proofview_monad.lazy_msg -> 'a tactic -> 'a tactic - val pr_info : ?lvl:int -> Proofview_monad.Info.tree -> Pp.t + val pr_info : Environ.env -> Evd.evar_map -> ?lvl:int -> Proofview_monad.Info.tree -> Pp.t end diff --git a/engine/proofview_monad.ml b/engine/proofview_monad.ml index 52bcabf958..69341d97df 100644 --- a/engine/proofview_monad.ml +++ b/engine/proofview_monad.ml @@ -64,8 +64,7 @@ end (** We typically label nodes of [Trace.tree] with messages to print. But we don't want to compute the result. *) -type lazy_msg = unit -> Pp.t -let pr_lazy_msg msg = msg () +type lazy_msg = Environ.env -> Evd.evar_map -> Pp.t (** Info trace. *) module Info = struct @@ -80,9 +79,7 @@ module Info = struct type state = tag Trace.incr type tree = tag Trace.forest - - - let pr_in_comments m = Pp.(str"(* "++pr_lazy_msg m++str" *)") + let pr_in_comments env sigma m = Pp.(str"(* "++ m env sigma ++str" *)") let unbranch = function | Trace.Seq (DBranch,brs) -> brs @@ -112,31 +109,31 @@ module Info = struct (** [with_sep] is [true] when [Tactic m] must be printed with a trailing semi-colon. *) - let rec pr_tree with_sep = let open Trace in function - | Seq (Msg m,[]) -> pr_in_comments m + let rec pr_tree env sigma with_sep = let open Trace in function + | Seq (Msg m,[]) -> pr_in_comments env sigma m | Seq (Tactic m,_) -> let tail = if with_sep then Pp.str";" else Pp.mt () in - Pp.(pr_lazy_msg m ++ tail) + Pp.(m env sigma ++ tail) | Seq (Dispatch,brs) -> let tail = if with_sep then Pp.str";" else Pp.mt () in - Pp.(pr_dispatch brs++tail) + Pp.(pr_dispatch env sigma brs++tail) | Seq (Msg _,_::_) | Seq (DBranch,_) -> assert false - and pr_dispatch brs = + and pr_dispatch env sigma brs = let open Pp in let brs = List.map unbranch brs in match brs with - | [br] -> pr_forest br + | [br] -> pr_forest env sigma br | _ -> let sep () = spc()++str"|"++spc() in - let branches = prlist_with_sep sep pr_forest brs in + let branches = prlist_with_sep sep (pr_forest env sigma) brs in str"[>"++spc()++branches++spc()++str"]" - and pr_forest = function + and pr_forest env sigma = function | [] -> Pp.mt () - | [tr] -> pr_tree false tr - | tr::l -> Pp.(pr_tree true tr ++ pr_forest l) + | [tr] -> pr_tree env sigma false tr + | tr::l -> Pp.(pr_tree env sigma true tr ++ pr_forest env sigma l) - let print f = - pr_forest (compress f) + let print env sigma f = + pr_forest env sigma (compress f) let rec collapse_tree n t = let open Trace in diff --git a/engine/proofview_monad.mli b/engine/proofview_monad.mli index 9d75242175..a08cab3bf6 100644 --- a/engine/proofview_monad.mli +++ b/engine/proofview_monad.mli @@ -45,7 +45,7 @@ end (** We typically label nodes of [Trace.tree] with messages to print. But we don't want to compute the result. *) -type lazy_msg = unit -> Pp.t +type lazy_msg = Environ.env -> Evd.evar_map -> Pp.t (** Info trace. *) module Info : sig @@ -60,7 +60,7 @@ module Info : sig type state = tag Trace.incr type tree = tag Trace.forest - val print : tree -> Pp.t + val print : Environ.env -> Evd.evar_map -> tree -> Pp.t (** [collapse n t] flattens the first [n] levels of [Tactic] in an info trace, effectively forgetting about the [n] top level of diff --git a/engine/uState.ml b/engine/uState.ml index 6969d2ba44..430a3a2fd9 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -12,6 +12,7 @@ open Pp open CErrors open Util open Names +open Univ module UNameMap = Names.Id.Map @@ -24,12 +25,12 @@ module UPairSet = UnivMinim.UPairSet (* 2nd part used to check consistency on the fly. *) type t = - { uctx_names : UnivNames.universe_binders * uinfo Univ.LMap.t; - uctx_local : Univ.ContextSet.t; (** The local context of variables *) - uctx_seff_univs : Univ.LSet.t; (** Local universes used through private constants *) + { uctx_names : UnivNames.universe_binders * uinfo LMap.t; + uctx_local : ContextSet.t; (** The local context of variables *) + uctx_seff_univs : LSet.t; (** Local universes used through private constants *) uctx_univ_variables : UnivSubst.universe_opt_subst; (** The local universes that are unification variables *) - uctx_univ_algebraic : Univ.LSet.t; + uctx_univ_algebraic : LSet.t; (** The subset of unification variables that can be instantiated with algebraic universes as they appear in inferred types only. *) uctx_universes : UGraph.t; (** The current graph extended with the local constraints *) @@ -38,11 +39,11 @@ type t = } let empty = - { uctx_names = UNameMap.empty, Univ.LMap.empty; - uctx_local = Univ.ContextSet.empty; - uctx_seff_univs = Univ.LSet.empty; - uctx_univ_variables = Univ.LMap.empty; - uctx_univ_algebraic = Univ.LSet.empty; + { uctx_names = UNameMap.empty, LMap.empty; + uctx_local = ContextSet.empty; + uctx_seff_univs = LSet.empty; + uctx_univ_variables = LMap.empty; + uctx_univ_algebraic = LSet.empty; uctx_universes = UGraph.initial_universes; uctx_initial_universes = UGraph.initial_universes; uctx_weak_constraints = UPairSet.empty; } @@ -52,8 +53,8 @@ let make u = uctx_universes = u; uctx_initial_universes = u} let is_empty ctx = - Univ.ContextSet.is_empty ctx.uctx_local && - Univ.LMap.is_empty ctx.uctx_univ_variables + ContextSet.is_empty ctx.uctx_local && + LMap.is_empty ctx.uctx_univ_variables let uname_union s t = if s == t then s @@ -67,29 +68,29 @@ let union ctx ctx' = if ctx == ctx' then ctx else if is_empty ctx' then ctx else - let local = Univ.ContextSet.union ctx.uctx_local ctx'.uctx_local in - let seff = Univ.LSet.union ctx.uctx_seff_univs ctx'.uctx_seff_univs in + let local = ContextSet.union ctx.uctx_local ctx'.uctx_local in + let seff = LSet.union ctx.uctx_seff_univs ctx'.uctx_seff_univs in let names = uname_union (fst ctx.uctx_names) (fst ctx'.uctx_names) in - let newus = Univ.LSet.diff (Univ.ContextSet.levels ctx'.uctx_local) - (Univ.ContextSet.levels ctx.uctx_local) in - let newus = Univ.LSet.diff newus (Univ.LMap.domain ctx.uctx_univ_variables) in + let newus = LSet.diff (ContextSet.levels ctx'.uctx_local) + (ContextSet.levels ctx.uctx_local) in + let newus = LSet.diff newus (LMap.domain ctx.uctx_univ_variables) in let weak = UPairSet.union ctx.uctx_weak_constraints ctx'.uctx_weak_constraints in let declarenew g = - Univ.LSet.fold (fun u g -> UGraph.add_universe u false g) newus g + LSet.fold (fun u g -> UGraph.add_universe u false g) newus g in - let names_rev = Univ.LMap.union (snd ctx.uctx_names) (snd ctx'.uctx_names) in + let names_rev = LMap.union (snd ctx.uctx_names) (snd ctx'.uctx_names) in { uctx_names = (names, names_rev); uctx_local = local; uctx_seff_univs = seff; uctx_univ_variables = - Univ.LMap.subst_union ctx.uctx_univ_variables ctx'.uctx_univ_variables; + LMap.subst_union ctx.uctx_univ_variables ctx'.uctx_univ_variables; uctx_univ_algebraic = - Univ.LSet.union ctx.uctx_univ_algebraic ctx'.uctx_univ_algebraic; + LSet.union ctx.uctx_univ_algebraic ctx'.uctx_univ_algebraic; uctx_initial_universes = declarenew ctx.uctx_initial_universes; uctx_universes = (if local == ctx.uctx_local then ctx.uctx_universes else - let cstrsr = Univ.ContextSet.constraints ctx'.uctx_local in + let cstrsr = ContextSet.constraints ctx'.uctx_local in UGraph.merge_constraints cstrsr (declarenew ctx.uctx_universes)); uctx_weak_constraints = weak} @@ -97,14 +98,14 @@ let context_set ctx = ctx.uctx_local let constraints ctx = snd ctx.uctx_local -let context ctx = Univ.ContextSet.to_context ctx.uctx_local +let context ctx = ContextSet.to_context ctx.uctx_local let const_univ_entry ~poly uctx = let open Entries in if poly then let (binders, _) = uctx.uctx_names in let uctx = context uctx in - let nas = UnivNames.compute_instance_binders (Univ.UContext.instance uctx) binders in + let nas = UnivNames.compute_instance_binders (UContext.instance uctx) binders in Polymorphic_const_entry (nas, uctx) else Monomorphic_const_entry (context_set uctx) @@ -114,7 +115,7 @@ let ind_univ_entry ~poly uctx = if poly then let (binders, _) = uctx.uctx_names in let uctx = context uctx in - let nas = UnivNames.compute_instance_binders (Univ.UContext.instance uctx) binders in + let nas = UnivNames.compute_instance_binders (UContext.instance uctx) binders in Polymorphic_ind_entry (nas, uctx) else Monomorphic_ind_entry (context_set uctx) @@ -132,19 +133,19 @@ let add_uctx_names ?loc s l (names, names_rev) = if UNameMap.mem s names then user_err ?loc ~hdr:"add_uctx_names" Pp.(str "Universe " ++ Names.Id.print s ++ str" already bound."); - (UNameMap.add s l names, Univ.LMap.add l { uname = Some s; uloc = loc } names_rev) + (UNameMap.add s l names, LMap.add l { uname = Some s; uloc = loc } names_rev) let add_uctx_loc l loc (names, names_rev) = match loc with | None -> (names, names_rev) - | Some _ -> (names, Univ.LMap.add l { uname = None; uloc = loc } names_rev) + | Some _ -> (names, LMap.add l { uname = None; uloc = loc } names_rev) let of_binders b = let ctx = empty in let rmap = UNameMap.fold (fun id l rmap -> - Univ.LMap.add l { uname = Some id; uloc = None } rmap) - b Univ.LMap.empty + LMap.add l { uname = Some id; uloc = None } rmap) + b LMap.empty in { ctx with uctx_names = b, rmap } @@ -157,7 +158,6 @@ let invent_name (named,cnt) u = aux cnt let universe_binders ctx = - let open Univ in let named, rev = ctx.uctx_names in let named, _ = LSet.fold (fun u named -> match LMap.find u rev with @@ -169,7 +169,7 @@ let universe_binders ctx = named let instantiate_variable l b v = - try v := Univ.LMap.set l (Some b) !v + try v := LMap.set l (Some b) !v with Not_found -> assert false exception UniversesDiffer @@ -177,7 +177,6 @@ exception UniversesDiffer let drop_weak_constraints = ref false let process_universe_constraints ctx cstrs = - let open Univ in let open UnivSubst in let open UnivProblem in let univs = ctx.uctx_universes in @@ -190,9 +189,9 @@ let process_universe_constraints ctx cstrs = | UEq (u, v) -> UEq (subst_univs_universe normalize u, subst_univs_universe normalize v) | ULe (u, v) -> ULe (subst_univs_universe normalize u, subst_univs_universe normalize v) in - let is_local l = Univ.LMap.mem l !vars in + let is_local l = LMap.mem l !vars in let varinfo x = - match Univ.Universe.level x with + match Universe.level x with | None -> Inl x | Some l -> Inr l in @@ -206,27 +205,27 @@ let process_universe_constraints ctx cstrs = else if not (UGraph.check_eq_level univs l' r') then (* Two rigid/global levels, none of them being local, one of them being Prop/Set, disallow *) - if Univ.Level.is_small l' || Univ.Level.is_small r' then - raise (Univ.UniverseInconsistency (Univ.Eq, l, r, None)) + if Level.is_small l' || Level.is_small r' then + raise (UniverseInconsistency (Eq, l, r, None)) else if fo then raise UniversesDiffer in - Univ.enforce_eq_level l' r' local + enforce_eq_level l' r' local in let equalize_universes l r local = match varinfo l, varinfo r with | Inr l', Inr r' -> equalize_variables false l l' r r' local | Inr l, Inl r | Inl r, Inr l -> - let alg = Univ.LSet.mem l ctx.uctx_univ_algebraic in - let inst = Univ.univ_level_rem l r r in + let alg = LSet.mem l ctx.uctx_univ_algebraic in + let inst = univ_level_rem l r r in if alg then (instantiate_variable l inst vars; local) else - let lu = Univ.Universe.make l in - if Univ.univ_level_mem l r then - Univ.enforce_leq inst lu local - else raise (Univ.UniverseInconsistency (Univ.Eq, lu, r, None)) + let lu = Universe.make l in + if univ_level_mem l r then + enforce_leq inst lu local + else raise (UniverseInconsistency (Eq, lu, r, None)) | Inl _, Inl _ (* both are algebraic *) -> if UGraph.check_eq univs l r then local - else raise (Univ.UniverseInconsistency (Univ.Eq, l, r, None)) + else raise (UniverseInconsistency (Eq, l, r, None)) in let unify_universes cst local = let cst = nf_constraint cst in @@ -237,29 +236,29 @@ let process_universe_constraints ctx cstrs = if UGraph.check_leq univs l r then (* Keep Prop/Set <= var around if var might be instantiated by prop or set later. *) - match Univ.Universe.level l, Univ.Universe.level r with + match Universe.level l, Universe.level r with | Some l, Some r -> - Univ.Constraint.add (l, Univ.Le, r) local + Constraint.add (l, Le, r) local | _ -> local else - begin match Univ.Universe.level r with + begin match Universe.level r with | None -> user_err Pp.(str "Algebraic universe on the right") | Some r' -> - if Univ.Level.is_small r' then - if not (Univ.Universe.is_levels l) + if Level.is_small r' then + if not (Universe.is_levels l) then - raise (Univ.UniverseInconsistency (Univ.Le, l, r, None)) + raise (UniverseInconsistency (Le, l, r, None)) else - let levels = Univ.Universe.levels l in + let levels = Universe.levels l in let fold l' local = - let l = Univ.Universe.make l' in - if Univ.Level.is_small l' || is_local l' then + let l = Universe.make l' in + if Level.is_small l' || is_local l' then equalize_variables false l l' r r' local - else raise (Univ.UniverseInconsistency (Univ.Le, l, r, None)) + else raise (UniverseInconsistency (Le, l, r, None)) in - Univ.LSet.fold fold levels local + LSet.fold fold levels local else - Univ.enforce_leq l r local + enforce_leq l r local end | ULub (l, r) -> equalize_variables true (Universe.make l) l (Universe.make r) r local @@ -268,26 +267,26 @@ let process_universe_constraints ctx cstrs = | UEq (l, r) -> equalize_universes l r local in let local = - UnivProblem.Set.fold unify_universes cstrs Univ.Constraint.empty + UnivProblem.Set.fold unify_universes cstrs Constraint.empty in !vars, !weak, local let add_constraints ctx cstrs = let univs, local = ctx.uctx_local in - let cstrs' = Univ.Constraint.fold (fun (l,d,r) acc -> - let l = Univ.Universe.make l and r = Univ.Universe.make r in + let cstrs' = Constraint.fold (fun (l,d,r) acc -> + let l = Universe.make l and r = Universe.make r in let cstr' = let open UnivProblem in match d with - | Univ.Lt -> - ULe (Univ.Universe.super l, r) - | Univ.Le -> ULe (l, r) - | Univ.Eq -> UEq (l, r) + | Lt -> + ULe (Universe.super l, r) + | Le -> ULe (l, r) + | Eq -> UEq (l, r) in UnivProblem.Set.add cstr' acc) cstrs UnivProblem.Set.empty in let vars, weak, local' = process_universe_constraints ctx cstrs' in { ctx with - uctx_local = (univs, Univ.Constraint.union local local'); + uctx_local = (univs, Constraint.union local local'); uctx_univ_variables = vars; uctx_universes = UGraph.merge_constraints local' ctx.uctx_universes; uctx_weak_constraints = weak; } @@ -299,7 +298,7 @@ let add_universe_constraints ctx cstrs = let univs, local = ctx.uctx_local in let vars, weak, local' = process_universe_constraints ctx cstrs in { ctx with - uctx_local = (univs, Univ.Constraint.union local local'); + uctx_local = (univs, Constraint.union local local'); uctx_univ_variables = vars; uctx_universes = UGraph.merge_constraints local' ctx.uctx_universes; uctx_weak_constraints = weak; } @@ -307,14 +306,14 @@ let add_universe_constraints ctx cstrs = let constrain_variables diff ctx = let univs, local = ctx.uctx_local in let univs, vars, local = - Univ.LSet.fold + LSet.fold (fun l (univs, vars, cstrs) -> try - match Univ.LMap.find l vars with + match LMap.find l vars with | Some u -> - (Univ.LSet.add l univs, - Univ.LMap.remove l vars, - Univ.Constraint.add (l, Univ.Eq, Option.get (Univ.Universe.level u)) cstrs) + (LSet.add l univs, + LMap.remove l vars, + Constraint.add (l, Eq, Option.get (Universe.level u)) cstrs) | None -> (univs, vars, cstrs) with Not_found | Option.IsNone -> (univs, vars, cstrs)) diff (univs, ctx.uctx_univ_variables, local) @@ -324,14 +323,14 @@ let constrain_variables diff ctx = let qualid_of_level uctx = let map, map_rev = uctx.uctx_names in fun l -> - try Some (Libnames.qualid_of_ident (Option.get (Univ.LMap.find l map_rev).uname)) + try Some (Libnames.qualid_of_ident (Option.get (LMap.find l map_rev).uname)) with Not_found | Option.IsNone -> UnivNames.qualid_of_level l let pr_uctx_level uctx l = match qualid_of_level uctx l with | Some qid -> Libnames.pr_qualid qid - | None -> Univ.Level.pr l + | None -> Level.pr l type ('a, 'b) gen_universe_decl = { univdecl_instance : 'a; (* Declared universes *) @@ -340,16 +339,15 @@ type ('a, 'b) gen_universe_decl = { univdecl_extensible_constraints : bool (* Can new constraints be added *) } type universe_decl = - (lident list, Univ.Constraint.t) gen_universe_decl + (lident list, Constraint.t) gen_universe_decl let default_univ_decl = { univdecl_instance = []; univdecl_extensible_instance = true; - univdecl_constraints = Univ.Constraint.empty; + univdecl_constraints = Constraint.empty; univdecl_extensible_constraints = true } let error_unbound_universes left uctx = - let open Univ in let n = LSet.cardinal left in let loc = try @@ -365,7 +363,6 @@ let error_unbound_universes left uctx = str" unbound.")) let universe_context ~names ~extensible uctx = - let open Univ in let levels = ContextSet.levels uctx.uctx_local in let newinst, left = List.fold_right @@ -388,7 +385,6 @@ let universe_context ~names ~extensible uctx = let check_universe_context_set ~names ~extensible uctx = if extensible then () else - let open Univ in let left = List.fold_left (fun left { CAst.loc; v = id } -> let l = try UNameMap.find id (fst uctx.uctx_names) @@ -415,7 +411,7 @@ let check_mono_univ_decl uctx decl = if not decl.univdecl_extensible_constraints then check_implication uctx decl.univdecl_constraints - (Univ.ContextSet.constraints uctx.uctx_local); + (ContextSet.constraints uctx.uctx_local); uctx.uctx_local let check_univ_decl ~poly uctx decl = @@ -425,7 +421,7 @@ let check_univ_decl ~poly uctx decl = if poly then let (binders, _) = uctx.uctx_names in let uctx = universe_context ~names ~extensible uctx in - let nas = UnivNames.compute_instance_binders (Univ.UContext.instance uctx) binders in + let nas = UnivNames.compute_instance_binders (UContext.instance uctx) binders in Entries.Polymorphic_const_entry (nas, uctx) else let () = check_universe_context_set ~names ~extensible uctx in @@ -434,11 +430,10 @@ let check_univ_decl ~poly uctx decl = if not decl.univdecl_extensible_constraints then check_implication uctx decl.univdecl_constraints - (Univ.ContextSet.constraints uctx.uctx_local); + (ContextSet.constraints uctx.uctx_local); ctx let restrict_universe_context (univs, csts) keep = - let open Univ in let removed = LSet.diff univs keep in if LSet.is_empty removed then univs, csts else @@ -453,8 +448,8 @@ let restrict_universe_context (univs, csts) keep = (LSet.inter univs keep, csts) let restrict ctx vars = - let vars = Univ.LSet.union vars ctx.uctx_seff_univs in - let vars = Names.Id.Map.fold (fun na l vars -> Univ.LSet.add l vars) + let vars = LSet.union vars ctx.uctx_seff_univs in + let vars = Names.Id.Map.fold (fun na l vars -> LSet.add l vars) (fst ctx.uctx_names) vars in let uctx' = restrict_universe_context ctx.uctx_local vars in @@ -465,7 +460,7 @@ let demote_seff_univs entry uctx = match entry.const_entry_universes with | Polymorphic_const_entry _ -> uctx | Monomorphic_const_entry (univs, _) -> - let seff = Univ.LSet.union uctx.uctx_seff_univs univs in + let seff = LSet.union uctx.uctx_seff_univs univs in { uctx with uctx_seff_univs = seff } type rigid = @@ -483,7 +478,6 @@ let univ_flexible_alg = UnivFlexible true or defined separately. In the later case, there is no extension, see [emit_side_effects] for example. *) let merge ?loc ~sideff ~extend rigid uctx ctx' = - let open Univ in let levels = ContextSet.levels ctx' in let uctx = if not extend then uctx else @@ -527,7 +521,7 @@ let merge ?loc ~sideff ~extend rigid uctx ctx' = uctx_initial_universes = initial } let merge_subst uctx s = - { uctx with uctx_univ_variables = Univ.LMap.subst_union uctx.uctx_univ_variables s } + { uctx with uctx_univ_variables = LMap.subst_union uctx.uctx_univ_variables s } let emit_side_effects eff u = let uctxs = Safe_typing.universes_of_private eff in @@ -536,14 +530,14 @@ let emit_side_effects eff u = let new_univ_variable ?loc rigid name ({ uctx_local = ctx; uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as uctx) = let u = UnivGen.fresh_level () in - let ctx' = Univ.ContextSet.add_universe u ctx in + let ctx' = ContextSet.add_universe u ctx in let uctx', pred = match rigid with | UnivRigid -> uctx, true | UnivFlexible b -> - let uvars' = Univ.LMap.add u None uvars in + let uvars' = LMap.add u None uvars in if b then {uctx with uctx_univ_variables = uvars'; - uctx_univ_algebraic = Univ.LSet.add u avars}, false + uctx_univ_algebraic = LSet.add u avars}, false else {uctx with uctx_univ_variables = uvars'}, false in let names = @@ -574,12 +568,11 @@ let add_global_univ uctx u = let univs = UGraph.add_universe u true uctx.uctx_universes in - { uctx with uctx_local = Univ.ContextSet.add_universe u uctx.uctx_local; + { uctx with uctx_local = ContextSet.add_universe u uctx.uctx_local; uctx_initial_universes = initial; uctx_universes = univs } let make_flexible_variable ctx ~algebraic u = - let open Univ in let {uctx_local = cstrs; uctx_univ_variables = uvars; uctx_univ_algebraic = avars; uctx_universes=g; } = ctx in assert (try LMap.find u uvars == None with Not_found -> true); @@ -608,48 +601,47 @@ let make_flexible_variable ctx ~algebraic u = uctx_univ_algebraic = avars'} let make_nonalgebraic_variable ctx u = - { ctx with uctx_univ_algebraic = Univ.LSet.remove u ctx.uctx_univ_algebraic } + { ctx with uctx_univ_algebraic = LSet.remove u ctx.uctx_univ_algebraic } let make_flexible_nonalgebraic ctx = - {ctx with uctx_univ_algebraic = Univ.LSet.empty} + {ctx with uctx_univ_algebraic = LSet.empty} let is_sort_variable uctx s = match s with | Sorts.Type u -> - (match Univ.universe_level u with + (match universe_level u with | Some l as x -> - if Univ.LSet.mem l (Univ.ContextSet.levels uctx.uctx_local) then x + if LSet.mem l (ContextSet.levels uctx.uctx_local) then x else None | None -> None) | _ -> None let subst_univs_context_with_def def usubst (ctx, cst) = - (Univ.LSet.diff ctx def, UnivSubst.subst_univs_constraints usubst cst) + (LSet.diff ctx def, UnivSubst.subst_univs_constraints usubst cst) let is_trivial_leq (l,d,r) = - Univ.Level.is_prop l && (d == Univ.Le || (d == Univ.Lt && Univ.Level.is_set r)) + Level.is_prop l && (d == Le || (d == Lt && Level.is_set r)) (* Prop < i <-> Set+1 <= i <-> Set < i *) let translate_cstr (l,d,r as cstr) = - let open Univ in - if Level.equal Level.prop l && d == Univ.Lt && not (Level.equal Level.set r) then + if Level.equal Level.prop l && d == Lt && not (Level.equal Level.set r) then (Level.set, d, r) else cstr let refresh_constraints univs (ctx, cstrs) = let cstrs', univs' = - Univ.Constraint.fold (fun c (cstrs', univs as acc) -> + Constraint.fold (fun c (cstrs', univs as acc) -> let c = translate_cstr c in if is_trivial_leq c then acc - else (Univ.Constraint.add c cstrs', UGraph.enforce_constraint c univs)) - cstrs (Univ.Constraint.empty, univs) + else (Constraint.add c cstrs', UGraph.enforce_constraint c univs)) + cstrs (Constraint.empty, univs) in ((ctx, cstrs'), univs') let normalize_variables uctx = let normalized_variables, def, subst = UnivSubst.normalize_univ_variables uctx.uctx_univ_variables in - let ctx_local = subst_univs_context_with_def def (Univ.make_subst subst) uctx.uctx_local in + let ctx_local = subst_univs_context_with_def def (make_subst subst) uctx.uctx_local in let ctx_local', univs = refresh_constraints uctx.uctx_initial_universes ctx_local in subst, { uctx with uctx_local = ctx_local'; uctx_univ_variables = normalized_variables; @@ -657,17 +649,17 @@ let normalize_variables uctx = let abstract_undefined_variables uctx = let vars' = - Univ.LMap.fold (fun u v acc -> - if v == None then Univ.LSet.remove u acc + LMap.fold (fun u v acc -> + if v == None then LSet.remove u acc else acc) uctx.uctx_univ_variables uctx.uctx_univ_algebraic - in { uctx with uctx_local = Univ.ContextSet.empty; + in { uctx with uctx_local = ContextSet.empty; uctx_univ_algebraic = vars' } let fix_undefined_variables uctx = let algs', vars' = - Univ.LMap.fold (fun u v (algs, vars as acc) -> - if v == None then (Univ.LSet.remove u algs, Univ.LMap.remove u vars) + LMap.fold (fun u v (algs, vars as acc) -> + if v == None then (LSet.remove u algs, LMap.remove u vars) else acc) uctx.uctx_univ_variables (uctx.uctx_univ_algebraic, uctx.uctx_univ_variables) @@ -677,20 +669,20 @@ let fix_undefined_variables uctx = let refresh_undefined_univ_variables uctx = let subst, ctx' = UnivGen.fresh_universe_context_set_instance uctx.uctx_local in - let subst_fn u = Univ.subst_univs_level_level subst u in - let alg = Univ.LSet.fold (fun u acc -> Univ.LSet.add (subst_fn u) acc) - uctx.uctx_univ_algebraic Univ.LSet.empty + let subst_fn u = subst_univs_level_level subst u in + let alg = LSet.fold (fun u acc -> LSet.add (subst_fn u) acc) + uctx.uctx_univ_algebraic LSet.empty in let vars = - Univ.LMap.fold + LMap.fold (fun u v acc -> - Univ.LMap.add (subst_fn u) - (Option.map (Univ.subst_univs_level_universe subst) v) acc) - uctx.uctx_univ_variables Univ.LMap.empty + LMap.add (subst_fn u) + (Option.map (subst_univs_level_universe subst) v) acc) + uctx.uctx_univ_variables LMap.empty in let weak = UPairSet.fold (fun (u,v) acc -> UPairSet.add (subst_fn u, subst_fn v) acc) uctx.uctx_weak_constraints UPairSet.empty in - let declare g = Univ.LSet.fold (fun u g -> UGraph.add_universe u false g) - (Univ.ContextSet.levels ctx') g in + let declare g = LSet.fold (fun u g -> UGraph.add_universe u false g) + (ContextSet.levels ctx') g in let initial = declare uctx.uctx_initial_universes in let univs = declare UGraph.initial_universes in let uctx' = {uctx_names = uctx.uctx_names; @@ -708,7 +700,7 @@ let minimize uctx = normalize_context_set uctx.uctx_universes uctx.uctx_local uctx.uctx_univ_variables uctx.uctx_univ_algebraic uctx.uctx_weak_constraints in - if Univ.ContextSet.equal us' uctx.uctx_local then uctx + if ContextSet.equal us' uctx.uctx_local then uctx else let us', universes = refresh_constraints uctx.uctx_initial_universes us' diff --git a/ide/fake_ide.ml b/ide/fake_ide.ml index 8b0c736f50..4e26cb6095 100644 --- a/ide/fake_ide.ml +++ b/ide/fake_ide.ml @@ -241,6 +241,9 @@ let eval_print l coq = | [ Tok(_,"ADD"); Top [Tok(_,name)]; Tok(_,phrase) ] -> let eid, tip = add_sentence ~name phrase in after_add (base_eval_call (add ((phrase,eid),(tip,true))) coq) + | [ Tok(_,"FAILADD"); Tok(_,phrase) ] -> + let eid, tip = add_sentence phrase in + after_fail coq (base_eval_call ~fail:false (add ((phrase,eid),(tip,true))) coq) | [ Tok(_,"GOALS"); ] -> eval_call (goals ()) coq | [ Tok(_,"FAILGOALS"); ] -> @@ -267,7 +270,8 @@ let eval_print l coq = prerr_endline "Quitting fake_ide"; exit 0 | Tok("#[^\n]*",_) :: _ -> () - | _ -> error "syntax error" + | Tok(s,_) :: _ -> error ("syntax error at " ^ s) + | _ -> error ("syntax error") let grammar = let open Parser in @@ -275,6 +279,7 @@ let grammar = let eat_phrase = eat_balanced '{' in Alt [ Seq [Item (eat_rex "ADD"); Opt (Item eat_id); Item eat_phrase] + ; Seq [Item (eat_rex "FAILADD"); Item eat_phrase] ; Seq [Item (eat_rex "EDIT_AT"); Item eat_id] ; Seq [Item (eat_rex "QUERY"); Opt (Item eat_id); Item eat_phrase] ; Seq [Item (eat_rex "WAIT")] diff --git a/ide/idetop.ml b/ide/idetop.ml index 716a942d5c..205f4455a3 100644 --- a/ide/idetop.ml +++ b/ide/idetop.ml @@ -64,11 +64,19 @@ let is_known_option cmd = match Vernacprop.under_control cmd with (** Check whether a command is forbidden in the IDE *) -let ide_cmd_checks ~id {CAst.loc;v=ast} = - let user_error s = CErrors.user_err ?loc ~hdr:"IDE" (str s) in - let warn msg = Feedback.(feedback ~id (Message (Warning, loc, strbrk msg))) in +let ide_cmd_checks ~last_valid {CAst.loc;v=ast} = + let user_error s = + try CErrors.user_err ?loc ~hdr:"IDE" (str s) + with e -> + let (e, info) = CErrors.push e in + let info = Stateid.add info ~valid:last_valid Stateid.dummy in + Exninfo.raise ~info e + in if is_debug ast then - user_error "Debug mode not available in the IDE"; + user_error "Debug mode not available in the IDE" + +let ide_cmd_warns ~id {CAst.loc;v=ast} = + let warn msg = Feedback.(feedback ~id (Message (Warning, loc, strbrk msg))) in if is_known_option ast then warn "Set this option from the IDE menu instead"; if is_navigation_vernac ast || is_undo ast then @@ -83,11 +91,15 @@ let set_doc doc = ide_doc := Some doc let add ((s,eid),(sid,verbose)) = let doc = get_doc () in let pa = Pcoq.Parsable.make (Stream.of_string s) in - let loc_ast = Stm.parse_sentence ~doc sid pa in + match Stm.parse_sentence ~doc sid ~entry:Pvernac.main_entry pa with + | None -> assert false (* s is not an empty string *) + | Some (loc, ast) -> + let loc_ast = CAst.make ~loc ast in + ide_cmd_checks ~last_valid:sid loc_ast; let doc, newid, rc = Stm.add ~doc ~ontop:sid verbose loc_ast in set_doc doc; let rc = match rc with `NewTip -> CSig.Inl () | `Unfocus id -> CSig.Inr id in - ide_cmd_checks ~id:newid loc_ast; + ide_cmd_warns ~id:newid loc_ast; (* TODO: the "" parameter is a leftover of the times the protocol * used to include stderr/stdout output. * @@ -121,10 +133,10 @@ let query (route, (s,id)) = let annotate phrase = let doc = get_doc () in - let {CAst.loc;v=ast} = - let pa = Pcoq.Parsable.make (Stream.of_string phrase) in - Stm.parse_sentence ~doc (Stm.get_current_state ~doc) pa - in + let pa = Pcoq.Parsable.make (Stream.of_string phrase) in + match Stm.parse_sentence ~doc (Stm.get_current_state ~doc) ~entry:Pvernac.main_entry pa with + | None -> Richpp.richpp_of_pp 78 (Pp.mt ()) + | Some (_, ast) -> (* XXX: Width should be a parameter of annotate... *) Richpp.richpp_of_pp 78 (Ppvernac.pr_vernac ast) diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 3a5af1dd5f..95a0039b0a 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -293,9 +293,6 @@ let ids_of_pattern_list = (List.fold_left (cases_pattern_fold_names Id.Set.add)) Id.Set.empty -let ids_of_cases_indtype p = - cases_pattern_fold_names Id.Set.add Id.Set.empty p - let ids_of_cases_tomatch tms = List.fold_right (fun (_, ona, indnal) l -> @@ -366,6 +363,14 @@ let free_vars_of_constr_expr c = | c -> fold_constr_expr_with_binders (fun a l -> a::l) aux bdvars l c in aux [] Id.Set.empty c +let names_of_constr_expr c = + let vars = ref Id.Set.empty in + let rec aux () () = function + | { CAst.v = CRef (qid, _) } when qualid_is_ident qid -> + let id = qualid_basename qid in vars := Id.Set.add id !vars + | c -> fold_constr_expr_with_binders (fun a () -> vars := Id.Set.add a !vars) aux () () c + in aux () () c; !vars + let occur_var_constr_expr id c = Id.Set.mem id (free_vars_of_constr_expr c) (* Used in correctness and interface *) diff --git a/interp/constrexpr_ops.mli b/interp/constrexpr_ops.mli index 7f14eb4583..f1a8ed202f 100644 --- a/interp/constrexpr_ops.mli +++ b/interp/constrexpr_ops.mli @@ -113,12 +113,12 @@ val map_constr_expr_with_binders : val replace_vars_constr_expr : Id.t Id.Map.t -> constr_expr -> constr_expr -(** Specific function for interning "in indtype" syntax of "match" *) -val ids_of_cases_indtype : cases_pattern_expr -> Id.Set.t - val free_vars_of_constr_expr : constr_expr -> Id.Set.t val occur_var_constr_expr : Id.t -> constr_expr -> bool +(** Return all (non-qualified) names treating binders as names *) +val names_of_constr_expr : constr_expr -> Id.Set.t + val split_at_annot : local_binder_expr list -> lident option -> local_binder_expr list * local_binder_expr list val ntn_loc : ?loc:Loc.t -> constr_notation_substitution -> notation -> (int * int) list diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 0d0b6158d9..13078840ef 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -67,10 +67,7 @@ let print_no_symbol = ref false (**********************************************************************) (* Turning notations and scopes on and off for printing *) -module IRuleSet = Set.Make(struct - type t = interp_rule - let compare x y = Pervasives.compare x y - end) +module IRuleSet = InterpRuleSet let inactive_notations_table = Summary.ref ~name:"inactive_notations_table" (IRuleSet.empty) @@ -628,8 +625,13 @@ let explicitize inctx impl (cf,f) args = CApp ((ip,f),args1@args2) | None -> let args = exprec 1 (args,impl) in - if List.is_empty args then f.CAst.v else CApp ((None, f), args) - in + if List.is_empty args then f.CAst.v else + match f.CAst.v with + | CApp (g,args') -> + (* may happen with notations for a prefix of an n-ary + application *) + CApp (g,args'@args) + | _ -> CApp ((None, f), args) in try expl () with Expl -> let f',us = match f with { CAst.v = CRef (f,us) } -> f,us | _ -> assert false in diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 7aa85a0810..c8c38ffe05 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -573,12 +573,17 @@ let find_fresh_name renaming (terms,termlists,binders,binderlists) avoid id = (* TODO binders *) next_ident_away_from id (fun id -> Id.Set.mem id fvs3) -let is_var store pat = +let is_patvar c = + match DAst.get c with + | PatVar _ -> true + | _ -> false + +let is_patvar_store store pat = match DAst.get pat with | PatVar na -> ignore(store na); true | _ -> false -let out_var pat = +let out_patvar pat = match pat.v with | CPatAtom (Some qid) when qualid_is_ident qid -> Name (qualid_basename qid) @@ -600,7 +605,7 @@ let traverse_binder intern_pat ntnvars (terms,_,binders,_ as subst) avoid (renam let pat = coerce_to_cases_pattern_expr (fst (Id.Map.find id terms)) in let env,((disjpat,ids),id),na = intern_pat ntnvars env pat in let pat, na = match disjpat with - | [pat] when is_var store pat -> let na = get () in None, na + | [pat] when is_patvar_store store pat -> let na = get () in None, na | _ -> Some ((List.map (fun x -> x.v) ids,disjpat),id), na.v in (renaming,env), pat, na with Not_found -> @@ -610,7 +615,7 @@ let traverse_binder intern_pat ntnvars (terms,_,binders,_ as subst) avoid (renam let env = set_env_scopes env scopes in if onlyident then (* Do not try to interpret a variable as a constructor *) - let na = out_var pat in + let na = out_patvar pat in let env = push_name_env ntnvars (Variable,[],[],[]) env (make ?loc:pat.loc na) in (renaming,env), None, na else @@ -618,7 +623,7 @@ let traverse_binder intern_pat ntnvars (terms,_,binders,_ as subst) avoid (renam let env,((disjpat,ids),id),na = intern_pat ntnvars env pat in let pat, na = match disjpat with - | [pat] when is_var store pat -> let na = get () in None, na + | [pat] when is_patvar_store store pat -> let na = get () in None, na | _ -> Some ((List.map (fun x -> x.v) ids,disjpat),id), na.v in (renaming,env), pat, na with Not_found -> @@ -743,7 +748,7 @@ let instantiate_notation_constr loc intern intern_pat ntnvars subst infos c = let mk_env' (c, (onlyident,(tmp_scope,subscopes))) = let nenv = {env with tmp_scope; scopes = subscopes @ env.scopes} in if onlyident then - let na = out_var c in term_of_name na, None + let na = out_patvar c in term_of_name na, None else let _,((disjpat,_),_),_ = intern_pat ntnvars nenv c in match disjpat with @@ -805,7 +810,7 @@ let instantiate_notation_constr loc intern intern_pat ntnvars subst infos c = (* and since we are only interested in the pattern as a term *) let env = reset_hidden_inductive_implicit_test env in if onlyident then - term_of_name (out_var pat) + term_of_name (out_patvar pat) else let env,((disjpat,ids),id),na = intern_pat ntnvars env pat in match disjpat with @@ -1741,7 +1746,7 @@ let intern_ind_pattern genv ntnvars scopes pat = let idslpl = List.map (intern_pat genv ntnvars empty_alias) (expl_pl@pl2) in (with_letin, match product_of_cases_patterns empty_alias idslpl with - | _,[_,pl] -> (c,chop_params_pattern loc c pl with_letin) + | ids,[asubst,pl] -> (c,ids,asubst,chop_params_pattern loc c pl with_letin) | _ -> error_bad_inductive_type ?loc) | x -> error_bad_inductive_type ?loc @@ -1979,30 +1984,30 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = end | CCases (sty, rtnpo, tms, eqns) -> let as_in_vars = List.fold_left (fun acc (_,na,inb) -> - Option.fold_left (fun acc tt -> Id.Set.union (ids_of_cases_indtype tt) acc) - (Option.fold_left (fun acc { CAst.v = y } -> Name.fold_right Id.Set.add y acc) acc na) - inb) Id.Set.empty tms in + (Option.fold_left (fun acc { CAst.v = y } -> Name.fold_right Id.Set.add y acc) acc na)) + Id.Set.empty tms in (* as, in & return vars *) let forbidden_vars = Option.cata free_vars_of_constr_expr as_in_vars rtnpo in - let tms,ex_ids,match_from_in = List.fold_right - (fun citm (inds,ex_ids,matchs) -> - let ((tm,ind),extra_id,match_td) = intern_case_item env forbidden_vars citm in - (tm,ind)::inds, Option.fold_right Id.Set.add extra_id ex_ids, List.rev_append match_td matchs) - tms ([],Id.Set.empty,[]) in + let tms,ex_ids,aliases,match_from_in = List.fold_right + (fun citm (inds,ex_ids,asubst,matchs) -> + let ((tm,ind),extra_id,(ind_ids,alias_subst,match_td)) = + intern_case_item env forbidden_vars citm in + (tm,ind)::inds, + Id.Set.union ind_ids (Option.fold_right Id.Set.add extra_id ex_ids), + merge_subst alias_subst asubst, + List.rev_append match_td matchs) + tms ([],Id.Set.empty,Id.Map.empty,[]) in let env' = Id.Set.fold (fun var bli -> push_name_env ntnvars (Variable,[],[],[]) bli (CAst.make @@ Name var)) (Id.Set.union ex_ids as_in_vars) (reset_hidden_inductive_implicit_test env) in (* PatVars before a real pattern do not need to be matched *) let stripped_match_from_in = - let is_patvar c = match DAst.get c with - | PatVar _ -> true - | _ -> false - in let rec aux = function | [] -> [] | (_, c) :: q when is_patvar c -> aux q | l -> l in aux match_from_in in + let rtnpo = Option.map (replace_vars_constr_expr aliases) rtnpo in let rtnpo = match stripped_match_from_in with | [] -> Option.map (intern_type env') rtnpo (* Only PatVar in "in" clauses *) | l -> @@ -2150,7 +2155,8 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = (* the "in" part *) let match_td,typ = match t with | Some t -> - let with_letin,(ind,l) = intern_ind_pattern globalenv ntnvars (None,env.scopes) t in + let with_letin,(ind,ind_ids,alias_subst,l) = + intern_ind_pattern globalenv ntnvars (None,env.scopes) t in let (mib,mip) = Inductive.lookup_mind_specif globalenv ind in let nparams = (List.length (mib.Declarations.mind_params_ctxt)) in (* for "in Vect n", we answer (["n","n"],[(loc,"n")]) @@ -2186,9 +2192,10 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let _,args_rel = List.chop nparams (List.rev mip.Declarations.mind_arity_ctxt) in canonize_args args_rel l forbidden_names_for_gen [] [] in - match_to_do, Some (CAst.make ?loc:(cases_pattern_expr_loc t) (ind,List.rev_map (fun x -> x.v) nal)) + (Id.Set.of_list (List.map (fun id -> id.CAst.v) ind_ids),alias_subst,match_to_do), + Some (CAst.make ?loc:(cases_pattern_expr_loc t) (ind,List.rev_map (fun x -> x.v) nal)) | None -> - [], None in + (Id.Set.empty,Id.Map.empty,[]), None in (tm',(na.CAst.v, typ)), extra_id, match_td and intern_impargs c env l subscopes args = diff --git a/interp/notation.ml b/interp/notation.ml index b0854de4a3..ca27d439fb 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -50,15 +50,25 @@ let notation_entry_level_eq s1 s2 = match (s1,s2) with | InCustomEntryLevel (s1,n1), InCustomEntryLevel (s2,n2) -> String.equal s1 s2 && n1 = n2 | (InConstrEntrySomeLevel | InCustomEntryLevel _), _ -> false +let notation_entry_level_compare s1 s2 = match (s1,s2) with +| InConstrEntrySomeLevel, InConstrEntrySomeLevel -> 0 +| InCustomEntryLevel (s1,n1), InCustomEntryLevel (s2,n2) -> + pair_compare String.compare Int.compare (s1,n1) (s2,n2) +| InConstrEntrySomeLevel, _ -> -1 +| InCustomEntryLevel _, _ -> 1 + let notation_eq (from1,ntn1) (from2,ntn2) = notation_entry_level_eq from1 from2 && String.equal ntn1 ntn2 let pr_notation (from,ntn) = qstring ntn ++ match from with InConstrEntrySomeLevel -> mt () | InCustomEntryLevel (s,n) -> str " in custom " ++ str s +let notation_compare = + pair_compare notation_entry_level_compare String.compare + module NotationOrd = struct type t = notation - let compare = Pervasives.compare + let compare = notation_compare end module NotationSet = Set.Make(NotationOrd) @@ -178,6 +188,17 @@ type scoped_notation_rule_core = scope_name * notation * interpretation * int op type notation_rule_core = interp_rule * interpretation * int option type notation_rule = notation_rule_core * delimiters option * bool +let interp_rule_compare r1 r2 = match r1, r2 with + | NotationRule (sc1,ntn1), NotationRule (sc2,ntn2) -> + pair_compare (Option.compare String.compare) notation_compare (sc1,ntn1) (sc2,ntn2) + | SynDefRule kn1, SynDefRule kn2 -> KerName.compare kn1 kn2 + | (NotationRule _ | SynDefRule _), _ -> -1 + +module InterpRuleSet = Set.Make(struct + type t = interp_rule + let compare = interp_rule_compare + end) + (* Scopes for uninterpretation: includes abbreviations (i.e. syntactic definitions) and *) type uninterp_scope_elem = diff --git a/interp/notation.mli b/interp/notation.mli index 75034cad70..a482e00e81 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -210,6 +210,8 @@ type interp_rule = | NotationRule of scope_name option * notation | SynDefRule of KerName.t +module InterpRuleSet : Set.S with type elt = interp_rule + val declare_notation_interpretation : notation -> scope_name option -> interpretation -> notation_location -> onlyprint:bool -> unit diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index 1f61bcae2e..196bb16f32 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -374,46 +374,6 @@ let rec stack_args_size = function | Zupdate(_)::s -> stack_args_size s | (ZcaseT _ | Zproj _ | Zfix _) :: _ | [] -> 0 -(* When used as an argument stack (only Zapp can appear) *) -let rec decomp_stack = function - | Zapp v :: s -> - (match Array.length v with - 0 -> decomp_stack s - | 1 -> Some (v.(0), s) - | _ -> - Some (v.(0), (Zapp (Array.sub v 1 (Array.length v - 1)) :: s))) - | (ZcaseT _ | Zproj _ | Zfix _ | Zshift _ | Zupdate _) :: _ | [] -> None -let array_of_stack s = - let rec stackrec = function - | [] -> [] - | Zapp args :: s -> args :: (stackrec s) - | (ZcaseT _ | Zproj _ | Zfix _ | Zshift _ | Zupdate _) :: _ -> assert false - in Array.concat (stackrec s) -let rec stack_assign s p c = match s with - | Zapp args :: s -> - let q = Array.length args in - if p >= q then - Zapp args :: stack_assign s (p-q) c - else - (let nargs = Array.copy args in - nargs.(p) <- c; - Zapp nargs :: s) - | (ZcaseT _ | Zproj _ | Zfix _ | Zshift _ | Zupdate _) :: _ | [] -> s -let rec stack_tail p s = - if Int.equal p 0 then s else - match s with - | Zapp args :: s -> - let q = Array.length args in - if p >= q then stack_tail (p-q) s - else Zapp (Array.sub args p (q-p)) :: s - | (ZcaseT _ | Zproj _ | Zfix _ | Zshift _ | Zupdate _) :: _ | [] -> failwith "stack_tail" -let rec stack_nth s p = match s with - | Zapp args :: s -> - let q = Array.length args in - if p >= q then stack_nth s (p-q) - else args.(p) - | (ZcaseT _ | Zproj _ | Zfix _ | Zshift _ | Zupdate _) :: _ | [] -> raise Not_found - (* Lifting. Preserves sharing (useful only for cell with norm=Red). lft_fconstr always create a new cell, while lift_fconstr avoids it when the lift is 0. *) diff --git a/kernel/cClosure.mli b/kernel/cClosure.mli index c2d53eed47..46be1bb279 100644 --- a/kernel/cClosure.mli +++ b/kernel/cClosure.mli @@ -123,8 +123,7 @@ type fterm = (*********************************************************************** s A [stack] is a context of arguments, arguments are pushed by - [append_stack] one array at a time but popped with [decomp_stack] - one by one *) + [append_stack] one array at a time *) type stack_member = | Zapp of fconstr array @@ -139,13 +138,7 @@ and stack = stack_member list val empty_stack : stack val append_stack : fconstr array -> stack -> stack -val decomp_stack : stack -> (fconstr * stack) option -val array_of_stack : stack -> fconstr array -val stack_assign : stack -> int -> fconstr -> stack val stack_args_size : stack -> int -val stack_tail : int -> stack -> stack -val stack_nth : stack -> int -> fconstr -val zip_term : (fconstr -> constr) -> constr -> stack -> constr val eta_expand_stack : stack -> stack (** To lazy reduce a constr, create a [clos_infos] with diff --git a/kernel/environ.ml b/kernel/environ.ml index 38a428d9a1..77820a301e 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -238,6 +238,13 @@ let is_impredicative_set env = | ImpredicativeSet -> true | _ -> false +let is_impredicative_sort env = function + | Sorts.Prop -> true + | Sorts.Set -> is_impredicative_set env + | Sorts.Type _ -> false + +let is_impredicative_univ env u = is_impredicative_sort env (Sorts.sort_of_univ u) + let type_in_type env = not (typing_flags env).check_universes let deactivated_guard env = not (typing_flags env).check_guarded diff --git a/kernel/environ.mli b/kernel/environ.mli index 8a2efb2477..6d4d3b282b 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -98,6 +98,9 @@ val type_in_type : env -> bool val deactivated_guard : env -> bool val indices_matter : env -> bool +val is_impredicative_sort : env -> Sorts.t -> bool +val is_impredicative_univ : env -> Univ.Universe.t -> bool + (** is the local context empty *) val empty_context : env -> bool diff --git a/kernel/indTyping.ml b/kernel/indTyping.ml new file mode 100644 index 0000000000..6976b2019d --- /dev/null +++ b/kernel/indTyping.ml @@ -0,0 +1,307 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Util +open Names +open Univ +open Term +open Constr +open Declarations +open Environ +open Entries +open Type_errors +open Context.Rel.Declaration + +(** Check name unicity. + Redundant with safe_typing's add_field checks -> to remove?. *) + +(* [check_constructors_names id s cl] checks that all the constructors names + appearing in [l] are not present in the set [s], and returns the new set + of names. The name [id] is the name of the current inductive type, used + when reporting the error. *) + +let check_constructors_names = + let rec check idset = function + | [] -> idset + | c::cl -> + if Id.Set.mem c idset then + raise (InductiveError (SameNamesConstructors c)) + else + check (Id.Set.add c idset) cl + in + check + +(* [mind_check_names mie] checks the names of an inductive types declaration, + and raises the corresponding exceptions when two types or two constructors + have the same name. *) + +let mind_check_names mie = + let rec check indset cstset = function + | [] -> () + | ind::inds -> + let id = ind.mind_entry_typename in + let cl = ind.mind_entry_consnames in + if Id.Set.mem id indset then + raise (InductiveError (SameNamesTypes id)) + else + let cstset' = check_constructors_names cstset cl in + check (Id.Set.add id indset) cstset' inds + in + check Id.Set.empty Id.Set.empty mie.mind_entry_inds +(* The above verification is not necessary from the kernel point of + vue since inductive and constructors are not referred to by their + name, but only by the name of the inductive packet and an index. *) + + +(************************************************************************) +(************************** Cumulativity checking************************) +(************************************************************************) + +(* Check arities and constructors *) +let check_subtyping_arity_constructor env subst arcn numparams is_arity = + let numchecked = ref 0 in + let basic_check ev tp = + if !numchecked < numparams then () else Reduction.conv_leq ev tp (subst tp); + numchecked := !numchecked + 1 + in + let check_typ typ typ_env = + match typ with + | LocalAssum (_, typ') -> + begin + try + basic_check typ_env typ'; Environ.push_rel typ typ_env + with Reduction.NotConvertible -> + CErrors.anomaly ~label:"bad inductive subtyping relation" + Pp.(str "Invalid subtyping relation") + end + | _ -> CErrors.anomaly Pp.(str "") + in + let typs, codom = Reduction.dest_prod env arcn in + let last_env = Context.Rel.fold_outside check_typ typs ~init:env in + if not is_arity then basic_check last_env codom else () + +let check_cumulativity univs env_ar params data = + let numparams = Context.Rel.nhyps params in + let uctx = CumulativityInfo.univ_context univs in + let new_levels = Array.init (UContext.size uctx) + (fun i -> Level.(make (UGlobal.make DirPath.empty i))) + in + let lmap = Array.fold_left2 (fun lmap u u' -> LMap.add u u' lmap) + LMap.empty (Instance.to_array @@ UContext.instance uctx) new_levels + in + let dosubst = Vars.subst_univs_level_constr lmap in + let instance_other = Instance.of_array new_levels in + let constraints_other = Univ.subst_univs_level_constraints lmap (Univ.UContext.constraints uctx) in + let uctx_other = Univ.UContext.make (instance_other, constraints_other) in + let env = Environ.push_context uctx_other env_ar in + let subtyp_constraints = + CumulativityInfo.leq_constraints univs + (UContext.instance uctx) instance_other + Constraint.empty + in + let env = Environ.add_constraints subtyp_constraints env in + (* process individual inductive types: *) + List.iter (fun (arity,lc) -> + check_subtyping_arity_constructor env dosubst arity numparams true; + Array.iter (fun cnt -> check_subtyping_arity_constructor env dosubst cnt numparams false) lc) + data + +(************************************************************************) +(************************** Type checking *******************************) +(************************************************************************) + +type univ_info = { ind_squashed : bool; + ind_min_univ : Universe.t option; (* Some for template *) + ind_univ : Universe.t } + +let check_univ_leq env u info = + let ind_univ = info.ind_univ in + if type_in_type env || (UGraph.check_leq (universes env) u ind_univ) + then { info with ind_min_univ = Option.map (Universe.sup u) info.ind_min_univ } + else if is_impredicative_univ env ind_univ + then if Option.is_empty info.ind_min_univ then { info with ind_squashed = true } + else raise (InductiveError BadUnivs) + else raise (InductiveError BadUnivs) + +let check_indices_matter env_params info indices = + let check_index d (info,env) = + let info = match d with + | LocalAssum (_,t) -> + (* could be retyping if it becomes available in the kernel *) + let tj = Typeops.infer_type env t in + check_univ_leq env (Sorts.univ_of_sort tj.utj_type) info + | LocalDef _ -> info + in + info, push_rel d env + in + if not (indices_matter env_params) then info + else fst (Context.Rel.fold_outside ~init:(info,env_params) check_index indices) + +(* env_ar contains the inductives before the current ones in the block, and no parameters *) +let check_arity env_params env_ar ind = + let {utj_val=arity;utj_type=_} = Typeops.infer_type env_params ind.mind_entry_arity in + let indices, ind_sort = Reduction.dest_arity env_params arity in + let ind_min_univ = if ind.mind_entry_template then Some Universe.type0m else None in + let univ_info = {ind_squashed=false;ind_min_univ;ind_univ=Sorts.univ_of_sort ind_sort} in + let univ_info = check_indices_matter env_params univ_info indices in + (* We do not need to generate the universe of the arity with params; + if later, after the validation of the inductive definition, + full_arity is used as argument or subject to cast, an upper + universe will be generated *) + let arity = it_mkProd_or_LetIn arity (Environ.rel_context env_params) in + push_rel (LocalAssum (Name ind.mind_entry_typename, arity)) env_ar, + (arity, indices, univ_info) + +let check_constructor_univs env_ar_par univ_info (args,_) = + (* We ignore the output, positivity will check that it's the expected inductive type *) + (* NB: very similar to check_indices_matter but that will change with SProp *) + fst (Context.Rel.fold_outside ~init:(univ_info,env_ar_par) (fun d (univ_info,env) -> + let univ_info = match d with + | LocalDef _ -> univ_info + | LocalAssum (_,t) -> + (* could be retyping if it becomes available in the kernel *) + let tj = Typeops.infer_type env t in + check_univ_leq env (Sorts.univ_of_sort tj.utj_type) univ_info + in + univ_info, push_rel d env) + args) + +let check_constructors env_ar_par params lc (arity,indices,univ_info) = + let lc = Array.map_of_list (fun c -> (Typeops.infer_type env_ar_par c).utj_val) lc in + let splayed_lc = Array.map (Reduction.dest_prod_assum env_ar_par) lc in + let univ_info = if Array.length lc <= 1 then univ_info + else check_univ_leq env_ar_par Univ.Universe.type0 univ_info + in + let univ_info = Array.fold_left (check_constructor_univs env_ar_par) univ_info splayed_lc in + (* generalize the constructors over the parameters *) + let lc = Array.map (fun c -> Term.it_mkProd_or_LetIn c params) lc in + (arity, lc), (indices, splayed_lc), univ_info + +(* Allowed eliminations *) + +(* Previous comment: *) +(* Unitary/empty Prop: elimination to all sorts are realizable *) +(* unless the type is large. If it is large, forbids large elimination *) +(* which otherwise allows simulating the inconsistent system Type:Type. *) +(* -> this is now handled by is_smashed: *) +(* - all_sorts in case of small, unitary Prop (not smashed) *) +(* - logical_sorts in case of large, unitary Prop (smashed) *) + +let all_sorts = [InProp;InSet;InType] +let small_sorts = [InProp;InSet] +let logical_sorts = [InProp] + +let allowed_sorts {ind_squashed;ind_univ;ind_min_univ=_} = + if not ind_squashed then all_sorts + else match Sorts.family (Sorts.sort_of_univ ind_univ) with + | InType -> assert false + | InSet -> small_sorts + | InProp -> logical_sorts + +(* Returns the list [x_1, ..., x_n] of levels contributing to template + polymorphism. The elements x_k is None if the k-th parameter (starting + from the most recent and ignoring let-definitions) is not contributing + or is Some u_k if its level is u_k and is contributing. *) +let param_ccls paramsctxt = + let fold acc = function + | (LocalAssum (_, p)) -> + (let c = Term.strip_prod_assum p in + match kind c with + | Sort (Type u) -> Univ.Universe.level u + | _ -> None) :: acc + | LocalDef _ -> acc + in + List.fold_left fold [] paramsctxt + +let abstract_packets univs usubst params ((arity,lc),(indices,splayed_lc),univ_info) = + let arity = Vars.subst_univs_level_constr usubst arity in + let lc = Array.map (Vars.subst_univs_level_constr usubst) lc in + let indices = Vars.subst_univs_level_context usubst indices in + let splayed_lc = Array.map (fun (args,out) -> + let args = Vars.subst_univs_level_context usubst args in + let out = Vars.subst_univs_level_constr usubst out in + args,out) + splayed_lc + in + let ind_univ = Univ.subst_univs_level_universe usubst univ_info.ind_univ in + + let arity = match univ_info.ind_min_univ with + | None -> RegularArity {mind_user_arity=arity;mind_sort=Sorts.sort_of_univ ind_univ} + | Some min_univ -> + ((match univs with + | Monomorphic_ind _ -> () + | Polymorphic_ind _ | Cumulative_ind _ -> + CErrors.anomaly ~label:"polymorphic_template_ind" + Pp.(strbrk "Template polymorphism and full polymorphism are incompatible.")); + TemplateArity {template_param_levels=param_ccls params; template_level=min_univ}) + in + + let kelim = allowed_sorts univ_info in + (arity,lc), (indices,splayed_lc), kelim + +let abstract_inductive_universes = function + | Monomorphic_ind_entry ctx -> (Univ.empty_level_subst, Monomorphic_ind ctx) + | Polymorphic_ind_entry (nas, ctx) -> + let (inst, auctx) = Univ.abstract_universes nas ctx in + let inst = Univ.make_instance_subst inst in + (inst, Polymorphic_ind auctx) + | Cumulative_ind_entry (nas, cumi) -> + let (inst, acumi) = Univ.abstract_cumulativity_info nas cumi in + let inst = Univ.make_instance_subst inst in + (inst, Cumulative_ind acumi) + +let typecheck_inductive env (mie:mutual_inductive_entry) = + let () = match mie.mind_entry_inds with + | [] -> CErrors.anomaly Pp.(str "empty inductive types declaration.") + | _ -> () + in + (* Check unicity of names (redundant with safe_typing's add_field checks) *) + mind_check_names mie; + assert (List.is_empty (Environ.rel_context env)); + + (* universes *) + let env_univs = + match mie.mind_entry_universes with + | Monomorphic_ind_entry ctx -> push_context_set ctx env + | Polymorphic_ind_entry (_, ctx) -> push_context ctx env + | Cumulative_ind_entry (_, cumi) -> push_context (Univ.CumulativityInfo.univ_context cumi) env + in + + (* Params *) + let env_params = Typeops.check_context env_univs mie.mind_entry_params in + let params = Environ.rel_context env_params in + + (* Arities *) + let env_ar, data = List.fold_left_map (check_arity env_params) env_univs mie.mind_entry_inds in + let env_ar_par = push_rel_context params env_ar in + + (* Constructors *) + let data = List.map2 (fun ind data -> check_constructors env_ar_par params ind.mind_entry_lc data) + mie.mind_entry_inds data + in + + let () = match mie.mind_entry_universes with + | Cumulative_ind_entry (_,univs) -> check_cumulativity univs env_ar params (List.map pi1 data) + | Monomorphic_ind_entry _ | Polymorphic_ind_entry _ -> () + in + + (* Abstract universes *) + let usubst, univs = abstract_inductive_universes mie.mind_entry_universes in + let params = Vars.subst_univs_level_context usubst params in + let data = List.map (abstract_packets univs usubst params) data in + + let env_ar_par = + let ctx = Environ.rel_context env_ar_par in + let ctx = Vars.subst_univs_level_context usubst ctx in + let env = Environ.pop_rel_context (Environ.nb_rel env_ar_par) env_ar_par in + Environ.push_rel_context ctx env + in + + env_ar_par, univs, params, Array.of_list data diff --git a/kernel/indTyping.mli b/kernel/indTyping.mli new file mode 100644 index 0000000000..8841e38636 --- /dev/null +++ b/kernel/indTyping.mli @@ -0,0 +1,32 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Environ +open Entries +open Declarations + +(** Type checking for some inductive entry. + Returns: + - environment with inductives + parameters in rel context + - abstracted universes + - parameters + - for each inductive, + (arity * constructors) (with params) + * (indices * splayed constructor types) (both without params) + * allowed eliminations + *) +val typecheck_inductive : env -> mutual_inductive_entry -> + env + * abstract_inductive_universes + * Constr.rel_context + * ((inductive_arity * Constr.types array) * + (Constr.rel_context * (Constr.rel_context * Constr.types) array) * + Sorts.family list) + array diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 68d44f8782..9bb848c6a4 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -11,7 +11,6 @@ open CErrors open Util open Names -open Univ open Term open Constr open Vars @@ -20,9 +19,7 @@ open Declareops open Inductive open Environ open Reduction -open Typeops open Entries -open Pp open Context.Rel.Declaration (* Terminology: @@ -49,14 +46,11 @@ let weaker_noccur_between env x nvars t = if noccur_between x nvars t' then Some t' else None -let is_constructor_head t = - isRel(fst(decompose_app t)) - (************************************************************************) (* Various well-formedness check for inductive declarations *) (* Errors related to inductive constructions *) -type inductive_error = +type inductive_error = Type_errors.inductive_error = | NonPos of env * constr * constr | NotEnoughArgs of env * constr * constr | NotConstructor of env * Id.t * constr * constr * int * int @@ -67,342 +61,9 @@ type inductive_error = | NotAnArity of env * constr | BadEntry | LargeNonPropInductiveNotInType + | BadUnivs -exception InductiveError of inductive_error - -(* [check_constructors_names id s cl] checks that all the constructors names - appearing in [l] are not present in the set [s], and returns the new set - of names. The name [id] is the name of the current inductive type, used - when reporting the error. *) - -let check_constructors_names = - let rec check idset = function - | [] -> idset - | c::cl -> - if Id.Set.mem c idset then - raise (InductiveError (SameNamesConstructors c)) - else - check (Id.Set.add c idset) cl - in - check - -(* [mind_check_names mie] checks the names of an inductive types declaration, - and raises the corresponding exceptions when two types or two constructors - have the same name. *) - -let mind_check_names mie = - let rec check indset cstset = function - | [] -> () - | ind::inds -> - let id = ind.mind_entry_typename in - let cl = ind.mind_entry_consnames in - if Id.Set.mem id indset then - raise (InductiveError (SameNamesTypes id)) - else - let cstset' = check_constructors_names cstset cl in - check (Id.Set.add id indset) cstset' inds - in - check Id.Set.empty Id.Set.empty mie.mind_entry_inds -(* The above verification is not necessary from the kernel point of - vue since inductive and constructors are not referred to by their - name, but only by the name of the inductive packet and an index. *) - -(************************************************************************) -(************************************************************************) - -(* Typing the arities and constructor types *) - -let infos_and_sort env t = - let rec aux env t max = - let t = whd_all env t in - match kind t with - | Prod (name,c1,c2) -> - let varj = infer_type env c1 in - let env1 = Environ.push_rel (LocalAssum (name,varj.utj_val)) env in - let max = Universe.sup max (Sorts.univ_of_sort varj.utj_type) in - aux env1 c2 max - | _ when is_constructor_head t -> max - | _ -> (* don't fail if not positive, it is tested later *) max - in aux env t Universe.type0m - -(* Computing the levels of polymorphic inductive types - - For each inductive type of a block that is of level u_i, we have - the constraints that u_i >= v_i where v_i is the type level of the - types of the constructors of this inductive type. Each v_i depends - of some of the u_i and of an extra (maybe non variable) universe, - say w_i that summarize all the other constraints. Typically, for - three inductive types, we could have - - u1,u2,u3,w1 <= u1 - u1 w2 <= u2 - u2,u3,w3 <= u3 - - From this system of inequations, we shall deduce - - w1,w2,w3 <= u1 - w1,w2 <= u2 - w1,w2,w3 <= u3 -*) - -(* This (re)computes informations relevant to extraction and the sort of an - arity or type constructor; we do not to recompute universes constraints *) - -let infer_constructor_packet env_ar_par params lc = - (* type-check the constructors *) - let jlc = List.map (infer_type env_ar_par) lc in - let jlc = Array.of_list jlc in - (* generalize the constructor over the parameters *) - let lc'' = Array.map (fun j -> Term.it_mkProd_or_LetIn j.utj_val params) jlc in - (* compute the max of the sorts of the products of the constructors types *) - let levels = List.map (infos_and_sort env_ar_par) lc in - let min = if Array.length jlc > 1 then Universe.type0 else Universe.type0m in - let level = List.fold_left (fun max l -> Universe.sup max l) min levels in - (lc'', level) - -(* If indices matter *) -let cumulate_arity_large_levels env sign = - fst (List.fold_right - (fun d (lev,env) -> - match d with - | LocalAssum (_,t) -> - let tj = infer_type env t in - let u = Sorts.univ_of_sort tj.utj_type in - (Universe.sup u lev, push_rel d env) - | LocalDef _ -> - lev, push_rel d env) - sign (Universe.type0m,env)) - -let is_impredicative env u = - is_type0m_univ u || (is_type0_univ u && is_impredicative_set env) - -(* Returns the list [x_1, ..., x_n] of levels contributing to template - polymorphism. The elements x_k is None if the k-th parameter (starting - from the most recent and ignoring let-definitions) is not contributing - or is Some u_k if its level is u_k and is contributing. *) -let param_ccls paramsctxt = - let fold acc = function - | (LocalAssum (_, p)) -> - (let c = Term.strip_prod_assum p in - match kind c with - | Sort (Type u) -> Univ.Universe.level u - | _ -> None) :: acc - | LocalDef _ -> acc - in - List.fold_left fold [] paramsctxt - -(* Check arities and constructors *) -let check_subtyping_arity_constructor env (subst : constr -> constr) (arcn : types) numparams is_arity = - let numchecked = ref 0 in - let basic_check ev tp = - if !numchecked < numparams then () else conv_leq ev tp (subst tp); - numchecked := !numchecked + 1 - in - let check_typ typ typ_env = - match typ with - | LocalAssum (_, typ') -> - begin - try - basic_check typ_env typ'; Environ.push_rel typ typ_env - with NotConvertible -> - anomaly ~label:"bad inductive subtyping relation" (Pp.str "Invalid subtyping relation") - end - | _ -> anomaly (Pp.str "") - in - let typs, codom = dest_prod env arcn in - let last_env = Context.Rel.fold_outside check_typ typs ~init:env in - if not is_arity then basic_check last_env codom else () - -(* Check that the subtyping information inferred for inductive types in the block is correct. *) -(* This check produces a value of the unit type if successful or raises an anomaly if check fails. *) -let check_subtyping cumi paramsctxt env_ar inds = - let numparams = Context.Rel.nhyps paramsctxt in - let uctx = CumulativityInfo.univ_context cumi in - let new_levels = Array.init (UContext.size uctx) - (fun i -> Level.make (Level.UGlobal.make DirPath.empty i)) - in - let lmap = Array.fold_left2 (fun lmap u u' -> LMap.add u u' lmap) - LMap.empty (Instance.to_array @@ UContext.instance uctx) new_levels - in - let dosubst = subst_univs_level_constr lmap in - let instance_other = Instance.of_array new_levels in - let constraints_other = Univ.subst_univs_level_constraints lmap (Univ.UContext.constraints uctx) in - let uctx_other = Univ.UContext.make (instance_other, constraints_other) in - let env = Environ.push_context uctx_other env_ar in - let subtyp_constraints = - CumulativityInfo.leq_constraints cumi - (UContext.instance uctx) instance_other - Constraint.empty - in - let env = Environ.add_constraints subtyp_constraints env in - (* process individual inductive types: *) - Array.iter (fun (_id,_cn,lc,(_sign,arity)) -> - match arity with - | RegularArity (_, full_arity, _) -> - check_subtyping_arity_constructor env dosubst full_arity numparams true; - Array.iter (fun cnt -> check_subtyping_arity_constructor env dosubst cnt numparams false) lc - | TemplateArity _ -> - anomaly ~label:"check_subtyping" - Pp.(str "template polymorphism and cumulative polymorphism are not compatible") - ) inds - -(* Type-check an inductive definition. Does not check positivity - conditions. *) -(* TODO check that we don't overgeneralize construcors/inductive arities with - universes that are absent from them. Is it possible? -*) -let typecheck_inductive env mie = - let () = match mie.mind_entry_inds with - | [] -> anomaly (Pp.str "empty inductive types declaration.") - | _ -> () - in - (* Check unicity of names *) - mind_check_names mie; - (* Params are typed-checked here *) - let env' = - match mie.mind_entry_universes with - | Monomorphic_ind_entry ctx -> push_context_set ctx env - | Polymorphic_ind_entry (_, ctx) -> push_context ctx env - | Cumulative_ind_entry (_, cumi) -> push_context (Univ.CumulativityInfo.univ_context cumi) env - in - let env_params = check_context env' mie.mind_entry_params in - let paramsctxt = mie.mind_entry_params in - (* We first type arity of each inductive definition *) - (* This allows building the environment of arities and to share *) - (* the set of constraints *) - let env_arities, rev_arity_list = - List.fold_left - (fun (env_ar,l) ind -> - (* Arities (without params) are typed-checked here *) - let template = ind.mind_entry_template in - let arity = - if isArity ind.mind_entry_arity then - let (ctx,s) = dest_arity env_params ind.mind_entry_arity in - match s with - | Type u when Univ.universe_level u = None -> - (** We have an algebraic universe as the conclusion of the arity, - typecheck the dummy Π ctx, Prop and do a special case for the conclusion. - *) - let proparity = infer_type env_params (mkArity (ctx, Sorts.prop)) in - let (cctx, _) = destArity proparity.utj_val in - (* Any universe is well-formed, we don't need to check [s] here *) - mkArity (cctx, s) - | _ -> - let arity = infer_type env_params ind.mind_entry_arity in - arity.utj_val - else let arity = infer_type env_params ind.mind_entry_arity in - arity.utj_val - in - let (sign, deflev) = dest_arity env_params arity in - let inflev = - (* The level of the inductive includes levels of indices if - in indices_matter mode *) - if indices_matter env - then Some (cumulate_arity_large_levels env_params sign) - else None - in - (* We do not need to generate the universe of full_arity; if - later, after the validation of the inductive definition, - full_arity is used as argument or subject to cast, an - upper universe will be generated *) - let full_arity = it_mkProd_or_LetIn arity paramsctxt in - let id = ind.mind_entry_typename in - let env_ar' = - push_rel (LocalAssum (Name id, full_arity)) env_ar in - (* (add_constraints cst2 env_ar) in *) - (env_ar', (id,full_arity,sign @ paramsctxt,template,deflev,inflev)::l)) - (env',[]) - mie.mind_entry_inds in - - let arity_list = List.rev rev_arity_list in - - (* builds the typing context "Gamma, I1:A1, ... In:An, params" *) - let env_ar_par = push_rel_context paramsctxt env_arities in - - (* Now, we type the constructors (without params) *) - let inds = - List.fold_right2 - (fun ind arity_data inds -> - let (lc',cstrs_univ) = - infer_constructor_packet env_ar_par paramsctxt ind.mind_entry_lc in - let consnames = ind.mind_entry_consnames in - let ind' = (arity_data,consnames,lc',cstrs_univ) in - ind'::inds) - mie.mind_entry_inds - arity_list - ([]) in - - let inds = Array.of_list inds in - - (* Compute/check the sorts of the inductive types *) - - let inds = - Array.map (fun ((id,full_arity,sign,template,def_level,inf_level),cn,lc,clev) -> - let infu = - (** Inferred level, with parameters and constructors. *) - match inf_level with - | Some alev -> Universe.sup clev alev - | None -> clev - in - let full_polymorphic () = - let defu = Sorts.univ_of_sort def_level in - let is_natural = - type_in_type env || (UGraph.check_leq (universes env') infu defu) - in - let _ = - (** Impredicative sort, always allow *) - if is_impredicative env defu then () - else (** Predicative case: the inferred level must be lower or equal to the - declared level. *) - if not is_natural then - anomaly ~label:"check_inductive" - (Pp.str"Incorrect universe " ++ - Universe.pr defu ++ Pp.str " declared for inductive type, inferred level is " - ++ Universe.pr infu ++ Pp.str ".") - in - RegularArity (not is_natural,full_arity,defu) - in - let template_polymorphic () = - let _sign, s = - try dest_arity env full_arity - with NotArity -> raise (InductiveError (NotAnArity (env, full_arity))) - in - let u = Sorts.univ_of_sort s in - (* The polymorphic level is a function of the level of the *) - (* conclusions of the parameters *) - (* We enforce [u >= lev] in case [lev] has a strict upper *) - (* constraints over [u] *) - let b = type_in_type env || UGraph.check_leq (universes env') infu u in - if not b then - anomaly ~label:"check_inductive" - (Pp.str"Incorrect universe " ++ - Universe.pr u ++ Pp.str " declared for inductive type, inferred level is " - ++ Universe.pr clev ++ Pp.str ".") - else - TemplateArity (param_ccls paramsctxt, infu) - in - let arity = - match mie.mind_entry_universes with - | Monomorphic_ind_entry _ -> - if template then template_polymorphic () - else full_polymorphic () - | Polymorphic_ind_entry _ | Cumulative_ind_entry _ -> - if template - then anomaly ~label:"polymorphic_template_ind" - Pp.(strbrk "Template polymorphism and full polymorphism are incompatible.") - else full_polymorphic () - in - (id,cn,lc,(sign,arity))) - inds - in - (* Check that the subtyping information inferred for inductive types in the block is correct. *) - (* This check produces a value of the unit type if successful or raises an anomaly if check fails. *) - let () = - match mie.mind_entry_universes with - | Monomorphic_ind_entry _ -> () - | Polymorphic_ind_entry _ -> () - | Cumulative_ind_entry (_, cumi) -> check_subtyping cumi paramsctxt env_arities inds - in (env_arities, env_ar_par, paramsctxt, inds) +exception InductiveError = Type_errors.InductiveError (************************************************************************) (************************************************************************) @@ -706,21 +367,20 @@ let check_positivity_one ~chkpos recursive (env,_,ntypes,_ as ienv) paramsctxt ( If [chkpos] is [false] then positivity is assumed, and [check_positivity_one] computes the subterms occurrences in a best-effort fashion. *) -let check_positivity ~chkpos kn env_ar_par paramsctxt finite inds = +let check_positivity ~chkpos kn names env_ar_par paramsctxt finite inds = let ntypes = Array.length inds in let recursive = finite != BiFinite in let rc = Array.mapi (fun j t -> (Mrec (kn,j),t)) (Rtree.mk_rec_calls ntypes) in let ra_env_ar = Array.rev_to_list rc in let nparamsctxt = Context.Rel.length paramsctxt in let nmr = Context.Rel.nhyps paramsctxt in - let check_one i (_,lcnames,lc,(sign,_)) = + let check_one i (_,lcnames) (nindices,lc) = let ra_env_ar_par = List.init nparamsctxt (fun _ -> (Norec,mk_norec)) @ ra_env_ar in let ienv = (env_ar_par, 1+nparamsctxt, ntypes, ra_env_ar_par) in - let nnonrecargs = Context.Rel.nhyps sign - nmr in - check_positivity_one ~chkpos recursive ienv paramsctxt (kn,i) nnonrecargs lcnames lc + check_positivity_one ~chkpos recursive ienv paramsctxt (kn,i) nindices lcnames lc in - let irecargs_nmr = Array.mapi check_one inds in + let irecargs_nmr = Array.map2_i check_one names inds in let irecargs = Array.map snd irecargs_nmr and nmr' = array_min nmr irecargs_nmr in (nmr',Rtree.mk_rec irecargs) @@ -730,48 +390,17 @@ let check_positivity ~chkpos kn env_ar_par paramsctxt finite inds = (************************************************************************) (* Build the inductive packet *) -(* Allowed eliminations *) - -let all_sorts = [InProp;InSet;InType] -let small_sorts = [InProp;InSet] -let logical_sorts = [InProp] - -let allowed_sorts is_smashed s = - if not is_smashed - then (** Naturally in the defined sort. - If [s] is Prop, it must be small and unitary. - Unsmashed, predicative Type and Set: all elimination allowed - as well. *) - all_sorts - else - match Sorts.family s with - (* Type: all elimination allowed: above and below *) - | InType -> all_sorts - (* Smashed Set is necessarily impredicative: forbids large elimination *) - | InSet -> small_sorts - (* Smashed to Prop, no informative eliminations allowed *) - | InProp -> logical_sorts - -(* Previous comment: *) -(* Unitary/empty Prop: elimination to all sorts are realizable *) -(* unless the type is large. If it is large, forbids large elimination *) -(* which otherwise allows simulating the inconsistent system Type:Type. *) -(* -> this is now handled by is_smashed: *) -(* - all_sorts in case of small, unitary Prop (not smashed) *) -(* - logical_sorts in case of large, unitary Prop (smashed) *) - -let arity_conclusion = function - | RegularArity (_, c, _) -> c - | TemplateArity (_, s) -> mkType s +let repair_arity indices = function + | RegularArity ar -> ar.mind_user_arity + | TemplateArity ar -> mkArity (indices,Sorts.sort_of_univ ar.template_level) let fold_inductive_blocks f = - Array.fold_left (fun acc (_,_,lc,(arsign,ar)) -> - f (Array.fold_left f acc lc) (it_mkProd_or_LetIn (arity_conclusion ar) arsign)) + Array.fold_left (fun acc ((arity,lc),(indices,_),_) -> + f (Array.fold_left f acc lc) (repair_arity indices arity)) let used_section_variables env inds = - let ids = fold_inductive_blocks - (fun l c -> Id.Set.union (Environ.global_vars_set env c) l) - Id.Set.empty inds in + let fold l c = Id.Set.union (Environ.global_vars_set env c) l in + let ids = fold_inductive_blocks fold Id.Set.empty inds in keep_hyps env ids let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) @@ -842,56 +471,21 @@ let compute_projections (kn, i as ind) mib = Array.of_list (List.rev labs), Array.of_list (List.rev pbs) -let abstract_inductive_universes iu = - match iu with - | Monomorphic_ind_entry ctx -> (Univ.empty_level_subst, Monomorphic_ind ctx) - | Polymorphic_ind_entry (nas, ctx) -> - let (inst, auctx) = Univ.abstract_universes nas ctx in - let inst = Univ.make_instance_subst inst in - (inst, Polymorphic_ind auctx) - | Cumulative_ind_entry (nas, cumi) -> - let (inst, acumi) = Univ.abstract_cumulativity_info nas cumi in - let inst = Univ.make_instance_subst inst in - (inst, Cumulative_ind acumi) - -let build_inductive env prv iu env_ar paramsctxt kn isrecord isfinite inds nmr recargs = +let build_inductive env names prv univs paramsctxt kn isrecord isfinite inds nmr recargs = let ntypes = Array.length inds in (* Compute the set of used section variables *) let hyps = used_section_variables env inds in let nparamargs = Context.Rel.nhyps paramsctxt in - let nparamsctxt = Context.Rel.length paramsctxt in - let substunivs, aiu = abstract_inductive_universes iu in - let paramsctxt = Vars.subst_univs_level_context substunivs paramsctxt in - let env_ar = - let ctxunivs = Environ.rel_context env_ar in - let ctxunivs' = Vars.subst_univs_level_context substunivs ctxunivs in - Environ.push_rel_context ctxunivs' env - in (* Check one inductive *) - let build_one_packet (id,cnames,lc,(ar_sign,ar_kind)) recarg = + let build_one_packet (id,cnames) ((arity,lc),(indices,splayed_lc),kelim) recarg = (* Type of constructors in normal form *) - let lc = Array.map (Vars.subst_univs_level_constr substunivs) lc in - let splayed_lc = Array.map (dest_prod_assum env_ar) lc in - let nf_lc = Array.map (fun (d,b) -> it_mkProd_or_LetIn b d) splayed_lc in + let nf_lc = Array.map (fun (d,b) -> it_mkProd_or_LetIn b (d@paramsctxt)) splayed_lc in let consnrealdecls = - Array.map (fun (d,_) -> Context.Rel.length d - nparamsctxt) + Array.map (fun (d,_) -> Context.Rel.length d) splayed_lc in let consnrealargs = - Array.map (fun (d,_) -> Context.Rel.nhyps d - nparamargs) + Array.map (fun (d,_) -> Context.Rel.nhyps d) splayed_lc in - (* Elimination sorts *) - let arkind,kelim = - match ar_kind with - | TemplateArity (paramlevs, lev) -> - let ar = {template_param_levels = paramlevs; template_level = lev} in - TemplateArity ar, all_sorts - | RegularArity (info,ar,defs) -> - let s = Sorts.sort_of_univ defs in - let kelim = allowed_sorts info s in - let ar = RegularArity - { mind_user_arity = Vars.subst_univs_level_constr substunivs ar; - mind_sort = Sorts.sort_of_univ (Univ.subst_univs_level_universe substunivs defs); } in - ar, kelim in (* Assigning VM tags to constructors *) let nconst, nblock = ref 0, ref 0 in let transf num = @@ -908,10 +502,10 @@ let build_inductive env prv iu env_ar paramsctxt kn isrecord isfinite inds nmr r let rtbl = Array.init (List.length cnames) transf in (* Build the inductive packet *) { mind_typename = id; - mind_arity = arkind; - mind_arity_ctxt = Vars.subst_univs_level_context substunivs ar_sign; - mind_nrealargs = Context.Rel.nhyps ar_sign - nparamargs; - mind_nrealdecls = Context.Rel.length ar_sign - nparamsctxt; + mind_arity = arity; + mind_arity_ctxt = indices @ paramsctxt; + mind_nrealargs = Context.Rel.nhyps indices; + mind_nrealdecls = Context.Rel.length indices; mind_kelim = kelim; mind_consnames = Array.of_list cnames; mind_consnrealdecls = consnrealdecls; @@ -923,7 +517,7 @@ let build_inductive env prv iu env_ar paramsctxt kn isrecord isfinite inds nmr r mind_nb_args = !nblock; mind_reloc_tbl = rtbl; } in - let packets = Array.map2 build_one_packet inds recargs in + let packets = Array.map3 build_one_packet names inds recargs in let mib = (* Build the mutual inductive *) { mind_record = NotRecord; @@ -934,7 +528,7 @@ let build_inductive env prv iu env_ar paramsctxt kn isrecord isfinite inds nmr r mind_nparams_rec = nmr; mind_params_ctxt = paramsctxt; mind_packets = packets; - mind_universes = aiu; + mind_universes = univs; mind_private = prv; mind_typing_flags = Environ.typing_flags env; } @@ -942,7 +536,7 @@ let build_inductive env prv iu env_ar paramsctxt kn isrecord isfinite inds nmr r let record_info = match isrecord with | Some (Some rid) -> let is_record pkt = - pkt.mind_kelim == all_sorts + List.exists (Sorts.family_equal Sorts.InType) pkt.mind_kelim && Array.length pkt.mind_consnames == 1 && pkt.mind_consnrealargs.(0) > 0 in @@ -965,11 +559,17 @@ let build_inductive env prv iu env_ar paramsctxt kn isrecord isfinite inds nmr r let check_inductive env kn mie = (* First type-check the inductive definition *) - let (env_ar, env_ar_par, paramsctxt, inds) = typecheck_inductive env mie in + let (env_ar_par, univs, paramsctxt, inds) = IndTyping.typecheck_inductive env mie in (* Then check positivity conditions *) let chkpos = (Environ.typing_flags env).check_guarded in - let (nmr,recargs) = check_positivity ~chkpos kn env_ar_par paramsctxt mie.mind_entry_finite inds in + let names = Array.map_of_list (fun entry -> entry.mind_entry_typename, entry.mind_entry_consnames) + mie.mind_entry_inds + in + let (nmr,recargs) = check_positivity ~chkpos kn names + env_ar_par paramsctxt mie.mind_entry_finite + (Array.map (fun ((_,lc),(indices,_),_) -> Context.Rel.nhyps indices,lc) inds) + in (* Build the inductive packets *) - build_inductive env mie.mind_entry_private mie.mind_entry_universes - env_ar paramsctxt kn mie.mind_entry_record mie.mind_entry_finite + build_inductive env names mie.mind_entry_private univs + paramsctxt kn mie.mind_entry_record mie.mind_entry_finite inds nmr recargs diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli index 840e23ed69..7810c1723e 100644 --- a/kernel/indtypes.mli +++ b/kernel/indtypes.mli @@ -14,12 +14,10 @@ open Declarations open Environ open Entries -(** Inductive type checking and errors *) - -(** The different kinds of errors that may result of a malformed inductive - definition. *) +(** Check an inductive. *) +val check_inductive : env -> MutInd.t -> mutual_inductive_entry -> mutual_inductive_body -(** Errors related to inductive constructions *) +(** Deprecated *) type inductive_error = | NonPos of env * constr * constr | NotEnoughArgs of env * constr * constr @@ -31,22 +29,8 @@ type inductive_error = | NotAnArity of env * constr | BadEntry | LargeNonPropInductiveNotInType + | BadUnivs +[@@ocaml.deprecated "Use [Type_errors.inductive_error]"] -exception InductiveError of inductive_error - -val infos_and_sort : env -> constr -> Univ.Universe.t - -val check_subtyping_arity_constructor : env -> (constr -> constr) -> types -> int -> bool -> unit - -val check_positivity : chkpos:bool -> - Names.MutInd.t -> - Environ.env -> - (Constr.constr, Constr.types) Context.Rel.pt -> - Declarations.recursivity_kind -> - ('a * Names.Id.t list * Constr.types array * - (('b, 'c) Context.Rel.pt * 'd)) - array -> Int.t * Declarations.recarg Rtree.t array - -(** The following function does checks on inductive declarations. *) - -val check_inductive : env -> MutInd.t -> mutual_inductive_entry -> mutual_inductive_body +exception InductiveError of Type_errors.inductive_error +[@@ocaml.deprecated "Use [Type_errors.InductiveError]"] diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib index 54c239349d..0b10e788b6 100644 --- a/kernel/kernel.mllib +++ b/kernel/kernel.mllib @@ -39,6 +39,7 @@ Type_errors Modops Inductive Typeops +IndTyping Indtypes Cooking Term_typing diff --git a/kernel/names.ml b/kernel/names.ml index b2d6a489a6..9f27212967 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -391,6 +391,8 @@ module KerName = struct let print kn = str (to_string kn) + let debug_print kn = str (debug_to_string kn) + let compare (kn1 : kernel_name) (kn2 : kernel_name) = if kn1 == kn2 then 0 else diff --git a/kernel/names.mli b/kernel/names.mli index 350db871d5..61df3bad0e 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -149,15 +149,15 @@ sig val is_empty : t -> bool (** Test whether a directory path is empty. *) - val to_string : t -> string - (** Print directory paths as ["coq_root.module.submodule"] *) - val initial : t (** Initial "seed" of the unique identifier generator *) val hcons : t -> t (** Hashconsing of directory paths. *) + val to_string : t -> string + (** Print non-empty directory paths as ["coq_root.module.submodule"] *) + val print : t -> Pp.t end @@ -180,15 +180,15 @@ sig val make : string -> t (** Create a label out of a string. *) - val to_string : t -> string - (** Conversion to string. *) - val of_id : Id.t -> t (** Conversion from an identifier. *) val to_id : t -> Id.t (** Conversion to an identifier. *) + val to_string : t -> string + (** Conversion to string. *) + val print : t -> Pp.t (** Pretty-printer. *) @@ -227,10 +227,10 @@ sig (** Return the identifier contained in the argument. *) val to_string : t -> string - (** Conversion to a string. *) + (** Encode as a string (not to be used for user-facing messages). *) val debug_to_string : t -> string - (** Same as [to_string], but outputs information related to debug. *) + (** Same as [to_string], but outputs extra information related to debug. *) end @@ -252,16 +252,17 @@ sig val is_bound : t -> bool - val to_string : t -> string - - val debug_to_string : t -> string - (** Same as [to_string], but outputs information related to debug. *) - val initial : t (** Name of the toplevel structure ([= MPfile initial_dir]) *) val dp : t -> DirPath.t + val to_string : t -> string + (** Encode as a string (not to be used for user-facing messages). *) + + val debug_to_string : t -> string + (** Same as [to_string], but outputs extra information related to debug. *) + end module MPset : Set.S with type elt = ModPath.t @@ -284,13 +285,17 @@ sig val modpath : t -> ModPath.t val label : t -> Label.t - (** Display *) val to_string : t -> string + (** Encode as a string (not to be used for user-facing messages). *) + + val print : t -> Pp.t + (** Print internal representation (not to be used for user-facing messages). *) val debug_to_string : t -> string - (** Same as [to_string], but outputs information related to debug. *) + (** Same as [to_string], but outputs extra information related to debug. *) - val print : t -> Pp.t + val debug_print : t -> Pp.t + (** Same as [print], but outputs extra information related to debug. *) (** Comparisons *) val compare : t -> t -> int @@ -365,9 +370,16 @@ sig (** Displaying *) val to_string : t -> string + (** Encode as a string (not to be used for user-facing messages). *) + val print : t -> Pp.t + (** Print internal representation (not to be used for user-facing messages). *) + val debug_to_string : t -> string + (** Same as [to_string], but outputs extra information related to debug. *) + val debug_print : t -> Pp.t + (** Same as [print], but outputs extra information related to debug. *) end @@ -444,9 +456,16 @@ sig (** Displaying *) val to_string : t -> string + (** Encode as a string (not to be used for user-facing messages). *) + val print : t -> Pp.t + (** Print internal representation (not to be used for user-facing messages). *) + val debug_to_string : t -> string + (** Same as [to_string], but outputs extra information related to debug. *) + val debug_print : t -> Pp.t + (** Same as [print], but outputs extra information related to debug. *) end @@ -567,8 +586,12 @@ module Projection : sig val map : (MutInd.t -> MutInd.t) -> t -> t val map_npars : (MutInd.t -> int -> MutInd.t * int) -> t -> t - val print : t -> Pp.t val to_string : t -> string + (** Encode as a string (not to be used for user-facing messages). *) + + val print : t -> Pp.t + (** Print internal representation (not to be used for user-facing messages). *) + end type t (* = Repr.t * bool *) @@ -609,7 +632,10 @@ module Projection : sig val map_npars : (MutInd.t -> int -> MutInd.t * int) -> t -> t val to_string : t -> string + (** Encode as a string (not to be used for user-facing messages). *) + val print : t -> Pp.t + (** Print internal representation (not to be used for user-facing messages). *) end diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml index 60293fe864..fd050085d7 100644 --- a/kernel/type_errors.ml +++ b/kernel/type_errors.ml @@ -68,6 +68,21 @@ type type_error = (constr, types) ptype_error exception TypeError of env * type_error +type inductive_error = + | NonPos of env * constr * constr + | NotEnoughArgs of env * constr * constr + | NotConstructor of env * Id.t * constr * constr * int * int + | NonPar of env * constr * int * constr * constr + | SameNamesTypes of Id.t + | SameNamesConstructors of Id.t + | SameNamesOverlap of Id.t list + | NotAnArity of env * constr + | BadEntry + | LargeNonPropInductiveNotInType + | BadUnivs + +exception InductiveError of inductive_error + let nfj env {uj_val=c;uj_type=ct} = {uj_val=c;uj_type=nf_betaiota env ct} diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli index 3fd40a7f42..3e954d6a8e 100644 --- a/kernel/type_errors.mli +++ b/kernel/type_errors.mli @@ -69,6 +69,25 @@ type type_error = (constr, types) ptype_error exception TypeError of env * type_error +(** The different kinds of errors that may result of a malformed inductive + definition. *) +type inductive_error = + | NonPos of env * constr * constr + | NotEnoughArgs of env * constr * constr + | NotConstructor of env * Id.t * constr * constr * int * int + | NonPar of env * constr * int * constr * constr + | SameNamesTypes of Id.t + | SameNamesConstructors of Id.t + | SameNamesOverlap of Id.t list + | NotAnArity of env * constr + | BadEntry + | LargeNonPropInductiveNotInType + | BadUnivs + +exception InductiveError of inductive_error + +(** Raising functions *) + val error_unbound_rel : env -> int -> 'a val error_unbound_var : env -> variable -> 'a diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index 5fc8d0297f..8187dea41b 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -8,749 +8,80 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Pp -open Util open Univ -(* Created in Caml by Gérard Huet for CoC 4.8 [Dec 1988] *) -(* Functional code by Jean-Christophe Filliâtre for Coq V7.0 [1999] *) -(* Extension with algebraic universes by HH for Coq V7.0 [Sep 2001] *) -(* Additional support for sort-polymorphic inductive types by HH [Mar 2006] *) -(* Support for universe polymorphism by MS [2014] *) +module G = AcyclicGraph.Make(struct + type t = Level.t + module Set = LSet + module Map = LMap + module Constraint = Constraint -(* Revisions by Bruno Barras, Hugo Herbelin, Pierre Letouzey, Matthieu - Sozeau, Pierre-Marie Pédrot, Jacques-Henri Jourdan *) + let equal = Level.equal + let compare = Level.compare -let error_inconsistency o u v p = - raise (UniverseInconsistency (o,Universe.make u,Universe.make v,p)) + type explanation = Univ.explanation + let error_inconsistency d u v p = + raise (UniverseInconsistency (d,Universe.make u, Universe.make v, p)) -(* Universes are stratified by a partial ordering $\le$. - Let $\~{}$ be the associated equivalence. We also have a strict ordering - $<$ between equivalence classes, and we maintain that $<$ is acyclic, - and contained in $\le$ in the sense that $[U]<[V]$ implies $U\le V$. + let pr = Level.pr + end) [@@inlined] (* without inline, +1% ish on HoTT, compcert. See jenkins 594 vs 596 *) +(* Do not include G to make it easier to control universe specific + code (eg add_universe with a constraint vs G.add with no + constraint) *) - At every moment, we have a finite number of universes, and we - maintain the ordering in the presence of assertions $U<V$ and $U\le V$. - - The equivalence $\~{}$ is represented by a tree structure, as in the - union-find algorithm. The assertions $<$ and $\le$ are represented by - adjacency lists. - - We use the algorithm described in the paper: - - Bender, M. A., Fineman, J. T., Gilbert, S., & Tarjan, R. E. (2011). A - new approach to incremental cycle detection and related - problems. arXiv preprint arXiv:1112.0784. - - *) - -open Universe - -module UMap = LMap - -type status = NoMark | Visited | WeakVisited | ToMerge - -(* Comparison on this type is pointer equality *) -type canonical_node = - { univ: Level.t; - ltle: bool UMap.t; (* true: strict (lt) constraint. - false: weak (le) constraint. *) - gtge: LSet.t; - rank : int; - klvl: int; - ilvl: int; - mutable status: status - } - -let big_rank = 1000000 - -(* A Level.t is either an alias for another one, or a canonical one, - for which we know the universes that are above *) - -type univ_entry = - Canonical of canonical_node - | Equiv of Level.t - -type universes = - { entries : univ_entry UMap.t; - index : int; - n_nodes : int; n_edges : int } - -type t = universes - -(** Used to cleanup universes if a traversal function is interrupted before it - has the opportunity to do it itself. *) -let unsafe_cleanup_universes g = - let iter _ n = match n with - | Equiv _ -> () - | Canonical n -> n.status <- NoMark - in - UMap.iter iter g.entries - -let rec cleanup_universes g = - try unsafe_cleanup_universes g - with e -> - (** The only way unsafe_cleanup_universes may raise an exception is when - a serious error (stack overflow, out of memory) occurs, or a signal is - sent. In this unlikely event, we relaunch the cleanup until we finally - succeed. *) - cleanup_universes g; raise e - -(* Every Level.t has a unique canonical arc representative *) - -(* Low-level function : makes u an alias for v. - Does not removes edges from n_edges, but decrements n_nodes. - u should be entered as canonical before. *) -let enter_equiv g u v = - { entries = - UMap.modify u (fun _ a -> - match a with - | Canonical n -> - n.status <- NoMark; - Equiv v - | _ -> assert false) g.entries; - index = g.index; - n_nodes = g.n_nodes - 1; - n_edges = g.n_edges } - -(* Low-level function : changes data associated with a canonical node. - Resets the mutable fields in the old record, in order to avoid breaking - invariants for other users of this record. - n.univ should already been inserted as a canonical node. *) -let change_node g n = - { g with entries = - UMap.modify n.univ - (fun _ a -> - match a with - | Canonical n' -> - n'.status <- NoMark; - Canonical n - | _ -> assert false) - g.entries } - -(* repr : universes -> Level.t -> canonical_node *) -(* canonical representative : we follow the Equiv links *) -let rec repr g u = - let a = - try UMap.find u g.entries - with Not_found -> CErrors.anomaly ~label:"Univ.repr" - (str"Universe " ++ Level.pr u ++ str" undefined.") - in - match a with - | Equiv v -> repr g v - | Canonical arc -> arc - -let get_set_arc g = repr g Level.set -let is_set_arc u = Level.is_set u.univ -let is_prop_arc u = Level.is_prop u.univ - -exception AlreadyDeclared - -(* Reindexes the given universe, using the next available index. *) -let use_index g u = - let u = repr g u in - let g = change_node g { u with ilvl = g.index } in - assert (g.index > min_int); - { g with index = g.index - 1 } - -(* [safe_repr] is like [repr] but if the graph doesn't contain the - searched universe, we add it. *) -let safe_repr g u = - let rec safe_repr_rec entries u = - match UMap.find u entries with - | Equiv v -> safe_repr_rec entries v - | Canonical arc -> arc - in - try g, safe_repr_rec g.entries u - with Not_found -> - let can = - { univ = u; - ltle = UMap.empty; gtge = LSet.empty; - rank = if Level.is_small u then big_rank else 0; - klvl = 0; ilvl = 0; - status = NoMark } - in - let g = { g with - entries = UMap.add u (Canonical can) g.entries; - n_nodes = g.n_nodes + 1 } - in - let g = use_index g u in - g, repr g u - -(* Returns 1 if u is higher than v in topological order. - -1 lower - 0 if u = v *) -let topo_compare u v = - if u.klvl > v.klvl then 1 - else if u.klvl < v.klvl then -1 - else if u.ilvl > v.ilvl then 1 - else if u.ilvl < v.ilvl then -1 - else (assert (u==v); 0) - -(* Checks most of the invariants of the graph. For debugging purposes. *) -let check_universes_invariants g = - let n_edges = ref 0 in - let n_nodes = ref 0 in - UMap.iter (fun l u -> - match u with - | Canonical u -> - UMap.iter (fun v _strict -> - incr n_edges; - let v = repr g v in - assert (topo_compare u v = -1); - if u.klvl = v.klvl then - assert (LSet.mem u.univ v.gtge || - LSet.exists (fun l -> u == repr g l) v.gtge)) - u.ltle; - LSet.iter (fun v -> - let v = repr g v in - assert (v.klvl = u.klvl && - (UMap.mem u.univ v.ltle || - UMap.exists (fun l _ -> u == repr g l) v.ltle)) - ) u.gtge; - assert (u.status = NoMark); - assert (Level.equal l u.univ); - assert (u.ilvl > g.index); - assert (not (UMap.mem u.univ u.ltle)); - incr n_nodes - | Equiv _ -> assert (not (Level.is_small l))) - g.entries; - assert (!n_edges = g.n_edges); - assert (!n_nodes = g.n_nodes) - -let clean_ltle g ltle = - UMap.fold (fun u strict acc -> - let uu = (repr g u).univ in - if Level.equal uu u then acc - else ( - let acc = UMap.remove u (fst acc) in - if not strict && UMap.mem uu acc then (acc, true) - else (UMap.add uu strict acc, true))) - ltle (ltle, false) - -let clean_gtge g gtge = - LSet.fold (fun u acc -> - let uu = (repr g u).univ in - if Level.equal uu u then acc - else LSet.add uu (LSet.remove u (fst acc)), true) - gtge (gtge, false) - -(* [get_ltle] and [get_gtge] return ltle and gtge arcs. - Moreover, if one of these lists is dirty (e.g. points to a - non-canonical node), these functions clean this node in the - graph by removing some duplicate edges *) -let get_ltle g u = - let ltle, chgt_ltle = clean_ltle g u.ltle in - if not chgt_ltle then u.ltle, u, g - else - let sz = UMap.cardinal u.ltle in - let sz2 = UMap.cardinal ltle in - let u = { u with ltle } in - let g = change_node g u in - let g = { g with n_edges = g.n_edges + sz2 - sz } in - u.ltle, u, g - -let get_gtge g u = - let gtge, chgt_gtge = clean_gtge g u.gtge in - if not chgt_gtge then u.gtge, u, g - else - let u = { u with gtge } in - let g = change_node g u in - u.gtge, u, g - -(* [revert_graph] rollbacks the changes made to mutable fields in - nodes in the graph. - [to_revert] contains the touched nodes. *) -let revert_graph to_revert g = - List.iter (fun t -> - match UMap.find t g.entries with - | Equiv _ -> () - | Canonical t -> - t.status <- NoMark) to_revert - -exception AbortBackward of universes -exception CycleDetected - -(* Implementation of the algorithm described in § 5.1 of the following paper: - - Bender, M. A., Fineman, J. T., Gilbert, S., & Tarjan, R. E. (2011). A - new approach to incremental cycle detection and related - problems. arXiv preprint arXiv:1112.0784. - - The "STEP X" comments contained in this file refers to the - corresponding step numbers of the algorithm described in Section - 5.1 of this paper. *) - -(* [delta] is the timeout for backward search. It might be - useful to tune a multiplicative constant. *) -let get_delta g = - int_of_float - (min (float_of_int g.n_edges ** 0.5) - (float_of_int g.n_nodes ** (2./.3.))) - -let rec backward_traverse to_revert b_traversed count g x = - let x = repr g x in - let count = count - 1 in - if count < 0 then begin - revert_graph to_revert g; - raise (AbortBackward g) - end; - if x.status = NoMark then begin - x.status <- Visited; - let to_revert = x.univ::to_revert in - let gtge, x, g = get_gtge g x in - let to_revert, b_traversed, count, g = - LSet.fold (fun y (to_revert, b_traversed, count, g) -> - backward_traverse to_revert b_traversed count g y) - gtge (to_revert, b_traversed, count, g) - in - to_revert, x.univ::b_traversed, count, g - end - else to_revert, b_traversed, count, g - -let rec forward_traverse f_traversed g v_klvl x y = - let y = repr g y in - if y.klvl < v_klvl then begin - let y = { y with klvl = v_klvl; - gtge = if x == y then LSet.empty - else LSet.singleton x.univ } - in - let g = change_node g y in - let ltle, y, g = get_ltle g y in - let f_traversed, g = - UMap.fold (fun z _ (f_traversed, g) -> - forward_traverse f_traversed g v_klvl y z) - ltle (f_traversed, g) - in - y.univ::f_traversed, g - end else if y.klvl = v_klvl && x != y then - let g = change_node g - { y with gtge = LSet.add x.univ y.gtge } in - f_traversed, g - else f_traversed, g - -let rec find_to_merge to_revert g x v = - let x = repr g x in - match x.status with - | Visited -> false, to_revert | ToMerge -> true, to_revert - | NoMark -> - let to_revert = x::to_revert in - if Level.equal x.univ v then - begin x.status <- ToMerge; true, to_revert end - else - begin - let merge, to_revert = LSet.fold - (fun y (merge, to_revert) -> - let merge', to_revert = find_to_merge to_revert g y v in - merge' || merge, to_revert) x.gtge (false, to_revert) - in - x.status <- if merge then ToMerge else Visited; - merge, to_revert - end - | _ -> assert false - -let get_new_edges g to_merge = - (* Computing edge sets. *) - let to_merge_lvl = - List.fold_left (fun acc u -> UMap.add u.univ u acc) - UMap.empty to_merge - in - let ltle = - let fold _ n acc = - let fold u strict acc = - if strict then UMap.add u strict acc - else if UMap.mem u acc then acc - else UMap.add u false acc - in - UMap.fold fold n.ltle acc - in - UMap.fold fold to_merge_lvl UMap.empty - in - let ltle, _ = clean_ltle g ltle in - let ltle = - UMap.merge (fun _ a strict -> - match a, strict with - | Some _, Some true -> - (* There is a lt edge inside the new component. This is a - "bad cycle". *) - raise CycleDetected - | Some _, Some false -> None - | _, _ -> strict - ) to_merge_lvl ltle - in - let gtge = - UMap.fold (fun _ n acc -> LSet.union acc n.gtge) - to_merge_lvl LSet.empty - in - let gtge, _ = clean_gtge g gtge in - let gtge = LSet.diff gtge (UMap.domain to_merge_lvl) in - (ltle, gtge) - - -let reorder g u v = - (* STEP 2: backward search in the k-level of u. *) - let delta = get_delta g in - - (* [v_klvl] is the chosen future level for u, v and all - traversed nodes. *) - let b_traversed, v_klvl, g = - try - let to_revert, b_traversed, _, g = backward_traverse [] [] delta g u in - revert_graph to_revert g; - let v_klvl = (repr g u).klvl in - b_traversed, v_klvl, g - with AbortBackward g -> - (* Backward search was too long, use the next k-level. *) - let v_klvl = (repr g u).klvl + 1 in - [], v_klvl, g - in - let f_traversed, g = - (* STEP 3: forward search. Contrary to what is described in - the paper, we do not test whether v_klvl = u.klvl nor we assign - v_klvl to v.klvl. Indeed, the first call to forward_traverse - will do all that. *) - forward_traverse [] g v_klvl (repr g v) v - in - - (* STEP 4: merge nodes if needed. *) - let to_merge, b_reindex, f_reindex = - if (repr g u).klvl = v_klvl then - begin - let merge, to_revert = find_to_merge [] g u v in - let r = - if merge then - List.filter (fun u -> u.status = ToMerge) to_revert, - List.filter (fun u -> (repr g u).status <> ToMerge) b_traversed, - List.filter (fun u -> (repr g u).status <> ToMerge) f_traversed - else [], b_traversed, f_traversed - in - List.iter (fun u -> u.status <- NoMark) to_revert; - r - end - else [], b_traversed, f_traversed - in - let to_reindex, g = - match to_merge with - | [] -> List.rev_append f_reindex b_reindex, g - | n0::q0 -> - (* Computing new root. *) - let root, rank_rest = - List.fold_left (fun ((best, _rank_rest) as acc) n -> - if n.rank >= best.rank then n, best.rank else acc) - (n0, min_int) q0 - in - let ltle, gtge = get_new_edges g to_merge in - (* Inserting the new root. *) - let g = change_node g - { root with ltle; gtge; - rank = max root.rank (rank_rest + 1); } - in - - (* Inserting shortcuts for old nodes. *) - let g = List.fold_left (fun g n -> - if Level.equal n.univ root.univ then g else enter_equiv g n.univ root.univ) - g to_merge - in - - (* Updating g.n_edges *) - let oldsz = - List.fold_left (fun sz u -> sz+UMap.cardinal u.ltle) - 0 to_merge - in - let sz = UMap.cardinal ltle in - let g = { g with n_edges = g.n_edges + sz - oldsz } in - - (* Not clear in the paper: we have to put the newly - created component just between B and F. *) - List.rev_append f_reindex (root.univ::b_reindex), g - - in - - (* STEP 5: reindex traversed nodes. *) - List.fold_left use_index g to_reindex - -(* Assumes [u] and [v] are already in the graph. *) -(* Does NOT assume that ucan != vcan. *) -let insert_edge strict ucan vcan g = - try - let u = ucan.univ and v = vcan.univ in - (* STEP 1: do we need to reorder nodes ? *) - let g = if topo_compare ucan vcan <= 0 then g else reorder g u v in - - (* STEP 6: insert the new edge in the graph. *) - let u = repr g u in - let v = repr g v in - if u == v then - if strict then raise CycleDetected else g - else - let g = - try let oldstrict = UMap.find v.univ u.ltle in - if strict && not oldstrict then - change_node g { u with ltle = UMap.add v.univ true u.ltle } - else g - with Not_found -> - { (change_node g { u with ltle = UMap.add v.univ strict u.ltle }) - with n_edges = g.n_edges + 1 } - in - if u.klvl <> v.klvl || LSet.mem u.univ v.gtge then g - else - let v = { v with gtge = LSet.add u.univ v.gtge } in - change_node g v - with - | CycleDetected as e -> raise e - | e -> - (** Unlikely event: fatal error or signal *) - let () = cleanup_universes g in - raise e - -let add_universe_gen vlev g = - try - let _arcv = UMap.find vlev g.entries in - raise AlreadyDeclared - with Not_found -> - assert (g.index > min_int); - let v = { - univ = vlev; - ltle = LMap.empty; - gtge = LSet.empty; - rank = 0; - klvl = 0; - ilvl = g.index; - status = NoMark; - } - in - let entries = UMap.add vlev (Canonical v) g.entries in - { entries; index = g.index - 1; n_nodes = g.n_nodes + 1; n_edges = g.n_edges }, v - -let add_universe vlev strict g = - let g, v = add_universe_gen vlev g in - insert_edge strict (get_set_arc g) v g - -let add_universe_unconstrained vlev g = - fst (add_universe_gen vlev g) - -exception UndeclaredLevel of Univ.Level.t -let check_declared_universes g us = - let check l = if not (UMap.mem l g.entries) then raise (UndeclaredLevel l) in - Univ.LSet.iter check us - -exception Found_explanation of explanation - -let get_explanation strict u v g = - let v = repr g v in - let visited_strict = ref UMap.empty in - let rec traverse strict u = - if u == v then - if strict then None else Some [] - else if topo_compare u v = 1 then None - else - let visited = - try not (UMap.find u.univ !visited_strict) || strict - with Not_found -> false - in - if visited then None - else begin - visited_strict := UMap.add u.univ strict !visited_strict; - try - UMap.iter (fun u' strictu' -> - match traverse (strict && not strictu') (repr g u') with - | None -> () - | Some exp -> - let typ = if strictu' then Lt else Le in - raise (Found_explanation ((typ, make u') :: exp))) - u.ltle; - None - with Found_explanation exp -> Some exp - end - in - let u = repr g u in - if u == v then [(Eq, make v.univ)] - else match traverse strict u with Some exp -> exp | None -> assert false - -let get_explanation strict u v g = - Some (lazy (get_explanation strict u v g)) - -(* To compare two nodes, we simply do a forward search. - We implement two improvements: - - we ignore nodes that are higher than the destination; - - we do a BFS rather than a DFS because we expect to have a short - path (typically, the shortest path has length 1) -*) -exception Found of canonical_node list -let search_path strict u v g = - let rec loop to_revert todo next_todo = - match todo, next_todo with - | [], [] -> to_revert (* No path found *) - | [], _ -> loop to_revert next_todo [] - | (u, strict)::todo, _ -> - if u.status = Visited || (u.status = WeakVisited && strict) - then loop to_revert todo next_todo - else - let to_revert = - if u.status = NoMark then u::to_revert else to_revert - in - u.status <- if strict then WeakVisited else Visited; - if try UMap.find v.univ u.ltle || not strict - with Not_found -> false - then raise (Found to_revert) - else - begin - let next_todo = - UMap.fold (fun u strictu next_todo -> - let strict = not strictu && strict in - let u = repr g u in - if u == v && not strict then raise (Found to_revert) - else if topo_compare u v = 1 then next_todo - else (u, strict)::next_todo) - u.ltle next_todo - in - loop to_revert todo next_todo - end - in - if u == v then not strict - else - try - let res, to_revert = - try false, loop [] [u, strict] [] - with Found to_revert -> true, to_revert - in - List.iter (fun u -> u.status <- NoMark) to_revert; - res - with e -> - (** Unlikely event: fatal error or signal *) - let () = cleanup_universes g in - raise e - -(** Uncomment to debug the cycle detection algorithm. *) -(*let insert_edge strict ucan vcan g = - check_universes_invariants g; - let g = insert_edge strict ucan vcan g in - check_universes_invariants g; - let ucan = repr g ucan.univ in - let vcan = repr g vcan.univ in - assert (search_path strict ucan vcan g); - g*) - -(** First, checks on universe levels *) - -let check_equal g u v = - let arcu = repr g u and arcv = repr g v in - arcu == arcv - -let check_eq_level g u v = u == v || check_equal g u v - -let check_smaller g strict u v = - let arcu = repr g u and arcv = repr g v in - if strict then - search_path true arcu arcv g - else - is_prop_arc arcu - || (is_set_arc arcu && not (is_prop_arc arcv)) - || search_path false arcu arcv g - -(** Then, checks on universes *) - -type 'a check_function = universes -> 'a -> 'a -> bool +type t = G.t +type 'a check_function = 'a G.check_function let check_smaller_expr g (u,n) (v,m) = let diff = n - m in match diff with - | 0 -> check_smaller g false u v - | 1 -> check_smaller g true u v - | x when x < 0 -> check_smaller g false u v + | 0 -> G.check_leq g u v + | 1 -> G.check_lt g u v + | x when x < 0 -> G.check_leq g u v | _ -> false let exists_bigger g ul l = - Universe.exists (fun ul' -> + Universe.exists (fun ul' -> check_smaller_expr g ul ul') l let real_check_leq g u v = Universe.for_all (fun ul -> exists_bigger g ul v) u - + let check_leq g u v = Universe.equal u v || is_type0m_univ u || real_check_leq g u v -let check_eq_univs g l1 l2 = - real_check_leq g l1 l2 && real_check_leq g l2 l1 - let check_eq g u v = - Universe.equal u v || check_eq_univs g u v - -(* enforce_univ_eq g u v will force u=v if possible, will fail otherwise *) - -let rec enforce_univ_eq u v g = - let ucan = repr g u in - let vcan = repr g v in - if topo_compare ucan vcan = 1 then enforce_univ_eq v u g - else - let g = insert_edge false ucan vcan g in (* Cannot fail *) - try insert_edge false vcan ucan g - with CycleDetected -> - error_inconsistency Eq v u (get_explanation true u v g) - -(* enforce_univ_leq g u v will force u<=v if possible, will fail otherwise *) -let enforce_univ_leq u v g = - let ucan = repr g u in - let vcan = repr g v in - try insert_edge false ucan vcan g - with CycleDetected -> - error_inconsistency Le u v (get_explanation true v u g) - -(* enforce_univ_lt u v will force u<v if possible, will fail otherwise *) -let enforce_univ_lt u v g = - let ucan = repr g u in - let vcan = repr g v in - try insert_edge true ucan vcan g - with CycleDetected -> - error_inconsistency Lt u v (get_explanation false v u g) - -let empty_universes = - { entries = UMap.empty; index = 0; n_nodes = 0; n_edges = 0 } + Universe.equal u v || + (real_check_leq g u v && real_check_leq g v u) + +let check_eq_level = G.check_eq + +let empty_universes = G.empty let initial_universes = - let set_arc = Canonical { - univ = Level.set; - ltle = LMap.empty; - gtge = LSet.empty; - rank = big_rank; - klvl = 0; - ilvl = (-1); - status = NoMark; - } in - let prop_arc = Canonical { - univ = Level.prop; - ltle = LMap.empty; - gtge = LSet.empty; - rank = big_rank; - klvl = 0; - ilvl = 0; - status = NoMark; - } in - let entries = UMap.add Level.set set_arc (UMap.singleton Level.prop prop_arc) in - let empty = { entries; index = (-2); n_nodes = 2; n_edges = 0 } in - enforce_univ_lt Level.prop Level.set empty - -let is_initial_universes g = UMap.equal (==) g.entries initial_universes.entries - -let enforce_constraint cst g = - match cst with - | (u,Lt,v) -> enforce_univ_lt u v g - | (u,Le,v) -> enforce_univ_leq u v g - | (u,Eq,v) -> enforce_univ_eq u v g - -let merge_constraints c g = - Constraint.fold enforce_constraint c g - -let check_constraint g (l,d,r) = + let big_rank = 1000000 in + let g = G.empty in + let g = G.add ~rank:big_rank Level.prop g in + let g = G.add ~rank:big_rank Level.set g in + G.enforce_lt Level.prop Level.set g + +let enforce_constraint (u,d,v) g = + match d with + | Le -> G.enforce_leq u v g + | Lt -> G.enforce_lt u v g + | Eq -> G.enforce_eq u v g + +let merge_constraints csts g = Constraint.fold enforce_constraint csts g + +let check_constraint g (u,d,v) = match d with - | Eq -> check_equal g l r - | Le -> check_smaller g false l r - | Lt -> check_smaller g true l r + | Le -> G.check_leq g u v + | Lt -> G.check_lt g u v + | Eq -> G.check_eq g u v -let check_constraints c g = - Constraint.for_all (check_constraint g) c +let check_constraints csts g = Constraint.for_all (check_constraint g) csts let leq_expr (u,m) (v,n) = let d = match m - n with @@ -760,6 +91,7 @@ let leq_expr (u,m) (v,n) = (u,d,v) let enforce_leq_alg u v g = + let open Util in let enforce_one (u,v) = function | Inr _ as orig -> orig | Inl (cstrs,g) as orig -> @@ -791,148 +123,19 @@ let enforce_leq_alg u v g = assert (check_leq g u v); cg -(* Normalization *) - -(** [normalize_universes g] returns a graph where all edges point - directly to the canonical representent of their target. The output - graph should be equivalent to the input graph from a logical point - of view, but optimized. We maintain the invariant that the key of - a [Canonical] element is its own name, by keeping [Equiv] edges. *) -let normalize_universes g = - let g = - { g with - entries = UMap.map (fun entry -> - match entry with - | Equiv u -> Equiv ((repr g u).univ) - | Canonical ucan -> Canonical { ucan with rank = 1 }) - g.entries } - in - UMap.fold (fun _ u g -> - match u with - | Equiv _u -> g - | Canonical u -> - let _, u, g = get_ltle g u in - let _, _, g = get_gtge g u in - g) - g.entries g - -let constraints_of_universes g = - let module UF = Unionfind.Make (LSet) (LMap) in - let uf = UF.create () in - let constraints_of u v acc = - match v with - | Canonical {univ=u; ltle; _} -> - UMap.fold (fun v strict acc-> - let typ = if strict then Lt else Le in - Constraint.add (u,typ,v) acc) ltle acc - | Equiv v -> UF.union u v uf; acc - in - let csts = UMap.fold constraints_of g.entries Constraint.empty in - csts, UF.partition uf - -(* domain g.entries = kept + removed *) -let constraints_for ~kept g = - (* rmap: partial map from canonical universes to kept universes *) - let rmap, csts = LSet.fold (fun u (rmap,csts) -> - let arcu = repr g u in - if LSet.mem arcu.univ kept then - LMap.add arcu.univ arcu.univ rmap, enforce_eq_level u arcu.univ csts - else - match LMap.find arcu.univ rmap with - | v -> rmap, enforce_eq_level u v csts - | exception Not_found -> LMap.add arcu.univ u rmap, csts) - kept (LMap.empty,Constraint.empty) - in - let rec add_from u csts todo = match todo with - | [] -> csts - | (v,strict)::todo -> - let v = repr g v in - (match LMap.find v.univ rmap with - | v -> - let d = if strict then Lt else Le in - let csts = Constraint.add (u,d,v) csts in - add_from u csts todo - | exception Not_found -> - (* v is not equal to any kept universe *) - let todo = LMap.fold (fun v' strict' todo -> - (v',strict || strict') :: todo) - v.ltle todo - in - add_from u csts todo) - in - LSet.fold (fun u csts -> - let arc = repr g u in - LMap.fold (fun v strict csts -> add_from u csts [v,strict]) - arc.ltle csts) - kept csts - -let domain g = LMap.domain g.entries - -let choose p g u = - let exception Found of Level.t in - let ru = (repr g u).univ in - if p ru then Some ru - else - try LMap.iter (fun v -> function - | Canonical _ -> () (* we already tried [p ru] *) - | Equiv v' -> - let rv = (repr g v').univ in - if rv == ru && p v then raise (Found v) - (* NB: we could also try [p v'] but it will come up in the - rest of the iteration regardless. *) - ) g.entries; None - with Found v -> Some v - -(** [sort_universes g] builds a totally ordered universe graph. The - output graph should imply the input graph (and the implication - will be strict most of the time), but is not necessarily minimal. - Moreover, it adds levels [Type.n] to identify universes at level - n. An artificial constraint Set < Type.2 is added to ensure that - Type.n and small universes are not merged. Note: the result is - unspecified if the input graph already contains [Type.n] nodes - (calling a module Type is probably a bad idea anyway). *) -let sort_universes g = - let cans = - UMap.fold (fun _ u l -> - match u with - | Equiv _ -> l - | Canonical can -> can :: l - ) g.entries [] - in - let cans = List.sort topo_compare cans in - let lowest_levels = - UMap.mapi (fun u _ -> if Level.is_small u then 0 else 2) - (UMap.filter - (fun _ u -> match u with Equiv _ -> false | Canonical _ -> true) - g.entries) - in - let lowest_levels = - List.fold_left (fun lowest_levels can -> - let lvl = UMap.find can.univ lowest_levels in - UMap.fold (fun u' strict lowest_levels -> - let cost = if strict then 1 else 0 in - let u' = (repr g u').univ in - UMap.modify u' (fun _ lvl0 -> max lvl0 (lvl+cost)) lowest_levels) - can.ltle lowest_levels) - lowest_levels cans - in - let max_lvl = UMap.fold (fun _ a b -> max a b) lowest_levels 0 in - let mp = Names.DirPath.make [Names.Id.of_string "Type"] in - let types = Array.init (max_lvl + 1) (function - | 0 -> Level.prop - | 1 -> Level.set - | n -> Level.make (Level.UGlobal.make mp (n-2))) - in - let g = Array.fold_left (fun g u -> - let g, u = safe_repr g u in - change_node g { u with rank = big_rank }) g types - in - let g = if max_lvl >= 2 then enforce_univ_lt Level.set types.(2) g else g in - let g = - UMap.fold (fun u lvl g -> enforce_univ_eq u (types.(lvl)) g) - lowest_levels g - in - normalize_universes g +exception AlreadyDeclared = G.AlreadyDeclared +let add_universe u strict g = + let g = G.add u g in + let d = if strict then Lt else Le in + enforce_constraint (Level.set,d,u) g + +let add_universe_unconstrained u g = G.add u g + +exception UndeclaredLevel = G.Undeclared +let check_declared_universes = G.check_declared + +let constraints_of_universes = G.constraints_of +let constraints_for = G.constraints_for (** Subtyping of polymorphic contexts *) @@ -957,45 +160,23 @@ let check_eq_instances g t1 t2 = (Int.equal i (Array.length t1)) || (check_eq_level g t1.(i) t2.(i) && aux (i + 1)) in aux 0) -(** Pretty-printing *) - -let pr_umap sep pr map = - let cmp (u,_) (v,_) = Level.compare u v in - Pp.prlist_with_sep sep pr (List.sort cmp (UMap.bindings map)) - -let pr_arc prl = function - | _, Canonical {univ=u; ltle; _} -> - if UMap.is_empty ltle then mt () - else - prl u ++ str " " ++ - v 0 - (pr_umap Pp.spc (fun (v, strict) -> - (if strict then str "< " else str "<= ") ++ prl v) - ltle) ++ - fnl () - | u, Equiv v -> - prl u ++ str " = " ++ prl v ++ fnl () - -let pr_universes prl g = - pr_umap mt (pr_arc prl) g.entries - -(* Dumping constraints to a file *) - -let dump_universes output g = - let dump_arc u = function - | Canonical {univ=u; ltle; _} -> - UMap.iter (fun v strict -> - let typ = if strict then Lt else Le in - output typ u v) ltle; - | Equiv v -> - output Eq u v - in - UMap.iter dump_arc g.entries +let domain = G.domain +let choose = G.choose + +let dump_universes = G.dump + +let check_universes_invariants g = G.check_invariants ~required_canonical:Level.is_small g + +let pr_universes = G.pr + +let dummy_mp = Names.DirPath.make [Names.Id.of_string "Type"] +let make_dummy i = Level.(make (UGlobal.make dummy_mp i)) +let sort_universes g = G.sort make_dummy [Level.prop;Level.set] g (** Profiling *) -let merge_constraints = - if Flags.profile then +let merge_constraints = + if Flags.profile then let key = CProfile.declare_profile "merge_constraints" in CProfile.profile2 key merge_constraints else merge_constraints @@ -1005,15 +186,14 @@ let check_constraints = CProfile.profile2 key check_constraints else check_constraints -let check_eq = +let check_eq = if Flags.profile then let check_eq_key = CProfile.declare_profile "check_eq" in CProfile.profile3 check_eq_key check_eq else check_eq -let check_leq = - if Flags.profile then +let check_leq = + if Flags.profile then let check_leq_key = CProfile.declare_profile "check_leq" in CProfile.profile3 check_leq_key check_leq else check_leq - diff --git a/kernel/uGraph.mli b/kernel/uGraph.mli index 4dbfac5c73..e1a5d50425 100644 --- a/kernel/uGraph.mli +++ b/kernel/uGraph.mli @@ -22,9 +22,6 @@ val check_eq_level : Level.t check_function (** The initial graph of universes: Prop < Set *) val initial_universes : t -(** Check if we are in the initial case *) -val is_initial_universes : t -> bool - (** Check equality of instances w.r.t. a universe graph *) val check_eq_instances : Instance.t check_function diff --git a/kernel/univ.ml b/kernel/univ.ml index d7c0cf13ec..8940c0337e 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -533,9 +533,9 @@ open Universe let universe_level = Universe.level -type constraint_type = Lt | Le | Eq +type constraint_type = AcyclicGraph.constraint_type = Lt | Le | Eq -type explanation = (constraint_type * universe) list +type explanation = (constraint_type * Level.t) list let constraint_type_ord c1 c2 = match c1, c2 with | Lt, Lt -> 0 @@ -1269,7 +1269,7 @@ let hcons_universe_context_set (v, c) = let hcons_univ x = Universe.hcons x -let explain_universe_inconsistency prl (o,u,v,p) = +let explain_universe_inconsistency prl (o,u,v,p : univ_inconsistency) = let pr_uni = Universe.pr_with prl in let pr_rel = function | Eq -> str"=" | Lt -> str"<" | Le -> str"<=" @@ -1281,9 +1281,9 @@ let explain_universe_inconsistency prl (o,u,v,p) = if p = [] then mt () else str " because" ++ spc() ++ pr_uni v ++ - prlist (fun (r,v) -> spc() ++ pr_rel r ++ str" " ++ pr_uni v) + prlist (fun (r,v) -> spc() ++ pr_rel r ++ str" " ++ prl v) p ++ - (if Universe.equal (snd (List.last p)) u then mt() else + (if Universe.equal (Universe.make (snd (List.last p))) u then mt() else (spc() ++ str "= " ++ pr_uni u)) in str "Cannot enforce" ++ spc() ++ pr_uni u ++ spc() ++ diff --git a/kernel/univ.mli b/kernel/univ.mli index d7097be570..b83251e983 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -166,7 +166,7 @@ val univ_level_rem : Level.t -> Universe.t -> Universe.t -> Universe.t (** {6 Constraints. } *) -type constraint_type = Lt | Le | Eq +type constraint_type = AcyclicGraph.constraint_type = Lt | Le | Eq type univ_constraint = Level.t * constraint_type * Level.t module Constraint : sig @@ -203,7 +203,7 @@ val enforce_leq_level : Level.t constraint_function system stores the graph and may result from combination of several Constraint.t... *) -type explanation = (constraint_type * Universe.t) list +type explanation = (constraint_type * Level.t) list type univ_inconsistency = constraint_type * Universe.t * Universe.t * explanation Lazy.t option exception UniverseInconsistency of univ_inconsistency diff --git a/lib/acyclicGraph.ml b/lib/acyclicGraph.ml new file mode 100644 index 0000000000..7d04c8f5a1 --- /dev/null +++ b/lib/acyclicGraph.ml @@ -0,0 +1,852 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +type constraint_type = Lt | Le | Eq + +module type Point = sig + type t + + module Set : CSig.SetS with type elt = t + module Map : CMap.ExtS with type key = t and module Set := Set + + module Constraint : CSet.S with type elt = (t * constraint_type * t) + + val equal : t -> t -> bool + val compare : t -> t -> int + + type explanation = (constraint_type * t) list + val error_inconsistency : constraint_type -> t -> t -> explanation lazy_t option -> 'a + + val pr : t -> Pp.t +end + +module Make (Point:Point) = struct + + (* Created in Caml by Gérard Huet for CoC 4.8 [Dec 1988] *) + (* Functional code by Jean-Christophe Filliâtre for Coq V7.0 [1999] *) + (* Extension with algebraic universes by HH for Coq V7.0 [Sep 2001] *) + (* Additional support for sort-polymorphic inductive types by HH [Mar 2006] *) + (* Support for universe polymorphism by MS [2014] *) + + (* Revisions by Bruno Barras, Hugo Herbelin, Pierre Letouzey, Matthieu + Sozeau, Pierre-Marie Pédrot, Jacques-Henri Jourdan *) + + (* Points are stratified by a partial ordering $\le$. + Let $\~{}$ be the associated equivalence. We also have a strict ordering + $<$ between equivalence classes, and we maintain that $<$ is acyclic, + and contained in $\le$ in the sense that $[U]<[V]$ implies $U\le V$. + + At every moment, we have a finite number of points, and we + maintain the ordering in the presence of assertions $U<V$ and $U\le V$. + + The equivalence $\~{}$ is represented by a tree structure, as in the + union-find algorithm. The assertions $<$ and $\le$ are represented by + adjacency lists. + + We use the algorithm described in the paper: + + Bender, M. A., Fineman, J. T., Gilbert, S., & Tarjan, R. E. (2011). A + new approach to incremental cycle detection and related + problems. arXiv preprint arXiv:1112.0784. + + *) + + module PMap = Point.Map + module PSet = Point.Set + module Constraint = Point.Constraint + + type status = NoMark | Visited | WeakVisited | ToMerge + + (* Comparison on this type is pointer equality *) + type canonical_node = + { canon: Point.t; + ltle: bool PMap.t; (* true: strict (lt) constraint. + false: weak (le) constraint. *) + gtge: PSet.t; + rank : int; + klvl: int; + ilvl: int; + mutable status: status + } + + let big_rank = 1000000 + + (* A Point.t is either an alias for another one, or a canonical one, + for which we know the points that are above *) + + type entry = + | Canonical of canonical_node + | Equiv of Point.t + + type t = + { entries : entry PMap.t; + index : int; + n_nodes : int; n_edges : int } + + (** Used to cleanup mutable marks if a traversal function is + interrupted before it has the opportunity to do it itself. *) + let unsafe_cleanup_marks g = + let iter _ n = match n with + | Equiv _ -> () + | Canonical n -> n.status <- NoMark + in + PMap.iter iter g.entries + + let rec cleanup_marks g = + try unsafe_cleanup_marks g + with e -> + (* The only way unsafe_cleanup_marks may raise an exception is when + a serious error (stack overflow, out of memory) occurs, or a signal is + sent. In this unlikely event, we relaunch the cleanup until we finally + succeed. *) + cleanup_marks g; raise e + + (* Every Point.t has a unique canonical arc representative *) + + (* Low-level function : makes u an alias for v. + Does not removes edges from n_edges, but decrements n_nodes. + u should be entered as canonical before. *) + let enter_equiv g u v = + { entries = + PMap.modify u (fun _ a -> + match a with + | Canonical n -> + n.status <- NoMark; + Equiv v + | _ -> assert false) g.entries; + index = g.index; + n_nodes = g.n_nodes - 1; + n_edges = g.n_edges } + + (* Low-level function : changes data associated with a canonical node. + Resets the mutable fields in the old record, in order to avoid breaking + invariants for other users of this record. + n.canon should already been inserted as a canonical node. *) + let change_node g n = + { g with entries = + PMap.modify n.canon + (fun _ a -> + match a with + | Canonical n' -> + n'.status <- NoMark; + Canonical n + | _ -> assert false) + g.entries } + + (* canonical representative : we follow the Equiv links *) + let rec repr g u = + match PMap.find u g.entries with + | Equiv v -> repr g v + | Canonical arc -> arc + | exception Not_found -> + CErrors.anomaly ~label:"Univ.repr" + Pp.(str"Universe " ++ Point.pr u ++ str" undefined.") + + exception AlreadyDeclared + + (* Reindexes the given point, using the next available index. *) + let use_index g u = + let u = repr g u in + let g = change_node g { u with ilvl = g.index } in + assert (g.index > min_int); + { g with index = g.index - 1 } + + (* [safe_repr] is like [repr] but if the graph doesn't contain the + searched point, we add it. *) + let safe_repr g u = + let rec safe_repr_rec entries u = + match PMap.find u entries with + | Equiv v -> safe_repr_rec entries v + | Canonical arc -> arc + in + try g, safe_repr_rec g.entries u + with Not_found -> + let can = + { canon = u; + ltle = PMap.empty; gtge = PSet.empty; + rank = 0; + klvl = 0; ilvl = 0; + status = NoMark } + in + let g = { g with + entries = PMap.add u (Canonical can) g.entries; + n_nodes = g.n_nodes + 1 } + in + let g = use_index g u in + g, repr g u + + (* Returns 1 if u is higher than v in topological order. + -1 lower + 0 if u = v *) + let topo_compare u v = + if u.klvl > v.klvl then 1 + else if u.klvl < v.klvl then -1 + else if u.ilvl > v.ilvl then 1 + else if u.ilvl < v.ilvl then -1 + else (assert (u==v); 0) + + (* Checks most of the invariants of the graph. For debugging purposes. *) + let check_invariants ~required_canonical g = + let n_edges = ref 0 in + let n_nodes = ref 0 in + PMap.iter (fun l u -> + match u with + | Canonical u -> + PMap.iter (fun v _strict -> + incr n_edges; + let v = repr g v in + assert (topo_compare u v = -1); + if u.klvl = v.klvl then + assert (PSet.mem u.canon v.gtge || + PSet.exists (fun l -> u == repr g l) v.gtge)) + u.ltle; + PSet.iter (fun v -> + let v = repr g v in + assert (v.klvl = u.klvl && + (PMap.mem u.canon v.ltle || + PMap.exists (fun l _ -> u == repr g l) v.ltle)) + ) u.gtge; + assert (u.status = NoMark); + assert (Point.equal l u.canon); + assert (u.ilvl > g.index); + assert (not (PMap.mem u.canon u.ltle)); + incr n_nodes + | Equiv _ -> assert (not (required_canonical l))) + g.entries; + assert (!n_edges = g.n_edges); + assert (!n_nodes = g.n_nodes) + + let clean_ltle g ltle = + PMap.fold (fun u strict acc -> + let uu = (repr g u).canon in + if Point.equal uu u then acc + else ( + let acc = PMap.remove u (fst acc) in + if not strict && PMap.mem uu acc then (acc, true) + else (PMap.add uu strict acc, true))) + ltle (ltle, false) + + let clean_gtge g gtge = + PSet.fold (fun u acc -> + let uu = (repr g u).canon in + if Point.equal uu u then acc + else PSet.add uu (PSet.remove u (fst acc)), true) + gtge (gtge, false) + + (* [get_ltle] and [get_gtge] return ltle and gtge arcs. + Moreover, if one of these lists is dirty (e.g. points to a + non-canonical node), these functions clean this node in the + graph by removing some duplicate edges *) + let get_ltle g u = + let ltle, chgt_ltle = clean_ltle g u.ltle in + if not chgt_ltle then u.ltle, u, g + else + let sz = PMap.cardinal u.ltle in + let sz2 = PMap.cardinal ltle in + let u = { u with ltle } in + let g = change_node g u in + let g = { g with n_edges = g.n_edges + sz2 - sz } in + u.ltle, u, g + + let get_gtge g u = + let gtge, chgt_gtge = clean_gtge g u.gtge in + if not chgt_gtge then u.gtge, u, g + else + let u = { u with gtge } in + let g = change_node g u in + u.gtge, u, g + + (* [revert_graph] rollbacks the changes made to mutable fields in + nodes in the graph. + [to_revert] contains the touched nodes. *) + let revert_graph to_revert g = + List.iter (fun t -> + match PMap.find t g.entries with + | Equiv _ -> () + | Canonical t -> + t.status <- NoMark) to_revert + + exception AbortBackward of t + exception CycleDetected + + (* Implementation of the algorithm described in § 5.1 of the following paper: + + Bender, M. A., Fineman, J. T., Gilbert, S., & Tarjan, R. E. (2011). A + new approach to incremental cycle detection and related + problems. arXiv preprint arXiv:1112.0784. + + The "STEP X" comments contained in this file refers to the + corresponding step numbers of the algorithm described in Section + 5.1 of this paper. *) + + (* [delta] is the timeout for backward search. It might be + useful to tune a multiplicative constant. *) + let get_delta g = + int_of_float + (min (float_of_int g.n_edges ** 0.5) + (float_of_int g.n_nodes ** (2./.3.))) + + let rec backward_traverse to_revert b_traversed count g x = + let x = repr g x in + let count = count - 1 in + if count < 0 then begin + revert_graph to_revert g; + raise (AbortBackward g) + end; + if x.status = NoMark then begin + x.status <- Visited; + let to_revert = x.canon::to_revert in + let gtge, x, g = get_gtge g x in + let to_revert, b_traversed, count, g = + PSet.fold (fun y (to_revert, b_traversed, count, g) -> + backward_traverse to_revert b_traversed count g y) + gtge (to_revert, b_traversed, count, g) + in + to_revert, x.canon::b_traversed, count, g + end + else to_revert, b_traversed, count, g + + let rec forward_traverse f_traversed g v_klvl x y = + let y = repr g y in + if y.klvl < v_klvl then begin + let y = { y with klvl = v_klvl; + gtge = if x == y then PSet.empty + else PSet.singleton x.canon } + in + let g = change_node g y in + let ltle, y, g = get_ltle g y in + let f_traversed, g = + PMap.fold (fun z _ (f_traversed, g) -> + forward_traverse f_traversed g v_klvl y z) + ltle (f_traversed, g) + in + y.canon::f_traversed, g + end else if y.klvl = v_klvl && x != y then + let g = change_node g + { y with gtge = PSet.add x.canon y.gtge } in + f_traversed, g + else f_traversed, g + + let rec find_to_merge to_revert g x v = + let x = repr g x in + match x.status with + | Visited -> false, to_revert | ToMerge -> true, to_revert + | NoMark -> + let to_revert = x::to_revert in + if Point.equal x.canon v then + begin x.status <- ToMerge; true, to_revert end + else + begin + let merge, to_revert = PSet.fold + (fun y (merge, to_revert) -> + let merge', to_revert = find_to_merge to_revert g y v in + merge' || merge, to_revert) x.gtge (false, to_revert) + in + x.status <- if merge then ToMerge else Visited; + merge, to_revert + end + | _ -> assert false + + let get_new_edges g to_merge = + (* Computing edge sets. *) + let to_merge_lvl = + List.fold_left (fun acc u -> PMap.add u.canon u acc) + PMap.empty to_merge + in + let ltle = + let fold _ n acc = + let fold u strict acc = + if strict then PMap.add u strict acc + else if PMap.mem u acc then acc + else PMap.add u false acc + in + PMap.fold fold n.ltle acc + in + PMap.fold fold to_merge_lvl PMap.empty + in + let ltle, _ = clean_ltle g ltle in + let ltle = + PMap.merge (fun _ a strict -> + match a, strict with + | Some _, Some true -> + (* There is a lt edge inside the new component. This is a + "bad cycle". *) + raise CycleDetected + | Some _, Some false -> None + | _, _ -> strict + ) to_merge_lvl ltle + in + let gtge = + PMap.fold (fun _ n acc -> PSet.union acc n.gtge) + to_merge_lvl PSet.empty + in + let gtge, _ = clean_gtge g gtge in + let gtge = PSet.diff gtge (PMap.domain to_merge_lvl) in + (ltle, gtge) + + + let reorder g u v = + (* STEP 2: backward search in the k-level of u. *) + let delta = get_delta g in + + (* [v_klvl] is the chosen future level for u, v and all + traversed nodes. *) + let b_traversed, v_klvl, g = + try + let to_revert, b_traversed, _, g = backward_traverse [] [] delta g u in + revert_graph to_revert g; + let v_klvl = (repr g u).klvl in + b_traversed, v_klvl, g + with AbortBackward g -> + (* Backward search was too long, use the next k-level. *) + let v_klvl = (repr g u).klvl + 1 in + [], v_klvl, g + in + let f_traversed, g = + (* STEP 3: forward search. Contrary to what is described in + the paper, we do not test whether v_klvl = u.klvl nor we assign + v_klvl to v.klvl. Indeed, the first call to forward_traverse + will do all that. *) + forward_traverse [] g v_klvl (repr g v) v + in + + (* STEP 4: merge nodes if needed. *) + let to_merge, b_reindex, f_reindex = + if (repr g u).klvl = v_klvl then + begin + let merge, to_revert = find_to_merge [] g u v in + let r = + if merge then + List.filter (fun u -> u.status = ToMerge) to_revert, + List.filter (fun u -> (repr g u).status <> ToMerge) b_traversed, + List.filter (fun u -> (repr g u).status <> ToMerge) f_traversed + else [], b_traversed, f_traversed + in + List.iter (fun u -> u.status <- NoMark) to_revert; + r + end + else [], b_traversed, f_traversed + in + let to_reindex, g = + match to_merge with + | [] -> List.rev_append f_reindex b_reindex, g + | n0::q0 -> + (* Computing new root. *) + let root, rank_rest = + List.fold_left (fun ((best, _rank_rest) as acc) n -> + if n.rank >= best.rank then n, best.rank else acc) + (n0, min_int) q0 + in + let ltle, gtge = get_new_edges g to_merge in + (* Inserting the new root. *) + let g = change_node g + { root with ltle; gtge; + rank = max root.rank (rank_rest + 1); } + in + + (* Inserting shortcuts for old nodes. *) + let g = List.fold_left (fun g n -> + if Point.equal n.canon root.canon then g else enter_equiv g n.canon root.canon) + g to_merge + in + + (* Updating g.n_edges *) + let oldsz = + List.fold_left (fun sz u -> sz+PMap.cardinal u.ltle) + 0 to_merge + in + let sz = PMap.cardinal ltle in + let g = { g with n_edges = g.n_edges + sz - oldsz } in + + (* Not clear in the paper: we have to put the newly + created component just between B and F. *) + List.rev_append f_reindex (root.canon::b_reindex), g + + in + + (* STEP 5: reindex traversed nodes. *) + List.fold_left use_index g to_reindex + + (* Assumes [u] and [v] are already in the graph. *) + (* Does NOT assume that ucan != vcan. *) + let insert_edge strict ucan vcan g = + try + let u = ucan.canon and v = vcan.canon in + (* STEP 1: do we need to reorder nodes ? *) + let g = if topo_compare ucan vcan <= 0 then g else reorder g u v in + + (* STEP 6: insert the new edge in the graph. *) + let u = repr g u in + let v = repr g v in + if u == v then + if strict then raise CycleDetected else g + else + let g = + try let oldstrict = PMap.find v.canon u.ltle in + if strict && not oldstrict then + change_node g { u with ltle = PMap.add v.canon true u.ltle } + else g + with Not_found -> + { (change_node g { u with ltle = PMap.add v.canon strict u.ltle }) + with n_edges = g.n_edges + 1 } + in + if u.klvl <> v.klvl || PSet.mem u.canon v.gtge then g + else + let v = { v with gtge = PSet.add u.canon v.gtge } in + change_node g v + with + | CycleDetected as e -> raise e + | e -> + (* Unlikely event: fatal error or signal *) + let () = cleanup_marks g in + raise e + + let add ?(rank=0) v g = + try + let _arcv = PMap.find v g.entries in + raise AlreadyDeclared + with Not_found -> + assert (g.index > min_int); + let node = { + canon = v; + ltle = PMap.empty; + gtge = PSet.empty; + rank; + klvl = 0; + ilvl = g.index; + status = NoMark; + } + in + let entries = PMap.add v (Canonical node) g.entries in + { entries; index = g.index - 1; n_nodes = g.n_nodes + 1; n_edges = g.n_edges } + + exception Undeclared of Point.t + let check_declared g us = + let check l = if not (PMap.mem l g.entries) then raise (Undeclared l) in + PSet.iter check us + + exception Found_explanation of (constraint_type * Point.t) list + + let get_explanation strict u v g = + let v = repr g v in + let visited_strict = ref PMap.empty in + let rec traverse strict u = + if u == v then + if strict then None else Some [] + else if topo_compare u v = 1 then None + else + let visited = + try not (PMap.find u.canon !visited_strict) || strict + with Not_found -> false + in + if visited then None + else begin + visited_strict := PMap.add u.canon strict !visited_strict; + try + PMap.iter (fun u' strictu' -> + match traverse (strict && not strictu') (repr g u') with + | None -> () + | Some exp -> + let typ = if strictu' then Lt else Le in + raise (Found_explanation ((typ, u') :: exp))) + u.ltle; + None + with Found_explanation exp -> Some exp + end + in + let u = repr g u in + if u == v then [(Eq, v.canon)] + else match traverse strict u with Some exp -> exp | None -> assert false + + let get_explanation strict u v g = + Some (lazy (get_explanation strict u v g)) + + (* To compare two nodes, we simply do a forward search. + We implement two improvements: + - we ignore nodes that are higher than the destination; + - we do a BFS rather than a DFS because we expect to have a short + path (typically, the shortest path has length 1) + *) + exception Found of canonical_node list + let search_path strict u v g = + let rec loop to_revert todo next_todo = + match todo, next_todo with + | [], [] -> to_revert (* No path found *) + | [], _ -> loop to_revert next_todo [] + | (u, strict)::todo, _ -> + if u.status = Visited || (u.status = WeakVisited && strict) + then loop to_revert todo next_todo + else + let to_revert = + if u.status = NoMark then u::to_revert else to_revert + in + u.status <- if strict then WeakVisited else Visited; + if try PMap.find v.canon u.ltle || not strict + with Not_found -> false + then raise (Found to_revert) + else + begin + let next_todo = + PMap.fold (fun u strictu next_todo -> + let strict = not strictu && strict in + let u = repr g u in + if u == v && not strict then raise (Found to_revert) + else if topo_compare u v = 1 then next_todo + else (u, strict)::next_todo) + u.ltle next_todo + in + loop to_revert todo next_todo + end + in + if u == v then not strict + else + try + let res, to_revert = + try false, loop [] [u, strict] [] + with Found to_revert -> true, to_revert + in + List.iter (fun u -> u.status <- NoMark) to_revert; + res + with e -> + (* Unlikely event: fatal error or signal *) + let () = cleanup_marks g in + raise e + + (** Uncomment to debug the cycle detection algorithm. *) + (*let insert_edge strict ucan vcan g = + let check_invariants = check_invariants ~required_canonical:(fun _ -> false) in + check_invariants g; + let g = insert_edge strict ucan vcan g in + check_invariants g; + let ucan = repr g ucan.canon in + let vcan = repr g vcan.canon in + assert (search_path strict ucan vcan g); + g*) + + (** User interface *) + + type 'a check_function = t -> 'a -> 'a -> bool + + let check_eq g u v = + u == v || + let arcu = repr g u and arcv = repr g v in + arcu == arcv + + let check_smaller g strict u v = + search_path strict (repr g u) (repr g v) g + + let check_leq g u v = check_smaller g false u v + let check_lt g u v = check_smaller g true u v + + (* enforce_eq g u v will force u=v if possible, will fail otherwise *) + + let rec enforce_eq u v g = + let ucan = repr g u in + let vcan = repr g v in + if topo_compare ucan vcan = 1 then enforce_eq v u g + else + let g = insert_edge false ucan vcan g in (* Cannot fail *) + try insert_edge false vcan ucan g + with CycleDetected -> + Point.error_inconsistency Eq v u (get_explanation true u v g) + + (* enforce_leq g u v will force u<=v if possible, will fail otherwise *) + let enforce_leq u v g = + let ucan = repr g u in + let vcan = repr g v in + try insert_edge false ucan vcan g + with CycleDetected -> + Point.error_inconsistency Le u v (get_explanation true v u g) + + (* enforce_lt u v will force u<v if possible, will fail otherwise *) + let enforce_lt u v g = + let ucan = repr g u in + let vcan = repr g v in + try insert_edge true ucan vcan g + with CycleDetected -> + Point.error_inconsistency Lt u v (get_explanation false v u g) + + let empty = + { entries = PMap.empty; index = 0; n_nodes = 0; n_edges = 0 } + + (* Normalization *) + + (** [normalize g] returns a graph where all edges point + directly to the canonical representent of their target. The output + graph should be equivalent to the input graph from a logical point + of view, but optimized. We maintain the invariant that the key of + a [Canonical] element is its own name, by keeping [Equiv] edges. *) + let normalize g = + let g = + { g with + entries = PMap.map (fun entry -> + match entry with + | Equiv u -> Equiv ((repr g u).canon) + | Canonical ucan -> Canonical { ucan with rank = 1 }) + g.entries } + in + PMap.fold (fun _ u g -> + match u with + | Equiv _u -> g + | Canonical u -> + let _, u, g = get_ltle g u in + let _, _, g = get_gtge g u in + g) + g.entries g + + let constraints_of g = + let module UF = Unionfind.Make (PSet) (PMap) in + let uf = UF.create () in + let constraints_of u v acc = + match v with + | Canonical {canon=u; ltle; _} -> + PMap.fold (fun v strict acc-> + let typ = if strict then Lt else Le in + Constraint.add (u,typ,v) acc) ltle acc + | Equiv v -> UF.union u v uf; acc + in + let csts = PMap.fold constraints_of g.entries Constraint.empty in + csts, UF.partition uf + + (* domain g.entries = kept + removed *) + let constraints_for ~kept g = + (* rmap: partial map from canonical points to kept points *) + let rmap, csts = PSet.fold (fun u (rmap,csts) -> + let arcu = repr g u in + if PSet.mem arcu.canon kept then + PMap.add arcu.canon arcu.canon rmap, Constraint.add (u,Eq,arcu.canon) csts + else + match PMap.find arcu.canon rmap with + | v -> rmap, Constraint.add (u,Eq,v) csts + | exception Not_found -> PMap.add arcu.canon u rmap, csts) + kept (PMap.empty,Constraint.empty) + in + let rec add_from u csts todo = match todo with + | [] -> csts + | (v,strict)::todo -> + let v = repr g v in + (match PMap.find v.canon rmap with + | v -> + let d = if strict then Lt else Le in + let csts = Constraint.add (u,d,v) csts in + add_from u csts todo + | exception Not_found -> + (* v is not equal to any kept point *) + let todo = PMap.fold (fun v' strict' todo -> + (v',strict || strict') :: todo) + v.ltle todo + in + add_from u csts todo) + in + PSet.fold (fun u csts -> + let arc = repr g u in + PMap.fold (fun v strict csts -> add_from u csts [v,strict]) + arc.ltle csts) + kept csts + + let domain g = PMap.domain g.entries + + let choose p g u = + let exception Found of Point.t in + let ru = (repr g u).canon in + if p ru then Some ru + else + try PMap.iter (fun v -> function + | Canonical _ -> () (* we already tried [p ru] *) + | Equiv v' -> + let rv = (repr g v').canon in + if rv == ru && p v then raise (Found v) + (* NB: we could also try [p v'] but it will come up in the + rest of the iteration regardless. *) + ) g.entries; None + with Found v -> Some v + + let sort make_dummy first g = + let cans = + PMap.fold (fun _ u l -> + match u with + | Equiv _ -> l + | Canonical can -> can :: l + ) g.entries [] + in + let cans = List.sort topo_compare cans in + let lowest = + PMap.mapi (fun u _ -> if CList.mem_f Point.equal u first then 0 else 2) + (PMap.filter + (fun _ u -> match u with Equiv _ -> false | Canonical _ -> true) + g.entries) + in + let lowest = + List.fold_left (fun lowest can -> + let lvl = PMap.find can.canon lowest in + PMap.fold (fun u' strict lowest -> + let cost = if strict then 1 else 0 in + let u' = (repr g u').canon in + PMap.modify u' (fun _ lvl0 -> max lvl0 (lvl+cost)) lowest) + can.ltle lowest) + lowest cans + in + let max_lvl = PMap.fold (fun _ a b -> max a b) lowest 0 in + let types = Array.init (max_lvl + 1) (fun i -> + match List.nth_opt first i with + | Some u -> u + | None -> make_dummy (i-2)) + in + let g = Array.fold_left (fun g u -> + let g, u = safe_repr g u in + change_node g { u with rank = big_rank }) g types + in + let g = if max_lvl > List.length first && not (CList.is_empty first) then + enforce_lt (CList.last first) types.(List.length first) g + else g + in + let g = + PMap.fold (fun u lvl g -> enforce_eq u (types.(lvl)) g) + lowest g + in + normalize g + + (** Pretty-printing *) + + let pr_pmap sep pr map = + let cmp (u,_) (v,_) = Point.compare u v in + Pp.prlist_with_sep sep pr (List.sort cmp (PMap.bindings map)) + + let pr_arc prl = let open Pp in + function + | _, Canonical {canon=u; ltle; _} -> + if PMap.is_empty ltle then mt () + else + prl u ++ str " " ++ + v 0 + (pr_pmap spc (fun (v, strict) -> + (if strict then str "< " else str "<= ") ++ prl v) + ltle) ++ + fnl () + | u, Equiv v -> + prl u ++ str " = " ++ prl v ++ fnl () + + let pr prl g = + pr_pmap Pp.mt (pr_arc prl) g.entries + + (* Dumping constraints to a file *) + + let dump output g = + let dump_arc u = function + | Canonical {canon=u; ltle; _} -> + PMap.iter (fun v strict -> + let typ = if strict then Lt else Le in + output typ u v) ltle; + | Equiv v -> + output Eq u v + in + PMap.iter dump_arc g.entries + +end diff --git a/lib/acyclicGraph.mli b/lib/acyclicGraph.mli new file mode 100644 index 0000000000..b53a4c018f --- /dev/null +++ b/lib/acyclicGraph.mli @@ -0,0 +1,82 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Graphs representing strict orders *) + +type constraint_type = Lt | Le | Eq + +module type Point = sig + type t + + module Set : CSig.SetS with type elt = t + module Map : CMap.ExtS with type key = t and module Set := Set + + module Constraint : CSet.S with type elt = (t * constraint_type * t) + + val equal : t -> t -> bool + val compare : t -> t -> int + + type explanation = (constraint_type * t) list + val error_inconsistency : constraint_type -> t -> t -> explanation lazy_t option -> 'a + + val pr : t -> Pp.t +end + +module Make (Point:Point) : sig + + type t + + val empty : t + + val check_invariants : required_canonical:(Point.t -> bool) -> t -> unit + + exception AlreadyDeclared + val add : ?rank:int -> Point.t -> t -> t + (** All points must be pre-declared through this function before + they can be mentioned in the others. NB: use a large [rank] to + keep the node canonical *) + + exception Undeclared of Point.t + val check_declared : t -> Point.Set.t -> unit + (** @raise Undeclared if one of the points is not present in the graph. *) + + type 'a check_function = t -> 'a -> 'a -> bool + + val check_eq : Point.t check_function + val check_leq : Point.t check_function + val check_lt : Point.t check_function + + val enforce_eq : Point.t -> Point.t -> t -> t + val enforce_leq : Point.t -> Point.t -> t -> t + val enforce_lt : Point.t -> Point.t -> t -> t + + val constraints_of : t -> Point.Constraint.t * Point.Set.t list + + val constraints_for : kept:Point.Set.t -> t -> Point.Constraint.t + + val domain : t -> Point.Set.t + + val choose : (Point.t -> bool) -> t -> Point.t -> Point.t option + + val sort : (int -> Point.t) -> Point.t list -> t -> t + (** [sort mk first g] builds a totally ordered graph. The output + graph should imply the input graph (and the implication will be + strict most of the time), but is not necessarily minimal. The + lowest points in the result are identified with [first]. + Moreover, it adds levels [Type.n] to identify the points (not in + [first]) at level n. An artificial constraint (last first < mk + (length first)) is added to ensure that they are not merged. + Note: the result is unspecified if the input graph already + contains [mk n] nodes. *) + + val pr : (Point.t -> Pp.t) -> t -> Pp.t + + val dump : (constraint_type -> Point.t -> Point.t -> unit) -> t -> unit +end diff --git a/lib/control.ml b/lib/control.ml index e09068740d..ffb3584f1e 100644 --- a/lib/control.ml +++ b/lib/control.ml @@ -57,7 +57,7 @@ let windows_timeout n f x e = done in let init = Unix.gettimeofday () in - let _id = Thread.create thread init in + let _id = CThread.create thread init in try let res = f x in let () = killed := true in diff --git a/lib/flags.ml b/lib/flags.ml index ae4d337ded..55bfa3cbde 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -66,7 +66,7 @@ let we_are_parsing = ref false (* Current means no particular compatibility consideration. For correct comparisons, this constructor should remain the last one. *) -type compat_version = V8_7 | V8_8 | Current +type compat_version = V8_7 | V8_8 | V8_9 | Current let compat_version = ref Current @@ -77,6 +77,9 @@ let version_compare v1 v2 = match v1, v2 with | V8_8, V8_8 -> 0 | V8_8, _ -> -1 | _, V8_8 -> 1 + | V8_9, V8_9 -> 0 + | V8_9, _ -> -1 + | _, V8_9 -> 1 | Current, Current -> 0 let version_strictly_greater v = version_compare !compat_version v > 0 @@ -85,6 +88,7 @@ let version_less_or_equal v = not (version_strictly_greater v) let pr_version = function | V8_7 -> "8.7" | V8_8 -> "8.8" + | V8_9 -> "8.9" | Current -> "current" (* Translate *) diff --git a/lib/flags.mli b/lib/flags.mli index d883cf1e30..7336b9beaf 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -58,7 +58,7 @@ val we_are_parsing : bool ref (* Set Printing All flag. For some reason it is a global flag *) val raw_print : bool ref -type compat_version = V8_7 | V8_8 | Current +type compat_version = V8_7 | V8_8 | V8_9 | Current val compat_version : compat_version ref val version_compare : compat_version -> compat_version -> int val version_strictly_greater : compat_version -> bool diff --git a/lib/lib.mllib b/lib/lib.mllib index 206b2504db..2db59712b9 100644 --- a/lib/lib.mllib +++ b/lib/lib.mllib @@ -11,6 +11,7 @@ Feedback CErrors CWarnings +AcyclicGraph Rtree System Explore @@ -284,15 +284,12 @@ let pr_vertical_list pr = function [pr 0 a0 ++ sep() ++ ... ++ sep() ++ pr n an] *) let prvecti_with_sep sep elem v = - let rec pr i = - if Int.equal i 0 then - elem 0 v.(0) - else - let r = pr (i-1) and s = sep () and e = elem i v.(i) in - r ++ s ++ e + let v = CArray.mapi (fun i x -> + let pp = if i = 0 then mt() else sep() in + pp ++ elem i x) + v in - let n = Array.length v in - if Int.equal n 0 then mt () else pr (n - 1) + seq (Array.to_list v) (* [prvecti pr [|a0 ; ... ; an|]] outputs [pr 0 a0 ++ ... ++ pr n an] *) diff --git a/lib/stateid.ml b/lib/stateid.ml index 5485c4bf19..8f45f3605d 100644 --- a/lib/stateid.ml +++ b/lib/stateid.ml @@ -27,6 +27,8 @@ let get exn = Exninfo.get exn state_id_info let equal = Int.equal let compare = Int.compare +let print id = Pp.int id + module Self = struct type t = int let compare = compare diff --git a/lib/stateid.mli b/lib/stateid.mli index 5d4b71a354..f6ce7ddc40 100644 --- a/lib/stateid.mli +++ b/lib/stateid.mli @@ -20,6 +20,7 @@ val initial : t val dummy : t val fresh : unit -> t val to_string : t -> string +val print : t -> Pp.t val of_int : int -> t val to_int : t -> int diff --git a/lib/system.ml b/lib/system.ml index a9db95318f..fd6579dd69 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -287,20 +287,20 @@ let fmt_time_difference (startreal,ustart,sstart) (stopreal,ustop,sstop) = real (round (sstop -. sstart)) ++ str "s" ++ str ")" -let with_time ~batch f x = +let with_time ~batch ~header f x = let tstart = get_time() in let msg = if batch then "" else "Finished transaction in " in try let y = f x in let tend = get_time() in let msg2 = if batch then "" else " (successful)" in - Feedback.msg_info (str msg ++ fmt_time_difference tstart tend ++ str msg2); + Feedback.msg_info (header ++ str msg ++ fmt_time_difference tstart tend ++ str msg2); y with e -> let tend = get_time() in let msg = if batch then "" else "Finished failing transaction in " in let msg2 = if batch then "" else " (failure)" in - Feedback.msg_info (str msg ++ fmt_time_difference tstart tend ++ str msg2); + Feedback.msg_info (header ++ str msg ++ fmt_time_difference tstart tend ++ str msg2); raise e (* We use argv.[0] as we don't want to resolve symlinks *) diff --git a/lib/system.mli b/lib/system.mli index a3b79ee528..6dd1eb5a84 100644 --- a/lib/system.mli +++ b/lib/system.mli @@ -105,7 +105,7 @@ val time_difference : time -> time -> float (** in seconds *) val fmt_time_difference : time -> time -> Pp.t -val with_time : batch:bool -> ('a -> 'b) -> 'a -> 'b +val with_time : batch:bool -> header:Pp.t -> ('a -> 'b) -> 'a -> 'b (** [get_toplevel_path program] builds a complete path to the executable denoted by [program]. This involves: diff --git a/lib/util.ml b/lib/util.ml index 38d73d3453..0389336258 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -20,6 +20,12 @@ let on_pi1 f (a,b,c) = (f a,b,c) let on_pi2 f (a,b,c) = (a,f b,c) let on_pi3 f (a,b,c) = (a,b,f c) +(* Comparing pairs *) + +let pair_compare cmpx cmpy (x1,y1 as p1) (x2,y2 as p2) = + if p1 == p2 then 0 else + let c = cmpx x1 x2 in if c == 0 then cmpy y1 y2 else c + (* Projections from triplets *) let pi1 (a,_,_) = a diff --git a/lib/util.mli b/lib/util.mli index 1eb60f509a..fa3b622621 100644 --- a/lib/util.mli +++ b/lib/util.mli @@ -17,6 +17,10 @@ val on_fst : ('a -> 'b) -> 'a * 'c -> 'b * 'c val on_snd : ('a -> 'b) -> 'c * 'a -> 'c * 'b val map_pair : ('a -> 'b) -> 'a * 'a -> 'b * 'b +(** Comparing pairs *) + +val pair_compare : ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('a * 'b -> 'a * 'b -> int) + (** Mapping under triple *) val on_pi1 : ('a -> 'b) -> 'a * 'c * 'd -> 'b * 'c * 'd diff --git a/man/coqtop.1 b/man/coqtop.1 index 084adfe453..addfb54672 100644 --- a/man/coqtop.1 +++ b/man/coqtop.1 @@ -85,22 +85,6 @@ load Coq library and import it (Require Import path.) .TP -.BI \-compile \ filename.v -compile Coq file -.I filename.v -(implies -.B \-batch -) - -.TP -.BI \-compile\-verbose \ filename.v -verbosely compile Coq file -.I filename.v -(implies -.B \-batch -) - -.TP .B \-where print Coq's standard library location and exit @@ -125,8 +109,6 @@ batch mode (exits just after arguments parsing) .B \-boot boot mode (implies .B \-q -and -.B \-batch ) .TP diff --git a/parsing/cLexer.ml b/parsing/cLexer.ml index c2b7fa117d..49d6cf01d9 100644 --- a/parsing/cLexer.ml +++ b/parsing/cLexer.ml @@ -548,20 +548,27 @@ let process_sequence loc bp c cs = aux 1 cs (* Must be a special token *) -let process_chars loc bp c cs = +let process_chars ~diff_mode loc bp c cs = let t = progress_from_byte loc None (-1) !token_tree cs c in let ep = Stream.count cs in match t with | Some t -> (KEYWORD t, set_loc_pos loc bp ep) | None -> let ep' = bp + utf8_char_size loc cs c in - njunk (ep' - ep) cs; - let loc = set_loc_pos loc bp ep' in - err loc Undefined_token + if diff_mode then begin + let len = ep' - bp in + ignore (store 0 c); + ignore (nstore (len - 1) 1 cs); + IDENT (get_buff len), set_loc_pos loc bp ep + end else begin + njunk (ep' - ep) cs; + let loc = set_loc_pos loc bp ep' in + err loc Undefined_token + end (* Parse what follows a dot *) -let parse_after_dot loc c bp s = match Stream.peek s with +let parse_after_dot ~diff_mode loc c bp s = match Stream.peek s with | Some ('a'..'z' | 'A'..'Z' | '_' as d) -> Stream.junk s; let len = @@ -576,11 +583,11 @@ let parse_after_dot loc c bp s = match Stream.peek s with let len = ident_tail loc (nstore n 0 s) s in let field = get_buff len in (try find_keyword loc ("."^field) s with Not_found -> FIELD field) - | AsciiChar | Utf8Token _ | EmptyStream -> fst (process_chars loc bp c s) + | AsciiChar | Utf8Token _ | EmptyStream -> fst (process_chars ~diff_mode loc bp c s) (* Parse what follows a question mark *) -let parse_after_qmark loc bp s = +let parse_after_qmark ~diff_mode loc bp s = match Stream.peek s with | Some ('a'..'z' | 'A'..'Z' | '_') -> LEFTQMARK | None -> KEYWORD "?" @@ -588,7 +595,7 @@ let parse_after_qmark loc bp s = match lookup_utf8 loc s with | Utf8Token (st, _) when Unicode.is_valid_ident_initial st -> LEFTQMARK | AsciiChar | Utf8Token _ | EmptyStream -> - fst (process_chars loc bp '?' s) + fst (process_chars ~diff_mode loc bp '?' s) let blank_or_eof cs = match Stream.peek cs with @@ -598,20 +605,20 @@ let blank_or_eof cs = (* Parse a token in a char stream *) -let rec next_token loc s = +let rec next_token ~diff_mode loc s = let bp = Stream.count s in match Stream.peek s with | Some ('\n' as c) -> Stream.junk s; let ep = Stream.count s in - comm_loc bp; push_char c; next_token (bump_loc_line loc ep) s + comm_loc bp; push_char c; next_token ~diff_mode (bump_loc_line loc ep) s | Some (' ' | '\t' | '\r' as c) -> Stream.junk s; - comm_loc bp; push_char c; next_token loc s + comm_loc bp; push_char c; next_token ~diff_mode loc s | Some ('.' as c) -> Stream.junk s; let t = - try parse_after_dot loc c bp s with + try parse_after_dot ~diff_mode loc c bp s with Stream.Failure -> raise (Stream.Error "") in let ep = Stream.count s in @@ -630,13 +637,13 @@ let rec next_token loc s = Stream.junk s; let t,new_between_commands = if !between_commands then process_sequence loc bp c s, true - else process_chars loc bp c s,false + else process_chars ~diff_mode loc bp c s,false in comment_stop bp; between_commands := new_between_commands; t | Some '?' -> Stream.junk s; let ep = Stream.count s in - let t = parse_after_qmark loc bp s in + let t = parse_after_qmark ~diff_mode loc bp s in comment_stop bp; (t, set_loc_pos loc bp ep) | Some ('a'..'z' | 'A'..'Z' | '_' as c) -> Stream.junk s; @@ -670,12 +677,16 @@ let rec next_token loc s = Stream.junk s; begin try match Stream.peek s with + | Some '*' when diff_mode -> + Stream.junk s; + let ep = Stream.count s in + (IDENT "(*", set_loc_pos loc bp ep) | Some '*' -> Stream.junk s; comm_loc bp; push_string "(*"; - let loc = comment loc bp s in next_token loc s - | _ -> let t = process_chars loc bp c s in comment_stop bp; t + let loc = comment loc bp s in next_token ~diff_mode loc s + | _ -> let t = process_chars ~diff_mode loc bp c s in comment_stop bp; t with Stream.Failure -> raise (Stream.Error "") end | Some ('{' | '}' as c) -> @@ -683,7 +694,7 @@ let rec next_token loc s = let ep = Stream.count s in let t,new_between_commands = if !between_commands then (KEYWORD (String.make 1 c), set_loc_pos loc bp ep), true - else process_chars loc bp c s, false + else process_chars ~diff_mode loc bp c s, false in comment_stop bp; between_commands := new_between_commands; t | _ -> @@ -695,14 +706,14 @@ let rec next_token loc s = comment_stop bp; (try find_keyword loc id s with Not_found -> IDENT id), set_loc_pos loc bp ep | AsciiChar | Utf8Token _ -> - let t = process_chars loc bp (Stream.next s) s in + let t = process_chars ~diff_mode loc bp (Stream.next s) s in comment_stop bp; t | EmptyStream -> comment_stop bp; (EOI, set_loc_pos loc bp (bp+1)) (* (* Debug: uncomment this for tracing tokens seen by coq...*) -let next_token loc s = - let (t,loc as r) = next_token loc s in +let next_token ~diff_mode loc s = + let (t,loc as r) = next_token ~diff_mode loc s in Printf.eprintf "(line %i, %i-%i)[%s]\n%!" (Ploc.line_nb loc) (Ploc.first_pos loc) (Ploc.last_pos loc) (Tok.to_string t); r *) @@ -743,7 +754,7 @@ let token_text = function | (con, "") -> con | (con, prm) -> con ^ " \"" ^ prm ^ "\"" -let func cs = +let func next_token cs = let loct = loct_create () in let cur_loc = ref (Loc.create !current_file 1 0 0 0) in let ts = @@ -755,8 +766,8 @@ let func cs = in (ts, loct_func loct) -let lexer = { - Plexing.tok_func = func; +let make_lexer ~diff_mode = { + Plexing.tok_func = func (next_token ~diff_mode); Plexing.tok_using = (fun pat -> match Tok.of_pattern pat with | KEYWORD s -> add_keyword s @@ -765,6 +776,8 @@ let lexer = { Plexing.tok_match = Tok.match_pattern; Plexing.tok_text = token_text } +let lexer = make_lexer ~diff_mode:false + (** Terminal symbols interpretation *) let is_ident_not_keyword s = diff --git a/parsing/cLexer.mli b/parsing/cLexer.mli index c0ebdd45ef..af3fd7f318 100644 --- a/parsing/cLexer.mli +++ b/parsing/cLexer.mli @@ -56,3 +56,14 @@ val set_lexer_state : lexer_state -> unit val get_lexer_state : unit -> lexer_state val drop_lexer_state : unit -> unit val get_comment_state : lexer_state -> ((int * int) * string) list + +(** Create a lexer. true enables alternate handling for computing diffs. +It ensures that, ignoring white space, the concatenated tokens equal the input +string. Specifically: +- for strings, return the enclosing quotes as tokens and treat the quoted value +as if it was unquoted, possibly becoming multiple tokens +- for comments, return the "(*" as a token and treat the contents of the comment as if +it was not in a comment, possibly becoming multiple tokens +- return any unrecognized Ascii or UTF-8 character as a string +*) +val make_lexer : diff_mode:bool -> Tok.t Gramlib.Plexing.lexer diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 19ae97da77..759e60fbca 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -439,7 +439,6 @@ module Module = let module_expr = Entry.create "module_expr" let module_type = Entry.create "module_type" end - let epsilon_value f e = let r = G.production (G.r_next G.r_stop (symbol_of_prod_entry_key e), (fun x _ -> f x)) in let ext = [None, None, [r]] in diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 352857d4cd..3203a25b46 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -41,6 +41,16 @@ end - static rules explicitly defined in files g_*.ml4 - static rules macro-generated by ARGUMENT EXTEND, TACTIC EXTEND and VERNAC EXTEND (see e.g. file extratactics.ml4) + + Note that parsing a Coq document is in essence stateful: the parser + needs to recognize commands that start proofs and use a different + parsing entry point for them. + + We thus provide two different interfaces: the "raw" parsing + interface, in the style of camlp5, which provides more flexibility, + and a more specialize "parse_vernac" one, which will indeed adjust + the state as needed. + *) (** Dynamic extension of rules @@ -269,3 +279,7 @@ type any_entry = AnyEntry : 'a Entry.t -> any_entry val register_grammars_by_name : string -> any_entry list -> unit val find_grammars_by_name : string -> any_entry list + +(** Parsing state handling *) +val freeze : marshallable:bool -> frozen_t +val unfreeze : frozen_t -> unit diff --git a/parsing/tok.ml b/parsing/tok.ml index c0d5b6742d..03825e350f 100644 --- a/parsing/tok.ml +++ b/parsing/tok.ml @@ -40,18 +40,19 @@ let extract_string diff_mode = function | KEYWORD s -> s | IDENT s -> s | STRING s -> - if diff_mode then - let escape_quotes s = - let len = String.length s in - let buf = Buffer.create len in - for i = 0 to len-1 do - let ch = String.get s i in - Buffer.add_char buf ch; - if ch = '"' then Buffer.add_char buf '"' else () - done; - Buffer.contents buf - in - "\"" ^ (escape_quotes s) ^ "\"" else s + if diff_mode then + let escape_quotes s = + let len = String.length s in + let buf = Buffer.create len in + for i = 0 to len-1 do + let ch = String.get s i in + Buffer.add_char buf ch; + if ch = '"' then Buffer.add_char buf '"' else () + done; + Buffer.contents buf + in + "\"" ^ (escape_quotes s) ^ "\"" + else s | PATTERNIDENT s -> s | FIELD s -> if diff_mode then "." ^ s else s | INT s -> s diff --git a/plugins/derive/g_derive.mlg b/plugins/derive/g_derive.mlg index df4b647642..0cdf8fb5d8 100644 --- a/plugins/derive/g_derive.mlg +++ b/plugins/derive/g_derive.mlg @@ -18,7 +18,7 @@ DECLARE PLUGIN "derive_plugin" { -let classify_derive_command _ = Vernacextend.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]),VtLater) +let classify_derive_command _ = Vernacextend.(VtStartProof (Doesn'tGuaranteeOpacity,[]),VtLater) } diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index 8f0440a2a4..c4f8843e51 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -186,7 +186,7 @@ VERNAC COMMAND EXTEND Function (Vernacexpr.(VernacExpr([], VernacFixpoint(Decl_kinds.NoDischarge, List.map snd recsl)))) with | Vernacextend.VtSideff ids, _ when hard -> - Vernacextend.(VtStartProof ("Classic", GuaranteesOpacity, ids), VtLater) + Vernacextend.(VtStartProof (GuaranteesOpacity, ids), VtLater) | x -> x } -> { do_generate_principle false (List.map snd recsl) } END diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 98aaa081c3..4b6caea70d 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -1494,7 +1494,7 @@ let do_build_inductive let _time2 = System.get_time () in try with_full_print - (Flags.silently (ComInductive.do_mutual_inductive ~template:None None rel_inds false false false ~uniform:ComInductive.NonUniformParameters)) + (Flags.silently (ComInductive.do_mutual_inductive ~template:(Some false) None rel_inds false false false ~uniform:ComInductive.NonUniformParameters)) Declarations.Finite with | UserError(s,msg) as e -> diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index d9b19c1ae6..4c24f51b1e 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -58,15 +58,8 @@ let new_entry name = let toplevel_selector = new_entry "vernac:toplevel_selector" let tacdef_body = new_entry "tactic:tacdef_body" -(* Registers the Classic Proof Mode (which uses [tactic_mode] as a parser for - proof editing and changes nothing else). Then sets it as the default proof mode. *) -let _ = - let mode = { - Proof_global.name = "Classic"; - set = (fun () -> Pvernac.set_command_entry tactic_mode); - reset = (fun () -> Pvernac.(set_command_entry noedit_mode)); - } in - Proof_global.register_proof_mode mode +(* Registers [tactic_mode] as a parser for proof editing *) +let classic_proof_mode = Pvernac.register_proof_mode "Classic" tactic_mode (* Hack to parse "[ id" without dropping [ *) let test_bracket_ident = diff --git a/plugins/ltac/g_obligations.mlg b/plugins/ltac/g_obligations.mlg index 1ea6ff84d4..cdee012a82 100644 --- a/plugins/ltac/g_obligations.mlg +++ b/plugins/ltac/g_obligations.mlg @@ -83,7 +83,7 @@ open Obligations let obligation obl tac = with_tac (fun t -> Obligations.obligation obl t) tac let next_obligation obl tac = with_tac (fun t -> Obligations.next_obligation obl t) tac -let classify_obbl _ = Vernacextend.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]), VtLater) +let classify_obbl _ = Vernacextend.(VtStartProof (Doesn'tGuaranteeOpacity,[]), VtLater) } diff --git a/plugins/ltac/g_rewrite.mlg b/plugins/ltac/g_rewrite.mlg index 31fb1c9abf..db8d1b20d8 100644 --- a/plugins/ltac/g_rewrite.mlg +++ b/plugins/ltac/g_rewrite.mlg @@ -285,13 +285,13 @@ VERNAC COMMAND EXTEND AddSetoid1 CLASSIFIED AS SIDEFF add_morphism_infer atts m n; } | #[ atts = rewrite_attributes; ] [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] - => { VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater } + => { VtStartProof(GuaranteesOpacity,[n]), VtLater } -> { add_morphism atts [] m s n; } | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] - => { VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater } + => { VtStartProof(GuaranteesOpacity,[n]), VtLater } -> { add_morphism atts binders m s n; } diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index 46ea3819ac..7bf705ffeb 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -287,10 +287,10 @@ GRAMMAR EXTEND Gram [ [ c = smart_global; nl = occs -> { (nl,c) } ] ] ; intropatterns: - [ [ l = LIST0 nonsimple_intropattern -> { l } ] ] + [ [ l = LIST0 intropattern -> { l } ] ] ; ne_intropatterns: - [ [ l = LIST1 nonsimple_intropattern -> { l } ] ] + [ [ l = LIST1 intropattern -> { l } ] ] ; or_and_intropattern: [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> { IntroOrPattern tc } @@ -317,7 +317,7 @@ GRAMMAR EXTEND Gram | "?" -> { IntroAnonymous } | id = ident -> { IntroIdentifier id } ] ] ; - nonsimple_intropattern: + intropattern: [ [ l = simple_intropattern -> { l } | "*" -> { CAst.make ~loc @@ IntroForthcoming true } | "**" -> { CAst.make ~loc @@ IntroForthcoming false } ] ] @@ -534,6 +534,8 @@ GRAMMAR EXTEND Gram { TacAtom (CAst.make ~loc @@ TacIntroPattern (false,[CAst.make ~loc @@IntroForthcoming false])) } | IDENT "eintros"; pl = ne_intropatterns -> { TacAtom (CAst.make ~loc @@ TacIntroPattern (true,pl)) } + | IDENT "eintros" -> + { TacAtom (CAst.make ~loc @@ TacIntroPattern (true,[CAst.make ~loc @@IntroForthcoming false])) } | IDENT "apply"; cl = LIST1 constr_with_bindings_arg SEP ","; inhyp = in_hyp_as -> { TacAtom (CAst.make ~loc @@ TacApply (true,false,cl,inhyp)) } diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 4bb52f599a..2055b25ff4 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -2014,7 +2014,7 @@ let add_morphism atts binders m s n = in let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in ignore(new_instance ~program_mode:atts.program ~global:atts.global atts.polymorphic binders instance - (Some (true, CAst.make @@ CRecord [])) + None ~generalize:false ~tac ~hook:(declare_projection n instance_id) Hints.empty_hint_info) (** Bind to "rewrite" too *) diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 816741b894..3e7479903a 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -104,7 +104,7 @@ let pr_appl h vs = let rec name_with_list appl t = match appl with | [] -> t - | (h,vs)::l -> Proofview.Trace.name_tactic (fun () -> pr_appl h vs) (name_with_list l t) + | (h,vs)::l -> Proofview.Trace.name_tactic (fun _ _ -> pr_appl h vs) (name_with_list l t) let name_if_glob appl t = match appl with | UnnamedAppl -> t @@ -1050,7 +1050,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with return (hov 0 msg , hov 0 msg) in let print (_,msgnl) = Proofview.(tclLIFT (NonLogical.print_info msgnl)) in - let log (msg,_) = Proofview.Trace.log (fun () -> msg) in + let log (msg,_) = Proofview.Trace.log (fun _ _ -> msg) in let break = Proofview.tclLIFT (db_breakpoint (curr_debug ist) s) in Ftactic.run msgnl begin fun msgnl -> print msgnl <*> log msgnl <*> break @@ -1132,7 +1132,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with in let tac = Ftactic.with_env interp_vars >>= fun (env, lr) -> - let name () = Pptactic.pr_alias (fun v -> print_top_val env v) 0 s lr in + let name _ _ = Pptactic.pr_alias (fun v -> print_top_val env v) 0 s lr in Proofview.Trace.name_tactic name (tac lr) (* spiwack: this use of name_tactic is not robust to a change of implementation of [Ftactic]. In such a situation, @@ -1153,7 +1153,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with let tac = Tacenv.interp_ml_tactic opn in let args = Ftactic.List.map_right (fun a -> interp_tacarg ist a) l in let tac args = - let name () = Pptactic.pr_extend (fun v -> print_top_val () v) 0 opn args in + let name _ _ = Pptactic.pr_extend (fun v -> print_top_val () v) 0 opn args in Proofview.Trace.name_tactic name (catch_error_tac trace (tac args ist)) in Ftactic.run args tac @@ -1539,7 +1539,7 @@ and name_atomic ?env tacexpr tac : unit Proofview.tactic = | None -> Proofview.tclENV end >>= fun env -> Proofview.tclEVARMAP >>= fun sigma -> - let name () = Pptactic.pr_atomic_tactic env sigma tacexpr in + let name _ _ = Pptactic.pr_atomic_tactic env sigma tacexpr in Proofview.Trace.name_tactic name tac (* Interprets a primitive tactic *) @@ -1560,7 +1560,7 @@ and interp_atomic ist tac : unit Proofview.tactic = end | TacApply (a,ev,cb,cl) -> (* spiwack: until the tactic is in the monad *) - Proofview.Trace.name_tactic (fun () -> Pp.str"<apply>") begin + Proofview.Trace.name_tactic (fun _ _ -> Pp.str"<apply>") begin Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in @@ -1601,7 +1601,7 @@ and interp_atomic ist tac : unit Proofview.tactic = end | TacMutualFix (id,n,l) -> (* spiwack: until the tactic is in the monad *) - Proofview.Trace.name_tactic (fun () -> Pp.str"<mutual fix>") begin + Proofview.Trace.name_tactic (fun _ _ -> Pp.str"<mutual fix>") begin Proofview.Goal.enter begin fun gl -> let env = pf_env gl in let f sigma (id,n,c) = @@ -1616,7 +1616,7 @@ and interp_atomic ist tac : unit Proofview.tactic = end | TacMutualCofix (id,l) -> (* spiwack: until the tactic is in the monad *) - Proofview.Trace.name_tactic (fun () -> Pp.str"<mutual cofix>") begin + Proofview.Trace.name_tactic (fun _ _ -> Pp.str"<mutual cofix>") begin Proofview.Goal.enter begin fun gl -> let env = pf_env gl in let f sigma (id,c) = @@ -1731,7 +1731,7 @@ and interp_atomic ist tac : unit Proofview.tactic = end | TacChange (None,c,cl) -> (* spiwack: until the tactic is in the monad *) - Proofview.Trace.name_tactic (fun () -> Pp.str"<change>") begin + Proofview.Trace.name_tactic (fun _ _ -> Pp.str"<change>") begin Proofview.Goal.enter begin fun gl -> let is_onhyps = match cl.onhyps with | None | Some [] -> true @@ -1756,7 +1756,7 @@ and interp_atomic ist tac : unit Proofview.tactic = end | TacChange (Some op,c,cl) -> (* spiwack: until the tactic is in the monad *) - Proofview.Trace.name_tactic (fun () -> Pp.str"<change>") begin + Proofview.Trace.name_tactic (fun _ _ -> Pp.str"<change>") begin Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in @@ -1957,7 +1957,9 @@ let lifts f = (); fun ist x -> Ftactic.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let (sigma, v) = f ist env sigma x in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) - (Ftactic.return v) + (* FIXME once we don't need to catch side effects *) + (Proofview.tclTHEN (Proofview.Unsafe.tclSETENV (Global.env())) + (Ftactic.return v)) end let interp_bindings' ist bl = Ftactic.return begin fun env sigma -> diff --git a/plugins/micromega/EnvRing.v b/plugins/micromega/EnvRing.v index 4042959b50..eb84b1203d 100644 --- a/plugins/micromega/EnvRing.v +++ b/plugins/micromega/EnvRing.v @@ -118,6 +118,7 @@ Section MakeRingPol. - (Pinj i (Pc c)) is (Pc c) *) + #[universes(template)] Inductive Pol : Type := | Pc : C -> Pol | Pinj : positive -> Pol -> Pol @@ -939,6 +940,7 @@ Qed. (** Definition of polynomial expressions *) + #[universes(template)] Inductive PExpr : Type := | PEc : C -> PExpr | PEX : positive -> PExpr diff --git a/plugins/micromega/RingMicromega.v b/plugins/micromega/RingMicromega.v index f066ea462f..782fab5e68 100644 --- a/plugins/micromega/RingMicromega.v +++ b/plugins/micromega/RingMicromega.v @@ -289,6 +289,7 @@ destruct o' ; rewrite H1 ; now rewrite (Rplus_0_l sor). now apply (Rplus_nonneg_nonneg sor). Qed. +#[universes(template)] Inductive Psatz : Type := | PsatzIn : nat -> Psatz | PsatzSquare : PolC -> Psatz @@ -685,6 +686,7 @@ end. Definition eval_pexpr : PolEnv -> PExpr C -> R := PEeval rplus rtimes rminus ropp phi pow_phi rpow. +#[universes(template)] Record Formula (T:Type) : Type := { Flhs : PExpr T; Fop : Op2; diff --git a/plugins/micromega/Tauto.v b/plugins/micromega/Tauto.v index 458844e1b9..587f2f1fa4 100644 --- a/plugins/micromega/Tauto.v +++ b/plugins/micromega/Tauto.v @@ -21,6 +21,7 @@ Require Import Bool. Set Implicit Arguments. + #[universes(template)] Inductive BFormula (A:Type) : Type := | TT : BFormula A | FF : BFormula A diff --git a/plugins/micromega/VarMap.v b/plugins/micromega/VarMap.v index 2d2c0bc77a..c888f9af45 100644 --- a/plugins/micromega/VarMap.v +++ b/plugins/micromega/VarMap.v @@ -30,6 +30,7 @@ Section MakeVarMap. Variable A : Type. Variable default : A. + #[universes(template)] Inductive t : Type := | Empty : t | Leaf : A -> t diff --git a/plugins/nsatz/Nsatz.v b/plugins/nsatz/Nsatz.v index c5a09d677e..a964febf9c 100644 --- a/plugins/nsatz/Nsatz.v +++ b/plugins/nsatz/Nsatz.v @@ -452,6 +452,7 @@ constructor;red;intros;subst;trivial. Qed. Instance Rops: (@Ring_ops R 0%R 1%R Rplus Rmult Rminus Ropp (@eq R)). +Defined. Instance Rri : (Ring (Ro:=Rops)). constructor; @@ -468,6 +469,7 @@ Class can_compute_Z (z : Z) := dummy_can_compute_Z : True. Hint Extern 0 (can_compute_Z ?v) => match isZcst v with true => exact I end : typeclass_instances. Instance reify_IZR z lvar {_ : can_compute_Z z} : reify (PEc z) lvar (IZR z). +Defined. Lemma R_one_zero: 1%R <> 0%R. discrR. @@ -484,6 +486,7 @@ exact Rmult_integral. exact R_one_zero. Defined. Require Import QArith. Instance Qops: (@Ring_ops Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq). +Defined. Instance Qri : (Ring (Ro:=Qops)). constructor. diff --git a/plugins/omega/PreOmega.v b/plugins/omega/PreOmega.v index 94a3d40441..695f000cb1 100644 --- a/plugins/omega/PreOmega.v +++ b/plugins/omega/PreOmega.v @@ -12,6 +12,120 @@ Require Import Arith Max Min BinInt BinNat Znat Nnat. Local Open Scope Z_scope. +(** * [Z.div_mod_to_equations], [Z.quot_rem_to_equations], [Z.to_euclidean_division_equations]: the tactics for preprocessing [Z.div] and [Z.modulo], [Z.quot] and [Z.rem] *) + +(** These tactic use the complete specification of [Z.div] and + [Z.modulo] ([Z.quot] and [Z.rem], respectively) to remove these + functions from the goal without losing information. The + [Z.euclidean_division_equations_cleanup] tactic removes needless + hypotheses, which makes tactics like [nia] run faster. The tactic + [Z.to_euclidean_division_equations] combines the handling of both variants + of division/quotient and modulo/remainder. *) + +Module Z. + Lemma mod_0_r_ext x y : y = 0 -> x mod y = 0. + Proof. intro; subst; destruct x; reflexivity. Qed. + Lemma div_0_r_ext x y : y = 0 -> x / y = 0. + Proof. intro; subst; destruct x; reflexivity. Qed. + + Lemma rem_0_r_ext x y : y = 0 -> Z.rem x y = x. + Proof. intro; subst; destruct x; reflexivity. Qed. + Lemma quot_0_r_ext x y : y = 0 -> Z.quot x y = 0. + Proof. intro; subst; destruct x; reflexivity. Qed. + + Lemma rem_bound_pos_pos x y : 0 < y -> 0 <= x -> 0 <= Z.rem x y < y. + Proof. intros; apply Z.rem_bound_pos; assumption. Qed. + Lemma rem_bound_neg_pos x y : y < 0 -> 0 <= x -> 0 <= Z.rem x y < -y. + Proof. rewrite <- Z.rem_opp_r'; intros; apply Z.rem_bound_pos; rewrite ?Z.opp_pos_neg; assumption. Qed. + Lemma rem_bound_pos_neg x y : 0 < y -> x <= 0 -> -y < Z.rem x y <= 0. + Proof. rewrite <- (Z.opp_involutive x), Z.rem_opp_l', <- Z.opp_lt_mono, and_comm, !Z.opp_nonpos_nonneg; apply rem_bound_pos_pos. Qed. + Lemma rem_bound_neg_neg x y : y < 0 -> x <= 0 -> y < Z.rem x y <= 0. + Proof. rewrite <- (Z.opp_involutive x), <- (Z.opp_involutive y), Z.rem_opp_l', <- Z.opp_lt_mono, and_comm, !Z.opp_nonpos_nonneg, Z.opp_involutive; apply rem_bound_neg_pos. Qed. + + Ltac div_mod_to_equations_generalize x y := + pose proof (Z.div_mod x y); + pose proof (Z.mod_pos_bound x y); + pose proof (Z.mod_neg_bound x y); + pose proof (div_0_r_ext x y); + pose proof (mod_0_r_ext x y); + let q := fresh "q" in + let r := fresh "r" in + set (q := x / y) in *; + set (r := x mod y) in *; + clearbody q r. + Ltac quot_rem_to_equations_generalize x y := + pose proof (Z.quot_rem' x y); + pose proof (rem_bound_pos_pos x y); + pose proof (rem_bound_pos_neg x y); + pose proof (rem_bound_neg_pos x y); + pose proof (rem_bound_neg_neg x y); + pose proof (quot_0_r_ext x y); + pose proof (rem_0_r_ext x y); + let q := fresh "q" in + let r := fresh "r" in + set (q := Z.quot x y) in *; + set (r := Z.rem x y) in *; + clearbody q r. + + Ltac div_mod_to_equations_step := + match goal with + | [ |- context[?x / ?y] ] => div_mod_to_equations_generalize x y + | [ |- context[?x mod ?y] ] => div_mod_to_equations_generalize x y + | [ H : context[?x / ?y] |- _ ] => div_mod_to_equations_generalize x y + | [ H : context[?x mod ?y] |- _ ] => div_mod_to_equations_generalize x y + end. + Ltac quot_rem_to_equations_step := + match goal with + | [ |- context[Z.quot ?x ?y] ] => quot_rem_to_equations_generalize x y + | [ |- context[Z.rem ?x ?y] ] => quot_rem_to_equations_generalize x y + | [ H : context[Z.quot ?x ?y] |- _ ] => quot_rem_to_equations_generalize x y + | [ H : context[Z.rem ?x ?y] |- _ ] => quot_rem_to_equations_generalize x y + end. + Ltac div_mod_to_equations' := repeat div_mod_to_equations_step. + Ltac quot_rem_to_equations' := repeat quot_rem_to_equations_step. + Ltac euclidean_division_equations_cleanup := + repeat match goal with + | [ H : ?x = ?x -> _ |- _ ] => specialize (H eq_refl) + | [ H : ?x <> ?x -> _ |- _ ] => clear H + | [ H : ?x < ?x -> _ |- _ ] => clear H + | [ H : ?T -> _, H' : ?T |- _ ] => specialize (H H') + | [ H : ?T -> _, H' : ~?T |- _ ] => clear H + | [ H : ~?T -> _, H' : ?T |- _ ] => clear H + | [ H : ?A -> ?x = ?x -> _ |- _ ] => specialize (fun a => H a eq_refl) + | [ H : ?A -> ?x <> ?x -> _ |- _ ] => clear H + | [ H : ?A -> ?x < ?x -> _ |- _ ] => clear H + | [ H : ?A -> ?B -> _, H' : ?B |- _ ] => specialize (fun a => H a H') + | [ H : ?A -> ?B -> _, H' : ~?B |- _ ] => clear H + | [ H : ?A -> ~?B -> _, H' : ?B |- _ ] => clear H + | [ H : 0 < ?x -> _, H' : ?x < 0 |- _ ] => clear H + | [ H : ?x < 0 -> _, H' : 0 < ?x |- _ ] => clear H + | [ H : ?A -> 0 < ?x -> _, H' : ?x < 0 |- _ ] => clear H + | [ H : ?A -> ?x < 0 -> _, H' : 0 < ?x |- _ ] => clear H + | [ H : 0 <= ?x -> _, H' : ?x < 0 |- _ ] => clear H + | [ H : ?x <= 0 -> _, H' : 0 < ?x |- _ ] => clear H + | [ H : ?A -> 0 <= ?x -> _, H' : ?x < 0 |- _ ] => clear H + | [ H : ?A -> ?x <= 0 -> _, H' : 0 < ?x |- _ ] => clear H + | [ H : 0 < ?x -> _, H' : ?x <= 0 |- _ ] => clear H + | [ H : ?x < 0 -> _, H' : 0 <= ?x |- _ ] => clear H + | [ H : ?A -> 0 < ?x -> _, H' : ?x <= 0 |- _ ] => clear H + | [ H : ?A -> ?x < 0 -> _, H' : 0 <= ?x |- _ ] => clear H + | [ H : 0 <= ?x -> _, H' : ?x <= 0 |- _ ] => specialize (fun pf => H (@Z.eq_le_incl 0 x (eq_sym pf))) + | [ H : ?A -> 0 <= ?x -> _, H' : ?x <= 0 |- _ ] => specialize (fun a pf => H a (@Z.eq_le_incl 0 x (eq_sym pf))) + | [ H : ?x <= 0 -> _, H' : 0 <= ?x |- _ ] => specialize (fun pf => H (@Z.eq_le_incl 0 x pf)) + | [ H : ?A -> ?x <= 0 -> _, H' : 0 <= ?x |- _ ] => specialize (fun a pf => H a (@Z.eq_le_incl x 0 pf)) + | [ H : ?x < ?y -> _, H' : ?x = ?y |- _ ] => clear H + | [ H : ?x < ?y -> _, H' : ?y = ?x |- _ ] => clear H + | [ H : ?A -> ?x < ?y -> _, H' : ?x = ?y |- _ ] => clear H + | [ H : ?A -> ?x < ?y -> _, H' : ?y = ?x |- _ ] => clear H + | [ H : ?x = ?y -> _, H' : ?x < ?y |- _ ] => clear H + | [ H : ?x = ?y -> _, H' : ?y < ?x |- _ ] => clear H + | [ H : ?A -> ?x = ?y -> _, H' : ?x < ?y |- _ ] => clear H + | [ H : ?A -> ?x = ?y -> _, H' : ?y < ?x |- _ ] => clear H + end. + Ltac div_mod_to_equations := div_mod_to_equations'; euclidean_division_equations_cleanup. + Ltac quot_rem_to_equations := quot_rem_to_equations'; euclidean_division_equations_cleanup. + Ltac to_euclidean_division_equations := div_mod_to_equations'; quot_rem_to_equations'; euclidean_division_equations_cleanup. +End Z. (** * zify: the Z-ification tactic *) @@ -411,6 +525,24 @@ Ltac zify_N_op := | |- context [ Z.of_N (N.mul ?a ?b) ] => pose proof (N2Z.is_nonneg (N.mul a b)); rewrite (N2Z.inj_mul a b) in * + (* N.div -> Z.div and a positivity hypothesis *) + | H : context [ Z.of_N (N.div ?a ?b) ] |- _ => + pose proof (N2Z.is_nonneg (N.div a b)); rewrite (N2Z.inj_div a b) in * + | |- context [ Z.of_N (N.div ?a ?b) ] => + pose proof (N2Z.is_nonneg (N.div a b)); rewrite (N2Z.inj_div a b) in * + + (* N.modulo -> Z.rem / Z.modulo and a positivity hypothesis (N.modulo agrees with Z.modulo on everything except 0; so we pose both the non-zero proof for this agreement, but also replace things with [Z.rem]) *) + | H : context [ Z.of_N (N.modulo ?a ?b) ] |- _ => + pose proof (N2Z.is_nonneg (N.modulo a b)); + pose proof (@Z.quot_div_nonneg (Z.of_N a) (Z.of_N b) (N2Z.is_nonneg a)); + pose proof (@Z.rem_mod_nonneg (Z.of_N a) (Z.of_N b) (N2Z.is_nonneg a)); + rewrite (N2Z.inj_rem a b) in * + | |- context [ Z.of_N (N.div ?a ?b) ] => + pose proof (N2Z.is_nonneg (N.modulo a b)); + pose proof (@Z.quot_div_nonneg (Z.of_N a) (Z.of_N b) (N2Z.is_nonneg a)); + pose proof (@Z.rem_mod_nonneg (Z.of_N a) (Z.of_N b) (N2Z.is_nonneg a)); + rewrite (N2Z.inj_rem a b) in * + (* atoms of type N : we add a positivity condition (if not already there) *) | _ : 0 <= Z.of_N ?a |- _ => hide_Z_of_N a | _ : context [ Z.of_N ?a ] |- _ => pose proof (N2Z.is_nonneg a); hide_Z_of_N a diff --git a/plugins/rtauto/Bintree.v b/plugins/rtauto/Bintree.v index 99c02995fb..751f0d8334 100644 --- a/plugins/rtauto/Bintree.v +++ b/plugins/rtauto/Bintree.v @@ -81,10 +81,12 @@ Section Store. Variable A:Type. +#[universes(template)] Inductive Poption : Type:= PSome : A -> Poption | PNone : Poption. +#[universes(template)] Inductive Tree : Type := Tempty : Tree | Branch0 : Tree -> Tree -> Tree @@ -177,6 +179,7 @@ generalize i;clear i;induction j;destruct T;simpl in H|-*; destruct i;simpl;try rewrite (IHj _ H);try (destruct i;simpl;congruence);reflexivity|| congruence. Qed. +#[universes(template)] Record Store : Type := mkStore {index:positive;contents:Tree}. @@ -191,6 +194,7 @@ Lemma get_empty : forall i, get i empty = PNone. intro i; case i; unfold empty,get; simpl;reflexivity. Qed. +#[universes(template)] Inductive Full : Store -> Type:= F_empty : Full empty | F_push : forall a S, Full S -> Full (push a S). diff --git a/plugins/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v index ce115f564f..dba72337b2 100644 --- a/plugins/setoid_ring/Field_theory.v +++ b/plugins/setoid_ring/Field_theory.v @@ -730,6 +730,7 @@ Qed. (* The input: syntax of a field expression *) +#[universes(template)] Inductive FExpr : Type := | FEO : FExpr | FEI : FExpr @@ -762,6 +763,7 @@ Strategy expand [FEeval]. (* The result of the normalisation *) +#[universes(template)] Record linear : Type := mk_linear { num : PExpr C; denum : PExpr C; @@ -944,6 +946,7 @@ induction e2; intros p1 p2; now rewrite <- PEpow_mul_r. Qed. +#[universes(template)] Record rsplit : Type := mk_rsplit { rsplit_left : PExpr C; rsplit_common : PExpr C; diff --git a/plugins/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v index f5db275465..15d490a6ab 100644 --- a/plugins/setoid_ring/InitialRing.v +++ b/plugins/setoid_ring/InitialRing.v @@ -740,6 +740,7 @@ Ltac abstract_ring_morphism set ext rspec := | _ => fail 1 "bad ring structure" end. +#[universes(template)] Record hypo : Type := mkhypo { hypo_type : Type; hypo_proof : hypo_type diff --git a/plugins/setoid_ring/Ncring_initial.v b/plugins/setoid_ring/Ncring_initial.v index 1ca6227f25..aa0370b2ac 100644 --- a/plugins/setoid_ring/Ncring_initial.v +++ b/plugins/setoid_ring/Ncring_initial.v @@ -32,6 +32,7 @@ Lemma Zsth : Equivalence (@eq Z). Proof. exact Z.eq_equiv. Qed. Instance Zops:@Ring_ops Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp (@eq Z). +Defined. Instance Zr: (@Ring _ _ _ _ _ _ _ _ Zops). Proof. diff --git a/plugins/setoid_ring/Ncring_polynom.v b/plugins/setoid_ring/Ncring_polynom.v index 12208ff6b9..31182f51e2 100644 --- a/plugins/setoid_ring/Ncring_polynom.v +++ b/plugins/setoid_ring/Ncring_polynom.v @@ -32,6 +32,7 @@ Variable phiCR_comm: forall (c:C)(x:R), x * [c] == [c] * x. with coefficients in C : *) +#[universes(template)] Inductive Pol : Type := | Pc : C -> Pol | PX : Pol -> positive -> positive -> Pol -> Pol. @@ -43,6 +44,7 @@ Definition cI:C . exact ring1. Defined. Definition P1 := Pc 1. Variable Ceqb:C->C->bool. +#[universes(template)] Class Equalityb (A : Type):= {equalityb : A -> A -> bool}. Notation "x =? y" := (equalityb x y) (at level 70, no associativity). Variable Ceqb_eq: forall x y:C, Ceqb x y = true -> (x == y). diff --git a/plugins/setoid_ring/Ncring_tac.v b/plugins/setoid_ring/Ncring_tac.v index 7958507819..c8d560cfe9 100644 --- a/plugins/setoid_ring/Ncring_tac.v +++ b/plugins/setoid_ring/Ncring_tac.v @@ -27,41 +27,50 @@ Class nth (R:Type) (t:R) (l:list R) (i:nat). Instance Ifind0 (R:Type) (t:R) l : nth t(t::l) 0. +Defined. Instance IfindS (R:Type) (t2 t1:R) l i {_:nth t1 l i} : nth t1 (t2::l) (S i) | 1. +Defined. Class closed (T:Type) (l:list T). Instance Iclosed_nil T : closed (T:=T) nil. +Defined. Instance Iclosed_cons T t (l:list T) {_:closed l} : closed (t::l). +Defined. Class reify (R:Type)`{Rr:Ring (T:=R)} (e:PExpr Z) (lvar:list R) (t:R). Instance reify_zero (R:Type) lvar op `{Ring (T:=R)(ring0:=op)} : reify (ring0:=op)(PEc 0%Z) lvar op. +Defined. Instance reify_one (R:Type) lvar op `{Ring (T:=R)(ring1:=op)} : reify (ring1:=op) (PEc 1%Z) lvar op. +Defined. Instance reifyZ0 (R:Type) lvar `{Ring (T:=R)} : reify (PEc Z0) lvar Z0|11. +Defined. Instance reifyZpos (R:Type) lvar (p:positive) `{Ring (T:=R)} : reify (PEc (Zpos p)) lvar (Zpos p)|11. +Defined. Instance reifyZneg (R:Type) lvar (p:positive) `{Ring (T:=R)} : reify (PEc (Zneg p)) lvar (Zneg p)|11. +Defined. Instance reify_add (R:Type) e1 lvar t1 e2 t2 op @@ -69,6 +78,7 @@ Instance reify_add (R:Type) {_:reify (add:=op) e1 lvar t1} {_:reify (add:=op) e2 lvar t2} : reify (add:=op) (PEadd e1 e2) lvar (op t1 t2). +Defined. Instance reify_mul (R:Type) e1 lvar t1 e2 t2 op @@ -76,6 +86,7 @@ Instance reify_mul (R:Type) {_:reify (mul:=op) e1 lvar t1} {_:reify (mul:=op) e2 lvar t2} : reify (mul:=op) (PEmul e1 e2) lvar (op t1 t2)|10. +Defined. Instance reify_mul_ext (R:Type) `{Ring R} lvar (z:Z) e2 t2 @@ -83,6 +94,7 @@ Instance reify_mul_ext (R:Type) `{Ring R} {_:reify e2 lvar t2} : reify (PEmul (PEc z) e2) lvar (@multiplication Z _ _ z t2)|9. +Defined. Instance reify_sub (R:Type) e1 lvar t1 e2 t2 op @@ -90,24 +102,28 @@ Instance reify_sub (R:Type) {_:reify (sub:=op) e1 lvar t1} {_:reify (sub:=op) e2 lvar t2} : reify (sub:=op) (PEsub e1 e2) lvar (op t1 t2). +Defined. Instance reify_opp (R:Type) e1 lvar t1 op `{Ring (T:=R)(opp:=op)} {_:reify (opp:=op) e1 lvar t1} : reify (opp:=op) (PEopp e1) lvar (op t1). +Defined. Instance reify_pow (R:Type) `{Ring R} e1 lvar t1 n `{Ring (T:=R)} {_:reify e1 lvar t1} : reify (PEpow e1 n) lvar (pow_N t1 n)|1. +Defined. Instance reify_var (R:Type) t lvar i `{nth R t lvar i} `{Rr: Ring (T:=R)} : reify (Rr:= Rr) (PEX Z (Pos.of_succ_nat i))lvar t | 100. +Defined. Class reifylist (R:Type)`{Rr:Ring (T:=R)} (lexpr:list (PExpr Z)) (lvar:list R) (lterm:list R). @@ -115,12 +131,14 @@ Class reifylist (R:Type)`{Rr:Ring (T:=R)} (lexpr:list (PExpr Z)) (lvar:list R) Instance reify_nil (R:Type) lvar `{Rr: Ring (T:=R)} : reifylist (Rr:= Rr) nil lvar (@nil R). +Defined. Instance reify_cons (R:Type) e1 lvar t1 lexpr2 lterm2 `{Rr: Ring (T:=R)} {_:reify (Rr:= Rr) e1 lvar t1} {_:reifylist (Rr:= Rr) lexpr2 lvar lterm2} : reifylist (Rr:= Rr) (e1::lexpr2) lvar (t1::lterm2). +Defined. Definition list_reifyl (R:Type) lexpr lvar lterm `{Rr: Ring (T:=R)} diff --git a/plugins/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v index ccd82eabcd..9ef24144d2 100644 --- a/plugins/setoid_ring/Ring_polynom.v +++ b/plugins/setoid_ring/Ring_polynom.v @@ -121,6 +121,7 @@ Section MakeRingPol. - (Pinj i (Pc c)) is (Pc c) *) + #[universes(template)] Inductive Pol : Type := | Pc : C -> Pol | Pinj : positive -> Pol -> Pol @@ -908,6 +909,7 @@ Section MakeRingPol. (** Definition of polynomial expressions *) + #[universes(template)] Inductive PExpr : Type := | PEO : PExpr | PEI : PExpr diff --git a/plugins/setoid_ring/Ring_theory.v b/plugins/setoid_ring/Ring_theory.v index d67a8d8dce..6c782269ab 100644 --- a/plugins/setoid_ring/Ring_theory.v +++ b/plugins/setoid_ring/Ring_theory.v @@ -540,6 +540,7 @@ Section AddRing. Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). Variable req : R -> R -> Prop. *) +#[universes(template)] Inductive ring_kind : Type := | Abstract | Computational diff --git a/plugins/setoid_ring/Rings_Q.v b/plugins/setoid_ring/Rings_Q.v index ae91ee1664..df3677e1c3 100644 --- a/plugins/setoid_ring/Rings_Q.v +++ b/plugins/setoid_ring/Rings_Q.v @@ -15,6 +15,7 @@ Require Export Integral_domain. Require Import QArith. Instance Qops: (@Ring_ops Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq). +Defined. Instance Qri : (Ring (Ro:=Qops)). constructor. diff --git a/plugins/setoid_ring/Rings_R.v b/plugins/setoid_ring/Rings_R.v index 901b36ed3b..fe7558845d 100644 --- a/plugins/setoid_ring/Rings_R.v +++ b/plugins/setoid_ring/Rings_R.v @@ -20,6 +20,7 @@ constructor;red;intros;subst;trivial. Qed. Instance Rops: (@Ring_ops R 0%R 1%R Rplus Rmult Rminus Ropp (@eq R)). +Defined. Instance Rri : (Ring (Ro:=Rops)). constructor; diff --git a/plugins/ssr/ssrast.mli b/plugins/ssr/ssrast.mli index fac524da6b..9ce9250a43 100644 --- a/plugins/ssr/ssrast.mli +++ b/plugins/ssr/ssrast.mli @@ -64,12 +64,10 @@ type ast_closure_term = { type ssrview = ast_closure_term list -type id_mod = Dependent - type id_block = Prefix of Id.t | SuffixId of Id.t | SuffixNum of int (* Only [One] forces an introduction, possibly reducing the goal. *) -type anon_iter = +type anon_kind = | One of string option (* name hint *) | Drop | All @@ -77,25 +75,24 @@ type anon_iter = type ssripat = | IPatNoop - | IPatId of id_mod option * Id.t - | IPatAnon of anon_iter (* inaccessible name *) -(* TODO | IPatClearMark *) - | IPatDispatch of bool (* ssr exception: accept a dispatch on the empty list even when there are subgoals *) * ssripatss_or_block (* (..|..) *) - | IPatCase of (* ipats_mod option * *) ssripatss_or_block (* this is not equivalent to /case /[..|..] if there are already multiple goals *) + | IPatId of Id.t + | IPatAnon of anon_kind (* inaccessible name *) + | IPatDispatch of ssripatss_or_block (* (..|..) *) + | IPatCase of ssripatss_or_block (* [..|..] *) | IPatInj of ssripatss | IPatRewrite of (*occurrence option * rewrite_pattern **) ssrocc * ssrdir - | IPatView of bool * ssrview (* {}/view (true if the clear is present) *) + | IPatView of ssrview (* /view *) | IPatClear of ssrclear (* {H1 H2} *) | IPatSimpl of ssrsimpl | IPatAbstractVars of Id.t list - | IPatEqGen of unit Proofview.tactic (* internal use: generation of eqn *) + | IPatFastNondep and ssripats = ssripat list and ssripatss = ssripats list and ssripatss_or_block = | Block of id_block | Regular of ssripats list -type ssrhpats = ((ssrclear * ssripats) * ssripats) * ssripats +type ssrhpats = ((ssrclear option * ssripats) * ssripats) * ssripats type ssrhpats_wtransp = bool * ssrhpats (* tac => inpats *) diff --git a/plugins/ssr/ssrbool.v b/plugins/ssr/ssrbool.v index 3a7cf41d43..ed4ff2aa66 100644 --- a/plugins/ssr/ssrbool.v +++ b/plugins/ssr/ssrbool.v @@ -609,6 +609,7 @@ Hint View for apply// equivPif|3 xorPif|3 equivPifn|3 xorPifn|3. (** Allow the direct application of a reflection lemma to a boolean assertion. **) Coercion elimT : reflect >-> Funclass. +#[universes(template)] Variant implies P Q := Implies of P -> Q. Lemma impliesP P Q : implies P Q -> P -> Q. Proof. by case. Qed. Lemma impliesPn (P Q : Prop) : implies P Q -> ~ Q -> ~ P. @@ -1130,10 +1131,12 @@ Proof. by move=> *; apply/orP; left. Qed. Lemma subrelUr r1 r2 : subrel r2 (relU r1 r2). Proof. by move=> *; apply/orP; right. Qed. +#[universes(template)] Variant mem_pred := Mem of pred T. Definition isMem pT topred mem := mem = (fun p : pT => Mem [eta topred p]). +#[universes(template)] Structure predType := PredType { pred_sort :> Type; topred : pred_sort -> pred T; @@ -1275,6 +1278,7 @@ Implicit Types (x : T) (p : pred T) (sp : simpl_pred T) (pp : pT). implementation of unification, notably improper expansion of telescope projections and overwriting of a variable assignment by a later unification (probably due to conversion cache cross-talk). **) +#[universes(template)] Structure manifest_applicative_pred p := ManifestApplicativePred { manifest_applicative_pred_value :> pred T; _ : manifest_applicative_pred_value = p @@ -1283,18 +1287,21 @@ Definition ApplicativePred p := ManifestApplicativePred (erefl p). Canonical applicative_pred_applicative sp := ApplicativePred (applicative_pred_of_simpl sp). +#[universes(template)] Structure manifest_simpl_pred p := ManifestSimplPred { manifest_simpl_pred_value :> simpl_pred T; _ : manifest_simpl_pred_value = SimplPred p }. Canonical expose_simpl_pred p := ManifestSimplPred (erefl (SimplPred p)). +#[universes(template)] Structure manifest_mem_pred p := ManifestMemPred { manifest_mem_pred_value :> mem_pred T; _ : manifest_mem_pred_value= Mem [eta p] }. Canonical expose_mem_pred p := @ManifestMemPred p _ (erefl _). +#[universes(template)] Structure applicative_mem_pred p := ApplicativeMemPred {applicative_mem_pred_value :> manifest_mem_pred p}. Canonical check_applicative_mem_pred p (ap : manifest_applicative_pred p) mp := @@ -1345,6 +1352,7 @@ End simpl_mem. (** Qualifiers and keyed predicates. **) +#[universes(template)] Variant qualifier (q : nat) T := Qualifier of predPredType T. Coercion has_quality n T (q : qualifier n T) : pred_class := @@ -1392,9 +1400,11 @@ Notation "[ 'qualify' 'an' x : T | P ]" := (Qualifier 2 (fun x : T => P%B)) Section KeyPred. Variable T : Type. +#[universes(template)] Variant pred_key (p : predPredType T) := DefaultPredKey. Variable p : predPredType T. +#[universes(template)] Structure keyed_pred (k : pred_key p) := PackKeyedPred {unkey_pred :> pred_class; _ : unkey_pred =i p}. @@ -1426,6 +1436,7 @@ Section KeyedQualifier. Variables (T : Type) (n : nat) (q : qualifier n T). +#[universes(template)] Structure keyed_qualifier (k : pred_key q) := PackKeyedQualifier {unkey_qualifier; _ : unkey_qualifier = q}. Definition KeyedQualifier k := PackKeyedQualifier k (erefl q). diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 311d912efd..c3b9bde9b8 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -66,7 +66,7 @@ let check_hyp_exists hyps (SsrHyp(_, id)) = try ignore(Context.Named.lookup id hyps) with Not_found -> errorstrm Pp.(str"No assumption is named " ++ Id.print id) -let test_hypname_exists hyps id = +let test_hyp_exists hyps (SsrHyp(_, id)) = try ignore(Context.Named.lookup id hyps); true with Not_found -> false diff --git a/plugins/ssr/ssrcommon.mli b/plugins/ssr/ssrcommon.mli index 51116ccd75..e642b5e788 100644 --- a/plugins/ssr/ssrcommon.mli +++ b/plugins/ssr/ssrcommon.mli @@ -29,7 +29,7 @@ val allocc : ssrocc val hyp_id : ssrhyp -> Id.t val hyps_ids : ssrhyps -> Id.t list val check_hyp_exists : ('a, 'b) Context.Named.pt -> ssrhyp -> unit -val test_hypname_exists : ('a, 'b) Context.Named.pt -> Id.t -> bool +val test_hyp_exists : ('a, 'b) Context.Named.pt -> ssrhyp -> bool val check_hyps_uniq : Id.t list -> ssrhyps -> unit val not_section_id : Id.t -> bool val hyp_err : ?loc:Loc.t -> string -> Id.t -> 'a diff --git a/plugins/ssr/ssreflect.v b/plugins/ssr/ssreflect.v index 7596f6638a..4721e19a8b 100644 --- a/plugins/ssr/ssreflect.v +++ b/plugins/ssr/ssreflect.v @@ -178,6 +178,7 @@ Register abstract_key as plugins.ssreflect.abstract_key. Register abstract as plugins.ssreflect.abstract. (** Constants for tactic-views **) +#[universes(template)] Inductive external_view : Type := tactic_view of Type. (** @@ -206,6 +207,7 @@ Inductive external_view : Type := tactic_view of Type. Module TheCanonical. +#[universes(template)] Variant put vT sT (v1 v2 : vT) (s : sT) := Put. Definition get vT sT v s (p : @put vT sT v v s) := let: Put _ _ _ := p in s. @@ -301,9 +303,11 @@ Notation "{ 'type' 'of' c 'for' s }" := (dependentReturnType c s) We also define a simpler version ("phant" / "Phant") of phantom for the common case where p_type is Type. **) +#[universes(template)] Variant phantom T (p : T) := Phantom. Arguments phantom : clear implicits. Arguments Phantom : clear implicits. +#[universes(template)] Variant phant (p : Type) := Phant. (** Internal tagging used by the implementation of the ssreflect elim. **) @@ -389,6 +393,7 @@ Ltac ssrdone0 := | match goal with H : ~ _ |- _ => solve [case H; trivial] end ]. (** To unlock opaque constants. **) +#[universes(template)] Structure unlockable T v := Unlockable {unlocked : T; _ : unlocked = v}. Lemma unlock T x C : @unlocked T x C = x. Proof. by case: C. Qed. diff --git a/plugins/ssr/ssrfun.v b/plugins/ssr/ssrfun.v index 6535cad8b7..b51ffada0c 100644 --- a/plugins/ssr/ssrfun.v +++ b/plugins/ssr/ssrfun.v @@ -285,6 +285,7 @@ Lemma unitE : all_equal_to tt. Proof. by case. Qed. (** A generic wrapper type **) +#[universes(template)] Structure wrapped T := Wrap {unwrap : T}. Canonical wrap T x := @Wrap T x. @@ -334,6 +335,7 @@ Section SimplFun. Variables aT rT : Type. +#[universes(template)] Variant simpl_fun := SimplFun of aT -> rT. Definition fun_of_simpl f := fun x => let: SimplFun lam := f in lam x. diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index 37c583ab53..8c1363020a 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -94,17 +94,23 @@ let basecuttac name c gl = let introstac ipats = Proofview.V82.of_tactic (tclIPAT ipats) let havetac ist - (transp,((((clr, pats), binders), simpl), (((fk, _), t), hint))) + (transp,((((clr, orig_pats), binders), simpl), (((fk, _), t), hint))) suff namefst gl = let concl = pf_concl gl in + let pats = tclCompileIPats orig_pats in + let binders = tclCompileIPats binders in + let simpl = tclCompileIPats simpl in let skols, pats = - List.partition (function IPatAbstractVars _ -> true | _ -> false) pats in + List.partition (function IOpAbstractVars _ -> true | _ -> false) pats in let itac_mkabs = introstac skols in - let itac_c = introstac (IPatClear clr :: pats) in + let itac_c, clr = + match clr with + | None -> introstac pats, [] + | Some clr -> introstac (tclCompileIPats (IPatClear clr :: orig_pats)), clr in let itac, id, clr = introstac pats, Tacticals.tclIDTAC, old_cleartac clr in let binderstac n = - let rec aux = function 0 -> [] | n -> IPatAnon (One None) :: aux (n-1) in + let rec aux = function 0 -> [] | n -> IOpInaccessible None :: aux (n-1) in Tacticals.tclTHEN (if binders <> [] then introstac (aux n) else Tacticals.tclIDTAC) (introstac binders) in let simpltac = introstac simpl in @@ -160,7 +166,7 @@ let havetac ist gl, ty, Tacticals.tclTHEN assert_is_conv (Proofview.V82.of_tactic (Tactics.apply t)), id, itac_c | FwdHave, false, false -> let skols = List.flatten (List.map (function - | IPatAbstractVars ids -> ids + | IOpAbstractVars ids -> ids | _ -> assert false) skols) in let skols_args = List.map (fun id -> Ssripats.Internal.examine_abstract (EConstr.mkVar id) gl) skols in @@ -203,10 +209,12 @@ let destProd_or_LetIn sigma c = | _ -> raise DestKO let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = + let clr0 = Option.default [] clr0 in + let pats = tclCompileIPats pats in let mkabs gen = abs_wgen false (fun x -> x) gen in let mkclr gen clrs = clr_of_wgen gen clrs in let mkpats = function - | _, Some ((x, _), _) -> fun pats -> IPatId (None,hoi_id x) :: pats + | _, Some ((x, _), _) -> fun pats -> IOpId (hoi_id x) :: pats | _ -> fun x -> x in let ct = match Ssrcommon.ssrterm_of_ast_closure_term ct with | (a, (b, Some ct)) -> @@ -265,7 +273,7 @@ let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = if gens = [] then errorstrm(str"gen have requires some generalizations"); let clear0 = old_cleartac clr0 in let id, name_general_hyp, cleanup, pats = match id, pats with - | None, (IPatId(_, id) as ip)::pats -> Some id, tacipat [ip], clear0, pats + | None, (IOpId id as ip)::pats -> Some id, tacipat [ip], clear0, pats | None, _ -> None, Tacticals.tclIDTAC, clear0, pats | Some (Some id),_ -> Some id, introid id, clear0, pats | Some _,_ -> @@ -289,6 +297,10 @@ let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = (** The "suffice" tactic *) let sufftac ist ((((clr, pats),binders),simpl), ((_, c), hint)) = + let clr = Option.default [] clr in + let pats = tclCompileIPats pats in + let binders = tclCompileIPats binders in + let simpl = tclCompileIPats simpl in let htac = Tacticals.tclTHEN (introstac pats) (hinttac ist true hint) in let c = match Ssrcommon.ssrterm_of_ast_closure_term c with | (a, (b, Some ct)) -> diff --git a/plugins/ssr/ssrfwd.mli b/plugins/ssr/ssrfwd.mli index 8a05e25504..35e89dbcea 100644 --- a/plugins/ssr/ssrfwd.mli +++ b/plugins/ssr/ssrfwd.mli @@ -22,7 +22,7 @@ val ssrposetac : Id.t * (ssrfwdfmt * ast_closure_term) -> v82tac val havetac : ist -> bool * - ((((Ssrast.ssrclear * Ssrast.ssripat list) * Ssrast.ssripats) * + ((((Ssrast.ssrclear option * Ssrast.ssripat list) * Ssrast.ssripats) * Ssrast.ssripats) * (((Ssrast.ssrfwdkind * 'a) * ast_closure_term) * (bool * Tacinterp.Value.t option list))) -> @@ -35,7 +35,7 @@ val basecuttac : val wlogtac : Ltac_plugin.Tacinterp.interp_sign -> - ((Ssrast.ssrhyps * Ssrast.ssripats) * 'a) * 'b -> + ((Ssrast.ssrclear option * Ssrast.ssripats) * 'a) * 'b -> (Ssrast.ssrhyps * ((Ssrast.ssrhyp_or_id * string) * Ssrmatching_plugin.Ssrmatching.cpattern option) @@ -50,7 +50,7 @@ val wlogtac : val sufftac : Ssrast.ist -> - (((Ssrast.ssrhyps * Ssrast.ssripats) * Ssrast.ssripat list) * + (((Ssrast.ssrclear option * Ssrast.ssripats) * Ssrast.ssripat list) * Ssrast.ssripat list) * (('a * ast_closure_term) * diff --git a/plugins/ssr/ssripats.ml b/plugins/ssr/ssripats.ml index e71e1bae0d..a8dfd69240 100644 --- a/plugins/ssr/ssripats.ml +++ b/plugins/ssr/ssripats.ml @@ -19,14 +19,78 @@ open Proofview.Notations open Ssrast +type ssriop = + | IOpId of Names.Id.t + | IOpDrop + | IOpTemporay + | IOpInaccessible of string option + | IOpInaccessibleAll + | IOpAbstractVars of Names.Id.t list + | IOpFastNondep + + | IOpInj of ssriops list + + | IOpDispatchBlock of id_block + | IOpDispatchBranches of ssriops list + + | IOpCaseBlock of id_block + | IOpCaseBranches of ssriops list + + | IOpRewrite of ssrocc * ssrdir + | IOpView of ssrclear option * ssrview (* extra clears to be performed *) + + | IOpClear of ssrclear * ssrhyp option (* must clear, may clear *) + | IOpSimpl of ssrsimpl + + | IOpEqGen of unit Proofview.tactic (* generation of eqn *) + + | IOpNoop + +and ssriops = ssriop list + +let rec pr_ipatop = function + | IOpId id -> Names.Id.print id + | IOpDrop -> Pp.str "_" + | IOpTemporay -> Pp.str "+" + | IOpInaccessible None -> Pp.str "?" + | IOpInaccessible (Some s) -> Pp.str ("?«"^s^"»") + | IOpInaccessibleAll -> Pp.str "*" + | IOpAbstractVars l -> Pp.str ("[:"^String.concat " " (List.map Names.Id.to_string l)^"]") + | IOpFastNondep -> Pp.str ">" + + | IOpInj l -> Pp.(str "[=" ++ ppl l ++ str "]") + + | IOpDispatchBlock b -> Pp.(str"(" ++ Ssrprinters.pr_block b ++ str")") + | IOpDispatchBranches l -> Pp.(str "(" ++ ppl l ++ str ")") + + | IOpCaseBlock b -> Pp.(str"[" ++ Ssrprinters.pr_block b ++ str"]") + | IOpCaseBranches l -> Pp.(str "[" ++ ppl l ++ str "]") + + | IOpRewrite (occ,dir) -> Pp.(Ssrprinters.(pr_occ occ ++ pr_dir dir)) + | IOpView (None,vs) -> Pp.(prlist_with_sep mt (fun c -> str "/" ++ Ssrprinters.pr_ast_closure_term c) vs) + | IOpView (Some cl,vs) -> Pp.(Ssrprinters.pr_clear Pp.spc cl ++ prlist_with_sep mt (fun c -> str "/" ++ Ssrprinters.pr_ast_closure_term c) vs) + + | IOpClear (clmust,clmay) -> + Pp.(Ssrprinters.pr_clear spc clmust ++ + match clmay with + | Some cl -> str "(try " ++ Ssrprinters.pr_clear spc [cl] ++ str")" + | None -> mt ()) + | IOpSimpl s -> Ssrprinters.pr_simpl s + + | IOpEqGen _ -> Pp.str "E:" + | IOpNoop -> Pp.str"-" +and ppl x = Pp.(prlist_with_sep (fun () -> str"|") (prlist_with_sep spc pr_ipatop)) x + + module IpatMachine : sig (* the => tactical. ?eqtac is a tactic to be eventually run * after the first [..] block. first_case_is_dispatch is the * ssr exception to elim: and case: *) val main : ?eqtac:unit tactic -> first_case_is_dispatch:bool -> - ssripats -> unit tactic + ssriops -> unit tactic + val tclCompileIPats : ssripats -> ssriops val tclSEED_SUBGOALS : Names.Name.t list array -> unit tactic -> unit tactic @@ -53,7 +117,7 @@ module State : sig val isNSEED_CONSUME : (Names.Name.t list option -> unit tactic) -> unit tactic (* Some data may expire *) - val isTICK : ssripat -> unit tactic + val isTICK : ssriop -> unit tactic val isPRINT : Proofview.Goal.t -> Pp.t @@ -149,7 +213,7 @@ let isNSEED_CONSUME k = k x) let isTICK = function - | IPatSimpl _ | IPatClear _ -> tclUNIT () + | IOpSimpl _ | IOpClear _ -> tclUNIT () | _ -> tclGET (fun s -> tclSET { s with name_seed = None }) end (* }}} *************************************************************** *) @@ -238,6 +302,13 @@ let tacCHECK_HYPS_EXIST hyps = Goal.enter begin fun gl -> tclUNIT () end +let tacFILTER_HYP_EXIST hyps k = Goal.enter begin fun gl -> + let ctx = Goal.hyps gl in + k (Option.bind hyps (fun h -> + if Ssrcommon.test_hyp_exists ctx h && + Ssrcommon.(not_section_id (hyp_id h)) then Some h else None)) +end + (** [=> []] *****************************************************************) (* calls t1 then t2 on each subgoal passing to t2 the index of the current @@ -286,13 +357,13 @@ let tac_intro_seed interp_ipats fix = Goal.enter begin fun gl -> | Prefix id -> Id.to_string id ^ "?" | SuffixNum n -> "?" ^ string_of_int n | SuffixId id -> "?" ^ Id.to_string id in - IPatAnon (One (Some s)) + IOpInaccessible (Some s) | Name id -> let s = match fix with | Prefix fix -> Id.to_string fix ^ Id.to_string id | SuffixNum n -> Id.to_string id ^ string_of_int n | SuffixId fix -> Id.to_string id ^ Id.to_string fix in - IPatId (None, Id.of_string s)) seeds in + IOpId (Id.of_string s)) seeds in interp_ipats ipats end end @@ -342,7 +413,7 @@ let tclMK_ABSTRACT_VARS ids = (* Debugging *) let tclLOG p t = tclUNIT () >>= begin fun () -> - Ssrprinters.ppdebug (lazy Pp.(str "exec: " ++ Ssrprinters.pr_ipat p)); + Ssrprinters.ppdebug (lazy Pp.(str "exec: " ++ pr_ipatop p)); tclUNIT () end <*> Goal.enter begin fun g -> @@ -362,59 +433,74 @@ let tclLOG p t = let notTAC = tclUNIT false +let duplicate_clear = + CWarnings.create ~name:"duplicate-clear" ~category:"ssr" + (fun id -> Pp.(str "Duplicate clear of " ++ Id.print id)) + (* returns true if it was a tactic (eg /ltac:tactic) *) let rec ipat_tac1 ipat : bool tactic = match ipat with - | IPatView (clear_if_id,l) -> + | IOpView (glued_clear,l) -> + let clear_if_id, extra_clear = + match glued_clear with + | None -> false, [] + | Some x -> true, List.map Ssrcommon.hyp_id x in Ssrview.tclIPAT_VIEWS ~views:l ~clear_if_id - ~conclusion:(fun ~to_clear:clr -> intro_clear clr) + ~conclusion:(fun ~to_clear:clr -> + let inter = CList.intersect Id.equal clr extra_clear in + List.iter duplicate_clear inter; + let cl = CList.union Id.equal clr extra_clear in + intro_clear cl) - | IPatDispatch(true, Regular [[]]) -> - notTAC - | IPatDispatch(_, Regular ipatss) -> + | IOpDispatchBranches ipatss -> tclDISPATCH (List.map ipat_tac ipatss) <*> notTAC - | IPatDispatch(_,Block id_block) -> + | IOpDispatchBlock id_block -> tac_intro_seed ipat_tac id_block <*> notTAC - - | IPatId (None, id) -> Ssrcommon.tclINTRO_ID id <*> notTAC - | IPatId (Some Dependent, id) -> - intro_anon_deps <*> Ssrcommon.tclINTRO_ID id <*> notTAC - - | IPatCase (Block id_block) -> + | IOpCaseBlock id_block -> Ssrcommon.tclWITHTOP tac_case <*> tac_intro_seed ipat_tac id_block <*> notTAC - | IPatCase (Regular ipatss) -> + | IOpCaseBranches ipatss -> tclIORPAT (Ssrcommon.tclWITHTOP tac_case) ipatss <*> notTAC - | IPatInj ipatss -> + + | IOpId id -> Ssrcommon.tclINTRO_ID id <*> notTAC + | IOpFastNondep -> intro_anon_deps <*> notTAC + | IOpDrop -> intro_drop <*> notTAC + | IOpInaccessible seed -> Ssrcommon.tclINTRO_ANON ?seed () <*> notTAC + | IOpInaccessibleAll -> intro_anon_all <*> notTAC + | IOpTemporay -> intro_anon_temp <*> notTAC + + | IOpSimpl Nop -> assert false + + | IOpInj ipatss -> tclIORPAT (Ssrcommon.tclWITHTOP (fun t -> V82.tactic ~nf_evars:false (Ssrelim.perform_injection t))) ipatss <*> notTAC - | IPatAnon Drop -> intro_drop <*> notTAC - | IPatAnon (One seed) -> Ssrcommon.tclINTRO_ANON ?seed () <*> notTAC - | IPatAnon All -> intro_anon_all <*> notTAC - | IPatAnon Temporary -> intro_anon_temp <*> notTAC - - | IPatNoop -> notTAC - | IPatSimpl Nop -> notTAC - - | IPatClear ids -> - tacCHECK_HYPS_EXIST ids <*> - intro_clear (List.map Ssrcommon.hyp_id ids) <*> + | IOpClear (must,may) -> + tacCHECK_HYPS_EXIST must <*> + tacFILTER_HYP_EXIST may (fun may -> + let must = List.map Ssrcommon.hyp_id must in + let cl = Option.fold_left (fun cls (SsrHyp(_,id)) -> + if CList.mem_f Id.equal id cls then begin + duplicate_clear id; + cls + end else id :: cls) must may in + intro_clear cl) <*> notTAC - | IPatSimpl x -> + | IOpSimpl x -> V82.tactic ~nf_evars:false (Ssrequality.simpltac x) <*> notTAC - | IPatRewrite (occ,dir) -> + | IOpRewrite (occ,dir) -> Ssrcommon.tclWITHTOP (fun x -> V82.tactic ~nf_evars:false (Ssrequality.ipat_rewrite occ dir x)) <*> notTAC - | IPatAbstractVars ids -> tclMK_ABSTRACT_VARS ids <*> notTAC + | IOpAbstractVars ids -> tclMK_ABSTRACT_VARS ids <*> notTAC - | IPatEqGen t -> t <*> notTAC + | IOpEqGen t -> t <*> notTAC + | IOpNoop -> notTAC and ipat_tac pl : unit tactic = match pl with @@ -434,51 +520,88 @@ and tclIORPAT tac = function | p -> Tacticals.New.tclTHENS tac (List.map ipat_tac p) and ssr_exception is_on = function - | Some (IPatCase l) when is_on -> Some (IPatDispatch(true, l)) + | Some (IOpCaseBranches [[]]) when is_on -> Some IOpNoop + | Some (IOpCaseBranches l) when is_on -> + Some (IOpDispatchBranches l) + | Some (IOpCaseBlock s) when is_on -> + Some (IOpDispatchBlock s) | x -> x and option_to_list = function None -> [] | Some x -> [x] and split_at_first_case ipats = let rec loop acc = function - | (IPatSimpl _ | IPatClear _) as x :: rest -> loop (x :: acc) rest - | (IPatCase _ | IPatDispatch _) as x :: xs -> CList.rev acc, Some x, xs + | (IOpSimpl _ | IOpClear _) as x :: rest -> loop (x :: acc) rest + | (IOpCaseBlock _ | IOpCaseBranches _ + | IOpDispatchBlock _ | IOpDispatchBranches _) as x :: xs -> + CList.rev acc, Some x, xs | pats -> CList.rev acc, None, pats in loop [] ipats ;; (* Simple pass doing {x}/v -> /v{x} *) -let elaborate_ipats l = +let tclCompileIPats l = let rec elab = function + + | (IPatClear cl) :: (IPatView v) :: rest -> + (IOpView(Some cl,v)) :: elab rest + | (IPatClear cl) :: (IPatId id) :: rest -> + (IOpClear (cl,Some (SsrHyp(None,id)))) :: IOpId id :: elab rest + + (* boring code *) | [] -> [] - | (IPatClear _ as p1) :: (IPatView _ as p2) :: rest -> p2 :: p1 :: elab rest - | IPatDispatch(s, Regular p) :: rest -> IPatDispatch (s, Regular (List.map elab p)) :: elab rest - | IPatCase (Regular p) :: rest -> IPatCase (Regular (List.map elab p)) :: elab rest - | IPatInj p :: rest -> IPatInj (List.map elab p) :: elab rest - | (IPatEqGen _ | IPatId _ | IPatSimpl _ | IPatClear _ | - IPatAnon _ | IPatView _ | IPatNoop | IPatRewrite _ | - IPatAbstractVars _ | IPatDispatch(_, Block _) | IPatCase(Block _)) as x :: rest -> x :: elab rest - in - elab l -let main ?eqtac ~first_case_is_dispatch ipats = - let ipats = elaborate_ipats ipats in - let ip_before, case, ip_after = split_at_first_case ipats in + | IPatId id :: rest -> IOpId id :: elab rest + | IPatAnon (One hint) ::rest -> IOpInaccessible hint :: elab rest + | IPatAnon Drop :: rest -> IOpDrop :: elab rest + | IPatAnon All :: rest -> IOpInaccessibleAll :: elab rest + | IPatAnon Temporary :: rest -> IOpTemporay :: elab rest + | IPatAbstractVars vs :: rest -> IOpAbstractVars vs :: elab rest + | IPatFastNondep :: rest -> IOpFastNondep :: elab rest + + | IPatInj pats :: rest -> IOpInj (List.map elab pats) :: elab rest + | IPatRewrite(occ,dir) :: rest -> IOpRewrite(occ,dir) :: elab rest + | IPatView vs :: rest -> IOpView (None,vs) :: elab rest + | IPatSimpl s :: rest -> IOpSimpl s :: elab rest + | IPatClear cl :: rest -> IOpClear (cl,None) :: elab rest + + | IPatCase (Block seed) :: rest -> IOpCaseBlock seed :: elab rest + | IPatCase (Regular bs) :: rest -> IOpCaseBranches (List.map elab bs) :: elab rest + | IPatDispatch (Block seed) :: rest -> IOpDispatchBlock seed :: elab rest + | IPatDispatch (Regular bs) :: rest -> IOpDispatchBranches (List.map elab bs) :: elab rest + | IPatNoop :: rest -> IOpNoop :: elab rest + + in + elab l +;; +let tclCompileIPats l = + Ssrprinters.ppdebug (lazy Pp.(str "tclCompileIPats input: " ++ + prlist_with_sep spc Ssrprinters.pr_ipat l)); + let ops = tclCompileIPats l in + Ssrprinters.ppdebug (lazy Pp.(str "tclCompileIPats output: " ++ + prlist_with_sep spc pr_ipatop ops)); + ops + +let main ?eqtac ~first_case_is_dispatch iops = + let ip_before, case, ip_after = split_at_first_case iops in let case = ssr_exception first_case_is_dispatch case in let case = option_to_list case in - let eqtac = option_to_list (Option.map (fun x -> IPatEqGen x) eqtac) in - Ssrcommon.tcl0G ~default:() (ipat_tac (ip_before @ case @ eqtac @ ip_after) <*> intro_end) + let eqtac = option_to_list (Option.map (fun x -> IOpEqGen x) eqtac) in + let ipats = ip_before @ case @ eqtac @ ip_after in + Ssrcommon.tcl0G ~default:() (ipat_tac ipats <*> intro_end) end (* }}} *) let tclIPAT_EQ eqtac ip = Ssrprinters.ppdebug (lazy Pp.(str "ipat@run: " ++ Ssrprinters.pr_ipats ip)); - IpatMachine.main ~eqtac ~first_case_is_dispatch:true ip + IpatMachine.(main ~eqtac ~first_case_is_dispatch:true (tclCompileIPats ip)) let tclIPATssr ip = Ssrprinters.ppdebug (lazy Pp.(str "ipat@run: " ++ Ssrprinters.pr_ipats ip)); - IpatMachine.main ~first_case_is_dispatch:true ip + IpatMachine.(main ~first_case_is_dispatch:true (tclCompileIPats ip)) + +let tclCompileIPats = IpatMachine.tclCompileIPats (* Common code to handle generalization lists along with the defective case *) let with_defective maintac deps clr = Goal.enter begin fun g -> @@ -512,8 +635,7 @@ let mkCoqRefl t c env sigma = let elim_intro_tac ipats ?seed what eqid ssrelim is_rec clr = let intro_eq = match eqid with - | Some (IPatId (Some _, _)) -> assert false (* parser *) - | Some (IPatId (None,ipat)) when not is_rec -> + | Some (IPatId ipat) when not is_rec -> let rec intro_eq () = Goal.enter begin fun g -> let sigma, env, concl = Goal.(sigma g, env g, concl g) in match EConstr.kind_of_type sigma concl with @@ -527,7 +649,7 @@ let elim_intro_tac ipats ?seed what eqid ssrelim is_rec clr = |_ -> Ssrcommon.errorstrm (Pp.str "Too many names in intro pattern") end in intro_eq () - | Some (IPatId (None,ipat)) -> + | Some (IPatId ipat) -> let intro_lhs = Goal.enter begin fun g -> let sigma = Goal.sigma g in let elim_name = match clr, what with @@ -723,12 +845,12 @@ let eqmovetac _ gen = ;; let rec eqmoveipats eqpat = function - | (IPatSimpl _ | IPatClear _ as ipat) :: ipats -> + | (IOpSimpl _ | IOpClear _ as ipat) :: ipats -> ipat :: eqmoveipats eqpat ipats - | (IPatAnon All :: _ | []) as ipats -> - IPatAnon (One None) :: eqpat :: ipats + | (IOpInaccessibleAll :: _ | []) as ipats -> + IOpInaccessible None :: eqpat @ ipats | ipat :: ipats -> - ipat :: eqpat :: ipats + ipat :: eqpat @ ipats let ssrsmovetac = Goal.enter begin fun g -> let sigma, concl = Goal.(sigma g, concl g) in @@ -738,7 +860,6 @@ let ssrsmovetac = Goal.enter begin fun g -> end let tclIPAT ip = - Ssrprinters.ppdebug (lazy Pp.(str "ipat@run: " ++ Ssrprinters.pr_ipats ip)); IpatMachine.main ~first_case_is_dispatch:false ip let ssrmovetac = function @@ -750,17 +871,17 @@ let ssrmovetac = function gentac <*> tclLAST_GEN ~to_ind:false lastgen (tacVIEW_THEN_GRAB view ~conclusion) <*> - tclIPAT (IPatClear clr :: ipats) + tclIPAT (IOpClear (clr,None) :: IpatMachine.tclCompileIPats ipats) | _::_ as view, (_, ({ gens = []; clr }, ipats)) -> - tclIPAT (IPatView (false,view) :: IPatClear clr :: ipats) + tclIPAT (IOpView (None,view) :: IOpClear (clr,None) :: IpatMachine.tclCompileIPats ipats) | _, (Some pat, (dgens, ipats)) -> let dgentac = with_dgens dgens eqmovetac in - dgentac <*> tclIPAT (eqmoveipats pat ipats) + dgentac <*> tclIPAT (eqmoveipats (IpatMachine.tclCompileIPats [pat]) (IpatMachine.tclCompileIPats ipats)) | _, (_, ({ gens = (_ :: _ as gens); dgens = []; clr}, ipats)) -> let gentac = V82.tactic ~nf_evars:false (Ssrcommon.genstac (gens, clr)) in - gentac <*> tclIPAT ipats + gentac <*> tclIPAT (IpatMachine.tclCompileIPats ipats) | _, (_, ({ clr }, ipats)) -> - Tacticals.New.tclTHENLIST [ssrsmovetac; Tactics.clear (List.map Ssrcommon.hyp_id clr); tclIPAT ipats] + Tacticals.New.tclTHENLIST [ssrsmovetac; Tactics.clear (List.map Ssrcommon.hyp_id clr); tclIPAT (IpatMachine.tclCompileIPats ipats)] (** [abstract: absvar gens] **************************************************) let rec is_Evar_or_CastedMeta sigma x = @@ -860,7 +981,7 @@ let ssrabstract dgens = let ipats = List.map (fun (_,cp) -> match id_of_pattern (interp_cpattern gl0 cp None) with | None -> IPatAnon (One None) - | Some id -> IPatId (None,id)) + | Some id -> IPatId id) (List.tl gens) in conclusion ipats end in diff --git a/plugins/ssr/ssripats.mli b/plugins/ssr/ssripats.mli index 89cba4be71..893061b154 100644 --- a/plugins/ssr/ssripats.mli +++ b/plugins/ssr/ssripats.mli @@ -19,8 +19,44 @@ open Ssrast +(* Atomic operations for the IPat machine. Use this if you are "patching" an + * ipat written by the user, since patching it at he AST level and then + * compiling it may have tricky effects, eg adding a clear in front of a view + * also has the effect of disposing the view (the compilation phase takes care + * of this, by using the compiled ipats you can be more precise *) +type ssriop = + | IOpId of Names.Id.t + | IOpDrop + | IOpTemporay + | IOpInaccessible of string option + | IOpInaccessibleAll + | IOpAbstractVars of Names.Id.t list + | IOpFastNondep + + | IOpInj of ssriops list + + | IOpDispatchBlock of id_block + | IOpDispatchBranches of ssriops list + + | IOpCaseBlock of id_block + | IOpCaseBranches of ssriops list + + | IOpRewrite of ssrocc * ssrdir + | IOpView of ssrclear option * ssrview (* extra clears to be performed *) + + | IOpClear of ssrclear * ssrhyp option + | IOpSimpl of ssrsimpl + + | IOpEqGen of unit Proofview.tactic (* generation of eqn *) + + | IOpNoop + +and ssriops = ssriop list + +val tclCompileIPats : ssripats -> ssriops + (* The => tactical *) -val tclIPAT : ssripats -> unit Proofview.tactic +val tclIPAT : ssriops -> unit Proofview.tactic (* As above but with the SSR exception: first case is dispatch *) val tclIPATssr : ssripats -> unit Proofview.tactic diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index 6938bbc9f6..3fb21e5ef6 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -605,7 +605,7 @@ let remove_loc x = x.CAst.v let ipat_of_intro_pattern p = Tactypes.( let rec ipat_of_intro_pattern = function - | IntroNaming (IntroIdentifier id) -> IPatId (None,id) + | IntroNaming (IntroIdentifier id) -> IPatId id | IntroAction IntroWildcard -> IPatAnon Drop | IntroAction (IntroOrAndPattern (IntroOrPattern iorpat)) -> IPatCase (Regular( @@ -629,17 +629,16 @@ let ipat_of_intro_pattern p = Tactypes.( ) let rec map_ipat map_id map_ssrhyp map_ast_closure_term = function - | (IPatSimpl _ | IPatAnon _ | IPatRewrite _ | IPatNoop) as x -> x - | IPatId (m,id) -> IPatId (m,map_id id) + | (IPatSimpl _ | IPatAnon _ | IPatRewrite _ | IPatNoop | IPatFastNondep) as x -> x + | IPatId id -> IPatId (map_id id) | IPatAbstractVars l -> IPatAbstractVars (List.map map_id l) | IPatClear clr -> IPatClear (List.map map_ssrhyp clr) | IPatCase (Regular iorpat) -> IPatCase (Regular (List.map (List.map (map_ipat map_id map_ssrhyp map_ast_closure_term)) iorpat)) | IPatCase (Block(hat)) -> IPatCase (Block(map_block map_id hat)) - | IPatDispatch (s, Regular iorpat) -> IPatDispatch (s, Regular (List.map (List.map (map_ipat map_id map_ssrhyp map_ast_closure_term)) iorpat)) - | IPatDispatch (s, Block (hat)) -> IPatDispatch (s, Block(map_block map_id hat)) + | IPatDispatch (Regular iorpat) -> IPatDispatch (Regular (List.map (List.map (map_ipat map_id map_ssrhyp map_ast_closure_term)) iorpat)) + | IPatDispatch (Block (hat)) -> IPatDispatch (Block(map_block map_id hat)) | IPatInj iorpat -> IPatInj (List.map (List.map (map_ipat map_id map_ssrhyp map_ast_closure_term)) iorpat) - | IPatView (clr,v) -> IPatView (clr,List.map map_ast_closure_term v) - | IPatEqGen _ -> assert false (*internal usage only *) + | IPatView v -> IPatView (List.map map_ast_closure_term v) and map_block map_id = function | Prefix id -> Prefix (map_id id) | SuffixId id -> SuffixId (map_id id) @@ -707,7 +706,7 @@ let interp_ipat ist gl = end | x -> x in let rec interp = function - | IPatId(_, id) when ltacvar id -> + | IPatId id when ltacvar id -> ipat_of_intro_pattern (interp_introid ist gl id) | IPatId _ as x -> x | IPatClear clr -> @@ -715,22 +714,22 @@ let interp_ipat ist gl = if not (ltacvar id) then hyp :: hyps else add_intro_pattern_hyps CAst.(make ?loc (interp_introid ist gl id)) hyps in let clr' = List.fold_right add_hyps clr [] in - check_hyps_uniq [] clr'; IPatClear clr' + check_hyps_uniq [] clr'; + IPatClear clr' | IPatCase(Regular iorpat) -> IPatCase(Regular(List.map (List.map interp) iorpat)) | IPatCase(Block(hat)) -> IPatCase(Block(interp_block hat)) - | IPatDispatch(s,Regular iorpat) -> - IPatDispatch(s,Regular (List.map (List.map interp) iorpat)) - | IPatDispatch(s,Block(hat)) -> IPatDispatch(s,Block(interp_block hat)) + | IPatDispatch(Regular iorpat) -> + IPatDispatch(Regular (List.map (List.map interp) iorpat)) + | IPatDispatch(Block(hat)) -> IPatDispatch(Block(interp_block hat)) | IPatInj iorpat -> IPatInj (List.map (List.map interp) iorpat) | IPatAbstractVars l -> IPatAbstractVars (List.map get_intro_id (List.map (interp_introid ist gl) l)) - | IPatView (clr,l) -> IPatView (clr,List.map (fun x -> snd(interp_ast_closure_term ist + | IPatView l -> IPatView (List.map (fun x -> snd(interp_ast_closure_term ist gl x)) l) - | (IPatSimpl _ | IPatAnon _ | IPatRewrite _ | IPatNoop) as x -> x - | IPatEqGen _ -> assert false (*internal usage only *) + | (IPatSimpl _ | IPatAnon _ | IPatRewrite _ | IPatNoop | IPatFastNondep) as x -> x in interp @@ -751,8 +750,8 @@ ARGUMENT EXTEND ssripat TYPED AS ssripatrep list PRINTED BY { pr_ssripats } GLOBALIZED BY { intern_ipats } | [ "_" ] -> { [IPatAnon Drop] } | [ "*" ] -> { [IPatAnon All] } - | [ ">" ident(id) ] -> { [IPatId(Some Dependent,id)] } - | [ ident(id) ] -> { [IPatId (None,id)] } + | [ ">" ] -> { [IPatFastNondep] } + | [ ident(id) ] -> { [IPatId id] } | [ "?" ] -> { [IPatAnon (One None)] } | [ "+" ] -> { [IPatAnon Temporary] } | [ "++" ] -> { [IPatAnon Temporary; IPatAnon Temporary] } @@ -765,10 +764,6 @@ ARGUMENT EXTEND ssripat TYPED AS ssripatrep list PRINTED BY { pr_ssripats } | Some [], _ -> CErrors.user_err ~loc (str"occ_switch expected") | None, occ -> [IPatRewrite (occ, R2L)] | Some clr, _ -> [IPatClear clr; IPatRewrite (allocc, R2L)] } - | [ ssrdocc(occ) ssrfwdview(v) ] -> { match occ with - | Some [], _ -> [IPatView (true,v)] - | Some cl, _ -> check_hyps_uniq [] cl; [IPatClear cl;IPatView (false,v)] - | _ -> CErrors.user_err ~loc (str"Only identifiers are allowed here") } | [ ssrdocc(occ) ] -> { match occ with | Some cl, _ -> check_hyps_uniq [] cl; [IPatClear cl] | _ -> CErrors.user_err ~loc (str"Only identifiers are allowed here") } @@ -786,7 +781,7 @@ ARGUMENT EXTEND ssripat TYPED AS ssripatrep list PRINTED BY { pr_ssripats } | [ "-/" integer(n) "/=" ] -> { [IPatNoop;IPatSimpl(SimplCut (n,~-1))] } | [ "-/" integer(n) "/" integer (m) "=" ] -> { [IPatNoop;IPatSimpl(SimplCut(n,m))] } - | [ ssrfwdview(v) ] -> { [IPatView (false,v)] } + | [ ssrfwdview(v) ] -> { [IPatView v] } | [ "[" ":" ident_list(idl) "]" ] -> { [IPatAbstractVars idl] } | [ "[:" ident_list(idl) "]" ] -> { [IPatAbstractVars idl] } END @@ -875,11 +870,12 @@ ARGUMENT EXTEND ssripats_ne TYPED AS ssripat PRINTED BY { pr_ssripats } let check_ssrhpats loc w_binders ipats = let err_loc s = CErrors.user_err ~loc ~hdr:"ssreflect" s in let clr, ipats = + let opt_app = function None -> fun l -> Some l + | Some l1 -> fun l2 -> Some (l1 @ l2) in let rec aux clr = function - | IPatClear cl :: tl -> aux (clr @ cl) tl -(* | IPatSimpl (cl, sim) :: tl -> clr @ cl, IPatSimpl ([], sim) :: tl *) + | IPatClear cl :: tl -> aux (opt_app clr cl) tl | tl -> clr, tl - in aux [] ipats in + in aux None ipats in let simpl, ipats = match List.rev ipats with | IPatSimpl _ as s :: tl -> [s], List.rev tl @@ -903,27 +899,29 @@ let check_ssrhpats loc w_binders ipats = in loop [] ipats in ((clr, ipat), binders), simpl +let pr_clear_opt sep = function None -> mt () | Some x -> pr_clear sep x + let pr_hpats (((clr, ipat), binders), simpl) = - pr_clear mt clr ++ pr_ipats ipat ++ pr_ipats binders ++ pr_ipats simpl + pr_clear_opt mt clr ++ pr_ipats ipat ++ pr_ipats binders ++ pr_ipats simpl let pr_ssrhpats _ _ _ = pr_hpats let pr_ssrhpats_wtransp _ _ _ (_, x) = pr_hpats x } -ARGUMENT EXTEND ssrhpats TYPED AS (((ssrclear * ssripat) * ssripat) * ssripat) +ARGUMENT EXTEND ssrhpats TYPED AS (((ssrclear option * ssripat) * ssripat) * ssripat) PRINTED BY { pr_ssrhpats } | [ ssripats(i) ] -> { check_ssrhpats loc true i } END ARGUMENT EXTEND ssrhpats_wtransp - TYPED AS (bool * (((ssrclear * ssripats) * ssripats) * ssripats)) + TYPED AS (bool * (((ssrclear option * ssripats) * ssripats) * ssripats)) PRINTED BY { pr_ssrhpats_wtransp } | [ ssripats(i) ] -> { false,check_ssrhpats loc true i } | [ ssripats(i) "@" ssripats(j) ] -> { true,check_ssrhpats loc true (i @ j) } END ARGUMENT EXTEND ssrhpats_nobs -TYPED AS (((ssrclear * ssripats) * ssripats) * ssripats) PRINTED BY { pr_ssrhpats } +TYPED AS (((ssrclear option * ssripats) * ssripats) * ssripats) PRINTED BY { pr_ssrhpats } | [ ssripats(i) ] -> { check_ssrhpats loc false i } END @@ -1492,7 +1490,7 @@ END { let intro_id_to_binder = List.map (function - | IPatId (None,id) -> + | IPatId id -> let { CAst.loc=xloc } as x = bvar_lname (mkCVar id) in (FwdPose, [BFvar]), CAst.make @@ CLambdaN ([CLocalAssum([x], Default Explicit, mkCHole xloc)], @@ -1502,8 +1500,8 @@ let intro_id_to_binder = List.map (function let binder_to_intro_id = CAst.(List.map (function | (FwdPose, [BFvar]), { v = CLambdaN ([CLocalAssum(ids,_,_)],_) } | (FwdPose, [BFdecl _]), { v = CLambdaN ([CLocalAssum(ids,_,_)],_) } -> - List.map (function {v=Name id} -> IPatId (None,id) | _ -> IPatAnon (One None)) ids - | (FwdPose, [BFdef]), { v = CLetIn ({v=Name id},_,_,_) } -> [IPatId (None,id)] + List.map (function {v=Name id} -> IPatId id | _ -> IPatAnon (One None)) ids + | (FwdPose, [BFdef]), { v = CLetIn ({v=Name id},_,_,_) } -> [IPatId id] | (FwdPose, [BFdef]), { v = CLetIn ({v=Anonymous},_,_,_) } -> [IPatAnon (One None)] | _ -> anomaly "ssrbinder is not a binder")) @@ -1994,7 +1992,7 @@ let test_ssreqid = Pcoq.Entry.of_parser "test_ssreqid" accept_ssreqid GRAMMAR EXTEND Gram GLOBAL: ssreqid; ssreqpat: [ - [ id = Prim.ident -> { IPatId (None,id) } + [ id = Prim.ident -> { IPatId id } | "_" -> { IPatAnon Drop } | "?" -> { IPatAnon (One None) } | "+" -> { IPatAnon Temporary } @@ -2051,7 +2049,7 @@ END (* We just add a numeric version that clears the n top assumptions. *) TACTIC EXTEND ssrclear - | [ "clear" natural(n) ] -> { tclIPAT (List.init n (fun _ -> IPatAnon Drop)) } + | [ "clear" natural(n) ] -> { tclIPAT (List.init n (fun _ -> IOpDrop)) } END (** The "move" tactic *) @@ -2090,10 +2088,10 @@ let movearg_of_parsed_movearg (v,(eq,(dg,ip))) = TACTIC EXTEND ssrmove | [ "move" ssrmovearg(arg) ssrrpat(pat) ] -> - { ssrmovetac (movearg_of_parsed_movearg arg) <*> tclIPAT [pat] } + { ssrmovetac (movearg_of_parsed_movearg arg) <*> tclIPAT (tclCompileIPats [pat]) } | [ "move" ssrmovearg(arg) ssrclauses(clauses) ] -> { tclCLAUSES (ssrmovetac (movearg_of_parsed_movearg arg)) clauses } -| [ "move" ssrrpat(pat) ] -> { tclIPAT [pat] } +| [ "move" ssrrpat(pat) ] -> { tclIPAT (tclCompileIPats [pat]) } | [ "move" ] -> { ssrsmovetac } END @@ -2632,7 +2630,11 @@ END { -let augment_preclr clr1 (((clr0, x),y),z) = (((clr1 @ clr0, x),y),z) +let augment_preclr clr1 (((clr0, x),y),z) = + let cl = match clr0 with + | None -> if clr1 = [] then None else Some clr1 + | Some clr0 -> Some (clr1 @ clr0) in + (((cl, x),y),z) } diff --git a/plugins/ssr/ssrprinters.ml b/plugins/ssr/ssrprinters.ml index 6ccefa1cab..38f5b7d107 100644 --- a/plugins/ssr/ssrprinters.ml +++ b/plugins/ssr/ssrprinters.ml @@ -74,7 +74,7 @@ let pr_occ = function | None -> str "{}" let pr_clear_ne clr = str "{" ++ pr_hyps clr ++ str "}" -let pr_clear sep clr = if clr = [] then mt () else sep () ++ pr_clear_ne clr +let pr_clear sep clr = sep () ++ pr_clear_ne clr let pr_dir = function L2R -> str "->" | R2L -> str "<-" @@ -97,25 +97,23 @@ let pr_view2 = pr_list mt (fun c -> str "/" ++ pr_ast_closure_term c) let rec pr_ipat p = match p with - | IPatId (None,id) -> Id.print id - | IPatId (Some Dependent,id) -> str">" ++ Id.print id + | IPatId id -> Id.print id | IPatSimpl sim -> pr_simpl sim | IPatClear clr -> pr_clear mt clr | IPatCase (Regular iorpat) -> hov 1 (str "[" ++ pr_iorpat iorpat ++ str "]") | IPatCase (Block m) -> hov 1 (str"[" ++ pr_block m ++ str"]") - | IPatDispatch(_,Regular iorpat) -> hov 1 (str "(" ++ pr_iorpat iorpat ++ str ")") - | IPatDispatch (_,Block m) -> hov 1 (str"(" ++ pr_block m ++ str")") + | IPatDispatch(Regular iorpat) -> hov 1 (str "(" ++ pr_iorpat iorpat ++ str ")") + | IPatDispatch (Block m) -> hov 1 (str"(" ++ pr_block m ++ str")") | IPatInj iorpat -> hov 1 (str "[=" ++ pr_iorpat iorpat ++ str "]") | IPatRewrite (occ, dir) -> pr_occ occ ++ pr_dir dir | IPatAnon All -> str "*" | IPatAnon Drop -> str "_" | IPatAnon (One _) -> str "?" - | IPatView (false,v) -> pr_view2 v - | IPatView (true,v) -> str"{}" ++ pr_view2 v + | IPatView v -> pr_view2 v | IPatAnon Temporary -> str "+" | IPatNoop -> str "-" | IPatAbstractVars l -> str "[:" ++ pr_list spc Id.print l ++ str "]" - | IPatEqGen _ -> str "<tac>" + | IPatFastNondep -> str">" and pr_ipats ipats = pr_list spc pr_ipat ipats and pr_iorpat iorpat = pr_list pr_bar pr_ipats iorpat and pr_block = function (Prefix id) -> str"^" ++ Id.print id diff --git a/plugins/ssr/ssrprinters.mli b/plugins/ssr/ssrprinters.mli index 31c360ad6d..5f20ac2705 100644 --- a/plugins/ssr/ssrprinters.mli +++ b/plugins/ssr/ssrprinters.mli @@ -43,6 +43,7 @@ val pr_view2 : ast_closure_term list -> Pp.t val pr_ipat : ssripat -> Pp.t val pr_ipats : ssripats -> Pp.t val pr_iorpat : ssripatss -> Pp.t +val pr_block : id_block -> Pp.t val pr_hyp : ssrhyp -> Pp.t val pr_hyps : ssrhyps -> Pp.t diff --git a/plugins/ssr/ssrview.ml b/plugins/ssr/ssrview.ml index 4816027296..2794696017 100644 --- a/plugins/ssr/ssrview.ml +++ b/plugins/ssr/ssrview.ml @@ -142,7 +142,7 @@ let intern_constr_expr { Genintern.genv; ltacvars = vars } sigma ce = To allow for t being a notation, like "Notation foo x := ltac:(foo x)", we need to internalize t. *) -let is_tac_in_term ?extra_scope { body; glob_env; interp_env } = +let is_tac_in_term ?extra_scope { annotation; body; glob_env; interp_env } = Goal.(enter_one ~__LOC__ begin fun goal -> let genv = env goal in let sigma = sigma goal in @@ -161,7 +161,7 @@ let is_tac_in_term ?extra_scope { body; glob_env; interp_env } = | Glob_term.GHole (_,_, Some x) when Genarg.has_type x (Genarg.glbwit Tacarg.wit_tactic) -> tclUNIT (`Tac (Genarg.out_gen (Genarg.glbwit Tacarg.wit_tactic) x)) - | _ -> tclUNIT (`Term (interp_env, g)) + | _ -> tclUNIT (`Term (annotation, interp_env, g)) end) (* To inject a constr into a glob_constr we use an Ltac variable *) @@ -207,7 +207,7 @@ let tclKeepOpenConstr (_env, sigma, t) = Unsafe.tclEVARS sigma <*> tclUNIT t let tclADD_CLEAR_IF_ID (env, ist, t) x = Ssrprinters.ppdebug (lazy Pp.(str"tclADD_CLEAR_IF_ID: " ++ Printer.pr_econstr_env env ist t)); - let hd, _ = EConstr.decompose_app ist t in + let hd, args = EConstr.decompose_app ist t in match EConstr.kind ist hd with | Constr.Var id when Ssrcommon.not_section_id id -> tclUNIT (x, [id]) | _ -> tclUNIT (x,[]) @@ -280,8 +280,9 @@ let interp_view ~clear_if_id ist v p = else tclKeepOpenConstr ot >>= tclPAIR [] (* we store in the state (v top), then (v1 (v2 top))... *) -let pile_up_view ~clear_if_id (ist, v) = +let pile_up_view ~clear_if_id (annotation, ist, v) = let ist = Ssrcommon.option_assert_get ist (Pp.str"not a term") in + let clear_if_id = clear_if_id && annotation <> `Parens in State.vsPUSH (fun p -> interp_view ~clear_if_id ist v p) let finalize_view s0 ?(simple_types=true) p = diff --git a/plugins/ssrmatching/ssrmatching.mli b/plugins/ssrmatching/ssrmatching.mli index f0bb6f58a6..ff2c900130 100644 --- a/plugins/ssrmatching/ssrmatching.mli +++ b/plugins/ssrmatching/ssrmatching.mli @@ -1,5 +1,14 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + (* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) -(* Distributed under the terms of CeCILL-B. *) open Goal open Environ diff --git a/plugins/ssrmatching/ssrmatching.v b/plugins/ssrmatching/ssrmatching.v index 9a53e1dd1a..a39f76db9e 100644 --- a/plugins/ssrmatching/ssrmatching.v +++ b/plugins/ssrmatching/ssrmatching.v @@ -1,5 +1,15 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + (* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) -(* Distributed under the terms of CeCILL-B. *) + Declare ML Module "ssrmatching_plugin". Module SsrMatchingSyntax. diff --git a/plugins/syntax/numeral.ml b/plugins/syntax/numeral.ml index 470deb4a60..ea564ae2ba 100644 --- a/plugins/syntax/numeral.ml +++ b/plugins/syntax/numeral.ml @@ -33,30 +33,41 @@ let get_constructors ind = Array.to_list (Array.mapi (fun j c -> ConstructRef (ind, j + 1)) mc) -let q_z = qualid_of_string "Coq.Numbers.BinNums.Z" -let q_positive = qualid_of_string "Coq.Numbers.BinNums.positive" -let q_int = qualid_of_string "Coq.Init.Decimal.int" -let q_uint = qualid_of_string "Coq.Init.Decimal.uint" -let q_option = qualid_of_string "Coq.Init.Datatypes.option" +let qualid_of_ref n = + n |> Coqlib.lib_ref |> Nametab.shortest_qualid_of_global Id.Set.empty + +let q_option () = qualid_of_ref "core.option.type" let unsafe_locate_ind q = match Nametab.locate q with | IndRef i -> i | _ -> raise Not_found -let locate_ind q = - try unsafe_locate_ind q - with Not_found -> Nametab.error_global_not_found q - let locate_z () = - try - Some { z_ty = unsafe_locate_ind q_z; - pos_ty = unsafe_locate_ind q_positive } - with Not_found -> None + let zn = "num.Z.type" in + let pn = "num.pos.type" in + if Coqlib.has_ref zn && Coqlib.has_ref pn + then + let q_z = qualid_of_ref zn in + let q_pos = qualid_of_ref pn in + Some ({ + z_ty = unsafe_locate_ind q_z; + pos_ty = unsafe_locate_ind q_pos; + }, mkRefC q_z) + else None let locate_int () = - { uint = locate_ind q_uint; - int = locate_ind q_int } + let int = "num.int.type" in + let uint = "num.uint.type" in + if Coqlib.has_ref int && Coqlib.has_ref uint + then + let q_int = qualid_of_ref int in + let q_uint = qualid_of_ref uint in + Some ({ + int = unsafe_locate_ind q_int; + uint = unsafe_locate_ind q_uint; + }, mkRefC q_int, mkRefC q_uint) + else None let has_type f ty = let (sigma, env) = Pfedit.get_current_context () in @@ -64,19 +75,17 @@ let has_type f ty = try let _ = Constrintern.interp_constr env sigma c in true with Pretype_errors.PretypeError _ -> false -let type_error_to f ty loadZ = +let type_error_to f ty = CErrors.user_err (pr_qualid f ++ str " should go from Decimal.int to " ++ pr_qualid ty ++ str " or (option " ++ pr_qualid ty ++ str ")." ++ - fnl () ++ str "Instead of Decimal.int, the types Decimal.uint or Z could be used" ++ - (if loadZ then str " (require BinNums first)." else str ".")) + fnl () ++ str "Instead of Decimal.int, the types Decimal.uint or Z could be used (you may need to require BinNums or Decimal first).") -let type_error_of g ty loadZ = +let type_error_of g ty = CErrors.user_err (pr_qualid g ++ str " should go from " ++ pr_qualid ty ++ str " to Decimal.int or (option Decimal.int)." ++ fnl () ++ - str "Instead of Decimal.int, the types Decimal.uint or Z could be used" ++ - (if loadZ then str " (require BinNums first)." else str ".")) + str "Instead of Decimal.int, the types Decimal.uint or Z could be used (you may need to require BinNums or Decimal first).") let vernac_numeral_notation local ty f g scope opts = let int_ty = locate_int () in @@ -86,43 +95,36 @@ let vernac_numeral_notation local ty f g scope opts = let of_ty = Smartlocate.global_with_alias g in let cty = mkRefC ty in let app x y = mkAppC (x,[y]) in - let cref q = mkRefC q in let arrow x y = mkProdC ([CAst.make Anonymous],Default Decl_kinds.Explicit, x, y) in - let cZ = cref q_z in - let cint = cref q_int in - let cuint = cref q_uint in - let coption = cref q_option in - let opt r = app coption r in + let opt r = app (mkRefC (q_option ())) r in let constructors = get_constructors tyc in (* Check the type of f *) let to_kind = - if has_type f (arrow cint cty) then Int int_ty, Direct - else if has_type f (arrow cint (opt cty)) then Int int_ty, Option - else if has_type f (arrow cuint cty) then UInt int_ty.uint, Direct - else if has_type f (arrow cuint (opt cty)) then UInt int_ty.uint, Option - else - match z_pos_ty with - | Some z_pos_ty -> - if has_type f (arrow cZ cty) then Z z_pos_ty, Direct - else if has_type f (arrow cZ (opt cty)) then Z z_pos_ty, Option - else type_error_to f ty false - | None -> type_error_to f ty true + match int_ty with + | Some (int_ty, cint, _) when has_type f (arrow cint cty) -> Int int_ty, Direct + | Some (int_ty, cint, _) when has_type f (arrow cint (opt cty)) -> Int int_ty, Option + | Some (int_ty, _, cuint) when has_type f (arrow cuint cty) -> UInt int_ty.uint, Direct + | Some (int_ty, _, cuint) when has_type f (arrow cuint (opt cty)) -> UInt int_ty.uint, Option + | _ -> + match z_pos_ty with + | Some (z_pos_ty, cZ) when has_type f (arrow cZ cty) -> Z z_pos_ty, Direct + | Some (z_pos_ty, cZ) when has_type f (arrow cZ (opt cty)) -> Z z_pos_ty, Option + | _ -> type_error_to f ty in (* Check the type of g *) let of_kind = - if has_type g (arrow cty cint) then Int int_ty, Direct - else if has_type g (arrow cty (opt cint)) then Int int_ty, Option - else if has_type g (arrow cty cuint) then UInt int_ty.uint, Direct - else if has_type g (arrow cty (opt cuint)) then UInt int_ty.uint, Option - else - match z_pos_ty with - | Some z_pos_ty -> - if has_type g (arrow cty cZ) then Z z_pos_ty, Direct - else if has_type g (arrow cty (opt cZ)) then Z z_pos_ty, Option - else type_error_of g ty false - | None -> type_error_of g ty true + match int_ty with + | Some (int_ty, cint, _) when has_type g (arrow cty cint) -> Int int_ty, Direct + | Some (int_ty, cint, _) when has_type g (arrow cty (opt cint)) -> Int int_ty, Option + | Some (int_ty, _, cuint) when has_type g (arrow cty cuint) -> UInt int_ty.uint, Direct + | Some (int_ty, _, cuint) when has_type g (arrow cty (opt cuint)) -> UInt int_ty.uint, Option + | _ -> + match z_pos_ty with + | Some (z_pos_ty, cZ) when has_type g (arrow cty cZ) -> Z z_pos_ty, Direct + | Some (z_pos_ty, cZ) when has_type g (arrow cty (opt cZ)) -> Z z_pos_ty, Option + | _ -> type_error_of g ty in let o = { to_kind; to_ty; of_kind; of_ty; ty_name = ty; diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index e6e1530e36..ed28cc7725 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -46,15 +46,10 @@ let () = Goptions.(declare_bool_option { (* Functions to deal with impossible cases *) (*******************************************) let impossible_default_case env = - let type_of_id = - let open Names.GlobRef in - match Coqlib.lib_ref "core.IDProp.type" with - | ConstRef c -> c - | VarRef _ | IndRef _ | ConstructRef _ -> assert false - in + let type_of_id = Coqlib.lib_ref "core.IDProp.type" in let c, ctx = UnivGen.fresh_global_instance env (Coqlib.(lib_ref "core.IDProp.idProp")) in - let (_, u) = Constr.destConst c in - Some (c, Constr.mkConstU (type_of_id, u), ctx) + let (_, u) = Constr.destRef c in + Some (c, Constr.mkRef (type_of_id, u), ctx) let coq_unit_judge = let open Environ in diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 6e3b19ae61..f58cce41cc 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -202,7 +202,14 @@ let cs_pattern_of_constr env t = App (f,vargs) -> begin try Const_cs (global_of_constr f) , None, Array.to_list vargs - with e when CErrors.noncritical e -> raise Not_found + with + | Not_found when isProj f -> + let p, c = destProj f in + let { Environ.uj_type = ty } = Typeops.infer env c in + let _, params = Inductive.find_rectype env ty in + Const_cs (ConstRef (Projection.constant p)), None, + params @ [c] @ Array.to_list vargs + | e when CErrors.noncritical e -> raise Not_found end | Rel n -> Default_cs, Some n, [] | Prod (_,a,b) when Vars.noccurn 1 b -> Prod_cs, None, [a; Vars.lift (-1) b] diff --git a/printing/prettyp.ml b/printing/prettyp.ml index 8f7e4470f9..408bd5f60b 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -267,7 +267,6 @@ let print_name_infos ref = print_ref true ref None; blankline] else [] in - print_polymorphism ref @ print_type_in_type ref @ print_primitive ref @ type_info_for_implicit @ @@ -575,7 +574,7 @@ let print_constant with_values sep sp udecl = in let env = Global.env () and sigma = Evd.from_ctx ctx in let pr_ltype = pr_ltype_env env sigma in - hov 0 (pr_polymorphic (Declareops.constant_is_polymorphic cb) ++ + hov 0 ( match val_0 with | None -> str"*** [ " ++ @@ -838,6 +837,7 @@ let print_about_any ?loc env sigma k udecl = Dumpglob.add_glob ?loc ref; pr_infos_list (print_ref false ref udecl :: blankline :: + print_polymorphism ref @ print_name_infos ref @ (if Pp.ismt rb then [] else [rb]) @ print_opacity ref @ diff --git a/printing/printer.ml b/printing/printer.ml index be0139da06..3f7837fd6e 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -982,14 +982,6 @@ let pr_assumptionset env sigma s = ] in prlist_with_sep fnl (fun x -> x) (Option.List.flatten assums) -let pr_cumulative poly cum = - if poly then - if cum then str "Cumulative " else str "NonCumulative " - else mt () - -let pr_polymorphic b = - if b then str"Polymorphic " else str"Monomorphic " - (* print the proof step, possibly with diffs highlighted, *) let print_and_diff oldp newp = match newp with diff --git a/printing/printer.mli b/printing/printer.mli index fd4682a086..9a06d555e4 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -81,8 +81,6 @@ val pr_sort : evar_map -> Sorts.t -> Pp.t (** Universe constraints *) -val pr_polymorphic : bool -> Pp.t -val pr_cumulative : bool -> bool -> Pp.t val pr_universe_instance : evar_map -> Univ.Instance.t -> Pp.t val pr_universe_instance_constraints : evar_map -> Univ.Instance.t -> Univ.Constraint.t -> Pp.t val pr_universe_ctx : evar_map -> ?variance:Univ.Variance.t array -> diff --git a/printing/printmod.ml b/printing/printmod.ml index a8d7b0c1a8..898f231a8b 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -123,11 +123,7 @@ let print_mutual_inductive env mind mib udecl = (Declareops.inductive_polymorphic_context mib) udecl in let sigma = Evd.from_ctx (UState.of_binders bl) in - hov 0 (Printer.pr_polymorphic (Declareops.inductive_is_polymorphic mib) ++ - Printer.pr_cumulative - (Declareops.inductive_is_polymorphic mib) - (Declareops.inductive_is_cumulative mib) ++ - def keyword ++ spc () ++ + hov 0 (def keyword ++ spc () ++ prlist_with_sep (fun () -> fnl () ++ str" with ") (print_one_inductive env sigma mib) inds ++ match mib.mind_universes with @@ -172,10 +168,6 @@ let print_record env mind mib udecl = in hov 0 ( hov 0 ( - Printer.pr_polymorphic (Declareops.inductive_is_polymorphic mib) ++ - Printer.pr_cumulative - (Declareops.inductive_is_polymorphic mib) - (Declareops.inductive_is_cumulative mib) ++ def keyword ++ spc () ++ Id.print mip.mind_typename ++ brk(1,4) ++ print_params env sigma params ++ str ": " ++ Printer.pr_lconstr_env envpar sigma arity ++ brk(1,2) ++ diff --git a/printing/proof_diffs.ml b/printing/proof_diffs.ml index b280ce909b..c1ea067567 100644 --- a/printing/proof_diffs.ml +++ b/printing/proof_diffs.ml @@ -88,7 +88,8 @@ let tokenize_string s = let st = CLexer.get_lexer_state () in try let istr = Stream.of_string s in - let lex = CLexer.lexer.Gramlib.Plexing.tok_func istr in + let lexer = CLexer.make_lexer ~diff_mode:true in + let lex = lexer.Gramlib.Plexing.tok_func istr in let toks = stream_tok [] (fst lex) in CLexer.set_lexer_state st; toks diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index e2b7df19de..7f1ae6d12b 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -107,11 +107,14 @@ let solve ?with_end_tac gi info_lvl tac pr = Proofview.tclTHEN tac Refine.solve_constraints else tac in - let (p,(status,info)) = Proof.run_tactic (Global.env ()) tac pr in + let env = Global.env () in + let (p,(status,info)) = Proof.run_tactic env tac pr in + let env = Global.env () in + let sigma = Evd.from_env env in let () = match info_lvl with | None -> () - | Some i -> Feedback.msg_info (hov 0 (Proofview.Trace.pr_info ~lvl:i info)) + | Some i -> Feedback.msg_info (hov 0 (Proofview.Trace.pr_info env sigma ~lvl:i info)) in (p,status) with diff --git a/proofs/proof.ml b/proofs/proof.ml index 1aeb24606b..4ce932b93d 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -351,19 +351,13 @@ let dependent_start ~name ~poly goals = type open_error_reason = | UnfinishedProof - | HasShelvedGoals | HasGivenUpGoals - | HasUnresolvedEvar let print_open_error_reason er = let open Pp in match er with | UnfinishedProof -> str "Attempt to save an incomplete proof" - | HasShelvedGoals -> - str "Attempt to save a proof with shelved goals" | HasGivenUpGoals -> strbrk "Attempt to save a proof with given up goals. If this is really what you want to do, use Admitted in place of Qed." - | HasUnresolvedEvar -> - strbrk "Attempt to save a proof with existential variables still non-instantiated" exception OpenProof of Names.Id.t option * open_error_reason @@ -375,19 +369,25 @@ let _ = CErrors.register_handler begin function | _ -> raise CErrors.Unhandled end +let warn_remaining_shelved_goals = + CWarnings.create ~name:"remaining-shelved-goals" ~category:"tactics" + (fun () -> Pp.str"The proof has remaining shelved goals") + +let warn_remaining_unresolved_evars = + CWarnings.create ~name:"remaining-unresolved-evars" ~category:"tactics" + (fun () -> Pp.str"The proof has unresolved variables") + let return ?pid (p : t) = if not (is_done p) then raise (OpenProof(pid, UnfinishedProof)) - else if has_shelved_goals p then - raise (OpenProof(pid, HasShelvedGoals)) else if has_given_up_goals p then raise (OpenProof(pid, HasGivenUpGoals)) - else if has_unresolved_evar p then - (* spiwack: for compatibility with <= 8.3 proof engine *) - raise (OpenProof(pid, HasUnresolvedEvar)) - else + else begin + if has_shelved_goals p then warn_remaining_shelved_goals () + else if has_unresolved_evar p then warn_remaining_unresolved_evars (); let p = unfocus end_of_stack_kind p () in Proofview.return p.proofview + end let compact p = let entry, proofview = Proofview.compact p.entry p.proofview in diff --git a/proofs/proof.mli b/proofs/proof.mli index fd5e905a3b..40e8ff7eef 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -130,13 +130,10 @@ val compact : t -> t (* Returns the proofs (with their type) of the initial goals. Raises [UnfinishedProof] is some goals remain to be considered. Raises [HasShelvedGoals] if some goals are left on the shelf. - Raises [HasGivenUpGoals] if some goals have been given up. - Raises [HasUnresolvedEvar] if some evars have been left undefined. *) + Raises [HasGivenUpGoals] if some goals have been given up. *) type open_error_reason = | UnfinishedProof - | HasShelvedGoals | HasGivenUpGoals - | HasUnresolvedEvar exception OpenProof of Names.Id.t option * open_error_reason diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index f8adc58921..9ee9e7ae2c 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -22,51 +22,6 @@ open Names module NamedDecl = Context.Named.Declaration -(*** Proof Modes ***) - -(* Type of proof modes : - - A function [set] to set it *from standard mode* - - A function [reset] to reset the *standard mode* from it *) -type proof_mode_name = string -type proof_mode = { - name : proof_mode_name ; - set : unit -> unit ; - reset : unit -> unit -} - -let proof_modes = Hashtbl.create 6 -let find_proof_mode n = - try Hashtbl.find proof_modes n - with Not_found -> - CErrors.user_err Pp.(str (Format.sprintf "No proof mode named \"%s\"." n)) - -let register_proof_mode ({name = n} as m) = - Hashtbl.add proof_modes n (CEphemeron.create m) - -(* initial mode: standard mode *) -let standard = { name = "No" ; set = (fun ()->()) ; reset = (fun () -> ()) } -let _ = register_proof_mode standard - -(* Default proof mode, to be set at the beginning of proofs. *) -let default_proof_mode = ref (find_proof_mode "No") - -let get_default_proof_mode_name () = - (CEphemeron.default !default_proof_mode standard).name - -let proof_mode_opt_name = ["Default";"Proof";"Mode"] -let () = - Goptions.(declare_string_option { - optdepr = false; - optname = "default proof mode" ; - optkey = proof_mode_opt_name ; - optread = begin fun () -> - (CEphemeron.default !default_proof_mode standard).name - end; - optwrite = begin fun n -> - default_proof_mode := find_proof_mode n - end - }) - (*** Proof Global Environment ***) (* Extra info on proofs. *) @@ -95,7 +50,6 @@ type pstate = { endline_tactic : Genarg.glob_generic_argument option; section_vars : Constr.named_context option; proof : Proof.t; - mode : proof_mode CEphemeron.key; universe_decl: UState.universe_decl; strength : Decl_kinds.goal_kind; } @@ -109,23 +63,8 @@ let apply_terminator f = f to be resumed when the current proof is closed or aborted. *) let pstates = ref ([] : pstate list) -(* Current proof_mode, for bookkeeping *) -let current_proof_mode = ref !default_proof_mode - -(* combinators for proof modes *) -let update_proof_mode () = - match !pstates with - | { mode = m } :: _ -> - CEphemeron.iter_opt !current_proof_mode (fun x -> x.reset ()); - current_proof_mode := m; - CEphemeron.iter_opt !current_proof_mode (fun x -> x.set ()) - | _ -> - CEphemeron.iter_opt !current_proof_mode (fun x -> x.reset ()); - current_proof_mode := find_proof_mode "No" - (* combinators for the current_proof lists *) -let push a l = l := a::!l; - update_proof_mode () +let push a l = l := a::!l exception NoSuchProof let () = CErrors.register_handler begin function @@ -221,25 +160,8 @@ let discard {CAst.loc;v=id} = let discard_current () = if List.is_empty !pstates then raise NoCurrentProof else pstates := List.tl !pstates - let discard_all () = pstates := [] -(* [set_proof_mode] sets the proof mode to be used after it's called. It is - typically called by the Proof Mode command. *) -let set_proof_mode m id = - pstates := List.map - (fun ps -> if pf_name_eq id ps then { ps with mode = m } else ps) - !pstates; - update_proof_mode () - -let set_proof_mode mn = - set_proof_mode (find_proof_mode mn) (get_current_proof_name ()) - -let activate_proof_mode mode = - CEphemeron.iter_opt (find_proof_mode mode) (fun x -> x.set ()) -let disactivate_current_proof_mode () = - CEphemeron.iter_opt !current_proof_mode (fun x -> x.reset ()) - (** [start_proof sigma id pl str goals terminator] starts a proof of name [id] with goals [goals] (a list of pairs of environment and conclusion); [str] describes what kind of theorem/definition this @@ -254,9 +176,8 @@ let start_proof sigma name ?(pl=UState.default_univ_decl) kind goals terminator proof = Proof.start ~name ~poly:(pi2 kind) sigma goals; endline_tactic = None; section_vars = None; - mode = find_proof_mode "No"; - universe_decl = pl; - strength = kind } in + strength = kind; + universe_decl = pl } in push initial_state pstates let start_dependent_proof name ?(pl=UState.default_univ_decl) kind goals terminator = @@ -265,9 +186,8 @@ let start_dependent_proof name ?(pl=UState.default_univ_decl) kind goals termina proof = Proof.dependent_start ~name ~poly:(pi2 kind) goals; endline_tactic = None; section_vars = None; - mode = find_proof_mode "No"; - universe_decl = pl; - strength = kind } in + strength = kind; + universe_decl = pl } in push initial_state pstates let get_used_variables () = (cur_pstate ()).section_vars @@ -443,8 +363,13 @@ let return_proof ?(allow_partial=false) () = (* ppedrot: FIXME, this is surely wrong. There is no reason to duplicate side-effects... This may explain why one need to uniquize side-effects thereafter... *) + let proof_opt c = + match EConstr.to_constr_opt evd c with + | Some p -> p + | None -> CErrors.user_err Pp.(str "Some unresolved existential variables remain") + in let proofs = - List.map (fun (c, _) -> (EConstr.to_constr evd c, eff)) initial_goals in + List.map (fun (c, _) -> (proof_opt c, eff)) initial_goals in proofs, Evd.evar_universe_context evd let close_future_proof ~opaque ~feedback_id proof = @@ -473,7 +398,7 @@ end let freeze ~marshallable = if marshallable then CErrors.anomaly (Pp.str"full marshalling of proof state not supported.") else !pstates -let unfreeze s = pstates := s; update_proof_mode () +let unfreeze s = pstates := s let proof_of_state = function { proof }::_ -> proof | _ -> raise NoCurrentProof let copy_terminators ~src ~tgt = assert(List.length src = List.length tgt); diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index e762f3b7dc..40920f51a3 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -13,7 +13,6 @@ environment. *) type t - val there_are_pending_proofs : unit -> bool val check_no_pending_proof : unit -> unit @@ -139,47 +138,3 @@ val freeze : marshallable:bool -> t val unfreeze : t -> unit val proof_of_state : t -> Proof.t val copy_terminators : src:t -> tgt:t -> t - - -(**********************************************************) -(* Proof Mode API *) -(* The current Proof Mode API is deprecated and a new one *) -(* will be (hopefully) defined in 8.8 *) -(**********************************************************) - -(** Type of proof modes : - - A name - - A function [set] to set it *from standard mode* - - A function [reset] to reset the *standard mode* from it - -*) -type proof_mode_name = string -type proof_mode = { - name : proof_mode_name ; - set : unit -> unit ; - reset : unit -> unit -} - -(** Registers a new proof mode which can then be adressed by name - in [set_default_proof_mode]. - One mode is already registered - the standard mode - named "No", - It corresponds to Coq default setting are they are set when coqtop starts. *) -val register_proof_mode : proof_mode -> unit -(* Can't make this deprecated due to limitations of camlp5 *) -(* [@@ocaml.deprecated "the current proof mode API is deprecated, use with care, see PR #459 and #566 "] *) - -val proof_mode_opt_name : string list - -val get_default_proof_mode_name : unit -> proof_mode_name -[@@ocaml.deprecated "the current proof mode API is deprecated, use with care, see PR #459 and #566 "] - -(** [set_proof_mode] sets the proof mode to be used after it's called. It is - typically called by the Proof Mode command. *) -val set_proof_mode : proof_mode_name -> unit -[@@ocaml.deprecated "the current proof mode API is deprecated, use with care, see PR #459 and #566 "] - -val activate_proof_mode : proof_mode_name -> unit -[@@ocaml.deprecated "the current proof mode API is deprecated, use with care, see PR #459 and #566 "] - -val disactivate_current_proof_mode : unit -> unit -[@@ocaml.deprecated "the current proof mode API is deprecated, use with care, see PR #459 and #566 "] diff --git a/proofs/refine.ml b/proofs/refine.ml index d812a8cad7..1d796fece5 100644 --- a/proofs/refine.ml +++ b/proofs/refine.ml @@ -107,8 +107,8 @@ let generic_refine ~typecheck f gl = (* Mark goals *) let sigma = Proofview.Unsafe.mark_as_goals sigma comb in let comb = CList.map (fun x -> Proofview.goal_with_state x state) comb in - let trace () = Pp.(hov 2 (str"simple refine"++spc()++ - Termops.Internal.print_constr_env env sigma c)) in + let trace env sigma = Pp.(hov 2 (str"simple refine"++spc()++ + Termops.Internal.print_constr_env env sigma c)) in Proofview.Trace.name_tactic trace (Proofview.tclUNIT v) >>= fun v -> Proofview.Unsafe.tclSETENV (Environ.reset_context env) <*> Proofview.Unsafe.tclEVARS sigma <*> diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index 51166cf238..2f8129bbfd 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -190,7 +190,7 @@ module Make(T : Task) () = struct let () = TQueue.broadcast queue in Worker.kill proc in - let _ = Thread.create kill_if () in + let _ = CThread.create kill_if () in try while true do report_status ~id "Idle"; @@ -250,7 +250,7 @@ module Make(T : Task) () = struct { active = Pool.create queue ~size; queue; - cleaner = if size > 0 then Some (Thread.create cleaner queue) else None; + cleaner = if size > 0 then Some (CThread.create cleaner queue) else None; } let destroy { active; queue } = diff --git a/stm/spawned.ml b/stm/spawned.ml index a5d6ea96f9..bd772d825d 100644 --- a/stm/spawned.ml +++ b/stm/spawned.ml @@ -38,7 +38,7 @@ let controller h pr pw = prerr_endline ("control channel broken: " ^ Printexc.to_string e); exit 1 in loop () in - ignore(Thread.create main ()) + ignore(CThread.create main ()) let main_channel = ref None let control_channel = ref None diff --git a/stm/stm.ml b/stm/stm.ml index 32c6c7d959..0165b3c029 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -126,8 +126,6 @@ type aast = { } let pr_ast { expr; indentation } = Pp.(int indentation ++ str " " ++ Ppvernac.pr_vernac expr) -let default_proof_mode () = Proof_global.get_default_proof_mode_name () [@ocaml.warning "-3"] - (* Commands piercing opaque *) let may_pierce_opaque = function | VernacPrint _ @@ -146,13 +144,13 @@ let update_global_env () = module Vcs_ = Vcs.Make(Stateid.Self) type future_proof = Proof_global.closed_proof_output Future.computation -type proof_mode = string + type depth = int type branch_type = [ `Master - | `Proof of proof_mode * depth + | `Proof of depth | `Edit of - proof_mode * Stateid.t * Stateid.t * Vernacextend.vernac_qed_type * Vcs_.Branch.t ] + Stateid.t * Stateid.t * Vernacextend.vernac_qed_type * Vcs_.Branch.t ] (* TODO 8.7 : split commands and tactics, since this type is too messy now *) type cmd_t = { ctac : bool; (* is a tactic *) @@ -203,10 +201,10 @@ let summary_pstate = Evarutil.meta_counter_summary_tag, Obligations.program_tcc_summary_tag type cached_state = - | Empty - | Error of Exninfo.iexn - | Valid of Vernacstate.t - + | EmptyState + | ParsingState of Vernacstate.Parser.state + | FullState of Vernacstate.t + | ErrorState of Vernacstate.Parser.state option * Exninfo.iexn type branch = Vcs_.Branch.t * branch_type Vcs_.branch_info type backup = { mine : branch; others : branch list } @@ -214,10 +212,16 @@ type 'vcs state_info = { (* TODO: Make this record private to VCS *) mutable n_reached : int; (* debug cache: how many times was computed *) mutable n_goals : int; (* open goals: indentation *) mutable state : cached_state; (* state value *) + mutable proof_mode : Pvernac.proof_mode option; mutable vcs_backup : 'vcs option * backup option; } -let default_info () = - { n_reached = 0; n_goals = 0; state = Empty; vcs_backup = None,None } +let default_info proof_mode = + { + n_reached = 0; n_goals = 0; + state = EmptyState; + proof_mode; + vcs_backup = (None,None); + } module DynBlockData : Dyn.S = Dyn.Make () @@ -256,15 +260,15 @@ end = struct (* {{{ *) List.fold_left max 0 (CList.map_filter (function - | { Vcs_.kind = `Proof (_,n) } -> Some n + | { Vcs_.kind = `Proof n } -> Some n | { Vcs_.kind = `Edit _ } -> Some 1 | _ -> None) (List.map (Vcs_.get_branch vcs) (Vcs_.branches vcs))) let find_proof_at_depth vcs pl = try List.find (function - | _, { Vcs_.kind = `Proof(m, n) } -> Int.equal n pl - | _, { Vcs_.kind = `Edit _ } -> anomaly(Pp.str "find_proof_at_depth.") + | _, { Vcs_.kind = `Proof n } -> Int.equal n pl + | _, { Vcs_.kind = `Edit _ } -> anomaly(Pp.str "find_proof_at_depth") | _ -> false) (List.map (fun h -> h, Vcs_.get_branch vcs h) (Vcs_.branches vcs)) with Not_found -> failwith "find_proof_at_depth" @@ -326,7 +330,7 @@ module VCS : sig type vcs = (branch_type, transaction, vcs state_info, box) Vcs_.t - val init : stm_doc_type -> id -> doc + val init : stm_doc_type -> id -> Vernacstate.Parser.state -> doc (* val get_type : unit -> stm_doc_type *) val set_ldir : Names.DirPath.t -> unit val get_ldir : unit -> Names.DirPath.t @@ -339,7 +343,7 @@ module VCS : sig val branches : unit -> Branch.t list val get_branch : Branch.t -> branch_type branch_info val get_branch_pos : Branch.t -> id - val new_node : ?id:Stateid.t -> unit -> id + val new_node : ?id:Stateid.t -> Pvernac.proof_mode option -> unit -> id val merge : id -> ours:transaction -> ?into:Branch.t -> Branch.t -> unit val rewrite_merge : id -> ours:transaction -> at:id -> Branch.t -> unit val delete_branch : Branch.t -> unit @@ -356,6 +360,10 @@ module VCS : sig val goals : id -> int -> unit val set_state : id -> cached_state -> unit val get_state : id -> cached_state + val set_parsing_state : id -> Vernacstate.Parser.state -> unit + val get_parsing_state : id -> Vernacstate.Parser.state option + val get_proof_mode : id -> Pvernac.proof_mode option + val set_proof_mode : id -> Pvernac.proof_mode option -> unit (* cuts from start -> stop, raising Expired if some nodes are not there *) val slice : block_start:id -> block_stop:id -> vcs @@ -369,7 +377,8 @@ module VCS : sig val proof_nesting : unit -> int val checkout_shallowest_proof_branch : unit -> unit - val propagate_sideff : action:seff_t -> unit + val propagate_sideff : action:seff_t -> Stateid.t list + val propagate_qed : unit -> unit val gc : unit -> unit @@ -411,11 +420,11 @@ end = struct (* {{{ *) | Qed { qast } -> Pp.string_of_ppcmds (pr_ast qast) in let is_green id = match get_info vcs id with - | Some { state = Valid _ } -> true + | Some { state = FullState _ } -> true | _ -> false in let is_red id = match get_info vcs id with - | Some { state = Error _ } -> true + | Some { state = ErrorState _ } -> true | _ -> false in let head = current_branch vcs in let heads = @@ -517,10 +526,11 @@ end = struct (* {{{ *) let doc_type = ref (Interactive (TopLogical (Names.DirPath.make []))) let ldir = ref Names.DirPath.empty - let init dt id = + let init dt id ps = doc_type := dt; vcs := empty id; - vcs := set_info !vcs id (default_info ()); + let info = { (default_info None) with state = ParsingState ps } in + vcs := set_info !vcs id info; dummy_doc let set_ldir ld = @@ -545,9 +555,9 @@ end = struct (* {{{ *) let branches () = branches !vcs let get_branch head = get_branch !vcs head let get_branch_pos head = (get_branch head).pos - let new_node ?(id=Stateid.fresh ()) () = + let new_node ?(id=Stateid.fresh ()) proof_mode () = assert(Vcs_.get_info !vcs id = None); - vcs := set_info !vcs id (default_info ()); + vcs := set_info !vcs id (default_info proof_mode); id let merge id ~ours ?into branch = vcs := merge !vcs id ~ours ~theirs:Noop ?into branch @@ -569,9 +579,39 @@ end = struct (* {{{ *) | Some x -> x | None -> raise Vcs_aux.Expired let set_state id s = - (get_info id).state <- s; - if async_proofs_is_master !cur_opt then Hooks.(call state_ready ~doc:dummy_doc (* XXX should be taken in input *) id) + let info = get_info id in + info.state <- s; + let is_full_state_valid = match s with + | FullState _ -> true + | EmptyState | ErrorState _ | ParsingState _ -> false + in + if async_proofs_is_master !cur_opt && is_full_state_valid then + Hooks.(call state_ready ~doc:dummy_doc (* XXX should be taken in input *) id) + let get_state id = (get_info id).state + + let get_parsing_state id = + stm_pperr_endline (fun () -> str "retrieve parsing state state " ++ str (Stateid.to_string id) ++ str " }}}"); + match (get_info id).state with + | FullState s -> Some s.Vernacstate.parsing + | ParsingState s -> Some s + | ErrorState (s,_) -> s + | EmptyState -> None + + let set_parsing_state id ps = + let info = get_info id in + let new_state = + match info.state with + | FullState s -> assert false + | ParsingState s -> assert false + | ErrorState _ -> assert false + | EmptyState -> ParsingState ps + in + info.state <- new_state + + let get_proof_mode id = (get_info id).proof_mode + let set_proof_mode id pm = (get_info id).proof_mode <- pm + let reached id = let info = get_info id in info.n_reached <- info.n_reached + 1 @@ -582,28 +622,33 @@ end = struct (* {{{ *) let checkout_shallowest_proof_branch () = if List.mem edit_branch (Vcs_.branches !vcs) then begin - checkout edit_branch; - match get_branch edit_branch with - | { kind = `Edit (mode, _,_,_,_) } -> Proof_global.activate_proof_mode mode [@ocaml.warning "-3"] - | _ -> assert false + checkout edit_branch end else let pl = proof_nesting () in try - let branch, mode = match Vcs_aux.find_proof_at_depth !vcs pl with - | h, { Vcs_.kind = `Proof (m, _) } -> h, m | _ -> assert false in - checkout branch; - stm_prerr_endline (fun () -> "mode:" ^ mode); - Proof_global.activate_proof_mode mode [@ocaml.warning "-3"] + let branch = fst @@ Vcs_aux.find_proof_at_depth !vcs pl in + checkout branch with Failure _ -> - checkout Branch.master; - Proof_global.disactivate_current_proof_mode () [@ocaml.warning "-3"] + checkout Branch.master (* copies the transaction on every open branch *) let propagate_sideff ~action = + List.map (fun b -> + checkout b; + let proof_mode = get_proof_mode @@ get_branch_pos b in + let id = new_node proof_mode () in + merge id ~ours:(Sideff action) ~into:b Branch.master; + id) + (List.filter (fun b -> not (Branch.equal b Branch.master)) (branches ())) + + let propagate_qed () = List.iter (fun b -> checkout b; - let id = new_node () in - merge id ~ours:(Sideff action) ~into:b Branch.master) + let proof_mode = get_proof_mode @@ get_branch_pos b in + let id = new_node proof_mode () in + let parsing = Option.get @@ get_parsing_state (get_branch_pos b) in + merge id ~ours:(Sideff CherryPickEnv) ~into:b Branch.master; + set_parsing_state id parsing) (List.filter (fun b -> not (Branch.equal b Branch.master)) (branches ())) let visit id = Vcs_aux.visit !vcs id @@ -625,10 +670,12 @@ end = struct (* {{{ *) let slice ~block_start ~block_stop = let l = nodes_in_slice ~block_start ~block_stop in let copy_info v id = + let info = get_info id in Vcs_.set_info v id - { (get_info id) with state = Empty; vcs_backup = None,None } in + { info with state = EmptyState; + vcs_backup = None,None } in let make_shallow = function - | Valid st -> Valid (Vernacstate.make_shallow st) + | FullState st -> FullState (Vernacstate.make_shallow st) | x -> x in let copy_info_w_state v id = @@ -651,12 +698,14 @@ end = struct (* {{{ *) let v = copy_info v id in v) l v in (* Stm should have reached the beginning of proof *) - assert (match (get_info block_start).state with Valid _ -> true | _ -> false); + assert (match get_state block_start + with FullState _ -> true | _ -> false); (* We put in the new dag the most recent state known to master *) let rec fill id = - match (get_info id).state with - | Empty | Error _ -> fill (Vcs_aux.visit v id).next - | Valid _ -> copy_info_w_state v id in + match get_state id with + | EmptyState | ErrorState _ | ParsingState _ -> fill (Vcs_aux.visit v id).next + | FullState _ -> copy_info_w_state v id + in let v = fill block_stop in (* We put in the new dag the first state (since Qed shall run on it, * see check_task_aux) *) @@ -739,7 +788,7 @@ end = struct (* {{{ *) else begin set_last_job job; if Option.is_empty !worker then - worker := Some (Thread.create run_command ()) + worker := Some (CThread.create run_command ()) end end @@ -753,13 +802,12 @@ end = struct (* {{{ *) end (* }}} *) let state_of_id ~doc id = - try match (VCS.get_info id).state with - | Valid s -> `Valid (Some s) - | Error (e,_) -> `Error e - | Empty -> `Valid None + try match VCS.get_state id with + | FullState s -> `Valid (Some s) + | ErrorState (_,(e,_)) -> `Error e + | EmptyState | ParsingState _ -> `Valid None with VCS.Expired -> `Expired - (****** A cache: fills in the nodes of the VCS document with their value ******) module State : sig @@ -782,6 +830,7 @@ module State : sig val fix_exn_ref : (Exninfo.iexn -> Exninfo.iexn) ref val install_cached : Stateid.t -> unit + (* val install_parsing_state : Stateid.t -> unit *) val is_cached : ?cache:bool -> Stateid.t -> bool val is_cached_and_valid : ?cache:bool -> Stateid.t -> bool @@ -804,10 +853,6 @@ module State : sig val register_root_state : unit -> unit val restore_root_state : unit -> unit - (* Only for internal use to catch problems in parse_sentence, should - be removed in the state handling refactoring. *) - val cur_id : Stateid.t ref - val purify : ('a -> 'b) -> 'a -> 'b end = struct (* {{{ *) @@ -824,6 +869,8 @@ end = struct (* {{{ *) Vernacstate.unfreeze_interp_state st.vernac_state; cur_id := st.id + let invalidate_cur_state () = cur_id := Stateid.dummy + type proof_part = Proof_global.t * int * (* Evarutil.meta_counter_summary_tag *) @@ -842,50 +889,58 @@ end = struct (* {{{ *) Summary.project_from_summary st Util.(pi3 summary_pstate) let cache_state ~marshallable id = - VCS.set_state id (Valid (Vernacstate.freeze_interp_state ~marshallable)) + VCS.set_state id (FullState (Vernacstate.freeze_interp_state ~marshallable)) - let freeze_invalid id iexn = VCS.set_state id (Error iexn) + let freeze_invalid id iexn = + let ps = VCS.get_parsing_state id in + VCS.set_state id (ErrorState (ps,iexn)) let is_cached ?(cache=false) id only_valid = if Stateid.equal id !cur_id then try match VCS.get_info id with - | { state = Empty } when cache -> cache_state ~marshallable:false id; true + | ({ state = EmptyState } | { state = ParsingState _ }) when cache -> cache_state ~marshallable:false id; true | _ -> true with VCS.Expired -> false else - try match VCS.get_info id with - | { state = Empty } -> false - | { state = Valid _ } -> true - | { state = Error _ } -> not only_valid + try match VCS.get_state id with + | EmptyState | ParsingState _ -> false + | FullState _ -> true + | ErrorState _ -> not only_valid with VCS.Expired -> false let is_cached_and_valid ?cache id = is_cached ?cache id true let is_cached ?cache id = is_cached ?cache id false let install_cached id = - match VCS.get_info id with - | { state = Valid s } -> + match VCS.get_state id with + | FullState s -> Vernacstate.unfreeze_interp_state s; cur_id := id - | { state = Error ie } -> - cur_id := id; + | ErrorState (_,ie) -> Exninfo.iraise ie - | _ -> - (* coqc has a 1 slot cache and only for valid states *) - if not (VCS.is_interactive ()) && Stateid.equal id !cur_id then () - else anomaly Pp.(str "installing a non cached state.") + | EmptyState | ParsingState _ -> + (* coqc has a 1 slot cache and only for valid states *) + if (VCS.is_interactive ()) || not (Stateid.equal id !cur_id) then + anomaly Pp.(str "installing a non cached state.") + + (* + let install_parsing_state id = + if not (Stateid.equal id !cur_id) then begin + Vernacstate.Parser.install @@ VCS.get_parsing_state id + end + *) let get_cached id = - try match VCS.get_info id with - | { state = Valid s } -> s + try match VCS.get_state id with + | FullState s -> s | _ -> anomaly Pp.(str "not a cached state.") with VCS.Expired -> anomaly Pp.(str "not a cached state (expired).") let assign id what = let open Vernacstate in - if VCS.get_state id <> Empty then () else + if VCS.get_state id <> EmptyState then () else try match what with | `Full s -> let s = @@ -897,7 +952,7 @@ end = struct (* {{{ *) ~src:(get_cached prev).proof ~tgt:s.proof } else s with VCS.Expired -> s in - VCS.set_state id (Valid s) + VCS.set_state id (FullState s) | `ProofOnly(ontop,(pstate,c1,c2,c3)) -> if is_cached_and_valid ontop then let s = get_cached ontop in @@ -913,7 +968,7 @@ end = struct (* {{{ *) st end } in - VCS.set_state id (Valid s) + VCS.set_state id (FullState s) with VCS.Expired -> () let exn_on id ~valid (e, info) = @@ -959,7 +1014,7 @@ end = struct (* {{{ *) with e -> let (e, info) = CErrors.push e in let good_id = !cur_id in - cur_id := Stateid.dummy; + invalidate_cur_state (); VCS.reached id; let ie = match Stateid.get info, safe_id with @@ -1131,7 +1186,7 @@ module Backtrack : sig val branches_of : Stateid.t -> backup (* Returns the state that the command should backtract to *) - val undo_vernac_classifier : vernac_control -> doc:doc -> Stateid.t * vernac_when + val undo_vernac_classifier : vernac_control -> doc:doc -> Stateid.t val get_prev_proof : doc:doc -> Stateid.t -> Proof.t option end = struct (* {{{ *) @@ -1206,30 +1261,30 @@ end = struct (* {{{ *) try match Vernacprop.under_control v with | VernacResetInitial -> - Stateid.initial, VtNow + Stateid.initial | VernacResetName {CAst.v=name} -> - let id = VCS.get_branch_pos (VCS.current_branch ()) in + let id = VCS.cur_tip () in (try let oid = fold_until (fun b (id,_,label,_,_) -> if b then `Stop id else `Cont (List.mem name label)) false id in - oid, VtNow + oid with Not_found -> - id, VtNow) + id) | VernacBack n -> - let id = VCS.get_branch_pos (VCS.current_branch ()) in + let id = VCS.cur_tip () in let oid = fold_until (fun n (id,_,_,_,_) -> if Int.equal n 0 then `Stop id else `Cont (n-1)) n id in - oid, VtNow + oid | VernacUndo n -> - let id = VCS.get_branch_pos (VCS.current_branch ()) in + let id = VCS.cur_tip () in let oid = fold_until back_tactic n id in - oid, VtLater + oid | VernacUndoTo _ | VernacRestart as e -> let m = match e with VernacUndoTo m -> m | _ -> 0 in - let id = VCS.get_branch_pos (VCS.current_branch ()) in + let id = VCS.cur_tip () in let vcs = match (VCS.get_info id).vcs_backup with | None, _ -> anomaly Pp.(str"Backtrack: tip with no vcs_backup.") @@ -1242,15 +1297,15 @@ end = struct (* {{{ *) 0 id in let oid = fold_until (fun n (id,_,_,_,_) -> if Int.equal n 0 then `Stop id else `Cont (n-1)) (n-m-1) id in - oid, VtLater + oid | VernacAbortAll -> - let id = VCS.get_branch_pos (VCS.current_branch ()) in + let id = VCS.cur_tip () in let oid = fold_until (fun () (id,vcs,_,_,_) -> match Vcs_.branches vcs with [_] -> `Stop id | _ -> `Cont ()) () id in - oid, VtLater + oid | VernacBackTo id -> - Stateid.of_int id, VtNow + Stateid.of_int id | _ -> anomaly Pp.(str "incorrect VtMeta classification") with | Not_found -> @@ -1616,7 +1671,7 @@ end = struct (* {{{ *) when is_tac expr && State.same_env o n -> (* A pure tactic *) Some (id, `ProofOnly (prev, State.proof_part_of_frozen n)) | Some _, Some s -> - msg_debug (Pp.str "STM: sending back a fat state"); + if !Flags.debug then msg_debug (Pp.str "STM: sending back a fat state"); Some (id, `Full s) | _, Some s -> Some (id, `Full s) in let rec aux seen = function @@ -2017,7 +2072,7 @@ end = struct (* {{{ *) find ~time:false ~batch:false ~fail:false e in let st = Vernacstate.freeze_interp_state ~marshallable:false in Vernacentries.with_fail st fail (fun () -> - (if time then System.with_time ~batch else (fun x -> x)) (fun () -> + (if time then System.with_time ~batch ~header:(Pp.mt ()) else (fun x -> x)) (fun () -> ignore(TaskQueue.with_n_workers nworkers (fun queue -> Proof_global.with_current_proof (fun _ p -> let Proof.{goals} = Proof.data p in @@ -2332,8 +2387,8 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = (Proofview.Goal.goal gl) goals_to_admit then Proofview.give_up else Proofview.tclUNIT () end in - match (VCS.get_info base_state).state with - | Valid { Vernacstate.proof } -> + match VCS.get_state base_state with + | FullState { Vernacstate.proof } -> Proof_global.unfreeze proof; Proof_global.with_current_proof (fun _ p -> feedback ~id:id Feedback.AddedAxiom; @@ -2470,7 +2525,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = VCS.create_proof_task_box nodes ~qed:id ~block_start; begin match brinfo, qed.fproof with | { VCS.kind = `Edit _ }, None -> assert false - | { VCS.kind = `Edit (_,_,_, okeep, _) }, Some (ofp, cancel) -> + | { VCS.kind = `Edit (_,_, okeep, _) }, Some (ofp, cancel) -> assert(redefine_qed = true); if okeep <> keep then msg_warning(strbrk("The command closing the proof changed. " @@ -2656,7 +2711,7 @@ let new_doc { doc_type ; iload_path; require_libs; stm_options } = (* We must reset the whole state before creating a document! *) State.restore_root_state (); - let doc = VCS.init doc_type Stateid.initial in + let doc = VCS.init doc_type Stateid.initial (Vernacstate.Parser.init ()) in (* Set load path; important, this has to happen before we declare the library below as [Declaremods/Library] will infer the module @@ -2724,16 +2779,8 @@ let observe ~doc id = let finish ~doc = let head = VCS.current_branch () in - let doc =observe ~doc (VCS.get_branch_pos head) in - VCS.print (); - (* EJGA: Setting here the proof state looks really wrong, and it - hides true bugs cf bug #5363. Also, what happens with observe? *) - (* Some commands may by side effect change the proof mode *) - (match VCS.get_branch head with - | { VCS.kind = `Edit (mode,_,_,_,_) } -> Proof_global.activate_proof_mode mode [@ocaml.warning "-3"] - | { VCS.kind = `Proof (mode, _) } -> Proof_global.activate_proof_mode mode [@ocaml.warning "-3"] - | _ -> () - ); doc + let doc = observe ~doc (VCS.get_branch_pos head) in + VCS.print (); doc let wait ~doc = let doc = observe ~doc (VCS.get_branch_pos VCS.Branch.master) in @@ -2810,12 +2857,14 @@ let merge_proof_branch ~valid ?id qast keep brname = match brinfo with | { VCS.kind = `Proof _ } -> VCS.checkout VCS.Branch.master; - let id = VCS.new_node ?id () in + let id = VCS.new_node ?id None () in + let parsing = Option.get @@ VCS.get_parsing_state (VCS.cur_tip ()) in VCS.merge id ~ours:(Qed (qed None)) brname; + VCS.set_parsing_state id parsing; VCS.delete_branch brname; - VCS.propagate_sideff ~action:CherryPickEnv; + VCS.propagate_qed (); `Ok - | { VCS.kind = `Edit (mode, qed_id, master_id, _,_) } -> + | { VCS.kind = `Edit (qed_id, master_id, _,_) } -> let ofp = match VCS.visit qed_id with | { step = `Qed ({ fproof }, _) } -> fproof @@ -2832,17 +2881,9 @@ let merge_proof_branch ~valid ?id qast keep brname = (* When tty is true, this code also does some of the job of the user interface: jump back to a state that is valid *) let handle_failure (e, info) vcs = - match Stateid.get info with - | None -> - VCS.restore vcs; - VCS.print (); - anomaly(str"error with no safe_id attached:" ++ spc() ++ - CErrors.iprint_no_report (e, info) ++ str".") - | Some (safe_id, id) -> - stm_prerr_endline (fun () -> "Failed at state " ^ Stateid.to_string id); - VCS.restore vcs; - VCS.print (); - Exninfo.iraise (e, info) + VCS.restore vcs; + VCS.print (); + Exninfo.iraise (e, info) let snapshot_vio ~doc ldir long_f_dot_vo = let doc = finish ~doc in @@ -2855,25 +2896,32 @@ let snapshot_vio ~doc ldir long_f_dot_vo = let reset_task_queue = Slaves.reset_task_queue (* Document building *) -let process_back_meta_command ~newtip ~head oid aast w = - let id = VCS.new_node ~id:newtip () in - let { mine; others } = Backtrack.branches_of oid in + +(* We process a meta command found in the document *) +let process_back_meta_command ~newtip ~head oid aast = let valid = VCS.get_branch_pos head in + let old_parsing = Option.get @@ VCS.get_parsing_state oid in + + (* Merge in and discard all the branches currently open that were not open in `oid` *) + let { mine; others } = Backtrack.branches_of oid in List.iter (fun branch -> if not (List.mem_assoc branch (mine::others)) then ignore(merge_proof_branch ~valid aast VtDrop branch)) (VCS.branches ()); + + (* We add a node on top of every branch, to represent state aliasing *) VCS.checkout_shallowest_proof_branch (); let head = VCS.current_branch () in List.iter (fun b -> - if not(VCS.Branch.equal b head) then begin - VCS.checkout b; - VCS.commit (VCS.new_node ()) (Alias (oid,aast)); - end) + VCS.checkout b; + let id = if (VCS.Branch.equal b head) then Some newtip else None in + let proof_mode = VCS.get_proof_mode @@ VCS.cur_tip () in + let id = VCS.new_node ?id proof_mode () in + VCS.commit id (Alias (oid,aast)); + VCS.set_parsing_state id old_parsing) (VCS.branches ()); VCS.checkout_shallowest_proof_branch (); - VCS.commit id (Alias (oid,aast)); - Backtrack.record (); if w == VtNow then ignore(finish ~doc:dummy_doc); `Ok + Backtrack.record (); `Ok let get_allow_nested_proofs = Goptions.declare_bool_option_and_ref @@ -2882,6 +2930,7 @@ let get_allow_nested_proofs = ~key:Vernac_classifier.stm_allow_nested_proofs_option_name ~value:false +(** [process_transaction] adds a node in the document *) let process_transaction ~doc ?(newtip=Stateid.fresh ()) ({ verbose; loc; expr } as x) c = stm_pperr_endline (fun () -> str "{{{ processing: " ++ pr_ast x); @@ -2889,18 +2938,21 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) try let head = VCS.current_branch () in VCS.checkout head; + let head_parsing = + Option.get @@ VCS.(get_parsing_state (get_branch_pos head)) in + let proof_mode = VCS.(get_proof_mode (get_branch_pos head)) in let rc = begin stm_prerr_endline (fun () -> " classified as: " ^ Vernac_classifier.string_of_vernac_classification c); match c with (* Meta *) | VtMeta, _ -> - let id, w = Backtrack.undo_vernac_classifier expr ~doc in - process_back_meta_command ~newtip ~head id x w + let id = Backtrack.undo_vernac_classifier expr ~doc in + process_back_meta_command ~newtip ~head id x (* Query *) | VtQuery, w -> - let id = VCS.new_node ~id:newtip () in + let id = VCS.new_node ~id:newtip proof_mode () in let queue = if VCS.is_vio_doc () && VCS.((get_branch head).kind = `Master) && @@ -2908,10 +2960,11 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) then `SkipQueue else `MainQueue in VCS.commit id (mkTransCmd x [] false queue); - Backtrack.record (); if w == VtNow then ignore(finish ~doc:dummy_doc); `Ok + VCS.set_parsing_state id head_parsing; + Backtrack.record (); assert (w == VtLater); `Ok (* Proof *) - | VtStartProof (mode, guarantee, names), w -> + | VtStartProof (guarantee, names), w -> if not (get_allow_nested_proofs ()) && VCS.proof_nesting () > 0 then "Nested proofs are not allowed unless you turn option Nested Proofs Allowed on." @@ -2921,39 +2974,22 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) |> Exninfo.iraise else - let id = VCS.new_node ~id:newtip () in + let proof_mode = Some (Vernacentries.get_default_proof_mode ()) in + let id = VCS.new_node ~id:newtip proof_mode () in let bname = VCS.mk_branch_name x in VCS.checkout VCS.Branch.master; if VCS.Branch.equal head VCS.Branch.master then begin VCS.commit id (Fork (x, bname, guarantee, names)); - VCS.branch bname (`Proof (mode, VCS.proof_nesting () + 1)) + VCS.branch bname (`Proof (VCS.proof_nesting () + 1)) end else begin - VCS.branch bname (`Proof (mode, VCS.proof_nesting () + 1)); + VCS.branch bname (`Proof (VCS.proof_nesting () + 1)); VCS.merge id ~ours:(Fork (x, bname, guarantee, names)) head end; - Proof_global.activate_proof_mode mode [@ocaml.warning "-3"]; - Backtrack.record (); if w == VtNow then ignore(finish ~doc:dummy_doc); `Ok - | VtProofMode _, VtLater -> - anomaly(str"VtProofMode must be executed VtNow.") - | VtProofMode mode, VtNow -> - let id = VCS.new_node ~id:newtip () in - VCS.commit id (mkTransCmd x [] false `MainQueue); - List.iter - (fun bn -> match VCS.get_branch bn with - | { VCS.root; kind = `Master; pos } -> () - | { VCS.root; kind = `Proof(_,d); pos } -> - VCS.delete_branch bn; - VCS.branch ~root ~pos bn (`Proof(mode,d)) - | { VCS.root; kind = `Edit(_,f,q,k,ob); pos } -> - VCS.delete_branch bn; - VCS.branch ~root ~pos bn (`Edit(mode,f,q,k,ob))) - (VCS.branches ()); - VCS.checkout_shallowest_proof_branch (); - Backtrack.record (); - ignore(finish ~doc:dummy_doc); - `Ok + VCS.set_parsing_state id head_parsing; + Backtrack.record (); assert (w == VtLater); `Ok + | VtProofStep { parallel; proof_block_detection = cblock }, w -> - let id = VCS.new_node ~id:newtip () in + let id = VCS.new_node ~id:newtip proof_mode () in let queue = match parallel with | `Yes(solve,abstract) -> `TacQueue (solve, abstract, ref false) @@ -2963,21 +2999,25 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) If/when and UI will make something useful with this piece of info, detection should occur here. detect_proof_block id cblock; *) - Backtrack.record (); if w == VtNow then ignore(finish ~doc:dummy_doc); `Ok + VCS.set_parsing_state id head_parsing; + Backtrack.record (); assert (w == VtLater); `Ok + | VtQed keep, w -> let valid = VCS.get_branch_pos head in - let rc = merge_proof_branch ~valid ~id:newtip x keep head in + let rc = + merge_proof_branch ~valid ~id:newtip x keep head in VCS.checkout_shallowest_proof_branch (); - Backtrack.record (); if w == VtNow then ignore(finish ~doc:dummy_doc); + Backtrack.record (); assert (w == VtLater); rc (* Side effect in a (still open) proof is replayed on all branches*) | VtSideff l, w -> - let id = VCS.new_node ~id:newtip () in - begin match (VCS.get_branch head).VCS.kind with - | `Edit _ -> VCS.commit id (mkTransCmd x l true `MainQueue); - | `Master -> VCS.commit id (mkTransCmd x l false `MainQueue); - | `Proof _ -> + let id = VCS.new_node ~id:newtip proof_mode () in + let new_ids = + match (VCS.get_branch head).VCS.kind with + | `Edit _ -> VCS.commit id (mkTransCmd x l true `MainQueue); [] + | `Master -> VCS.commit id (mkTransCmd x l false `MainQueue); [] + | `Proof _ -> VCS.checkout VCS.Branch.master; VCS.commit id (mkTransCmd x l true `MainQueue); (* We can't replay a Definition since universes may be differently @@ -2985,15 +3025,39 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) let action = match Vernacprop.under_control x.expr with | VernacDefinition(_, _, DefineBody _) -> CherryPickEnv | _ -> ReplayCommand x in - VCS.propagate_sideff ~action; - end; + VCS.propagate_sideff ~action + in VCS.checkout_shallowest_proof_branch (); - Backtrack.record (); if w == VtNow then ignore(finish ~doc:dummy_doc); `Ok + Backtrack.record (); + let parsing_state = + begin match w with + | VtNow -> + (* We need to execute to get the new parsing state *) + ignore(finish ~doc:dummy_doc); + let parsing = Vernacstate.Parser.cur_state () in + (* If execution has not been put in cache, we need to save the parsing state *) + if (VCS.get_info id).state == EmptyState then VCS.set_parsing_state id parsing; + parsing + | VtLater -> VCS.set_parsing_state id head_parsing; head_parsing + end + in + (* We save the parsing state on non-master branches *) + List.iter (fun id -> + if (VCS.get_info id).state == EmptyState then + VCS.set_parsing_state id parsing_state) new_ids; + `Ok (* Unknown: we execute it, check for open goals and propagate sideeff *) | VtUnknown, VtNow -> let in_proof = not (VCS.Branch.equal head VCS.Branch.master) in - let id = VCS.new_node ~id:newtip () in + if not (get_allow_nested_proofs ()) && in_proof then + "Commands which may open proofs are not allowed in a proof unless you turn option Nested Proofs Allowed on." + |> Pp.str + |> (fun s -> (UserError (None, s), Exninfo.null)) + |> State.exn_on ~valid:Stateid.dummy Stateid.dummy + |> Exninfo.iraise + else + let id = VCS.new_node ~id:newtip proof_mode () in let head_id = VCS.get_branch_pos head in let _st : unit = Reach.known_state ~doc ~cache:true head_id in (* ensure it is ok *) let step () = @@ -3008,12 +3072,11 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) let bname = VCS.mk_branch_name x in let opacity_of_produced_term = function (* This AST is ambiguous, hence we check it dynamically *) - | VernacInstance (false, _,_ , None, _) -> GuaranteesOpacity + | VernacInstance (_,_ , None, _) -> GuaranteesOpacity | _ -> Doesn'tGuaranteeOpacity in VCS.commit id (Fork (x,bname,opacity_of_produced_term (Vernacprop.under_control x.expr),[])); - let proof_mode = default_proof_mode () in - VCS.branch bname (`Proof (proof_mode, VCS.proof_nesting () + 1)); - Proof_global.activate_proof_mode proof_mode [@ocaml.warning "-3"]; + VCS.set_proof_mode id (Some (Vernacentries.get_default_proof_mode ())); + VCS.branch bname (`Proof (VCS.proof_nesting () + 1)); end else begin begin match (VCS.get_branch head).VCS.kind with | `Edit _ -> VCS.commit id (mkTransCmd x [] in_proof `MainQueue); @@ -3021,7 +3084,7 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) | `Proof _ -> VCS.commit id (mkTransCmd x [] in_proof `MainQueue); (* We hope it can be replayed, but we can't really know *) - VCS.propagate_sideff ~action:(ReplayCommand x); + ignore(VCS.propagate_sideff ~action:(ReplayCommand x)); end; VCS.checkout_shallowest_proof_branch (); end in @@ -3030,6 +3093,17 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) | VtUnknown, VtLater -> anomaly(str"classifier: VtUnknown must imply VtNow.") + + | VtProofMode pm, VtNow -> + let proof_mode = Pvernac.lookup_proof_mode pm in + let id = VCS.new_node ~id:newtip proof_mode () in + VCS.commit id (mkTransCmd x [] false `MainQueue); + VCS.set_parsing_state id head_parsing; + Backtrack.record (); `Ok + + | VtProofMode _, VtLater -> + anomaly(str"classifier: VtProofMode must imply VtNow.") + end in let pr_rc rc = match rc with | `Ok -> Pp.(seq [str "newtip ("; str (Stateid.to_string (VCS.cur_tip ())); str ")"]) @@ -3053,45 +3127,10 @@ let get_ast ~doc id = let stop_worker n = Slaves.cancel_worker n -(* We must parse on top of a state id, it should be something like: - - - get parsing information for that state. - - feed the parsable / parser with the right parsing information. - - call the parser - - Now, the invariant in ensured by the callers, but this is a bit - problematic. -*) -exception End_of_input - -let parse_sentence ~doc sid pa = - (* XXX: Should this restore the previous state? - Using reach here to try to really get to the - proper state makes the error resilience code fail *) - (* Reach.known_state ~cache:`Yes sid; *) - let cur_tip = VCS.cur_tip () in - let real_tip = !State.cur_id in - if not (Stateid.equal sid cur_tip) then - user_err ~hdr:"Stm.parse_sentence" - (str "Currently, the parsing api only supports parsing at the tip of the document." ++ fnl () ++ - str "You wanted to parse at: " ++ str (Stateid.to_string sid) ++ - str " but the current tip is: " ++ str (Stateid.to_string cur_tip)) ; - if not (Stateid.equal sid real_tip) && !Flags.debug && !stm_debug then - Feedback.msg_debug - (str "Warning, the real tip doesn't match the current tip." ++ - str "You wanted to parse at: " ++ str (Stateid.to_string sid) ++ - str " but the real tip is: " ++ str (Stateid.to_string real_tip) ++ fnl () ++ - str "This is usually due to use of Stm.observe to evaluate a state different than the tip. " ++ - str "All is good if not parsing changes occur between the two states, however if they do, a problem might occur."); - Flags.with_option Flags.we_are_parsing (fun () -> - try - match Pcoq.Entry.parse Pvernac.main_entry pa with - | None -> raise End_of_input - | Some (loc, cmd) -> CAst.make ~loc cmd - with e when CErrors.noncritical e -> - let (e, info) = CErrors.push e in - Exninfo.iraise (e, info)) - () +let parse_sentence ~doc sid ~entry pa = + let ps = Option.get @@ VCS.get_parsing_state sid in + let proof_mode = VCS.get_proof_mode sid in + Vernacstate.Parser.parse ps (entry proof_mode) pa (* You may need to know the len + indentation of previous command to compute * the indentation of the current one. @@ -3155,20 +3194,20 @@ let query ~doc ~at ~route s = State.purify (fun s -> if Stateid.equal at Stateid.dummy then ignore(finish ~doc:dummy_doc) else Reach.known_state ~doc ~cache:true at; - try - while true do - let { CAst.loc; v=ast } = parse_sentence ~doc at s in - let indentation, strlen = compute_indentation ?loc at in - let st = State.get_cached at in - let aast = { verbose = true; indentation; strlen; loc; expr = ast } in - ignore(stm_vernac_interp ~route at st aast) - done; - with - | End_of_input -> () - | exn -> - let iexn = CErrors.push exn in - Exninfo.iraise iexn - ) + let rec loop () = + match parse_sentence ~doc at ~entry:Pvernac.main_entry s with + | None -> () + | Some (loc, ast) -> + let indentation, strlen = compute_indentation ~loc at in + let st = State.get_cached at in + let aast = { + verbose = true; indentation; strlen; + loc = Some loc; expr = ast } in + ignore(stm_vernac_interp ~route at st aast); + loop () + in + loop () + ) s let edit_at ~doc id = @@ -3206,21 +3245,21 @@ let edit_at ~doc id = | { step = `Sideff (ReplayCommand _,id) } -> id | { step = `Sideff _ } -> tip | { next } -> master_for_br root next in - let reopen_branch start at_id mode qed_id tip old_branch = + let reopen_branch start at_id qed_id tip old_branch = let master_id, cancel_switch, keep = (* Hum, this should be the real start_id in the cluster and not next *) match VCS.visit qed_id with | { step = `Qed ({ fproof = Some (_,cs); keep },_) } -> start, cs, keep | _ -> anomaly (str "ProofTask not ending with Qed.") in VCS.branch ~root:master_id ~pos:id - VCS.edit_branch (`Edit (mode, qed_id, master_id, keep, old_branch)); + VCS.edit_branch (`Edit (qed_id, master_id, keep, old_branch)); VCS.delete_boxes_of id; cancel_switch := true; Reach.known_state ~doc ~cache:(VCS.is_interactive ()) id; VCS.checkout_shallowest_proof_branch (); `Focus { stop = qed_id; start = master_id; tip } in let no_edit = function - | `Edit (pm, _,_,_,_) -> `Proof(pm,1) + | `Edit (_,_,_,_) -> `Proof 1 | x -> x in let backto id bn = List.iter VCS.delete_branch (VCS.branches ()); @@ -3246,17 +3285,17 @@ let edit_at ~doc id = let focused = List.exists ((=) VCS.edit_branch) (VCS.branches ()) in let branch_info = match snd (VCS.get_info id).vcs_backup with - | Some{ mine = bn, { VCS.kind = `Proof(m,_) }} -> Some(m,bn) - | Some{ mine = _, { VCS.kind = `Edit(m,_,_,_,bn) }} -> Some (m,bn) + | Some{ mine = bn, { VCS.kind = `Proof _ }} -> Some bn + | Some{ mine = _, { VCS.kind = `Edit(_,_,_,bn) }} -> Some bn | _ -> None in match focused, VCS.proof_task_box_of id, branch_info with | _, Some _, None -> assert false - | false, Some { qed = qed_id ; lemma = start }, Some(mode,bn) -> + | false, Some { qed = qed_id ; lemma = start }, Some bn -> let tip = VCS.cur_tip () in if has_failed qed_id && is_pure qed_id && not !cur_opt.async_proofs_never_reopen_branch - then reopen_branch start id mode qed_id tip bn + then reopen_branch start id qed_id tip bn else backto id (Some bn) - | true, Some { qed = qed_id }, Some(mode,bn) -> + | true, Some { qed = qed_id }, Some bn -> if on_cur_branch id then begin assert false end else if is_ancestor_of_cur_branch id then begin @@ -3275,7 +3314,7 @@ let edit_at ~doc id = end else begin anomaly(str"Cannot leave an `Edit branch open.") end - | false, None, Some(_,bn) -> backto id (Some bn) + | false, None, Some bn -> backto id (Some bn) | false, None, None -> backto id None in VCS.print (); diff --git a/stm/stm.mli b/stm/stm.mli index b6071fa56b..821ab59a43 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -93,16 +93,17 @@ val init_core : unit -> unit (** [new_doc opt] Creates a new document with options [opt] *) val new_doc : stm_init_options -> doc * Stateid.t -(** [parse_sentence sid pa] Reads a sentence from [pa] with parsing - state [sid] Returns [End_of_input] if the stream ends *) -val parse_sentence : doc:doc -> Stateid.t -> Pcoq.Parsable.t -> - Vernacexpr.vernac_control CAst.t +(** [parse_sentence sid entry pa] Reads a sentence from [pa] with parsing state + [sid] and non terminal [entry]. [entry] receives in input the current proof + mode. [sid] should be associated with a valid parsing state (which may not + be the case if an error was raised at parsing time). *) +val parse_sentence : + doc:doc -> Stateid.t -> + entry:(Pvernac.proof_mode option -> 'a Pcoq.Entry.t) -> Pcoq.Parsable.t -> 'a (* Reminder: A parsable [pa] is constructed using [Pcoq.Parsable.t stream], where [stream : char Stream.t]. *) -exception End_of_input - (* [add ~ontop ?newtip verbose cmd] adds a new command [cmd] ontop of the state [ontop]. The [ontop] parameter just asserts that the GUI is on diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index f40b3e901b..292e3966a1 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -15,8 +15,6 @@ open CAst open Vernacextend open Vernacexpr -let default_proof_mode () = Proof_global.get_default_proof_mode_name () [@ocaml.warning "-3"] - let string_of_parallel = function | `Yes (solve,abs) -> "par" ^ if solve then "solve" else "" ^ if abs then "abs" else "" @@ -32,9 +30,9 @@ let string_of_vernac_type = function | VtProofStep { parallel; proof_block_detection } -> "ProofStep " ^ string_of_parallel parallel ^ Option.default "" proof_block_detection - | VtProofMode s -> "ProofMode " ^ s | VtQuery -> "Query" | VtMeta -> "Meta " + | VtProofMode _ -> "Proof Mode" let string_of_vernac_when = function | VtLater -> "Later" @@ -57,7 +55,7 @@ let stm_allow_nested_proofs_option_name = ["Nested";"Proofs";"Allowed"] let options_affecting_stm_scheduling = [ Attributes.universe_polymorphism_option_name; stm_allow_nested_proofs_option_name; - Proof_global.proof_mode_opt_name; + Vernacentries.proof_mode_opt_name; ] let classify_vernac e = @@ -97,15 +95,15 @@ let classify_vernac e = | VernacSetOption (_, ["Default";"Proof";"Using"],_) -> VtSideff [], VtNow (* StartProof *) | VernacDefinition ((Decl_kinds.DoDischarge,_),({v=i},_),ProveBody _) -> - VtStartProof(default_proof_mode (),Doesn'tGuaranteeOpacity, idents_of_name i), VtLater + VtStartProof(Doesn'tGuaranteeOpacity, idents_of_name i), VtLater | VernacDefinition (_,({v=i},_),ProveBody _) -> let guarantee = if poly then Doesn'tGuaranteeOpacity else GuaranteesOpacity in - VtStartProof(default_proof_mode (),guarantee, idents_of_name i), VtLater + VtStartProof(guarantee, idents_of_name i), VtLater | VernacStartTheoremProof (_,l) -> let ids = List.map (fun (({v=i}, _), _) -> i) l in let guarantee = if poly then Doesn'tGuaranteeOpacity else GuaranteesOpacity in - VtStartProof (default_proof_mode (),guarantee,ids), VtLater + VtStartProof (guarantee,ids), VtLater | VernacFixpoint (discharge,l) -> let guarantee = if discharge = Decl_kinds.DoDischarge || poly then Doesn'tGuaranteeOpacity @@ -115,7 +113,7 @@ let classify_vernac e = List.fold_left (fun (l,b) ((({v=id},_),_,_,_,p),_) -> id::l, b || p = None) ([],false) l in if open_proof - then VtStartProof (default_proof_mode (),guarantee,ids), VtLater + then VtStartProof (guarantee,ids), VtLater else VtSideff ids, VtLater | VernacCoFixpoint (discharge,l) -> let guarantee = @@ -126,7 +124,7 @@ let classify_vernac e = List.fold_left (fun (l,b) ((({v=id},_),_,_,p),_) -> id::l, b || p = None) ([],false) l in if open_proof - then VtStartProof (default_proof_mode (),guarantee,ids), VtLater + then VtStartProof (guarantee,ids), VtLater else VtSideff ids, VtLater (* Sideff: apply to all open branches. usually run on master only *) | VernacAssumption (_,_,l) -> @@ -160,11 +158,11 @@ let classify_vernac e = | VernacMemOption _ | VernacPrintOption _ | VernacGlobalCheck _ | VernacDeclareReduction _ - | VernacDeclareClass _ | VernacDeclareInstances _ + | VernacExistingClass _ | VernacExistingInstance _ | VernacRegister _ | VernacNameSectionHypSet _ - | VernacDeclareCustomEntry _ - | VernacComments _ -> VtSideff [], VtLater + | VernacComments _ + | VernacDeclareInstance _ -> VtSideff [], VtLater (* Who knows *) | VernacLoad _ -> VtSideff [], VtNow (* (Local) Notations have to disappear *) @@ -176,6 +174,7 @@ let classify_vernac e = | VernacDeclareModuleType ({v=id},bl,_,_) -> VtSideff [id], if bl = [] then VtLater else VtNow (* These commands alter the parser *) + | VernacDeclareCustomEntry _ | VernacOpenCloseScope _ | VernacDeclareScope _ | VernacDelimiters _ | VernacBindScope _ | VernacInfix _ | VernacNotation _ | VernacNotationAddFormat _ @@ -183,8 +182,8 @@ let classify_vernac e = | VernacSyntacticDefinition _ | VernacRequire _ | VernacImport _ | VernacInclude _ | VernacDeclareMLModule _ - | VernacContext _ (* TASSI: unsure *) - | VernacProofMode _ -> VtSideff [], VtNow + | VernacContext _ (* TASSI: unsure *) -> VtSideff [], VtNow + | VernacProofMode pm -> VtProofMode pm, VtNow (* These are ambiguous *) | VernacInstance _ -> VtUnknown, VtNow (* Stm will install a new classifier to handle these *) @@ -210,10 +209,10 @@ let classify_vernac e = | VernacFail e -> (* Fail Qed or Fail Lemma must not join/fork the DAG *) (match static_control_classifier e with | ( VtQuery | VtProofStep _ | VtSideff _ - | VtProofMode _ | VtMeta), _ as x -> x + | VtMeta), _ as x -> x | VtQed _, _ -> VtProofStep { parallel = `No; proof_block_detection = None }, - VtNow - | (VtStartProof _ | VtUnknown), _ -> VtUnknown, VtNow) + VtLater + | (VtStartProof _ | VtUnknown | VtProofMode _), _ -> VtQuery, VtLater) in static_control_classifier e diff --git a/stm/vio_checking.ml b/stm/vio_checking.ml index 64f19e1fd9..69c1d9bd23 100644 --- a/stm/vio_checking.ml +++ b/stm/vio_checking.ml @@ -95,6 +95,7 @@ let schedule_vio_checking j fs = done; let pid, ret = Unix.wait () in if ret <> Unix.WEXITED 0 then rc := 1; + Worker.kill (Pool.find pid !pool); pool := Pool.remove pid !pool; done; exit !rc @@ -124,6 +125,7 @@ let schedule_vio_compilation j fs = | s :: rest -> s :: filter_argv b rest in let prog = Sys.argv.(0) in let stdargs = filter_argv false (List.tl (Array.to_list Sys.argv)) in + let all_jobs = !jobs in let make_job () = let f, t = List.hd !jobs in jobs := List.tl !jobs; @@ -137,8 +139,15 @@ let schedule_vio_compilation j fs = done; let pid, ret = Unix.wait () in if ret <> Unix.WEXITED 0 then rc := 1; + Worker.kill (Pool.find pid !pool); pool := Pool.remove pid !pool; done; + if !rc = 0 then begin + (* set the access and last modification time of all files to the same t + * not to confuse make into thinking that some of them are outdated *) + let t = Unix.gettimeofday () in + List.iter (fun (f,_) -> Unix.utimes (f^".vo") t t) all_jobs; + end; exit !rc diff --git a/stm/workerPool.ml b/stm/workerPool.ml index 0ff66686e4..2432e72c8a 100644 --- a/stm/workerPool.ml +++ b/stm/workerPool.ml @@ -86,7 +86,7 @@ let rec create_worker extra pool id = let exit () = cancel := true; cleanup pool; Thread.exit () in let cancelled () = !cancel in let cpanel = { exit; cancelled; extra } in - let manager = Thread.create (Model.manager cpanel) worker in + let manager = CThread.create (Model.manager cpanel) worker in { name; cancel; manager; process } and cleanup x = locking x begin fun { workers; count; extra_arg } -> diff --git a/tactics/auto.ml b/tactics/auto.ml index f5c3619e64..2619620eb8 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -215,11 +215,15 @@ let tclLOG (dbg,_,depth,trace) pp tac = let s = String.make (depth+1) '*' in Proofview.(tclIFCATCH ( tac >>= fun v -> - Feedback.msg_debug (str s ++ spc () ++ pp () ++ str ". (*success*)"); + tclENV >>= fun env -> + tclEVARMAP >>= fun sigma -> + Feedback.msg_debug (str s ++ spc () ++ pp env sigma ++ str ". (*success*)"); tclUNIT v - ) Proofview.tclUNIT + ) tclUNIT (fun (exn, info) -> - Feedback.msg_debug (str s ++ spc () ++ pp () ++ str ". (*fail*)"); + tclENV >>= fun env -> + tclEVARMAP >>= fun sigma -> + Feedback.msg_debug (str s ++ spc () ++ pp env sigma ++ str ". (*fail*)"); tclZERO ~info exn)) | Info -> (* For "info (trivial/auto)", we store a log trace *) @@ -248,12 +252,12 @@ and erase_subtree depth = function | [] -> [] | (d,_) :: l -> if Int.equal d depth then l else erase_subtree depth l -let pr_info_atom (d,pp) = - str (String.make d ' ') ++ pp () ++ str "." +let pr_info_atom env sigma (d,pp) = + str (String.make d ' ') ++ pp env sigma ++ str "." -let pr_info_trace = function +let pr_info_trace env sigma = function | (Info,_,_,{contents=(d,Some pp)::l}) -> - Feedback.msg_info (prlist_with_sep fnl pr_info_atom (cleanup_info_trace d [(d,pp)] l)) + Feedback.msg_info (prlist_with_sep fnl (pr_info_atom env sigma) (cleanup_info_trace d [(d,pp)] l)) | _ -> () let pr_info_nop = function @@ -269,8 +273,12 @@ let pr_dbg_header = function let tclTRY_dbg d tac = let delay f = Proofview.tclUNIT () >>= fun () -> f () in - let tac = delay (fun () -> pr_dbg_header d; tac) >>= - fun () -> pr_info_trace d; Proofview.tclUNIT () in + let tac = + delay (fun () -> pr_dbg_header d; tac) >>= fun () -> + Proofview.tclENV >>= fun env -> + Proofview.tclEVARMAP >>= fun sigma -> + pr_info_trace env sigma d; + Proofview.tclUNIT () in let after = delay (fun () -> pr_info_nop d; Proofview.tclUNIT ()) in Tacticals.New.tclORELSE0 tac after @@ -300,8 +308,8 @@ let exists_evaluable_reference env = function | EvalConstRef _ -> true | EvalVarRef v -> try ignore(lookup_named v env); true with Not_found -> false -let dbg_intro dbg = tclLOG dbg (fun () -> str "intro") intro -let dbg_assumption dbg = tclLOG dbg (fun () -> str "assumption") assumption +let dbg_intro dbg = tclLOG dbg (fun _ _ -> str "intro") intro +let dbg_assumption dbg = tclLOG dbg (fun _ _ -> str "assumption") assumption let rec trivial_fail_db dbg mod_delta db_list local_db = let intro_tac = @@ -385,12 +393,11 @@ and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly;db= | Extern tacast -> conclPattern concl p tacast in - let pr_hint () = + let pr_hint env sigma = let origin = match dbname with | None -> mt () | Some n -> str " (in " ++ str n ++ str ")" in - let sigma, env = Pfedit.get_current_context () in pr_hint env sigma t ++ origin in tclLOG dbg pr_hint (run_hint t tactic) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index b1f2ceee57..070b2356e5 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -98,7 +98,7 @@ let use_bracketing_last_or_and_intro_pattern () = let () = declare_bool_option - { optdepr = false; + { optdepr = true; optname = "bracketing last or-and introduction pattern"; optkey = ["Bracketing";"Last";"Introduction";"Pattern"]; optread = (fun () -> !bracketing_last_or_and_intro_pattern); @@ -891,10 +891,6 @@ let reduce redexp cl = let pr = (pr_econstr_env, pr_leconstr_env, pr_evaluable_reference, pr_constr_pattern_env) in Pp.(hov 2 (Ppred.pr_red_expr_env env sigma pr str redexp)) in - let trace () = - let sigma, env = Pfedit.get_current_context () in - trace env sigma - in Proofview.Trace.name_tactic trace begin Proofview.Goal.enter begin fun gl -> let cl' = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cl in diff --git a/test-suite/Makefile b/test-suite/Makefile index 34a1900bbc..111bd52a33 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -36,15 +36,17 @@ include ../Makefile.common # easily overridden LIB := .. BIN := $(shell cd ..; pwd)/bin/ +COQFLAGS?= -coqtop := $(BIN)coqtop -coqlib $(LIB) -boot -q -batch -test-mode -R prerequisite TestSuite -coqc := $(BIN)coqc -coqlib $(LIB) -R prerequisite TestSuite +coqc_boot := $(BIN)coqc -coqlib $(LIB) -boot -q -test-mode -R prerequisite TestSuite $(COQFLAGS) +coqc := $(BIN)coqc -coqlib $(LIB) -R prerequisite TestSuite $(COQFLAGS) coqchk := $(BIN)coqchk -coqlib $(LIB) -R prerequisite TestSuite coqdoc := $(BIN)coqdoc +coqtop := $(BIN)coqtop -batch -coqlib $(LIB) -boot -q -test-mode -R prerequisite TestSuite coqtopbyte := $(BIN)coqtop.byte -coqtopload := $(coqtop) -async-proofs-cache force -load-vernac-source -coqtopcompile := $(coqtop) -async-proofs-cache force -compile +coqc_interactive := $(coqc) -async-proofs-cache force +coqc_boot_interactive := $(coqc_boot) -async-proofs-cache force coqdep := $(BIN)coqdep -coqlib $(LIB) VERBOSE?= @@ -59,12 +61,8 @@ SINGLE_QUOTE=" #" # double up on the quotes, in a comment, to appease the emacs syntax highlighter # wrap the arguments in parens, but only if they exist get_coq_prog_args_in_parens = $(subst $(SINGLE_QUOTE),,$(if $(call get_coq_prog_args,$(1)), ($(call get_coq_prog_args,$(1))))) -# get the command to use with this set of arguments; if there's -compile, use coqc, else use coqtop -has_profile_ltac_or_compile_flag = $(filter "-profile-ltac-cutoff" "-profile-ltac" "-compile",$(call get_coq_prog_args,$(1))) -get_command_based_on_flags = $(if $(call has_profile_ltac_or_compile_flag,$(1)),$(coqtopcompile),$(coqtopload)) get_set_impredicativity= $(filter "-impredicative-set",$(call get_coq_prog_args,$(1))) - bogomips:= ifneq (,$(wildcard /proc/cpuinfo)) sedbogo := -e "s/bogomips.*: \([0-9]*\).*/\1/p" # i386, ppc @@ -208,7 +206,7 @@ $(addsuffix .log,$(wildcard bugs/opened/*.v)): %.v.log: %.v @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(coqtopcompile) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ + $(coqc) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...still active"; \ @@ -230,7 +228,7 @@ $(addsuffix .log,$(wildcard bugs/closed/*.v)): %.v.log: %.v @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(coqtopcompile) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ + $(coqc) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ @@ -296,7 +294,7 @@ $(addsuffix .log,$(wildcard prerequisite/*.v)): %.v.log: %.v @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(coqtopcompile) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ + $(coqc) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ if [ $$R != 0 ]; then \ echo $(log_failure); \ echo " $<...could not be prepared" ; \ @@ -315,7 +313,7 @@ $(addsuffix .log,$(wildcard ssr/*.v success/*.v micromega/*.v modules/*.v)): %.v $(HIDE){ \ opts="$(if $(findstring modules/,$<),-R modules Mods)"; \ echo $(call log_intro,$<); \ - $(coqtopcompile) "$<" $(call get_coq_prog_args,"$<") $$opts 2>&1; R=$$?; times; \ + $(coqc) "$<" $(call get_coq_prog_args,"$<") $$opts 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ @@ -341,7 +339,7 @@ $(addsuffix .log,$(wildcard stm/*.v)): %.v.log: %.v @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(coqtopcompile) "$<" $(call get_coq_prog_args,"$<") -async-proofs on \ + $(coqc) "$<" $(call get_coq_prog_args,"$<") -async-proofs on \ $$opts 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ @@ -366,7 +364,7 @@ $(addsuffix .log,$(wildcard failure/*.v)): %.v.log: %.v $(PREREQUISITELOG) @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(coqtopcompile) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ + $(coqc) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ @@ -391,7 +389,7 @@ $(addsuffix .log,$(wildcard output/*.v)): %.v.log: %.v %.out $(PREREQUISITELOG) $(HIDE){ \ echo $(call log_intro,$<); \ output=$*.out.real; \ - $(call get_command_based_on_flags,"$<") "$<" $(call get_coq_prog_args,"$<") 2>&1 \ + $(coqc_boot_interactive) "$<" $(call get_coq_prog_args,"$<") 2>&1 \ | grep -v "Welcome to Coq" \ | grep -v "\[Loading ML file" \ | grep -v "Skipping rcfile loading" \ @@ -430,7 +428,7 @@ $(addsuffix .log,$(wildcard output-modulo-time/*.v)): %.v.log: %.v %.out echo $(call log_intro,$<); \ tmpoutput=`mktemp /tmp/coqcheck.XXXXXX`; \ tmpexpected=`mktemp /tmp/coqcheck.XXXXXX`; \ - $(call get_command_based_on_flags,"$<") "$<" $(call get_coq_prog_args,"$<") 2>&1 \ + $(coqc_boot_interactive) "$<" $(call get_coq_prog_args,"$<") 2>&1 \ | grep -v "Welcome to Coq" \ | grep -v "\[Loading ML file" \ | grep -v "Skipping rcfile loading" \ @@ -485,7 +483,7 @@ $(addsuffix .log,$(wildcard complexity/*.v)): %.v.log: %.v $(PREREQUISITELOG) $(HIDE){ \ echo $(call log_intro,$<); \ true "extract effective user time"; \ - res=`$(call get_command_based_on_flags,"$<") "$<" $(call get_coq_prog_args,"$<") 2>&1 | sed -n -e "s/Finished transaction in .*(\([0-9]*\.[0-9]*\)u.*)/\1/p" | head -1`; \ + res=`$(coqc_boot_interactive) "$<" $(call get_coq_prog_args,"$<") 2>&1 | sed -n -e "s/Finished transaction in .*(\([0-9]*\.[0-9]*\)u.*)/\1/p" | head -1`; \ R=$$?; times; \ if [ $$R != 0 ]; then \ echo $(log_failure); \ @@ -516,7 +514,7 @@ $(addsuffix .log,$(wildcard ideal-features/*.v)): %.v.log: %.v $(PREREQUISITELOG @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(coqtopcompile) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ + $(coqc) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ if [ $$R != 0 ]; then \ echo $(log_success); \ echo " $<...still wished"; \ @@ -530,7 +528,7 @@ $(addsuffix .log,$(wildcard ideal-features/*.v)): %.v.log: %.v $(PREREQUISITELOG # Additional dependencies for module tests $(addsuffix .log,$(wildcard modules/*.v)): %.v.log: modules/Nat.vo modules/plik.vo modules/%.vo: modules/%.v - $(HIDE)$(coqtop) -R modules Mods -compile $< + $(HIDE)$(coqc) -R modules Mods $< ####################################################################### # Miscellaneous tests @@ -549,7 +547,7 @@ $(patsubst %.sh,%.log,$(wildcard misc/*.sh)): %.log: %.sh $(PREREQUISITELOG) echo $(call log_intro,$<); \ export BIN="$(BIN)"; \ export coqc="$(coqc)"; \ - export coqtop="$(coqtop)"; \ + export coqtop="$(coqc_boot)"; \ export coqdep="$(coqdep)"; \ export coqtopbyte="$(coqtopbyte)"; \ "$<" 2>&1; R=$$?; times; \ @@ -590,7 +588,7 @@ vio: $(patsubst %.v,%.vio.log,$(wildcard vio/*.v)) @echo "TEST $<" $(HIDE){ \ $(coqc) -quick -R vio vio $* 2>&1 && \ - $(coqtop) -R vio vio -vio2vo $*.vio 2>&1 && \ + $(coqc) -R vio vio -vio2vo $*.vio 2>&1 && \ $(coqchk) -R vio vio -norec $(subst /,.,$*) 2>&1; \ if [ $$? = 0 ]; then \ echo $(log_success); \ diff --git a/test-suite/bugs/closed/HoTT_coq_056.v b/test-suite/bugs/closed/HoTT_coq_056.v index 3e3a987a7c..b80e0bb0e4 100644 --- a/test-suite/bugs/closed/HoTT_coq_056.v +++ b/test-suite/bugs/closed/HoTT_coq_056.v @@ -94,9 +94,9 @@ Definition FunctorApplicationOf {C D} F {argsT} args {T} {rtn} Global Arguments FunctorApplicationOf / {C} {D} F {argsT} args {T} {rtn} {_}. Global Instance FunctorApplicationDash C D (F : Functor C D) -: FunctorApplicationInterpretable F (IdentityFunctor C) F | 0. +: FunctorApplicationInterpretable F (IdentityFunctor C) F | 0 := {}. Global Instance FunctorApplicationFunctorFunctor' A B C C' D (F : Functor (A * B) D) (G : Functor C A) (H : Functor C' B) -: FunctorApplicationInterpretable F (G, H) (F ∘ (FunctorProduct' G H))%functor | 100. +: FunctorApplicationInterpretable F (G, H) (F ∘ (FunctorProduct' G H))%functor | 100 := {}. Notation "F ⟨ x ⟩" := (FunctorApplicationOf F%functor x%functor) : functor_scope. diff --git a/test-suite/bugs/closed/bug_2830.v b/test-suite/bugs/closed/bug_2830.v index 801c61b132..a321bb324e 100644 --- a/test-suite/bugs/closed/bug_2830.v +++ b/test-suite/bugs/closed/bug_2830.v @@ -194,14 +194,17 @@ Instance skel_equiv A : Equivalence (@skel A). Admitted. Import FunctionalExtensionality. -Instance set_cat : Category Type (fun A B => A -> B) := { + +Instance set_cat : Category Type (fun A B => A -> B). +refine {| id := fun A => fun x => x ; comp c b a f g := fun x => f (g x) ; eqv := fun A B => @skel (A -> B) -}. +|}. intros. compute. symmetry. apply eta_expansion. intros. compute. symmetry. apply eta_expansion. -intros. compute. reflexivity. Defined. +intros. compute. reflexivity. +Defined. (* The [list] type constructor is a Functor. *) diff --git a/test-suite/bugs/closed/bug_3324.v b/test-suite/bugs/closed/bug_3324.v index 45dbb57aa2..dae0d4c024 100644 --- a/test-suite/bugs/closed/bug_3324.v +++ b/test-suite/bugs/closed/bug_3324.v @@ -6,7 +6,7 @@ Module ETassi. Record hProp := hp { hproptype :> Type ; isp : IsHProp hproptype}. Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}. Canonical Structure default_HSet:= fun T P => (@BuildhSet T P). - Global Instance isset_hProp : IsHSet hProp | 0. + Global Instance isset_hProp : IsHSet hProp | 0 := {}. Check (eq_refl _ : setT (default_HSet _ _) = hProp). Check (eq_refl _ : setT _ = hProp). @@ -22,7 +22,7 @@ Module JGross. Definition Unit_hp:hProp:=(hp Unit admit). Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}. Canonical Structure default_HSet:= fun T P => (@BuildhSet T P). - Global Instance isset_hProp : IsHSet hProp | 0. + Global Instance isset_hProp : IsHSet hProp | 0 := {}. Definition isepi {X Y} `(f:X->Y) := forall Z: hSet, forall g h: Y -> Z, (fun x => g (f x)) = (fun x => h (f x)) -> g = h. Lemma isepi_issurj {X Y} (f:X->Y): isepi f -> True. diff --git a/test-suite/bugs/closed/bug_3454.v b/test-suite/bugs/closed/bug_3454.v index e4cd60cb24..0a01adec33 100644 --- a/test-suite/bugs/closed/bug_3454.v +++ b/test-suite/bugs/closed/bug_3454.v @@ -32,14 +32,14 @@ Local Instance isequiv_tgt_compose A B : @IsEquiv (A -> {xy : B * B & fst xy = snd xy}) (A -> B) (@compose A {xy : B * B & fst xy = snd xy} B - (@compose {xy : B * B & fst xy = snd xy} _ B (@snd B B) pr1)). + (@compose {xy : B * B & fst xy = snd xy} _ B (@snd B B) pr1)) := {}. (* Toplevel input, characters 220-223: *) (* Error: Cannot infer this placeholder. *) Local Instance isequiv_tgt_compose' A B : @IsEquiv (A -> {xy : B * B & fst xy = snd xy}) (A -> B) - (@compose A {xy : B * B & fst xy = snd xy} B (@compose {xy : B * B & fst xy = snd xy} _ B (@snd _ _) pr1)). + (@compose A {xy : B * B & fst xy = snd xy} B (@compose {xy : B * B & fst xy = snd xy} _ B (@snd _ _) pr1)) := {}. (* Toplevel input, characters 221-232: *) (* Error: *) (* In environment *) @@ -52,7 +52,7 @@ Local Instance isequiv_tgt_compose'' A B : @IsEquiv (A -> {xy : B * B & fst xy = snd xy}) (A -> B) (@compose A {xy : B * B & fst xy = snd xy} B (@compose {xy : B * B & fst xy = snd xy} _ B (@snd _ _) - (fun s => s.(projT1)))). + (fun s => s.(projT1)))) := {}. (* Toplevel input, characters 15-241: Error: Cannot infer an internal placeholder of type "Type" in environment: diff --git a/test-suite/bugs/closed/bug_3495.v b/test-suite/bugs/closed/bug_3495.v index 7b0883f910..47db64a096 100644 --- a/test-suite/bugs/closed/bug_3495.v +++ b/test-suite/bugs/closed/bug_3495.v @@ -1,7 +1,7 @@ Require Import RelationClasses. Axiom R : Prop -> Prop -> Prop. -Declare Instance : Reflexive R. +Declare Instance R_refl : Reflexive R. Class bar := { x : False }. Record foo := { a : Prop ; b : bar }. diff --git a/test-suite/bugs/closed/bug_3682.v b/test-suite/bugs/closed/bug_3682.v index 9d37d1a2d0..07b759afb5 100644 --- a/test-suite/bugs/closed/bug_3682.v +++ b/test-suite/bugs/closed/bug_3682.v @@ -1,6 +1,6 @@ Require Import TestSuite.admit. Class Foo. Definition bar `{Foo} (x : Set) := Set. -Instance: Foo. +Instance: Foo := {}. Definition bar1 := bar nat. Definition bar2 := bar ltac:(admit). diff --git a/test-suite/bugs/closed/bug_4498.v b/test-suite/bugs/closed/bug_4498.v index 379e46b3e3..9b3210860c 100644 --- a/test-suite/bugs/closed/bug_4498.v +++ b/test-suite/bugs/closed/bug_4498.v @@ -19,6 +19,6 @@ Class Category := { Require Export Coq.Setoids.Setoid. -Add Parametric Morphism `{C : Category} {A B C} : (@compose _ A B C) with +Add Parametric Morphism `{Category} {A B C} : (@compose _ A B C) with signature equiv ==> equiv ==> equiv as compose_mor. Proof. apply comp_respects. Qed. diff --git a/test-suite/bugs/opened/bug_4781.v b/test-suite/bugs/closed/bug_4781.v index 8b651ac22e..464a3de1b3 100644 --- a/test-suite/bugs/opened/bug_4781.v +++ b/test-suite/bugs/closed/bug_4781.v @@ -25,29 +25,29 @@ Goal True. let x := match constr:(Set) with ?y => constr:(y) end in pose x. (* This fails with an error: *) - Fail let term := constr:(I) in + let term := constr:(I) in let T := type of term in let x := constr:((_ : abstract_term term) : T) in let x := match constr:(x) with ?y => constr:(y) end in pose x. (* The command has indeed failed with message: Error: Variable y should be bound to a term. *) (* And the rest fail with Anomaly: Uncaught exception Not_found. Please report. *) - Fail let term := constr:(I) in + let term := constr:(I) in let T := type of term in let x := constr:((_ : abstract_term term) : T) in let x := match constr:(x) with ?y => y end in pose x. - Fail let term := constr:(I) in + let term := constr:(I) in let T := type of term in let x := constr:((_ : abstract_term term) : T) in let x := (eval cbv iota in x) in pose x. - Fail let term := constr:(I) in + let term := constr:(I) in let T := type of term in let x := constr:((_ : abstract_term term) : T) in let x := type of x in pose x. (* should succeed *) - Fail let term := constr:(I) in + let term := constr:(I) in let T := type of term in let x := constr:(_ : abstract_term term) in let x := type of x in @@ -70,7 +70,7 @@ Even stranger, consider:*) (*This works fine. But if I change the period to a semicolon, I get:*) - Fail let term := constr:(I) in + let term := constr:(I) in let T := type of term in let x := constr:((_ : abstract_term term) : T) in let y := (eval cbv iota in (let v : T := x in v)) in @@ -82,7 +82,7 @@ Even stranger, consider:*) (* should succeed *) (*and if I use the second one instead of [pose x] (note that using [idtac] works fine), I get:*) - Fail let term := constr:(I) in + let term := constr:(I) in let T := type of term in let x := constr:((_ : abstract_term term) : T) in let y := (eval cbv iota in (let v : T := x in v)) in @@ -92,3 +92,5 @@ Even stranger, consider:*) let x := (eval cbv delta [x'] in x') in let z := (eval cbv iota in x) in (* Error: Variable x should be bound to a term. *) idtac. (* should succeed *) + exact I. +Qed. diff --git a/test-suite/bugs/closed/bug_4782.v b/test-suite/bugs/closed/bug_4782.v index be17a96f15..c08195d502 100644 --- a/test-suite/bugs/closed/bug_4782.v +++ b/test-suite/bugs/closed/bug_4782.v @@ -15,8 +15,8 @@ Record T := { dom : Type }. Definition pairT A B := {| dom := (dom A * dom B)%type |}. Class C (A:Type). Parameter B:T. -Instance c (A:T) : C (dom A). -Instance cn : C (dom B). +Instance c (A:T) : C (dom A) := {}. +Instance cn : C (dom B) := {}. Parameter F : forall A:T, C (dom A) -> forall x:dom A, x=x -> A = A. Set Typeclasses Debug. Goal forall (A:T) (x:dom A), pairT A A = pairT A A. diff --git a/test-suite/bugs/closed/bug_4798.v b/test-suite/bugs/closed/bug_4798.v index 41a1251ca5..696812dee1 100644 --- a/test-suite/bugs/closed/bug_4798.v +++ b/test-suite/bugs/closed/bug_4798.v @@ -1,3 +1,5 @@ +(* DO NOT MODIFY THIS FILE DIRECTLY *) +(* It is autogenerated by dev/tools/update-compat.py. *) Check match 2 with 0 => 0 | S n => n end. Notation "|" := 1 (compat "8.7"). Check match 2 with 0 => 0 | S n => n end. (* fails *) diff --git a/test-suite/bugs/closed/bug_4836.v b/test-suite/bugs/closed/bug_4836.v index 5838dcd8a7..9aefb10172 100644 --- a/test-suite/bugs/closed/bug_4836.v +++ b/test-suite/bugs/closed/bug_4836.v @@ -1 +1 @@ -(* -*- coq-prog-args: ("-compile" "bugs/closed/PLACEHOLDER.v") -*- *) +(* -*- coq-prog-args: ("bugs/closed/PLACEHOLDER.v") -*- *) diff --git a/test-suite/bugs/closed/bug_5401.v b/test-suite/bugs/closed/bug_5401.v index 95193b993b..466e669d00 100644 --- a/test-suite/bugs/closed/bug_5401.v +++ b/test-suite/bugs/closed/bug_5401.v @@ -5,7 +5,7 @@ Parameter P : nat -> Type. Parameter v : forall m, P m. Parameter f : forall (P : nat -> Type), (forall a, P a) -> P 0. Class U (R : P 0) (m : forall x, P x) : Prop. -Instance w : U (f _ (fun _ => v _)) v. +Instance w : U (f _ (fun _ => v _)) v := {}. Print HintDb typeclass_instances. End A. diff --git a/test-suite/bugs/closed/bug_7811.v b/test-suite/bugs/closed/bug_7811.v index fee330f22d..155f3285b7 100644 --- a/test-suite/bugs/closed/bug_7811.v +++ b/test-suite/bugs/closed/bug_7811.v @@ -1,4 +1,4 @@ -(* -*- mode: coq; coq-prog-args: ("-emacs" "-top" "atomic" "-Q" "." "iris" "-R" "." "stdpp") -*- *) +(* -*- mode: coq; coq-prog-args: ("-top" "atomic" "-Q" "." "iris" "-R" "." "stdpp") -*- *) (* File reduced by coq-bug-finder from original input, then from 140 lines to 26 lines, then from 141 lines to 27 lines, then from 142 lines to 27 lines, then from 272 lines to 61 lines, then from 291 lines to 94 lines, then from 678 lines to 142 lines, then from 418 lines to 161 lines, then from 538 lines to 189 lines, then from 840 lines to 493 lines, then from 751 lines to 567 lines, then from 913 lines to 649 lines, then from 875 lines to 666 lines, then from 784 lines to 568 lines, then from 655 lines to 173 lines, then from 317 lines to 94 lines, then from 172 lines to 86 lines, then from 102 lines to 86 lines, then from 130 lines to 86 lines, then from 332 lines to 112 lines, then from 279 lines to 111 lines, then from 3996 lines to 5697 lines, then from 153 lines to 117 lines, then from 146 lines to 108 lines, then from 124 lines to 108 lines *) (* coqc version 8.8.0 (May 2018) compiled on May 2 2018 16:49:46 with OCaml 4.02.3 coqtop version 8.8.0 (May 2018) *) diff --git a/test-suite/bugs/closed/bug_7904.v b/test-suite/bugs/closed/bug_7904.v new file mode 100644 index 0000000000..1e518e2adf --- /dev/null +++ b/test-suite/bugs/closed/bug_7904.v @@ -0,0 +1,13 @@ + + +Class abstract_term {T} (x : T) := by_abstract_term : T. +Hint Extern 0 (@abstract_term ?T ?x) => change T; abstract (exact x) : typeclass_instances. + +Goal True. + let term := constr:(I) in + let T := type of term in + let x := constr:((_ : abstract_term term) : T) in + let x := match constr:(x) with ?y => y end in + pose x as v. (* was Error: Variable x should be bound to a term but is bound to a constr. *) + exact v. +Qed. diff --git a/test-suite/bugs/closed/bug_8369.v b/test-suite/bugs/closed/bug_8369.v new file mode 100644 index 0000000000..9816954d0c --- /dev/null +++ b/test-suite/bugs/closed/bug_8369.v @@ -0,0 +1,3 @@ +(* Was failing in master with a not_found generated by the printer *) + +Fail Definition foo := fun '(u, v) p2 => (u, v). diff --git a/test-suite/bugs/closed/bug_9166.v b/test-suite/bugs/closed/bug_9166.v index 8a7e9c37b0..a89837dd12 100644 --- a/test-suite/bugs/closed/bug_9166.v +++ b/test-suite/bugs/closed/bug_9166.v @@ -1,3 +1,5 @@ +(* DO NOT MODIFY THIS FILE DIRECTLY *) +(* It is autogenerated by dev/tools/update-compat.py. *) Set Warnings "+deprecated". Notation bar := option (compat "8.7"). diff --git a/test-suite/bugs/closed/bug_9229.v b/test-suite/bugs/closed/bug_9229.v new file mode 100644 index 0000000000..7514741af4 --- /dev/null +++ b/test-suite/bugs/closed/bug_9229.v @@ -0,0 +1,6 @@ +(* There was a problem of freshness with Infix choice of vars *) + +(* In particular, x and y were special... *) + +Infix "#" := (fun x y => x + y) (at level 50, left associativity). +Check (3 # 5). diff --git a/test-suite/bugs/closed/bug_9240.v b/test-suite/bugs/closed/bug_9240.v new file mode 100644 index 0000000000..e0901dc2d9 --- /dev/null +++ b/test-suite/bugs/closed/bug_9240.v @@ -0,0 +1,12 @@ +Register unit as core.IDProp.type. +Register tt as core.IDProp.idProp. + + +Inductive vec (A : Type) : nat -> Type := +| nil : vec A 0 +| cons : forall n : nat, A -> vec A n -> vec A (S n). + +Definition hd (A : Type) (n : nat) (v : vec A (S n)) : A := +match v in (vec _ (S n)) return A with +| cons _ _ h _ => h +end. (* assertion failure in evarconv *) diff --git a/test-suite/bugs/closed/bug_9300.v b/test-suite/bugs/closed/bug_9300.v new file mode 100644 index 0000000000..a80f3233a3 --- /dev/null +++ b/test-suite/bugs/closed/bug_9300.v @@ -0,0 +1,6 @@ +Existing Class True. + +Instance foo {n : nat} (x := I) : forall {b : bool} (s : nat * nat), True. auto. Defined. + +Fail Check foo (n := 3) true (s := (4 , 5)). +Check foo (n := 3) (b := true) (4 , 5). diff --git a/test-suite/bugs/closed/bug_9329.v b/test-suite/bugs/closed/bug_9329.v new file mode 100644 index 0000000000..c0322dec40 --- /dev/null +++ b/test-suite/bugs/closed/bug_9329.v @@ -0,0 +1,12 @@ +(* Declare empty levels in the same order they are computed *) + +Notation "< a ; b ; c >1" := + (sum a (sum b c)) (at level 18, a at level 19, b at level 20, c at level 21). +Notation "< a ; b ; c >2" := + (sum a (sum b c)) (at level 28, a at level 29, c at level 32, b at level 31). +Notation "< a ; b ; c >3" := + (sum a (sum b c)) (at level 38, c at level 42, a at level 39, b at level 41). +Notation "< a ; b ; c >4" := + (sum a (sum b c)) (at level 48, c at level 52, b at level 51, a at level 49). +Notation "< a ; b >" := + (sum a b) (at level 61, a at level 63, b at level 62). diff --git a/test-suite/bugs/closed/bug_9375.v b/test-suite/bugs/closed/bug_9375.v new file mode 100644 index 0000000000..a2bfbafe06 --- /dev/null +++ b/test-suite/bugs/closed/bug_9375.v @@ -0,0 +1,16 @@ +Set Primitive Projections. + +Record toto : Type := Toto { + toto1 : Type; + toto2 : toto1 -> Type +}. + +Record tata := Tata { + tata1 : Type +}. + +Canonical Structure tata_toto (x : toto) X := + Tata (toto2 x X). + +Check fun (T : toto) (t : toto1 T) => + (eq_refl _ : @tata1 _ = @toto2 _ t). diff --git a/test-suite/bugs/opened/bug_3166.v b/test-suite/bugs/opened/bug_3166.v index e1c29a954c..baf87631f0 100644 --- a/test-suite/bugs/opened/bug_3166.v +++ b/test-suite/bugs/opened/bug_3166.v @@ -81,3 +81,4 @@ Goal forall T (x y : T) (p : x = y), True. compute in H0. change (fun (x' : T) (_ : y = x') => x' = y) with ((fun y => fun (x' : T) (_ : y = x') => x' = y) y) in H0. Fail pose proof (fun k => @eq_trans _ _ _ k H0). +Abort. diff --git a/test-suite/bugs/opened/bug_3754.v b/test-suite/bugs/opened/bug_3754.v index a717bbe735..18820b1a4c 100644 --- a/test-suite/bugs/opened/bug_3754.v +++ b/test-suite/bugs/opened/bug_3754.v @@ -282,3 +282,4 @@ Defined. rewrite <- ap_p_pp; rewrite_moveL_Mp_p. Set Debug Tactic Unification. Fail rewrite (concat_Ap ff2). + Abort. diff --git a/test-suite/bugs/opened/bug_3890.v b/test-suite/bugs/opened/bug_3890.v index 5c74addb62..9d83743b2a 100644 --- a/test-suite/bugs/opened/bug_3890.v +++ b/test-suite/bugs/opened/bug_3890.v @@ -1,7 +1,11 @@ +Set Nested Proofs Allowed. + Class Foo. Class Bar := b : Type. +Set Refine Instance Mode. Instance foo : Foo := _. +Unset Refine Instance Mode. (* 1 subgoals, subgoal 1 (ID 4) ============================ diff --git a/test-suite/bugs/opened/bug_3938.v b/test-suite/bugs/opened/bug_3938.v index 2d0d1930f1..3c7c945ed8 100644 --- a/test-suite/bugs/opened/bug_3938.v +++ b/test-suite/bugs/opened/bug_3938.v @@ -4,3 +4,4 @@ Goal forall a b (f : nat -> Set), Nat.eq a b -> f a = f b. intros a b f H. rewrite H. (* Toplevel input, characters 15-25: Anomaly: Evar ?X11 was not declared. Please report. *) +Abort. diff --git a/test-suite/complexity/constructor.v b/test-suite/complexity/constructor.v index c5e1953829..31217ca75e 100644 --- a/test-suite/complexity/constructor.v +++ b/test-suite/complexity/constructor.v @@ -214,3 +214,4 @@ Fixpoint expand (n : nat) : Prop := Example Expand : expand 2500. Time constructor. (* ~0.45 secs *) +Qed. diff --git a/test-suite/complexity/f_equal.v b/test-suite/complexity/f_equal.v index 86698fa872..c2c566930b 100644 --- a/test-suite/complexity/f_equal.v +++ b/test-suite/complexity/f_equal.v @@ -12,3 +12,4 @@ end. Goal stupid 23 = stupid 23. Timeout 5 Time f_equal. +Abort. diff --git a/test-suite/complexity/injection.v b/test-suite/complexity/injection.v index a76fa19d3c..298a07c1c4 100644 --- a/test-suite/complexity/injection.v +++ b/test-suite/complexity/injection.v @@ -111,3 +111,4 @@ Lemma test: forall n1 w1 n2 w2, mk_world n1 w1 = mk_world n2 w2 -> Proof. intros. Timeout 10 Time injection H. +Abort. diff --git a/test-suite/complexity/ring.v b/test-suite/complexity/ring.v index 51f7c4dabc..2d585ce5c5 100644 --- a/test-suite/complexity/ring.v +++ b/test-suite/complexity/ring.v @@ -5,3 +5,4 @@ Require Import ZArith. Open Scope Z_scope. Goal forall a, a+a+a+a+a+a+a+a+a+a+a+a+a = a*13. Timeout 5 Time intro; ring. +Abort. diff --git a/test-suite/complexity/ring2.v b/test-suite/complexity/ring2.v index 04fa59075b..1c119b8e42 100644 --- a/test-suite/complexity/ring2.v +++ b/test-suite/complexity/ring2.v @@ -50,3 +50,4 @@ Infix "+" := Zadd : Z_scope. Goal forall a, a+a+a+a+a+a+a+a+a+a+a+a+a = a*13. Timeout 5 Time intro; ring. +Abort. diff --git a/test-suite/complexity/setoid_rewrite.v b/test-suite/complexity/setoid_rewrite.v index 2e3b006ef0..10b270ccad 100644 --- a/test-suite/complexity/setoid_rewrite.v +++ b/test-suite/complexity/setoid_rewrite.v @@ -8,3 +8,4 @@ Variable f : nat -> Prop. Goal forall U:Prop, f 100 <-> U. intros U. Timeout 5 Time setoid_replace U with False. +Abort. diff --git a/test-suite/complexity/unification.v b/test-suite/complexity/unification.v index d2ea527516..0c9915c84e 100644 --- a/test-suite/complexity/unification.v +++ b/test-suite/complexity/unification.v @@ -49,3 +49,4 @@ Goal )))) . Timeout 2 Time try refine (refl_equal _). +Abort. diff --git a/test-suite/ide/debug_ltac.fake b/test-suite/ide/debug_ltac.fake new file mode 100644 index 0000000000..aa68fad39e --- /dev/null +++ b/test-suite/ide/debug_ltac.fake @@ -0,0 +1,2 @@ +FAILADD { Debug On. } +ADD { Set Debug On. } diff --git a/test-suite/misc/4722.sh b/test-suite/misc/4722.sh index 86bc50b5cd..70071b9d60 100755 --- a/test-suite/misc/4722.sh +++ b/test-suite/misc/4722.sh @@ -4,12 +4,12 @@ set -e # create test files mkdir -p misc/4722 ln -sf toto misc/4722/tata -touch misc/4722.v +touch misc/bug_4722.v # run test -$coqtop "-R" "misc/4722" "Foo" -top Top -load-vernac-source misc/4722.v +$coqc "-R" "misc/4722" "Foo" -top Top misc/bug_4722.v # clean up test files rm misc/4722/tata rmdir misc/4722 -rm misc/4722.v +rm misc/bug_4722.v diff --git a/test-suite/misc/7704.sh b/test-suite/misc/7704.sh index 0ca2c97d24..5fc171649e 100755 --- a/test-suite/misc/7704.sh +++ b/test-suite/misc/7704.sh @@ -4,4 +4,4 @@ set -e export PATH=$BIN:$PATH -${coqtop#"$BIN"} -compile misc/aux7704.v +${coqc#"$BIN"} misc/aux7704.v diff --git a/test-suite/misc/aux7704.v b/test-suite/misc/aux7704.v index 6fdcf67684..1c95211a71 100644 --- a/test-suite/misc/aux7704.v +++ b/test-suite/misc/aux7704.v @@ -1,4 +1,3 @@ - Goal True /\ True. Proof. split. diff --git a/test-suite/misc/deps-checksum.sh b/test-suite/misc/deps-checksum.sh index a15a8fbee9..8523358303 100755 --- a/test-suite/misc/deps-checksum.sh +++ b/test-suite/misc/deps-checksum.sh @@ -3,4 +3,4 @@ rm -f misc/deps/A/*.vo misc/deps/B/*.vo $coqc -R misc/deps/A A misc/deps/A/A.v $coqc -R misc/deps/B A misc/deps/B/A.v $coqc -R misc/deps/B A misc/deps/B/B.v -$coqtop -R misc/deps/B A -R misc/deps/A A -load-vernac-source misc/deps/checksum.v +$coqc -R misc/deps/B A -R misc/deps/A A misc/deps/checksum.v diff --git a/test-suite/misc/deps-order.sh b/test-suite/misc/deps-order.sh index 6bb2ba2da0..551515b0d6 100755 --- a/test-suite/misc/deps-order.sh +++ b/test-suite/misc/deps-order.sh @@ -10,12 +10,12 @@ R=$? times $coqc -R misc/deps/lib lib misc/deps/lib/foo.v 2>&1 $coqc -R misc/deps/lib lib -R misc/deps/client client misc/deps/client/foo.v 2>&1 -$coqtop -R misc/deps/lib lib -R misc/deps/client client -load-vernac-source misc/deps/client/bar.v 2>&1 +$coqc -R misc/deps/lib lib -R misc/deps/client client misc/deps/client/bar.v 2>&1 S=$? if [ $R = 0 ] && [ $S = 0 ]; then - printf "coqdep and coqtop agree\n" + printf "coqdep and coqc agree\n" exit 0 else - printf "coqdep and coqtop disagree\n" + printf "coqdep and coqc disagree\n" exit 1 fi diff --git a/test-suite/misc/deps-utf8.sh b/test-suite/misc/deps-utf8.sh index acb45b2292..af69370ce4 100755 --- a/test-suite/misc/deps-utf8.sh +++ b/test-suite/misc/deps-utf8.sh @@ -8,7 +8,7 @@ rm -f misc/deps/théorèmes/*.v tmpoutput=$(mktemp /tmp/coqcheck.XXXXXX) $coqc -R misc/deps AlphaBêta misc/deps/αβ/γδ.v R=$? -$coqtop -R misc/deps AlphaBêta -load-vernac-source misc/deps/αβ/εζ.v +$coqc -R misc/deps AlphaBêta misc/deps/αβ/εζ.v S=$? if [ $R = 0 ] && [ $S = 0 ]; then exit 0 diff --git a/test-suite/output-modulo-time/ltacprof_cutoff.v b/test-suite/output-modulo-time/ltacprof_cutoff.v index ae5d51bae8..b7c98aa134 100644 --- a/test-suite/output-modulo-time/ltacprof_cutoff.v +++ b/test-suite/output-modulo-time/ltacprof_cutoff.v @@ -1,4 +1,4 @@ -(* -*- coq-prog-args: ("-profile-ltac") -*- *) +(* -*- coq-prog-args: ("-async-proofs" "off" "-profile-ltac") -*- *) Require Coq.ZArith.BinInt. Module WithIdTac. Ltac sleep := do 50 (idtac; let sleep := (eval vm_compute in Coq.ZArith.BinInt.Z.div_eucl) in idtac). diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out index b071da86c9..ba4bc070c6 100644 --- a/test-suite/output/Arguments_renaming.out +++ b/test-suite/output/Arguments_renaming.out @@ -11,7 +11,7 @@ eq_refl : ?y = ?y where ?y : [ |- nat] -Monomorphic Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x +Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x For eq_refl: Arguments are renamed to B, y For eq: Argument A is implicit and maximally inserted @@ -31,8 +31,7 @@ When applied to 1 argument: Argument B is implicit Argument scopes are [type_scope _] Expands to: Constructor Coq.Init.Logic.eq_refl -Monomorphic Inductive myEq (B : Type) (x : A) : A -> Prop := - myrefl : B -> myEq B x x +Inductive myEq (B : Type) (x : A) : A -> Prop := myrefl : B -> myEq B x x For myrefl: Arguments are renamed to C, x, _ For myrefl: Argument C is implicit and maximally inserted @@ -45,7 +44,7 @@ Arguments are renamed to C, x, _ Argument C is implicit and maximally inserted Argument scopes are [type_scope _ _] Expands to: Constructor Arguments_renaming.Test1.myrefl -Monomorphic myplus = +myplus = fix myplus (T : Type) (t : T) (n m : nat) {struct n} : nat := match n with | 0 => m @@ -53,7 +52,6 @@ fix myplus (T : Type) (t : T) (n m : nat) {struct n} : nat := end : forall T : Type, T -> nat -> nat -> nat -myplus is not universe polymorphic Arguments are renamed to Z, t, n, m Argument Z is implicit and maximally inserted Argument scopes are [type_scope _ nat_scope nat_scope] @@ -69,7 +67,7 @@ myplus is transparent Expands to: Constant Arguments_renaming.Test1.myplus @myplus : forall Z : Type, Z -> nat -> nat -> nat -Monomorphic Inductive myEq (A B : Type) (x : A) : A -> Prop := +Inductive myEq (A B : Type) (x : A) : A -> Prop := myrefl : B -> myEq A B x x For myrefl: Arguments are renamed to A, C, x, _ @@ -85,7 +83,7 @@ Argument scopes are [type_scope type_scope _ _] Expands to: Constructor Arguments_renaming.myrefl myrefl : forall (A C : Type) (x : A), C -> myEq A C x x -Monomorphic myplus = +myplus = fix myplus (T : Type) (t : T) (n m : nat) {struct n} : nat := match n with | 0 => m @@ -93,7 +91,6 @@ fix myplus (T : Type) (t : T) (n m : nat) {struct n} : nat := end : forall T : Type, T -> nat -> nat -> nat -myplus is not universe polymorphic Arguments are renamed to Z, t, n, m Argument Z is implicit and maximally inserted Argument scopes are [type_scope _ nat_scope nat_scope] diff --git a/test-suite/output/Binder.out b/test-suite/output/Binder.out index 9c46ace463..34558e9a6b 100644 --- a/test-suite/output/Binder.out +++ b/test-suite/output/Binder.out @@ -1,12 +1,8 @@ -Monomorphic foo = fun '(x, y) => x + y +foo = fun '(x, y) => x + y : nat * nat -> nat - -foo is not universe polymorphic forall '(a, b), a /\ b : Prop -Monomorphic foo = λ '(x, y), x + y +foo = λ '(x, y), x + y : nat * nat → nat - -foo is not universe polymorphic ∀ '(a, b), a ∧ b : Prop diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out index 0a02c5a7dd..cb835ab48d 100644 --- a/test-suite/output/Cases.out +++ b/test-suite/output/Cases.out @@ -1,4 +1,4 @@ -Monomorphic t_rect = +t_rect = fun (P : t -> Type) (f : let x := t in forall x0 : x, P x0 -> P (k x0)) => fix F (t : t) : P t := match t as t0 return (P t0) with @@ -7,7 +7,6 @@ fix F (t : t) : P t := : forall P : t -> Type, (let x := t in forall x0 : x, P x0 -> P (k x0)) -> forall t : t, P t -t_rect is not universe polymorphic Argument scopes are [function_scope function_scope _] = fun d : TT => match d with | {| f3 := b |} => b @@ -17,7 +16,7 @@ Argument scopes are [function_scope function_scope _] | {| f3 := b |} => b end : TT -> 0 = 0 -Monomorphic proj = +proj = fun (x y : nat) (P : nat -> Type) (def : P x) (prf : P y) => match Nat.eq_dec x y with | left eqprf => match eqprf in (_ = z) return (P z) with @@ -27,9 +26,8 @@ match Nat.eq_dec x y with end : forall (x y : nat) (P : nat -> Type), P x -> P y -> P y -proj is not universe polymorphic Argument scopes are [nat_scope nat_scope function_scope _ _] -Monomorphic foo = +foo = fix foo (A : Type) (l : list A) {struct l} : option A := match l with | nil => None @@ -38,21 +36,17 @@ fix foo (A : Type) (l : list A) {struct l} : option A := end : forall A : Type, list A -> option A -foo is not universe polymorphic Argument scopes are [type_scope list_scope] -Monomorphic uncast = +uncast = fun (A : Type) (x : I A) => match x with | x0 <: _ => x0 end : forall A : Type, I A -> A -uncast is not universe polymorphic Argument scopes are [type_scope _] -Monomorphic foo' = if A 0 then true else false +foo' = if A 0 then true else false : bool - -foo' is not universe polymorphic -Monomorphic f = +f = fun H : B => match H with | AC x => @@ -62,8 +56,6 @@ match H with else fun _ : P false => Logic.I) x end : B -> True - -f is not universe polymorphic The command has indeed failed with message: Non exhaustive pattern-matching: no clause found for pattern gadtTy _ _ @@ -83,22 +75,17 @@ fun '(D n m p q) => n + m + p + q : J -> nat The command has indeed failed with message: The constructor D (in type J) expects 3 arguments. -Monomorphic lem1 = +lem1 = fun dd : nat * nat => let (bb, cc) as aa return (aa = aa) := dd in eq_refl : forall k : nat * nat, k = k - -lem1 is not universe polymorphic -Monomorphic lem2 = +lem2 = fun dd : bool => if dd as aa return (aa = aa) then eq_refl else eq_refl : forall k : bool, k = k -lem2 is not universe polymorphic Argument scope is [bool_scope] -Monomorphic lem3 = +lem3 = fun dd : nat * nat => let (bb, cc) as aa return (aa = aa) := dd in eq_refl : forall k : nat * nat, k = k - -lem3 is not universe polymorphic 1 subgoal x : nat diff --git a/test-suite/output/Cases.v b/test-suite/output/Cases.v index 43718a0f07..4e949dcb04 100644 --- a/test-suite/output/Cases.v +++ b/test-suite/output/Cases.v @@ -43,6 +43,7 @@ Print foo. (* Accept and use notation with binded parameters *) +#[universes(template)] Inductive I (A: Type) : Type := C : A -> I A. Notation "x <: T" := (C T x) (at level 38). @@ -83,6 +84,7 @@ Print f. (* Was enhancement request #5142 (error message reported on the most general return clause heuristic) *) +#[universes(template)] Inductive gadt : Type -> Type := | gadtNat : nat -> gadt nat | gadtTy : forall T, T -> gadt T. diff --git a/test-suite/output/Coercions.v b/test-suite/output/Coercions.v index 0e84bf3966..6976f35a88 100644 --- a/test-suite/output/Coercions.v +++ b/test-suite/output/Coercions.v @@ -1,7 +1,7 @@ (* Submitted by Randy Pollack *) -Record pred (S : Set) : Type := {sp_pred :> S -> Prop}. -Record rel (S : Set) : Type := {sr_rel :> S -> S -> Prop}. +#[universes(template)] Record pred (S : Set) : Type := {sp_pred :> S -> Prop}. +#[universes(template)] Record rel (S : Set) : Type := {sr_rel :> S -> S -> Prop}. Section testSection. Variables (S : Set) (P : pred S) (R : rel S) (x : S). diff --git a/test-suite/output/Errors.out b/test-suite/output/Errors.out index cf2d5b2850..14c48e8fa0 100644 --- a/test-suite/output/Errors.out +++ b/test-suite/output/Errors.out @@ -9,10 +9,11 @@ The command has indeed failed with message: Ltac call to "instantiate ( (ident) := (lglob) )" failed. Instance is not well-typed in the environment of ?x. The command has indeed failed with message: -Cannot infer the domain of the type of f. +Cannot infer ?T in the partial instance "?T -> nat" found for the type of f. The command has indeed failed with message: -Cannot infer the domain of the implicit parameter A of id whose type is -"Type". +Cannot infer ?T in the partial instance "?T -> nat" found for the implicit +parameter A of id whose type is "Type". The command has indeed failed with message: -Cannot infer the codomain of the type of f in environment: +Cannot infer ?T in the partial instance "forall x : nat, ?T" found for the +type of f in environment: x : nat diff --git a/test-suite/output/Extraction_matchs_2413.v b/test-suite/output/Extraction_matchs_2413.v index 1ecd9771eb..f9398fdca9 100644 --- a/test-suite/output/Extraction_matchs_2413.v +++ b/test-suite/output/Extraction_matchs_2413.v @@ -101,7 +101,7 @@ Section decoder_result. Variable inst : Type. - Inductive decoder_result : Type := + #[universes(template)] Inductive decoder_result : Type := | DecUndefined : decoder_result | DecUnpredictable : decoder_result | DecInst : inst -> decoder_result diff --git a/test-suite/output/Fixpoint.v b/test-suite/output/Fixpoint.v index 61ae4edbd1..9b25c2dbd3 100644 --- a/test-suite/output/Fixpoint.v +++ b/test-suite/output/Fixpoint.v @@ -44,7 +44,7 @@ fix even_pos_odd_pos 2 with (odd_pos_even_pos n (H:odd n) {struct H} : n >= 1). omega. Qed. -CoInductive Inf := S { projS : Inf }. +#[universes(template)] CoInductive Inf := S { projS : Inf }. Definition expand_Inf (x : Inf) := S (projS x). CoFixpoint inf := S inf. Eval compute in inf. diff --git a/test-suite/output/FunExt.v b/test-suite/output/FunExt.v index 7658ce718e..440fe46003 100644 --- a/test-suite/output/FunExt.v +++ b/test-suite/output/FunExt.v @@ -1,3 +1,4 @@ +(* -*- coq-prog-args: ("-async-proofs" "no") -*- *) Require Import FunctionalExtensionality. (* Basic example *) diff --git a/test-suite/output/Implicit.out b/test-suite/output/Implicit.out index 71c7070f2b..3b65003c29 100644 --- a/test-suite/output/Implicit.out +++ b/test-suite/output/Implicit.out @@ -2,11 +2,9 @@ compose (C:=nat) S : (nat -> nat) -> nat -> nat ex_intro (P:=fun _ : nat => True) (x:=0) I : ex (fun _ : nat => True) -Monomorphic d2 = -fun x : nat => d1 (y:=x) +d2 = fun x : nat => d1 (y:=x) : forall x x0 : nat, x0 = x -> x0 = x -d2 is not universe polymorphic Arguments x, x0 are implicit Argument scopes are [nat_scope nat_scope _] map id (1 :: nil) diff --git a/test-suite/output/Inductive.out b/test-suite/output/Inductive.out index 5a548cfae4..2ba02924c9 100644 --- a/test-suite/output/Inductive.out +++ b/test-suite/output/Inductive.out @@ -1,8 +1,7 @@ The command has indeed failed with message: Last occurrence of "list'" must have "A" as 1st argument in "A -> list' A -> list' (A * A)". -Monomorphic Inductive foo (A : Type) (x : A) (y : A := x) : Prop := - Foo : foo A x +Inductive foo (A : Type) (x : A) (y : A := x) : Prop := Foo : foo A x For foo: Argument scopes are [type_scope _] For Foo: Argument scopes are [type_scope _] diff --git a/test-suite/output/Inductive.v b/test-suite/output/Inductive.v index 8ff91268a6..9eec9a7dad 100644 --- a/test-suite/output/Inductive.v +++ b/test-suite/output/Inductive.v @@ -3,5 +3,5 @@ Fail Inductive list' (A:Set) : Set := | cons' : A -> list' A -> list' (A*A). (* Check printing of let-ins *) -Inductive foo (A : Type) (x : A) (y := x) := Foo. +#[universes(template)] Inductive foo (A : Type) (x : A) (y := x) := Foo. Print foo. diff --git a/test-suite/output/InitSyntax.out b/test-suite/output/InitSyntax.out index 4743fb0d0a..c17c63e724 100644 --- a/test-suite/output/InitSyntax.out +++ b/test-suite/output/InitSyntax.out @@ -1,4 +1,4 @@ -Monomorphic Inductive sig2 (A : Type) (P Q : A -> Prop) : Type := +Inductive sig2 (A : Type) (P Q : A -> Prop) : Type := exist2 : forall x : A, P x -> Q x -> {x : A | P x & Q x} For sig2: Argument A is implicit diff --git a/test-suite/output/Load.out b/test-suite/output/Load.out index f84cedfa62..0904d5540b 100644 --- a/test-suite/output/Load.out +++ b/test-suite/output/Load.out @@ -1,10 +1,6 @@ -Monomorphic f = 2 +f = 2 : nat - -f is not universe polymorphic -Monomorphic u = I +u = I : True - -u is not universe polymorphic The command has indeed failed with message: Files processed by Load cannot leave open proofs. diff --git a/test-suite/output/Notations3.out b/test-suite/output/Notations3.out index f53313def9..015dac2512 100644 --- a/test-suite/output/Notations3.out +++ b/test-suite/output/Notations3.out @@ -225,14 +225,13 @@ fun S : nat => [[S | S + S]] : Set exists2 '{{y, z}} : nat * nat, y > z & z > y : Prop -Monomorphic foo = +foo = fun l : list nat => match l with | _ :: (_ :: _) as l1 => l1 | _ => l end : list nat -> list nat -foo is not universe polymorphic Argument scope is [list_scope] Notation "'exists' x .. y , p" := ex (fun x => .. (ex (fun y => p)) ..) : type_scope @@ -261,11 +260,7 @@ myfoo01 tt {4; 5; 6}; {7; 8; 9}] : list (list nat) -Monomorphic amatch = mmatch 0 (with 0 => 1| 1 => 2 end) +amatch = mmatch 0 (with 0 => 1| 1 => 2 end) : unit - -amatch is not universe polymorphic -Monomorphic alist = [0; 1; 2] +alist = [0; 1; 2] : list nat - -alist is not universe polymorphic diff --git a/test-suite/output/Notations3.v b/test-suite/output/Notations3.v index 15211f1233..2caffad1d9 100644 --- a/test-suite/output/Notations3.v +++ b/test-suite/output/Notations3.v @@ -123,7 +123,7 @@ Check fun n => foo4 n (fun x y z => (fun _ => y=0) z). (**********************************************************************) (* Test printing of #4932 *) -Inductive ftele : Type := +#[universes(template)] Inductive ftele : Type := | fb {T:Type} : T -> ftele | fr {T} : (T -> ftele) -> ftele. diff --git a/test-suite/output/Notations4.out b/test-suite/output/Notations4.out index d58e4bf2d6..7a64b7eb45 100644 --- a/test-suite/output/Notations4.out +++ b/test-suite/output/Notations4.out @@ -45,3 +45,9 @@ fun x : nat => (x.-1)%pred : Prop ## : Prop +myAnd1 True True + : Prop +r 2 3 + : Prop +Notation Cn := Foo.FooCn +Expands to: Notation Notations4.J.Mfoo.Foo.Bar.Cn diff --git a/test-suite/output/Notations4.v b/test-suite/output/Notations4.v index 61206b6dd0..90babf9c55 100644 --- a/test-suite/output/Notations4.v +++ b/test-suite/output/Notations4.v @@ -164,3 +164,36 @@ Open Scope my_scope. Check ##. End H. + +(* Fixing bugs reported by G. Gonthier in #9207 *) + +Module I. + +Definition myAnd A B := A /\ B. +Notation myAnd1 A := (myAnd A). +Check myAnd1 True True. + +Set Warnings "-auto-template". + +Record Pnat := {inPnat :> nat -> Prop}. +Axiom r : nat -> Pnat. +Check r 2 3. + +End I. + +(* Fixing a bug reported by G. Gonthier in #9207 *) + +Module J. + +Module Import Mfoo. +Module Foo. +Definition FooCn := 2. +Module Bar. +Notation Cn := FooCn. +End Bar. +End Foo. +Export Foo.Bar. +End Mfoo. +About Cn. + +End J. diff --git a/test-suite/output/PatternsInBinders.out b/test-suite/output/PatternsInBinders.out index bfeff20524..8a6d94c732 100644 --- a/test-suite/output/PatternsInBinders.out +++ b/test-suite/output/PatternsInBinders.out @@ -1,31 +1,20 @@ -Monomorphic swap = fun '(x, y) => (y, x) +swap = fun '(x, y) => (y, x) : A * B -> B * A - -swap is not universe polymorphic fun '(x, y) => (y, x) : A * B -> B * A forall '(x, y), swap (x, y) = (y, x) : Prop -Monomorphic proj_informative = -fun '(exist _ x _) => x : A +proj_informative = fun '(exist _ x _) => x : A : {x : A | P x} -> A - -proj_informative is not universe polymorphic -Monomorphic foo = -fun '(Bar n b tt p) => if b then n + p else n - p +foo = fun '(Bar n b tt p) => if b then n + p else n - p : Foo -> nat - -foo is not universe polymorphic -Monomorphic baz = +baz = fun '(Bar n1 _ tt p1) '(Bar _ _ tt _) => n1 + p1 : Foo -> Foo -> nat - -baz is not universe polymorphic -Monomorphic swap = +swap = fun (A B : Type) '(x, y) => (y, x) : forall A B : Type, A * B -> B * A -swap is not universe polymorphic Arguments A, B are implicit and maximally inserted Argument scopes are [type_scope type_scope _] fun (A B : Type) '(x, y) => swap (x, y) = (y, x) @@ -40,22 +29,19 @@ exists '(x, y) '(z, w), swap (x, y) = (z, w) : A * B → B * A ∀ '(x, y), swap (x, y) = (y, x) : Prop -Monomorphic both_z = +both_z = fun pat : nat * nat => let '(n, p) as x := pat return (F x) in (Z n, Z p) : F (n, p) : forall pat : nat * nat, F pat - -both_z is not universe polymorphic fun '(x, y) '(z, t) => swap (x, y) = (z, t) : A * B -> B * A -> Prop forall '(x, y) '(z, t), swap (x, y) = (z, t) : Prop fun (pat : nat) '(x, y) => x + y = pat : nat -> nat * nat -> Prop -Monomorphic f = fun x : nat => x + x +f = fun x : nat => x + x : nat -> nat -f is not universe polymorphic Argument scope is [nat_scope] fun x : nat => x + x : nat -> nat diff --git a/test-suite/output/PatternsInBinders.v b/test-suite/output/PatternsInBinders.v index d671053c07..0c1b08f5a3 100644 --- a/test-suite/output/PatternsInBinders.v +++ b/test-suite/output/PatternsInBinders.v @@ -53,7 +53,7 @@ Module Suboptimal. (** This test shows an example which exposes the [let] introduced by the pattern notation in binders. *) -Inductive Fin (n:nat) := Z : Fin n. +#[universes(template)] Inductive Fin (n:nat) := Z : Fin n. Definition F '(n,p) : Type := (Fin n * Fin p)%type. Definition both_z '(n,p) : F (n,p) := (Z _,Z _). Print both_z. diff --git a/test-suite/output/PrintInfos.out b/test-suite/output/PrintInfos.out index be793dd453..ab4172711e 100644 --- a/test-suite/output/PrintInfos.out +++ b/test-suite/output/PrintInfos.out @@ -4,7 +4,7 @@ existT is template universe polymorphic Argument A is implicit Argument scopes are [type_scope function_scope _ _] Expands to: Constructor Coq.Init.Specif.existT -Monomorphic Inductive sigT (A : Type) (P : A -> Type) : Type := +Inductive sigT (A : Type) (P : A -> Type) : Type := existT : forall x : A, P x -> {x : A & P x} For sigT: Argument A is implicit @@ -14,7 +14,7 @@ For existT: Argument scopes are [type_scope function_scope _ _] existT : forall (A : Type) (P : A -> Type) (x : A), P x -> {x : A & P x} Argument A is implicit -Monomorphic Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x +Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x For eq: Argument A is implicit and maximally inserted For eq_refl, when applied to no arguments: @@ -38,7 +38,7 @@ When applied to no arguments: Arguments A, x are implicit and maximally inserted When applied to 1 argument: Argument A is implicit -Monomorphic Nat.add = +Nat.add = fix add (n m : nat) {struct n} : nat := match n with | 0 => m @@ -46,7 +46,6 @@ fix add (n m : nat) {struct n} : nat := end : nat -> nat -> nat -Nat.add is not universe polymorphic Argument scopes are [nat_scope nat_scope] Nat.add : nat -> nat -> nat @@ -62,7 +61,7 @@ plus_n_O is not universe polymorphic Argument scope is [nat_scope] plus_n_O is opaque Expands to: Constant Coq.Init.Peano.plus_n_O -Monomorphic Inductive le (n : nat) : nat -> Prop := +Inductive le (n : nat) : nat -> Prop := le_n : n <= n | le_S : forall m : nat, n <= m -> n <= S m For le_S: Argument m is implicit @@ -74,7 +73,7 @@ comparison : Set comparison is not universe polymorphic Expands to: Inductive Coq.Init.Datatypes.comparison -Monomorphic Inductive comparison : Set := +Inductive comparison : Set := Eq : comparison | Lt : comparison | Gt : comparison bar : foo @@ -84,9 +83,8 @@ bar : forall x : nat, x = 0 Argument x is implicit and maximally inserted Expands to: Constant PrintInfos.bar -Monomorphic *** [ bar : foo ] +*** [ bar : foo ] -bar is not universe polymorphic Expanded type for implicit arguments bar : forall x : nat, x = 0 @@ -94,7 +92,7 @@ Argument x is implicit and maximally inserted Module Coq.Init.Peano Notation sym_eq := eq_sym Expands to: Notation Coq.Init.Logic.sym_eq -Monomorphic Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x +Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x For eq: Argument A is implicit and maximally inserted For eq_refl, when applied to no arguments: diff --git a/test-suite/output/Projections.v b/test-suite/output/Projections.v index 098a518dc4..2713e6a188 100644 --- a/test-suite/output/Projections.v +++ b/test-suite/output/Projections.v @@ -5,7 +5,7 @@ Class HostFunction := host_func : Type. Section store. Context `{HostFunction}. - Record store := { store_funcs : host_func }. + #[universes(template)] Record store := { store_funcs : host_func }. End store. Check (fun (S:@store nat) => S.(store_funcs)). diff --git a/test-suite/output/RecognizePluginWarning.v b/test-suite/output/RecognizePluginWarning.v index cd667bbd00..a53b52396f 100644 --- a/test-suite/output/RecognizePluginWarning.v +++ b/test-suite/output/RecognizePluginWarning.v @@ -1,4 +1,4 @@ -(* -*- mode: coq; coq-prog-args: ("-emacs" "-w" "extraction-logical-axiom") -*- *) +(* -*- mode: coq; coq-prog-args: ("-w" "extraction-logical-axiom") -*- *) (* Test that mentioning a warning defined in plugins works. The failure mode here is that these result in a warning about unknown warnings, since the diff --git a/test-suite/output/Record.v b/test-suite/output/Record.v index d9a649fadc..4fe7b051f8 100644 --- a/test-suite/output/Record.v +++ b/test-suite/output/Record.v @@ -20,12 +20,12 @@ Check {| field := 5 |}. Check build_r 5. Check build_c 5. -Record N := C { T : Type; _ : True }. +#[universes(template)] Record N := C { T : Type; _ : True }. Check fun x:N => let 'C _ p := x in p. Check fun x:N => let 'C T _ := x in T. Check fun x:N => let 'C T p := x in (T,p). -Record M := D { U : Type; a := 0; q : True }. +#[universes(template)] Record M := D { U : Type; a := 0; q : True }. Check fun x:M => let 'D T _ p := x in p. Check fun x:M => let 'D T _ p := x in T. Check fun x:M => let 'D T p := x in (T,p). diff --git a/test-suite/output/Show.v b/test-suite/output/Show.v index 60faac8dd9..c875051bdc 100644 --- a/test-suite/output/Show.v +++ b/test-suite/output/Show.v @@ -5,7 +5,7 @@ Theorem nums : forall (n m : nat), n = m -> (S n) = (S m). Proof. intros. - induction n as [| n']. + induction n as [| n']. induction m as [| m']. Show. Admitted. diff --git a/test-suite/output/ShowMatch.v b/test-suite/output/ShowMatch.v index 9cf6ad35b8..99183f2064 100644 --- a/test-suite/output/ShowMatch.v +++ b/test-suite/output/ShowMatch.v @@ -3,12 +3,12 @@ *) Module A. - Inductive foo := f. + #[universes(template)] Inductive foo := f. Show Match foo. (* no need to disambiguate *) End A. Module B. - Inductive foo := f. + #[universes(template)] Inductive foo := f. (* local foo shadows A.foo, so constructor "f" needs disambiguation *) Show Match A.foo. End B. diff --git a/test-suite/output/StringSyntax.out b/test-suite/output/StringSyntax.out index bbc936766d..9366113c0c 100644 --- a/test-suite/output/StringSyntax.out +++ b/test-suite/output/StringSyntax.out @@ -1,4 +1,4 @@ -Monomorphic byte_rect = +byte_rect = fun (P : byte -> Type) (f : P "000") (f0 : P "001") (f1 : P "002") (f2 : P "003") (f3 : P "004") (f4 : P "005") (f5 : P "006") (f6 : P "007") (f7 : P "008") (f8 : P "009") (f9 : P "010") (f10 : P "011") (f11 : P "012") (f12 : P "013") (f13 : P "014") (f14 : P "015") (f15 : P "016") (f16 : P "017") (f17 : P "018") (f18 : P "019") (f19 : P "020") (f20 : P "021") (f21 : P "022") (f22 : P "023") (f23 : P "024") (f24 : P "025") (f25 : P "026") (f26 : P "027") (f27 : P "028") (f28 : P "029") (f29 : P "030") (f30 : P "031") (f31 : P " ") (f32 : P "!") (f33 : P """") (f34 : P "#") (f35 : P "$") (f36 : P "%") (f37 : P "&") (f38 : P "'") (f39 : P "(") (f40 : P ")") (f41 : P "*") (f42 : P "+") (f43 : P ",") (f44 : P "-") (f45 : P ".") (f46 : P "/") (f47 : P "0") (f48 : P "1") (f49 : P "2") (f50 : P "3") (f51 : P "4") (f52 : P "5") (f53 : P "6") (f54 : P "7") (f55 : P "8") (f56 : P "9") (f57 : P ":") (f58 : P ";") (f59 : P "<") (f60 : P "=") (f61 : P ">") (f62 : P "?") (f63 : P "@") (f64 : P "A") (f65 : P "B") (f66 : P "C") (f67 : P "D") (f68 : P "E") (f69 : P "F") (f70 : P "G") (f71 : P "H") (f72 : P "I") (f73 : P "J") (f74 : P "K") (f75 : P "L") (f76 : P "M") (f77 : P "N") (f78 : P "O") (f79 : P "P") (f80 : P "Q") (f81 : P "R") (f82 : P "S") (f83 : P "T") (f84 : P "U") (f85 : P "V") (f86 : P "W") (f87 : P "X") (f88 : P "Y") (f89 : P "Z") (f90 : P "[") (f91 : P "\") (f92 : P "]") (f93 : P "^") (f94 : P "_") (f95 : P "`") (f96 : P "a") (f97 : P "b") (f98 : P "c") (f99 : P "d") (f100 : P "e") (f101 : P "f") (f102 : P "g") (f103 : P "h") (f104 : P "i") (f105 : P "j") (f106 : P "k") (f107 : P "l") (f108 : P "m") (f109 : P "n") (f110 : P "o") (f111 : P "p") (f112 : P "q") (f113 : P "r") (f114 : P "s") (f115 : P "t") (f116 : P "u") (f117 : P "v") (f118 : P "w") (f119 : P "x") (f120 : P "y") (f121 : P "z") (f122 : P "{") (f123 : P "|") (f124 : P "}") (f125 : P "~") (f126 : P "127") (f127 : P "128") (f128 : P "129") (f129 : P "130") (f130 : P "131") (f131 : P "132") (f132 : P "133") (f133 : P "134") (f134 : P "135") (f135 : P "136") (f136 : P "137") (f137 : P "138") (f138 : P "139") (f139 : P "140") (f140 : P "141") (f141 : P "142") (f142 : P "143") (f143 : P "144") (f144 : P "145") (f145 : P "146") (f146 : P "147") (f147 : P "148") (f148 : P "149") (f149 : P "150") (f150 : P "151") (f151 : P "152") (f152 : P "153") (f153 : P "154") (f154 : P "155") (f155 : P "156") (f156 : P "157") (f157 : P "158") (f158 : P "159") (f159 : P "160") (f160 : P "161") (f161 : P "162") (f162 : P "163") (f163 : P "164") (f164 : P "165") (f165 : P "166") (f166 : P "167") (f167 : P "168") (f168 : P "169") (f169 : P "170") (f170 : P "171") (f171 : P "172") (f172 : P "173") (f173 : P "174") (f174 : P "175") (f175 : P "176") (f176 : P "177") (f177 : P "178") (f178 : P "179") (f179 : P "180") (f180 : P "181") (f181 : P "182") (f182 : P "183") (f183 : P "184") (f184 : P "185") (f185 : P "186") (f186 : P "187") @@ -433,9 +433,8 @@ end P "167" -> P "168" -> P "169" -> P "170" -> P "171" -> P "172" -> P "173" -> P "174" -> P "175" -> P "176" -> P "177" -> P "178" -> P "179" -> P "180" -> P "181" -> P "182" -> P "183" -> P "184" -> P "185" -> P "186" -> P "187" -> P "188" -> P "189" -> P "190" -> P "191" -> P "192" -> P "193" -> P "194" -> P "195" -> P "196" -> P "197" -> P "198" -> P "199" -> P "200" -> P "201" -> P "202" -> P "203" -> P "204" -> P "205" -> P "206" -> P "207" -> P "208" -> P "209" -> P "210" -> P "211" -> P "212" -> P "213" -> P "214" -> P "215" -> P "216" -> P "217" -> P "218" -> P "219" -> P "220" -> P "221" -> P "222" -> P "223" -> P "224" -> P "225" -> P "226" -> P "227" -> P "228" -> P "229" -> P "230" -> P "231" -> P "232" -> P "233" -> P "234" -> P "235" -> P "236" -> P "237" -> P "238" -> P "239" -> P "240" -> P "241" -> P "242" -> P "243" -> P "244" -> P "245" -> P "246" -> P "247" -> P "248" -> P "249" -> P "250" -> P "251" -> P "252" -> P "253" -> P "254" -> P "255" -> forall b : byte, P b -byte_rect is not universe polymorphic Argument scopes are [function_scope _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ byte_scope] -Monomorphic byte_rec = +byte_rec = fun P : byte -> Set => byte_rect P : forall P : byte -> Set, P "000" -> @@ -608,9 +607,8 @@ fun P : byte -> Set => byte_rect P P "167" -> P "168" -> P "169" -> P "170" -> P "171" -> P "172" -> P "173" -> P "174" -> P "175" -> P "176" -> P "177" -> P "178" -> P "179" -> P "180" -> P "181" -> P "182" -> P "183" -> P "184" -> P "185" -> P "186" -> P "187" -> P "188" -> P "189" -> P "190" -> P "191" -> P "192" -> P "193" -> P "194" -> P "195" -> P "196" -> P "197" -> P "198" -> P "199" -> P "200" -> P "201" -> P "202" -> P "203" -> P "204" -> P "205" -> P "206" -> P "207" -> P "208" -> P "209" -> P "210" -> P "211" -> P "212" -> P "213" -> P "214" -> P "215" -> P "216" -> P "217" -> P "218" -> P "219" -> P "220" -> P "221" -> P "222" -> P "223" -> P "224" -> P "225" -> P "226" -> P "227" -> P "228" -> P "229" -> P "230" -> P "231" -> P "232" -> P "233" -> P "234" -> P "235" -> P "236" -> P "237" -> P "238" -> P "239" -> P "240" -> P "241" -> P "242" -> P "243" -> P "244" -> P "245" -> P "246" -> P "247" -> P "248" -> P "249" -> P "250" -> P "251" -> P "252" -> P "253" -> P "254" -> P "255" -> forall b : byte, P b -byte_rec is not universe polymorphic Argument scopes are [function_scope _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ byte_scope] -Monomorphic byte_ind = +byte_ind = fun (P : byte -> Prop) (f : P "000") (f0 : P "001") (f1 : P "002") (f2 : P "003") (f3 : P "004") (f4 : P "005") (f5 : P "006") (f6 : P "007") (f7 : P "008") (f8 : P "009") (f9 : P "010") (f10 : P "011") (f11 : P "012") (f12 : P "013") (f13 : P "014") (f14 : P "015") (f15 : P "016") (f16 : P "017") (f17 : P "018") (f18 : P "019") (f19 : P "020") (f20 : P "021") (f21 : P "022") (f22 : P "023") (f23 : P "024") (f24 : P "025") (f25 : P "026") (f26 : P "027") (f27 : P "028") (f28 : P "029") (f29 : P "030") (f30 : P "031") (f31 : P " ") (f32 : P "!") (f33 : P """") (f34 : P "#") (f35 : P "$") (f36 : P "%") (f37 : P "&") (f38 : P "'") (f39 : P "(") (f40 : P ")") (f41 : P "*") (f42 : P "+") (f43 : P ",") (f44 : P "-") (f45 : P ".") (f46 : P "/") (f47 : P "0") (f48 : P "1") (f49 : P "2") (f50 : P "3") (f51 : P "4") (f52 : P "5") (f53 : P "6") (f54 : P "7") (f55 : P "8") (f56 : P "9") (f57 : P ":") (f58 : P ";") (f59 : P "<") (f60 : P "=") (f61 : P ">") (f62 : P "?") (f63 : P "@") (f64 : P "A") (f65 : P "B") (f66 : P "C") (f67 : P "D") (f68 : P "E") (f69 : P "F") (f70 : P "G") (f71 : P "H") (f72 : P "I") (f73 : P "J") (f74 : P "K") (f75 : P "L") (f76 : P "M") (f77 : P "N") (f78 : P "O") (f79 : P "P") (f80 : P "Q") (f81 : P "R") (f82 : P "S") (f83 : P "T") (f84 : P "U") (f85 : P "V") (f86 : P "W") (f87 : P "X") (f88 : P "Y") (f89 : P "Z") (f90 : P "[") (f91 : P "\") (f92 : P "]") (f93 : P "^") (f94 : P "_") (f95 : P "`") (f96 : P "a") (f97 : P "b") (f98 : P "c") (f99 : P "d") (f100 : P "e") (f101 : P "f") (f102 : P "g") (f103 : P "h") (f104 : P "i") (f105 : P "j") (f106 : P "k") (f107 : P "l") (f108 : P "m") (f109 : P "n") (f110 : P "o") (f111 : P "p") (f112 : P "q") (f113 : P "r") (f114 : P "s") (f115 : P "t") (f116 : P "u") (f117 : P "v") (f118 : P "w") (f119 : P "x") (f120 : P "y") (f121 : P "z") (f122 : P "{") (f123 : P "|") (f124 : P "}") (f125 : P "~") (f126 : P "127") (f127 : P "128") (f128 : P "129") (f129 : P "130") (f130 : P "131") (f131 : P "132") (f132 : P "133") (f133 : P "134") (f134 : P "135") (f135 : P "136") (f136 : P "137") (f137 : P "138") (f138 : P "139") (f139 : P "140") (f140 : P "141") (f141 : P "142") (f142 : P "143") (f143 : P "144") (f144 : P "145") (f145 : P "146") (f146 : P "147") (f147 : P "148") (f148 : P "149") (f149 : P "150") (f150 : P "151") (f151 : P "152") (f152 : P "153") (f153 : P "154") (f154 : P "155") (f155 : P "156") (f156 : P "157") (f157 : P "158") (f158 : P "159") (f159 : P "160") (f160 : P "161") (f161 : P "162") (f162 : P "163") (f163 : P "164") (f164 : P "165") (f165 : P "166") (f166 : P "167") (f167 : P "168") (f168 : P "169") (f169 : P "170") (f170 : P "171") (f171 : P "172") (f172 : P "173") (f173 : P "174") (f174 : P "175") (f175 : P "176") (f176 : P "177") (f177 : P "178") (f178 : P "179") (f179 : P "180") (f180 : P "181") (f181 : P "182") (f182 : P "183") (f183 : P "184") (f184 : P "185") (f185 : P "186") (f186 : P "187") @@ -1045,7 +1043,6 @@ end P "167" -> P "168" -> P "169" -> P "170" -> P "171" -> P "172" -> P "173" -> P "174" -> P "175" -> P "176" -> P "177" -> P "178" -> P "179" -> P "180" -> P "181" -> P "182" -> P "183" -> P "184" -> P "185" -> P "186" -> P "187" -> P "188" -> P "189" -> P "190" -> P "191" -> P "192" -> P "193" -> P "194" -> P "195" -> P "196" -> P "197" -> P "198" -> P "199" -> P "200" -> P "201" -> P "202" -> P "203" -> P "204" -> P "205" -> P "206" -> P "207" -> P "208" -> P "209" -> P "210" -> P "211" -> P "212" -> P "213" -> P "214" -> P "215" -> P "216" -> P "217" -> P "218" -> P "219" -> P "220" -> P "221" -> P "222" -> P "223" -> P "224" -> P "225" -> P "226" -> P "227" -> P "228" -> P "229" -> P "230" -> P "231" -> P "232" -> P "233" -> P "234" -> P "235" -> P "236" -> P "237" -> P "238" -> P "239" -> P "240" -> P "241" -> P "242" -> P "243" -> P "244" -> P "245" -> P "246" -> P "247" -> P "248" -> P "249" -> P "250" -> P "251" -> P "252" -> P "253" -> P "254" -> P "255" -> forall b : byte, P b -byte_ind is not universe polymorphic Argument scopes are [function_scope _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ byte_scope] "000" : byte diff --git a/test-suite/output/TranspModtype.out b/test-suite/output/TranspModtype.out index f080f6d0f0..f94ed64234 100644 --- a/test-suite/output/TranspModtype.out +++ b/test-suite/output/TranspModtype.out @@ -1,15 +1,7 @@ -Monomorphic TrM.A = M.A +TrM.A = M.A : Set - -TrM.A is not universe polymorphic -Monomorphic OpM.A = M.A +OpM.A = M.A : Set - -OpM.A is not universe polymorphic -Monomorphic TrM.B = M.B +TrM.B = M.B : Set - -TrM.B is not universe polymorphic -Monomorphic *** [ OpM.B : Set ] - -OpM.B is not universe polymorphic +*** [ OpM.B : Set ] diff --git a/test-suite/output/UnclosedBlocks.v b/test-suite/output/UnclosedBlocks.v index 854bd6a6d5..b9ba579246 100644 --- a/test-suite/output/UnclosedBlocks.v +++ b/test-suite/output/UnclosedBlocks.v @@ -1,4 +1,3 @@ -(* -*- mode: coq; coq-prog-args: ("-compile" "UnclosedBlocks.v") *) Module Foo. Module Closed. End Closed. diff --git a/test-suite/output/UnivBinders.out b/test-suite/output/UnivBinders.out index 4d3f7419e6..a960fe3441 100644 --- a/test-suite/output/UnivBinders.out +++ b/test-suite/output/UnivBinders.out @@ -1,66 +1,53 @@ -Polymorphic NonCumulative Inductive Empty@{u} : Type@{u} := -Polymorphic NonCumulative Record PWrap (A : Type@{u}) : Type@{u} := pwrap - { punwrap : A } +Inductive Empty@{u} : Type@{u} := +Record PWrap (A : Type@{u}) : Type@{u} := pwrap { punwrap : A } PWrap has primitive projections with eta conversion. For PWrap: Argument scope is [type_scope] For pwrap: Argument scopes are [type_scope _] -Polymorphic punwrap@{u} = +punwrap@{u} = fun (A : Type@{u}) (p : PWrap@{u} A) => punwrap _ p : forall A : Type@{u}, PWrap@{u} A -> A (* u |= *) -punwrap is universe polymorphic Argument scopes are [type_scope _] -Polymorphic NonCumulative Record RWrap (A : Type@{u}) : Type@{u} := rwrap - { runwrap : A } +Record RWrap (A : Type@{u}) : Type@{u} := rwrap { runwrap : A } For RWrap: Argument scope is [type_scope] For rwrap: Argument scopes are [type_scope _] -Polymorphic runwrap@{u} = +runwrap@{u} = fun (A : Type@{u}) (r : RWrap@{u} A) => let (runwrap) := r in runwrap : forall A : Type@{u}, RWrap@{u} A -> A (* u |= *) -runwrap is universe polymorphic Argument scopes are [type_scope _] -Polymorphic Wrap@{u} = -fun A : Type@{u} => A +Wrap@{u} = fun A : Type@{u} => A : Type@{u} -> Type@{u} (* u |= *) -Wrap is universe polymorphic Argument scope is [type_scope] -Polymorphic wrap@{u} = +wrap@{u} = fun (A : Type@{u}) (Wrap : Wrap@{u} A) => Wrap : forall A : Type@{u}, Wrap@{u} A -> A (* u |= *) -wrap is universe polymorphic Arguments A, Wrap are implicit and maximally inserted Argument scopes are [type_scope _] -Polymorphic bar@{u} = nat +bar@{u} = nat : Wrap@{u} Set (* u |= Set < u *) - -bar is universe polymorphic -Polymorphic foo@{u UnivBinders.17 v} = +foo@{u UnivBinders.17 v} = Type@{UnivBinders.17} -> Type@{v} -> Type@{u} : Type@{max(u+1,UnivBinders.17+1,v+1)} (* u UnivBinders.17 v |= *) - -foo is universe polymorphic Type@{i} -> Type@{j} : Type@{max(i+1,j+1)} (* {j i} |= *) = Type@{i} -> Type@{j} : Type@{max(i+1,j+1)} (* {j i} |= *) -Monomorphic mono = Type@{mono.u} +mono = Type@{mono.u} : Type@{mono.u+1} (* {mono.u} |= *) - -mono is not universe polymorphic mono : Type@{mono.u+1} Type@{mono.u} @@ -77,29 +64,22 @@ mono : Type@{mono.u+1} The command has indeed failed with message: Universe u already exists. -Monomorphic bobmorane = +bobmorane = let tt := Type@{UnivBinders.32} in let ff := Type@{UnivBinders.34} in tt -> ff : Type@{max(UnivBinders.31,UnivBinders.33)} - -bobmorane is not universe polymorphic The command has indeed failed with message: Universe u already bound. -Polymorphic foo@{E M N} = +foo@{E M N} = Type@{M} -> Type@{N} -> Type@{E} : Type@{max(E+1,M+1,N+1)} (* E M N |= *) - -foo is universe polymorphic -Polymorphic foo@{u UnivBinders.17 v} = +foo@{u UnivBinders.17 v} = Type@{UnivBinders.17} -> Type@{v} -> Type@{u} : Type@{max(u+1,UnivBinders.17+1,v+1)} (* u UnivBinders.17 v |= *) - -foo is universe polymorphic -Polymorphic NonCumulative Inductive Empty@{E} : Type@{E} := -Polymorphic NonCumulative Record PWrap (A : Type@{E}) : Type@{E} := pwrap - { punwrap : A } +Inductive Empty@{E} : Type@{E} := +Record PWrap (A : Type@{E}) : Type@{E} := pwrap { punwrap : A } PWrap has primitive projections with eta conversion. For PWrap: Argument scope is [type_scope] @@ -119,63 +99,42 @@ The command has indeed failed with message: This object does not support universe names. The command has indeed failed with message: Cannot enforce v < u because u < gU < gV < v -Monomorphic bind_univs.mono = +bind_univs.mono = Type@{bind_univs.mono.u} : Type@{bind_univs.mono.u+1} (* {bind_univs.mono.u} |= *) - -bind_univs.mono is not universe polymorphic -Polymorphic bind_univs.poly@{u} = Type@{u} +bind_univs.poly@{u} = Type@{u} : Type@{u+1} (* u |= *) - -bind_univs.poly is universe polymorphic -Polymorphic insec@{v} = -Type@{u} -> Type@{v} +insec@{v} = Type@{u} -> Type@{v} : Type@{max(u+1,v+1)} (* v |= *) - -insec is universe polymorphic -Polymorphic NonCumulative Inductive insecind@{k} : Type@{k+1} := - inseccstr : Type@{k} -> insecind@{k} +Inductive insecind@{k} : Type@{k+1} := inseccstr : Type@{k} -> insecind@{k} For inseccstr: Argument scope is [type_scope] -Polymorphic insec@{u v} = -Type@{u} -> Type@{v} +insec@{u v} = Type@{u} -> Type@{v} : Type@{max(u+1,v+1)} (* u v |= *) - -insec is universe polymorphic -Polymorphic NonCumulative Inductive insecind@{u k} : Type@{k+1} := +Inductive insecind@{u k} : Type@{k+1} := inseccstr : Type@{k} -> insecind@{u k} For inseccstr: Argument scope is [type_scope] -Polymorphic insec2@{u} = Prop +insec2@{u} = Prop : Type@{Set+1} (* u |= *) - -insec2 is universe polymorphic -Polymorphic inmod@{u} = Type@{u} +inmod@{u} = Type@{u} : Type@{u+1} (* u |= *) - -inmod is universe polymorphic -Polymorphic SomeMod.inmod@{u} = Type@{u} +SomeMod.inmod@{u} = Type@{u} : Type@{u+1} (* u |= *) - -SomeMod.inmod is universe polymorphic -Polymorphic inmod@{u} = Type@{u} +inmod@{u} = Type@{u} : Type@{u+1} (* u |= *) - -inmod is universe polymorphic -Polymorphic Applied.infunct@{u v} = +Applied.infunct@{u v} = inmod@{u} -> Type@{v} : Type@{max(u+1,v+1)} (* u v |= *) - -Applied.infunct is universe polymorphic axfoo@{i UnivBinders.56 UnivBinders.57} : Type@{UnivBinders.56} -> Type@{i} (* i UnivBinders.56 UnivBinders.57 |= *) diff --git a/test-suite/output/UsePluginWarning.v b/test-suite/output/UsePluginWarning.v index c6e0054641..618b8fd42f 100644 --- a/test-suite/output/UsePluginWarning.v +++ b/test-suite/output/UsePluginWarning.v @@ -1,5 +1,4 @@ -(* -*- mode: coq; coq-prog-args: ("-emacs" "-w" "-extraction-logical-axiom") -*- *) - +(* -*- mode: coq; coq-prog-args: ("-w" "-extraction-logical-axiom") -*- *) Require Extraction. Axiom foo : Prop. diff --git a/test-suite/output/Warnings.v b/test-suite/output/Warnings.v index 7465442cab..0eb5db1733 100644 --- a/test-suite/output/Warnings.v +++ b/test-suite/output/Warnings.v @@ -1,5 +1,5 @@ (* Term in warning was not printed in the right environment at some time *) -Record A := { B:Type; b:B->B }. +#[universes(template)] Record A := { B:Type; b:B->B }. Definition a B := {| B:=B; b:=fun x => x |}. Canonical Structure a. diff --git a/test-suite/output/goal_output.out b/test-suite/output/goal_output.out index 3dad2360c4..773533a8d3 100644 --- a/test-suite/output/goal_output.out +++ b/test-suite/output/goal_output.out @@ -1,11 +1,7 @@ -Monomorphic Nat.t = nat +Nat.t = nat : Set - -Nat.t is not universe polymorphic -Monomorphic Nat.t = nat +Nat.t = nat : Set - -Nat.t is not universe polymorphic 1 subgoal ============================ diff --git a/test-suite/output/inference.out b/test-suite/output/inference.out index a1326596bb..f7ffd1959a 100644 --- a/test-suite/output/inference.out +++ b/test-suite/output/inference.out @@ -1,11 +1,9 @@ -Monomorphic P = +P = fun e : option L => match e with | Some cl => Some cl | None => None end : option L -> option L - -P is not universe polymorphic fun n : nat => let y : T n := A n in ?t ?x : T n : forall n : nat, T n where diff --git a/test-suite/output/inference.v b/test-suite/output/inference.v index 57a4739e9f..209fedc343 100644 --- a/test-suite/output/inference.v +++ b/test-suite/output/inference.v @@ -21,6 +21,6 @@ Print P. (* Note: exact numbers of evars are not important... *) -Inductive T (n:nat) : Type := A : T n. +#[universes(template)] Inductive T (n:nat) : Type := A : T n. Check fun n (y:=A n:T n) => _ _ : T n. Check fun n => _ _ : T n. diff --git a/test-suite/output/simpl.v b/test-suite/output/simpl.v index 5f1926f142..5f7e3ab9dd 100644 --- a/test-suite/output/simpl.v +++ b/test-suite/output/simpl.v @@ -11,3 +11,4 @@ Undo. simpl (0 + _). Show. Undo. +Abort. diff --git a/test-suite/output/unifconstraints.v b/test-suite/output/unifconstraints.v index 179dec3fb0..c987d66c5f 100644 --- a/test-suite/output/unifconstraints.v +++ b/test-suite/output/unifconstraints.v @@ -1,3 +1,4 @@ +(* -*- coq-prog-args: ("-async-proofs" "no") -*- *) (* Set Printing Existential Instances. *) Unset Solve Unification Constraints. Axiom veeryyyyyyyyyyyyloooooooooooooonggidentifier : nat. diff --git a/test-suite/report.sh b/test-suite/report.sh index c5e698232f..71aac029ea 100755 --- a/test-suite/report.sh +++ b/test-suite/report.sh @@ -15,7 +15,7 @@ mkdir "$SAVEDIR" FAILMARK="==========> FAILURE <==========" FAILED=$(mktemp /tmp/coq-check-XXXXXX) -find . '(' -path ./bugs/opened -prune ')' -o '(' -name '*.log' -exec grep "$FAILMARK" -q '{}' ';' -print0 ')' > "$FAILED" +find . '(' -name '*.log' -exec grep "$FAILMARK" -q '{}' ';' -print0 ')' > "$FAILED" rsync -a --from0 --files-from="$FAILED" . "$SAVEDIR" cp summary.log "$SAVEDIR"/ @@ -24,21 +24,11 @@ cp summary.log "$SAVEDIR"/ rm "$FAILED" # print info -if [ -n "$TRAVIS" ] || [ -n "$APPVEYOR" ] || [ -n "$PRINT_LOGS" ]; then +if [ -n "$APPVEYOR" ] || [ -n "$PRINT_LOGS" ]; then find logs/ -name '*.log' -not -name 'summary.log' -print0 | while IFS= read -r -d '' file; do - if [ -n "$TRAVIS" ]; then - # ${foo////.} replaces every / by . in $foo - printf 'travis_fold:start:coq.logs.%s\n' "${file////.}"; - else printf '%s\n' "$file" - fi - + printf '%s\n' "$file" cat "$file" - - if [ -n "$TRAVIS" ]; then - # ${foo////.} replaces every / by . in $foo - printf 'travis_fold:end:coq.logs.%s\n' "${file////.}"; - else printf '\n' - fi + printf '\n' done printed_logs=1 fi diff --git a/test-suite/ssr/ipat_fast_any.v b/test-suite/ssr/ipat_fast_any.v new file mode 100644 index 0000000000..a50984c7c0 --- /dev/null +++ b/test-suite/ssr/ipat_fast_any.v @@ -0,0 +1,21 @@ +Require Import ssreflect. + +Goal forall y x : nat, x = y -> x = x. +Proof. +move=> + > ->. match goal with |- forall y, y = y => by [] end. +Qed. + +Goal forall y x : nat, le x y -> x = y. +Proof. +move=> > [|]. + by []. +match goal with |- forall a, _ <= a -> _ = S a => admit end. +Admitted. + +Goal forall y x : nat, le x y -> x = y. +Proof. +move=> y x. +case E: x => >. + admit. +match goal with |- S _ <= y -> S _ = y => admit end. +Admitted. diff --git a/test-suite/ssr/ipat_fastid.v b/test-suite/ssr/ipat_fastid.v index 8dc0c6cf0b..b0985a0d2f 100644 --- a/test-suite/ssr/ipat_fastid.v +++ b/test-suite/ssr/ipat_fastid.v @@ -11,6 +11,15 @@ lazymatch goal with end. Qed. +Lemma simple2 : + forall x, 3 <= x -> forall y, odd (y+x) -> x = y -> True. +Proof. +move=> >; move=>x_ge_3; move=> >; move=>xy_odd. +lazymatch goal with +| |- ?x = ?y -> True => done +end. +Qed. + Definition stuff x := 3 <= x -> forall y, odd (y+x) -> x = y -> True. @@ -22,6 +31,14 @@ lazymatch goal with end. Qed. +Lemma harder2 : forall x, stuff x. +Proof. +move=> >; move=>x_ge_3;move=> >; move=>xy_odd. +lazymatch goal with +| |- ?x = ?y -> True => done +end. +Qed. + Lemma homotop : forall x : nat, forall e : x = x, e = e -> True. Proof. move=> >eq_ee. diff --git a/test-suite/ssr/ipat_replace.v b/test-suite/ssr/ipat_replace.v new file mode 100644 index 0000000000..528f33f30d --- /dev/null +++ b/test-suite/ssr/ipat_replace.v @@ -0,0 +1,17 @@ +Require Import ssreflect. + +Lemma test : True. +Proof. +have H : True. + by []. +have {}H : True. + by apply: H. +by apply: H. +Qed. + +Lemma test2 (H : True) : False -> False -> False. +Proof. +move=> {}W. +move=> {}H. +by apply: H. +Qed. diff --git a/test-suite/success/Cases.v b/test-suite/success/Cases.v index 52fe98ac07..232ac17cbf 100644 --- a/test-suite/success/Cases.v +++ b/test-suite/success/Cases.v @@ -1873,3 +1873,12 @@ Check match niln in listn O return O=O with niln => eq_refl end. (* (was failing up to May 2017) *) Check fun x => match x with (y,z) as t as w => (y+z,t) = (0,w) end. + +(* A test about binding variables of "in" clause of "match" *) +(* (was failing from 8.5 to Dec 2018) *) + +Check match O in nat return nat with O => O | _ => O end. + +(* Checking that aliases are substituted in the correct order *) + +Check match eq_refl (1,0) in _ = (y as z, y' as z) return z = z with eq_refl => eq_refl end : 0=0. diff --git a/test-suite/success/CompatCurrentFlag.v b/test-suite/success/CompatCurrentFlag.v index 5650dba236..81469d79c3 100644 --- a/test-suite/success/CompatCurrentFlag.v +++ b/test-suite/success/CompatCurrentFlag.v @@ -1,3 +1,3 @@ -(* -*- coq-prog-args: ("-compat" "8.9") -*- *) +(* -*- coq-prog-args: ("-compat" "8.10") -*- *) (** Check that the current compatibility flag actually requires the relevant modules. *) -Import Coq.Compat.Coq89. +Import Coq.Compat.Coq810. diff --git a/test-suite/success/CompatOldFlag.v b/test-suite/success/CompatOldFlag.v index 37d50ee67d..afeb57f9f2 100644 --- a/test-suite/success/CompatOldFlag.v +++ b/test-suite/success/CompatOldFlag.v @@ -1,5 +1,5 @@ -(* -*- coq-prog-args: ("-compat" "8.7") -*- *) +(* -*- coq-prog-args: ("-compat" "8.8") -*- *) (** Check that the current-minus-two compatibility flag actually requires the relevant modules. *) +Import Coq.Compat.Coq810. Import Coq.Compat.Coq89. Import Coq.Compat.Coq88. -Import Coq.Compat.Coq87. diff --git a/test-suite/success/CompatOldOldFlag.v b/test-suite/success/CompatOldOldFlag.v new file mode 100644 index 0000000000..1f62635f50 --- /dev/null +++ b/test-suite/success/CompatOldOldFlag.v @@ -0,0 +1,6 @@ +(* -*- coq-prog-args: ("-compat" "8.7") -*- *) +(** Check that the current-minus-three compatibility flag actually requires the relevant modules. *) +Import Coq.Compat.Coq810. +Import Coq.Compat.Coq89. +Import Coq.Compat.Coq88. +Import Coq.Compat.Coq87. diff --git a/test-suite/success/CompatPreviousFlag.v b/test-suite/success/CompatPreviousFlag.v index 9981388381..c8f75915c8 100644 --- a/test-suite/success/CompatPreviousFlag.v +++ b/test-suite/success/CompatPreviousFlag.v @@ -1,4 +1,4 @@ -(* -*- coq-prog-args: ("-compat" "8.8") -*- *) +(* -*- coq-prog-args: ("-compat" "8.9") -*- *) (** Check that the current-minus-one compatibility flag actually requires the relevant modules. *) +Import Coq.Compat.Coq810. Import Coq.Compat.Coq89. -Import Coq.Compat.Coq88. diff --git a/test-suite/success/Nia.v b/test-suite/success/Nia.v new file mode 100644 index 0000000000..62ecece792 --- /dev/null +++ b/test-suite/success/Nia.v @@ -0,0 +1,918 @@ +Require Import Coq.ZArith.ZArith. +Require Import Coq.micromega.Lia. +Open Scope Z_scope. + +(** Add [Z.to_euclidean_division_equations] to the end of [zify], just for this + file. *) +Ltac zify ::= repeat (zify_nat; zify_positive; zify_N); zify_op; Z.to_euclidean_division_equations. + +Lemma Z_zerop_or x : x = 0 \/ x <> 0. Proof. nia. Qed. +Lemma Z_eq_dec_or (x y : Z) : x = y \/ x <> y. Proof. nia. Qed. + +Ltac unique_pose_proof pf := + let T := type of pf in + lazymatch goal with + | [ H : T |- _ ] => fail + | _ => pose proof pf + end. + +Ltac saturate_mod_div := + repeat match goal with + | [ |- context[?x mod ?y] ] => unique_pose_proof (Z_zerop_or (x / y)) + | [ H : context[?x mod ?y] |- _ ] => unique_pose_proof (Z_zerop_or (x / y)) + | [ |- context[?x / ?y] ] => unique_pose_proof (Z_zerop_or y) + | [ H : context[?x / ?y] |- _ ] => unique_pose_proof (Z_zerop_or y) + | [ |- context[Z.rem ?x ?y] ] => unique_pose_proof (Z_zerop_or (Z.quot x y)) + | [ H : context[Z.rem ?x ?y] |- _ ] => unique_pose_proof (Z_zerop_or (Z.quot x y)) + | [ |- context[Z.quot ?x ?y] ] => unique_pose_proof (Z_zerop_or y) + | [ H : context[Z.quot ?x ?y] |- _ ] => unique_pose_proof (Z_zerop_or y) + end. + +Ltac t := intros; saturate_mod_div; try nia. + +Ltac destr_step := + match goal with + | [ H : and _ _ |- _ ] => destruct H + | [ H : or _ _ |- _ ] => destruct H + end. + +Example mod_0_l: forall x : Z, 0 mod x = 0. Proof. t. Qed. +Example mod_0_r: forall x : Z, x mod 0 = 0. Proof. intros; nia. Qed. +Example Z_mod_same_full: forall a : Z, a mod a = 0. Proof. t. Qed. +Example Zmod_0_l: forall a : Z, 0 mod a = 0. Proof. t. Qed. +Example Zmod_0_r: forall a : Z, a mod 0 = 0. Proof. intros; nia. Qed. +Example mod_mod_same: forall x y : Z, (x mod y) mod y = x mod y. Proof. t. Qed. +Example Zmod_mod: forall a n : Z, (a mod n) mod n = a mod n. Proof. t. Qed. +Example Zmod_1_r: forall a : Z, a mod 1 = 0. Proof. intros; nia. Qed. +Example Zmod_div: forall a b : Z, a mod b / b = 0. Proof. intros; nia. Qed. +Example Z_mod_1_r: forall a : Z, a mod 1 = 0. Proof. intros; nia. Qed. +Example Z_mod_same: forall a : Z, a > 0 -> a mod a = 0. Proof. t. Qed. +Example Z_mod_mult: forall a b : Z, (a * b) mod b = 0. +Proof. + intros a b. + assert (b = 0 \/ (a * b) / b = a) by nia. + nia. +Qed. +Example Z_mod_same': forall a : Z, a <> 0 -> a mod a = 0. Proof. t. Qed. +Example Z_mod_0_l: forall a : Z, a <> 0 -> 0 mod a = 0. Proof. t. Qed. +Example Zmod_opp_opp: forall a b : Z, - a mod - b = - (a mod b). +Proof. + intros a b. + pose proof (Z_eq_dec_or ((-a)/(-b)) (a/b)). + nia. +Qed. +Example Z_mod_le: forall a b : Z, 0 <= a -> 0 < b -> a mod b <= a. Proof. t. Qed. +Example Zmod_le: forall a b : Z, 0 < b -> 0 <= a -> a mod b <= a. Proof. t. Qed. +Example Zplus_mod_idemp_r: forall a b n : Z, (b + a mod n) mod n = (b + a) mod n. +Proof. + intros a b n. + destruct (Z_zerop n); [ subst; nia | ]. + assert ((b + a mod n) / n = (b / n) + (b mod n + a mod n) / n) + by nia. + assert ((b + a) / n = (b / n) + (a / n) + (b mod n + a mod n) / n) + by nia. + nia. +Qed. +Example Zplus_mod_idemp_l: forall a b n : Z, (a mod n + b) mod n = (a + b) mod n. +Proof. + intros a b n. + destruct (Z_zerop n); [ subst; nia | ]. + assert ((a mod n + b) / n = (b / n) + (b mod n + a mod n) / n) by nia. + assert ((a + b) / n = (b / n) + (a / n) + (b mod n + a mod n) / n) by nia. + nia. +Qed. +Example Zmult_mod_distr_r: forall a b c : Z, (a * c) mod (b * c) = a mod b * c. +Proof. + intros a b c. + destruct (Z_zerop c); try nia. + pose proof (Z_eq_dec_or ((a * c) / (b * c)) (a / b)). + nia. +Qed. +Example Z_mod_zero_opp_full: forall a b : Z, a mod b = 0 -> - a mod b = 0. +Proof. + intros a b. + pose proof (Z_eq_dec_or (a/b) (-(-a/b))). + nia. +Qed. +Example Zmult_mod_idemp_r: forall a b n : Z, (b * (a mod n)) mod n = (b * a) mod n. +Proof. + intros a b n. + destruct (Z_zerop n); [ subst; nia | ]. + assert ((b * (a mod n)) / n = (b / n) * (a mod n) + ((b mod n) * (a mod n)) / n) + by nia. + assert ((b * a) / n = (b / n) * (a / n) * n + (b / n) * (a mod n) + (b mod n) * (a / n) + ((b mod n) * (a mod n)) / n) + by nia. + nia. +Qed. +Example Zmult_mod_idemp_l: forall a b n : Z, (a mod n * b) mod n = (a * b) mod n. +Proof. + intros a b n. + destruct (Z_zerop n); [ subst; nia | ]. + assert (((a mod n) * b) / n = (b / n) * (a mod n) + ((b mod n) * (a mod n)) / n) + by nia. + assert ((a * b) / n = (b / n) * (a / n) * n + (b / n) * (a mod n) + (b mod n) * (a / n) + ((b mod n) * (a mod n)) / n) + by nia. + nia. +Qed. +Example Zminus_mod_idemp_r: forall a b n : Z, (a - b mod n) mod n = (a - b) mod n. +Proof. + intros a b n. + destruct (Z_zerop n); [ subst; nia | ]. + assert ((a - b mod n) / n = a / n + ((a mod n) - (b mod n)) / n) by nia. + assert ((a - b) / n = a / n - b / n + ((a mod n) - (b mod n)) / n) by nia. + nia. +Qed. +Example Zminus_mod_idemp_l: forall a b n : Z, (a mod n - b) mod n = (a - b) mod n. +Proof. + intros a b n. + destruct (Z_zerop n); [ subst; nia | ]. + assert ((a mod n - b) / n = - (b / n) + ((a mod n) - (b mod n)) / n) by nia. + assert ((a - b) / n = a / n - b / n + ((a mod n) - (b mod n)) / n) by nia. + nia. +Qed. +Example Z_mod_plus_full: forall a b c : Z, (a + b * c) mod c = a mod c. +Proof. + intros a b c. + pose proof (Z_eq_dec_or ((a+b*c)/c) (a/c + b)). + nia. +Qed. +Example Zmult_mod_distr_l: forall a b c : Z, (c * a) mod (c * b) = c * (a mod b). +Proof. + intros a b c. + destruct (Z_zerop c); try nia. + pose proof (Z_eq_dec_or ((c * a) / (c * b)) (a / b)). + nia. +Qed. +Example Z_mod_zero_opp_r: forall a b : Z, a mod b = 0 -> a mod - b = 0. +Proof. + intros a b. + pose proof (Z_eq_dec_or (a/b) (-(a/-b))). + nia. +Qed. +Example Zmod_1_l: forall a : Z, 1 < a -> 1 mod a = 1. Proof. t. Qed. +Example Z_mod_1_l: forall a : Z, 1 < a -> 1 mod a = 1. Proof. t. Qed. +Example Z_mod_mul: forall a b : Z, b <> 0 -> (a * b) mod b = 0. +Proof. + intros a b. + pose proof (Z_eq_dec_or ((a*b)/b) a). + nia. +Qed. +Example Zminus_mod: forall a b n : Z, (a - b) mod n = (a mod n - b mod n) mod n. +Proof. + intros a b n. + destruct (Z_zerop n); [ subst; nia | ]. + assert ((a - b) / n = (a / n) - (b / n) + ((a mod n) - (b mod n)) / n) by nia. + nia. +Qed. +Example Zplus_mod: forall a b n : Z, (a + b) mod n = (a mod n + b mod n) mod n. +Proof. + intros a b n. + destruct (Z_zerop n); [ subst; nia | ]. + assert ((a + b) / n = (a / n) + (b / n) + ((a mod n) + (b mod n)) / n) by nia. + nia. +Qed. +Example Zmult_mod: forall a b n : Z, (a * b) mod n = (a mod n * (b mod n)) mod n. +Proof. + intros a b n. + destruct (Z_zerop n); [ subst; nia | ]. + assert ((a * b) / n = n * (a / n) * (b / n) + (a mod n) * (b / n) + (a / n) * (b mod n) + ((a mod n) * (b mod n)) / n) + by nia. + nia. +Qed. +Example Z_mod_mod: forall a n : Z, n <> 0 -> (a mod n) mod n = a mod n. Proof. t. Qed. +Example Z_mod_div: forall a b : Z, b <> 0 -> a mod b / b = 0. Proof. intros; nia. Qed. +Example Z_div_exact_full_1: forall a b : Z, a = b * (a / b) -> a mod b = 0. Proof. intros; nia. Qed. +Example Z_mod_pos_bound: forall a b : Z, 0 < b -> 0 <= a mod b < b. Proof. intros; nia. Qed. +Example Z_mod_sign_mul: forall a b : Z, b <> 0 -> 0 <= a mod b * b. Proof. intros; nia. Qed. +Example Z_mod_neg_bound: forall a b : Z, b < 0 -> b < a mod b <= 0. Proof. intros; nia. Qed. +Example Z_mod_neg: forall a b : Z, b < 0 -> b < a mod b <= 0. Proof. intros; nia. Qed. +Example div_mod_small: forall x y : Z, 0 <= x < y -> x mod y = x. Proof. t. Qed. +Example Zmod_small: forall a n : Z, 0 <= a < n -> a mod n = a. Proof. t. Qed. +Example Z_mod_small: forall a b : Z, 0 <= a < b -> a mod b = a. Proof. t. Qed. +Example Z_div_zero_opp_full: forall a b : Z, a mod b = 0 -> - a / b = - (a / b). Proof. intros; nia. Qed. +Example Z_mod_zero_opp: forall a b : Z, b > 0 -> a mod b = 0 -> - a mod b = 0. +Proof. + intros a b. + pose proof (Z_eq_dec_or (a/b) (-(-a/b))). + nia. +Qed. +Example Z_div_zero_opp_r: forall a b : Z, a mod b = 0 -> a / - b = - (a / b). Proof. intros; nia. Qed. +Example Z_mod_lt: forall a b : Z, b > 0 -> 0 <= a mod b < b. Proof. intros; nia. Qed. +Example Z_mod_opp_opp: forall a b : Z, b <> 0 -> - a mod - b = - (a mod b). +Proof. + intros a b. + pose proof (Z_eq_dec_or ((-a)/(-b)) ((a/b))). + nia. +Qed. +Example Z_mod_bound_pos: forall a b : Z, 0 <= a -> 0 < b -> 0 <= a mod b < b. Proof. intros; nia. Qed. +Example Z_mod_opp_l_z: forall a b : Z, b <> 0 -> a mod b = 0 -> - a mod b = 0. +Proof. + intros a b. + pose proof (Z_eq_dec_or (a/b) (-(-a/b))). + nia. +Qed. +Example Z_mod_plus: forall a b c : Z, c > 0 -> (a + b * c) mod c = a mod c. +Proof. + intros a b c. + pose proof (Z_eq_dec_or ((a+b*c)/c) (a/c+b)). + nia. +Qed. +Example Z_mod_opp_r_z: forall a b : Z, b <> 0 -> a mod b = 0 -> a mod - b = 0. +Proof. + intros a b. + pose proof (Z_eq_dec_or (a/b) (-(a/-b))). + nia. +Qed. +Example Zmod_eq: forall a b : Z, b > 0 -> a mod b = a - a / b * b. Proof. intros; nia. Qed. +Example Z_div_exact_2: forall a b : Z, b > 0 -> a mod b = 0 -> a = b * (a / b). Proof. intros; nia. Qed. +Example Z_div_mod_eq: forall a b : Z, b > 0 -> a = b * (a / b) + a mod b. Proof. intros; nia. Qed. +Example Z_div_exact_1: forall a b : Z, b > 0 -> a = b * (a / b) -> a mod b = 0. Proof. intros; nia. Qed. +Example Z_mod_add: forall a b c : Z, c <> 0 -> (a + b * c) mod c = a mod c. +Proof. + intros a b c. + pose proof (Z_eq_dec_or ((a+b*c)/c) (a/c+b)). + nia. +Qed. +Example Z_mod_nz_opp_r: forall a b : Z, a mod b <> 0 -> a mod - b = a mod b - b. +Proof. + intros a b. + assert (a mod b <> 0 -> a / -b = -(a/b)-1) by t. + nia. +Qed. +Example Z_mul_mod_idemp_l: forall a b n : Z, n <> 0 -> (a mod n * b) mod n = (a * b) mod n. +Proof. + intros a b n ?. + assert (((a mod n) * b) / n = (b / n) * (a mod n) + ((b mod n) * (a mod n)) / n) + by nia. + assert ((a * b) / n = (b / n) * (a / n) * n + (b / n) * (a mod n) + (b mod n) * (a / n) + ((b mod n) * (a mod n)) / n) + by nia. + nia. +Qed. +Example Z_mod_nz_opp_full: forall a b : Z, a mod b <> 0 -> - a mod b = b - a mod b. +Proof. + intros a b. + assert (a mod b <> 0 -> -a/b = -1-a/b) by nia. + nia. +Qed. +Example Z_add_mod_idemp_r: forall a b n : Z, n <> 0 -> (a + b mod n) mod n = (a + b) mod n. +Proof. + intros a b n ?. + assert ((a + b mod n) / n = (a / n) + (a mod n + b mod n) / n) by nia. + assert ((a + b) / n = (a / n) + (b / n) + (a mod n + b mod n) / n) by nia. + nia. +Qed. +Example Z_add_mod_idemp_l: forall a b n : Z, n <> 0 -> (a mod n + b) mod n = (a + b) mod n. +Proof. + intros a b n ?. + assert ((a mod n + b) / n = (b / n) + (a mod n + b mod n) / n) by nia. + assert ((a + b) / n = (a / n) + (b / n) + (a mod n + b mod n) / n) by nia. + nia. +Qed. +Example Z_mul_mod_idemp_r: forall a b n : Z, n <> 0 -> (a * (b mod n)) mod n = (a * b) mod n. +Proof. + intros a b n ?. + assert ((a * (b mod n)) / n = (a / n) * (b mod n) + ((a mod n) * (b mod n)) / n) + by nia. + assert ((a * b) / n = (b / n) * (a / n) * n + (b / n) * (a mod n) + (b mod n) * (a / n) + ((a mod n) * (b mod n)) / n) + by nia. + nia. +Qed. +Example Zmod_eq_full: forall a b : Z, b <> 0 -> a mod b = a - a / b * b. Proof. intros; nia. Qed. +Example div_eq: forall x y : Z, y <> 0 -> x mod y = 0 -> x / y * y = x. Proof. intros; nia. Qed. +Example Z_mod_eq: forall a b : Z, b <> 0 -> a mod b = a - b * (a / b). Proof. intros; nia. Qed. +Example Z_mod_sign_nz: forall a b : Z, b <> 0 -> a mod b <> 0 -> Z.sgn (a mod b) = Z.sgn b. Proof. intros; nia. Qed. +Example Z_div_exact_full_2: forall a b : Z, b <> 0 -> a mod b = 0 -> a = b * (a / b). Proof. intros; nia. Qed. +Example Z_div_mod: forall a b : Z, b <> 0 -> a = b * (a / b) + a mod b. Proof. intros; nia. Qed. +Example Z_add_mod: forall a b n : Z, n <> 0 -> (a + b) mod n = (a mod n + b mod n) mod n. +Proof. + intros a b n ?. + assert ((a + b) / n = (a / n) + (b / n) + (a mod n + b mod n) / n) by nia. + nia. +Qed. +Example Z_mul_mod: forall a b n : Z, n <> 0 -> (a * b) mod n = (a mod n * (b mod n)) mod n. +Proof. + intros a b n ?. + assert ((a * b) / n = (b / n) * (a / n) * n + (b / n) * (a mod n) + (b mod n) * (a / n) + ((a mod n) * (b mod n)) / n) + by nia. + nia. +Qed. +Example Z_div_exact: forall a b : Z, b <> 0 -> a = b * (a / b) <-> a mod b = 0. Proof. intros; nia. Qed. +Example Z_div_opp_l_z: forall a b : Z, b <> 0 -> a mod b = 0 -> - a / b = - (a / b). Proof. intros; nia. Qed. +Example Z_div_opp_r_z: forall a b : Z, b <> 0 -> a mod b = 0 -> a / - b = - (a / b). Proof. intros; nia. Qed. +Example Z_mod_opp_r_nz: forall a b : Z, b <> 0 -> a mod b <> 0 -> a mod - b = a mod b - b. +Proof. + intros a b. + assert (a mod b <> 0 -> a/(-b) = -1-a/b) by nia. + nia. +Qed. +Example Z_mul_mod_distr_r: forall a b c : Z, b <> 0 -> c <> 0 -> (a * c) mod (b * c) = a mod b * c. +Proof. + intros a b c. + pose proof (Z_eq_dec_or ((a*c)/(b*c)) (a/b)). + nia. +Qed. +Example Z_mul_mod_distr_l: forall a b c : Z, b <> 0 -> c <> 0 -> (c * a) mod (c * b) = c * (a mod b). +Proof. + intros a b c. + pose proof (Z_eq_dec_or ((c*a)/(c*b)) (a/b)). + nia. +Qed. +Example Z_mod_opp_l_nz: forall a b : Z, b <> 0 -> a mod b <> 0 -> - a mod b = b - a mod b. +Proof. + intros a b. + assert (a mod b <> 0 -> -a/b = -1-a/b) by nia. + nia. +Qed. +Example mod_eq: forall x x' y : Z, x / y = x' / y -> x mod y = x' mod y -> y <> 0 -> x = x'. Proof. intros; nia. Qed. +Example Z_div_nz_opp_r: forall a b : Z, a mod b <> 0 -> a / - b = - (a / b) - 1. Proof. intros; nia. Qed. +Example Z_div_nz_opp_full: forall a b : Z, a mod b <> 0 -> - a / b = - (a / b) - 1. Proof. intros; nia. Qed. +Example Zmod_unique: forall a b q r : Z, 0 <= r < b -> a = b * q + r -> r = a mod b. +Proof. + intros a b q r ??. + assert (q = a / b) by nia. + nia. +Qed. +Example Z_mod_unique_neg: forall a b q r : Z, b < r <= 0 -> a = b * q + r -> r = a mod b. +Proof. + intros a b q r ??. + assert (q = a / b) by nia. + nia. +Qed. +Example Z_mod_unique_pos: forall a b q r : Z, 0 <= r < b -> a = b * q + r -> r = a mod b. +Proof. + intros a b q r ??. + assert (q = a / b) by nia. + nia. +Qed. +Example Z_rem_mul_r: forall a b c : Z, b <> 0 -> 0 < c -> a mod (b * c) = a mod b + b * ((a / b) mod c). +Proof. + intros a b c ??. + assert (a / (b * c) = ((a / b) / c)) by nia. + nia. +Qed. +Example Z_mod_bound_or: forall a b : Z, b <> 0 -> 0 <= a mod b < b \/ b < a mod b <= 0. Proof. intros; nia. Qed. +Example Z_div_opp_l_nz: forall a b : Z, b <> 0 -> a mod b <> 0 -> - a / b = - (a / b) - 1. Proof. intros; nia. Qed. +Example Z_div_opp_r_nz: forall a b : Z, b <> 0 -> a mod b <> 0 -> a / - b = - (a / b) - 1. Proof. intros; nia. Qed. +Example Z_mod_small_iff: forall a b : Z, b <> 0 -> a mod b = a <-> 0 <= a < b \/ b < a <= 0. Proof. t. Qed. +Example Z_mod_unique: forall a b q r : Z, 0 <= r < b \/ b < r <= 0 -> a = b * q + r -> r = a mod b. +Proof. + intros a b q r ??. + assert (q = a/b) by nia. + nia. +Qed. +Example Z_opp_mod_bound_or: forall a b : Z, b <> 0 -> 0 <= - (a mod b) < - b \/ - b < - (a mod b) <= 0. Proof. intros; nia. Qed. + +Example Zdiv_0_r: forall a : Z, a / 0 = 0. Proof. intros; nia. Qed. +Example Zdiv_0_l: forall a : Z, 0 / a = 0. Proof. intros; nia. Qed. +Example Z_div_1_r: forall a : Z, a / 1 = a. Proof. intros; nia. Qed. +Example Zdiv_1_r: forall a : Z, a / 1 = a. Proof. intros; nia. Qed. +Example Zdiv_opp_opp: forall a b : Z, - a / - b = a / b. Proof. intros; nia. Qed. +Example Z_div_0_l: forall a : Z, a <> 0 -> 0 / a = 0. Proof. intros; nia. Qed. +Example Z_div_pos: forall a b : Z, b > 0 -> 0 <= a -> 0 <= a / b. Proof. intros; nia. Qed. +Example Z_div_ge0: forall a b : Z, b > 0 -> a >= 0 -> a / b >= 0. Proof. intros; nia. Qed. +Example Z_div_pos': forall a b : Z, 0 <= a -> 0 < b -> 0 <= a / b. Proof. intros; nia. Qed. +Example Z_mult_div_ge: forall a b : Z, b > 0 -> b * (a / b) <= a. Proof. intros; nia. Qed. +Example Z_mult_div_ge_neg: forall a b : Z, b < 0 -> b * (a / b) >= a. Proof. intros; nia. Qed. +Example Z_mul_div_le: forall a b : Z, 0 < b -> b * (a / b) <= a. Proof. intros; nia. Qed. +Example Z_mul_div_ge: forall a b : Z, b < 0 -> a <= b * (a / b). Proof. intros; nia. Qed. +Example Z_div_same: forall a : Z, a > 0 -> a / a = 1. Proof. intros; nia. Qed. +Example Z_div_mult: forall a b : Z, b > 0 -> a * b / b = a. Proof. intros; nia. Qed. +Example Z_mul_succ_div_gt: forall a b : Z, 0 < b -> a < b * Z.succ (a / b). Proof. intros; nia. Qed. +Example Z_mul_succ_div_lt: forall a b : Z, b < 0 -> b * Z.succ (a / b) < a. Proof. intros; nia. Qed. +Example Zdiv_1_l: forall a : Z, 1 < a -> 1 / a = 0. Proof. intros; nia. Qed. +Example Z_div_1_l: forall a : Z, 1 < a -> 1 / a = 0. Proof. intros; nia. Qed. +Example Z_div_str_pos: forall a b : Z, 0 < b <= a -> 0 < a / b. Proof. intros; nia. Qed. +Example Z_div_ge: forall a b c : Z, c > 0 -> a >= b -> a / c >= b / c. Proof. intros; nia. Qed. +Example Z_div_mult_full: forall a b : Z, b <> 0 -> a * b / b = a. Proof. intros; nia. Qed. +Example Z_div_same': forall a : Z, a <> 0 -> a / a = 1. Proof. intros; nia. Qed. +Example Zdiv_lt_upper_bound: forall a b q : Z, 0 < b -> a < q * b -> a / b < q. Proof. intros; nia. Qed. +Example Z_div_mul: forall a b : Z, b <> 0 -> a * b / b = a. Proof. intros; nia. Qed. +Example Z_div_lt: forall a b : Z, 0 < a -> 1 < b -> a / b < a. Proof. intros; nia. Qed. +Example Z_div_le_mono: forall a b c : Z, 0 < c -> a <= b -> a / c <= b / c. Proof. intros; nia. Qed. +Example Zdiv_sgn: forall a b : Z, 0 <= Z.sgn (a / b) * Z.sgn a * Z.sgn b. Proof. intros; nia. Qed. +Example Z_div_same_full: forall a : Z, a <> 0 -> a / a = 1. Proof. intros; nia. Qed. +Example Z_div_lt_upper_bound: forall a b q : Z, 0 < b -> a < b * q -> a / b < q. Proof. intros; nia. Qed. +Example Z_div_le: forall a b c : Z, c > 0 -> a <= b -> a / c <= b / c. Proof. intros; nia. Qed. +Example Z_div_le_lower_bound: forall a b q : Z, 0 < b -> b * q <= a -> q <= a / b. Proof. intros; nia. Qed. +Example Zdiv_le_lower_bound: forall a b q : Z, 0 < b -> q * b <= a -> q <= a / b. Proof. intros; nia. Qed. +Example Zdiv_le_upper_bound: forall a b q : Z, 0 < b -> a <= q * b -> a / b <= q. Proof. intros; nia. Qed. +Example Z_div_le_upper_bound: forall a b q : Z, 0 < b -> a <= b * q -> a / b <= q. Proof. intros; nia. Qed. +Example Z_div_small: forall a b : Z, 0 <= a < b -> a / b = 0. Proof. intros; nia. Qed. +Example Zdiv_small: forall a b : Z, 0 <= a < b -> a / b = 0. Proof. intros; nia. Qed. +Example Z_div_opp_opp: forall a b : Z, b <> 0 -> - a / - b = a / b. Proof. intros; nia. Qed. +Example Zdiv_mult_cancel_r: forall a b c : Z, c <> 0 -> a * c / (b * c) = a / b. Proof. intros; nia. Qed. +Example Z_div_unique_exact: forall a b q : Z, b <> 0 -> a = b * q -> q = a / b. Proof. intros; nia. Qed. +Example Zdiv_mult_cancel_l: forall a b c : Z, c <> 0 -> c * a / (c * b) = a / b. Proof. intros; nia. Qed. +Example Zdiv_le_compat_l: forall p q r : Z, 0 <= p -> 0 < q < r -> p / r <= p / q. +Proof. + intros p q r ??. + assert (p mod r <= p mod q \/ p mod q <= p mod r) by nia. + assert (0 <= p / r) by nia. + assert (0 <= p / q) by nia. + nia. +Qed. +Example Z_div_le_compat_l: forall p q r : Z, 0 <= p -> 0 < q <= r -> p / r <= p / q. +Proof. + intros p q r ??. + assert (p mod r <= p mod q \/ p mod q <= p mod r) by nia. + assert (0 <= p / r) by nia. + assert (0 <= p / q) by nia. + nia. +Qed. +Example Zdiv_Zdiv: forall a b c : Z, 0 <= b -> 0 <= c -> a / b / c = a / (b * c). Proof. intros; nia. Qed. +Example Z_div_plus: forall a b c : Z, c > 0 -> (a + b * c) / c = a / c + b. Proof. intros; nia. Qed. +Example Z_div_lt': forall a b : Z, b >= 2 -> a > 0 -> a / b < a. Proof. intros; nia. Qed. +Example Zdiv_mult_le: forall a b c : Z, 0 <= a -> 0 <= b -> 0 <= c -> c * (a / b) <= c * a / b. Proof. intros; nia. Qed. +Example Z_div_add_l: forall a b c : Z, b <> 0 -> (a * b + c) / b = a + c / b. Proof. intros; nia. Qed. +Example Z_div_plus_full_l: forall a b c : Z, b <> 0 -> (a * b + c) / b = a + c / b. Proof. intros; nia. Qed. +Example Z_div_add: forall a b c : Z, c <> 0 -> (a + b * c) / c = a / c + b. Proof. intros; nia. Qed. +Example Z_div_plus_full: forall a b c : Z, c <> 0 -> (a + b * c) / c = a / c + b. Proof. intros; nia. Qed. +Example Z_div_mul_le: forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a / b) <= c * a / b. Proof. intros; nia. Qed. +Example Z_div_mul_cancel_r: forall a b c : Z, b <> 0 -> c <> 0 -> a * c / (b * c) = a / b. Proof. intros; nia. Qed. +Example Z_div_div: forall a b c : Z, b <> 0 -> 0 < c -> a / b / c = a / (b * c). Proof. intros; nia. Qed. +Example Z_div_mul_cancel_l: forall a b c : Z, b <> 0 -> c <> 0 -> c * a / (c * b) = a / b. Proof. intros; nia. Qed. +Example Z_div_unique_neg: forall a b q r : Z, b < r <= 0 -> a = b * q + r -> q = a / b. Proof. intros; nia. Qed. +Example Zdiv_unique: forall a b q r : Z, 0 <= r < b -> a = b * q + r -> q = a / b. Proof. intros; nia. Qed. +Example Z_div_unique_pos: forall a b q r : Z, 0 <= r < b -> a = b * q + r -> q = a / b. Proof. intros; nia. Qed. +Example Z_div_small_iff: forall a b : Z, b <> 0 -> a / b = 0 <-> 0 <= a < b \/ b < a <= 0. Proof. intros; nia. Qed. +Example Z_div_unique: forall a b q r : Z, 0 <= r < b \/ b < r <= 0 -> a = b * q + r -> q = a / b. Proof. intros; nia. Qed. + +(** Now we do the same, but with [Z.quot] and [Z.rem] instead. *) +Lemma N2Z_inj_quot : forall n m : N, Z.of_N (n / m) = Z.of_N n ÷ Z.of_N m. Proof. intros; nia. Qed. +Lemma N2Z_inj_rem : forall n m : N, Z.of_N (n mod m) = Z.rem (Z.of_N n) (Z.of_N m). Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_mul_quot_ge : forall a b : Z, a <= 0 -> b <> 0 -> a <= b * (a ÷ b) <= 0. +Proof. intros; destruct (Z_zerop (a ÷ b)); nia. Qed. +Lemma OrdersEx_Z_as_DT_mul_quot_le : forall a b : Z, 0 <= a -> b <> 0 -> 0 <= b * (a ÷ b) <= a. Proof. intros; destruct (Z_zerop (a ÷ b)); nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_0_l : forall a : Z, 0 < a -> 0 ÷ a = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_1_l : forall a : Z, 1 < a -> 1 ÷ a = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_1_r : forall a : Z, 0 <= a -> a ÷ 1 = a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_add : forall a b c : Z, 0 <= a -> 0 <= a + b * c -> 0 < c -> (a + b * c) ÷ c = a ÷ c + b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_add_l : forall a b c : Z, 0 <= c -> 0 <= a * b + c -> 0 < b -> (a * b + c) ÷ b = a + c ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_div : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> a ÷ b ÷ c = a ÷ (b * c). +Proof. intros; assert (0 < b * c) by nia; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_le_compat_l : forall p q r : Z, 0 <= p -> 0 < q <= r -> p ÷ r <= p ÷ q. +Proof. + intros. + destruct (Z_zerop p), (Z_zerop (p ÷ r)), (Z_zerop (p ÷ q)); subst; [ nia.. | ]. + assert (0 < q) by nia; assert (0 < r) by nia; assert (0 < p) by nia. + nia. +Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_le_lower_bound : forall a b q : Z, 0 <= a -> 0 < b -> b * q <= a -> q <= a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_le_mono : forall a b c : Z, 0 < c -> 0 <= a <= b -> a ÷ c <= b ÷ c. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_le_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a <= b * q -> a ÷ b <= q. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_lt : forall a b : Z, 0 < a -> 1 < b -> a ÷ b < a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < b * q -> a ÷ b < q. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_mul_cancel_l : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> c * a ÷ (c * b) = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_mul_cancel_r : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> a * c ÷ (b * c) = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_mul : forall a b : Z, 0 <= a -> 0 < b -> a * b ÷ b = a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_mul_le : forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a ÷ b) <= c * a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_same : forall a : Z, 0 < a -> a ÷ a = 1. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_small : forall a b : Z, 0 <= a < b -> a ÷ b = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_small_iff : forall a b : Z, 0 <= a -> 0 < b -> a ÷ b = 0 <-> a < b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_str_pos : forall a b : Z, 0 < b <= a -> 0 < a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_str_pos_iff : forall a b : Z, 0 <= a -> 0 < b -> 0 < a ÷ b <-> b <= a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_unique_exact : forall a b q : Z, 0 <= a -> 0 < b -> a = b * q -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_div_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_Private_Div_NZQuot_mul_div_le : forall a b : Z, 0 <= a -> 0 < b -> b * (a ÷ b) <= a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_0_l : forall a : Z, a <> 0 -> 0 ÷ a = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_1_l : forall a : Z, 1 < a -> 1 ÷ a = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_1_r : forall a : Z, a ÷ 1 = a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_add : forall a b c : Z, c <> 0 -> 0 <= (a + b * c) * a -> (a + b * c) ÷ c = a ÷ c + b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_add_l : forall a b c : Z, b <> 0 -> 0 <= (a * b + c) * c -> (a * b + c) ÷ b = a + c ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_div_nonneg : forall a b : Z, 0 <= a -> 0 < b -> a ÷ b = a / b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_le_compat_l : forall p q r : Z, 0 <= p -> 0 < q <= r -> p ÷ r <= p ÷ q. +Proof. + intros. + destruct (Z_zerop p), (Z_zerop (p ÷ r)), (Z_zerop (p ÷ q)); [ subst; nia.. | ]. + assert (0 < p) by nia; assert (0 < r) by nia. + nia. +Qed. +Lemma OrdersEx_Z_as_DT_quot_le_lower_bound : forall a b q : Z, 0 < b -> b * q <= a -> q <= a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_le_mono : forall a b c : Z, 0 < c -> a <= b -> a ÷ c <= b ÷ c. +Proof. + intros. + destruct (Z_zerop a), (Z_zerop b), (Z_zerop (a ÷ c)), (Z_zerop (b ÷ c)); [ subst; nia.. | ]. + nia. +Qed. +Lemma OrdersEx_Z_as_DT_quot_le_upper_bound : forall a b q : Z, 0 < b -> a <= b * q -> a ÷ b <= q. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_lt : forall a b : Z, 0 < a -> 1 < b -> a ÷ b < a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < b * q -> a ÷ b < q. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_mul_cancel_l : forall a b c : Z, b <> 0 -> c <> 0 -> c * a ÷ (c * b) = a ÷ b. +Proof. + intros. + assert (c * b <> 0) by nia. + destruct (Z_zerop a), (Z_zerop (c * a)); subst; [ nia | exfalso; nia.. | ]. +Abort. +Lemma OrdersEx_Z_as_DT_quot_mul_cancel_r : forall a b c : Z, b <> 0 -> c <> 0 -> a * c ÷ (b * c) = a ÷ b. Proof. Abort. +Lemma OrdersEx_Z_as_DT_quot_mul : forall a b : Z, b <> 0 -> a * b ÷ b = a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_mul_le : forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a ÷ b) <= c * a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_opp_l : forall a b : Z, b <> 0 -> - a ÷ b = - (a ÷ b). Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_opp_opp : forall a b : Z, b <> 0 -> - a ÷ - b = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_opp_r : forall a b : Z, b <> 0 -> a ÷ - b = - (a ÷ b). Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_quot : forall a b c : Z, b <> 0 -> c <> 0 -> a ÷ b ÷ c = a ÷ (b * c). Proof. intros; assert (b * c <> 0) by nia. Abort. +Lemma OrdersEx_Z_as_DT_quot_same : forall a : Z, a <> 0 -> a ÷ a = 1. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_small : forall a b : Z, 0 <= a < b -> a ÷ b = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_str_pos : forall a b : Z, 0 < b <= a -> 0 < a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_unique_exact : forall a b q : Z, b <> 0 -> a = b * q -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_DT_quot_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_mul_quot_ge : forall a b : Z, a <= 0 -> b <> 0 -> a <= b * (a ÷ b) <= 0. Proof. intros. Fail nia. Abort. +Lemma OrdersEx_Z_as_OT_mul_quot_le : forall a b : Z, 0 <= a -> b <> 0 -> 0 <= b * (a ÷ b) <= a. Proof. intros. Fail nia. Abort. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_0_l : forall a : Z, 0 < a -> 0 ÷ a = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_1_l : forall a : Z, 1 < a -> 1 ÷ a = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_1_r : forall a : Z, 0 <= a -> a ÷ 1 = a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_add : forall a b c : Z, 0 <= a -> 0 <= a + b * c -> 0 < c -> (a + b * c) ÷ c = a ÷ c + b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_add_l : forall a b c : Z, 0 <= c -> 0 <= a * b + c -> 0 < b -> (a * b + c) ÷ b = a + c ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_div : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> a ÷ b ÷ c = a ÷ (b * c). Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_le_compat_l : forall p q r : Z, 0 <= p -> 0 < q <= r -> p ÷ r <= p ÷ q. Proof. intros. Abort. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_le_lower_bound : forall a b q : Z, 0 <= a -> 0 < b -> b * q <= a -> q <= a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_le_mono : forall a b c : Z, 0 < c -> 0 <= a <= b -> a ÷ c <= b ÷ c. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_le_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a <= b * q -> a ÷ b <= q. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_lt : forall a b : Z, 0 < a -> 1 < b -> a ÷ b < a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < b * q -> a ÷ b < q. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_mul_cancel_l : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> c * a ÷ (c * b) = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_mul_cancel_r : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> a * c ÷ (b * c) = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_mul : forall a b : Z, 0 <= a -> 0 < b -> a * b ÷ b = a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_mul_le : forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a ÷ b) <= c * a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_same : forall a : Z, 0 < a -> a ÷ a = 1. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_small : forall a b : Z, 0 <= a < b -> a ÷ b = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_small_iff : forall a b : Z, 0 <= a -> 0 < b -> a ÷ b = 0 <-> a < b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_str_pos : forall a b : Z, 0 < b <= a -> 0 < a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_str_pos_iff : forall a b : Z, 0 <= a -> 0 < b -> 0 < a ÷ b <-> b <= a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_unique_exact : forall a b q : Z, 0 <= a -> 0 < b -> a = b * q -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_div_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_Private_Div_NZQuot_mul_div_le : forall a b : Z, 0 <= a -> 0 < b -> b * (a ÷ b) <= a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_0_l : forall a : Z, a <> 0 -> 0 ÷ a = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_1_l : forall a : Z, 1 < a -> 1 ÷ a = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_1_r : forall a : Z, a ÷ 1 = a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_add : forall a b c : Z, c <> 0 -> 0 <= (a + b * c) * a -> (a + b * c) ÷ c = a ÷ c + b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_add_l : forall a b c : Z, b <> 0 -> 0 <= (a * b + c) * c -> (a * b + c) ÷ b = a + c ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_div_nonneg : forall a b : Z, 0 <= a -> 0 < b -> a ÷ b = a / b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_le_compat_l : forall p q r : Z, 0 <= p -> 0 < q <= r -> p ÷ r <= p ÷ q. Proof. intros. Fail nia. Abort. +Lemma OrdersEx_Z_as_OT_quot_le_lower_bound : forall a b q : Z, 0 < b -> b * q <= a -> q <= a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_le_mono : forall a b c : Z, 0 < c -> a <= b -> a ÷ c <= b ÷ c. Proof. intros. Fail nia. Abort. +Lemma OrdersEx_Z_as_OT_quot_le_upper_bound : forall a b q : Z, 0 < b -> a <= b * q -> a ÷ b <= q. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_lt : forall a b : Z, 0 < a -> 1 < b -> a ÷ b < a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < b * q -> a ÷ b < q. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_mul_cancel_l : forall a b c : Z, b <> 0 -> c <> 0 -> c * a ÷ (c * b) = a ÷ b. Proof. intros. Abort. +Lemma OrdersEx_Z_as_OT_quot_mul_cancel_r : forall a b c : Z, b <> 0 -> c <> 0 -> a * c ÷ (b * c) = a ÷ b. Proof. intros. Abort. +Lemma OrdersEx_Z_as_OT_quot_mul : forall a b : Z, b <> 0 -> a * b ÷ b = a. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_mul_le : forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a ÷ b) <= c * a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_opp_l : forall a b : Z, b <> 0 -> - a ÷ b = - (a ÷ b). Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_opp_opp : forall a b : Z, b <> 0 -> - a ÷ - b = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_opp_r : forall a b : Z, b <> 0 -> a ÷ - b = - (a ÷ b). Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_quot : forall a b c : Z, b <> 0 -> c <> 0 -> a ÷ b ÷ c = a ÷ (b * c). Proof. intros. Abort. +Lemma OrdersEx_Z_as_OT_quot_same : forall a : Z, a <> 0 -> a ÷ a = 1. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_small : forall a b : Z, 0 <= a < b -> a ÷ b = 0. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_str_pos : forall a b : Z, 0 < b <= a -> 0 < a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_unique_exact : forall a b q : Z, b <> 0 -> a = b * q -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma OrdersEx_Z_as_OT_quot_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma Z2N_inj_quot : forall n m : Z, 0 <= n -> 0 <= m -> Z.to_N (n ÷ m) = (Z.to_N n / Z.to_N m)%N. +Proof. intros; destruct (Z_zerop n), (Z_zerop m), (Z_zerop (n ÷ m)); [ subst; try nia.. | ]. Abort. +Lemma Z2N_inj_rem : forall n m : Z, 0 <= n -> 0 <= m -> Z.to_N (Z.rem n m) = (Z.to_N n mod Z.to_N m)%N. Proof. intros. Abort. +Lemma Zabs2N_inj_quot : forall n m : Z, Z.abs_N (n ÷ m) = (Z.abs_N n / Z.abs_N m)%N. Proof. intros. Abort. +Lemma Zabs2N_inj_rem : forall n m : Z, Z.abs_N (Z.rem n m) = (Z.abs_N n mod Z.abs_N m)%N. Proof. intros. Abort. +(* Some of these don't work, and I haven't gone through and figured out which ones yet, so they're all commented out for now *) +(* +Lemma Z_add_rem : forall a b n : Z, n <> 0 -> 0 <= a * b -> Z.rem (a + b) n = Z.rem (Z.rem a n + Z.rem b n) n. Proof. intros; nia. Qed. +Lemma Z_add_rem_idemp_l : forall a b n : Z, n <> 0 -> 0 <= a * b -> Z.rem (Z.rem a n + b) n = Z.rem (a + b) n. Proof. intros; nia. Qed. +Lemma Z_add_rem_idemp_r : forall a b n : Z, n <> 0 -> 0 <= a * b -> Z.rem (a + Z.rem b n) n = Z.rem (a + b) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_add_rem : forall a b n : Z, n <> 0 -> 0 <= a * b -> ZBinary.Z.rem (a + b) n = ZBinary.Z.rem (ZBinary.Z.rem a n + ZBinary.Z.rem b n) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_add_rem_idemp_l : forall a b n : Z, n <> 0 -> 0 <= a * b -> ZBinary.Z.rem (ZBinary.Z.rem a n + b) n = ZBinary.Z.rem (a + b) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_add_rem_idemp_r : forall a b n : Z, n <> 0 -> 0 <= a * b -> ZBinary.Z.rem (a + ZBinary.Z.rem b n) n = ZBinary.Z.rem (a + b) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_gcd_quot_gcd : forall a b g : Z, g <> 0 -> g = ZBinary.Z.gcd a b -> ZBinary.Z.gcd (a ÷ g) (b ÷ g) = 1. Proof. intros; nia. Qed. +Lemma ZBinary_Z_gcd_rem : forall a b : Z, b <> 0 -> ZBinary.Z.gcd (ZBinary.Z.rem a b) b = ZBinary.Z.gcd b a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_mod_mul_r : forall a b c : Z, b <> 0 -> c <> 0 -> ZBinary.Z.rem a (b * c) = ZBinary.Z.rem a b + b * ZBinary.Z.rem (a ÷ b) c. Proof. intros; nia. Qed. +Lemma ZBinary_Z_mul_pred_quot_gt : forall a b : Z, 0 <= a -> b < 0 -> a < b * ZBinary.Z.pred (a ÷ b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_mul_pred_quot_lt : forall a b : Z, a <= 0 -> 0 < b -> b * ZBinary.Z.pred (a ÷ b) < a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_mul_quot_ge : forall a b : Z, a <= 0 -> b <> 0 -> a <= b * (a ÷ b) <= 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_mul_quot_le : forall a b : Z, 0 <= a -> b <> 0 -> 0 <= b * (a ÷ b) <= a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_mul_rem_distr_l : forall a b c : Z, b <> 0 -> c <> 0 -> ZBinary.Z.rem (c * a) (c * b) = c * ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_mul_rem_distr_r : forall a b c : Z, b <> 0 -> c <> 0 -> ZBinary.Z.rem (a * c) (b * c) = ZBinary.Z.rem a b * c. Proof. intros; nia. Qed. +Lemma ZBinary_Z_mul_rem : forall a b n : Z, n <> 0 -> ZBinary.Z.rem (a * b) n = ZBinary.Z.rem (ZBinary.Z.rem a n * ZBinary.Z.rem b n) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_mul_rem_idemp_l : forall a b n : Z, n <> 0 -> ZBinary.Z.rem (ZBinary.Z.rem a n * b) n = ZBinary.Z.rem (a * b) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_mul_rem_idemp_r : forall a b n : Z, n <> 0 -> ZBinary.Z.rem (a * ZBinary.Z.rem b n) n = ZBinary.Z.rem (a * b) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_mul_succ_quot_gt : forall a b : Z, 0 <= a -> 0 < b -> a < b * ZBinary.Z.succ (a ÷ b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_mul_succ_quot_lt : forall a b : Z, a <= 0 -> b < 0 -> b * ZBinary.Z.succ (a ÷ b) < a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_add_mod : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> ZBinary.Z.rem (a + b) n = ZBinary.Z.rem (ZBinary.Z.rem a n + ZBinary.Z.rem b n) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_add_mod_idemp_l : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> ZBinary.Z.rem (ZBinary.Z.rem a n + b) n = ZBinary.Z.rem (a + b) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_add_mod_idemp_r : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> ZBinary.Z.rem (a + ZBinary.Z.rem b n) n = ZBinary.Z.rem (a + b) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_0_l : forall a : Z, 0 < a -> 0 ÷ a = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_1_l : forall a : Z, 1 < a -> 1 ÷ a = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_1_r : forall a : Z, 0 <= a -> a ÷ 1 = a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_add : forall a b c : Z, 0 <= a -> 0 <= a + b * c -> 0 < c -> (a + b * c) ÷ c = a ÷ c + b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_add_l : forall a b c : Z, 0 <= c -> 0 <= a * b + c -> 0 < b -> (a * b + c) ÷ b = a + c ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_div : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> a ÷ b ÷ c = a ÷ (b * c). Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_exact : forall a b : Z, 0 <= a -> 0 < b -> a = b * (a ÷ b) <-> ZBinary.Z.rem a b = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_le_compat_l : forall p q r : Z, 0 <= p -> 0 < q <= r -> p ÷ r <= p ÷ q. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_le_lower_bound : forall a b q : Z, 0 <= a -> 0 < b -> b * q <= a -> q <= a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_le_mono : forall a b c : Z, 0 < c -> 0 <= a <= b -> a ÷ c <= b ÷ c. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_le_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a <= b * q -> a ÷ b <= q. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_lt : forall a b : Z, 0 < a -> 1 < b -> a ÷ b < a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < b * q -> a ÷ b < q. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_mul_cancel_l : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> c * a ÷ (c * b) = a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_mul_cancel_r : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> a * c ÷ (b * c) = a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_mul : forall a b : Z, 0 <= a -> 0 < b -> a * b ÷ b = a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_mul_le : forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a ÷ b) <= c * a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_same : forall a : Z, 0 < a -> a ÷ a = 1. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_small : forall a b : Z, 0 <= a < b -> a ÷ b = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_small_iff : forall a b : Z, 0 <= a -> 0 < b -> a ÷ b = 0 <-> a < b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_str_pos : forall a b : Z, 0 < b <= a -> 0 < a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_str_pos_iff : forall a b : Z, 0 <= a -> 0 < b -> 0 < a ÷ b <-> b <= a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_unique_exact : forall a b q : Z, 0 <= a -> 0 < b -> a = b * q -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_div_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_0_l : forall a : Z, 0 < a -> ZBinary.Z.rem 0 a = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_1_l : forall a : Z, 1 < a -> ZBinary.Z.rem 1 a = 1. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_1_r : forall a : Z, 0 <= a -> ZBinary.Z.rem a 1 = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_add : forall a b c : Z, 0 <= a -> 0 <= a + b * c -> 0 < c -> ZBinary.Z.rem (a + b * c) c = ZBinary.Z.rem a c. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_divides : forall a b : Z, 0 <= a -> 0 < b -> ZBinary.Z.rem a b = 0 <-> (exists c : Z, a = b * c). Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_le : forall a b : Z, 0 <= a -> 0 < b -> ZBinary.Z.rem a b <= a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_mod : forall a n : Z, 0 <= a -> 0 < n -> ZBinary.Z.rem (ZBinary.Z.rem a n) n = ZBinary.Z.rem a n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_mul : forall a b : Z, 0 <= a -> 0 < b -> ZBinary.Z.rem (a * b) b = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_mul_r : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> ZBinary.Z.rem a (b * c) = ZBinary.Z.rem a b + b * ZBinary.Z.rem (a ÷ b) c. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_same : forall a : Z, 0 < a -> ZBinary.Z.rem a a = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_small : forall a b : Z, 0 <= a < b -> ZBinary.Z.rem a b = a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_small_iff : forall a b : Z, 0 <= a -> 0 < b -> ZBinary.Z.rem a b = a <-> a < b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mod_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> r = ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mul_div_le : forall a b : Z, 0 <= a -> 0 < b -> b * (a ÷ b) <= a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mul_mod_distr_l : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> ZBinary.Z.rem (c * a) (c * b) = c * ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mul_mod_distr_r : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> ZBinary.Z.rem (a * c) (b * c) = ZBinary.Z.rem a b * c. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mul_mod : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> ZBinary.Z.rem (a * b) n = ZBinary.Z.rem (ZBinary.Z.rem a n * ZBinary.Z.rem b n) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mul_mod_idemp_l : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> ZBinary.Z.rem (ZBinary.Z.rem a n * b) n = ZBinary.Z.rem (a * b) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mul_mod_idemp_r : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> ZBinary.Z.rem (a * ZBinary.Z.rem b n) n = ZBinary.Z.rem (a * b) n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_NZQuot_mul_succ_div_gt : forall a b : Z, 0 <= a -> 0 < b -> a < b * ZBinary.Z.succ (a ÷ b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_Private_Div_Quot2Div_div_mod : forall a b : Z, b <> 0 -> a = b * (a ÷ b) + ZBinary.Z.rem a b. Proof. intros; nia. Qed. +ZBinary_Z_Private_Div_Quot2Div_div_wd Morphisms.Proper (Morphisms.respectful eq (Morphisms.respectful eq eq)) ZBinary.Z.quot +Lemma ZBinary_Z_Private_Div_Quot2Div_mod_bound_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= ZBinary.Z.rem a b < b. Proof. intros; nia. Qed. +ZBinary_Z_Private_Div_Quot2Div_mod_wd Morphisms.Proper (Morphisms.respectful eq (Morphisms.respectful eq eq)) ZBinary.Z.rem +Lemma ZBinary_Z_quot_0_l : forall a : Z, a <> 0 -> 0 ÷ a = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_1_l : forall a : Z, 1 < a -> 1 ÷ a = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_1_r : forall a : Z, a ÷ 1 = a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_abs : forall a b : Z, b <> 0 -> ZBinary.Z.abs a ÷ ZBinary.Z.abs b = ZBinary.Z.abs (a ÷ b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_abs_l : forall a b : Z, b <> 0 -> ZBinary.Z.abs a ÷ b = ZBinary.Z.sgn a * (a ÷ b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_abs_r : forall a b : Z, b <> 0 -> a ÷ ZBinary.Z.abs b = ZBinary.Z.sgn b * (a ÷ b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_add : forall a b c : Z, c <> 0 -> 0 <= (a + b * c) * a -> (a + b * c) ÷ c = a ÷ c + b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_add_l : forall a b c : Z, b <> 0 -> 0 <= (a * b + c) * c -> (a * b + c) ÷ b = a + c ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_div : forall a b : Z, b <> 0 -> a ÷ b = ZBinary.Z.sgn a * ZBinary.Z.sgn b * (ZBinary.Z.abs a / ZBinary.Z.abs b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_div_nonneg : forall a b : Z, 0 <= a -> 0 < b -> a ÷ b = a / b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_exact : forall a b : Z, b <> 0 -> a = b * (a ÷ b) <-> ZBinary.Z.rem a b = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_le_compat_l : forall p q r : Z, 0 <= p -> 0 < q <= r -> p ÷ r <= p ÷ q. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_le_lower_bound : forall a b q : Z, 0 < b -> b * q <= a -> q <= a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_le_mono : forall a b c : Z, 0 < c -> a <= b -> a ÷ c <= b ÷ c. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_le_upper_bound : forall a b q : Z, 0 < b -> a <= b * q -> a ÷ b <= q. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_lt : forall a b : Z, 0 < a -> 1 < b -> a ÷ b < a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < b * q -> a ÷ b < q. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_mul_cancel_l : forall a b c : Z, b <> 0 -> c <> 0 -> c * a ÷ (c * b) = a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_mul_cancel_r : forall a b c : Z, b <> 0 -> c <> 0 -> a * c ÷ (b * c) = a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_mul : forall a b : Z, b <> 0 -> a * b ÷ b = a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_mul_le : forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a ÷ b) <= c * a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_opp_l : forall a b : Z, b <> 0 -> - a ÷ b = - (a ÷ b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_opp_opp : forall a b : Z, b <> 0 -> - a ÷ - b = a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_opp_r : forall a b : Z, b <> 0 -> a ÷ - b = - (a ÷ b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_quot : forall a b c : Z, b <> 0 -> c <> 0 -> a ÷ b ÷ c = a ÷ (b * c). Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_rem' : forall a b : Z, a = b * (a ÷ b) + ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_rem : forall a b : Z, b <> 0 -> a = b * (a ÷ b) + ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_same : forall a : Z, a <> 0 -> a ÷ a = 1. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_small : forall a b : Z, 0 <= a < b -> a ÷ b = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_small_iff : forall a b : Z, b <> 0 -> a ÷ b = 0 <-> ZBinary.Z.abs a < ZBinary.Z.abs b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_str_pos : forall a b : Z, 0 < b <= a -> 0 < a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_unique_exact : forall a b q : Z, b <> 0 -> a = b * q -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_quot_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> q = a ÷ b. Proof. intros; nia. Qed. +ZBinary_Z_quot_wd Morphisms.Proper (Morphisms.respectful ZBinary.Z.eq (Morphisms.respectful ZBinary.Z.eq ZBinary.Z.eq)) ZBinary.Z.quot +Lemma ZBinary_Z_rem_0_l : forall a : Z, a <> 0 -> ZBinary.Z.rem 0 a = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_1_l : forall a : Z, 1 < a -> ZBinary.Z.rem 1 a = 1. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_1_r : forall a : Z, ZBinary.Z.rem a 1 = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_abs : forall a b : Z, b <> 0 -> ZBinary.Z.rem (ZBinary.Z.abs a) (ZBinary.Z.abs b) = ZBinary.Z.abs (ZBinary.Z.rem a b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_abs_l : forall a b : Z, b <> 0 -> ZBinary.Z.rem (ZBinary.Z.abs a) b = ZBinary.Z.abs (ZBinary.Z.rem a b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_abs_r : forall a b : Z, b <> 0 -> ZBinary.Z.rem a (ZBinary.Z.abs b) = ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_add : forall a b c : Z, c <> 0 -> 0 <= (a + b * c) * a -> ZBinary.Z.rem (a + b * c) c = ZBinary.Z.rem a c. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_bound_abs : forall a b : Z, b <> 0 -> ZBinary.Z.abs (ZBinary.Z.rem a b) < ZBinary.Z.abs b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_bound_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= ZBinary.Z.rem a b < b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_eq : forall a b : Z, b <> 0 -> ZBinary.Z.rem a b = a - b * (a ÷ b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_le : forall a b : Z, 0 <= a -> 0 < b -> ZBinary.Z.rem a b <= a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_mod_eq_0 : forall a b : Z, b <> 0 -> ZBinary.Z.rem a b = 0 <-> a mod b = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_mod : forall a b : Z, b <> 0 -> ZBinary.Z.rem a b = ZBinary.Z.sgn a * (ZBinary.Z.abs a mod ZBinary.Z.abs b). Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_mod_nonneg : forall a b : Z, 0 <= a -> 0 < b -> ZBinary.Z.rem a b = a mod b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_mul : forall a b : Z, b <> 0 -> ZBinary.Z.rem (a * b) b = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_nonneg : forall a b : Z, b <> 0 -> 0 <= a -> 0 <= ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_nonpos : forall a b : Z, b <> 0 -> a <= 0 -> ZBinary.Z.rem a b <= 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_opp_l : forall a b : Z, b <> 0 -> ZBinary.Z.rem (- a) b = - ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_opp_l' : forall a b : Z, ZBinary.Z.rem (- a) b = - ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_opp_opp : forall a b : Z, b <> 0 -> ZBinary.Z.rem (- a) (- b) = - ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_opp_r : forall a b : Z, b <> 0 -> ZBinary.Z.rem a (- b) = ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_opp_r' : forall a b : Z, ZBinary.Z.rem a (- b) = ZBinary.Z.rem a b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_quot : forall a b : Z, b <> 0 -> ZBinary.Z.rem a b ÷ b = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_rem : forall a n : Z, n <> 0 -> ZBinary.Z.rem (ZBinary.Z.rem a n) n = ZBinary.Z.rem a n. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_same : forall a : Z, a <> 0 -> ZBinary.Z.rem a a = 0. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_sign : forall a b : Z, a <> 0 -> b <> 0 -> ZBinary.Z.sgn (ZBinary.Z.rem a b) <> - ZBinary.Z.sgn a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_sign_mul : forall a b : Z, b <> 0 -> 0 <= ZBinary.Z.rem a b * a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_sign_nz : forall a b : Z, b <> 0 -> ZBinary.Z.rem a b <> 0 -> ZBinary.Z.sgn (ZBinary.Z.rem a b) = ZBinary.Z.sgn a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_small : forall a b : Z, 0 <= a < b -> ZBinary.Z.rem a b = a. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_small_iff : forall a b : Z, b <> 0 -> ZBinary.Z.rem a b = a <-> ZBinary.Z.abs a < ZBinary.Z.abs b. Proof. intros; nia. Qed. +Lemma ZBinary_Z_rem_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> r = ZBinary.Z.rem a b. Proof. intros; nia. Qed. +ZBinary_Z_rem_wd Morphisms.Proper (Morphisms.respectful ZBinary.Z.eq (Morphisms.respectful ZBinary.Z.eq ZBinary.Z.eq)) ZBinary.Z.rem +Lemma Z_gcd_quot_gcd : forall a b g : Z, g <> 0 -> g = Z.gcd a b -> Z.gcd (a ÷ g) (b ÷ g) = 1. Proof. intros; nia. Qed. +Lemma Z_gcd_rem : forall a b : Z, b <> 0 -> Z.gcd (Z.rem a b) b = Z.gcd b a. Proof. intros; nia. Qed. +Lemma Z_mod_mul_r : forall a b c : Z, b <> 0 -> c <> 0 -> Z.rem a (b * c) = Z.rem a b + b * Z.rem (a ÷ b) c. Proof. intros; nia. Qed. +Lemma Z_mul_pred_quot_gt : forall a b : Z, 0 <= a -> b < 0 -> a < b * Z.pred (a ÷ b). Proof. intros; nia. Qed. +Lemma Z_mul_pred_quot_lt : forall a b : Z, a <= 0 -> 0 < b -> b * Z.pred (a ÷ b) < a. Proof. intros; nia. Qed. +Lemma Z_mul_quot_ge : forall a b : Z, a <= 0 -> b <> 0 -> a <= b * (a ÷ b) <= 0. Proof. intros; nia. Qed. +Lemma Z_mul_quot_le : forall a b : Z, 0 <= a -> b <> 0 -> 0 <= b * (a ÷ b) <= a. Proof. intros; nia. Qed. +Lemma Z_mul_rem_distr_l : forall a b c : Z, b <> 0 -> c <> 0 -> Z.rem (c * a) (c * b) = c * Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_mul_rem_distr_r : forall a b c : Z, b <> 0 -> c <> 0 -> Z.rem (a * c) (b * c) = Z.rem a b * c. Proof. intros; nia. Qed. +Lemma Z_mul_rem : forall a b n : Z, n <> 0 -> Z.rem (a * b) n = Z.rem (Z.rem a n * Z.rem b n) n. Proof. intros; nia. Qed. +Lemma Z_mul_rem_idemp_l : forall a b n : Z, n <> 0 -> Z.rem (Z.rem a n * b) n = Z.rem (a * b) n. Proof. intros; nia. Qed. +Lemma Z_mul_rem_idemp_r : forall a b n : Z, n <> 0 -> Z.rem (a * Z.rem b n) n = Z.rem (a * b) n. Proof. intros; nia. Qed. +Lemma Z_mul_succ_quot_gt : forall a b : Z, 0 <= a -> 0 < b -> a < b * Z.succ (a ÷ b). Proof. intros; nia. Qed. +Lemma Z_mul_succ_quot_lt : forall a b : Z, a <= 0 -> b < 0 -> b * Z.succ (a ÷ b) < a. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_add_mod : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> Z.rem (a + b) n = Z.rem (Z.rem a n + Z.rem b n) n. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_add_mod_idemp_l : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> Z.rem (Z.rem a n + b) n = Z.rem (a + b) n. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_add_mod_idemp_r : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> Z.rem (a + Z.rem b n) n = Z.rem (a + b) n. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_0_l : forall a : Z, 0 < a -> 0 ÷ a = 0. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_1_l : forall a : Z, 1 < a -> 1 ÷ a = 0. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_1_r : forall a : Z, 0 <= a -> a ÷ 1 = a. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_add : forall a b c : Z, 0 <= a -> 0 <= a + b * c -> 0 < c -> (a + b * c) ÷ c = a ÷ c + b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_add_l : forall a b c : Z, 0 <= c -> 0 <= a * b + c -> 0 < b -> (a * b + c) ÷ b = a + c ÷ b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_div : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> a ÷ b ÷ c = a ÷ (b * c). Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_exact : forall a b : Z, 0 <= a -> 0 < b -> a = b * (a ÷ b) <-> Z.rem a b = 0. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_le_compat_l : forall p q r : Z, 0 <= p -> 0 < q <= r -> p ÷ r <= p ÷ q. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_le_lower_bound : forall a b q : Z, 0 <= a -> 0 < b -> b * q <= a -> q <= a ÷ b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_le_mono : forall a b c : Z, 0 < c -> 0 <= a <= b -> a ÷ c <= b ÷ c. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_le_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a <= b * q -> a ÷ b <= q. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_lt : forall a b : Z, 0 < a -> 1 < b -> a ÷ b < a. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < b * q -> a ÷ b < q. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_mul_cancel_l : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> c * a ÷ (c * b) = a ÷ b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_mul_cancel_r : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> a * c ÷ (b * c) = a ÷ b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_mul : forall a b : Z, 0 <= a -> 0 < b -> a * b ÷ b = a. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_mul_le : forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a ÷ b) <= c * a ÷ b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= a ÷ b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_same : forall a : Z, 0 < a -> a ÷ a = 1. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_small : forall a b : Z, 0 <= a < b -> a ÷ b = 0. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_small_iff : forall a b : Z, 0 <= a -> 0 < b -> a ÷ b = 0 <-> a < b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_str_pos : forall a b : Z, 0 < b <= a -> 0 < a ÷ b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_str_pos_iff : forall a b : Z, 0 <= a -> 0 < b -> 0 < a ÷ b <-> b <= a. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_unique_exact : forall a b q : Z, 0 <= a -> 0 < b -> a = b * q -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_div_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_0_l : forall a : Z, 0 < a -> Z.rem 0 a = 0. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_1_l : forall a : Z, 1 < a -> Z.rem 1 a = 1. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_1_r : forall a : Z, 0 <= a -> Z.rem a 1 = 0. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_add : forall a b c : Z, 0 <= a -> 0 <= a + b * c -> 0 < c -> Z.rem (a + b * c) c = Z.rem a c. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_divides : forall a b : Z, 0 <= a -> 0 < b -> Z.rem a b = 0 <-> (exists c : Z, a = b * c). Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_le : forall a b : Z, 0 <= a -> 0 < b -> Z.rem a b <= a. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_mod : forall a n : Z, 0 <= a -> 0 < n -> Z.rem (Z.rem a n) n = Z.rem a n. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_mul : forall a b : Z, 0 <= a -> 0 < b -> Z.rem (a * b) b = 0. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_mul_r : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> Z.rem a (b * c) = Z.rem a b + b * Z.rem (a ÷ b) c. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_same : forall a : Z, 0 < a -> Z.rem a a = 0. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_small : forall a b : Z, 0 <= a < b -> Z.rem a b = a. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_small_iff : forall a b : Z, 0 <= a -> 0 < b -> Z.rem a b = a <-> a < b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mod_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> r = Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mul_div_le : forall a b : Z, 0 <= a -> 0 < b -> b * (a ÷ b) <= a. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mul_mod_distr_l : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> Z.rem (c * a) (c * b) = c * Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mul_mod_distr_r : forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> Z.rem (a * c) (b * c) = Z.rem a b * c. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mul_mod : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> Z.rem (a * b) n = Z.rem (Z.rem a n * Z.rem b n) n. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mul_mod_idemp_l : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> Z.rem (Z.rem a n * b) n = Z.rem (a * b) n. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mul_mod_idemp_r : forall a b n : Z, 0 <= a -> 0 <= b -> 0 < n -> Z.rem (a * Z.rem b n) n = Z.rem (a * b) n. Proof. intros; nia. Qed. +Lemma Z_Private_Div_NZQuot_mul_succ_div_gt : forall a b : Z, 0 <= a -> 0 < b -> a < b * Z.succ (a ÷ b). Proof. intros; nia. Qed. +Lemma Z_Private_Div_Quot2Div_div_mod : forall a b : Z, b <> 0 -> a = b * (a ÷ b) + Z.rem a b. Proof. intros; nia. Qed. +Z_Private_Div_Quot2Div_div_wd Morphisms.Proper (Morphisms.respectful eq (Morphisms.respectful eq eq)) Z.quot +Lemma Z_Private_Div_Quot2Div_mod_bound_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= Z.rem a b < b. Proof. intros; nia. Qed. +Z_Private_Div_Quot2Div_mod_wd Morphisms.Proper (Morphisms.respectful eq (Morphisms.respectful eq eq)) Z.rem +Lemma Z_quot_0_l : forall a : Z, a <> 0 -> 0 ÷ a = 0. Proof. intros; nia. Qed. +Lemma Z_quot_0_r_ext : forall x y : Z, y = 0 -> x ÷ y = 0. Proof. intros; nia. Qed. +Lemma Z_quot_1_l : forall a : Z, 1 < a -> 1 ÷ a = 0. Proof. intros; nia. Qed. +Lemma Z_quot_1_r : forall a : Z, a ÷ 1 = a. Proof. intros; nia. Qed. +Lemma Zquot2_quot : forall n : Z, Z.quot2 n = n ÷ 2. Proof. intros; nia. Qed. +Lemma Z_quot_abs : forall a b : Z, b <> 0 -> Z.abs a ÷ Z.abs b = Z.abs (a ÷ b). Proof. intros; nia. Qed. +Lemma Z_quot_abs_l : forall a b : Z, b <> 0 -> Z.abs a ÷ b = Z.sgn a * (a ÷ b). Proof. intros; nia. Qed. +Lemma Z_quot_abs_r : forall a b : Z, b <> 0 -> a ÷ Z.abs b = Z.sgn b * (a ÷ b). Proof. intros; nia. Qed. +Lemma Z_quot_add : forall a b c : Z, c <> 0 -> 0 <= (a + b * c) * a -> (a + b * c) ÷ c = a ÷ c + b. Proof. intros; nia. Qed. +Lemma Z_quot_add_l : forall a b c : Z, b <> 0 -> 0 <= (a * b + c) * c -> (a * b + c) ÷ b = a + c ÷ b. Proof. intros; nia. Qed. +Lemma Z_quot_div : forall a b : Z, b <> 0 -> a ÷ b = Z.sgn a * Z.sgn b * (Z.abs a / Z.abs b). Proof. intros; nia. Qed. +Lemma Z_quot_div_nonneg : forall a b : Z, 0 <= a -> 0 < b -> a ÷ b = a / b. Proof. intros; nia. Qed. +Lemma Z_quot_exact : forall a b : Z, b <> 0 -> a = b * (a ÷ b) <-> Z.rem a b = 0. Proof. intros; nia. Qed. +Lemma Z_quot_le_compat_l : forall p q r : Z, 0 <= p -> 0 < q <= r -> p ÷ r <= p ÷ q. Proof. intros; nia. Qed. +Lemma Z_quot_le_lower_bound : forall a b q : Z, 0 < b -> b * q <= a -> q <= a ÷ b. Proof. intros; nia. Qed. +Lemma Z_quot_le_mono : forall a b c : Z, 0 < c -> a <= b -> a ÷ c <= b ÷ c. Proof. intros; nia. Qed. +Lemma Z_quot_le_upper_bound : forall a b q : Z, 0 < b -> a <= b * q -> a ÷ b <= q. Proof. intros; nia. Qed. +Lemma Z_quot_lt : forall a b : Z, 0 < a -> 1 < b -> a ÷ b < a. Proof. intros; nia. Qed. +Lemma Z_quot_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < b * q -> a ÷ b < q. Proof. intros; nia. Qed. +Lemma Z_quot_mul_cancel_l : forall a b c : Z, b <> 0 -> c <> 0 -> c * a ÷ (c * b) = a ÷ b. Proof. intros; nia. Qed. +Lemma Z_quot_mul_cancel_r : forall a b c : Z, b <> 0 -> c <> 0 -> a * c ÷ (b * c) = a ÷ b. Proof. intros; nia. Qed. +Lemma Z_quot_mul : forall a b : Z, b <> 0 -> a * b ÷ b = a. Proof. intros; nia. Qed. +Lemma Z_quot_mul_le : forall a b c : Z, 0 <= a -> 0 < b -> 0 <= c -> c * (a ÷ b) <= c * a ÷ b. Proof. intros; nia. Qed. +Lemma Z_quot_opp_l : forall a b : Z, b <> 0 -> - a ÷ b = - (a ÷ b). Proof. intros; nia. Qed. +Lemma Z_quot_opp_opp : forall a b : Z, b <> 0 -> - a ÷ - b = a ÷ b. Proof. intros; nia. Qed. +Lemma Z_quot_opp_r : forall a b : Z, b <> 0 -> a ÷ - b = - (a ÷ b). Proof. intros; nia. Qed. +Lemma Z_quot_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= a ÷ b. Proof. intros; nia. Qed. +Lemma Z_quot_quot : forall a b c : Z, b <> 0 -> c <> 0 -> a ÷ b ÷ c = a ÷ (b * c). Proof. intros; nia. Qed. +Lemma Z_quot_rem' : forall a b : Z, a = b * (a ÷ b) + Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_quot_rem : forall a b : Z, b <> 0 -> a = b * (a ÷ b) + Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_quot_same : forall a : Z, a <> 0 -> a ÷ a = 1. Proof. intros; nia. Qed. +Lemma Z_quot_small : forall a b : Z, 0 <= a < b -> a ÷ b = 0. Proof. intros; nia. Qed. +Lemma Z_quot_small_iff : forall a b : Z, b <> 0 -> a ÷ b = 0 <-> Z.abs a < Z.abs b. Proof. intros; nia. Qed. +Lemma Z_quot_str_pos : forall a b : Z, 0 < b <= a -> 0 < a ÷ b. Proof. intros; nia. Qed. +Lemma Z_quot_unique_exact : forall a b q : Z, b <> 0 -> a = b * q -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma Z_quot_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> q = a ÷ b. Proof. intros; nia. Qed. +Z_quot_wd Morphisms.Proper (Morphisms.respectful Z.eq (Morphisms.respectful Z.eq Z.eq)) Z.quot +Lemma Zquot_Zeven_rem : forall a : Z, Z.even a = (Z.rem a 2 =? 0). Proof. intros; nia. Qed. +Lemma Zquot_Z_mult_quot_ge : forall a b : Z, a <= 0 -> a <= b * (a ÷ b) <= 0. Proof. intros; nia. Qed. +Lemma Zquot_Z_mult_quot_le : forall a b : Z, 0 <= a -> 0 <= b * (a ÷ b) <= a. Proof. intros; nia. Qed. +Lemma Zquot_Zmult_rem_distr_l : forall a b c : Z, Z.rem (c * a) (c * b) = c * Z.rem a b. Proof. intros; nia. Qed. +Lemma Zquot_Zmult_rem_distr_r : forall a b c : Z, Z.rem (a * c) (b * c) = Z.rem a b * c. Proof. intros; nia. Qed. +Lemma Zquot_Zmult_rem : forall a b n : Z, Z.rem (a * b) n = Z.rem (Z.rem a n * Z.rem b n) n. Proof. intros; nia. Qed. +Lemma Zquot_Zmult_rem_idemp_l : forall a b n : Z, Z.rem (Z.rem a n * b) n = Z.rem (a * b) n. Proof. intros; nia. Qed. +Lemma Zquot_Zmult_rem_idemp_r : forall a b n : Z, Z.rem (b * Z.rem a n) n = Z.rem (b * a) n. Proof. intros; nia. Qed. +Lemma Zquot_Zodd_rem : forall a : Z, Z.odd a = negb (Z.rem a 2 =? 0). Proof. intros; nia. Qed. +Lemma Zquot_Zplus_rem : forall a b n : Z, 0 <= a * b -> Z.rem (a + b) n = Z.rem (Z.rem a n + Z.rem b n) n. Proof. intros; nia. Qed. +Lemma Zquot_Zplus_rem_idemp_l : forall a b n : Z, 0 <= a * b -> Z.rem (Z.rem a n + b) n = Z.rem (a + b) n. Proof. intros; nia. Qed. +Lemma Zquot_Zplus_rem_idemp_r : forall a b n : Z, 0 <= a * b -> Z.rem (b + Z.rem a n) n = Z.rem (b + a) n. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_0_l : forall a : Z, 0 ÷ a = 0. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_0_r : forall a : Z, a ÷ 0 = 0. Proof. intros; nia. Qed. +Lemma Zquot_Z_quot_exact_full : forall a b : Z, a = b * (a ÷ b) <-> Z.rem a b = 0. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_le_lower_bound : forall a b q : Z, 0 < b -> q * b <= a -> q <= a ÷ b. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_le_upper_bound : forall a b q : Z, 0 < b -> a <= q * b -> a ÷ b <= q. Proof. intros; nia. Qed. +Lemma Zquot_Z_quot_lt : forall a b : Z, 0 < a -> 2 <= b -> a ÷ b < a. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_lt_upper_bound : forall a b q : Z, 0 <= a -> 0 < b -> a < q * b -> a ÷ b < q. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_mod_unique_full : forall a b q r : Z, Zquot.Remainder a b r -> a = b * q + r -> q = a ÷ b /\ r = Z.rem a b. Proof. intros; nia. Qed. +Lemma Zquot_Z_quot_monotone : forall a b c : Z, 0 <= c -> a <= b -> a ÷ c <= b ÷ c. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_mult_cancel_l : forall a b c : Z, c <> 0 -> c * a ÷ (c * b) = a ÷ b. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_mult_cancel_r : forall a b c : Z, c <> 0 -> a * c ÷ (b * c) = a ÷ b. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_mult_le : forall a b c : Z, 0 <= a -> 0 <= b -> 0 <= c -> c * (a ÷ b) <= c * a ÷ b. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_opp_l : forall a b : Z, - a ÷ b = - (a ÷ b). Proof. intros; nia. Qed. +Lemma Zquot_Zquot_opp_opp : forall a b : Z, - a ÷ - b = a ÷ b. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_opp_r : forall a b : Z, a ÷ - b = - (a ÷ b). Proof. intros; nia. Qed. +Lemma Zquot_Z_quot_plus : forall a b c : Z, 0 <= (a + b * c) * a -> c <> 0 -> (a + b * c) ÷ c = a ÷ c + b. Proof. intros; nia. Qed. +Lemma Zquot_Z_quot_plus_l : forall a b c : Z, 0 <= (a * b + c) * c -> b <> 0 -> b <> 0 -> (a * b + c) ÷ b = a + c ÷ b. Proof. intros; nia. Qed. +Lemma Zquot_Z_quot_pos : forall a b : Z, 0 <= a -> 0 <= b -> 0 <= a ÷ b. Proof. intros; nia. Qed. +Lemma Zquot_Zquotrem_Zdiv_eucl_pos : forall a b : Z, 0 <= a -> 0 < b -> a ÷ b = a / b /\ Z.rem a b = a mod b. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_sgn : forall a b : Z, 0 <= Z.sgn (a ÷ b) * Z.sgn a * Z.sgn b. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_unique_full : forall a b q r : Z, Zquot.Remainder a b r -> a = b * q + r -> q = a ÷ b. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_Zdiv_pos : forall a b : Z, 0 <= a -> 0 <= b -> a ÷ b = a / b. Proof. intros; nia. Qed. +Lemma Zquot_Zquot_Zquot : forall a b c : Z, a ÷ b ÷ c = a ÷ (b * c). Proof. intros; nia. Qed. +Lemma Zquot_Zrem_0_l : forall a : Z, Z.rem 0 a = 0. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_0_r : forall a : Z, Z.rem a 0 = a. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_divides : forall a b : Z, Z.rem a b = 0 <-> (exists c : Z, a = b * c). Proof. intros; nia. Qed. +Lemma Zquot_Zrem_even : forall a : Z, Z.rem a 2 = (if Z.even a then 0 else Z.sgn a). Proof. intros; nia. Qed. +Lemma Zquot_Zrem_le : forall a b : Z, 0 <= a -> 0 <= b -> Z.rem a b <= a. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_lt_neg : forall a b : Z, a <= 0 -> b <> 0 -> - Z.abs b < Z.rem a b <= 0. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_lt_neg_neg : forall a b : Z, a <= 0 -> b < 0 -> b < Z.rem a b <= 0. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_lt_neg_pos : forall a b : Z, a <= 0 -> 0 < b -> - b < Z.rem a b <= 0. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_lt_pos : forall a b : Z, 0 <= a -> b <> 0 -> 0 <= Z.rem a b < Z.abs b. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_lt_pos_neg : forall a b : Z, 0 <= a -> b < 0 -> 0 <= Z.rem a b < - b. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_lt_pos_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= Z.rem a b < b. Proof. intros; nia. Qed. +Lemma Zquot_Z_rem_mult : forall a b : Z, Z.rem (a * b) b = 0. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_odd : forall a : Z, Z.rem a 2 = (if Z.odd a then Z.sgn a else 0). Proof. intros; nia. Qed. +Lemma Zquot_Zrem_opp_l : forall a b : Z, Z.rem (- a) b = - Z.rem a b. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_opp_opp : forall a b : Z, Z.rem (- a) (- b) = - Z.rem a b. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_opp_r : forall a b : Z, Z.rem a (- b) = Z.rem a b. Proof. intros; nia. Qed. +Lemma Zquot_Z_rem_plus : forall a b c : Z, 0 <= (a + b * c) * a -> Z.rem (a + b * c) c = Z.rem a c. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_rem : forall a n : Z, Z.rem (Z.rem a n) n = Z.rem a n. Proof. intros; nia. Qed. +Lemma Zquot_Z_rem_same : forall a : Z, Z.rem a a = 0. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_sgn2 : forall a b : Z, 0 <= Z.rem a b * a. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_sgn : forall a b : Z, 0 <= Z.sgn (Z.rem a b) * Z.sgn a. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_unique_full : forall a b q r : Z, Zquot.Remainder a b r -> a = b * q + r -> r = Z.rem a b. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_Zmod_pos : forall a b : Z, 0 <= a -> 0 < b -> Z.rem a b = a mod b. Proof. intros; nia. Qed. +Lemma Zquot_Zrem_Zmod_zero : forall a b : Z, b <> 0 -> Z.rem a b = 0 <-> a mod b = 0. Proof. intros; nia. Qed. +Lemma Z_rem_0_l : forall a : Z, a <> 0 -> Z.rem 0 a = 0. Proof. intros; nia. Qed. +Lemma Z_rem_0_r_ext : forall x y : Z, y = 0 -> Z.rem x y = x. Proof. intros; nia. Qed. +Lemma Z_rem_1_l : forall a : Z, 1 < a -> Z.rem 1 a = 1. Proof. intros; nia. Qed. +Lemma Z_rem_1_r : forall a : Z, Z.rem a 1 = 0. Proof. intros; nia. Qed. +Lemma Z_rem_abs : forall a b : Z, b <> 0 -> Z.rem (Z.abs a) (Z.abs b) = Z.abs (Z.rem a b). Proof. intros; nia. Qed. +Lemma Z_rem_abs_l : forall a b : Z, b <> 0 -> Z.rem (Z.abs a) b = Z.abs (Z.rem a b). Proof. intros; nia. Qed. +Lemma Z_rem_abs_r : forall a b : Z, b <> 0 -> Z.rem a (Z.abs b) = Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_rem_add : forall a b c : Z, c <> 0 -> 0 <= (a + b * c) * a -> Z.rem (a + b * c) c = Z.rem a c. Proof. intros; nia. Qed. +Lemma Z_rem_bound_abs : forall a b : Z, b <> 0 -> Z.abs (Z.rem a b) < Z.abs b. Proof. intros; nia. Qed. +Lemma Z_rem_bound_neg_neg : forall x y : Z, y < 0 -> x <= 0 -> y < Z.rem x y <= 0. Proof. intros; nia. Qed. +Lemma Z_rem_bound_neg_pos : forall x y : Z, y < 0 -> 0 <= x -> 0 <= Z.rem x y < - y. Proof. intros; nia. Qed. +Lemma Z_rem_bound_pos : forall a b : Z, 0 <= a -> 0 < b -> 0 <= Z.rem a b < b. Proof. intros; nia. Qed. +Lemma Z_rem_bound_pos_neg : forall x y : Z, 0 < y -> x <= 0 -> - y < Z.rem x y <= 0. Proof. intros; nia. Qed. +Lemma Z_rem_bound_pos_pos : forall x y : Z, 0 < y -> 0 <= x -> 0 <= Z.rem x y < y. Proof. intros; nia. Qed. +Lemma Z_rem_eq : forall a b : Z, b <> 0 -> Z.rem a b = a - b * (a ÷ b). Proof. intros; nia. Qed. +Lemma Z_rem_le : forall a b : Z, 0 <= a -> 0 < b -> Z.rem a b <= a. Proof. intros; nia. Qed. +Lemma Z_rem_mod_eq_0 : forall a b : Z, b <> 0 -> Z.rem a b = 0 <-> a mod b = 0. Proof. intros; nia. Qed. +Lemma Z_rem_mod : forall a b : Z, b <> 0 -> Z.rem a b = Z.sgn a * (Z.abs a mod Z.abs b). Proof. intros; nia. Qed. +Lemma Z_rem_mod_nonneg : forall a b : Z, 0 <= a -> 0 < b -> Z.rem a b = a mod b. Proof. intros; nia. Qed. +Lemma Z_rem_mul : forall a b : Z, b <> 0 -> Z.rem (a * b) b = 0. Proof. intros; nia. Qed. +Lemma Z_rem_nonneg : forall a b : Z, b <> 0 -> 0 <= a -> 0 <= Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_rem_nonpos : forall a b : Z, b <> 0 -> a <= 0 -> Z.rem a b <= 0. Proof. intros; nia. Qed. +Lemma Z_rem_opp_l : forall a b : Z, b <> 0 -> Z.rem (- a) b = - Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_rem_opp_l' : forall a b : Z, Z.rem (- a) b = - Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_rem_opp_opp : forall a b : Z, b <> 0 -> Z.rem (- a) (- b) = - Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_rem_opp_r : forall a b : Z, b <> 0 -> Z.rem a (- b) = Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_rem_opp_r' : forall a b : Z, Z.rem a (- b) = Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_rem_quot : forall a b : Z, b <> 0 -> Z.rem a b ÷ b = 0. Proof. intros; nia. Qed. +Lemma Z_rem_rem : forall a n : Z, n <> 0 -> Z.rem (Z.rem a n) n = Z.rem a n. Proof. intros; nia. Qed. +Lemma Z_rem_same : forall a : Z, a <> 0 -> Z.rem a a = 0. Proof. intros; nia. Qed. +Lemma Z_rem_sign : forall a b : Z, a <> 0 -> b <> 0 -> Z.sgn (Z.rem a b) <> - Z.sgn a. Proof. intros; nia. Qed. +Lemma Z_rem_sign_mul : forall a b : Z, b <> 0 -> 0 <= Z.rem a b * a. Proof. intros; nia. Qed. +Lemma Z_rem_sign_nz : forall a b : Z, b <> 0 -> Z.rem a b <> 0 -> Z.sgn (Z.rem a b) = Z.sgn a. Proof. intros; nia. Qed. +Lemma Z_rem_small : forall a b : Z, 0 <= a < b -> Z.rem a b = a. Proof. intros; nia. Qed. +Lemma Z_rem_small_iff : forall a b : Z, b <> 0 -> Z.rem a b = a <-> Z.abs a < Z.abs b. Proof. intros; nia. Qed. +Lemma Z_rem_unique : forall a b q r : Z, 0 <= a -> 0 <= r < b -> a = b * q + r -> r = Z.rem a b. Proof. intros; nia. Qed. +Lemma Z_rem_wd : Morphisms.Proper (Morphisms.respectful Z.eq (Morphisms.respectful Z.eq Z.eq)) Z.rem. Proof. intros; nia. Qed. +*) diff --git a/test-suite/success/Typeclasses.v b/test-suite/success/Typeclasses.v index 400479ae85..3888cafed3 100644 --- a/test-suite/success/Typeclasses.v +++ b/test-suite/success/Typeclasses.v @@ -14,7 +14,7 @@ Module onlyclasses. Module RJung. Class Foo (x : nat). - Instance foo x : x = 2 -> Foo x. + Instance foo x : x = 2 -> Foo x := {}. Hint Extern 0 (_ = _) => reflexivity : typeclass_instances. Typeclasses eauto := debug. Check (_ : Foo 2). @@ -63,7 +63,7 @@ End RefineVsNoTceauto. Module Leivantex2PR339. (** Was a bug preventing to find hints associated with no pattern *) Class Bar := {}. - Instance bar1 (t:Type) : Bar. + Instance bar1 (t:Type) : Bar := {}. Hint Extern 0 => exact True : typeclass_instances. Typeclasses eauto := debug. Goal Bar. @@ -198,7 +198,9 @@ Module UniqueInstances. for it. *) Set Typeclasses Unique Instances. Class Eq (A : Type) : Set. + Set Refine Instance Mode. Instance eqa : Eq nat := _. constructor. Qed. + Unset Refine Instance Mode. Instance eqb : Eq nat := {}. Class Foo (A : Type) (e : Eq A) : Set. Instance fooa : Foo _ eqa := {}. @@ -220,10 +222,10 @@ Module IterativeDeepening. Class B. Class C. - Instance: B -> A | 0. - Instance: C -> A | 0. - Instance: C -> B -> A | 0. - Instance: A -> A | 0. + Instance: B -> A | 0 := {}. + Instance: C -> A | 0 := {}. + Instance: C -> B -> A | 0 := {}. + Instance: A -> A | 0 := {}. Goal C -> A. intros. diff --git a/test-suite/success/auto.v b/test-suite/success/auto.v index 5477c83316..62a66daf7d 100644 --- a/test-suite/success/auto.v +++ b/test-suite/success/auto.v @@ -51,7 +51,7 @@ Qed. Class B (A : Type). Class I. -Instance i : I. +Instance i : I := {}. Definition flip {A B C : Type} (f : A -> B -> C) := fun y x => f x y. Class D (f : nat -> nat -> nat). @@ -59,7 +59,7 @@ Definition ftest (x y : nat) := x + y. Definition flipD (f : nat -> nat -> nat) : D f -> D (flip f). Admitted. Module Instnopat. - Local Instance: B nat. + Local Instance: B nat := {}. (* pattern_of_constr -> B nat *) (* exact hint *) Check (_ : B nat). @@ -72,7 +72,7 @@ Module Instnopat. eauto with typeclass_instances. Qed. - Local Instance: D ftest. + Local Instance: D ftest := {}. Local Hint Resolve flipD | 0 : typeclass_instances. (* pattern: D (flip _) *) Fail Timeout 1 Check (_ : D _). (* loops applying flipD *) @@ -80,7 +80,7 @@ Module Instnopat. End Instnopat. Module InstnopatApply. - Local Instance: I -> B nat. + Local Instance: I -> B nat := {}. (* pattern_of_constr -> B nat *) (* apply hint *) Check (_ : B nat). @@ -116,7 +116,7 @@ Module InstPat. Hint Extern 0 (D (flip _)) => apply flipD : typeclass_instances. Module withftest. - Local Instance: D ftest. + Local Instance: D ftest := {}. Check (_ : D _). (* D_instance_0 : D ftest *) diff --git a/test-suite/success/bteauto.v b/test-suite/success/bteauto.v index 730b367d60..cea7d92c0b 100644 --- a/test-suite/success/bteauto.v +++ b/test-suite/success/bteauto.v @@ -149,10 +149,10 @@ Module IterativeDeepening. Class B. Class C. - Instance: B -> A | 0. - Instance: C -> A | 0. - Instance: C -> B -> A | 0. - Instance: A -> A | 0. + Instance: B -> A | 0 := {}. + Instance: C -> A | 0 := {}. + Instance: C -> B -> A | 0 := {}. + Instance: A -> A | 0 := {}. Goal C -> A. intros. diff --git a/test-suite/success/destruct.v b/test-suite/success/destruct.v index d1d384659b..573912c7cd 100644 --- a/test-suite/success/destruct.v +++ b/test-suite/success/destruct.v @@ -263,7 +263,7 @@ Abort. (* This one was working in 8.4 (because of full conv on closed arguments) *) Class E. -Instance a:E. +Instance a:E := {}. Goal forall h : E -> nat -> nat, h (id a) 0 = h a 0. intros. destruct (h _). diff --git a/test-suite/success/eauto.v b/test-suite/success/eauto.v index c44747379f..5b616ccc33 100644 --- a/test-suite/success/eauto.v +++ b/test-suite/success/eauto.v @@ -9,11 +9,11 @@ (************************************************************************) Class A (A : Type). - Instance an: A nat. + Instance an: A nat := {}. Class B (A : Type) (a : A). -Instance bn0: B nat 0. -Instance bn1: B nat 1. +Instance bn0: B nat 0 := {}. +Instance bn1: B nat 1 := {}. Goal A nat. Proof. @@ -39,7 +39,7 @@ Proof. eexists. eexists. typeclasses eauto. Defined. -Instance ab: A bool. (* Backtrack on A instance *) +Instance ab: A bool := {}. (* Backtrack on A instance *) Goal exists (T : Type) (t : T), A T /\ B T t. Proof. eexists. eexists. typeclasses eauto. @@ -51,7 +51,7 @@ Hint Extern 0 { x : ?A & _ } => unshelve class_apply @existT : typeclass_instances. Existing Class sigT. Set Typeclasses Debug. -Instance can: C an 0. +Instance can: C an 0 := {}. (* Backtrack on instance implementation *) Goal exists (T : Type) (t : T), { x : A T & C x t }. Proof. @@ -59,7 +59,7 @@ Proof. Defined. Class D T `(a: A T). - Instance: D _ an. + Instance: D _ an := {}. Goal exists (T : Type), { x : A T & D T x }. Proof. eexists. typeclasses eauto. diff --git a/test-suite/success/setoid_test2.v b/test-suite/success/setoid_test2.v index 79467e549c..351481b0b6 100644 --- a/test-suite/success/setoid_test2.v +++ b/test-suite/success/setoid_test2.v @@ -120,7 +120,7 @@ Axiom eqS1: S1 -> S1 -> Prop. Axiom SetoidS1 : Setoid_Theory S1 eqS1. Add Setoid S1 eqS1 SetoidS1 as S1setoid. -Instance eqS1_default : DefaultRelation eqS1. +Instance eqS1_default : DefaultRelation eqS1 := {}. Axiom eqS1': S1 -> S1 -> Prop. Axiom SetoidS1' : Setoid_Theory S1 eqS1'. @@ -220,7 +220,7 @@ Axiom eqS1_test8: S1_test8 -> S1_test8 -> Prop. Axiom SetoidS1_test8 : Setoid_Theory S1_test8 eqS1_test8. Add Setoid S1_test8 eqS1_test8 SetoidS1_test8 as S1_test8setoid. -Instance eqS1_test8_default : DefaultRelation eqS1_test8. +Instance eqS1_test8_default : DefaultRelation eqS1_test8 := {}. Axiom f_test8 : S2 -> S1_test8. Add Morphism f_test8 with signature (eqS2 ==> eqS1_test8) as f_compat_test8. Admitted. diff --git a/test-suite/tools/update-compat/run.sh b/test-suite/tools/update-compat/run.sh index 02a2348450..61273c4f37 100755 --- a/test-suite/tools/update-compat/run.sh +++ b/test-suite/tools/update-compat/run.sh @@ -6,4 +6,4 @@ SCRIPT_DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null && pwd )" # we assume that the script lives in test-suite/tools/update-compat/, # and that update-compat.py lives in dev/tools/ cd "${SCRIPT_DIR}/../../.." -dev/tools/update-compat.py --assert-unchanged --cur-version=8.9 || exit $? +dev/tools/update-compat.py --assert-unchanged --master || exit $? diff --git a/test-suite/unit-tests/lib/pp_big_vect.ml b/test-suite/unit-tests/lib/pp_big_vect.ml new file mode 100644 index 0000000000..e1cdd290e2 --- /dev/null +++ b/test-suite/unit-tests/lib/pp_big_vect.ml @@ -0,0 +1,14 @@ +open OUnit +open Pp + +let pr_big_vect = + let n = "pr_big_vect" in + n >:: (fun () -> + let v = Array.make (1 lsl 20) () in + let pp = prvecti_with_sep spc (fun _ _ -> str"x") v in + let str = string_of_ppcmds pp in + ignore(str)) + +let tests = [pr_big_vect] + +let () = Utest.run_tests __FILE__ (Utest.open_log_out_ch __FILE__) tests diff --git a/test-suite/unit-tests/printing/proof_diffs_test.ml b/test-suite/unit-tests/printing/proof_diffs_test.ml index 7f9e6cc6e0..d0b8d21b69 100644 --- a/test-suite/unit-tests/printing/proof_diffs_test.ml +++ b/test-suite/unit-tests/printing/proof_diffs_test.ml @@ -51,23 +51,28 @@ let t () = assert_equal ~msg:"has `Removed" ~printer:string_of_bool true has_removed let _ = add_test "diff_str add/remove" t -(* example of a limitation, not really a test *) -let t () = - try - let _ = diff_str "a" ">" in - assert_failure "unlexable string gives an exception" - with _ -> () -let _ = add_test "diff_str unlexable" t - -(* problematic examples for tokenize_string: - comments omitted - quoted string loses quote marks (are escapes supported/handled?) - char constant split into 2 +(* lexer tweaks: + comments are lexed as multiple tokens + strings tokens include begin/end quotes and embedded "" + single multibyte characters returned even if they're not keywords + + inputs that give a lexer failure (but no use case needs them yet): + ".12" + unterminated string + invalid UTF-8 sequences *) let t () = - List.iter (fun x -> cprintf "'%s' " x) (tokenize_string "(* comment *) \"string\" 'c' xx"); - cprintf "\n" -let _ = add_test "tokenize_string examples" t + let str = "(* comment.field *) ?id () \"str\"\"ing\" \\ := Ж > ∃ 'c' xx" in + let toks = tokenize_string str in + (*List.iter (fun x -> cprintf "'%s' " x) toks;*) + (*cprintf "\n";*) + let str_no_white = String.concat "" (String.split_on_char ' ' str) in + assert_equal ~printer:(fun x -> x) str_no_white (String.concat "" toks); + List.iter (fun s -> + assert_equal ~msg:("'" ^ s ^ "' is a single token") ~printer:string_of_bool true (List.mem s toks)) + [ "(*"; "()"; ":="] + +let _ = add_test "tokenize_string/diff_mode in lexer" t open Pp diff --git a/theories/Classes/CRelationClasses.v b/theories/Classes/CRelationClasses.v index bc821532fe..bb873588b1 100644 --- a/theories/Classes/CRelationClasses.v +++ b/theories/Classes/CRelationClasses.v @@ -177,6 +177,7 @@ Section Defs. a rewrite crelation. *) Global Instance equivalence_rewrite_crelation `(Equivalence eqA) : RewriteRelation eqA. + Defined. (** Leibniz equality. *) Section Leibniz. @@ -195,7 +196,10 @@ End Defs. (** Default rewrite crelations handled by [setoid_rewrite]. *) Instance: RewriteRelation impl. +Defined. + Instance: RewriteRelation iff. +Defined. (** Hints to drive the typeclass resolution avoiding loops due to the use of full unification. *) @@ -299,7 +303,8 @@ Section Binary. fun R R' => forall x y, iffT (R x y) (R' x y). Global Instance: RewriteRelation relation_equivalence. - + Defined. + Definition relation_conjunction (R : crelation A) (R' : crelation A) : crelation A := fun x y => prod (R x y) (R' x y). diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v index 86a3a88be9..6e2ff49536 100644 --- a/theories/Classes/RelationClasses.v +++ b/theories/Classes/RelationClasses.v @@ -171,6 +171,7 @@ Section Defs. a rewrite relation. *) Global Instance equivalence_rewrite_relation `(Equivalence eqA) : RewriteRelation eqA. + Defined. (** Leibniz equality. *) Section Leibniz. @@ -189,7 +190,9 @@ End Defs. (** Default rewrite relations handled by [setoid_rewrite]. *) Instance: RewriteRelation impl. +Defined. Instance: RewriteRelation iff. +Defined. (** Hints to drive the typeclass resolution avoiding loops due to the use of full unification. *) @@ -283,6 +286,7 @@ Local Open Scope list_scope. (** A compact representation of non-dependent arities, with the codomain singled-out. *) (* Note, we do not use [list Type] because it imposes unnecessary universe constraints *) +#[universes(template)] Inductive Tlist : Type := Tnil : Tlist | Tcons : Type -> Tlist -> Tlist. Local Infix "::" := Tcons. @@ -429,6 +433,7 @@ Section Binary. @predicate_equivalence (_::_::Tnil). Global Instance: RewriteRelation relation_equivalence. + Defined. Definition relation_conjunction (R : relation A) (R' : relation A) : relation A := @predicate_intersection (A::A::Tnil) R R'. diff --git a/theories/Classes/RelationPairs.v b/theories/Classes/RelationPairs.v index 3e6358c8f3..341dacd4b2 100644 --- a/theories/Classes/RelationPairs.v +++ b/theories/Classes/RelationPairs.v @@ -62,7 +62,10 @@ Class Measure {A B} (f : A -> B). (** Standard measures. *) Instance fst_measure : @Measure (A * B) A Fst. +Defined. + Instance snd_measure : @Measure (A * B) B Snd. +Defined. (** We define a product relation over [A*B]: each components should satisfy the corresponding initial relation. *) diff --git a/theories/Classes/SetoidClass.v b/theories/Classes/SetoidClass.v index 2673a11917..e6968bd6c2 100644 --- a/theories/Classes/SetoidClass.v +++ b/theories/Classes/SetoidClass.v @@ -27,6 +27,7 @@ Require Export Coq.Classes.Morphisms. (** A setoid wraps an equivalence. *) +#[universes(template)] Class Setoid A := { equiv : relation A ; setoid_equiv :> Equivalence equiv }. @@ -128,6 +129,7 @@ Program Instance setoid_partial_app_morphism `(sa : Setoid A) (x : A) : Proper ( (** Partial setoids don't require reflexivity so we can build a partial setoid on the function space. *) +#[universes(template)] Class PartialSetoid (A : Type) := { pequiv : relation A ; pequiv_prf :> PER pequiv }. diff --git a/theories/Classes/SetoidTactics.v b/theories/Classes/SetoidTactics.v index 3fab3c5a07..94920f74ec 100644 --- a/theories/Classes/SetoidTactics.v +++ b/theories/Classes/SetoidTactics.v @@ -41,6 +41,7 @@ Definition default_relation `{DefaultRelation A R} := R. (lowest priority). *) Instance equivalence_default `(Equivalence A R) : DefaultRelation R | 4. +Defined. (** The setoid_replace tactics in Ltac, defined in terms of default relations and the setoid_rewrite tactic. *) diff --git a/theories/Compat/Coq810.v b/theories/Compat/Coq810.v new file mode 100644 index 0000000000..f10201661e --- /dev/null +++ b/theories/Compat/Coq810.v @@ -0,0 +1,11 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Compatibility file for making Coq act similar to Coq v8.10 *) diff --git a/theories/Compat/Coq89.v b/theories/Compat/Coq89.v index 81a087b525..05d63d9a47 100644 --- a/theories/Compat/Coq89.v +++ b/theories/Compat/Coq89.v @@ -11,4 +11,7 @@ (** Compatibility file for making Coq act similar to Coq v8.9 *) Local Set Warnings "-deprecated". +Require Export Coq.Compat.Coq810. + Unset Private Polymorphic Universes. +Set Refine Instance Mode. diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v index 8fc04d81e6..9a815d2a7e 100644 --- a/theories/FSets/FMapAVL.v +++ b/theories/FSets/FMapAVL.v @@ -53,6 +53,7 @@ Variable elt : Type. The fifth field of [Node] is the height of the tree *) +#[universes(template)] Inductive tree := | Leaf : tree | Node : tree -> key -> elt -> tree -> int -> tree. @@ -235,6 +236,7 @@ Fixpoint join l : key -> elt -> t -> t := - [o] is the result of [find x m]. *) +#[universes(template)] Record triple := mktriple { t_left:t; t_opt:option elt; t_right:t }. Notation "<< l , b , r >>" := (mktriple l b r) (at level 9). @@ -291,6 +293,7 @@ Variable cmp : elt->elt->bool. (** ** Enumeration of the elements of a tree *) +#[universes(template)] Inductive enumeration := | End : enumeration | More : key -> elt -> t -> enumeration -> enumeration. @@ -1817,6 +1820,7 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Module Raw := Raw I X. Import Raw.Proofs. + #[universes(template)] Record bst (elt:Type) := Bst {this :> Raw.tree elt; is_bst : Raw.bst this}. diff --git a/theories/FSets/FMapFullAVL.v b/theories/FSets/FMapFullAVL.v index 950b30ee4d..7bc9edff8d 100644 --- a/theories/FSets/FMapFullAVL.v +++ b/theories/FSets/FMapFullAVL.v @@ -451,6 +451,7 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Import Raw. Import Raw.Proofs. + #[universes(template)] Record bbst (elt:Type) := Bbst {this :> tree elt; is_bst : bst this; is_avl: avl this}. diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v index 6ca158a277..4febd64842 100644 --- a/theories/FSets/FMapList.v +++ b/theories/FSets/FMapList.v @@ -1024,6 +1024,7 @@ Module E := X. Definition key := E.t. +#[universes(template)] Record slist (elt:Type) := {this :> Raw.t elt; sorted : sort (@Raw.PX.ltk elt) this}. Definition t (elt:Type) : Type := slist elt. diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v index 0fc68b1433..b47c99244b 100644 --- a/theories/FSets/FMapPositive.v +++ b/theories/FSets/FMapPositive.v @@ -73,6 +73,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Definition key := positive : Type. + #[universes(template)] Inductive tree (A : Type) := | Leaf : tree A | Node : tree A -> option A -> tree A -> tree A. diff --git a/theories/FSets/FMapWeakList.v b/theories/FSets/FMapWeakList.v index 03dce9666d..a923f4e6f9 100644 --- a/theories/FSets/FMapWeakList.v +++ b/theories/FSets/FMapWeakList.v @@ -869,6 +869,7 @@ Module Make (X: DecidableType) <: WS with Module E:=X. Module E := X. Definition key := E.t. +#[universes(template)] Record slist (elt:Type) := {this :> Raw.t elt; NoDup : NoDupA (@Raw.PX.eqk elt) this}. Definition t (elt:Type) := slist elt. diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index 7f0387dd12..3603604a71 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -167,6 +167,7 @@ Register S as num.nat.S. (** [option A] is the extension of [A] with an extra element [None] *) +#[universes(template)] Inductive option (A:Type) : Type := | Some : A -> option A | None : option A. @@ -186,6 +187,7 @@ Definition option_map (A B:Type) (f:A->B) (o : option A) : option B := (** [sum A B], written [A + B], is the disjoint sum of [A] and [B] *) +#[universes(template)] Inductive sum (A B:Type) : Type := | inl : A -> sum A B | inr : B -> sum A B. @@ -198,6 +200,7 @@ Arguments inr {A B} _ , A [B] _. (** [prod A B], written [A * B], is the product of [A] and [B]; the pair [pair A B a b] of [a] and [b] is abbreviated [(a,b)] *) +#[universes(template)] Inductive prod (A B:Type) : Type := pair : A -> B -> A * B @@ -256,6 +259,7 @@ Defined. (** Polymorphic lists and some operations *) +#[universes(template)] Inductive list (A : Type) : Type := | nil : list A | cons : A -> list A -> list A. @@ -384,6 +388,7 @@ Proof. intros. apply CompareSpec2Type; assumption. Defined. member is the singleton datatype [identity A a a] whose sole inhabitant is denoted [identity_refl A a] *) +#[universes(template)] Inductive identity (A:Type) (a:A) : A -> Type := identity_refl : identity a a. Hint Resolve identity_refl: core. diff --git a/theories/Init/Decimal.v b/theories/Init/Decimal.v index 537400fb05..3d4b3d0568 100644 --- a/theories/Init/Decimal.v +++ b/theories/Init/Decimal.v @@ -40,7 +40,7 @@ Notation zero := (D0 Nil). (** For signed integers, we use two constructors [Pos] and [Neg]. *) -Inductive int := Pos (d:uint) | Neg (d:uint). +Variant int := Pos (d:uint) | Neg (d:uint). Declare Scope dec_uint_scope. Delimit Scope dec_uint_scope with uint. @@ -50,6 +50,9 @@ Declare Scope dec_int_scope. Delimit Scope dec_int_scope with int. Bind Scope dec_int_scope with int. +Register uint as num.uint.type. +Register int as num.int.type. + (** This representation favors simplicity over canonicity. For normalizing numbers, we need to remove head zero digits, and choose our canonical representation of 0 (here [D0 Nil] diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v index e4796a8059..cfba2bae69 100644 --- a/theories/Init/Specif.v +++ b/theories/Init/Specif.v @@ -24,6 +24,7 @@ Require Import Logic. Similarly [(sig2 A P Q)], or [{x:A | P x & Q x}], denotes the subset of elements of the type [A] which satisfy both [P] and [Q]. *) +#[universes(template)] Inductive sig (A:Type) (P:A -> Prop) : Type := exist : forall x:A, P x -> sig P. @@ -31,12 +32,14 @@ Register sig as core.sig.type. Register exist as core.sig.intro. Register sig_rect as core.sig.rect. +#[universes(template)] Inductive sig2 (A:Type) (P Q:A -> Prop) : Type := exist2 : forall x:A, P x -> Q x -> sig2 P Q. (** [(sigT A P)], or more suggestively [{x:A & (P x)}] is a Sigma-type. Similarly for [(sigT2 A P Q)], also written [{x:A & (P x) & (Q x)}]. *) +#[universes(template)] Inductive sigT (A:Type) (P:A -> Type) : Type := existT : forall x:A, P x -> sigT P. @@ -44,6 +47,7 @@ Register sigT as core.sigT.type. Register existT as core.sigT.intro. Register sigT_rect as core.sigT.rect. +#[universes(template)] Inductive sigT2 (A:Type) (P Q:A -> Type) : Type := existT2 : forall x:A, P x -> Q x -> sigT2 P Q. @@ -700,6 +704,7 @@ Register sumbool as core.sumbool.type. (** [sumor] is an option type equipped with the justification of why it may not be a regular value *) +#[universes(template)] Inductive sumor (A:Type) (B:Prop) : Type := | inleft : A -> A + {B} | inright : B -> A + {B} diff --git a/theories/Lists/StreamMemo.v b/theories/Lists/StreamMemo.v index 57f558de50..d93816e9ff 100644 --- a/theories/Lists/StreamMemo.v +++ b/theories/Lists/StreamMemo.v @@ -78,6 +78,7 @@ Section DependentMemoFunction. Variable A: nat -> Type. Variable f: forall n, A n. +#[universes(template)] Inductive memo_val: Type := memo_mval: forall n, A n -> memo_val. diff --git a/theories/Lists/Streams.v b/theories/Lists/Streams.v index 8a01b8fb19..a03799959e 100644 --- a/theories/Lists/Streams.v +++ b/theories/Lists/Streams.v @@ -16,6 +16,7 @@ Section Streams. Variable A : Type. +#[universes(template)] CoInductive Stream : Type := Cons : A -> Stream -> Stream. diff --git a/theories/Logic/ExtensionalityFacts.v b/theories/Logic/ExtensionalityFacts.v index 02c8998a8d..a70bd92329 100644 --- a/theories/Logic/ExtensionalityFacts.v +++ b/theories/Logic/ExtensionalityFacts.v @@ -40,6 +40,7 @@ Definition is_inverse A B f g := (forall a:A, g (f a) = a) /\ (forall b:B, f (g (** The diagonal over A and the one-one correspondence with A *) +#[universes(template)] Record Delta A := { pi1:A; pi2:A; eq:pi1=pi2 }. Definition delta {A} (a:A) := {|pi1 := a; pi2 := a; eq := eq_refl a |}. diff --git a/theories/MSets/MSetAVL.v b/theories/MSets/MSetAVL.v index ac2a143472..13e1dad361 100644 --- a/theories/MSets/MSetAVL.v +++ b/theories/MSets/MSetAVL.v @@ -208,6 +208,7 @@ Definition concat s1 s2 := - [present] is [true] if and only if [s] contains [x]. *) +#[universes(template)] Record triple := mktriple { t_left:t; t_in:bool; t_right:t }. Notation "<< l , b , r >>" := (mktriple l b r) (at level 9). diff --git a/theories/MSets/MSetGenTree.v b/theories/MSets/MSetGenTree.v index 888f9850c1..a3dcca7dfd 100644 --- a/theories/MSets/MSetGenTree.v +++ b/theories/MSets/MSetGenTree.v @@ -48,6 +48,7 @@ Module Type Ops (X:OrderedType)(Info:InfoTyp). Definition elt := X.t. Hint Transparent elt : core. +#[universes(template)] Inductive tree : Type := | Leaf : tree | Node : Info.t -> tree -> X.t -> tree -> tree. @@ -167,6 +168,7 @@ end. (** Enumeration of the elements of a tree. This corresponds to the "samefringe" notion in the litterature. *) +#[universes(template)] Inductive enumeration := | End : enumeration | More : elt -> tree -> enumeration -> enumeration. diff --git a/theories/MSets/MSetInterface.v b/theories/MSets/MSetInterface.v index a4bbaef52d..0ba2799bfb 100644 --- a/theories/MSets/MSetInterface.v +++ b/theories/MSets/MSetInterface.v @@ -439,6 +439,7 @@ Module WRaw2SetsOn (E:DecidableType)(M:WRawSets E) <: WSetsOn E. Definition elt := E.t. +#[universes(template)] Record t_ := Mkt {this :> M.t; is_ok : M.Ok this}. Definition t := t_. Arguments Mkt this {is_ok}. diff --git a/theories/Numbers/BinNums.v b/theories/Numbers/BinNums.v index ef2c688759..247827597a 100644 --- a/theories/Numbers/BinNums.v +++ b/theories/Numbers/BinNums.v @@ -29,6 +29,7 @@ Bind Scope positive_scope with positive. Arguments xO _%positive. Arguments xI _%positive. +Register positive as num.pos.type. Register xI as num.pos.xI. Register xO as num.pos.xO. Register xH as num.pos.xH. diff --git a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v index 951a4ef2b0..9f718cba65 100644 --- a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v +++ b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v @@ -28,6 +28,7 @@ Local Open Scope Z_scope. Module ZnZ. + #[universes(template)] Class Ops (t:Type) := MkOps { (* Conversion functions with Z *) diff --git a/theories/Numbers/Cyclic/Abstract/DoubleType.v b/theories/Numbers/Cyclic/Abstract/DoubleType.v index fe0476e4de..b6441bb76a 100644 --- a/theories/Numbers/Cyclic/Abstract/DoubleType.v +++ b/theories/Numbers/Cyclic/Abstract/DoubleType.v @@ -22,6 +22,7 @@ Section Carry. Variable A : Type. + #[universes(template)] Inductive carry := | C0 : A -> carry | C1 : A -> carry. @@ -44,6 +45,7 @@ Section Zn2Z. first. *) + #[universes(template)] Inductive zn2z := | W0 : zn2z | WW : znz -> znz -> zn2z. diff --git a/theories/Program/Equality.v b/theories/Program/Equality.v index cf42ed18db..5ae933d433 100644 --- a/theories/Program/Equality.v +++ b/theories/Program/Equality.v @@ -257,6 +257,7 @@ Ltac blocked t := block_goal ; t ; unblock_goal. be used by the [equations] resolver. It is especially useful to register the dependent elimination principles for things in [Prop] which are not automatically generated. *) +#[universes(template)] Class DependentEliminationPackage (A : Type) := { elim_type : Type ; elim : elim_type }. diff --git a/theories/Reals/RiemannInt_SF.v b/theories/Reals/RiemannInt_SF.v index ceac021ef2..49a485c741 100644 --- a/theories/Reals/RiemannInt_SF.v +++ b/theories/Reals/RiemannInt_SF.v @@ -137,6 +137,7 @@ Definition IsStepFun (f:R -> R) (a b:R) : Type := { l:Rlist & is_subdivision f a b l }. (** ** Class of step functions *) +#[universes(template)] Record StepFun (a b:R) : Type := mkStepFun {fe :> R -> R; pre : IsStepFun fe a b}. diff --git a/theories/Reals/Rlimit.v b/theories/Reals/Rlimit.v index e3e995d201..b6b72de889 100644 --- a/theories/Reals/Rlimit.v +++ b/theories/Reals/Rlimit.v @@ -116,6 +116,7 @@ Qed. (*******************************) (*********) +#[universes(template)] Record Metric_Space : Type := {Base : Type; dist : Base -> Base -> R; diff --git a/theories/Reals/Rtopology.v b/theories/Reals/Rtopology.v index 171dba5522..f94b5cab65 100644 --- a/theories/Reals/Rtopology.v +++ b/theories/Reals/Rtopology.v @@ -380,6 +380,7 @@ Proof. apply Rinv_0_lt_compat; prove_sup0. Qed. +#[universes(template)] Record family : Type := mkfamily {ind : R -> Prop; f :> R -> R -> Prop; diff --git a/theories/Sets/Cpo.v b/theories/Sets/Cpo.v index 61fe55770b..2ed422ffe9 100644 --- a/theories/Sets/Cpo.v +++ b/theories/Sets/Cpo.v @@ -100,9 +100,11 @@ Hint Resolve Totally_ordered_definition Upper_Bound_definition Section Specific_orders. Variable U : Type. + #[universes(template)] Record Cpo : Type := Definition_of_cpo {PO_of_cpo : PO U; Cpo_cond : Complete U PO_of_cpo}. + #[universes(template)] Record Chain : Type := Definition_of_chain {PO_of_chain : PO U; Chain_cond : Totally_ordered U PO_of_chain (@Carrier_of _ PO_of_chain)}. diff --git a/theories/Sets/Multiset.v b/theories/Sets/Multiset.v index a79ddead20..6a8a3014c3 100644 --- a/theories/Sets/Multiset.v +++ b/theories/Sets/Multiset.v @@ -22,6 +22,7 @@ Section multiset_defs. Hypothesis eqA_equiv : Equivalence eqA. Hypothesis Aeq_dec : forall x y:A, {eqA x y} + {~ eqA x y}. + #[universes(template)] Inductive multiset : Type := Bag : (A -> nat) -> multiset. diff --git a/theories/Sets/Partial_Order.v b/theories/Sets/Partial_Order.v index 17fc0ed25e..5b51c7b953 100644 --- a/theories/Sets/Partial_Order.v +++ b/theories/Sets/Partial_Order.v @@ -36,6 +36,7 @@ Section Partial_orders. Definition Rel := Relation U. + #[universes(template)] Record PO : Type := Definition_of_PO { Carrier_of : Ensemble U; Rel_of : Relation U; diff --git a/theories/Sorting/Heap.v b/theories/Sorting/Heap.v index 6a22501afa..f5cda792ce 100644 --- a/theories/Sorting/Heap.v +++ b/theories/Sorting/Heap.v @@ -42,6 +42,7 @@ Section defs. Let emptyBag := EmptyBag A. Let singletonBag := SingletonBag _ eqA_dec. + #[universes(template)] Inductive Tree := | Tree_Leaf : Tree | Tree_Node : A -> Tree -> Tree -> Tree. @@ -128,6 +129,7 @@ Section defs. (** ** Merging two sorted lists *) + #[universes(template)] Inductive merge_lem (l1 l2:list A) : Type := merge_exist : forall l:list A, @@ -201,6 +203,7 @@ Section defs. (** ** Specification of heap insertion *) + #[universes(template)] Inductive insert_spec (a:A) (T:Tree) : Type := insert_exist : forall T1:Tree, @@ -234,6 +237,7 @@ Section defs. (** ** Building a heap from a list *) + #[universes(template)] Inductive build_heap (l:list A) : Type := heap_exist : forall T:Tree, @@ -258,6 +262,7 @@ Section defs. (** ** Building the sorted list *) + #[universes(template)] Inductive flat_spec (T:Tree) : Type := flat_exist : forall l:list A, diff --git a/theories/Vectors/VectorDef.v b/theories/Vectors/VectorDef.v index 7f96aa6b87..906cf79ca9 100644 --- a/theories/Vectors/VectorDef.v +++ b/theories/Vectors/VectorDef.v @@ -28,6 +28,7 @@ Local Open Scope nat_scope. (** A vector is a list of size n whose elements belong to a set A. *) +#[universes(template)] Inductive t A : nat -> Type := |nil : t A 0 |cons : forall (h:A) (n:nat), t A n -> t A (S n). diff --git a/theories/Wellfounded/Well_Ordering.v b/theories/Wellfounded/Well_Ordering.v index fd363d02ca..cf46657d36 100644 --- a/theories/Wellfounded/Well_Ordering.v +++ b/theories/Wellfounded/Well_Ordering.v @@ -18,6 +18,7 @@ Section WellOrdering. Variable A : Type. Variable B : A -> Type. + #[universes(template)] Inductive WO : Type := sup : forall (a:A) (f:B a -> WO), WO. diff --git a/theories/ZArith/Int.v b/theories/ZArith/Int.v index 1e35370d29..0b0ed48d51 100644 --- a/theories/ZArith/Int.v +++ b/theories/ZArith/Int.v @@ -212,6 +212,7 @@ Module MoreInt (Import I:Int). | EZofI : ExprI -> ExprZ | EZraw : Z -> ExprZ. + #[universes(template)] Inductive ExprP : Type := | EPeq : ExprZ -> ExprZ -> ExprP | EPlt : ExprZ -> ExprZ -> ExprP diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in index 4372ac72ae..f8f10b34ae 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -126,6 +126,8 @@ TIME_OF_PRETTY_BUILD_FILE ?= time-of-build-pretty.log TIME_OF_PRETTY_BOTH_BUILD_FILE ?= time-of-build-both.log TIME_OF_PRETTY_BUILD_EXTRA_FILES ?= - # also output to the command line +TGTS ?= + ########## End of parameters ################################################## # What follows may be relevant to you only if you need to # extend this Makefile. If so, look for 'Extension point' here and @@ -237,6 +239,11 @@ vo_to_obj = $(addsuffix .o,\ $(filter-out Warning: Error:,\ $(shell $(COQTOP) -q -noinit -batch -quiet -print-mod-uid $(1)))) strip_dotslash = $(patsubst ./%,%,$(1)) + +# without this we get undefined variables in the expansion for the +# targets of the [deprecated,use-mllib-or-mlpack] rule +with_undef = $(if $(filter-out undefined, $(origin $(1))),$($(1))) + VO = vo VOFILES = $(VFILES:.v=.$(VO)) @@ -269,14 +276,14 @@ CMXSFILES = \ PACKEDFILES = \ $(call strip_dotslash, \ $(foreach lib, \ - $(call strip_dotslash, \ - $(MLPACKFILES:.mlpack=_MLPACK_DEPENDENCIES)),$($(lib)))) + $(call strip_dotslash, \ + $(MLPACKFILES:.mlpack=_MLPACK_DEPENDENCIES)),$(call with_undef,$(lib)))) # files that are archived into a .cma (mllib) LIBEDFILES = \ $(call strip_dotslash, \ $(foreach lib, \ - $(call strip_dotslash, \ - $(MLLIBFILES:.mllib=_MLLIB_DEPENDENCIES)),$($(lib)))) + $(call strip_dotslash, \ + $(MLLIBFILES:.mllib=_MLLIB_DEPENDENCIES)),$(call with_undef,$(lib)))) CMIFILESTOINSTALL = $(filter-out $(addsuffix .cmi,$(PACKEDFILES)),$(CMIFILES)) CMOFILESTOINSTALL = $(filter-out $(addsuffix .cmo,$(PACKEDFILES)),$(CMOFILES)) OBJFILES = $(call vo_to_obj,$(VOFILES)) @@ -681,11 +688,11 @@ $(GHTMLFILES): %.g.html: %.v %.glob # Dependency files ############################################################ -ifneq ($(filter-out archclean clean cleanall printenv make-pretty-timed make-pretty-timed-before make-pretty-timed-after print-pretty-timed print-pretty-timed-diff print-pretty-single-time-diff,$(MAKECMDGOALS)),) - -include $(ALLDFILES) -else - ifeq ($(MAKECMDGOALS),) +ifndef MAKECMDGOALS -include $(ALLDFILES) +else + ifneq ($(filter-out archclean clean cleanall printenv make-pretty-timed make-pretty-timed-before make-pretty-timed-after print-pretty-timed print-pretty-timed-diff print-pretty-single-time-diff,$(MAKECMDGOALS)),) + -include $(ALLDFILES) endif endif @@ -784,3 +791,7 @@ debug: .PHONY: debug .DEFAULT_GOAL := all + +# Local Variables: +# mode: makefile-gmake +# End: diff --git a/tools/coq_dune.ml b/tools/coq_dune.ml index 9ecd8f19ce..8f6c4c0968 100644 --- a/tools/coq_dune.ml +++ b/tools/coq_dune.ml @@ -186,7 +186,7 @@ let pp_vo_dep dir fmt vo = (* We explicitly include the location of coqlib to avoid tricky issues with coqlib location *) let libflag = "-coqlib %{project_root}" in (* The final build rule *) - let action = sprintf "(chdir %%{project_root} (run coqtop -boot %s %s %s -compile %s))" libflag eflag cflag source in + let action = sprintf "(chdir %%{project_root} (run coqtop -boot %s %s %s -w -deprecate-compile-arg -compile %s))" libflag eflag cflag source in let all_targets = gen_coqc_targets vo in pp_rule fmt all_targets deps action diff --git a/tools/coqc.ml b/tools/coqc.ml index ae841212a7..0f65823740 100644 --- a/tools/coqc.ml +++ b/tools/coqc.ml @@ -32,8 +32,9 @@ let verbose = ref false let rec make_compilation_args = function | [] -> [] | file :: fl -> - (if !verbose then "-compile-verbose" else "-compile") - :: file :: (make_compilation_args fl) + "-w" :: "-deprecate-compile-arg" + :: (if !verbose then "-compile-verbose" else "-compile") + :: file :: (make_compilation_args fl) (* compilation of files [files] with command [command] and args [args] *) @@ -61,16 +62,28 @@ let usage () = (* parsing of the command line *) let extra_arg_needed = ref true +let deprecated_coqc_warning = CWarnings.(create + ~name:"deprecate-compile-arg" + ~category:"toplevel" + ~default:Enabled + (fun opt_name -> Pp.(seq [str "The option "; str opt_name; str" is deprecated."]))) + let parse_args () = let rec parse (cfiles,args) = function | [] -> List.rev cfiles, List.rev args | ("-verbose" | "--verbose") :: rem -> verbose := true ; parse (cfiles,args) rem - | "-image" :: f :: rem -> image := f; parse (cfiles,args) rem + | "-image" :: f :: rem -> + deprecated_coqc_warning "-image"; + image := f; parse (cfiles,args) rem | "-image" :: [] -> usage () - | "-byte" :: rem -> use_bytecode := true; parse (cfiles,args) rem - | "-opt" :: rem -> use_bytecode := false; parse (cfiles,args) rem + | "-byte" :: rem -> + deprecated_coqc_warning "-byte"; + use_bytecode := true; parse (cfiles,args) rem + | "-opt" :: rem -> + deprecated_coqc_warning "-opt"; + use_bytecode := false; parse (cfiles,args) rem (* Informative options *) @@ -87,7 +100,7 @@ let parse_args () = Envars.set_coqlib ~fail:(fun x -> x); Envars.print_config stdout Coq_config.all_src_dirs; exit 0 - + | ("-print-version" | "--print-version") :: _ -> Usage.machine_readable_version 0 @@ -97,7 +110,7 @@ let parse_args () = |"-batch"|"-noinit"|"-nois"|"-noglob"|"-no-glob" |"-q"|"-profile"|"-echo" |"-quiet" |"-silent"|"-m"|"-beautify"|"-strict-implicit" - |"-impredicative-set"|"-vm" + |"-impredicative-set"|"-vm"|"-test-mode"|"-emacs" |"-indices-matter"|"-quick"|"-type-in-type" |"-async-proofs-always-delegate"|"-async-proofs-never-reopen-branch" |"-stm-debug" @@ -108,22 +121,28 @@ let parse_args () = | ("-outputstate"|"-inputstate"|"-is"|"-exclude-dir"|"-color" |"-load-vernac-source"|"-l"|"-load-vernac-object" - |"-load-ml-source"|"-require"|"-load-ml-object" + |"-load-ml-source"|"-require"|"-load-ml-object"|"-async-proofs-cache" |"-init-file"|"-dump-glob"|"-compat"|"-coqlib"|"-top"|"-topfile" |"-async-proofs-j" |"-async-proofs-private-flags" |"-async-proofs" |"-w" - |"-o"|"-profile-ltac-cutoff"|"-mangle-names"|"-bytecode-compiler"|"-native-compiler" + |"-profile-ltac-cutoff"|"-mangle-names"|"-bytecode-compiler"|"-native-compiler" as o) :: rem -> begin match rem with | s :: rem' -> parse (cfiles,s::o::args) rem' | [] -> usage () end + | "-o" :: rem-> + begin + match rem with + | s :: rem' -> parse (cfiles,s::"-o"::args) rem' + | [] -> usage () + end | ("-I"|"-include" as o) :: s :: rem -> parse (cfiles,s::o::args) rem (* Options for coqtop : c) options with 1 argument and possibly more *) | ("-R"|"-Q" as o) :: s :: t :: rem -> parse (cfiles,t::s::o::args) rem - | ("-schedule-vio-checking" + | ("-schedule-vio-checking"|"-vio2vo" |"-check-vio-tasks" | "-schedule-vio2vo" as o) :: s :: rem -> let nodash, rem = CList.split_when (fun x -> String.length x > 1 && x.[0] = '-') rem in diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index 0a32879764..f822c68843 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -165,7 +165,8 @@ let add_compat_require opts v = match v with | Flags.V8_7 -> add_vo_require opts "Coq.Compat.Coq87" None (Some false) | Flags.V8_8 -> add_vo_require opts "Coq.Compat.Coq88" None (Some false) - | Flags.Current -> add_vo_require opts "Coq.Compat.Coq89" None (Some false) + | Flags.V8_9 -> add_vo_require opts "Coq.Compat.Coq89" None (Some false) + | Flags.Current -> add_vo_require opts "Coq.Compat.Coq810" None (Some false) let set_batch_mode opts = (* XXX: This should be in the argument record *) @@ -322,6 +323,12 @@ let usage batch = then Usage.print_usage_coqc () else Usage.print_usage_coqtop () +let deprecated_coqc_warning = CWarnings.(create + ~name:"deprecate-compile-arg" + ~category:"toplevel" + ~default:Enabled + (fun opt_name -> Pp.(seq [str "The option "; str opt_name; str" is deprecated, please use coqc."]))) + (* Main parsing routine *) let parse_args init_opts arglist : coq_cmdopts * string list = let args = ref arglist in @@ -435,10 +442,12 @@ let parse_args init_opts arglist : coq_cmdopts * string list = Flags.compat_version := v; add_compat_require oval v - |"-compile" -> + |"-compile" as opt -> + deprecated_coqc_warning opt; add_compile oval false (next ()) - |"-compile-verbose" -> + |"-compile-verbose" as opt -> + deprecated_coqc_warning opt; add_compile oval true (next ()) |"-dump-glob" -> @@ -518,7 +527,9 @@ let parse_args init_opts arglist : coq_cmdopts * string list = CWarnings.set_flags (CWarnings.normalize_flags_string w); oval - |"-o" -> { oval with compilation_output_name = Some (next()) } + |"-o" as opt -> + deprecated_coqc_warning opt; + { oval with compilation_output_name = Some (next()) } |"-bytecode-compiler" -> { oval with enable_VM = get_bool opt (next ()) } diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index e58b9ccac7..cdbe444e5b 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -243,7 +243,7 @@ let set_prompt prompt = let parse_to_dot = let rec dot st = match Stream.next st with | Tok.KEYWORD ("."|"...") -> () - | Tok.EOI -> raise Stm.End_of_input + | Tok.EOI -> () | _ -> dot st in Pcoq.Entry.of_parser "Coqtoplevel.dot" dot @@ -257,12 +257,12 @@ let rec discard_to_dot () = Pcoq.Entry.parse parse_to_dot top_buffer.tokens with | Gramlib.Plexing.Error _ | CLexer.Error.E _ -> discard_to_dot () - | Stm.End_of_input -> raise Stm.End_of_input | e when CErrors.noncritical e -> () let read_sentence ~state input = (* XXX: careful with ignoring the state Eugene!*) - try G_toplevel.parse_toplevel input + let open Vernac.State in + try Stm.parse_sentence ~doc:state.doc state.sid ~entry:G_toplevel.vernac_toplevel input with reraise -> let reraise = CErrors.push reraise in discard_to_dot (); @@ -366,7 +366,6 @@ let top_goal_print ~doc c oldp newp = let msg = CErrors.iprint (e, info) in TopErr.print_error_for_buffer ?loc Feedback.Error msg top_buffer -(* Careful to keep this loop tail-rec *) let rec vernac_loop ~state = let open CAst in let open Vernac.State in @@ -379,26 +378,30 @@ let rec vernac_loop ~state = try let input = top_buffer.tokens in match read_sentence ~state input with - | {v=VernacBacktrack(bid,_,_)} -> + | Some { v = VernacBacktrack(bid,_,_) } -> let bid = Stateid.of_int bid in let doc, res = Stm.edit_at ~doc:state.doc bid in assert (res = `NewTip); let state = { state with doc; sid = bid } in vernac_loop ~state - | {v=VernacQuit} -> + | Some { v = VernacQuit } -> exit 0 - | {v=VernacDrop} -> + + | Some { v = VernacDrop } -> if Mltop.is_ocaml_top() then (drop_last_doc := Some state; state) else (Feedback.msg_warning (str "There is no ML toplevel."); vernac_loop ~state) - | {v=VernacControl c; loc} -> + + | Some { v = VernacControl c; loc } -> let nstate = Vernac.process_expr ~state (make ?loc c) in top_goal_print ~doc:state.doc c state.proof nstate.proof; vernac_loop ~state:nstate + + | None -> + top_stderr (fnl ()); exit 0 + with - | Stm.End_of_input -> - top_stderr (fnl ()); exit 0 (* Exception printing should be done by the feedback listener, however this is not yet ready so we rely on the exception for now. *) diff --git a/toplevel/g_toplevel.mlg b/toplevel/g_toplevel.mlg index 5aba3d6b0b..7f1cca277e 100644 --- a/toplevel/g_toplevel.mlg +++ b/toplevel/g_toplevel.mlg @@ -21,7 +21,7 @@ type vernac_toplevel = | VernacControl of vernac_control module Toplevel_ : sig - val vernac_toplevel : vernac_toplevel CAst.t Entry.t + val vernac_toplevel : vernac_toplevel CAst.t option Entry.t end = struct let gec_vernac s = Entry.create ("toplevel:" ^ s) let vernac_toplevel = gec_vernac "vernac_toplevel" @@ -34,14 +34,14 @@ open Toplevel_ GRAMMAR EXTEND Gram GLOBAL: vernac_toplevel; vernac_toplevel: FIRST - [ [ IDENT "Drop"; "." -> { CAst.make VernacDrop } - | IDENT "Quit"; "." -> { CAst.make VernacQuit } + [ [ IDENT "Drop"; "." -> { Some (CAst.make VernacDrop) } + | IDENT "Quit"; "." -> { Some (CAst.make VernacQuit) } | IDENT "Backtrack"; n = natural ; m = natural ; p = natural; "." -> - { CAst.make (VernacBacktrack (n,m,p)) } - | cmd = Pvernac.main_entry -> + { Some (CAst.make (VernacBacktrack (n,m,p))) } + | cmd = Pvernac.Vernac_.main_entry -> { match cmd with - | None -> raise Stm.End_of_input - | Some (loc,c) -> CAst.make ~loc (VernacControl c) } + | None -> None + | Some (loc,c) -> Some (CAst.make ~loc (VernacControl c)) } ] ] ; @@ -49,6 +49,8 @@ END { -let parse_toplevel pa = Pcoq.Entry.parse vernac_toplevel pa +let vernac_toplevel pm = + Pvernac.Unsafe.set_tactic_entry pm; + vernac_toplevel } diff --git a/toplevel/usage.ml b/toplevel/usage.ml index c43538017c..53bfeddf00 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -23,7 +23,7 @@ let machine_readable_version ret = let extra_usage = ref [] let add_to_usage name text = extra_usage := (name,text) :: !extra_usage -let print_usage_channel co command = +let print_usage_common co command = output_string co command; output_string co "Coq options are:\n"; output_string co @@ -48,9 +48,6 @@ let print_usage_channel co command = \n -lv f (idem)\ \n -load-vernac-object f load Coq object file f.vo\ \n -require path load Coq library path and import it (Require Import path.)\ -\n -compile f.v compile Coq file f.v (implies -batch)\ -\n -compile-verbose f.v verbosely compile Coq file f.v (implies -batch)\ -\n -o f.vo use f.vo as the output file name\ \n -quick quickly compile .v files to .vio files (skip proofs)\ \n -schedule-vio2vo j f1..fn run up to j instances of Coq to turn each fi.vio\ \n into fi.vo\ @@ -66,16 +63,15 @@ let print_usage_channel co command = \n -quiet unset display of extra information (implies -w \"-all\")\ \n -w (w1,..,wn) configure display of warnings\ \n -color (yes|no|auto) configure color output\ +\n -emacs tells Coq it is executed under Emacs\ \n\ \n -q skip loading of rcfile\ \n -init-file f set the rcfile to f\ -\n -batch batch mode (exits just after arguments parsing)\ \n -boot boot mode (implies -q and -batch)\ \n -bt print backtraces (requires configure debug flag)\ \n -debug debug mode (implies -bt)\ \n -diffs (on|off|removed) highlight differences between proof steps\ \n -stm-debug STM debug mode (will trace every transaction)\ -\n -emacs tells Coq it is executed under Emacs\ \n -noglob do not dump globalizations\ \n -dump-glob f dump globalizations in file f (to be used by coqdoc)\ \n -impredicative-set set sort Set impredicative\ @@ -101,21 +97,36 @@ let print_usage_channel co command = (* print the usage on standard error *) -let print_usage = print_usage_channel stderr - let print_usage_coqtop () = - print_usage "Usage: coqtop <options>\n\n"; + print_usage_common stderr "Usage: coqtop <options>\n\n"; + output_string stderr "\n\ +coqtop specific options:\ +\n\ +\n -batch batch mode (exits just after arguments parsing)\ +\n\ +\nDeprecated options [use coqc instead]:\ +\n\ +\n -compile f.v compile Coq file f.v (implies -batch)\ +\n -compile-verbose f.v verbosely compile Coq file f.v (implies -batch)\ +\n -o f.vo use f.vo as the output file name\ +\n"; flush stderr ; exit 1 let print_usage_coqc () = - print_usage "Usage: coqc <options> <Coq options> file...\n\ -\noptions are:\ -\n -verbose compile verbosely\ -\n -image f specify an alternative executable for Coq\ -\n -opt run the native-code version of Coq\ -\n -byte run the bytecode version of Coq\ -\n -t keep temporary files\n\n"; + print_usage_common stderr "Usage: coqc <options> <Coq options> file..."; + output_string stderr "\n\ +coqc specific options:\ +\n\ +\n -o f.vo use f.vo as the output file name\ +\n -verbose compile and output the input file\ +\n\ +\nDeprecated options:\ +\n\ +\n -image f specify an alternative executable for Coq\ +\n -opt run the native-code version of Coq\ +\n -byte run the bytecode version of Coq\ +\n -t keep temporary files\ +\n"; flush stderr ; exit 1 - diff --git a/toplevel/usage.mli b/toplevel/usage.mli index fbb0117d45..64170adaa4 100644 --- a/toplevel/usage.mli +++ b/toplevel/usage.mli @@ -13,9 +13,6 @@ val version : int -> 'a val machine_readable_version : int -> 'a -(** {6 Prints the usage on the error output, preceeded by a user-provided message. } *) -val print_usage : string -> unit - (** {6 Enable toploop plugins to insert some text in the usage message. } *) val add_to_usage : string -> string -> unit diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index c914bbecff..45ca658857 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -37,34 +37,6 @@ let vernac_echo ?loc in_chan = let open Loc in Feedback.msg_notice @@ str @@ really_input_string in_chan len ) loc -(* For coqtop -time, we display the position in the file, - and a glimpse of the executed command *) - -let pp_cmd_header {CAst.loc;v=com} = - let shorten s = - if Unicode.utf8_length s > 33 then (Unicode.utf8_sub s 0 30) ^ "..." else s - in - let noblank s = String.map (fun c -> - match c with - | ' ' | '\n' | '\t' | '\r' -> '~' - | x -> x - ) s - in - let (start,stop) = Option.cata Loc.unloc (0,0) loc in - let safe_pr_vernac x = - try Ppvernac.pr_vernac x - with e -> str (Printexc.to_string e) in - let cmd = noblank (shorten (string_of_ppcmds (safe_pr_vernac com))) - in str "Chars " ++ int start ++ str " - " ++ int stop ++ - str " [" ++ str cmd ++ str "] " - -(* This is a special case where we assume we are in console batch mode - and take control of the console. - *) -let print_cmd_header com = - Pp.pp_with !Topfmt.std_ft (pp_cmd_header com); - Format.pp_print_flush !Topfmt.std_ft () - (* Reenable when we get back to feedback printing *) (* let is_end_of_input any = match any with *) (* Stm.End_of_input -> true *) @@ -88,7 +60,6 @@ let interp_vernac ~check ~interactive ~state ({CAst.loc;_} as com) = due to the way it prints. *) let com = if state.time then begin - print_cmd_header com; CAst.make ?loc @@ VernacTime(state.time,com) end else com in let doc, nsid, ntip = Stm.add ~doc:state.doc ~ontop:state.sid (not !Flags.quiet) com in @@ -97,10 +68,8 @@ let interp_vernac ~check ~interactive ~state ({CAst.loc;_} as com) = if ntip <> `NewTip then anomaly (str "vernac.ml: We got an unfocus operation on the toplevel!"); - (* Due to bug #5363 we cannot use observe here as we should, - it otherwise reveals bugs *) - (* Stm.observe nsid; *) - let ndoc = if check then Stm.finish ~doc else doc in + (* Force the command *) + let ndoc = if check then Stm.observe ~doc nsid else doc in let new_proof = Proof_global.give_me_the_proof_opt () in { state with doc = ndoc; sid = nsid; proof = new_proof; } with reraise -> @@ -121,51 +90,37 @@ let load_vernac_core ~echo ~check ~interactive ~state file = let in_echo = if echo then Some (open_utf8_file_in file) else None in let input_cleanup () = close_in in_chan; Option.iter close_in in_echo in - let in_pa = Pcoq.Parsable.make ~file:(Loc.InFile file) (Stream.of_channel in_chan) in - let rstate = ref state in - (* For beautify, list of parsed sids *) - let rids = ref [] in + let in_pa = + Pcoq.Parsable.make ~file:(Loc.InFile file) (Stream.of_channel in_chan) in let open State in - try - (* we go out of the following infinite loop when a End_of_input is - * raised, which means that we raised the end of the file being loaded *) - while true do - let { CAst.loc; _ } as ast = - Stm.parse_sentence ~doc:!rstate.doc !rstate.sid in_pa - (* If an error in parsing occurs, we propagate the exception - so the caller of load_vernac will take care of it. However, - in the future it could be possible that we want to handle - all the errors as feedback events, thus in this case we - should relay the exception here for convenience. A - possibility is shown below, however we may want to refactor - this code: - - try Stm.parse_sentence !rsid in_pa - with - | any when not is_end_of_input any -> - let (e, info) = CErrors.push any in - let loc = Loc.get_loc info in - let msg = CErrors.iprint (e, info) in - Feedback.msg_error ?loc msg; - iraise (e, info) - *) - in - (* Printing of vernacs *) - Option.iter (vernac_echo ?loc) in_echo; - - checknav_simple ast; - let state = Flags.silently (interp_vernac ~check ~interactive ~state:!rstate) ast in - rids := state.sid :: !rids; - rstate := state; - done; - input_cleanup (); - !rstate, !rids, Pcoq.Parsable.comment_state in_pa + + (* ids = For beautify, list of parsed sids *) + let rec loop state ids = + match + Stm.parse_sentence + ~doc:state.doc ~entry:Pvernac.main_entry state.sid in_pa + with + | None -> + input_cleanup (); + state, ids, Pcoq.Parsable.comment_state in_pa + | Some (loc, ast) -> + let ast = CAst.make ~loc ast in + + (* Printing of AST for -compile-verbose *) + Option.iter (vernac_echo ~loc) in_echo; + + checknav_simple ast; + + let state = + Flags.silently (interp_vernac ~check ~interactive ~state) ast in + + loop state (state.sid :: ids) + in + try loop state [] with any -> (* whatever the exception *) let (e, info) = CErrors.push any in input_cleanup (); - match e with - | Stm.End_of_input -> !rstate, !rids, Pcoq.Parsable.comment_state in_pa - | reraise -> iraise (e, info) + iraise (e, info) let process_expr ~state loc_ast = checknav_deep loc_ast; diff --git a/vernac/classes.ml b/vernac/classes.ml index 370df615fc..5cac6af4b2 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -28,7 +28,7 @@ module RelDecl = Context.Rel.Declaration open Decl_kinds open Entries -let refine_instance = ref true +let refine_instance = ref false let () = Goptions.(declare_bool_option { optdepr = false; @@ -105,8 +105,6 @@ let id_of_class cl = mip.(0).Declarations.mind_typename | _ -> assert false -open Pp - let instance_hook k info global imps ?hook cst = Impargs.maybe_declare_manual_implicits false cst ~enriching:false imps; let info = intern_info info in @@ -128,7 +126,7 @@ let declare_instance_constant k info global imps ?hook id decl poly sigma term t Declare.declare_univ_binders (ConstRef kn) (Evd.universe_binders sigma); instance_hook k info global imps ?hook (ConstRef kn) -let do_abstract_instance env sigma ?hook ~global ~poly k u ctx ctx' pri decl imps subst id = +let do_declare_instance env sigma ~global ~poly k u ctx ctx' pri decl imps subst id = let subst = List.fold_left2 (fun subst' s decl -> if is_local_assum decl then s :: subst' else subst') [] subst (snd k.cl_context) @@ -144,7 +142,7 @@ let do_abstract_instance env sigma ?hook ~global ~poly k u ctx ctx' pri decl imp (None,(termtype,univs),None), Decl_kinds.IsAssumption Decl_kinds.Logical) in Declare.declare_univ_binders (ConstRef cst) (Evd.universe_binders sigma); - instance_hook k pri global imps ?hook (ConstRef cst); id + instance_hook k pri global imps (ConstRef cst) let declare_instance_open env sigma ?hook ~tac ~program_mode ~global ~poly k id pri imps decl ids term termtype = let kind = Decl_kinds.Global, poly, Decl_kinds.DefinitionBody Decl_kinds.Instance in @@ -191,7 +189,7 @@ let declare_instance_open env sigma ?hook ~tac ~program_mode ~global ~poly k id else ignore (Pfedit.by (Tactics.auto_intros_tac ids)); (match tac with Some tac -> ignore (Pfedit.by tac) | None -> ())) () -let do_transparent_instance env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode cty k u ctx ctx' pri decl imps subst id props = +let do_instance env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode cty k u ctx ctx' pri decl imps subst id props = let props = match props with | Some (true, { CAst.v = CRecord fs }) -> @@ -271,76 +269,81 @@ let do_transparent_instance env env' sigma ?hook ~refine ~tac ~global ~poly ~pro Pretyping.check_evars env (Evd.from_env env) sigma termtype; let termtype = to_constr sigma termtype in let term = Option.map (to_constr ~abort_on_undefined_evars:false sigma) term in - if not (Evd.has_undefined sigma) && not (Option.is_empty term) then + if not (Evd.has_undefined sigma) && not (Option.is_empty props) then declare_instance_constant k pri global imps ?hook id decl poly sigma (Option.get term) termtype - else if program_mode || refine || Option.is_empty term then + else if program_mode || refine || Option.is_empty props then declare_instance_open env sigma ?hook ~tac ~program_mode ~global ~poly k id pri imps decl (List.map RelDecl.get_name ctx) term termtype else CErrors.user_err Pp.(str "Unsolved obligations remaining."); id -let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) ~program_mode - poly ctx (instid, bk, cl) props - ?(generalize=true) ?(tac:unit Proofview.tactic option) ?hook pri = - let env = Global.env() in - let ({CAst.loc;v=instid}, pl) = instid in +let interp_instance_context env ctx ?(generalize=false) pl bk cl = let sigma, decl = Constrexpr_ops.interp_univ_decl_opt env pl in let tclass, ids = match bk with | Decl_kinds.Implicit -> - Implicit_quantifiers.implicit_application Id.Set.empty ~allow_partial:false - (fun avoid (clname, _) -> - match clname with - | Some cl -> - let t = CAst.make @@ CHole (None, Namegen.IntroAnonymous, None) in - t, avoid - | None -> failwith ("new instance: under-applied typeclass")) - cl + Implicit_quantifiers.implicit_application Id.Set.empty ~allow_partial:false + (fun avoid (clname, _) -> + match clname with + | Some cl -> + let t = CAst.make @@ CHole (None, Namegen.IntroAnonymous, None) in + t, avoid + | None -> failwith ("new instance: under-applied typeclass")) + cl | Explicit -> cl, Id.Set.empty in let tclass = if generalize then CAst.make @@ CGeneralization (Implicit, Some AbsPi, tclass) else tclass in - let sigma, k, u, cty, ctx', ctx, len, imps, subst = - let sigma, (impls, ((env', ctx), imps)) = interp_context_evars env sigma ctx in - let sigma, (c', imps') = interp_type_evars_impls ~impls env' sigma tclass in - let len = List.length ctx in - let imps = imps @ Impargs.lift_implicits len imps' in - let ctx', c = decompose_prod_assum sigma c' in - let ctx'' = ctx' @ ctx in - let (k, u), args = Typeclasses.dest_class_app (push_rel_context ctx'' env) sigma c in - let u_s = EInstance.kind sigma u in - let cl = Typeclasses.typeclass_univ_instance (k, u_s) in - let args = List.map of_constr args in - let cl_context = List.map (Termops.map_rel_decl of_constr) (snd cl.cl_context) in - let _, args = - List.fold_right (fun decl (args, args') -> - match decl with - | LocalAssum _ -> (List.tl args, List.hd args :: args') + let sigma, (impls, ((env', ctx), imps)) = interp_context_evars env sigma ctx in + let sigma, (c', imps') = interp_type_evars_impls ~impls env' sigma tclass in + let len = Context.Rel.nhyps ctx in + let imps = imps @ Impargs.lift_implicits len imps' in + let ctx', c = decompose_prod_assum sigma c' in + let ctx'' = ctx' @ ctx in + let (k, u), args = Typeclasses.dest_class_app (push_rel_context ctx'' env) sigma c in + let u_s = EInstance.kind sigma u in + let cl = Typeclasses.typeclass_univ_instance (k, u_s) in + let args = List.map of_constr args in + let cl_context = List.map (Termops.map_rel_decl of_constr) (snd cl.cl_context) in + let _, args = + List.fold_right (fun decl (args, args') -> + match decl with + | LocalAssum _ -> (List.tl args, List.hd args :: args') | LocalDef (_,b,_) -> (args, Vars.substl args' b :: args')) - cl_context (args, []) - in - sigma, cl, u, c', ctx', ctx, len, imps, args + cl_context (args, []) + in + let sigma = Evarutil.nf_evar_map sigma in + let sigma = resolve_typeclasses ~filter:Typeclasses.all_evars ~fail:true env sigma in + sigma, cl, u, c', ctx', ctx, imps, args, decl + + +let new_instance ?(global=false) ?(refine= !refine_instance) ~program_mode + poly ctx (instid, bk, cl) props + ?(generalize=true) ?(tac:unit Proofview.tactic option) ?hook pri = + let env = Global.env() in + let ({CAst.loc;v=instid}, pl) = instid in + let sigma, k, u, cty, ctx', ctx, imps, subst, decl = + interp_instance_context env ~generalize ctx pl bk cl in let id = match instid with - Name id -> - let sp = Lib.make_path id in - if Nametab.exists_cci sp then - user_err ~hdr:"new_instance" (Id.print id ++ Pp.str " already exists."); - id - | Anonymous -> - let i = Nameops.add_suffix (id_of_class k) "_instance_0" in - Namegen.next_global_ident_away i (Termops.vars_of_env env) + | Name id -> id + | Anonymous -> + let i = Nameops.add_suffix (id_of_class k) "_instance_0" in + Namegen.next_global_ident_away i (Termops.vars_of_env env) in let env' = push_rel_context ctx env in - let sigma = Evarutil.nf_evar_map sigma in - let sigma = resolve_typeclasses ~filter:Typeclasses.all_evars ~fail:true env sigma in - if abstract then - do_abstract_instance env sigma ?hook ~global ~poly k u ctx ctx' pri decl imps subst id - else - do_transparent_instance env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode - cty k u ctx ctx' pri decl imps subst id props + do_instance env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode + cty k u ctx ctx' pri decl imps subst id props + +let declare_new_instance ?(global=false) poly ctx (instid, bk, cl) pri = + let env = Global.env() in + let ({CAst.loc;v=instid}, pl) = instid in + let sigma, k, u, cty, ctx', ctx, imps, subst, decl = + interp_instance_context env ctx pl bk cl + in + do_declare_instance env sigma ~global ~poly k u ctx ctx' pri decl imps subst instid let named_of_rel_context l = let open Vars in diff --git a/vernac/classes.mli b/vernac/classes.mli index eb6c0c92e1..6f61da66cf 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -40,7 +40,6 @@ val declare_instance_constant : unit val new_instance : - ?abstract:bool (** Not abstract by default. *) -> ?global:bool (** Not global by default. *) -> ?refine:bool (** Allow refinement *) -> program_mode:bool -> @@ -54,6 +53,14 @@ val new_instance : Hints.hint_info_expr -> Id.t +val declare_new_instance : + ?global:bool (** Not global by default. *) -> + Decl_kinds.polymorphic -> + local_binder_expr list -> + ident_decl * Decl_kinds.binding_kind * constr_expr -> + Hints.hint_info_expr -> + unit + (** Setting opacity *) val set_typeclass_transparency : evaluable_global_reference -> bool -> bool -> unit diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index 4af6415a4d..92b1ff7572 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -24,7 +24,7 @@ open Constrexpr_ops open Constrintern open Impargs open Reductionops -open Indtypes +open Type_errors open Pretyping open Indschemes open Context.Rel.Declaration @@ -34,6 +34,13 @@ module RelDecl = Context.Rel.Declaration (* 3b| Mutual inductive definitions *) +let warn_auto_template = + CWarnings.create ~name:"auto-template" ~category:"vernacular" ~default:CWarnings.Disabled + (fun id -> + Pp.(strbrk "Automatically declaring " ++ Id.print id ++ + strbrk " as template polymorphic. Use attributes or " ++ + strbrk "disable Auto Template Polymorphism to avoid this warning.")) + let should_auto_template = let open Goptions in let auto = ref true in @@ -44,7 +51,10 @@ let should_auto_template = optread = (fun () -> !auto); optwrite = (fun b -> auto := b); } in - fun () -> !auto + fun id would_auto -> + let b = !auto && would_auto in + if b then warn_auto_template id; + b let rec complete_conclusion a cs = CAst.map_with_loc (fun ?loc -> function | CProdN (bl,c) -> CProdN (bl,complete_conclusion a cs c) @@ -294,7 +304,7 @@ let inductive_levels env evd poly arities inds = let evd = if Sorts.is_set du then if not (Evd.check_leq evd cu Univ.type0_univ) then - raise (Indtypes.InductiveError Indtypes.LargeNonPropInductiveNotInType) + raise (InductiveError LargeNonPropInductiveNotInType) else evd else evd (* Evd.set_leq_sort env evd (Type cu) du *) @@ -431,8 +441,8 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not if poly && template then user_err Pp.(strbrk "template and polymorphism not compatible"); template | None -> - should_auto_template () && not poly && - Option.cata (fun s -> not (Sorts.is_small s)) false concl + should_auto_template ind.ind_name (not poly && + Option.cata (fun s -> not (Sorts.is_small s)) false concl) in { mind_entry_typename = ind.ind_name; mind_entry_arity = arity; diff --git a/vernac/comInductive.mli b/vernac/comInductive.mli index 9df8f7c341..1d6f652385 100644 --- a/vernac/comInductive.mli +++ b/vernac/comInductive.mli @@ -46,7 +46,10 @@ val declare_mutual_inductive_with_eliminations : mutual_inductive_entry -> UnivNames.universe_binders -> one_inductive_impls list -> MutInd.t -val should_auto_template : unit -> bool +val should_auto_template : Id.t -> bool -> bool +(** [should_auto_template x b] is [true] when [b] is [true] and we + automatically use template polymorphism. [x] is the name of the + inductive under consideration. *) (** Exported for Funind *) diff --git a/vernac/egramcoq.ml b/vernac/egramcoq.ml index 43abc0a200..1a07d74a0e 100644 --- a/vernac/egramcoq.ml +++ b/vernac/egramcoq.ml @@ -146,7 +146,8 @@ let register_empty_levels accu forpat levels = (where, ans) :: rem, save_levels accu where nlev else rem, accu in - filter accu levels + let (l,accu) = filter accu levels in + List.rev l, accu let find_position accu custom forpat assoc level = let accu, (clev, plev) = find_levels accu custom in diff --git a/vernac/explainErr.ml b/vernac/explainErr.ml index e1496e58d7..71770a21ca 100644 --- a/vernac/explainErr.ml +++ b/vernac/explainErr.ml @@ -10,7 +10,6 @@ open Pp open CErrors -open Indtypes open Type_errors open Pretype_errors open Indrec diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 22528a607f..79adefdcf7 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -61,7 +61,8 @@ let make_bullet s = | _ -> assert false let parse_compat_version = let open Flags in function - | "8.9" -> Current + | "8.10" -> Current + | "8.9" -> V8_9 | "8.8" -> V8_8 | "8.7" -> V8_7 | ("8.6" | "8.5" | "8.4" | "8.3" | "8.2" | "8.1" | "8.0") as s -> @@ -683,19 +684,19 @@ GRAMMAR EXTEND Gram info = hint_info ; props = [ ":="; "{"; r = record_declaration; "}" -> { Some (true,r) } | ":="; c = lconstr -> { Some (false,c) } | -> { None } ] -> - { VernacInstance (false,snd namesup,(fst namesup,expl,t),props,info) } + { VernacInstance (snd namesup,(fst namesup,expl,t),props,info) } | IDENT "Existing"; IDENT "Instance"; id = global; info = hint_info -> - { VernacDeclareInstances [id, info] } + { VernacExistingInstance [id, info] } | IDENT "Existing"; IDENT "Instances"; ids = LIST1 global; pri = OPT [ "|"; i = natural -> { i } ] -> { let info = { Typeclasses.hint_priority = pri; hint_pattern = None } in let insts = List.map (fun i -> (i, info)) ids in - VernacDeclareInstances insts } + VernacExistingInstance insts } - | IDENT "Existing"; IDENT "Class"; is = global -> { VernacDeclareClass is } + | IDENT "Existing"; IDENT "Class"; is = global -> { VernacExistingClass is } (* Arguments *) | IDENT "Arguments"; qid = smart_global; @@ -809,9 +810,8 @@ GRAMMAR EXTEND Gram | IDENT "transparent" -> { Conv_oracle.transparent } ] ] ; instance_name: - [ [ name = ident_decl; sup = OPT binders -> - { (CAst.map (fun id -> Name id) (fst name), snd name), - (Option.default [] sup) } + [ [ name = ident_decl; bl = binders -> + { (CAst.map (fun id -> Name id) (fst name), snd name), bl } | -> { ((CAst.make ~loc Anonymous), None), [] } ] ] ; hint_info: @@ -845,10 +845,10 @@ GRAMMAR EXTEND Gram [ [ IDENT "Comments"; l = LIST0 comment -> { VernacComments l } (* Hack! Should be in grammar_ext, but camlp5 factorizes badly *) - | IDENT "Declare"; IDENT "Instance"; namesup = instance_name; ":"; + | IDENT "Declare"; IDENT "Instance"; id = ident_decl; bl = binders; ":"; expl = [ "!" -> { Decl_kinds.Implicit } | -> { Decl_kinds.Explicit } ] ; t = operconstr LEVEL "200"; info = hint_info -> - { VernacInstance (true, snd namesup, (fst namesup, expl, t), None, info) } + { VernacDeclareInstance (bl, (id, expl, t), info) } (* Should be in syntax, but camlp5 would not factorize *) | IDENT "Declare"; IDENT "Scope"; sc = IDENT -> diff --git a/vernac/himsg.ml b/vernac/himsg.ml index a2b5c8d70a..ebbec86b9c 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -15,7 +15,6 @@ open Nameops open Namegen open Constr open Termops -open Indtypes open Environ open Pretype_errors open Type_errors @@ -511,7 +510,7 @@ let pr_trailing_ne_context_of env sigma = if List.is_empty (Environ.rel_context env) && List.is_empty (Environ.named_context env) then str "." - else (str " in environment:"++ pr_context_unlimited env sigma) + else (strbrk " in environment:" ++ pr_context_unlimited env sigma) let rec explain_evar_kind env sigma evk ty = let open Evar_kinds in @@ -551,21 +550,21 @@ let rec explain_evar_kind env sigma evk ty = strbrk "an instance of type " ++ ty ++ str " for the variable " ++ Id.print id | Evar_kinds.SubEvar (where,evk') -> - let evi = Evd.find sigma evk' in + let rec find_source evk = + let evi = Evd.find sigma evk in + match snd evi.evar_source with + | Evar_kinds.SubEvar (_,evk) -> find_source evk + | src -> evi,src in + let evi,src = find_source evk' in let pc = match evi.evar_body with | Evar_defined c -> pr_leconstr_env env sigma c | Evar_empty -> assert false in let ty' = evi.evar_concl in - (match where with - | Some Evar_kinds.Body -> str "the body of " - | Some Evar_kinds.Domain -> str "the domain of " - | Some Evar_kinds.Codomain -> str "the codomain of " - | None -> - pr_existential_key sigma evk ++ str " of type " ++ ty ++ - str " in the partial instance " ++ pc ++ - str " found for ") ++ - explain_evar_kind env sigma evk' - (pr_leconstr_env env sigma ty') (snd evi.evar_source) + pr_existential_key sigma evk ++ + strbrk " in the partial instance " ++ pc ++ + strbrk " found for " ++ + explain_evar_kind env sigma evk + (pr_leconstr_env env sigma ty') src let explain_typeclass_resolution env sigma evi k = match Typeclasses.class_of_constr sigma evi.evar_concl with @@ -1163,6 +1162,9 @@ let error_bad_entry () = let error_large_non_prop_inductive_not_in_type () = str "Large non-propositional inductive types must be in Type." +let error_inductive_bad_univs () = + str "Incorrect universe constrains declared for inductive type." + (* Recursion schemes errors *) let error_not_allowed_case_analysis env isrec kind i = @@ -1199,7 +1201,8 @@ let explain_inductive_error = function | NotAnArity (env, c) -> error_not_an_arity env c | BadEntry -> error_bad_entry () | LargeNonPropInductiveNotInType -> - error_large_non_prop_inductive_not_in_type () + error_large_non_prop_inductive_not_in_type () + | BadUnivs -> error_inductive_bad_univs () (* Recursion schemes errors *) diff --git a/vernac/himsg.mli b/vernac/himsg.mli index bab66b2af4..986906d303 100644 --- a/vernac/himsg.mli +++ b/vernac/himsg.mli @@ -8,7 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Indtypes open Environ open Type_errors open Pretype_errors diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 8f155adb8a..0dfbba0e83 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -340,7 +340,7 @@ let start_proof id ?pl kind sigma ?terminator ?sign ?(compute_guard=[]) ?hook c | None -> standard_proof_terminator ?hook compute_guard | Some terminator -> terminator ?hook compute_guard in - let sign = + let sign = match sign with | Some sign -> sign | None -> initialize_named_context_for_proof () diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 4e79b50b79..3da12e7714 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -1563,14 +1563,17 @@ let add_notation_extra_printing_rule df k v = (* Infix notations *) -let inject_var x = CAst.make @@ CRef (qualid_of_ident (Id.of_string x),None) +let inject_var x = CAst.make @@ CRef (qualid_of_ident x,None) let add_infix local env ({CAst.loc;v=inf},modifiers) pr sc = check_infix_modifiers modifiers; (* check the precedence *) - let metas = [inject_var "x"; inject_var "y"] in + let vars = names_of_constr_expr pr in + let x = Namegen.next_ident_away (Id.of_string "x") vars in + let y = Namegen.next_ident_away (Id.of_string "y") vars in + let metas = [inject_var x; inject_var y] in let c = mkAppC (pr,metas) in - let df = CAst.make ?loc @@ "x "^(quote_notation_token inf)^" y" in + let df = CAst.make ?loc @@ Id.to_string x ^" "^(quote_notation_token inf)^" "^Id.to_string y in add_notation local env c (df,modifiers) sc (**********************************************************************) diff --git a/vernac/mltop.ml b/vernac/mltop.ml index 8d6268753e..78e26c65d4 100644 --- a/vernac/mltop.ml +++ b/vernac/mltop.ml @@ -215,7 +215,7 @@ let add_vo_path ~recursive lp = let () = match lp.has_ml with | AddNoML -> () | AddTopML -> add_ml_dir unix_path - | AddRecML -> List.iter (fun (lp,_) -> add_ml_dir lp) dirs in + | AddRecML -> List.iter (fun (lp,_) -> add_ml_dir lp) dirs; add_ml_dir unix_path in let add (path, dir) = Loadpath.add_load_path path ~implicit dir in let () = List.iter add dirs in diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index e0dd3380f9..5eeeaada2d 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -887,10 +887,9 @@ open Pputils spc() ++ pr_class_rawexpr c2) ) - | VernacInstance (abst, sup, (instid, bk, cl), props, info) -> + | VernacInstance (sup, (instid, bk, cl), props, info) -> return ( hov 1 ( - (if abst then keyword "Declare" ++ spc () else mt ()) ++ keyword "Instance" ++ (match instid with | {loc; v = Name id}, l -> spc () ++ pr_ident_decl (CAst.(make ?loc id),l) ++ spc () @@ -906,13 +905,23 @@ open Pputils | None -> mt())) ) + | VernacDeclareInstance (sup, (instid, bk, cl), info) -> + return ( + hov 1 ( + keyword "Declare Instance" ++ spc () ++ pr_ident_decl instid ++ spc () ++ + pr_and_type_binders_arg sup ++ + str":" ++ spc () ++ + (match bk with Implicit -> str "! " | Explicit -> mt ()) ++ + pr_constr cl ++ pr_hint_info pr_constr_pattern_expr info) + ) + | VernacContext l -> return ( hov 1 ( keyword "Context" ++ pr_and_type_binders_arg l) ) - | VernacDeclareInstances insts -> + | VernacExistingInstance insts -> let pr_inst (id, info) = pr_qualid id ++ pr_hint_info pr_constr_pattern_expr info in @@ -922,7 +931,7 @@ open Pputils spc () ++ prlist_with_sep (fun () -> str", ") pr_inst insts) ) - | VernacDeclareClass id -> + | VernacExistingClass id -> return ( hov 1 (keyword "Existing" ++ spc () ++ keyword "Class" ++ spc () ++ pr_qualid id) ) diff --git a/vernac/pvernac.ml b/vernac/pvernac.ml index a647b2ef73..0e46df2320 100644 --- a/vernac/pvernac.ml +++ b/vernac/pvernac.ml @@ -12,6 +12,27 @@ open Pcoq let uvernac = create_universe "vernac" +type proof_mode = string + +(* Tactic parsing modes *) +let register_proof_mode, find_proof_mode, lookup_proof_mode = + let proof_mode : (string, Vernacexpr.vernac_expr Entry.t) Hashtbl.t = + Hashtbl.create 19 in + let register_proof_mode ename e = Hashtbl.add proof_mode ename e; ename in + let find_proof_mode ename = + try Hashtbl.find proof_mode ename + with Not_found -> + CErrors.anomaly Pp.(str "proof mode not found: " ++ str ename) in + let lookup_proof_mode name = + if Hashtbl.mem proof_mode name then Some name + else None + in + register_proof_mode, find_proof_mode, lookup_proof_mode + +let proof_mode_to_string name = name + +let command_entry_ref = ref None + module Vernac_ = struct let gec_vernac s = Entry.create ("vernac:" ^ s) @@ -39,17 +60,24 @@ module Vernac_ = ] in Pcoq.grammar_extend main_entry None (None, [None, None, rule]) - let command_entry_ref = ref noedit_mode + let select_tactic_entry spec = + match spec with + | None -> noedit_mode + | Some ename -> find_proof_mode ename + let command_entry = Pcoq.Entry.of_parser "command_entry" - (fun strm -> Pcoq.Entry.parse_token_stream !command_entry_ref strm) + (fun strm -> Pcoq.Entry.parse_token_stream (select_tactic_entry !command_entry_ref) strm) end -let main_entry = Vernac_.main_entry +module Unsafe = struct + let set_tactic_entry oname = command_entry_ref := oname +end -let set_command_entry e = Vernac_.command_entry_ref := e -let get_command_entry () = !Vernac_.command_entry_ref +let main_entry proof_mode = + Unsafe.set_tactic_entry proof_mode; + Vernac_.main_entry let () = register_grammar Genredexpr.wit_red_expr (Vernac_.red_expr); diff --git a/vernac/pvernac.mli b/vernac/pvernac.mli index b2f8f71462..fa251281dc 100644 --- a/vernac/pvernac.mli +++ b/vernac/pvernac.mli @@ -14,6 +14,8 @@ open Vernacexpr val uvernac : gram_universe +type proof_mode + module Vernac_ : sig val gallina : vernac_expr Entry.t @@ -24,13 +26,31 @@ module Vernac_ : val rec_definition : (fixpoint_expr * decl_notation list) Entry.t val noedit_mode : vernac_expr Entry.t val command_entry : vernac_expr Entry.t + val main_entry : (Loc.t * vernac_control) option Entry.t val red_expr : raw_red_expr Entry.t val hint_info : Hints.hint_info_expr Entry.t end +(* To be removed when the parser is made functional wrt the tactic + * non terminal *) +module Unsafe : sig + (* To let third party grammar entries reuse Vernac_ and + * do something with the proof mode *) + val set_tactic_entry : proof_mode option -> unit +end + (** The main entry: reads an optional vernac command *) -val main_entry : (Loc.t * vernac_control) option Entry.t +val main_entry : proof_mode option -> (Loc.t * vernac_control) option Entry.t + +(** Grammar entry for tactics: proof mode(s). + By default Coq's grammar has an empty entry (non-terminal) for + tactics. A plugin can register its non-terminal by providing a name + and a grammar entry. + + For example the Ltac plugin register the "Classic" grammar + entry for parsing its tactics. + *) -(** Handling of the proof mode entry *) -val get_command_entry : unit -> vernac_expr Entry.t -val set_command_entry : vernac_expr Entry.t -> unit +val register_proof_mode : string -> Vernacexpr.vernac_expr Entry.t -> proof_mode +val lookup_proof_mode : string -> proof_mode option +val proof_mode_to_string : proof_mode -> string diff --git a/vernac/record.ml b/vernac/record.ml index ffd4f654c6..2867ad1437 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -415,9 +415,9 @@ let declare_structure finite ubinders univs paramimpls params template ?(kind=St template | None, template -> (* auto detect template *) - ComInductive.should_auto_template () && template && not poly && + ComInductive.should_auto_template id (template && not poly && let _, s = Reduction.dest_arity (Global.env()) arity in - not (Sorts.is_small s) + not (Sorts.is_small s)) in { mind_entry_typename = id; mind_entry_arity = arity; diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml index 4065bb9c1f..b4b893a3fd 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -406,3 +406,24 @@ let with_output_to_file fname func input = deep_ft := Util.pi3 old_fmt; close_out channel; Exninfo.iraise reraise + +(* For coqtop -time, we display the position in the file, + and a glimpse of the executed command *) + +let pr_cmd_header {CAst.loc;v=com} = + let shorten s = + if Unicode.utf8_length s > 33 then (Unicode.utf8_sub s 0 30) ^ "..." else s + in + let noblank s = String.map (fun c -> + match c with + | ' ' | '\n' | '\t' | '\r' -> '~' + | x -> x + ) s + in + let (start,stop) = Option.cata Loc.unloc (0,0) loc in + let safe_pr_vernac x = + try Ppvernac.pr_vernac x + with e -> str (Printexc.to_string e) in + let cmd = noblank (shorten (string_of_ppcmds (safe_pr_vernac com))) + in str "Chars " ++ int start ++ str " - " ++ int stop ++ + str " [" ++ str cmd ++ str "] " diff --git a/vernac/topfmt.mli b/vernac/topfmt.mli index 0ddf474970..5f84c5edee 100644 --- a/vernac/topfmt.mli +++ b/vernac/topfmt.mli @@ -71,3 +71,4 @@ val print_err_exn : exn -> unit redirected to a file [file] *) val with_output_to_file : string -> ('a -> 'b) -> 'a -> 'b +val pr_cmd_header : Vernacexpr.vernac_control CAst.t -> Pp.t diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index e6e3db4beb..996fe320f9 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -489,6 +489,28 @@ let vernac_notation ~module_local = let vernac_custom_entry ~module_local s = Metasyntax.declare_custom_entry module_local s +(* Default proof mode, to be set at the beginning of proofs for + programs that cannot be statically classified. *) +let default_proof_mode = ref (Pvernac.register_proof_mode "Noedit" Pvernac.Vernac_.noedit_mode) +let get_default_proof_mode () = !default_proof_mode + +let get_default_proof_mode_opt () = Pvernac.proof_mode_to_string !default_proof_mode +let set_default_proof_mode_opt name = + default_proof_mode := + match Pvernac.lookup_proof_mode name with + | Some pm -> pm + | None -> CErrors.user_err Pp.(str (Format.sprintf "No proof mode named \"%s\"." name)) + +let proof_mode_opt_name = ["Default";"Proof";"Mode"] +let () = + Goptions.declare_string_option Goptions.{ + optdepr = false; + optname = "default proof mode" ; + optkey = proof_mode_opt_name; + optread = get_default_proof_mode_opt; + optwrite = set_default_proof_mode_opt; + } + (***********) (* Gallina *) @@ -1005,22 +1027,29 @@ let vernac_identity_coercion ~atts id qids qidt = (* Type classes *) -let vernac_instance ~atts abst sup inst props pri = +let vernac_instance ~atts sup inst props pri = let open DefAttributes in let atts = parse atts in let global = not (make_section_locality atts.locality) in Dumpglob.dump_constraint (fst (pi1 inst)) false "inst"; let program_mode = Flags.is_program_mode () in - ignore(Classes.new_instance ~program_mode ~abstract:abst ~global atts.polymorphic sup inst props pri) + ignore(Classes.new_instance ~program_mode ~global atts.polymorphic sup inst props pri) + +let vernac_declare_instance ~atts sup inst pri = + let open DefAttributes in + let atts = parse atts in + let global = not (make_section_locality atts.locality) in + Dumpglob.dump_definition (fst (pi1 inst)) false "inst"; + Classes.declare_new_instance ~global atts.polymorphic sup inst pri let vernac_context ~poly l = if not (Classes.context poly l) then Feedback.feedback Feedback.AddedAxiom -let vernac_declare_instances ~section_local insts = +let vernac_existing_instance ~section_local insts = let glob = not section_local in List.iter (fun (id, info) -> Classes.existing_instance glob id (Some info)) insts -let vernac_declare_class id = +let vernac_existing_class id = Record.declare_existing_class (Nametab.global id) (***********) @@ -2108,13 +2137,9 @@ exception End_of_input let vernac_load interp fname = if Proof_global.there_are_pending_proofs () then CErrors.user_err Pp.(str "Load is not supported inside proofs."); - let interp x = - let proof_mode = Proof_global.get_default_proof_mode_name () [@ocaml.warning "-3"] in - Proof_global.activate_proof_mode proof_mode [@ocaml.warning "-3"]; - interp x in - let parse_sentence = Flags.with_option Flags.we_are_parsing + let parse_sentence proof_mode = Flags.with_option Flags.we_are_parsing (fun po -> - match Pcoq.Entry.parse Pvernac.main_entry po with + match Pcoq.Entry.parse (Pvernac.main_entry proof_mode) po with | Some x -> x | None -> raise End_of_input) in let fname = @@ -2125,7 +2150,15 @@ let vernac_load interp fname = let in_chan = open_utf8_file_in longfname in Pcoq.Parsable.make ~file:(Loc.InFile longfname) (Stream.of_channel in_chan) in begin - try while true do interp (snd (parse_sentence input)) done + try while true do + let proof_mode = + if Proof_global.there_are_pending_proofs () then + Some (get_default_proof_mode ()) + else + None + in + interp (snd (parse_sentence proof_mode input)); + done with End_of_input -> () end; (* If Load left a proof open, we fail too. *) @@ -2227,11 +2260,13 @@ let interp ?proof ~atts ~st c = vernac_identity_coercion ~atts id s t (* Type classes *) - | VernacInstance (abst, sup, inst, props, info) -> - vernac_instance ~atts abst sup inst props info + | VernacInstance (sup, inst, props, info) -> + vernac_instance ~atts sup inst props info + | VernacDeclareInstance (sup, inst, info) -> + vernac_declare_instance ~atts sup inst info | VernacContext sup -> vernac_context ~poly:(only_polymorphism atts) sup - | VernacDeclareInstances insts -> with_section_locality ~atts vernac_declare_instances insts - | VernacDeclareClass id -> unsupported_attributes atts; vernac_declare_class id + | VernacExistingInstance insts -> with_section_locality ~atts vernac_existing_instance insts + | VernacExistingClass id -> unsupported_attributes atts; vernac_existing_class id (* Solving *) | VernacSolveExistential (n,c) -> unsupported_attributes atts; vernac_solve_existential n c @@ -2303,8 +2338,7 @@ let interp ?proof ~atts ~st c = Aux_file.record_in_aux_at "VernacProof" (tacs^" "^usings); Option.iter vernac_set_end_tac tac; Option.iter vernac_set_used_variables using - | VernacProofMode mn -> unsupported_attributes atts; - Proof_global.set_proof_mode mn [@ocaml.warning "-3"] + | VernacProofMode mn -> unsupported_attributes atts; () (* Extensions *) | VernacExtend (opn,args) -> @@ -2388,8 +2422,9 @@ let interp ?(verbosely=true) ?proof ~st {CAst.loc;v=c} = control v | VernacRedirect (s, {v}) -> Topfmt.with_output_to_file s control v - | VernacTime (batch, {v}) -> - System.with_time ~batch control v; + | VernacTime (batch, com) -> + let header = if batch then Topfmt.pr_cmd_header com else Pp.mt () in + System.with_time ~batch ~header control com.CAst.v; and aux ~atts : _ -> unit = function diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index 8d8d7cfcf0..4fbd3849b0 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -10,6 +10,11 @@ val dump_global : Libnames.qualid Constrexpr.or_by_notation -> unit +(** Default proof mode set by `start_proof` *) +val get_default_proof_mode : unit -> Pvernac.proof_mode + +val proof_mode_opt_name : string list + (** Vernacular entries *) val vernac_require : Libnames.qualid option -> bool option -> Libnames.qualid list -> unit diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index 417c9ebfbd..68a17e316e 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -300,18 +300,22 @@ type nonrec vernac_expr = (* Type classes *) | VernacInstance of - bool * (* abstract instance *) local_binder_expr list * (* super *) typeclass_constraint * (* instance name, class name, params *) (bool * constr_expr) option * (* props *) Hints.hint_info_expr + | VernacDeclareInstance of + local_binder_expr list * (* super *) + (ident_decl * Decl_kinds.binding_kind * constr_expr) * (* instance name, class name, params *) + Hints.hint_info_expr + | VernacContext of local_binder_expr list - | VernacDeclareInstances of + | VernacExistingInstance of (qualid * Hints.hint_info_expr) list (* instances names, priorities and patterns *) - | VernacDeclareClass of qualid (* inductive or definition name *) + | VernacExistingClass of qualid (* inductive or definition name *) (* Modules and Module Types *) | VernacDeclareModule of bool option * lident * diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index 05687afd8b..f5cf3401d0 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -29,15 +29,15 @@ type vernac_type = parallel : [ `Yes of solving_tac * anon_abstracting_tac | `No ]; proof_block_detection : proof_block_name option } - (* To be removed *) - | VtProofMode of string (* Queries are commands assumed to be "pure", that is to say, they don't modify the interpretation state. *) | VtQuery + (* Commands that change the current proof mode *) + | VtProofMode of string (* To be removed *) | VtMeta | VtUnknown -and vernac_start = string * opacity_guarantee * Names.Id.t list +and vernac_start = opacity_guarantee * Names.Id.t list and vernac_sideff_type = Names.Id.t list and opacity_guarantee = | GuaranteesOpacity (** Only generates opaque terms at [Qed] *) diff --git a/vernac/vernacextend.mli b/vernac/vernacextend.mli index 0d43eb1ee8..118907c31b 100644 --- a/vernac/vernacextend.mli +++ b/vernac/vernacextend.mli @@ -45,15 +45,15 @@ type vernac_type = parallel : [ `Yes of solving_tac * anon_abstracting_tac | `No ]; proof_block_detection : proof_block_name option } - (* To be removed *) - | VtProofMode of string (* Queries are commands assumed to be "pure", that is to say, they don't modify the interpretation state. *) | VtQuery + (* Commands that change the current proof mode *) + | VtProofMode of string (* To be removed *) | VtMeta | VtUnknown -and vernac_start = string * opacity_guarantee * Names.Id.t list +and vernac_start = opacity_guarantee * Names.Id.t list and vernac_sideff_type = Names.Id.t list and opacity_guarantee = | GuaranteesOpacity (** Only generates opaque terms at [Qed] *) diff --git a/vernac/vernacstate.ml b/vernac/vernacstate.ml index b40bccf27e..c691dc8559 100644 --- a/vernac/vernacstate.ml +++ b/vernac/vernacstate.ml @@ -8,10 +8,30 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +module Parser = struct + + type state = Pcoq.frozen_t + + let init () = Pcoq.freeze ~marshallable:false + + let cur_state () = Pcoq.freeze ~marshallable:false + + let parse ps entry pa = + Pcoq.unfreeze ps; + Flags.with_option Flags.we_are_parsing (fun () -> + try Pcoq.Entry.parse entry pa + with e when CErrors.noncritical e -> + let (e, info) = CErrors.push e in + Exninfo.iraise (e, info)) + () + +end + type t = { - system : States.state; (* summary + libstack *) - proof : Proof_global.t; (* proof state *) - shallow : bool (* is the state trimmed down (libstack) *) + parsing: Parser.state; + system : States.state; (* summary + libstack *) + proof : Proof_global.t; (* proof state *) + shallow : bool; (* is the state trimmed down (libstack) *) } let s_cache = ref None @@ -36,11 +56,14 @@ let do_if_not_cached rf f v = let freeze_interp_state ~marshallable = { system = update_cache s_cache (States.freeze ~marshallable); proof = update_cache s_proof (Proof_global.freeze ~marshallable); - shallow = marshallable } + shallow = false; + parsing = Parser.cur_state (); + } -let unfreeze_interp_state { system; proof } = +let unfreeze_interp_state { system; proof; parsing } = do_if_not_cached s_cache States.unfreeze system; - do_if_not_cached s_proof Proof_global.unfreeze proof + do_if_not_cached s_proof Proof_global.unfreeze proof; + Pcoq.unfreeze parsing let make_shallow st = let lib = States.lib_of_state st.system in diff --git a/vernac/vernacstate.mli b/vernac/vernacstate.mli index ed20cb935a..581c23386a 100644 --- a/vernac/vernacstate.mli +++ b/vernac/vernacstate.mli @@ -8,10 +8,21 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +module Parser : sig + type state + + val init : unit -> state + val cur_state : unit -> state + + val parse : state -> 'a Pcoq.Entry.t -> Pcoq.Parsable.t -> 'a + +end + type t = { - system : States.state; (* summary + libstack *) - proof : Proof_global.t; (* proof state *) - shallow : bool (* is the state trimmed down (libstack) *) + parsing: Parser.state; + system : States.state; (* summary + libstack *) + proof : Proof_global.t; (* proof state *) + shallow : bool; (* is the state trimmed down (libstack) *) } val freeze_interp_state : marshallable:bool -> t |