diff options
571 files changed, 25354 insertions, 17997 deletions
diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index 4a126c4e5a..8dbdf43e52 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -118,7 +118,15 @@ /gramlib/ @coq/parsing-maintainers /parsing/ @coq/parsing-maintainers -########## Plugins ########## +########## Standard library and plugins ########## + +/theories/ @coq/stdlib-maintainers + +/theories/Classes/ @coq/typeclasses-maintainers + +/theories/Reals/ @coq/reals-library-maintainers + +/theories/Compat/ @coq/compat-maintainers /plugins/btauto/ @coq/btauto-maintainers /theories/btauto/ @coq/btauto-maintainers @@ -195,16 +203,6 @@ /tactics/class_tactics.* @coq/typeclasses-maintainers /test-suite/typeclasses/ @coq/typeclasses-maintainers -########## Standard library ########## - -/theories/ @coq/stdlib-maintainers - -/theories/Classes/ @coq/typeclasses-maintainers - -/theories/Reals/ @coq/reals-library-maintainers - -/theories/Compat/ @coq/compat-maintainers - ########## Tools ########## /tools/coqdoc/ @coq/coqdoc-maintainers diff --git a/.gitignore b/.gitignore index b665b2f86d..adbf9dd189 100644 --- a/.gitignore +++ b/.gitignore @@ -184,11 +184,6 @@ plugins/ssr/ssrvernac.ml META.coq # Files automatically generated by Dune. -plugins/*/dune -theories/*/dune -theories/*/*/dune -theories/*/*/*/dune -/user-contrib/Ltac2/dune *.install !Makefile.install diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index f2e0c362b4..70e04ee205 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -18,7 +18,7 @@ stages: variables: # Format: $IMAGE-V$DATE [Cache is not used as of today but kept here # for reference] - CACHEKEY: "bionic_coq-V2020-03-19-V29" + CACHEKEY: "bionic_coq-V2020-03-13-V69" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -41,6 +41,7 @@ docker-boot: except: variables: - $SKIP_DOCKER == "true" + - $ONLY_WINDOWS == "true" tags: - docker @@ -62,6 +63,9 @@ before_script: # TODO figure out how to build doc for installed Coq .build-template: stage: stage-1 + except: + variables: + - $ONLY_WINDOWS == "true" interruptible: true artifacts: name: "$CI_JOB_NAME" @@ -100,11 +104,15 @@ before_script: # Template for building Coq + stdlib, typical use: overload the switch .dune-template: stage: stage-1 + except: + variables: + - $ONLY_WINDOWS == "true" interruptible: true dependencies: [] script: # flambda can be pretty stack hungry, specially with -O3 # See also https://github.com/ocaml/ocaml/issues/7842#issuecomment-596863244 + # and https://github.com/coq/coq/pull/11916#issuecomment-609977375 - ulimit -s 16384 - set -e - make -f Makefile.dune world @@ -123,6 +131,9 @@ before_script: .dune-ci-template: stage: stage-2 + except: + variables: + - $ONLY_WINDOWS == "true" interruptible: true needs: - build:edge+flambda:dune:dev @@ -150,6 +161,9 @@ before_script: .doc-template: stage: stage-2 + except: + variables: + - $ONLY_WINDOWS == "true" interruptible: true dependencies: - not-a-real-job @@ -166,6 +180,9 @@ before_script: # set dependencies when using .test-suite-template: stage: stage-2 + except: + variables: + - $ONLY_WINDOWS == "true" interruptible: true dependencies: - not-a-real-job @@ -188,11 +205,17 @@ before_script: # set dependencies when using .validate-template: stage: stage-2 + except: + variables: + - $ONLY_WINDOWS == "true" interruptible: true dependencies: - not-a-real-job script: - - cd _install_ci + # exit 0: workaround for https://gitlab.com/gitlab-org/gitlab/issues/202505 + # the validate:quick job is sometimes started before build:quick, without artifacts + # we ignore these spurious errors so if the job fails it's a real error + - cd _install_ci || exit 0 - find lib/coq/ -name '*.vo' -fprint0 vofiles - xargs -0 --arg-file=vofiles bin/coqchk -o -m -coqlib lib/coq/ > ../coqchk.log 2>&1 || touch coqchk.failed - tail -n 1000 ../coqchk.log # the log is too big for gitlab so pipe to a file and display the tail @@ -205,6 +228,9 @@ before_script: .ci-template: stage: stage-2 + except: + variables: + - $ONLY_WINDOWS == "true" interruptible: true script: - set -e @@ -248,6 +274,9 @@ before_script: .deploy-template: stage: deploy + except: + variables: + - $ONLY_WINDOWS == "true" before_script: - which ssh-agent || ( apt-get update -y && apt-get install openssh-client -y ) - eval $(ssh-agent -s) @@ -349,6 +378,9 @@ pkg:opam: .nix-template: image: nixorg/nix:latest # Minimal NixOS image which doesn't even contain git + except: + variables: + - $ONLY_WINDOWS == "true" interruptible: true stage: stage-1 variables: @@ -537,6 +569,30 @@ test-suite:edge:dune:dev: # Gitlab doesn't support yet "expire_in: never" so we use the instance default # expire_in: never +test-suite:edge+4.11+trunk+dune: + stage: stage-1 + dependencies: [] + script: + - opam switch create 4.11.0 --empty + - eval $(opam env) + - opam repo add ocaml-beta https://github.com/ocaml/ocaml-beta-repository.git + - opam update + - opam install ocaml-variants=4.11.0+trunk + - opam install dune num + - eval $(opam env) + - export COQ_UNIT_TEST=noop + - make -f Makefile.dune test-suite + variables: + OPAM_SWITCH: base + artifacts: + name: "$CI_JOB_NAME.logs" + when: always + paths: + - _build/log + - _build/default/test-suite/logs + expire_in: 2 week + allow_failure: true + test-suite:base+async: extends: .test-suite-template dependencies: @@ -620,6 +676,9 @@ library:ci-color: library:ci-compcert: extends: .ci-template-flambda +library:ci-coq_tools: + extends: .ci-template + library:ci-coqprime: stage: stage-3 extends: .ci-template-flambda @@ -637,14 +696,17 @@ library:ci-coqprime: library:ci-coquelicot: extends: .ci-template -library:ci-cross-crypto: +library:ci-cross_crypto: extends: .ci-template -library:ci-fcsl-pcm: +library:ci-fcsl_pcm: extends: .ci-template -library:ci-fiat-crypto: - extends: .ci-template-flambda +# We cannot use flambda due to +# https://github.com/ocaml/ocaml/issues/7842, see +# https://github.com/coq/coq/pull/11916#issuecomment-609977375 +library:ci-fiat_crypto: + extends: .ci-template stage: stage-4 needs: - build:edge+flambda @@ -657,7 +719,11 @@ library:ci-fiat-crypto: - plugin:ci-rewriter library:ci-flocq: - extends: .ci-template + extends: .ci-template-flambda + artifacts: + name: "$CI_JOB_NAME" + paths: + - _build_ci library:ci-corn: extends: .ci-template-flambda @@ -665,10 +731,10 @@ library:ci-corn: needs: - build:edge+flambda - plugin:ci-bignums - - library:ci-math-classes + - library:ci-math_classes dependencies: - build:edge+flambda - - library:ci-math-classes + - library:ci-math_classes library:ci-geocoq: extends: .ci-template-flambda @@ -676,10 +742,10 @@ library:ci-geocoq: library:ci-hott: extends: .ci-template -library:ci-iris-lambda-rust: +library:ci-lambda_rust: extends: .ci-template-flambda -library:ci-math-classes: +library:ci-math_classes: extends: .ci-template-flambda stage: stage-3 artifacts: @@ -693,7 +759,7 @@ library:ci-math-classes: - build:edge+flambda - plugin:ci-bignums -library:ci-math-comp: +library:ci-mathcomp: extends: .ci-template-flambda library:ci-sf: @@ -708,11 +774,18 @@ library:ci-tlc: library:ci-unimath: extends: .ci-template-flambda -library:ci-verdi-raft: +library:ci-verdi_raft: extends: .ci-template-flambda library:ci-vst: extends: .ci-template-flambda + stage: stage-3 + needs: + - build:edge+flambda + - library:ci-flocq + dependencies: + - build:edge+flambda + - library:ci-flocq # Plugins are by definition the projects that depend on Coq's ML API @@ -9,7 +9,9 @@ ## If you're mentioned here and want to update your information, ## either amend this file and commit it, or contact the coqdev list +Guillaume Allais <guillaume.allais@ens-lyon.org> gallais <guillaume.allais@ens-lyon.org> Abhishek Anand <abhishek.anand.iitg@gmail.com> Abhishek Anand (@brixpro-home) <abhishek.anand.iitg@gmail.com> +Abhishek Anand <abhishek.anand.iitg@gmail.com> Abhishek Anand (optiplex7010@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> @@ -21,13 +23,17 @@ Yves Bertot <yves.bertot@inria.fr> Yves Bertot <Yves.Bertot@inri Yves Bertot <yves.bertot@inria.fr> Yves Bertot <bertot@nardis.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> +Lasse Blaauwbroek <lasse@blaauwbroek.eu> Lasse Blaauwbroek <lasse@lasse-work.localdomain> Simon Boulier <simon.boulier@ens-rennes.fr> SimonBoulier <simon.boulier@ens-rennes.fr> +Simon Boulier <simon.boulier@ens-rennes.fr> SimonBoulier <SimonBoulier@users.noreply.github.com> 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> +Michele Caci <michele.caci@gmail.com> mcaci <michele.caci@gmail.com> 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> +Cyril Cohen <cohen@crans.org> Cyril Cohen <CohenCyril@users.noreply.github.com> Pierre Corbineau <Pierre.Corbineau@NOSPAM@imag.fr> corbinea <corbinea@85f007b7-540e-0410-9357-904b9bb8a0f7> Judicaël Courant <courant@gforge> courant <courant@85f007b7-540e-0410-9357-904b9bb8a0f7> Pierre Courtieu <Pierre.Courtieu@cnam.fr> courtieu <courtieu@85f007b7-540e-0410-9357-904b9bb8a0f7> @@ -39,8 +45,10 @@ Maxime Dénès <mail@maximedenes.fr> Maxime Dénès <maxime.dene 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> +formalize.eth <formalize@protonmail.com> ilya <ilya@localhost.localdomain> Andres Erbsen <andreser@mit.edu> Andres Erbsen <andres@kevix.co> Jim Fehrle <jfehrle@sbcglobal.net> Jim <jfehrle@sbcglobal.net> +Jim Fehrle <jfehrle@sbcglobal.net> Jim Fehrle <jim.fehrle@gmail.com> Jean-Christophe Filliâtre <Jean-Christophe.Filliatre@lri.fr> filliatr <filliatr@85f007b7-540e-0410-9357-904b9bb8a0f7> Jean-Christophe Filliâtre <Jean-Christophe.Filliatre@lri.fr> Jean-Christophe Filliatre <Jean-Christophe.Filliatre@lri.fr> Julien Forest <julien.forest@ensiie.fr> jforest <jforest@85f007b7-540e-0410-9357-904b9bb8a0f7> @@ -63,6 +71,7 @@ Jason Gross <jgross@mit.edu> Jason Gross <jasongross9@gmai Vincent Gross <vgross@gforge> vgross <vgross@85f007b7-540e-0410-9357-904b9bb8a0f7> Huang Guan-Shieng <huang@gforge> huang <huang@85f007b7-540e-0410-9357-904b9bb8a0f7> Hugo Herbelin <Hugo.Herbelin@inria.fr> herbelin <herbelin@85f007b7-540e-0410-9357-904b9bb8a0f7> +Hugo Herbelin <Hugo.Herbelin@inria.fr> Hugo Herbelin <herbelin@users.noreply.github.com> Jasper Hugunin <jasperh@cs.washington.edu> Jasper Hugunin <jasper@hashplex.com> Tom Hutchinson <thutchin@gforge> thutchin <thutchin@85f007b7-540e-0410-9357-904b9bb8a0f7> Cezary Kaliszyk <cek@gforge> cek <cek@85f007b7-540e-0410-9357-904b9bb8a0f7> @@ -74,13 +83,18 @@ Matej Košík <matej.kosik@inria.fr> Matej Kosik <matej.kosik@in Matej Košík <matej.kosik@inria.fr> Matej Košík <mail@matej-kosik.net> 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> +Vincent Laporte <Vincent.Laporte@inria.fr> Vincent Laporte <Vincent.Laporte@gmail.com> +Vincent Laporte <Vincent.Laporte@inria.fr> Vincent Laporte <Vincent.Laporte@fondation-inria.fr> Marc Lasson <marc.lasson@gmail.com> mlasson <marc.lasson@gmail.com> William Lawvere <mundungus.corleone@gmail.com> william-lawvere <mundungus.corleone@gmail.com> +Larry Darryl Lee Jr. <llee454@gmail.com> llee454@gmail.com <llee454@gmail.com> +Xavier Leroy <xavier.leroy@college-de-france.fr> Xavier Leroy <xavier.leroy@inria.fr> 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> +Yishuai Li <yishuai@cis.upenn.edu> Yishuai Li <yishuai@upenn.edu> Assia Mahboubi <assia.mahboubi@inria.fr> amahboub <amahboub@85f007b7-540e-0410-9357-904b9bb8a0f7> +Kenji Maillard <kenji.maillard@inria.fr> Kenji Maillard <kenji@maillard.blue> Evgeny Makarov <emakarov@gforge> emakarov <emakarov@85f007b7-540e-0410-9357-904b9bb8a0f7> Gregory Malecha <gmalecha@eecs.harvard.edu> Gregory Malecha <gmalecha@cs.harvard.edu> Gregory Malecha <gmalecha@eecs.harvard.edu> Gregory Malecha <gmalecha@gmail.com> @@ -101,11 +115,15 @@ 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> +Pierre-Marie Pédrot <pierre-marie.pedrot@inria.fr> Pierre-Marie Pédrot <pierre-marie.pedrot@irif.fr> 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> +Clément Pit-Claudel <clement.pitclaudel@live.com> Clément Pit-Claudel <cpitclaudel@users.noreply.github.com> Loïc Pottier <pottier@gforge> pottier <pottier@85f007b7-540e-0410-9357-904b9bb8a0f7> Matthias Puech <puech@gforge> puech <puech@85f007b7-540e-0410-9357-904b9bb8a0f7> +Robert Rand <rnrand@gmail.com> Robert Rand <rxtreme@gmail.com> Lars Rasmusson <lars.rasmusson@sics.se> larsr <Lars.Rasmusson@sics.se> +Lars Rasmusson <lars.rasmusson@sics.se> larsr <Lars.Rasmusson@gmail.com> Daniel de Rauglaudre <daniel.de_rauglaudre@inria.fr> ddr <ddr@85f007b7-540e-0410-9357-904b9bb8a0f7> Daniel de Rauglaudre <daniel.de_rauglaudre@inria.fr> Daniel de Rauglaudre <daniel.de_rauglaudre@inria.fr> Daniel de Rauglaudre <daniel.de_rauglaudre@inria.fr> Daniel De Rauglaudre <ddr@gforge> @@ -116,6 +134,7 @@ Pierre Roux <pierre@roux01.fr> Pierre Roux <pierre.roux@oner 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> +Kazuhiko Sakaguchi <pi8027@gmail.com> Kazuhiko Sakaguchi <sakaguchi@peano-system.jp> Vincent Siles <vsiles@gforge> vsiles <vsiles@85f007b7-540e-0410-9357-904b9bb8a0f7> Michael Soegtrop <michael.soegtrop@intel.com> Michael Soegtrop <7895506+MSoegtropIMC@users.noreply.github.com> Elie Soubiran <soubiran@gforge> soubiran <soubiran@85f007b7-540e-0410-9357-904b9bb8a0f7> @@ -138,8 +157,9 @@ Benjamin Werner <werner@gforge> werner <werner@85f007b7-540e- Wang Zhuyang <hawnzug@gmail.com> hawnzug <hawnzug@gmail.com> Beta Ziliani <beta@mpi-sws.org> Beta Ziliani <bziliani@famaf.unc.edu.ar> Beta Ziliani <beta@mpi-sws.org> beta <beta@mpi-sws.org> -Théo Zimmermann <theo.zimmermann@univ-paris-diderot.fr> Theo Zimmermann <theo.zimmermann@ens.fr> -Théo Zimmermann <theo.zimmermann@univ-paris-diderot.fr> Théo Zimmermann <theo.zimmi@gmail.com> +Théo Zimmermann <theo.zimmermann@inria.fr> Theo Zimmermann <theo.zimmermann@ens.fr> +Théo Zimmermann <theo.zimmermann@inria.fr> Théo Zimmermann <theo.zimmi@gmail.com> +Théo Zimmermann <theo.zimmermann@inria.fr> Théo Zimmermann <theo.zimmermann@univ-paris-diderot.fr> # Anonymous accounts diff --git a/.ocamlformat b/.ocamlformat index 4480935e3b..62e609fb55 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,4 @@ -version=0.13.0 +version=0.14.0 profile=ocamlformat # to enable a whole directory, put "disable=false" in dir/.ocamlformat @@ -11,4 +11,4 @@ cases-exp-indent=2 field-space=loose exp-grouping=preserve break-cases=fit -doc-comments=before +doc-comments-val=before diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index d9adaf5dc7..3582d18cf6 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -30,17 +30,18 @@ well. - [Helping triage existing issues](#helping-triage-existing-issues) - [Code changes](#code-changes) - [Using GitHub pull requests](#using-github-pull-requests) + - [Fixing bugs and performing small changes](#fixing-bugs-and-performing-small-changes) + - [Proposing large changes: Coq Enhancement Proposals](#proposing-large-changes-coq-enhancement-proposals) + - [Seeking early feedback on work-in-progress](#seeking-early-feedback-on-work-in-progress) - [Taking feedback into account](#taking-feedback-into-account) - [Understanding automatic feedback](#understanding-automatic-feedback) - [Understanding reviewers' feedback](#understanding-reviewers-feedback) - [Fixing your branch](#fixing-your-branch) - [Improving the official documentation](#improving-the-official-documentation) - [Contributing to the standard library](#contributing-to-the-standard-library) - - [Fixing bugs and performing small changes](#fixing-bugs-and-performing-small-changes) - - [Proposing large changes: Coq Enhancement Proposals](#proposing-large-changes-coq-enhancement-proposals) - - [Collaborating on a pull request](#collaborating-on-a-pull-request) - [Becoming a maintainer](#becoming-a-maintainer) - [Reviewing pull requests](#reviewing-pull-requests) + - [Collaborating on a pull request](#collaborating-on-a-pull-request) - [Merging pull requests](#merging-pull-requests) - [Additional notes for pull request reviewers and assignees](#additional-notes-for-pull-request-reviewers-and-assignees) - [Joining / leaving maintainer teams](#joining--leaving-maintainer-teams) @@ -443,6 +444,72 @@ several months after your PR is merged). That said, you can start using the latest Coq `master` branch to take advantage of all the new features, improvements, and fixes. +#### Fixing bugs and performing small changes #### + +Before fixing a bug, it is best to check that it was reported before: + +- If it was already reported and you intend to fix it, self-assign the + issue (if you have the permission), or leave a comment marking your + intention to work on it (and a contributor with write-access may + then assign the issue to you). + +- If the issue already has an assignee, you should check with them if + they still intend to work on it. If the assignment is several + weeks, months, or even years (!) old, there are good chances that it + does not reflect their current priorities. + +- If the bug has not been reported before, it can be a good idea to + open an issue about it, while stating that you are preparing a fix. + The issue can be the place to discuss about the bug itself while the + PR will be the place to discuss your proposed fix. + +It is generally a good idea to add a regression test to the +test-suite. See the test-suite [README][test-suite-README] for how to +do so. + +Small fixes do not need any documentation, or changelog update. New, +or updated, user-facing features, and major bug fixes do. See above +on how to contribute to the documentation, and the README in +[`doc/changelog`][user-changelog] for how to add a changelog entry. + +#### Proposing large changes: Coq Enhancement Proposals #### + +You are always welcome to open a PR for a change of any size. +However, you should be aware that the larger the change, the higher +the chances it will take very long to review, and possibly never get +merged. + +So it is recommended that before spending a lot of time coding, you +seek feedback from maintainers to see if your change would be +supported, and if they have recommendations about its implementation. +You can do this informally by opening an issue, or more formally by +producing a design document as a [Coq Enhancement Proposal][CEP]. + +Another recommendation is that you do not put several unrelated +changes in the same PR (even if you produced them together). In +particular, make sure you split bug fixes into separate PRs when this +is possible. More generally, smaller-sized PRs, or PRs changing less +components, are more likely to be reviewed and merged promptly. + +#### Seeking early feedback on work-in-progress #### + +You should always feel free to open your PR before the documentation, +changelog entry and tests are ready. That's the purpose of the +checkboxes in the PR template which you can leave unticked. This can +be a way of getting reviewers' approval before spending time on +writing the documentation (but you should still do it before your PR +can be merged). + +If even the implementation is not ready but you are still looking for +early feedback on your code changes, please use the [draft +PR](#draft-pull-requests) mechanism. + +If you are looking for feedback on the design of your change, rather +than on its implementation, then please refrain from opening a PR. +You may open an issue to start a discussion, or create a [Coq +Enhancement Proposal][CEP] if you have a clear enough view of the +design to write a document about it. + ### Taking feedback into account ### #### Understanding automatic feedback #### @@ -503,9 +570,10 @@ We have a linter that checks a few different things: [Style guide](#style-guide) for additional style recommendations. - **Code is properly formatted**: for some parts of the codebase, formatting will be enforced using the - [`ocamlformat`](https://github.com/ocaml-ppx/ocamlformat) tool. You - can integrate the formatter in your editor of choice (see docs) or - use `dune build @fmt --auto-promote` to fix this kind of errors. + [`ocamlformat`](https://github.com/ocaml-ppx/ocamlformat) tool. + Formatting issues will also be fixed automatically by the pre-commit + hook mentioned above (you may also use `dune build @fmt + --auto-promote` to fix this kind of errors). You may run the linter yourself with `dev/lint-repository.sh`. @@ -643,59 +711,35 @@ Add coqdoc comments to extend the [standard library documentation][stdlib-doc]. See the [coqdoc documentation][coqdoc-documentation] to learn more. -### Fixing bugs and performing small changes ### - -Before fixing a bug, it is best to check that it was reported before: - -- If it was already reported and you intend to fix it, self-assign the - issue (if you have the permission), or leave a comment marking your - intention to work on it (and a contributor with write-access may - then assign the issue to you). - -- If the issue already has an assignee, you should check with them if - they still intend to work on it. If the assignment is several - weeks, months, or even years (!) old, there are good chances that it - does not reflect their current priorities. - -- If the bug has not been reported before, it can be a good idea to - open an issue about it, while stating that you are preparing a fix. - The issue can be the place to discuss about the bug itself while the - PR will be the place to discuss your proposed fix. - -In any case, feel free to just ignore the recommendation above, and -jump ahead and open a PR with your fix. If it is not yet complete, do -not hesitate to open a [*draft PR*][GitHub-draft-PR] to get early -feedback, and talk to developers on [Gitter][]. - -It is generally a good idea to add a regression test to the -test-suite. See the test-suite [README][test-suite-README] for how to -do so. - -Small fixes do not need any documentation, or changelog update. New, -or updated, user-facing features, and major bug fixes do. See above -on how to contribute to the documentation, and the README in -[`doc/changelog`][user-changelog] for how to add a changelog entry. +## Becoming a maintainer ## -### Proposing large changes: Coq Enhancement Proposals ### +### Reviewing pull requests ### -You are always welcome to open a PR for a change of any size. -However, you should be aware that the larger the change, the higher -the chances it will take very long to review, and possibly never get -merged. +You can start reviewing PRs as soon as you feel comfortable doing so +(anyone can review anything, although some designated reviewers +will have to give a final approval before a PR can be merged, as is +explained in the next sub-section). -So it is recommended that before spending a lot of time coding, you -seek feedback from maintainers to see if your change would be -supported, and if they have recommendations about its implementation. -You can do this informally by opening an issue, or more formally by -producing a design document as a [Coq Enhancement Proposal][CEP]. +Reviewers should ensure that the code that is changed or introduced is +in good shape and will not be a burden to maintain, is unlikely to +break anything, or the compatibility-breakage has been identified and +validated, includes documentation, changelog entries, and test files +when necessary. Reviewers can use labels, or change requests to +further emphasize what remains to be changed before they can approve +the PR. Once reviewers are satisfied (regarding the part they +reviewed), they should formally approve the PR, possibly stating what +they reviewed. -Another recommendation is that you do not put several unrelated -changes in the same PR (even if you produced them together). In -particular, make sure you split bug fixes into separate PRs when this -is possible. More generally, smaller-sized PRs, or PRs changing less -components, are more likely to be reviewed and merged promptly. +That being said, reviewers should also make sure that they do not make +the contributing process harder than necessary: they should make it +clear which comments are really required to perform before approving, +and which are just suggestions. They should strive to reduce the +number of rounds of feedback that are needed by posting most of their +comments at the same time. If they are opposed to the change, they +should clearly say so from the beginning to avoid the contributor +spending time in vain. -### Collaborating on a pull request ### +#### Collaborating on a pull request #### Beyond making suggestions to a PR author during the review process, you may want to collaborate further by checking out the code, making @@ -720,42 +764,14 @@ else), this should be reflected by adding ["Co-authored-by:" tags][GitHub-co-authored-by] at the end of the commit message. The line should contain the co-author name and committer e-mail address. -## Becoming a maintainer ## - -### Reviewing pull requests ### - -You can start reviewing PRs as soon as you feel comfortable doing so -(anyone can review anything, although some designated reviewers -will have to give a final approval before a PR can be merged, as is -explained in the next sub-section). - -Reviewers should ensure that the code that is changed or introduced is -in good shape and will not be a burden to maintain, is unlikely to -break anything, or the compatibility-breakage has been identified and -validated, includes documentation, changelog entries, and test files -when necessary. Reviewers can use labels, or change requests to -further emphasize what remains to be changed before they can approve -the PR. Once reviewers are satisfied (regarding the part they -reviewed), they should formally approve the PR, possibly stating what -they reviewed. - -That being said, reviewers should also make sure that they do not make -the contributing process harder than necessary: they should make it -clear which comments are really required to perform before approving, -and which are just suggestions. They should strive to reduce the -number of rounds of feedback that are needed by posting most of their -comments at the same time. If they are opposed to the change, they -should clearly say so from the beginning to avoid the contributor -spending time in vain. - ### Merging pull requests ### Our [CODEOWNERS][] file associates a team of maintainers to each -component. When a PR is opened (or a draft PR is marked as ready for -review), GitHub will automatically request reviews to maintainer teams -of affected components. As soon as it is the case, one available -member of a team that was requested a review should self-assign the -PR, and will act as its shepherd from then on. +component. When a PR is opened (or a [draft PR](#draft-pull-requests) +is marked as ready for review), GitHub will automatically request +reviews to maintainer teams of affected components. As soon as it is +the case, one available member of a team that was requested a review +should self-assign the PR, and will act as its shepherd from then on. The PR assignee is responsible for making sure that all the proposed changes have been reviewed by relevant maintainers (at least one @@ -1099,6 +1115,33 @@ interface to mark as read, save for later or mute threads. You can also manage your GitHub web notifications using a tool such as [Octobox][]. +##### Draft pull requests ##### + +[Draft PRs][GitHub-draft-PR] are a mechanism proposed by GitHub to +open a pull request before it is ready for review. + +Opening a draft PR is a way of announcing a change and seeking early +feedback without formally requesting maintainers' reviews. Indeed, +you should avoid cluttering our maintainers' review request lists +before a change is ready on your side. + +When opening a draft PR, make sure to give it a descriptive enough +title so that interested developers still notice it in their +notification feed. You may also advertise it by talking about it in +our [developer chat][Gitter]. If you know which developer would be +able to provide useful feedback to you, you may also ping them. + +###### Turning a PR into draft mode ###### + +If a PR was opened as ready for review, but it turns out that it still +needs work, it can be transformed into a draft PR. + +In this case, previous review requests won't be removed automatically. +Someone with write access to the repository should remove them +manually. Afterwards, upon marking the PR as ready for review, +someone with write access will have to manually add the review +requests that were previously removed. + #### GitLab documentation, tips and tricks #### We use GitLab mostly for its CI service. The [Coq organization on diff --git a/INSTALL.md b/INSTALL.md index 0c98a611a5..2397f2c5c2 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -7,7 +7,7 @@ Build Requirements To compile Coq yourself, you need: - [OCaml](https://ocaml.org/) (version >= 4.05.0) - (This version of Coq has been tested up to OCaml 4.09.1) + (This version of Coq has been tested up to OCaml 4.10.0) - The [num](https://github.com/ocaml/num) library; note that it is included in the OCaml distribution for OCaml versions < 4.06.0 @@ -45,7 +45,7 @@ CoqIDE with: Opam (https://opam.ocaml.org/) is recommended to install OCaml and the corresponding packages. - $ opam switch create coq 4.09.1+flambda + $ opam switch create coq 4.10.0+flambda $ eval $(opam env) $ opam install num ocamlfind lablgtk3-sourceview3 diff --git a/Makefile.build b/Makefile.build index 5b26f11b12..b7a4dd655a 100644 --- a/Makefile.build +++ b/Makefile.build @@ -56,6 +56,10 @@ TIMING_SORT_BY ?= auto TIMING_FUZZ ?= 0 # Option for changing whether to use real or user time for timing tables TIMING_REAL?= +# Option for including the memory column(s) +TIMING_INCLUDE_MEM?= +# Option for sorting by the memory column +TIMING_SORT_BY_MEM?= # Output file names for timed builds TIME_OF_BUILD_FILE ?= time-of-build.log TIME_OF_BUILD_BEFORE_FILE ?= time-of-build-before.log @@ -123,6 +127,18 @@ TIMING_USER_ARG := endif endif +ifeq (0,$(TIMING_INCLUDE_MEM)) +TIMING_INCLUDE_MEM_ARG := --no-include-mem +else +TIMING_INCLUDE_MEM_ARG := +endif + +ifeq (1,$(TIMING_SORT_BY_MEM)) +TIMING_SORT_BY_MEM_ARG := --sort-by-mem +else +TIMING_SORT_BY_MEM_ARG := +endif + make-pretty-timed-before:: TIME_OF_BUILD_FILE=$(TIME_OF_BUILD_BEFORE_FILE) make-pretty-timed-after:: TIME_OF_BUILD_FILE=$(TIME_OF_BUILD_AFTER_FILE) make-pretty-timed make-pretty-timed-before make-pretty-timed-after:: @@ -130,9 +146,9 @@ make-pretty-timed make-pretty-timed-before make-pretty-timed-after:: $(HIDE)($(MAKE) --no-print-directory $(TGTS) TIMED=1 2>&1 && touch pretty-timed-success.ok) | tee -a $(TIME_OF_BUILD_FILE) $(HIDE)rm pretty-timed-success.ok # must not be -f; must fail if the touch failed print-pretty-timed:: - $(HIDE)$(COQMAKE_ONE_TIME_FILE) $(TIMING_REAL_ARG) $(TIME_OF_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) + $(HIDE)$(COQMAKE_ONE_TIME_FILE) $(TIMING_INCLUDE_MEM_ARG) $(TIMING_SORT_BY_MEM_ARG) $(TIMING_REAL_ARG) $(TIME_OF_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) print-pretty-timed-diff:: - $(HIDE)$(COQMAKE_BOTH_TIME_FILES) --sort-by=$(TIMING_SORT_BY) $(TIMING_REAL_ARG) $(TIME_OF_BUILD_AFTER_FILE) $(TIME_OF_BUILD_BEFORE_FILE) $(TIME_OF_PRETTY_BOTH_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) + $(HIDE)$(COQMAKE_BOTH_TIME_FILES) --sort-by=$(TIMING_SORT_BY) $(TIMING_INCLUDE_MEM_ARG) $(TIMING_SORT_BY_MEM_ARG) $(TIMING_REAL_ARG) $(TIME_OF_BUILD_AFTER_FILE) $(TIME_OF_BUILD_BEFORE_FILE) $(TIME_OF_PRETTY_BOTH_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) ifeq (,$(BEFORE)) print-pretty-single-time-diff:: @echo 'Error: Usage: $(MAKE) print-pretty-single-time-diff AFTER=path/to/file.v.after-timing BEFORE=path/to/file.v.before-timing' @@ -201,12 +217,12 @@ DEPENDENCIES := \ # Default timing command # Use /usr/bin/env time on linux, gtime on Mac OS -TIMEFMT?="$* (real: %e, user: %U, sys: %S, mem: %M ko)" +TIMEFMT?="$@ (real: %e, user: %U, sys: %S, mem: %M ko)" ifneq (,$(TIMED)) -ifeq (0,$(shell /usr/bin/env time -f $(TIMEFMT) true >/dev/null 2>/dev/null; echo $$?)) +ifeq (0,$(shell /usr/bin/env time -f "" true >/dev/null 2>/dev/null; echo $$?)) STDTIME?=/usr/bin/env time -f $(TIMEFMT) else -ifeq (0,$(shell gtime -f $(TIMEFMT) true >/dev/null 2>/dev/null; echo $$?)) +ifeq (0,$(shell gtime -f "" true >/dev/null 2>/dev/null; echo $$?)) STDTIME?=gtime -f $(TIMEFMT) else STDTIME?=time @@ -269,10 +285,6 @@ OPT:= BESTOBJ:=.cmo BESTLIB:=.cma BESTDYN:=.cma - -# needed while booting if non -local -CAML_LD_LIBRARY_PATH := $(PWD)/kernel/byterun:$(CAML_LD_LIBRARY_PATH) -export CAML_LD_LIBRARY_PATH endif define bestobj diff --git a/Makefile.ci b/Makefile.ci index d4383fd409..af92d476ba 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -19,21 +19,22 @@ CI_TARGETS= \ ci-coq_dpdgraph \ ci-coquelicot \ ci-corn \ - ci-cross-crypto \ + ci-cross_crypto \ + ci-coq_tools \ ci-coqprime \ ci-elpi \ - ci-ext-lib \ + ci-ext_lib \ ci-equations \ - ci-fcsl-pcm \ - ci-fiat-crypto \ + ci-fcsl_pcm \ + ci-fiat_crypto \ ci-fiat_parsers \ ci-flocq \ ci-geocoq \ ci-coqhammer \ ci-hott \ - ci-iris-lambda-rust \ - ci-math-classes \ - ci-math-comp \ + ci-lambda_rust \ + ci-math_classes \ + ci-mathcomp \ ci-metacoq \ ci-mtac2 \ ci-paramcoq \ @@ -43,12 +44,12 @@ CI_TARGETS= \ ci-relation_algebra \ ci-rewriter \ ci-sf \ - ci-simple-io \ + ci-simple_io \ ci-stdlib2 \ ci-tlc \ ci-unimath \ ci-unicoq \ - ci-verdi-raft \ + ci-verdi_raft \ ci-vst .PHONY: ci-all $(CI_TARGETS) @@ -63,19 +64,21 @@ ci-color: ci-bignums ci-coqprime: ci-bignums -ci-math-classes: ci-bignums +ci-math_classes: ci-bignums -ci-corn: ci-math-classes +ci-corn: ci-math_classes ci-mtac2: ci-unicoq -ci-fiat-crypto: ci-coqprime ci-rewriter +ci-fiat_crypto: ci-coqprime ci-rewriter -ci-simple-io: ci-ext-lib -ci-quickchick: ci-ext-lib ci-simple-io +ci-simple_io: ci-ext_lib +ci-quickchick: ci-ext_lib ci-simple_io ci-metacoq: ci-equations +ci-vst: ci-flocq + # Generic rule, we use make to ease CI integration $(CI_TARGETS): ci-%: +./dev/ci/ci-wrapper.sh $* diff --git a/Makefile.doc b/Makefile.doc index 9da175f0e5..8be032ceb3 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -100,6 +100,9 @@ doc-stdlib: \ full-stdlib: \ doc/stdlib/html/index.html doc/stdlib/FullLibrary.ps doc/stdlib/FullLibrary.pdf +sphinx-clean: + rm -rf $(SPHINXBUILDDIR) + .PHONY: plugin-tutorial plugin-tutorial: states tools +$(MAKE) COQBIN=$(PWD)/bin/ -C $(PLUGINTUTO) @@ -248,7 +251,7 @@ PLUGIN_MLGS := $(wildcard plugins/*/*.mlg) OMITTED_PLUGIN_MLGS := plugins/ssr/ssrparser.mlg plugins/ssr/ssrvernac.mlg plugins/ssrmatching/g_ssrmatching.mlg DOC_MLGS := $(wildcard */*.mlg) $(sort $(filter-out $(OMITTED_PLUGIN_MLGS), $(PLUGIN_MLGS))) DOC_EDIT_MLGS := $(wildcard doc/tools/docgram/*.edit_mlg) -DOC_RSTS := $(wildcard doc/sphinx/*/*.rst) +DOC_RSTS := $(wildcard doc/sphinx/*/*.rst) $(wildcard doc/sphinx/*/*/*.rst) doc/tools/docgram/fullGrammar: $(DOC_GRAM) $(DOC_MLGS) $(SHOW)'DOC_GRAM' diff --git a/Makefile.dune b/Makefile.dune index b77e78db69..b002c7709d 100644 --- a/Makefile.dune +++ b/Makefile.dune @@ -1,122 +1,109 @@ # -*- mode: makefile -*- # Dune Makefile for Coq -.PHONY: help voboot states world watch check # Main developer targets -.PHONY: coq coqide coqide-server # Package targets -.PHONY: quickbyte quickopt quickide # Partial / quick developer targets +.PHONY: help states world watch check # Main developer targets .PHONY: refman-html refman-pdf stdlib-html apidoc # Documentation targets -.PHONY: test-suite release # Accessory targets +.PHONY: test-suite .PHONY: fmt ocheck ireport clean # Maintenance targets +.PHONY: voboot release install # Added just not to break old scripts # use DUNEOPT=--display=short for a more verbose build # DUNEOPT=--display=short -BOOT_DIR=_build_boot -BOOT_CONTEXT=$(BOOT_DIR)/default - help: - @echo "Welcome to Coq's Dune-based build system. Targets are:" + @echo "Welcome to Coq's Dune-based build system. Common developer targets are:" @echo "" @echo " - states: build a minimal functional coqtop" - @echo " - world: build all binaries and libraries" - @echo " - watch: build all binaries and libraries [continuous build]" + @echo " - world: build all public binaries and libraries" + @echo " - watch: build all public binaries and libraries [continuous build]" @echo " - check: build all ML files as fast as possible" + @echo " - test-suite: run Coq's test suite" @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 " Note: these targets produce a developer build," + @echo " not suitable for distribution to end-users" @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 " - quickide: build main IDE files [client + server + prelude] using the optimizing compiler" + @echo " Documentation targets:" @echo "" - @echo " - test-suite: run Coq's test suite" @echo " - refman-html: build Coq's reference manual [HTML version]" @echo " - refman-pdf: build Coq's reference manual [PDF version]" @echo " - stdlib-html: build Coq's Stdlib documentation [HTML version]" @echo " - apidoc: build ML API documentation" - @echo " - release: build Coq in release mode" + @echo "" + @echo " Miscellaneous targets:" @echo "" @echo " - fmt: run ocamlformat on the codebase" @echo " - ocheck: build for all supported OCaml versions [requires OPAM]" @echo " - ireport: build with optimized flambda settings and emit an inline report" @echo " - clean: remove build directory and autogenerated files" @echo " - help: show this message" + @echo "" + @echo " To run an app \\in {coqc,coqtop,coqbyte,coqide}:" + @echo "" + @echo " - use 'dune exec -- dev/shim/app-prelude args'" + @echo "" + @echo " Provided opam/dune packages are:" + @echo "" + @echo " - coq: base Coq package, toplevel compilers, tools, stdlib, no GTK" + @echo " - coqide-server: XML protocol language server" + @echo " - coqide: CoqIDE gtk application" + @echo "" + @echo " To build a package, you can use:" + @echo "" + @echo " - 'dune build package.install' : build package in developer mode" + @echo " - 'dune build -p package' : build package in release mode" + @echo "" + @echo " Packages _must_ be installed using release mode, use: 'dune install -p package'" + @echo " See Dune documentation for more information." -# We need to bootstrap with a dummy coq.plugins.ltac so install targets do work. -plugins/ltac/dune: - @echo "(library (name ltac_plugin) (public_name coq.plugins.ltac) (modules_without_implementation extraargs extratactics))" > plugins/ltac/dune - -voboot: plugins/ltac/dune - dune build --build-dir=$(BOOT_DIR) $(DUNEOPT) @vodeps - dune exec --build-dir=$(BOOT_DIR) -- ./tools/coq_dune.exe $(BOOT_CONTEXT)/.vfiles.d +voboot: + @echo "This target is empty and not needed anymore" -states: voboot - dune build --display=short $(DUNEOPT) dev/shim/coqtop-prelude +states: + dune build $(DUNEOPT) dev/shim/coqtop-prelude NONDOC_INSTALL_TARGETS:=coq.install coqide-server.install coqide.install -world: voboot +world: dune build $(DUNEOPT) $(NONDOC_INSTALL_TARGETS) -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 +watch: dune build $(DUNEOPT) $(NONDOC_INSTALL_TARGETS) -w -check: voboot +check: dune build $(DUNEOPT) @check -COQTOP_FILES=ide/idetop.bc ide/coqide_main.bc checker/coqchk.bc -PLUGIN_FILES=$(wildcard plugins/*/*.mlpack) -PRINTER_FILES=dev/top_printers.cma -QUICKBYTE_TARGETS=$(COQTOP_FILES) $(PLUGIN_FILES:.mlpack=.cma) $(PRINTER_FILES) topbin/coqtop_byte_bin.bc -QUICKOPT_TARGETS=$(COQTOP_FILES:.bc=.exe) $(PLUGIN_FILES:.mlpack=.cmxs) $(PRINTER_FILES:.cma=.cmxa) topbin/coqtop_bin.exe - -quickbyte: voboot - dune build $(DUNEOPT) $(QUICKBYTE_TARGETS) - -quickopt: voboot - dune build $(DUNEOPT) $(QUICKOPT_TARGETS) - -quickide: states - dune build $(DUNEOPT) dev/shim/coqide-prelude - -test-suite: voboot +test-suite: dune runtest --no-buffer $(DUNEOPT) -refman-html: voboot +refman-html: dune build @refman-html -refman-pdf: voboot +refman-pdf: dune build @refman-pdf -stdlib-html: voboot +stdlib-html: dune build @stdlib-html -apidoc: voboot +apidoc: dune build $(DUNEOPT) @doc -release: voboot +release: + @echo "release target is deprecated, use dune directly" dune build $(DUNEOPT) -p coq -fmt: voboot +# We define this target as to override Make's built-in one +install: + @echo "To install Coq using dune, use 'dune install -p PACKAGE' where" + @echo "PACKAGE is any of the packages defined by opam files in the root dira" + +fmt: dune build @fmt --auto-promote -ocheck: voboot +ocheck: dune build $(DUNEOPT) @install --workspace=dev/dune-workspace.all ireport: dune clean - dune build --build-dir=$(BOOT_DIR) $(DUNEOPT) @vodeps - dune exec --build-dir=$(BOOT_DIR) -- ./tools/coq_dune.exe $(BOOT_CONTEXT)/.vfiles.d dune build $(DUNEOPT) @install --profile=ireport clean: diff --git a/azure-pipelines.yml b/azure-pipelines.yml index aae2c3cb42..770cc5193e 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -6,37 +6,37 @@ variables: NJOBS: "2" jobs: -- job: Windows - pool: - vmImage: 'vs2017-win2016' +#- job: Windows +# pool: +# vmImage: 'vs2017-win2016' - steps: - - checkout: self - fetchDepth: 10 +# 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 python3 - - 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: | +# 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 python3 - - script: C:\cygwin64\bin\bash -l %cd%\dev\ci\azure-opam.sh - displayName: 'Install opam' +# 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-build.sh - displayName: 'Build Coq' +# - 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' +# - script: C:\cygwin64\bin\bash -l %cd%\dev\ci\azure-test.sh +# displayName: 'Test Coq' - job: macOS pool: @@ -72,7 +72,7 @@ jobs: opam list displayName: 'Install OCaml dependencies' env: - COMPILER: "4.09.1" + COMPILER: "4.10.0" FINDLIB_VER: ".1.8.1" OPAMYES: "true" diff --git a/checker/check.ml b/checker/check.ml index bb3255338f..31bfebc3d5 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -255,7 +255,7 @@ let try_locate_qualified_library lib = match lib with (*s Low-level interning of libraries from files *) let raw_intern_library f = - System.raw_intern_state Coq_config.vo_magic_number f + ObjFile.open_in ~file:f (************************************************************************) (* Internalise libraries *) @@ -294,57 +294,56 @@ type intern_mode = Rec | Root | Dep (* Rec = standard, Root = -norec, Dep = depe (* Dependency graph *) let depgraph = ref LibraryMap.empty -let marshal_in_segment ~validate ~value f ch = +let marshal_in_segment ~validate ~value ~segment f ch = + let () = LargeFile.seek_in ch segment.ObjFile.pos in if validate then - let v, stop, digest = + let v = try - let stop = input_binary_int ch in let v = Analyze.parse_channel ch in let digest = Digest.input ch in - v, stop, digest + let () = if not (String.equal digest segment.ObjFile.hash) then raise Exit in + v with _ -> user_err (str "Corrupted file " ++ quote (str f)) in - let () = Validate.validate ~debug:!Flags.debug value v in + let () = Validate.validate value v in let v = Analyze.instantiate v in - Obj.obj v, stop, digest + Obj.obj v else - System.marshal_in_segment f ch + System.marshal_in f ch -let skip_in_segment f ch = - try - let stop = (input_binary_int ch : int) in - seek_in ch stop; - let digest = Digest.input ch in - stop, digest - with _ -> - user_err (str "Corrupted file " ++ quote (str f)) - -let marshal_or_skip ~validate ~value f ch = +let marshal_or_skip ~validate ~value ~segment f ch = if validate then - let v, pos, digest = marshal_in_segment ~validate ~value f ch in - Some v, pos, digest + let v = marshal_in_segment ~validate:true ~value ~segment f ch in + Some v else - let pos, digest = skip_in_segment f ch in - None, pos, digest + None let intern_from_file ~intern_mode (dir, f) = let validate = intern_mode <> Dep in Flags.if_verbose chk_pp (str"[intern "++str f++str" ..."); let (sd,md,table,opaque_csts,digest) = try + (* First pass to read the metadata of the file *) let ch = System.with_magic_number_check raw_intern_library f in - let (sd:summary_disk), _, digest = marshal_in_segment ~validate ~value:Values.v_libsum f ch in - let (md:library_disk), _, digest = marshal_in_segment ~validate ~value:Values.v_lib f ch in - let (opaque_csts:seg_univ option), _, udg = marshal_in_segment ~validate ~value:Values.v_univopaques f ch in - let (tasks:'a option), _, _ = marshal_in_segment ~validate ~value:Values.(Opt Any) f ch in - let (table:seg_proofs option), pos, checksum = - marshal_or_skip ~validate ~value:Values.v_opaquetable f ch in + let seg_sd = ObjFile.get_segment ch ~segment:"summary" in + let seg_md = ObjFile.get_segment ch ~segment:"library" in + let seg_univs = ObjFile.get_segment ch ~segment:"universes" in + let seg_tasks = ObjFile.get_segment ch ~segment:"tasks" in + let seg_opaque = ObjFile.get_segment ch ~segment:"opaques" in + let () = ObjFile.close_in ch in + (* Actually read the data *) + let ch = open_in_bin f in + + let (sd:summary_disk) = marshal_in_segment ~validate ~value:Values.v_libsum ~segment:seg_sd f ch in + let (md:library_disk) = marshal_in_segment ~validate ~value:Values.v_lib ~segment:seg_md f ch in + let (opaque_csts:seg_univ option) = marshal_in_segment ~validate ~value:Values.v_univopaques ~segment:seg_univs f ch in + let (tasks:'a option) = marshal_in_segment ~validate ~value:Values.(Opt Any) ~segment:seg_tasks f ch in + let (table:seg_proofs option) = + marshal_or_skip ~validate ~value:Values.v_opaquetable ~segment:seg_opaque f ch in (* Verification of the final checksum *) let () = close_in ch in let ch = open_in_bin f in - if not (String.equal (Digest.channel ch pos) checksum) then - user_err ~hdr:"intern_from_file" (str "Checksum mismatch"); let () = close_in ch in if dir <> sd.md_name then user_err ~hdr:"intern_from_file" @@ -361,8 +360,9 @@ let intern_from_file ~intern_mode (dir, f) = end; Flags.if_verbose chk_pp (str" done]" ++ fnl ()); let digest = - if opaque_csts <> None then Safe_typing.Dvivo (digest,udg) - else (Safe_typing.Dvo_or_vi digest) in + let open ObjFile in + if opaque_csts <> None then Safe_typing.Dvivo (seg_md.hash, seg_univs.hash) + else (Safe_typing.Dvo_or_vi seg_md.hash) in sd,md,table,opaque_csts,digest with e -> Flags.if_verbose chk_pp (str" failed!]" ++ fnl ()); raise e in depgraph := LibraryMap.add sd.md_name sd.md_deps !depgraph; diff --git a/checker/check.mllib b/checker/check.mllib index d47a93c70d..a16a871dc3 100644 --- a/checker/check.mllib +++ b/checker/check.mllib @@ -1,5 +1,6 @@ Analyze +CheckFlags CheckInductive Mod_checking CheckTypes diff --git a/checker/checkFlags.ml b/checker/checkFlags.ml new file mode 100644 index 0000000000..1f5e76bd83 --- /dev/null +++ b/checker/checkFlags.ml @@ -0,0 +1,23 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \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 Declarations + +let set_local_flags flags env = + let flags = + { (Environ.typing_flags env) with + check_guarded = flags.check_guarded; + check_positive = flags.check_positive; + check_universes = flags.check_universes; + conv_oracle = flags.conv_oracle; + cumulative_sprop = flags.cumulative_sprop; + } + in + Environ.set_typing_flags flags env diff --git a/checker/checkFlags.mli b/checker/checkFlags.mli new file mode 100644 index 0000000000..2e41e656f1 --- /dev/null +++ b/checker/checkFlags.mli @@ -0,0 +1,12 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \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) *) +(************************************************************************) + +val set_local_flags : Declarations.typing_flags -> Environ.env -> Environ.env +(** Set flags except for those ignored by the checker (eg vm_compute). *) diff --git a/checker/checkInductive.ml b/checker/checkInductive.ml index a1d5aedb01..c370a77ea0 100644 --- a/checker/checkInductive.ml +++ b/checker/checkInductive.ml @@ -164,16 +164,7 @@ let check_inductive env mind mb = mind_private; mind_typing_flags; } = (* Locally set typing flags for further typechecking *) - let mb_flags = mb.mind_typing_flags in - let env = Environ.set_typing_flags - {env.env_typing_flags with - check_guarded = mb_flags.check_guarded; - check_positive = mb_flags.check_positive; - check_universes = mb_flags.check_universes; - conv_oracle = mb_flags.conv_oracle; - } - env - in + let env = CheckFlags.set_local_flags mb.mind_typing_flags env in Indtypes.check_inductive env ~sec_univs:None mind entry in let check = check mind in diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index 44b7089fd0..2f795ff8d9 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -17,14 +17,7 @@ let set_indirect_accessor f = indirect_accessor := f let check_constant_declaration env kn cb = Flags.if_verbose Feedback.msg_notice (str " checking cst:" ++ Constant.print kn); - let cb_flags = cb.const_typing_flags in - let env = Environ.set_typing_flags - {env.env_typing_flags with - check_guarded = cb_flags.check_guarded; - check_universes = cb_flags.check_universes; - conv_oracle = cb_flags.conv_oracle;} - env - in + let env = CheckFlags.set_local_flags cb.const_typing_flags env in let poly, env = match cb.const_universes with | Monomorphic ctx -> @@ -84,7 +77,6 @@ let mk_mtb mp sign delta = mod_expr = (); mod_type = sign; mod_type_alg = None; - mod_constraints = Univ.ContextSet.empty; mod_delta = delta; mod_retroknowledge = ModTypeRK; } diff --git a/checker/safe_checking.ml b/checker/safe_checking.ml index 524ffbc022..b5beab532e 100644 --- a/checker/safe_checking.ml +++ b/checker/safe_checking.ml @@ -14,7 +14,7 @@ open Environ let import senv clib univs digest = let mb = Safe_typing.module_of_library clib in let env = Safe_typing.env_of_safe_env senv in - let env = push_context_set ~strict:true mb.mod_constraints env in + let env = push_context_set ~strict:true (Safe_typing.univs_of_library clib) env in let env = push_context_set ~strict:true univs env in let env = Modops.add_retroknowledge mb.mod_retroknowledge env in Mod_checking.check_module env mb.mod_mp mb; diff --git a/checker/validate.ml b/checker/validate.ml index 66367cb002..20884c4d01 100644 --- a/checker/validate.ml +++ b/checker/validate.ml @@ -208,11 +208,10 @@ let print_frame = function | CtxField i -> Printf.sprintf "fld=%i" i | CtxTag i -> Printf.sprintf "tag=%i" i -let validate ~debug v (o, mem) = +let validate v (o, mem) = try val_gen v mem mt_ec o with ValidObjError(msg,ctx,obj) -> - (if debug then - let ctx = List.rev_map print_frame ctx in - print_endline ("Context: "^String.concat"/"ctx); - pr_obj mem obj); + let rctx = List.rev_map print_frame ctx in + print_endline ("Context: "^String.concat"/"rctx); + pr_obj mem obj; failwith ("Validation failed: "^msg^" (in "^(print_frame (List.hd ctx))^")") diff --git a/checker/validate.mli b/checker/validate.mli index 9ddc510e4a..1204b528f9 100644 --- a/checker/validate.mli +++ b/checker/validate.mli @@ -10,4 +10,4 @@ open Analyze -val validate : debug:bool -> Values.value -> data * obj LargeArray.t -> unit +val validate : Values.value -> data * obj LargeArray.t -> unit diff --git a/checker/values.ml b/checker/values.ml index 12f7135cdf..76e3ab0d45 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -241,7 +241,10 @@ let v_cst_def = [|[|Opt Int|]; [|v_cstr_subst|]; [|v_opaque|]; [|v_primitive|]|] let v_typing_flags = - v_tuple "typing_flags" [|v_bool; v_bool; v_bool; v_oracle; v_bool; v_bool; v_bool; v_bool|] + v_tuple "typing_flags" + [|v_bool; v_bool; v_bool; + v_oracle; v_bool; v_bool; + v_bool; v_bool; v_bool|] let v_univs = v_sum "universes" 0 [|[|v_context_set|]; [|v_abs_context|]|] @@ -356,22 +359,33 @@ and v_impl = and v_noimpl = v_unit and v_module = Tuple ("module_body", - [|v_mp;v_impl;v_sign;Opt v_mexpr;v_context_set;v_resolver;v_retroknowledge|]) + [|v_mp;v_impl;v_sign;Opt v_mexpr;v_resolver;v_retroknowledge|]) and v_modtype = Tuple ("module_type_body", - [|v_mp;v_noimpl;v_sign;Opt v_mexpr;v_context_set;v_resolver;v_unit|]) + [|v_mp;v_noimpl;v_sign;Opt v_mexpr;v_resolver;v_unit|]) (** kernel/safe_typing *) let v_vodigest = Sum ("module_impl",0, [| [|String|]; [|String;String|] |]) let v_deps = Array (v_tuple "dep" [|v_dp;v_vodigest|]) let v_compiled_lib = - v_tuple "compiled" [|v_dp;v_module;v_deps;v_engagement;Any|] + v_tuple "compiled" [|v_dp;v_module;v_context_set;v_deps;v_engagement;Any|] (** Library objects *) let v_obj = Dyn +let v_globref = Sum("globref",0,[| + [|v_id|]; + [|v_cst|]; + [|v_ind|]; + [|v_cons|] + |]) + +let v_ext_gref = Sum("extended_global_reference",0,[|[|v_globref|];[|v_kn|]|]) + +let v_open_filter = Sum ("open_filter",1,[|[|v_hset v_ext_gref|]|]) + let rec v_aobjs = Sum("algebraic_objects", 0, [| [|v_libobjs|]; [|v_mp;v_subst|] @@ -383,7 +397,7 @@ and v_libobjt = Sum("Libobject.t",0, [| v_substobjs |]; [| v_aobjs |]; [| v_libobjs |]; - [| List v_mp |]; + [| List (v_pair v_open_filter v_mp)|]; [| v_obj |] |]) diff --git a/checker/votour.ml b/checker/votour.ml index a83ba20dd6..3fb3ccadf4 100644 --- a/checker/votour.ml +++ b/checker/votour.ml @@ -349,14 +349,63 @@ let parse_header chan = let size64 = input_binary_int chan in { magic; length; size32; size64; objects } +module ObjFile = +struct + type segment = { name : string; - mutable pos : int; - typ : Values.value; + pos : int64; + len : int64; + hash : Digest.t; mutable header : header; } -let make_seg name typ = { name; typ; pos = 0; header = dummy_header } +let input_int32 ch = + let accu = ref 0l in + for _i = 0 to 3 do + let c = input_byte ch in + accu := Int32.add (Int32.shift_left !accu 8) (Int32.of_int c) + done; + !accu + +let input_int64 ch = + let accu = ref 0L in + for _i = 0 to 7 do + let c = input_byte ch in + accu := Int64.add (Int64.shift_left !accu 8) (Int64.of_int c) + done; + !accu + +let input_segment_summary ch = + let nlen = input_int32 ch in + let name = really_input_string ch (Int32.to_int nlen) in + let pos = input_int64 ch in + let len = input_int64 ch in + let hash = Digest.input ch in + { name; pos; len; hash; header = dummy_header } + +let rec input_segment_summaries ch n accu = + if Int32.equal n 0l then Array.of_list (List.rev accu) + else + let s = input_segment_summary ch in + let accu = s :: accu in + input_segment_summaries ch (Int32.pred n) accu + +let parse_segments ch = + let magic = input_int32 ch in + let version = input_int32 ch in + let summary_pos = input_int64 ch in + let () = LargeFile.seek_in ch summary_pos in + let nsum = input_int32 ch in + let seg = input_segment_summaries ch nsum [] in + for i = 0 to Array.length seg - 1 do + let () = LargeFile.seek_in ch seg.(i).pos in + let header = parse_header ch in + seg.(i).header <- header + done; + (magic, version, seg) + +end let visit_vo f = Printf.printf "\nWelcome to votour !\n"; @@ -364,13 +413,13 @@ let visit_vo f = Printf.printf "Object sizes are in words (%d bits)\n" Sys.word_size; Printf.printf "At prompt, <n> enters the <n>-th child, u goes up 1 level, x exits\n\n%!"; - let segments = [| - make_seg "summary" Values.v_libsum; - make_seg "library" Values.v_lib; - make_seg "univ constraints of opaque proofs" Values.v_univopaques; - make_seg "STM tasks" (Opt Values.v_stm_seg); - make_seg "opaque proofs" Values.v_opaquetable; - |] in + let known_segments = [ + "summary", Values.v_libsum; + "library", Values.v_lib; + "universes", Values.v_univopaques; + "tasks", (Opt Values.v_stm_seg); + "opaques", Values.v_opaquetable; + ] in let repr = if Sys.word_size = 64 then (module ReprMem : S) else (module ReprObj : S) (* On 32-bit machines, representation may exceed the max size of arrays *) @@ -379,28 +428,23 @@ let visit_vo f = let module Visit = Visit(Repr) in while true do let ch = open_in_bin f in - let magic = input_binary_int ch in - Printf.printf "File format: %d\n%!" magic; - for i=0 to Array.length segments - 1 do - let pos = input_binary_int ch in - segments.(i).pos <- pos_in ch; - let header = parse_header ch in - segments.(i).header <- header; - seek_in ch pos; - ignore(Digest.input ch); - done; + let (_magic, version, segments) = ObjFile.parse_segments ch in + Printf.printf "File format: %ld\n%!" version; Printf.printf "The file has %d segments, choose the one to visit:\n" (Array.length segments); - Array.iteri (fun i { name; pos; header } -> + Array.iteri (fun i ObjFile.{ name; pos; header } -> let size = if Sys.word_size = 64 then header.size64 else header.size32 in - Printf.printf " %d: %s, starting at byte %d (size %iw)\n" i name pos size) + Printf.printf " %d: %s, starting at byte %Ld (size %iw)\n" i name pos size) segments; match read_num (Array.length segments) with | Some seg -> - seek_in ch segments.(seg).pos; + let seg = segments.(seg) in + let open ObjFile in + LargeFile.seek_in ch seg.pos; let o = Repr.input ch in let () = Visit.init () in - Visit.visit segments.(seg).typ o [] + let typ = try List.assoc seg.name known_segments with Not_found -> Any in + Visit.visit typ o [] | None -> () done diff --git a/config/coq_config.mli b/config/coq_config.mli index 6ed4bf9b8e..12856cb6e6 100644 --- a/config/coq_config.mli +++ b/config/coq_config.mli @@ -35,7 +35,7 @@ val caml_version : string (* OCaml version used to compile Coq *) val caml_version_nums : int list (* OCaml version used to compile Coq by components *) val date : string (* release date *) val compile_date : string (* compile date *) -val vo_magic_number : int +val vo_version : int32 val state_magic_number : int val all_src_dirs : string list diff --git a/configure.ml b/configure.ml index ee2e50ef86..75c11dab5f 100644 --- a/configure.ml +++ b/configure.ml @@ -616,8 +616,9 @@ let camltag = match caml_version_list with 45: "open" shadowing a label or constructor: see 44 48: implicit elimination of optional arguments: too common 58: "no cmx file was found in path": See https://github.com/ocaml/num/issues/9 + 67: "unused functor parameter" seems totally bogus *) -let coq_warnings = "-w +a-4-9-27-41-42-44-45-48-58" +let coq_warnings = "-w +a-4-9-27-41-42-44-45-48-58-67" let coq_warn_error = if !prefs.warn_error then "-warn-error +a" @@ -750,10 +751,10 @@ let check_coqide () = if !prefs.coqide = Some No then set_ide No "CoqIde manually disabled"; let dir, via = get_lablgtkdir () in if dir = "" - then set_ide No "LablGtk3 not found" + then set_ide No "LablGtk3 or LablGtkSourceView3 not found" else let (ok, version) = check_lablgtk_version () in - let found = sprintf "LablGtk3 found (%s)" version in + let found = sprintf "LablGtk3 and LablGtkSourceView3 found (%s)" version in if not ok then set_ide No (found^", but too old (required >= 3.0, found " ^ version ^ ")"); (* We're now sure to produce at least one kind of coqide *) lablgtkdir := shorten_camllib dir; @@ -982,7 +983,7 @@ let config_runtime () = ["-dllib";"-lcoqrun";"-dllpath";("\"" ^ coqtop ^ "/kernel/byterun\"")] | _ -> let ld="CAML_LD_LIBRARY_PATH" in - build_loadpath := sprintf "export %s:='%s/kernel/byterun':$(%s)" ld coqtop ld; + build_loadpath := sprintf "export %s:=%s/kernel/byterun:$(%s)" ld coqtop ld; ["-dllib";"-lcoqrun";"-dllpath";coqlib/"kernel/byterun"] let vmbyteflags = config_runtime () @@ -1058,6 +1059,7 @@ let write_configml f = let pr_s = pr "let %s = %S\n" in let pr_b = pr "let %s = %B\n" in let pr_i = pr "let %s = %d\n" in + let pr_i32 = pr "let %s = %dl\n" in let pr_p s o = pr "let %s = %S\n" s (match o with Relative s -> s | Absolute s -> s) in let pr_li n l = pr "let %s = [%s]\n" n (String.concat ";" (List.map string_of_int l)) in @@ -1085,7 +1087,7 @@ let write_configml f = pr_s "exec_extension" exe; pr "let gtk_platform = `%s\n" !idearchdef; pr_b "has_natdynlink" hasnatdynlink; - pr_i "vo_magic_number" vo_magic; + pr_i32 "vo_version" vo_magic; pr_i "state_magic_number" state_magic; pr_s "browser" browser; pr_s "wwwcoq" !prefs.coqwebsite; @@ -22,13 +22,12 @@ version: "dev" depends: [ "ocaml" { >= "4.05.0" } - "dune" { >= "2.0.0" } + "dune" { >= "2.5.0" } "ocamlfind" { build } "num" ] build: [ [ "./configure" "-prefix" prefix ] - [ "make" "-f" "Makefile.dune" "voboot" ] [ "dune" "build" "-p" name "-j" jobs ] ] diff --git a/dev/base_include b/dev/base_include index 96a867475d..45e79147c1 100644 --- a/dev/base_include +++ b/dev/base_include @@ -129,7 +129,7 @@ open Elim open Equality open Hipattern open Inv -open Leminv +open Ltac_plugin.Leminv open Tacticals open Tactics open Eqschemes diff --git a/dev/ci/README-developers.md b/dev/ci/README-developers.md index 6a740b9033..88d08a1724 100644 --- a/dev/ci/README-developers.md +++ b/dev/ci/README-developers.md @@ -72,10 +72,10 @@ Moreover your PR must absolutely update the [`CHANGES.md`](../../CHANGES.md) fil ### Experimental automatic overlay creation and building If you break external projects that are hosted on GitHub, you can use -the `create-overlays.sh` script to automatically perform most of the +the `create_overlays.sh` script to automatically perform most of the above steps. In order to do so, call the script as: ``` -./dev/tools/create-overlays.sh ejgallego 9873 aac_tactics elpi ltac +./dev/tools/create_overlays.sh ejgallego 9873 aac_tactics elpi ltac ``` replacing `ejgallego` by your GitHub nickname and `9873` by the actual PR number. The script will: diff --git a/dev/ci/azure-opam.sh b/dev/ci/azure-opam.sh index 7b3e2703b8..64936cd236 100755 --- a/dev/ci/azure-opam.sh +++ b/dev/ci/azure-opam.sh @@ -2,7 +2,7 @@ set -e -x -OPAM_VARIANT=ocaml-variants.4.09.1+mingw64c +OPAM_VARIANT=ocaml-variants.4.10.0+mingw64c 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 diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index c18e556da8..b87a9c0392 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -46,9 +46,9 @@ : "${math_classes_CI_GITURL:=https://github.com/coq-community/math-classes}" : "${math_classes_CI_ARCHIVEURL:=${math_classes_CI_GITURL}/archive}" -: "${Corn_CI_REF:=master}" -: "${Corn_CI_GITURL:=https://github.com/coq-community/corn}" -: "${Corn_CI_ARCHIVEURL:=${Corn_CI_GITURL}/archive}" +: "${corn_CI_REF:=master}" +: "${corn_CI_GITURL:=https://github.com/coq-community/corn}" +: "${corn_CI_ARCHIVEURL:=${corn_CI_GITURL}/archive}" ######################################################################## # Iris @@ -59,19 +59,19 @@ : "${stdpp_CI_GITURL:=https://gitlab.mpi-sws.org/iris/stdpp}" : "${stdpp_CI_ARCHIVEURL:=${stdpp_CI_GITURL}/-/archive}" -: "${Iris_CI_GITURL:=https://gitlab.mpi-sws.org/iris/iris}" -: "${Iris_CI_ARCHIVEURL:=${Iris_CI_GITURL}/-/archive}" +: "${iris_CI_GITURL:=https://gitlab.mpi-sws.org/iris/iris}" +: "${iris_CI_ARCHIVEURL:=${iris_CI_GITURL}/-/archive}" -: "${lambdaRust_CI_REF:=master}" -: "${lambdaRust_CI_GITURL:=https://gitlab.mpi-sws.org/iris/lambda-rust}" -: "${lambdaRust_CI_ARCHIVEURL:=${lambdaRust_CI_GITURL}/-/archive}" +: "${lambda_rust_CI_REF:=master}" +: "${lambda_rust_CI_GITURL:=https://gitlab.mpi-sws.org/iris/lambda-rust}" +: "${lambda_rust_CI_ARCHIVEURL:=${lambda_rust_CI_GITURL}/-/archive}" ######################################################################## # HoTT ######################################################################## -: "${HoTT_CI_REF:=master}" -: "${HoTT_CI_GITURL:=https://github.com/HoTT/HoTT}" -: "${HoTT_CI_ARCHIVEURL:=${HoTT_CI_GITURL}/archive}" +: "${hott_CI_REF:=master}" +: "${hott_CI_GITURL:=https://github.com/HoTT/HoTT}" +: "${hott_CI_ARCHIVEURL:=${hott_CI_GITURL}/archive}" ######################################################################## # CoqHammer @@ -83,16 +83,23 @@ ######################################################################## # GeoCoq ######################################################################## -: "${GeoCoq_CI_REF:=master}" -: "${GeoCoq_CI_GITURL:=https://github.com/GeoCoq/GeoCoq}" -: "${GeoCoq_CI_ARCHIVEURL:=${GeoCoq_CI_GITURL}/archive}" +: "${geocoq_CI_REF:=master}" +: "${geocoq_CI_GITURL:=https://github.com/GeoCoq/GeoCoq}" +: "${geocoq_CI_ARCHIVEURL:=${geocoq_CI_GITURL}/archive}" ######################################################################## # Flocq ######################################################################## -: "${Flocq_CI_REF:=master}" -: "${Flocq_CI_GITURL:=https://gitlab.inria.fr/flocq/flocq}" -: "${Flocq_CI_ARCHIVEURL:=${Flocq_CI_GITURL}/-/archive}" +: "${flocq_CI_REF:=master}" +: "${flocq_CI_GITURL:=https://gitlab.inria.fr/flocq/flocq}" +: "${flocq_CI_ARCHIVEURL:=${flocq_CI_GITURL}/-/archive}" + +######################################################################## +# coq-tools +######################################################################## +: "${coq_tools_CI_REF:=master}" +: "${coq_tools_CI_GITURL:=https://github.com/JasonGross/coq-tools}" +: "${coq_tools_CI_ARCHIVEURL:=${coq_tools_CI_GITURL}/archive}" ######################################################################## # Coquelicot @@ -242,7 +249,7 @@ # ext-lib ######################################################################## : "${ext_lib_CI_REF:=master}" -: "${ext_lib_CI_GITURL:=https://github.com/coq-ext-lib/coq-ext-lib}" +: "${ext_lib_CI_GITURL:=https://github.com/coq-community/coq-ext-lib}" : "${ext_lib_CI_ARCHIVEURL:=${ext_lib_CI_GITURL}/archive}" ######################################################################## diff --git a/dev/ci/ci-bignums.sh b/dev/ci/ci-bignums.sh index 756f54dfbd..a21310cbd5 100755 --- a/dev/ci/ci-bignums.sh +++ b/dev/ci/ci-bignums.sh @@ -5,4 +5,4 @@ ci_dir="$(dirname "$0")" git_download bignums -( cd "${CI_BUILD_DIR}/bignums" && make && make install) +( cd "${CI_BUILD_DIR}/bignums" && make && make install && cd tests && make) diff --git a/dev/ci/ci-coq_tools.sh b/dev/ci/ci-coq_tools.sh new file mode 100755 index 0000000000..9c95c49c9f --- /dev/null +++ b/dev/ci/ci-coq_tools.sh @@ -0,0 +1,9 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +. "${ci_dir}/ci-common.sh" + +git_download coq_tools + +( cd "${CI_BUILD_DIR}/coq_tools" && make check || \ + { RV=$?; echo "The build broke, if an overlay is needed, mention @JasonGross in describing the expected change in Coq that needs to be taken into account, and he'll prepare a fix for coq-tools"; exit $RV; } ) diff --git a/dev/ci/ci-corn.sh b/dev/ci/ci-corn.sh index 7d5d70cf90..ac3978dc8d 100755 --- a/dev/ci/ci-corn.sh +++ b/dev/ci/ci-corn.sh @@ -3,6 +3,6 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" -git_download Corn +git_download corn -( cd "${CI_BUILD_DIR}/Corn" && make && make install ) +( cd "${CI_BUILD_DIR}/corn" && ./configure.sh && make && make install ) diff --git a/dev/ci/ci-cross-crypto.sh b/dev/ci/ci-cross_crypto.sh index 900d12c1dd..900d12c1dd 100755 --- a/dev/ci/ci-cross-crypto.sh +++ b/dev/ci/ci-cross_crypto.sh diff --git a/dev/ci/ci-ext-lib.sh b/dev/ci/ci-ext_lib.sh index 5eb167d97d..5eb167d97d 100755 --- a/dev/ci/ci-ext-lib.sh +++ b/dev/ci/ci-ext_lib.sh diff --git a/dev/ci/ci-fcsl-pcm.sh b/dev/ci/ci-fcsl_pcm.sh index cb951630c8..cb951630c8 100755 --- a/dev/ci/ci-fcsl-pcm.sh +++ b/dev/ci/ci-fcsl_pcm.sh diff --git a/dev/ci/ci-fiat-crypto.sh b/dev/ci/ci-fiat_crypto.sh index 811fefda35..811fefda35 100755 --- a/dev/ci/ci-fiat-crypto.sh +++ b/dev/ci/ci-fiat_crypto.sh diff --git a/dev/ci/ci-flocq.sh b/dev/ci/ci-flocq.sh index e87483df0a..a3a704091b 100755 --- a/dev/ci/ci-flocq.sh +++ b/dev/ci/ci-flocq.sh @@ -3,6 +3,6 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" -git_download Flocq +git_download flocq -( cd "${CI_BUILD_DIR}/Flocq" && ./autogen.sh && ./configure && ./remake "-j${NJOBS}" ) +( cd "${CI_BUILD_DIR}/flocq" && autoconf && ./configure && ./remake "-j${NJOBS}" && ./remake install ) diff --git a/dev/ci/ci-geocoq.sh b/dev/ci/ci-geocoq.sh index 8c57318477..e4fc983e68 100755 --- a/dev/ci/ci-geocoq.sh +++ b/dev/ci/ci-geocoq.sh @@ -5,6 +5,6 @@ ci_dir="$(dirname "$0")" install_ssralg -git_download GeoCoq +git_download geocoq -( cd "${CI_BUILD_DIR}/GeoCoq" && ./configure.sh && make ) +( cd "${CI_BUILD_DIR}/geocoq" && ./configure.sh && make ) diff --git a/dev/ci/ci-hott.sh b/dev/ci/ci-hott.sh index c8e6fe690f..4b92c8cb4d 100755 --- a/dev/ci/ci-hott.sh +++ b/dev/ci/ci-hott.sh @@ -3,6 +3,6 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" -git_download HoTT +git_download hott -( cd "${CI_BUILD_DIR}/HoTT" && ./autogen.sh -skip-submodules && ./configure && make && make validate ) +( cd "${CI_BUILD_DIR}/hott" && ./autogen.sh -skip-submodules && ./configure && make && make validate ) diff --git a/dev/ci/ci-iris-lambda-rust.sh b/dev/ci/ci-lambda_rust.sh index d99e140bce..1ef0c2cb8f 100755 --- a/dev/ci/ci-iris-lambda-rust.sh +++ b/dev/ci/ci-lambda_rust.sh @@ -5,17 +5,17 @@ ci_dir="$(dirname "$0")" install_ssreflect -# Setup lambdaRust first -git_download lambdaRust +# Setup lambda_rust first +git_download lambda_rust # Extract required version of Iris (avoiding "+" which does not work on MacOS :( *) -Iris_CI_REF=$(grep -F coq-iris < "${CI_BUILD_DIR}/lambdaRust/opam" | sed 's/.*"dev\.[0-9][0-9.-]*\.\([0-9a-z][0-9a-z]*\)".*/\1/') +iris_CI_REF=$(grep -F coq-iris < "${CI_BUILD_DIR}/lambda_rust/opam" | sed 's/.*"dev\.[0-9][0-9.-]*\.\([0-9a-z][0-9a-z]*\)".*/\1/') # Setup Iris -git_download Iris +git_download iris # Extract required version of std++ -stdpp_CI_REF=$(grep -F coq-stdpp < "${CI_BUILD_DIR}/Iris/opam" | sed 's/.*"dev\.[0-9][0-9.-]*\.\([0-9a-z][0-9a-z]*\)".*/\1/') +stdpp_CI_REF=$(grep -F coq-stdpp < "${CI_BUILD_DIR}/iris/opam" | sed 's/.*"dev\.[0-9][0-9.-]*\.\([0-9a-z][0-9a-z]*\)".*/\1/') # Setup std++ git_download stdpp @@ -24,7 +24,7 @@ git_download stdpp ( cd "${CI_BUILD_DIR}/stdpp" && make && make install ) # Build and validate Iris -( cd "${CI_BUILD_DIR}/Iris" && make && make validate && make install ) +( cd "${CI_BUILD_DIR}/iris" && make && make validate && make install ) -# Build lambdaRust -( cd "${CI_BUILD_DIR}/lambdaRust" && make && make install ) +# Build lambda_rust +( cd "${CI_BUILD_DIR}/lambda_rust" && make && make install ) diff --git a/dev/ci/ci-math-classes.sh b/dev/ci/ci-math_classes.sh index ae31a8e7f8..ae31a8e7f8 100755 --- a/dev/ci/ci-math-classes.sh +++ b/dev/ci/ci-math_classes.sh diff --git a/dev/ci/ci-math-comp.sh b/dev/ci/ci-mathcomp.sh index cae127ee7b..cae127ee7b 100755 --- a/dev/ci/ci-math-comp.sh +++ b/dev/ci/ci-mathcomp.sh diff --git a/dev/ci/ci-simple-io.sh b/dev/ci/ci-simple_io.sh index e7bcd80de7..e7bcd80de7 100755 --- a/dev/ci/ci-simple-io.sh +++ b/dev/ci/ci-simple_io.sh diff --git a/dev/ci/ci-verdi-raft.sh b/dev/ci/ci-verdi_raft.sh index 3bcd52c464..3bcd52c464 100755 --- a/dev/ci/ci-verdi-raft.sh +++ b/dev/ci/ci-verdi_raft.sh diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index e56e4d38ea..e240ea3ba1 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,4 +1,4 @@ -# CACHEKEY: "bionic_coq-V2020-03-19-V29" +# CACHEKEY: "bionic_coq-V2020-03-13-V69" # ^^ Update when modifying this file. FROM ubuntu:bionic @@ -22,7 +22,7 @@ RUN pip3 install sphinx==1.8.0 sphinx_rtd_theme==0.2.5b2 \ antlr4-python3-runtime==4.7.1 sphinxcontrib-bibtex==0.4.0 # We need to install OPAM 2.0 manually for now. -RUN wget https://github.com/ocaml/opam/releases/download/2.0.5/opam-2.0.5-x86_64-linux -O /usr/bin/opam && chmod 755 /usr/bin/opam +RUN wget https://github.com/ocaml/opam/releases/download/2.0.6/opam-2.0.6-x86_64-linux -O /usr/bin/opam && chmod 755 /usr/bin/opam # Basic OPAM setup ENV NJOBS="2" \ @@ -37,7 +37,7 @@ ENV COMPILER="4.05.0" # Common OPAM packages. # `num` does not have a version number as the right version to install varies # with the compiler version. -ENV BASE_OPAM="num ocamlfind.1.8.1 dune.2.0.1 ounit.2.2.2 odoc.1.5.0" \ +ENV BASE_OPAM="num ocamlfind.1.8.1 ounit.2.2.2 odoc.1.5.0" \ CI_OPAM="menhir.20190626 ocamlgraph.1.8.8" \ BASE_ONLY_OPAM="elpi.1.10.2" @@ -56,8 +56,8 @@ RUN opam switch create "${COMPILER}+32bit" && eval $(opam env) && \ opam install $BASE_OPAM # EDGE switch -ENV COMPILER_EDGE="4.09.1" \ - BASE_OPAM_EDGE="dune-release.1.3.3 ocamlformat.0.13.0" +ENV COMPILER_EDGE="4.10.0" \ + BASE_OPAM_EDGE="dune.2.5.0 dune-release.1.3.3 ocamlformat.0.14.0" # EDGE+flambda switch, we install CI_OPAM as to be able to use # `ci-template-flambda` with everything. diff --git a/dev/ci/nix/default.nix b/dev/ci/nix/default.nix index c8ea59f08a..b3ced999f6 100644 --- a/dev/ci/nix/default.nix +++ b/dev/ci/nix/default.nix @@ -22,7 +22,7 @@ let ssreflect = coqPackages.ssreflect.overrideAttrs (o: { }); in let coq-ext-lib = coqPackages.coq-ext-lib.overrideAttrs (o: { - src = fetchTarball "https://github.com/coq-ext-lib/coq-ext-lib/tarball/master"; + src = fetchTarball "https://github.com/coq-community/coq-ext-lib/tarball/master"; }); in let simple-io = diff --git a/dev/ci/user-overlays/11818-ejgallego-proof+remove_special_case_first_declaration_in_mutual.sh b/dev/ci/user-overlays/11818-ejgallego-proof+remove_special_case_first_declaration_in_mutual.sh new file mode 100644 index 0000000000..e3a8eb07f3 --- /dev/null +++ b/dev/ci/user-overlays/11818-ejgallego-proof+remove_special_case_first_declaration_in_mutual.sh @@ -0,0 +1,15 @@ +if [ "$CI_PULL_REQUEST" = "11818" ] || [ "$CI_BRANCH" = "proof+remove_special_case_first_declaration_in_mutual" ]; then + + metacoq_CI_REF=proof+remove_special_case_first_declaration_in_mutual + metacoq_CI_GITURL=https://github.com/ejgallego/metacoq + + elpi_CI_REF=proof+remove_special_case_first_declaration_in_mutual + elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi + + paramcoq_CI_REF=proof+remove_special_case_first_declaration_in_mutual + paramcoq_CI_GITURL=https://github.com/ejgallego/paramcoq + + equations_CI_REF=proof+remove_special_case_first_declaration_in_mutual + equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations + +fi diff --git a/dev/ci/user-overlays/11820-SkySkimmer-partial-import.sh b/dev/ci/user-overlays/11820-SkySkimmer-partial-import.sh new file mode 100644 index 0000000000..4170799be7 --- /dev/null +++ b/dev/ci/user-overlays/11820-SkySkimmer-partial-import.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "11820" ] || [ "$CI_BRANCH" = "partial-import" ]; then + + elpi_CI_REF=partial-import + elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi + +fi diff --git a/dev/ci/user-overlays/11896-ppedrot-evar-inst-list.sh b/dev/ci/user-overlays/11896-ppedrot-evar-inst-list.sh new file mode 100644 index 0000000000..cd6b408813 --- /dev/null +++ b/dev/ci/user-overlays/11896-ppedrot-evar-inst-list.sh @@ -0,0 +1,24 @@ +if [ "$CI_PULL_REQUEST" = "11896" ] || [ "$CI_BRANCH" = "evar-inst-list" ]; then + + coqhammer_CI_REF="evar-inst-list" + coqhammer_CI_GITURL=https://github.com/ppedrot/coqhammer + + elpi_CI_REF="evar-inst-list" + elpi_CI_GITURL=https://github.com/ppedrot/coq-elpi + + equations_CI_REF="evar-inst-list" + equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations + + metacoq_CI_REF="evar-inst-list" + metacoq_CI_GITURL=https://github.com/ppedrot/metacoq + + mtac2_CI_REF="evar-inst-list" + mtac2_CI_GITURL=https://github.com/ppedrot/Mtac2 + + quickchick_CI_REF="evar-inst-list" + quickchick_CI_GITURL=https://github.com/ppedrot/QuickChick + + unicoq_CI_REF="evar-inst-list" + unicoq_CI_GITURL=https://github.com/ppedrot/unicoq + +fi diff --git a/dev/ci/user-overlays/12023-herbelin-master+fixing-empty-Ltac-v-file.sh b/dev/ci/user-overlays/12023-herbelin-master+fixing-empty-Ltac-v-file.sh new file mode 100644 index 0000000000..6bee3c7bb6 --- /dev/null +++ b/dev/ci/user-overlays/12023-herbelin-master+fixing-empty-Ltac-v-file.sh @@ -0,0 +1,15 @@ +if [ "$CI_PULL_REQUEST" = "12023" ] || [ "$CI_BRANCH" = "master+fixing-empty-Ltac-v-file" ]; then + + fiat_crypto_CI_REF=master+pr12023-atomic-tactic-now-qualified-in-ltac-file + fiat_crypto_CI_GITURL=https://github.com/herbelin/fiat-crypto + + mtac2_CI_REF=master+pr12023-atomic-tactic-now-qualified-in-ltac-file + mtac2_CI_GITURL=https://github.com/herbelin/Mtac2 + + metacoq_CI_REF=master+pr12023-atomic-tactic-now-qualified-in-ltac-file + metacoq_CI_GITURL=https://github.com/herbelin/template-coq + + unimath_CI_REF=master+pr12023-atomic-tactic-now-qualified-in-ltac-file + unimath_CI_GITURL=https://github.com/herbelin/UniMath + +fi diff --git a/dev/ci/user-overlays/12107-SkySkimmer-no-mod-univs.sh b/dev/ci/user-overlays/12107-SkySkimmer-no-mod-univs.sh new file mode 100644 index 0000000000..b5faabcfe1 --- /dev/null +++ b/dev/ci/user-overlays/12107-SkySkimmer-no-mod-univs.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "12107" ] || [ "$CI_BRANCH" = "no-mod-univs" ]; then + + elpi_CI_REF=no-mod-univs + elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi + +fi diff --git a/dev/doc/build-system.dune.md b/dev/doc/build-system.dune.md index 0506216541..8b0bf216e3 100644 --- a/dev/doc/build-system.dune.md +++ b/dev/doc/build-system.dune.md @@ -18,10 +18,6 @@ Dune will get confused if it finds leftovers of in-tree compilation, so please be sure your tree is clean from objects files generated by the make-based system. -If you want to build the standard libraries and plugins you should -call `make -f Makefile.dune voboot`. It is usually enough to do that -once per-session. - More helper targets are available in `Makefile.dune`, `make -f Makefile.dune` will display some help. @@ -55,7 +51,6 @@ Instead, you should use the provided "shims" for running `coqtop` and `coqide` in a fast build. In order to use them, do: ``` -$ make -f Makefile.dune voboot # Only once per session $ dune exec -- dev/shim/coqtop-prelude ``` @@ -153,7 +148,7 @@ depending on your OCaml version. This is due to several factors: ## Dropping from coqtop: -After doing `make -f Makefile.dune voboot`, the following commands should work: +The following commands should work: ``` dune exec -- dev/shim/coqbyte-prelude > Drop. diff --git a/dev/doc/changes.md b/dev/doc/changes.md index eac8d86b0a..9498ab8bbb 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -9,6 +9,13 @@ ### ML API +Proof state and constant declaration: + +- A large consolidation of the API handling interactive and + non-interactive constant has been performed; low-level APIs are no + longer available, and the functionality of the `Proof_global` module + has been merged into `Declare`. + Notations: - Most operators on numerals have moved to file numTok.ml. @@ -68,7 +75,6 @@ Proof state: information related to the constant declaration. Some functions have been renamed from `start_proof` to `start_lemma` - Plugins that require access to the information about currently opened lemmas can add one of the `![proof]` attributes to their `mlg` entry, which will refine the type accordingly. See diff --git a/dev/dune-workspace.all b/dev/dune-workspace.all index 556493ffad..d6348a3624 100644 --- a/dev/dune-workspace.all +++ b/dev/dune-workspace.all @@ -3,5 +3,5 @@ ; Add custom flags here. Default developer profile is `dev` (context (opam (switch 4.05.0))) (context (opam (switch 4.05.0+32bit))) -(context (opam (switch 4.09.1))) -(context (opam (switch 4.09.1+flambda))) +(context (opam (switch 4.10.0))) +(context (opam (switch 4.10.0+flambda))) diff --git a/dev/nixpkgs.nix b/dev/nixpkgs.nix index b8a696ef21..fb84155392 100644 --- a/dev/nixpkgs.nix +++ b/dev/nixpkgs.nix @@ -1,4 +1,4 @@ import (fetchTarball { - url = "https://github.com/NixOS/nixpkgs/archive/34e41a91547e342f6fbc901929134b34000297eb.tar.gz"; - sha256 = "0mlqxim36xg8aj4r35mpcgqg27wy1dbbim9l1cpjl24hcy96v48w"; + url = "https://github.com/NixOS/nixpkgs/archive/807ca93fadd5197c2260490de0c76e500562dc05.tar.gz"; + sha256 = "10yq8bnls77fh3pk5chkkb1sv5lbdgyk1rr2v9xn71rr1k2x563p"; }) diff --git a/dev/tools/pre-commit b/dev/tools/pre-commit index 633913aac6..448e224f2e 100755 --- a/dev/tools/pre-commit +++ b/dev/tools/pre-commit @@ -16,6 +16,15 @@ then 1>&2 echo "Warning: ocamlformat is not in path. Cannot check formatting." fi +# Verify that the version of ocamlformat matches the one in .ocamlformat +# The following command will print an error message if that's not the case +# (and will print nothing if the versions match) +if ! echo "let () = ()" | "$ocamlformat" --impl - > /dev/null +then + 1>&2 echo "Warning: Cannot check formatting." + ocamlformat=true +fi + 1>&2 echo "Auto fixing whitespace and formatting issues..." # We fix whitespace in the index and in the working tree @@ -43,7 +52,7 @@ if [ -s "$index" ]; then git apply --cached --whitespace=fix "$index" git apply --whitespace=fix "$index" 2>/dev/null # no need to repeat yourself git diff --cached --name-only -z | xargs -0 dev/tools/check-eof-newline.sh --fix - git diff --cached --name-only -z | grep -E '.*\.mli?$' -z | xargs -0 "$ocamlformat" -i || true + { git diff --cached --name-only -z | grep -E '.*\.mli?$' -z | xargs -0 "$ocamlformat" -i || true; } 2> /dev/null git add -u 1>&2 echo #newline fi @@ -59,7 +68,7 @@ if [ -s "$tree" ]; then 1>&2 echo "Fixing unstaged changes..." git apply --whitespace=fix "$tree" git diff --name-only -z | xargs -0 dev/tools/check-eof-newline.sh --fix - git diff --name-only -z | grep -E '.*\.mli?$' -z | xargs -0 "$ocamlformat" -i || true + { git diff --name-only -z | grep -E '.*\.mli?$' -z | xargs -0 "$ocamlformat" -i || true; } 2> /dev/null 1>&2 echo #newline fi diff --git a/dev/tools/update-compat.py b/dev/tools/update-compat.py index ddb0362186..666fb6cc91 100755 --- a/dev/tools/update-compat.py +++ b/dev/tools/update-compat.py @@ -1,6 +1,4 @@ #!/usr/bin/env python3 -from __future__ import with_statement -from __future__ import print_function import os, re, sys, subprocess from io import open diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 7002cbffac..00050a89e1 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -59,8 +59,8 @@ let prrecarg = function let ppwf_paths x = pp (Rtree.pp_tree prrecarg x) let get_current_context () = - try Vernacstate.Proof_global.get_current_context () - with Vernacstate.Proof_global.NoCurrentProof -> + try Vernacstate.Declare.get_current_context () + with Vernacstate.Declare.NoCurrentProof -> let env = Global.env() in Evd.from_env env, env [@@ocaml.warning "-3"] @@ -287,7 +287,7 @@ let constr_display csr = "LetIn("^(name_display na)^","^(term_display b)^"," ^(term_display t)^","^(term_display c)^")" | App (c,l) -> "App("^(term_display c)^","^(array_display l)^")\n" - | Evar (e,l) -> "Evar("^(Pp.string_of_ppcmds (Evar.print e))^","^(array_display l)^")" + | Evar (e,l) -> "Evar("^(Pp.string_of_ppcmds (Evar.print e))^","^(array_display (Array.of_list l))^")" | Const (c,u) -> "Const("^(Constant.to_string c)^","^(universes_display u)^")" | Ind ((sp,i),u) -> "MutInd("^(MutInd.to_string sp)^","^(string_of_int i)^","^(universes_display u)^")" @@ -383,7 +383,7 @@ let print_pure_constr csr = Array.iter (fun x -> print_space (); box_display x) l; print_string ")" | Evar (e,l) -> print_string "Evar#"; print_int (Evar.repr e); print_string "{"; - Array.iter (fun x -> print_space (); box_display x) l; + List.iter (fun x -> print_space (); box_display x) l; print_string"}" | Const (c,u) -> print_string "Cons("; sp_con_display c; diff --git a/doc/changelog/01-kernel/11811-uncheck_positivity_bug.rst b/doc/changelog/01-kernel/11811-uncheck_positivity_bug.rst deleted file mode 100644 index c08ebb7f25..0000000000 --- a/doc/changelog/01-kernel/11811-uncheck_positivity_bug.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Fixed:** - Allow more inductive types in `Unset Positivity Checking` mode - (`#11811 <https://github.com/coq/coq/pull/11811>`_, - by SimonBoulier). diff --git a/doc/changelog/01-kernel/11972-fix-require-in-section.rst b/doc/changelog/01-kernel/11972-fix-require-in-section.rst new file mode 100644 index 0000000000..7a2fa9185f --- /dev/null +++ b/doc/changelog/01-kernel/11972-fix-require-in-section.rst @@ -0,0 +1,6 @@ +- **Fixed:** + Using :cmd:`Require` inside a section caused an anomaly when closing + the section. (`#11972 <https://github.com/coq/coq/pull/11972>`_, by + Gaëtan Gilbert, fixing `#11783 + <https://github.com/coq/coq/issues/11783>`_, reported by Attila + Boros). diff --git a/doc/changelog/02-specification-language/11235-non_maximal_implicit.rst b/doc/changelog/02-specification-language/11235-non_maximal_implicit.rst index 67e43973ce..768ef68339 100644 --- a/doc/changelog/02-specification-language/11235-non_maximal_implicit.rst +++ b/doc/changelog/02-specification-language/11235-non_maximal_implicit.rst @@ -1,5 +1,5 @@ - **Added:** - Syntax for non maximal implicit arguments in definitions and terms using + Syntax for non-maximal implicit arguments in definitions and terms using square brackets. The syntax is ``[x : A]``, ``[x]``, ```[A]`` to be consistent with the command :cmd:`Arguments`. (`#11235 <https://github.com/coq/coq/pull/11235>`_, diff --git a/doc/changelog/02-specification-language/11368-trailing_implicit_error.rst b/doc/changelog/02-specification-language/11368-trailing_implicit_error.rst index 11d7218ed0..66139f76e1 100644 --- a/doc/changelog/02-specification-language/11368-trailing_implicit_error.rst +++ b/doc/changelog/02-specification-language/11368-trailing_implicit_error.rst @@ -1,5 +1,5 @@ - **Changed:** - The warning raised when a trailing implicit is declared to be non maximally + The warning raised when a trailing implicit is declared to be non-maximally inserted (with the command :cmd:`Arguments`) has been turned into an error. This was deprecated since Coq 8.10 (`#11368 <https://github.com/coq/coq/pull/11368>`_, diff --git a/doc/changelog/02-specification-language/11579-inductive-params.rst b/doc/changelog/02-specification-language/11579-inductive-params.rst new file mode 100644 index 0000000000..28bc8e9592 --- /dev/null +++ b/doc/changelog/02-specification-language/11579-inductive-params.rst @@ -0,0 +1,7 @@ +- **Fixed:** + More robust and expressive treatment of implicit inductive + parameters in inductive declarations (`#11579 + <https://github.com/coq/coq/pull/11579>`_, by Maxime Dénès, Gaëtan + Gilbert and Jasper Hugunin; fixes `#7253 + <https://github.com/coq/coq/pull/7253>`_ and `#11585 + <https://github.com/coq/coq/pull/11585>`_) diff --git a/doc/changelog/03-notations/11120-master+refactoring-application-printing.rst b/doc/changelog/03-notations/11120-master+refactoring-application-printing.rst index d95f554766..eeb4c755f6 100644 --- a/doc/changelog/03-notations/11120-master+refactoring-application-printing.rst +++ b/doc/changelog/03-notations/11120-master+refactoring-application-printing.rst @@ -10,7 +10,7 @@ Herbelin, fixing `#4690 <https://github.com/coq/coq/pull/4690>`_ and `#11091 <https://github.com/coq/coq/pull/11091>`_). -- **Changed:** Interpretation scopes are now always inherited in +- **Changed:** Notation scopes are now always inherited in notations binding a partially applied constant, including for notations binding an expression of the form :n:`@@qualid`. The latter was not the case beforehand diff --git a/doc/changelog/03-notations/11530-master+fix11331-custom-entries-precedence.rst b/doc/changelog/03-notations/11530-master+fix11331-custom-entries-precedence.rst deleted file mode 100644 index b105928b22..0000000000 --- a/doc/changelog/03-notations/11530-master+fix11331-custom-entries-precedence.rst +++ /dev/null @@ -1,8 +0,0 @@ -- **Fixed:** - Bugs in dealing with precedences of notations in custom entries - (`#11530 <https://github.com/coq/coq/pull/11530>`_, - by Hugo Herbelin, fixing in particular - `#9517 <https://github.com/coq/coq/pull/9517>`_, - `#9519 <https://github.com/coq/coq/pull/9519>`_, - `#9521 <https://github.com/coq/coq/pull/9521>`_, - `#11331 <https://github.com/coq/coq/pull/11331>`_). diff --git a/doc/changelog/03-notations/11859-warn-inexact-float.rst b/doc/changelog/03-notations/11859-warn-inexact-float.rst deleted file mode 100644 index 224ffdbe9b..0000000000 --- a/doc/changelog/03-notations/11859-warn-inexact-float.rst +++ /dev/null @@ -1,6 +0,0 @@ -- **Added:** - In primitive floats, print a warning when parsing a decimal value - that is not exactly a binary64 floating-point number. - For instance, parsing 0.1 will print a warning whereas parsing 0.5 won't. - (`#11859 <https://github.com/coq/coq/pull/11859>`_, - by Pierre Roux). diff --git a/doc/changelog/04-tactics/11023-nativecompute-timing.rst b/doc/changelog/04-tactics/11023-nativecompute-timing.rst deleted file mode 100644 index e8cdfcca21..0000000000 --- a/doc/changelog/04-tactics/11023-nativecompute-timing.rst +++ /dev/null @@ -1,7 +0,0 @@ -- The :flag:`NativeCompute Timing` flag causes calls to - :tacn:`native_compute` (as well as kernel calls to the native - compiler) to emit separate timing information about compilation, - execution, and reification. It replaces the timing information - previously emitted when the `-debug` flag was set, and allows more - fine-grained timing of the native compiler (`#11023 - <https://github.com/coq/coq/pull/11023>`_, by Jason Gross). diff --git a/doc/changelog/04-tactics/11025-nativecompute-timing.rst b/doc/changelog/04-tactics/11025-nativecompute-timing.rst new file mode 100644 index 0000000000..cb77457c31 --- /dev/null +++ b/doc/changelog/04-tactics/11025-nativecompute-timing.rst @@ -0,0 +1,11 @@ +- **Changed:** The :flag:`NativeCompute Timing` flag causes calls to + :tacn:`native_compute` (as well as kernel calls to the native + compiler) to emit separate timing information about conversion to + native code, compilation, execution, and reification. It replaces + the timing information previously emitted when the `-debug` flag was + set, and allows more fine-grained timing of the native compiler + (`#11025 <https://github.com/coq/coq/pull/11025>`_, by Jason Gross). + Additionally, the timing information now uses real time rather than + user time (Fixes `#11962 + <https://github.com/coq/coq/issues/11962>`_, `#11963 + <https://github.com/coq/coq/pull/11963>`_, by Jason Gross) diff --git a/doc/changelog/04-tactics/11883-fix-autounfold.rst b/doc/changelog/04-tactics/11883-fix-autounfold.rst new file mode 100644 index 0000000000..83ff177380 --- /dev/null +++ b/doc/changelog/04-tactics/11883-fix-autounfold.rst @@ -0,0 +1,13 @@ +- **Fixed:** + The behavior of :tacn:`autounfold` no longer depends on the names of terms and modules + (`#11883 <https://github.com/coq/coq/pull/11883>`_, + fixes `#7812 <https://github.com/coq/coq/issues/7812>`_, + by Attila Gáspár). +- **Changed:** + `at` clauses can no longer be used with :tacn:`autounfold`. Since they had no effect, it is safe to remove them + (`#11883 <https://github.com/coq/coq/pull/11883>`_, + by Attila Gáspár). +- **Changed:** + :tacn:`autounfold` no longer fails when the :cmd:`Opaque` command is used on constants in the hint databases + (`#11883 <https://github.com/coq/coq/pull/11883>`_, + by Attila Gáspár). diff --git a/doc/changelog/04-tactics/11976-deprecate-omega.rst b/doc/changelog/04-tactics/11976-deprecate-omega.rst new file mode 100644 index 0000000000..59c9612d17 --- /dev/null +++ b/doc/changelog/04-tactics/11976-deprecate-omega.rst @@ -0,0 +1,5 @@ +- **Deprecated:** + The :tacn:`omega` tactic is deprecated; + use :tacn:`lia` from the :ref:`Micromega <micromega>` plugin instead + (`#11976 <https://github.com/coq/coq/pull/11976>`_, + by Vincent Laporte). diff --git a/doc/changelog/04-tactics/12023-master+fixing-empty-Ltac-v-file.rst b/doc/changelog/04-tactics/12023-master+fixing-empty-Ltac-v-file.rst new file mode 100644 index 0000000000..f10208e9b2 --- /dev/null +++ b/doc/changelog/04-tactics/12023-master+fixing-empty-Ltac-v-file.rst @@ -0,0 +1,6 @@ +- **Changed:** + Tactics with qualified name of the form ``Coq.Init.Notations`` are + now qualified with prefix ``Coq.Init.Ltac``; users of the -noinit + option should now import Coq.Init.Ltac if they want to use Ltac + (`#12023 <https://github.com/coq/coq/pull/12023>`_, + by Hugo Herbelin; minor source of incompatibilities). diff --git a/doc/changelog/04-tactics/12116-master+fix12045-missing-reduction-in-using-ind-scheme.rst b/doc/changelog/04-tactics/12116-master+fix12045-missing-reduction-in-using-ind-scheme.rst new file mode 100644 index 0000000000..7af2b4d97b --- /dev/null +++ b/doc/changelog/04-tactics/12116-master+fix12045-missing-reduction-in-using-ind-scheme.rst @@ -0,0 +1,5 @@ +- **Fixed:** + Anomaly with induction schemes whose conclusion is not normalized + (`#12116 <https://github.com/coq/coq/pull/12116>`_, + by Hugo Herbelin; fixes + `#12045 <https://github.com/coq/coq/pull/12045>`_) diff --git a/doc/changelog/04-tactics/12213-zify-Nat.rst b/doc/changelog/04-tactics/12213-zify-Nat.rst new file mode 100644 index 0000000000..8b744cd193 --- /dev/null +++ b/doc/changelog/04-tactics/12213-zify-Nat.rst @@ -0,0 +1,3 @@ +- **Added:** + The :tacn:`zify` tactic is now aware of `Nat.le`, `Nat.lt` and `Nat.eq` + (`#12213 <https://github.com/coq/coq/pull/12213>`_, by Frédéric Besson; fixes `#12210 <https://github.com/coq/coq/issues/12210>`_). diff --git a/doc/changelog/05-tactic-language/11882-master+ltac2-fresh-in-context.rst b/doc/changelog/05-tactic-language/11882-master+ltac2-fresh-in-context.rst new file mode 100644 index 0000000000..47e7be4d0e --- /dev/null +++ b/doc/changelog/05-tactic-language/11882-master+ltac2-fresh-in-context.rst @@ -0,0 +1,6 @@ +- **Added:** + New Ltac2 function ``Fresh.Free.of_goal`` to return the list of + names of declarations of the current goal; new Ltac2 function + ``Fresh.in_goal`` to return a variable fresh in the current goal + (`#11882 <https://github.com/coq/coq/pull/11882>`_, + by Hugo Herbelin). diff --git a/doc/changelog/07-commands-and-options/11534-let-with-annotations.rst b/doc/changelog/07-commands-and-options/11534-let-with-annotations.rst new file mode 100644 index 0000000000..7bcbb9a8e3 --- /dev/null +++ b/doc/changelog/07-commands-and-options/11534-let-with-annotations.rst @@ -0,0 +1,3 @@ +- **Added:** Support for universe bindings and universe contrainsts in + :cmd:`Let` definitions (`#11534 + <https://github.com/coq/coq/pull/11534>`_, by Théo Zimmermann). diff --git a/doc/changelog/07-commands-and-options/11746-remove-chapter.rst b/doc/changelog/07-commands-and-options/11746-remove-chapter.rst new file mode 100644 index 0000000000..0316432b0a --- /dev/null +++ b/doc/changelog/07-commands-and-options/11746-remove-chapter.rst @@ -0,0 +1,3 @@ +- **Removed:** undocumented ``Chapter`` command. Use :cmd:`Section` + instead (`#11746 <https://github.com/coq/coq/pull/11746>`_, by Théo + Zimmermann). diff --git a/doc/changelog/07-commands-and-options/12034-cumul-sprop.rst b/doc/changelog/07-commands-and-options/12034-cumul-sprop.rst new file mode 100644 index 0000000000..ad7cf44482 --- /dev/null +++ b/doc/changelog/07-commands-and-options/12034-cumul-sprop.rst @@ -0,0 +1,5 @@ +- **Changed:** + Added :flag:`Cumulative StrictProp` to control cumulativity of + |SProp| and deprecated now redundant command line + ``--cumulative-sprop`` (`#12034 + <https://github.com/coq/coq/pull/12034>`_, by Gaëtan Gilbert). diff --git a/doc/changelog/07-commands-and-options/12070-native-compiler-disabled.rst b/doc/changelog/07-commands-and-options/12070-native-compiler-disabled.rst new file mode 100644 index 0000000000..0f30b5f5e8 --- /dev/null +++ b/doc/changelog/07-commands-and-options/12070-native-compiler-disabled.rst @@ -0,0 +1,5 @@ +- **Changed:** + Ignore -native-compiler option when built without native compute + support. + (`#12070 <https://github.com/coq/coq/pull/12070>`_, + by Pierre Roux). diff --git a/doc/changelog/08-tools/10592-coqdoc-details.rst b/doc/changelog/08-tools/10592-coqdoc-details.rst new file mode 100644 index 0000000000..c5bdc1dbb0 --- /dev/null +++ b/doc/changelog/08-tools/10592-coqdoc-details.rst @@ -0,0 +1,5 @@ +- **Added:** + A new documentation environment ``details`` to make certain portion + of a Coq document foldable. See :ref:`coqdoc` + (`#10592 <https://github.com/coq/coq/pull/10592>`_, + by Thomas Letan). diff --git a/doc/changelog/08-tools/11606-memory-in-timing-scripts.rst b/doc/changelog/08-tools/11606-memory-in-timing-scripts.rst new file mode 100644 index 0000000000..e09c6ef3a3 --- /dev/null +++ b/doc/changelog/08-tools/11606-memory-in-timing-scripts.rst @@ -0,0 +1,25 @@ +- **Added:** + The ``make-one-time-file.py`` and ``make-both-time-files.py`` + scripts now include peak memory usage information in the tables (can + be turned off by the ``--no-include-mem`` command-line parameter), + and a ``--sort-by-mem`` parameter to sort the tables by memory + rather than time. When invoking these scripts via the + ``print-pretty-timed`` or ``print-pretty-timed-diff`` targets in a + ``Makefile`` made by ``coq_makefile``, you can set this argument by + passing ``TIMING_INCLUDE_MEM=0`` (to pass ``--no-include-mem``) and + ``TIMING_SORT_BY_MEM=1`` (to pass ``--sort-by-mem``) to ``make`` + (`#11606 <https://github.com/coq/coq/pull/11606>`_, by Jason Gross). + +- **Added:** + Coq's build system now supports both ``TIMING_INCLUDE_MEM`` and + ``TIMING_SORT_BY_MEM`` just like a ``Makefile`` made by + ``coq_makefile`` (`#11606 <https://github.com/coq/coq/pull/11606>`_, + by Jason Gross). + +- **Changed:** + The sorting order of the timing script ``make-both-time-files.py`` + and the target ``print-pretty-timed-diff`` is now deterministic even + when the sorting order is ``absolute`` or ``diff``; previously the + relative ordering of two files with identical times was + non-deterministic (`#11606 + <https://github.com/coq/coq/pull/11606>`_, by Jason Gross). diff --git a/doc/changelog/08-tools/12005-remove-deprecated-coqtop-options.rst b/doc/changelog/08-tools/12005-remove-deprecated-coqtop-options.rst new file mode 100644 index 0000000000..affb685fcb --- /dev/null +++ b/doc/changelog/08-tools/12005-remove-deprecated-coqtop-options.rst @@ -0,0 +1,5 @@ +- **Removed:** + Confusingly-named and deprecated since 8.11 `-require` option. + Use the equivalent `-require-import` instead + (`#12005 <https://github.com/coq/coq/pull/12005>`_, + by Théo Zimmermann). diff --git a/doc/changelog/08-tools/12006-issue5632.rst b/doc/changelog/08-tools/12006-issue5632.rst new file mode 100644 index 0000000000..162d56b1b6 --- /dev/null +++ b/doc/changelog/08-tools/12006-issue5632.rst @@ -0,0 +1,4 @@ +- **Added:** + ``Makefile`` generated by ``coq_makefile`` erases ``.lia.cache`` and ``.nia.cache`` by ``make cleanall``. + (`#12006 <https://github.com/coq/coq/pull/12006>`_, + by Olivier Laurent). diff --git a/doc/changelog/08-tools/12026-master+coqdoc-self-linked-defs-wish7093.rst b/doc/changelog/08-tools/12026-master+coqdoc-self-linked-defs-wish7093.rst new file mode 100644 index 0000000000..5c4ef82b8b --- /dev/null +++ b/doc/changelog/08-tools/12026-master+coqdoc-self-linked-defs-wish7093.rst @@ -0,0 +1,4 @@ +- **Added:** + Definitions in coqdoc link to themselves, giving access in html to their own url + (`#12026 <https://github.com/coq/coq/pull/12026>`_, + by Hugo Herbelin; granting `#7093 <https://github.com/coq/coq/pull/7093>`_). diff --git a/doc/changelog/08-tools/12027-master+fix3415-coqdoc-record.rst b/doc/changelog/08-tools/12027-master+fix3415-coqdoc-record.rst new file mode 100644 index 0000000000..ae9b69e592 --- /dev/null +++ b/doc/changelog/08-tools/12027-master+fix3415-coqdoc-record.rst @@ -0,0 +1,5 @@ +- **Fixed:** + Fields of a record tuple now link in coqdoc to their definition + (`#12027 <https://github.com/coq/coq/pull/12027>`_, fixes + `#3415 <https://github.com/coq/coq/issues/3415>`_, + by Hugo Herbelin; ). diff --git a/doc/changelog/08-tools/12033-master+coqdoc-fix7697-passing-binders-location.rst b/doc/changelog/08-tools/12033-master+coqdoc-fix7697-passing-binders-location.rst new file mode 100644 index 0000000000..af0d28305a --- /dev/null +++ b/doc/changelog/08-tools/12033-master+coqdoc-fix7697-passing-binders-location.rst @@ -0,0 +1,5 @@ +- **Added:** + Add hyperlinks on bound variables for coqdoc + (`#12033 <https://github.com/coq/coq/pull/12033>`_, + by Hugo Herbelin; it incidentally fixes + `#7697 <https://github.com/coq/coq/pull/7697>`_). diff --git a/doc/changelog/08-tools/12037-coqdoc-preformatted.rst b/doc/changelog/08-tools/12037-coqdoc-preformatted.rst new file mode 100644 index 0000000000..bf65719516 --- /dev/null +++ b/doc/changelog/08-tools/12037-coqdoc-preformatted.rst @@ -0,0 +1,6 @@ +- **Fixed:** + ``coqdoc`` now reports the location of a mismatched opening ``[[`` instead of + throwing an uninformative exception. + (`#12037 <https://github.com/coq/coq/pull/12037>`_, + fixes `#9670 <https://github.com/coq/coq/issues/9670>`_, + by Lysxia). diff --git a/doc/changelog/08-tools/12091-master+coqdoc-css-target.rst b/doc/changelog/08-tools/12091-master+coqdoc-css-target.rst new file mode 100644 index 0000000000..f6af5d40e8 --- /dev/null +++ b/doc/changelog/08-tools/12091-master+coqdoc-css-target.rst @@ -0,0 +1,4 @@ +- **Added:** + ``Coqdoc``: Highlighting of the exact position of the target of links + (`#12091 <https://github.com/coq/coq/pull/12091>`_, + by Hugo Herbelin). diff --git a/doc/changelog/08-tools/12126-adjust-timed-name.rst b/doc/changelog/08-tools/12126-adjust-timed-name.rst new file mode 100644 index 0000000000..c305b384d9 --- /dev/null +++ b/doc/changelog/08-tools/12126-adjust-timed-name.rst @@ -0,0 +1,8 @@ +- **Changed:** + The output of ``make TIMED=1`` (and therefore the timing targets + such as ``print-pretty-timed`` and ``print-pretty-timed-diff``) now + displays the full name of the output file being built, rather than + the stem of the rule (which was usually the filename without the + extension, but in general could be anything for user-defined rules + involving ``%``) (`#12126 + <https://github.com/coq/coq/pull/12126>`_, by Jason Gross). diff --git a/doc/changelog/09-coqide/10008-snyke7+escape_spaces.rst b/doc/changelog/09-coqide/10008-snyke7+escape_spaces.rst deleted file mode 100644 index cbd97688c3..0000000000 --- a/doc/changelog/09-coqide/10008-snyke7+escape_spaces.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Fixed:** - Compiling file paths containing spaces - (`#10008 <https://github.com/coq/coq/pull/10008>`_, - by snyke7, fixing `#11595 <https://github.com/coq/coq/pull/11595>`_). diff --git a/doc/changelog/09-coqide/12060-ide-disable-csd.rst b/doc/changelog/09-coqide/12060-ide-disable-csd.rst new file mode 100644 index 0000000000..b61ab26007 --- /dev/null +++ b/doc/changelog/09-coqide/12060-ide-disable-csd.rst @@ -0,0 +1,6 @@ +- **Changed:** + CoqIDE now uses native window frames by default on Windows. + The GTK window frames can be restored by setting the `GTK_CSD` environment variable to `1` + (`#12060 <https://github.com/coq/coq/pull/12060>`_, + fixes `#11080 <https://github.com/coq/coq/issues/11080>`_, + by Attila Gáspár). diff --git a/doc/changelog/09-coqide/12106-master+coqide-style-apply-all-windows.rst b/doc/changelog/09-coqide/12106-master+coqide-style-apply-all-windows.rst new file mode 100644 index 0000000000..6b1148a9a8 --- /dev/null +++ b/doc/changelog/09-coqide/12106-master+coqide-style-apply-all-windows.rst @@ -0,0 +1,5 @@ +- **Fixed:** + Highlighting style consistently applied to all three buffers of CoqIDE + (`#12106 <https://github.com/coq/coq/pull/12106>`_, + by Hugo Herbelin; fixes + `#11506 <https://github.com/coq/coq/pull/11506>`_). diff --git a/doc/changelog/10-standard-library/11249-ollibs-list-changelog.rst b/doc/changelog/10-standard-library/11249-ollibs-list-changelog.rst new file mode 100644 index 0000000000..be15fbf8f5 --- /dev/null +++ b/doc/changelog/10-standard-library/11249-ollibs-list-changelog.rst @@ -0,0 +1,17 @@ +- **Added:** + lemmas about lists: + + - properties of ``In``: ``in_elt``, ``in_elt_inv`` + - properties of ``nth``: ``app_nth2_plus``, ``nth_middle``, ``nth_ext`` + - properties of ``last``: ``last_last``, ``removelast_last`` + - properties of ``remove``: ``remove_cons``, ``remove_app``, ``notin_remove``, ``in_remove``, ``in_in_remove``, ``remove_remove_comm``, ``remove_remove_eq``, ``remove_length_le``, ``remove_length_lt`` + - properties of ``concat``: ``in_concat``, ``remove_concat`` + - properties of ``map`` and ``flat_map``: ``map_last``, ``map_eq_cons``, ``map_eq_app``, ``flat_map_app``, ``flat_map_ext``, ``nth_nth_nth_map`` + - properties of ``incl``: ``incl_nil_l``, ``incl_l_nil``, ``incl_cons_inv``, ``incl_app_app``, ``incl_app_inv``, ``remove_incl`` + - properties of ``Exists`` and ``Forall``: ``Exists_nth``, ``Exists_app``, ``Exists_rev``, ``Exists_fold_right``, ``incl_Exists``, ``Forall_nth``, ``Forall_app``, ``Forall_elt``, ``Forall_rev``, ``Forall_fold_right``, ``incl_Forall``, ``map_ext_Forall``, ``Exists_or``, ``Exists_or_inv``, ``Forall_and``, ``Forall_and_inv``, ``exists_Forall``, ``Forall_image``, ``concat_nil_Forall``, ``in_flat_map_Exists``, ``notin_flat_map_Forall`` + - properties of ``repeat``: ``repeat_cons``, ``repeat_to_concat`` + - definitions and properties of ``list_sum`` and ``list_max``: ``list_sum_app``, ``list_max_app``, ``list_max_le``, ``list_max_lt`` + - misc: ``elt_eq_unit``, ``last_length``, ``rev_eq_app``, ``removelast_firstn_len``, ``NoDup_rev``, ``nodup_incl``, ``cons_seq``, ``seq_S`` + + (`#11249 <https://github.com/coq/coq/pull/11249>`_, + by Olivier Laurent). diff --git a/doc/changelog/10-standard-library/11335-ollibs-wfnat-changelog.rst b/doc/changelog/10-standard-library/11335-ollibs-wfnat-changelog.rst new file mode 100644 index 0000000000..0eb3eefde5 --- /dev/null +++ b/doc/changelog/10-standard-library/11335-ollibs-wfnat-changelog.rst @@ -0,0 +1,4 @@ +- **Added:** + Well-founded induction principles for `nat`: ``lt_wf_rect1``, ``lt_wf_rect``, ``gt_wf_rect``, ``lt_wf_double_rect`` + (`#11335 <https://github.com/coq/coq/pull/11335>`_, + by Olivier Laurent). diff --git a/doc/changelog/10-standard-library/11880-iter.rst b/doc/changelog/10-standard-library/11880-iter.rst new file mode 100644 index 0000000000..be4e44ce4c --- /dev/null +++ b/doc/changelog/10-standard-library/11880-iter.rst @@ -0,0 +1,8 @@ +- **Added:** + Facts about ``N.iter`` and ``Pos.iter``: + + - ``N.iter_swap_gen``, ``N.iter_swap``, ``N.iter_succ``, ``N.iter_succ_r``, ``N.iter_add``, ``N.iter_ind``, ``N.iter_invariant``; + - ``Pos.iter_succ_r``, ``Pos.iter_ind``. + + (`#11880 <https://github.com/coq/coq/pull/11880>`_, + by Lysxia). diff --git a/doc/changelog/10-standard-library/11909-fix-≡-level.rst b/doc/changelog/10-standard-library/11909-fix-≡-level.rst new file mode 100644 index 0000000000..96551be537 --- /dev/null +++ b/doc/changelog/10-standard-library/11909-fix-≡-level.rst @@ -0,0 +1,7 @@ +- **Changed:** + The level of :g:`≡` in ``Coq.Numbers.Cyclic.Int63.Int63`` is now 70, + no associativity, in line with :g:`=`. Note that this is a minor + incompatibility with developments that declare their own :g:`≡` + notation and import ``Int63`` (fixes `#11905 + <https://github.com/coq/coq/issues/11905>`_, `#11909 + <https://github.com/coq/coq/pull/11909>`_, by Jason Gross). diff --git a/doc/changelog/10-standard-library/11946-ollibs-permutation.rst b/doc/changelog/10-standard-library/11946-ollibs-permutation.rst new file mode 100644 index 0000000000..626677d31a --- /dev/null +++ b/doc/changelog/10-standard-library/11946-ollibs-permutation.rst @@ -0,0 +1,10 @@ +- **Added:** + Facts about ``Permutation``: + + - structure: ``Permutation_refl'``, ``Permutation_morph_transp`` + - compatibilities: ``Permutation_app_rot``, ``Permutation_app_swap_app``, ``Permutation_app_middle``, ``Permutation_middle2``, ``Permutation_elt``, ``Permutation_Forall``, ``Permutation_Exists``, ``Permutation_Forall2``, ``Permutation_flat_map``, ``Permutation_list_sum``, ``Permutation_list_max`` + - inversions: ``Permutation_app_inv_m``, ``Permutation_vs_elt_inv``, ``Permutation_vs_cons_inv``, ``Permutation_vs_cons_cons_inv``, ``Permutation_map_inv``, ``Permutation_image``, ``Permutation_elt_map_inv`` + - length-preserving definition by means of transpositions ``Permutation_transp`` with associated properties: ``Permutation_transp_sym``, ``Permutation_transp_equiv``, ``Permutation_transp_cons``, ``Permutation_Permutation_transp``, ``Permutation_ind_transp`` + + (`#11946 <https://github.com/coq/coq/pull/11946>`_, + by Olivier Laurent). diff --git a/doc/changelog/10-standard-library/11957-signotations.rst b/doc/changelog/10-standard-library/11957-signotations.rst new file mode 100644 index 0000000000..fc5d434274 --- /dev/null +++ b/doc/changelog/10-standard-library/11957-signotations.rst @@ -0,0 +1,4 @@ +- **Added:** + notations for sigma types: ``{ x & P & Q }``, ``{ ' pat & P }``, ``{ ' pat & P & Q }`` + (`#11957 <https://github.com/coq/coq/pull/11957>`_, + by Olivier Laurent). diff --git a/doc/changelog/10-standard-library/12014-ollibs-vector.rst b/doc/changelog/10-standard-library/12014-ollibs-vector.rst new file mode 100644 index 0000000000..87625dd23b --- /dev/null +++ b/doc/changelog/10-standard-library/12014-ollibs-vector.rst @@ -0,0 +1,10 @@ +- **Added:** + Properties of some operations on vectors: + + - ``nth_order``: ``nth_order_hd``, ``nth_order_tl``, ``nth_order_ext`` + - ``replace``: ``nth_order_replace_eq``, ``nth_order_replace_neq``, ``replace_id``, ``replace_replace_eq``, ``replace_replace_neq`` + - ``map``: ``map_id``, ``map_map``, ``map_ext_in``, ``map_ext`` + - ``Forall`` and ``Forall2``: ``Forall_impl``, ``Forall_forall``, ``Forall_nth_order``, ``Forall2_nth_order`` + + (`#12014 <https://github.com/coq/coq/pull/12014>`_, + by Olivier Laurent). diff --git a/doc/changelog/10-standard-library/12031-ollibs-cpermutation.rst b/doc/changelog/10-standard-library/12031-ollibs-cpermutation.rst new file mode 100644 index 0000000000..95b4cce2f7 --- /dev/null +++ b/doc/changelog/10-standard-library/12031-ollibs-cpermutation.rst @@ -0,0 +1,4 @@ +- **Added:** + Definition and properties of cyclic permutations / circular shifts: ``CPermutation`` + (`#12031 <https://github.com/coq/coq/pull/12031>`_, + by Olivier Laurent). diff --git a/doc/changelog/10-standard-library/12044-issue-12015.rst b/doc/changelog/10-standard-library/12044-issue-12015.rst new file mode 100644 index 0000000000..166fc80fb0 --- /dev/null +++ b/doc/changelog/10-standard-library/12044-issue-12015.rst @@ -0,0 +1,10 @@ +- **Fixed:** + Rewrote ``Structures.OrderedTypeEx.String_as_OT.compare`` + to avoid huge proof terms + (Fixes `#12015 <https://github.com/coq/coq/issues/12015>`_, + `#12044 <https://github.com/coq/coq/pull/12044>`_, + by formalize.eth (formalize@protonmail.com)). +- **Added:** + Added ``Structures.OrderedTypeEx.Ascii_as_OT`` + (`#12044 <https://github.com/coq/coq/pull/12044>`_, + by formalize.eth (formalize@protonmail.com)). diff --git a/doc/changelog/10-standard-library/12073-split-nsatz.rst b/doc/changelog/10-standard-library/12073-split-nsatz.rst new file mode 100644 index 0000000000..bc3c24e441 --- /dev/null +++ b/doc/changelog/10-standard-library/12073-split-nsatz.rst @@ -0,0 +1,11 @@ +- **Changed:** + It is now possible to import the :g:`nsatz` machinery without + transitively depending on the axioms of the real numbers nor of + classical logic by loading ``Coq.nsatz.NsatzTactic`` rather than + ``Coq.nsatz.Nsatz``. Note that some constants have changed kernel + names, living in ``Coq.nsatz.NsatzTactic`` rather than + ``Coq.nsatz.Nsatz``; this might cause minor incompatibilities that + can be fixed by actually running :g:`Import Nsatz` rather than + relying on absolute names (fixes `#5445 + <https://github.com/coq/coq/issues/5445>`_, `#12073 + <https://github.com/coq/coq/pull/12073>`_, by Jason Gross). diff --git a/doc/changelog/10-standard-library/12119-issue12119.rst b/doc/changelog/10-standard-library/12119-issue12119.rst new file mode 100644 index 0000000000..42672b1465 --- /dev/null +++ b/doc/changelog/10-standard-library/12119-issue12119.rst @@ -0,0 +1,5 @@ +- **Changed:** + new lemma ``NoDup_incl_NoDup`` in ``List.v`` + to remove useless hypothesis `NoDup l'` in ``Sorting.Permutation.NoDup_Permutation_bis`` + (`#12119 <https://github.com/coq/coq/pull/12119>`_, + by Olivier Laurent). diff --git a/doc/changelog/10-standard-library/9803-reals.rst b/doc/changelog/10-standard-library/9803-reals.rst new file mode 100644 index 0000000000..86c5e45bc1 --- /dev/null +++ b/doc/changelog/10-standard-library/9803-reals.rst @@ -0,0 +1,14 @@ +- **Changed:** + Cleanup of names in the Reals theory: replaced `tan_is_inj` with `tan_inj` and replaced `atan_right_inv` with `tan_atan` - + compatibility notations are provided. Moved various auxiliary lemmas from `Ratan.v` to more appropriate places. + (`#9803 <https://github.com/coq/coq/pull/9803>`_, + by Laurent Théry and Michael Soegtrop). + +- **Added:** to the Reals theory: + inverse trigonometric functions `asin` and `acos` with lemmas for the derivatives, bounds and special values of these functions; + an extensive set of identities between trigonometric functions and their inverse functions; + lemmas for the injectivity of sine and cosine; + lemmas on the derivative of the inverse of decreasing functions and on the derivative of horizontally mirrored functions; + various generic auxiliary lemmas and definitions for Rsqr, sqrt, posreal an others. + (`#9803 <https://github.com/coq/coq/pull/9803>`_, + by Laurent Théry and Michael Soegtrop). diff --git a/doc/changelog/11-infrastructure-and-dependencies/11860-ci+ocaml_to_4091.rst b/doc/changelog/11-infrastructure-and-dependencies/11860-ci+ocaml_to_4091.rst deleted file mode 100644 index 94e2c34828..0000000000 --- a/doc/changelog/11-infrastructure-and-dependencies/11860-ci+ocaml_to_4091.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Added:** - Bump official OCaml support to 4.09.1 - (`#11860 <https://github.com/coq/coq/pull/11860>`_, - by Emilio Jesus Gallego Arias). diff --git a/doc/changelog/12-misc/11329-master+fix11114-extraction-anomaly-implicit-record.rst b/doc/changelog/12-misc/11329-master+fix11114-extraction-anomaly-implicit-record.rst deleted file mode 100644 index 0a686dd87d..0000000000 --- a/doc/changelog/12-misc/11329-master+fix11114-extraction-anomaly-implicit-record.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Fixed:** - :cmd:`Extraction Implicit` on the constructor of a record was leading to an anomaly - (`#11329 <https://github.com/coq/coq/pull/11329>`_, - by Hugo Herbelin, fixes `#11114 <https://github.com/coq/coq/pull/11114>`_). diff --git a/doc/common/styles/html/coqremote/sites/all/themes/coq/coqdoc.css b/doc/common/styles/html/coqremote/sites/all/themes/coq/coqdoc.css deleted file mode 100644 index d23ea8f362..0000000000 --- a/doc/common/styles/html/coqremote/sites/all/themes/coq/coqdoc.css +++ /dev/null @@ -1,329 +0,0 @@ -body { padding: 0px 0px; - margin: 0px 0px; - background-color: white } - -#page { display: block; - padding: 0px; - margin: 0px; - padding-bottom: 10px; } - -#header { display: block; - position: relative; - padding: 0; - margin: 0; - vertical-align: middle; - border-bottom-style: solid; - border-width: thin } - -#header h1 { padding: 0; - margin: 0;} - - -/* Contents */ - -#main{ display: block; - padding: 10px; - font-family: sans-serif; - font-size: 100%; - line-height: 100% } - -#main h1 { line-height: 95% } /* allow for multi-line headers */ - -#main a.idref:visited {color : #416DFF; text-decoration : none; } -#main a.idref:link {color : #416DFF; text-decoration : none; } -#main a.idref:hover {text-decoration : none; } -#main a.idref:active {text-decoration : none; } - -#main a.modref:visited {color : #416DFF; text-decoration : none; } -#main a.modref:link {color : #416DFF; text-decoration : none; } -#main a.modref:hover {text-decoration : none; } -#main a.modref:active {text-decoration : none; } - -#main .keyword { color : #cf1d1d } -#main { color: black } - -.section { background-color: rgb(60%,60%,100%); - padding-top: 13px; - padding-bottom: 13px; - padding-left: 3px; - margin-top: 5px; - margin-bottom: 5px; - font-size : 175% } - -h2.section { background-color: rgb(80%,80%,100%); - padding-left: 3px; - padding-top: 12px; - padding-bottom: 10px; - font-size : 130% } - -h3.section { background-color: rgb(90%,90%,100%); - padding-left: 3px; - padding-top: 7px; - padding-bottom: 7px; - font-size : 115% } - -h4.section { -/* - background-color: rgb(80%,80%,80%); - max-width: 20em; - padding-left: 5px; - padding-top: 5px; - padding-bottom: 5px; -*/ - background-color: white; - padding-left: 0px; - padding-top: 0px; - padding-bottom: 0px; - font-size : 100%; - font-weight : bold; - text-decoration : underline; - } - -#main .doc { margin: 0px; - font-family: sans-serif; - font-size: 100%; - line-height: 125%; - max-width: 40em; - color: black; - padding: 10px; - background-color: #90bdff} - -.inlinecode { - display: inline; -/* font-size: 125%; */ - color: #666666; - font-family: monospace } - -.doc .inlinecode { - display: inline; - font-size: 120%; - color: rgb(30%,30%,70%); - font-family: monospace } - -.doc .inlinecode .id { - color: rgb(30%,30%,70%); -} - -.inlinecodenm { - display: inline; - color: #444444; -} - -.doc .code { - display: inline; - font-size: 120%; - color: rgb(30%,30%,70%); - font-family: monospace } - -.comment { - display: inline; - font-family: monospace; - color: rgb(50%,50%,80%); -} - -.code { - display: block; -/* padding-left: 15px; */ - font-size: 110%; - font-family: monospace; - } - -table.infrule { - border: 0px; - margin-left: 50px; - margin-top: 10px; - margin-bottom: 10px; -} - -td.infrule { - font-family: monospace; - text-align: center; -/* color: rgb(35%,35%,70%); */ - padding: 0px; - line-height: 100%; -} - -tr.infrulemiddle hr { - margin: 1px 0 1px 0; -} - -.infrulenamecol { - color: rgb(60%,60%,60%); - font-size: 80%; - padding-left: 1em; - padding-bottom: 0.1em -} - -/* Pied de page */ - -#footer { font-size: 65%; - font-family: sans-serif; } - -/* Identifiers: <span class="id" title="...">) */ - -.id { display: inline; } - -.id[title="constructor"] { - color: rgb(60%,0%,0%); -} - -.id[title="var"] { - color: rgb(40%,0%,40%); -} - -.id[title="variable"] { - color: rgb(40%,0%,40%); -} - -.id[title="definition"] { - color: rgb(0%,40%,0%); -} - -.id[title="abbreviation"] { - color: rgb(0%,40%,0%); -} - -.id[title="lemma"] { - color: rgb(0%,40%,0%); -} - -.id[title="instance"] { - color: rgb(0%,40%,0%); -} - -.id[title="projection"] { - color: rgb(0%,40%,0%); -} - -.id[title="method"] { - color: rgb(0%,40%,0%); -} - -.id[title="inductive"] { - color: rgb(0%,0%,80%); -} - -.id[title="record"] { - color: rgb(0%,0%,80%); -} - -.id[title="class"] { - color: rgb(0%,0%,80%); -} - -.id[title="keyword"] { - color : #cf1d1d; -/* color: black; */ -} - -/* Deprecated rules using the 'type' attribute of <span> (not xhtml valid) */ - -.id[type="constructor"] { - color: rgb(60%,0%,0%); -} - -.id[type="var"] { - color: rgb(40%,0%,40%); -} - -.id[type="variable"] { - color: rgb(40%,0%,40%); -} - -.id[type="definition"] { - color: rgb(0%,40%,0%); -} - -.id[type="abbreviation"] { - color: rgb(0%,40%,0%); -} - -.id[type="lemma"] { - color: rgb(0%,40%,0%); -} - -.id[type="instance"] { - color: rgb(0%,40%,0%); -} - -.id[type="projection"] { - color: rgb(0%,40%,0%); -} - -.id[type="method"] { - color: rgb(0%,40%,0%); -} - -.id[type="inductive"] { - color: rgb(0%,0%,80%); -} - -.id[type="record"] { - color: rgb(0%,0%,80%); -} - -.id[type="class"] { - color: rgb(0%,0%,80%); -} - -.id[type="keyword"] { - color : #cf1d1d; -/* color: black; */ -} - -.inlinecode .id { - color: rgb(0%,0%,0%); -} - - -/* TOC */ - -#toc h2 { - padding: 10px; - background-color: rgb(60%,60%,100%); -} - -#toc li { - padding-bottom: 8px; -} - -/* Index */ - -#index { - margin: 0; - padding: 0; - width: 100%; -} - -#index #frontispiece { - margin: 1em auto; - padding: 1em; - width: 60%; -} - -.booktitle { font-size : 140% } -.authors { font-size : 90%; - line-height: 115%; } -.moreauthors { font-size : 60% } - -#index #entrance { - text-align: center; -} - -#index #entrance .spacer { - margin: 0 30px 0 30px; -} - -#index #footer { - position: absolute; - bottom: 0; -} - -.paragraph { - height: 0.75em; -} - -ul.doclist { - margin-top: 0em; - margin-bottom: 0em; -} diff --git a/doc/common/styles/html/coqremote/sites/all/themes/coq/style.css b/doc/common/styles/html/coqremote/sites/all/themes/coq/style.css deleted file mode 100644 index 32c0b33166..0000000000 --- a/doc/common/styles/html/coqremote/sites/all/themes/coq/style.css +++ /dev/null @@ -1,801 +0,0 @@ -body -{ - background: white; - color:#444; - font:normal normal normal small/1.5em "Lucida Grande", Verdana, sans-serif; - margin:0; - padding:0; -} - -h2 -{ - font-size:150%; - font-weight:normal; - margin:20px 0 0; -} - -h3 -{ - font-size:130%; - font-weight:normal; -} - -a:link,a:visited -{ - color:#660403; - font-weight:normal; - text-decoration:none; -} - -a:hover -{ - color: red; - text-decoration:none; -} - -#container -{ - margin: 0; - padding: 0; - } - - /*----------header, logo and site name styles----------*/ - #headertop - { - display: block; - /* position:absolute; */ - min-width: 700px; - top: 0; - width: 100%; - height:30px; - z-index: 1; - background: transparent url('images/header_top.png') repeat-x; - } - - #header - { - min-width: 700px; - width: 100%; height:70px; - position: relative; - left: 0; top: 0; - background: transparent url('images/header_bot.png') repeat-x; - } - - #logo - { - float:left; - z-index: 2; - position: absolute; - top: -15px; - left: 0px; - } - - #logo img - { - border:0; - float:left; - } - - #logoWrapper - { - line-height:4em; - } - - #siteName - { - position: relative; - top: 10px; left: 80px; - color:#fff; - float:left; - font-size:350%; - } - - #siteName a - { - color:#fff; - text-decoration:none; - } - - #siteName a:hover - { - color:#ddd; - text-decoration:none; - } - - #siteSlogan - { - color:#eee; - float:left; - font-size:170%; - margin:50px 0 0 10px; - text-transform:lowercase; - white-space:nowrap; - } - - /*----------nav styles -- primary links in header----------*/ - - #nav -{ - position:absolute; right:0; - margin: 0; - padding: 5px; - } - -#nav ul - { - list-style:none outside none; - list-style-image:none; - margin:0; - padding:0; - } - - #nav li - { - display: inline; - margin: 0; padding: 4px; - } - - #nav li a - { - border:medium none; - color:#ccc; - font-weight:normal; - padding-left:10px; - padding-right:10px; - text-decoration:none; - } - - #nav li a:hover - { - background:#7B0505 none repeat; - border:medium none; - border-left:1px solid #ddd; - border-right:1px solid #ddd; - color:#fff; - padding: 6px 9px 5px 9px; - } - - -/************** FOOTER *******************/ - - -#footer -{ - background:transparent url('images/footer.png') repeat-x; - width:100%; - clear:both; - font-size:85%; - text-align:center; - /* position:fixed; */ - margin: 0; - padding: 0; -} - - -#nav-footer -{ - display: inline; - color:#444; - margin: 0; - padding: 0; - text-align:right; - } - -#nav-footer ul - { - list-style:none outside none; - list-style-image:none; - margin:0; - padding:0px; padding-right: 5px; - } - -#nav-footer li -{ - display:inline; padding: 4px; -} - - #nav-footer li a - { - border:medium none; - color:#ccc; - font-size: 11px; - font-weight:normal; - padding-left: 10px; - padding-right: 10px; - text-decoration:none; - } - - #nav-footer li a:hover - { - background:#7B0505 none repeat; - border:medium none; - border-left:1px solid #ddd; - border-right:1px solid #ddd; - color:#fff; - margin:0; - padding: 3px 9px 0px 9px; - } - - - /*----------main content----------*/ - #content - { - display: block; - position: static; - -/* min-width: 640px; */ - max-width: 800px; - - margin-left:40px; - margin-right:300px; - padding: 2ex 2ex; - - z-index:1; - } - -.content { - display: block; - position: relative; - - margin: 0; - padding: 0; -} - - /*----------sidebar styles----------*/ - #sidebarWrapper - { - /* background:transparent url('images/sidebar_bottom.jpg') no-repeat scroll left bottom;*/ - display:block; - position:fixed; - /* avant : top: 100px; right:0px*/ - top: 15px; /* 180 */ - right:0px; - left: auto; - - margin-right: 0px; - - /* avant - width: 12%; - min-width:80px; */ - - /* width: 18%; */ - /* min-*/ - width:270px; - - z-index:0; - overflow:hidden; - -/* ajout precedent:*/ -/* min-height:320px; - padding:10px; - background-image:url('http://www.lix.polytechnique.fr/Labo/Denis.Cousineau/data/coq/rttr340bis.png'); - background-repeat : repeat-x ;*/ - -/* last ajout */ - /* min-height:510px; */ /* 360 */ - padding-left:0px; - padding-right:0px; - padding-top:105px; /* 40 */ - padding-bottom:/*105px*/115px; - /* background:transparent url('http://www.lix.polytechnique.fr/Labo/Denis.Cousineau/data/coq/trig6b.png') no-repeat scroll left top; */ - background:transparent url('images/sidebarbot.png') no-repeat scroll right bottom; - - } - -#sidebar { - padding-left: 40px; - padding-top: 105px; - overflow: visible; - background:transparent url('images/sidebartop.png') no-repeat scroll right top; -} - -#sidebar .title -{ - /* avant :border-bottom:1px solid #eee;*/ - /* avant : color:#660403;*/ - color:#2D0102; - font-size:120%; - font-weight:bold; - line-height:19px; - margin:10px 0; -} - -/*----------page styles----------*/ -.pageTitle -{ - color:#2D0102; - font-size:220%; - margin:10px 0 20px; -} - -.mission -{ - background-color:#efefef; - border:solid 1px #ccc; - margin:0 0 10px 0; - padding:10px; -} - -.messages -{ - color:#C80000; - font-size:110%; - margin:10px 0; -} - -/*----------node styles----------*/ -.nodeTitle -{ - background: url('images/nodeTitle.gif') no-repeat 0 100%; - color:#9a0000; - font-size: 100%; - margin:0; -} - -.nodeTitle a -{ - color:#660403; - text-decoration:none; -} - -.nodeTitle a:hover -{ - color:#d00000; - text-decoration:none; -} - -.node -{ - margin:0 0 20px; -} - -.content p -{ - margin:10px 0; -} - -.submitted -{ - color:#a3a3a3; - font-size:70%; -} - -.nodeLinks -{ - font-size:95%; - margin:0; - padding:0; -} - -.taxonomy -{ - background:url('icons/tag_red.png') no-repeat 0 7px; - font-size:80%; - padding:0 0 5px 16px; -} - -/*----------comment styles----------*/ -.commentTitle -{ - Border-bottom:1px solid #ddd; - color:#9a0000; - font-size:130%; - margin:20px 0 0; -} - -.commentTitle a -{ - color:#660403; - text-decoration:none; -} - -.commentTitle a:hover -{ - color:#d00000; - text-decoration:none; -} - -.commentLinks -{ - background:#f7f7f7; - border:1px solid #e1e1e1; - color:#444; - font-size:95%; - margin:20px 0 30px; - padding:4px 0 4px 4px; -} - - -/*----------img styles----------*/ -img -{ - padding:3px; -} - -/*----------icons for links----------*/ -.comment_comments a -{ - background:url('icons/comment.png') no-repeat 0 2px; - padding-bottom:5px; - padding-left:20px; -} - -.node_read_more a -{ - background:url('icons/page_white_go.png') no-repeat; - padding-bottom:5px; - padding-left:20px; -} - -.comment_add a,.comment_reply a -{ - background:url('icons/comment_add.png') no-repeat; - padding-bottom:5px; - padding-left:20px; -} -.comment_delete a -{ - background:url('icons/comment_delete.png') no-repeat; - padding-bottom:5px; - padding-left:20px; -} - -.comment_edit a -{ - background:url('icons/comment_edit.png') no-repeat; - padding-bottom:5px; - padding-left:20px; -} - -/*----------TinyMCE editor----------*/ -body.mceContentBody -{ - background:#fff; - color:#000; - font-size:12px; -} - -body.mceContentBody a:link -{ - color:#ff0000; -} - -/*----------table styles----------*/ -table -{ - margin:1em 0; - width:100%; -} - -thead th -{ - border-bottom:2px solid #AAA; - color:#494949; - font-weight:bold; -} - -td,th -{ - padding:.3em 0 .5em; -} - -tr.even,tr.odd,tbody th -{ - border:solid #D5D6D7; - border-width:1px 0; -} - -tr.even -{ - background:#fff; -} - -td.region,td.module,td.container -{ - background:#D5D6D7; - border-bottom:1px solid #AAA; - border-top:1.5em solid #fff; - color:#455067; - font-weight:bold; -} - -tr:first-child td.region,tr:first-child td.module,tr:first-child td.container -{ - border-top-width:0; -} - -td.menu-disabled,td.menu-disabled a -{ - background-color:#D5C2C2; - color:#000; -} - -/*----------other styles----------*/ - -.block -{ - margin:5px 0 20px; -} - -.thumbnail,.preview -{ - border:1px solid #ccc; -} - -.lstlisting { - display: block; - font-family: monospace; - white-space: pre; - margin: 1em 0; -} -.center { - text-align: center; -} -.centered { - display: block-inline; -} - -/*----------download table------------*/ - -table.downloadtable -{ - width:90%; - margin-left:auto; - margin-right:auto; -} - -table.downloadtable td.downloadheader -{ -padding: 2px 1em; -font-weight: bold; -font-size: 120%; -color: white; -background: transparent url('images/header_bot.png') repeat-x; -/*background-color: #660403; */ -border: solid 2px white; -border-left: none; -} - -table.downloadtable td.downloadcategory -{ -padding: 2px 1em; -background-color: #dfbfbe; -text-indent: 0; -} - -table.downloadtable td.downloadsize -{ -text-indent: 0; -white-space: nowrap; -height: 52px; -} - -table.downloadtable td -{ -padding: 2px 1em; -background-color: #dfbfbe; -border-right: solid white 2px; -} - - -table.downloadtable td.downloadtopline -{ -border-top: solid white 2px; -} - -table.downloadtable td.downloadtoprightline -{ -border-top: solid 2px white; -border-right: solid 2px white; -} - -table.downloadtable td.downloadbottomline -{ -border-bottom: solid 2px white; -border-right: solid 2px white; -} - -table.downloadtable td.downloadbottomrightline -{ -border-bottom: solid 2px white; -border-right: solid 2px white; -} - -table.downloadtable td.downloadrightline -{ -border-right: solid 2px white; -} - -table.downloadtable td.downloadback -{ -background-color: #efe4e4; -} - -table.downloadtable td.downloadbottomback -{ -border-bottom: solid 2px white; -background-color: #efe4e4; -} - - -/*********** Normal text style ************/ - -p { - text-indent:3em; -} - -ul { - margin: 0px; - margin-left:4em; - padding: 0px; - list-style-type:square; -} - -li -{ - text-indent: 0px; - margin: 0px; - padding: 0px; -} - -tt { font-size: 1em; } - -pre { font-size: 1em; } - -/*********** Framework ***********/ -.framework -{ - display: block; - position:relative; - border:solid 1px #660033; - margin: 8ex 1em; /* 8ex 8ex 1em 1em; */ - padding: 0; -} - -.frameworkcontent -{ - position:relative; - left:0px; - - - margin: 0; - padding: .5ex 2em; - - text-indent: 2em; - text-align: justify; -} - - -.frameworklabel -{ - display: inline; - position:relative; - top:-1.3ex; - - margin-left:2ex; - padding-top:.4ex; - padding-bottom:.4ex; - padding-right:1ex; - padding-left:1ex; - - border: none; - background: white; - color: black; - - font-weight: bold; - font-size:115%; -} - -.frameworklinks { - display:block; - position:relative; - top:1.4ex; - - margin-right:2ex; - - text-align:right; - font-size:100% - } - -.frameworklinks ul -{ - display: inline; - padding: 0px 1ex; - - border: none; - background: white; -} - - -.frameworklinks li - { - display:inline; - padding: 1ex 0px; - } - - .frameworklinks li a -{ - border:medium none; - - margin: 0px 1ex; - padding-left:2px; - padding-right:3px; - - font-weight:normal; - text-decoration:none; - - color: #660003; -} - - .frameworklinks li a:hover - { - color: red; - - border: none; - } - -/* General flat lists */ -.flatlist li {display: inline} - -/* For sections in bycat.html */ -.bycatsection dt { - text-indent: 3em -} - -.bycatsection dt a -{ - font-weight: bold; - color:#444; -} - -/* footnote is used in the new contribution form */ -.footnote { - text-indent: 0pt; - font-size: 80%; - color: silver; - text-align: justify -} - -/****************** CoqIDE Screenshots *****************/ - - -.SCpager { - position:relative; - top:5px; - width:630px; - background: transparent url('images/header_bot.png') repeat-x; - padding:4px; -} - -.SCpagercontent { - width:390px; - position:relative; - margin-left:auto; - margin-right:auto; -} - -.SCthumb { - height:45px; - margin-left:2px; - margin-right:2px; -} - -.SCthumbselected { - height:55px; - margin-left:2px; - margin-right:2px; -} - -.SCcontent { - position:relative; - top:5px; - width:638px; - background-color: #dfbfbe; -} - -.SCscreenshot { - position:relative; - height:400px; - width:auto; - margin:15px auto 15px 19px; -} @@ -23,19 +23,33 @@ (targets refman-html) (alias refman-html) (package coq-doc) - (deps (alias refman-deps)) + ; Cannot use this deps alias because of ocaml/dune#3415 + ; (deps (alias refman-deps)) + (deps + (package coq) + (source_tree sphinx) + (source_tree tools/coqrst) + unreleased.rst + (env_var SPHINXWARNOPT)) (action - (run env COQLIB=%{project_root} sphinx-build %{env:SPHINXWARNOPT=-W} -b html sphinx %{targets}))) + (run env COQLIB=%{project_root} sphinx-build -q %{env:SPHINXWARNOPT=-W} -b html sphinx %{targets}))) (rule (targets refman-pdf) (alias refman-pdf) (package coq-doc) - (deps (alias refman-deps)) + ; Cannot use this deps alias because of ocaml/dune#3415 + ; (deps (alias refman-deps)) + (deps + (package coq) + (source_tree sphinx) + (source_tree tools/coqrst) + unreleased.rst + (env_var SPHINXWARNOPT)) (action (progn - (run env COQLIB=%{project_root} sphinx-build %{env:SPHINXWARNOPT=-W} -b latex sphinx %{targets}) - (chdir %{targets} (run make))))) + (run env COQLIB=%{project_root} sphinx-build -q %{env:SPHINXWARNOPT=-W} -b latex sphinx %{targets}) + (chdir %{targets} (run make LATEXMKOPTS=-silent))))) ; Installable directories are not yet fully supported by Dune. See ; ocaml/dune#1868. Yet, this makes coq-doc.install a valid target to diff --git a/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg b/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg index 73d94c2a51..8c2090f3be 100644 --- a/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg +++ b/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg @@ -286,8 +286,8 @@ END VERNAC COMMAND EXTEND ExploreProof CLASSIFIED AS QUERY | ![ proof_query ] [ "ExploreProof" ] -> { fun ~pstate -> - let sigma, env = Pfedit.get_current_context pstate in - let pprf = Proof.partial_proof (Proof_global.get_proof pstate) in + let sigma, env = Declare.get_current_context pstate in + let pprf = Proof.partial_proof (Declare.Proof.get_proof pstate) in Feedback.msg_notice (Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf) } diff --git a/doc/plugin_tutorial/tuto1/src/simple_declare.ml b/doc/plugin_tutorial/tuto1/src/simple_declare.ml index 2fdca15552..b94b1fc657 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_declare.ml +++ b/doc/plugin_tutorial/tuto1/src/simple_declare.ml @@ -1,12 +1,6 @@ -let edeclare ?hook ~name ~poly ~scope ~kind ~opaque ~udecl ~impargs sigma body tyopt = - let sigma, ce = DeclareDef.prepare_definition ~allow_evars:false - ~opaque ~poly sigma ~udecl ~types:tyopt ~body in - let uctx = Evd.evar_universe_context sigma in - let ubind = Evd.universe_binders sigma in - let hook_data = Option.map (fun hook -> hook, uctx, []) hook in - DeclareDef.declare_definition ~name ~scope ~kind ~ubind ce ~impargs ?hook_data - let declare_definition ~poly name sigma body = let udecl = UState.default_univ_decl in - edeclare ~name ~poly ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) - ~kind:Decls.(IsDefinition Definition) ~opaque:false ~impargs:[] ~udecl sigma body None + let scope = DeclareDef.Global Declare.ImportDefaultBehavior in + let kind = Decls.(IsDefinition Definition) in + DeclareDef.declare_definition ~name ~scope ~kind ~impargs:[] ~udecl + ~opaque:false ~poly ~types:None ~body sigma diff --git a/doc/sphinx/README.rst b/doc/sphinx/README.rst index 0802b5d0b4..e20469bb8b 100644 --- a/doc/sphinx/README.rst +++ b/doc/sphinx/README.rst @@ -358,6 +358,13 @@ In addition to the objects and directives above, the ``coqrst`` Sphinx plugin de <http://www.sphinx-doc.org/en/stable/markup/para.html#directive-productionlist>`_ and reference its tokens using ``:token:`…```. +``:gdef:`` Marks the definition of a glossary term inline in the text. Matching :term:`XXX` + constructs will link to it. The term will also appear in the Glossary Index. + + Example:: + + A :gdef:`prime` number is divisible only by itself and 1. + Common mistakes =============== diff --git a/doc/sphinx/_static/notations.css b/doc/sphinx/_static/notations.css index 733a73bd21..9546f7107e 100644 --- a/doc/sphinx/_static/notations.css +++ b/doc/sphinx/_static/notations.css @@ -215,6 +215,14 @@ margin-bottom: 0.28em; } +.term-defn { + font-style: italic; +} + +.std-term { + color: #2980B9; /* override if :visited */ +} + /* We can't display nested blocks otherwise */ code, .rst-content tt, .rst-content code { background: transparent !important; diff --git a/doc/sphinx/addendum/implicit-coercions.rst b/doc/sphinx/addendum/implicit-coercions.rst index 1f33775a01..a6dc15da55 100644 --- a/doc/sphinx/addendum/implicit-coercions.rst +++ b/doc/sphinx/addendum/implicit-coercions.rst @@ -37,6 +37,8 @@ In addition to these user-defined classes, we have two built-in classes: * ``Funclass``, the class of functions; its objects are all the terms with a functional type, i.e. of form :g:`forall x:A,B`. +Formally, the syntax of classes is defined as: + .. insertprodn class class .. prodn:: @@ -257,7 +259,7 @@ Activating the Printing of Coercions :name: Printing Coercion Specifies a set of qualids for which coercions are always displayed. Use the - :cmd:`Add @table` and :cmd:`Remove @table` commands to update the set of qualids. + :cmd:`Add` and :cmd:`Remove` commands to update the set of qualids. .. _coercions-classes-as-records: diff --git a/doc/sphinx/addendum/micromega.rst b/doc/sphinx/addendum/micromega.rst index f706633da9..77bf58aac6 100644 --- a/doc/sphinx/addendum/micromega.rst +++ b/doc/sphinx/addendum/micromega.rst @@ -1,4 +1,4 @@ -.. _ micromega: +.. _micromega: Micromega: tactics for solving arithmetic goals over ordered rings ================================================================== diff --git a/doc/sphinx/addendum/omega.rst b/doc/sphinx/addendum/omega.rst index daca43e65e..e1b1ee8e8d 100644 --- a/doc/sphinx/addendum/omega.rst +++ b/doc/sphinx/addendum/omega.rst @@ -1,4 +1,4 @@ -.. _omega: +.. _omega_chapter: Omega: a solver for quantifier-free problems in Presburger Arithmetic ===================================================================== @@ -7,20 +7,18 @@ Omega: a solver for quantifier-free problems in Presburger Arithmetic .. warning:: - The :tacn:`omega` tactic is about to be deprecated in favor of the - :tacn:`lia` tactic. The goal is to consolidate the arithmetic - solving capabilities of Coq into a single engine; moreover, - :tacn:`lia` is in general more powerful than :tacn:`omega` (it is a - complete Presburger arithmetic solver while :tacn:`omega` was known - to be incomplete). - - Work is in progress to make sure that there are no regressions - (including no performance regression) when switching from - :tacn:`omega` to :tacn:`lia` in existing projects. However, we - already recommend using :tacn:`lia` in new or refactored proof - scripts. We also ask that you report (in our `bug tracker - <https://github.com/coq/coq/issues>`_) any issue you encounter, - especially if the issue was not present in :tacn:`omega`. + The :tacn:`omega` tactic is deprecated in favor of the :tacn:`lia` + tactic. The goal is to consolidate the arithmetic solving + capabilities of Coq into a single engine; moreover, :tacn:`lia` is + in general more powerful than :tacn:`omega` (it is a complete + Presburger arithmetic solver while :tacn:`omega` was known to be + incomplete). + + It is recommended to switch from :tacn:`omega` to :tacn:`lia` in existing + projects. We also ask that you report (in our `bug tracker + <https://github.com/coq/coq/issues>`_) any issue you encounter, especially + if the issue was not present in :tacn:`omega`. If no new issues are + reported, :tacn:`omega` will be removed soon. Note that replacing :tacn:`omega` with :tacn:`lia` can break non-robust proof scripts which rely on incompleteness bugs of @@ -30,6 +28,11 @@ Description of ``omega`` ------------------------ .. tacn:: omega + :name: omega + + .. deprecated:: 8.12 + + Use :tacn:`lia` instead. :tacn:`omega` is a tactic for solving goals in Presburger arithmetic, i.e. for proving formulas made of equations and inequalities over the @@ -118,7 +121,7 @@ loaded by .. example:: - .. coqtop:: all + .. coqtop:: all warn Require Import Omega. diff --git a/doc/sphinx/addendum/sprop.rst b/doc/sphinx/addendum/sprop.rst index 9acdd18b89..b19239ed22 100644 --- a/doc/sphinx/addendum/sprop.rst +++ b/doc/sphinx/addendum/sprop.rst @@ -7,27 +7,26 @@ SProp (proof irrelevant propositions) The status of strict propositions is experimental. + In particular, conversion checking through bytecode or native code + compilation currently does not understand proof irrelevance. + This section describes the extension of |Coq| with definitionally proof irrelevant propositions (types in the sort :math:`\SProp`, also known as strict propositions) as described in :cite:`Gilbert:POPL2019`. -Using :math:`\SProp` may be prevented by passing ``-disallow-sprop`` -to the |Coq| program or using :flag:`Allow StrictProp`. +Use of |SProp| may be disabled by passing ``-disallow-sprop`` to the +|Coq| program or by turning the :flag:`Allow StrictProp` flag off. .. flag:: Allow StrictProp :name: Allow StrictProp - Allows using :math:`\SProp` when set and forbids it when unset. The - initial value depends on whether you used the command line - ``-disallow-sprop`` and ``-allow-sprop``. - -.. exn:: SProp not allowed, you need to Set Allow StrictProp or to use the -allow-sprop command-line-flag. - :undocumented: - -.. coqtop:: none + Enables or disables the use of |SProp|. It is enabled by default. + The command-line flag ``-disallow-sprop`` disables |SProp| at + startup. - Set Allow StrictProp. + .. exn:: SProp is disallowed because the "Allow StrictProp" flag is off. + :undocumented: Some of the definitions described in this document are available through ``Coq.Logic.StrictProp``, which see. @@ -38,29 +37,35 @@ Basic constructs The purpose of :math:`\SProp` is to provide types where all elements are convertible: -.. coqdoc:: +.. coqtop:: all - Definition irrelevance (A:SProp) (P:A -> Prop) (x:A) (v:P x) (y:A) : P y := v. + Theorem irrelevance (A : SProp) (P : A -> Prop) : forall x : A, P x -> forall y : A, P y. + Proof. + intros * Hx *. + exact Hx. + Qed. Since we have definitional :ref:`eta-expansion` for functions, the property of being a type of definitionally irrelevant values is impredicative, and so is :math:`\SProp`: -.. coqdoc:: +.. coqtop:: all Check fun (A:Type) (B:A -> SProp) => (forall x:A, B x) : SProp. -.. warning:: - - Conversion checking through bytecode or native code compilation - currently does not understand proof irrelevance. - In order to keep conversion tractable, cumulativity for :math:`\SProp` -is forbidden: +is forbidden, unless the :flag:`Cumulative StrictProp` flag is turned +on: .. coqtop:: all Fail Check (fun (A:SProp) => A : Type). + Set Cumulative StrictProp. + Check (fun (A:SProp) => A : Type). + +.. coqtop:: none + + Unset Cumulative StrictProp. We can explicitly lift strict propositions into the relevant world by using a wrapping inductive type. The inductive stops definitional @@ -240,3 +245,10 @@ so correctly converts ``x`` and ``y``. the kernel when it is passed a term with incorrect relevance marks. To avoid conversion issues as in ``late_mark`` you may wish to use it to find when your tactics are producing incorrect marks. + +.. flag:: Cumulative StrictProp + :name: Cumulative StrictProp + + Set this flag (it is off by default) to make the kernel accept + cumulativity between |SProp| and other universes. This makes + typechecking incomplete. diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index bd4c276571..903aa266e2 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -241,7 +241,7 @@ binders. For example: Definition lt `{eqa : EqDec A, ! Ord eqa} (x y : A) := andb (le x y) (neqb x y). -The ``!`` modifier switches the way a binder is parsed back to the regular +The ``!`` modifier switches the way a binder is parsed back to the usual interpretation of Coq. In particular, it uses the implicit arguments mechanism if available, as shown in the example. @@ -323,7 +323,7 @@ Summary of the commands .. cmdv:: Existing Class @ident - This variant declares a class a posteriori from a constant or + This variant declares a class from a previously declared constant or inductive definition. No methods or instances are defined. .. warn:: @ident is already declared as a typeclass @@ -394,7 +394,7 @@ few other commands related to typeclasses. :name: typeclasses eauto This proof search tactic implements the resolution engine that is run - implicitly during type-checking. This tactic uses a different resolution + implicitly during type checking. This tactic uses a different resolution engine than :tacn:`eauto` and :tacn:`auto`. The main differences are the following: diff --git a/doc/sphinx/addendum/universe-polymorphism.rst b/doc/sphinx/addendum/universe-polymorphism.rst index a08495badd..2958d866ac 100644 --- a/doc/sphinx/addendum/universe-polymorphism.rst +++ b/doc/sphinx/addendum/universe-polymorphism.rst @@ -227,7 +227,7 @@ constraints by prefixing the level names with symbols. Because inductive subtypings are only produced by comparing inductives to themselves with universes changed, they amount to variance information: each universe is either invariant, covariant or -irrelevant (there are no contravariant subtypings in Coq), +irrelevant (there are no contravariant subtypings in |Coq|), respectively represented by the symbols `=`, `+` and `*`. Here we see that :g:`list` binds an irrelevant universe, so any two @@ -426,6 +426,19 @@ mode, introduced universe names can be referred to in terms. Note that local universe names shadow global universe names. During a proof, one can use :cmd:`Show Universes` to display the current context of universes. +It is possible to provide only some universe levels and let |Coq| infer the others +by adding a :g:`+` in the list of bound universe levels: + +.. coqtop:: all + + Fail Definition foobar@{u} : Type@{u} := Type. + Definition foobar@{u +} : Type@{u} := Type. + Set Printing Universes. + Print foobar. + +This can be used to find which universes need to be explicitly bound in a given +definition. + Definitions can also be instantiated explicitly, giving their full instance: diff --git a/doc/sphinx/appendix/indexes/index.rst b/doc/sphinx/appendix/indexes/index.rst index a5032ff822..c8b2cf46dc 100644 --- a/doc/sphinx/appendix/indexes/index.rst +++ b/doc/sphinx/appendix/indexes/index.rst @@ -16,9 +16,12 @@ find what you are looking for. ../../coq-tacindex ../../coq-optindex ../../coq-exnindex + ../../coq-attrindex + ../../std-glossindex For reference, here are direct links to the documentation of: - :ref:`flags, options and tables <flags-options-tables>`; - controlling the display of warning messages with the :opt:`Warnings` - option. + option; +- :ref:`gallina-attributes`. diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index ba1cb741ed..88ca0e63d8 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -55,7 +55,8 @@ __ 811Reals_ Additionally, while the :tacn:`omega` tactic is not yet deprecated in this version of Coq, it should soon be the case and we already recommend users to switch to :tacn:`lia` in new proof scripts (see -also the warning message in the :ref:`corresponding chapter <omega>`). +also the warning message in the :ref:`corresponding chapter +<omega_chapter>`). The ``dev/doc/critical-bugs`` file documents the known critical bugs of |Coq| and affected releases. See the `Changes in 8.11+beta1`_ @@ -326,7 +327,7 @@ Changes in 8.11+beta1 the documentation by Théo Zimmermann and Jim Fehrle). - **Added:** Ltac2 tactic notations with “constr” arguments can specify the - interpretation scope for these arguments; + notation scope for these arguments; see :ref:`ltac2_notations` for details (`#10289 <https://github.com/coq/coq/pull/10289>`_, by Vincent Laporte). @@ -649,6 +650,57 @@ Changes in 8.11.0 (`#11227 <https://github.com/coq/coq/pull/11227>`_, by Bernhard M. Wiedemann). +Changes in 8.11.1 +~~~~~~~~~~~~~~~~~ + +**Kernel** + +- **Fixed:** + Allow more inductive types in `Unset Positivity Checking` mode + (`#11811 <https://github.com/coq/coq/pull/11811>`_, + by SimonBoulier). + +**Notations** + +- **Fixed:** + Bugs in dealing with precedences of notations in custom entries + (`#11530 <https://github.com/coq/coq/pull/11530>`_, + by Hugo Herbelin, fixing in particular + `#9517 <https://github.com/coq/coq/pull/9517>`_, + `#9519 <https://github.com/coq/coq/pull/9519>`_, + `#9521 <https://github.com/coq/coq/pull/9521>`_, + `#11331 <https://github.com/coq/coq/pull/11331>`_). +- **Added:** + In primitive floats, print a warning when parsing a decimal value + that is not exactly a binary64 floating-point number. + For instance, parsing 0.1 will print a warning whereas parsing 0.5 won't. + (`#11859 <https://github.com/coq/coq/pull/11859>`_, + by Pierre Roux). + +**CoqIDE** + +- **Fixed:** + Compiling file paths containing spaces + (`#10008 <https://github.com/coq/coq/pull/10008>`_, + by snyke7, fixing `#11595 <https://github.com/coq/coq/pull/11595>`_). + +**Infrastructure and dependencies** + +- **Added:** + Bump official OCaml support and CI testing to 4.10.0 + (`#11131 <https://github.com/coq/coq/pull/11131>`_, + `#11123 <https://github.com/coq/coq/pull/11123>`_, + `#11102 <https://github.com/coq/coq/pull/11123>`_, + by Emilio Jesus Gallego Arias, Jacques-Henri Jourdan, + Guillaume Melquiond, and Guillaume Munch-Maccagnoni). + +**Miscellaneous** + +- **Fixed:** + :cmd:`Extraction Implicit` on the constructor of a record was leading to an anomaly + (`#11329 <https://github.com/coq/coq/pull/11329>`_, + by Hugo Herbelin, fixes `#11114 <https://github.com/coq/coq/pull/11114>`_). + Version 8.10 ------------ @@ -1513,8 +1565,7 @@ changes: attribute. - Removed deprecated commands ``Arguments Scope`` and ``Implicit - Arguments`` in favor of :cmd:`Arguments (scopes)` and - :cmd:`Arguments`, with the help of Jasper Hugunin. + Arguments`` in favor of :cmd:`Arguments`, with the help of Jasper Hugunin. - New flag :flag:`Uniform Inductive Parameters` by Jasper Hugunin to avoid repeating uniform parameters in constructor declarations. @@ -2352,9 +2403,9 @@ Tactics - Tactic "auto with real" can now discharge comparisons of literals. - The types of variables in patterns of "match" are now - beta-iota-reduced after type-checking. This has an impact on the + beta-iota-reduced after type checking. This has an impact on the type of the variables that the tactic "refine" introduces in the - context, producing types a priori closer to the expectations. + context, producing types that should be closer to the expectations. - In "Tactic Notation" or "TACTIC EXTEND", entry "constr_with_bindings" now uses type classes and rejects terms with unresolved holes, like @@ -3420,7 +3471,7 @@ Tactics native_compute now strictly interpret it as the head of a pattern starting with this reference. -- The "change p with c" tactic semantics changed, now type-checking +- The "change p with c" tactic semantics changed, now type checking "c" at each matching occurrence "t" of the pattern "p", and converting "t" with "c". @@ -4787,7 +4838,7 @@ Type classes - Declaring axiomatic type class instances in Module Type should be now done via new command "Declare Instance", while the syntax "Instance" now always provides a concrete instance, both in and out of Module Type. -- Use [Existing Class foo] to declare foo as a class a posteriori. +- Use [Existing Class foo] to declare a preexisting object [foo] as a class. [foo] can be an inductive type or a constant definition. No projections or instances are defined. - Various bug fixes and improvements: support for defined fields, @@ -4797,7 +4848,7 @@ Type classes Vernacular commands - New command "Timeout <n> <command>." interprets a command and a timeout - interrupts the interpretation after <n> seconds. + interrupts the execution after <n> seconds. - New command "Compute <expr>." is a shortcut for "Eval vm_compute in <expr>". - New command "Fail <command>." interprets a command and is successful iff the command fails on an error (but not an anomaly). Handy for tests and @@ -5982,7 +6033,7 @@ main motivations were syntax. Together with the revision of the concrete syntax, a new mechanism of -*interpretation scopes* permits to reuse the same symbols (typically +, +*notation scopes* permits to reuse the same symbols (typically +, -, \*, /, <, <=) in various mathematical theories without any ambiguities for |Coq|, leading to a largely improved readability of |Coq| scripts. New commands to easily add new symbols are also provided. @@ -6020,7 +6071,7 @@ translator from old to new syntax released with |Coq| is also their work with contributions by Olivier Desmettre. Hugo Herbelin is the main designer and implementer of the notion of -interpretation scopes and of the commands for easily adding new +notation scopes and of the commands for easily adding new notations. Hugo Herbelin is the main implementer of the restructured standard library. @@ -6242,12 +6293,12 @@ Syntax extensions - "Grammar" for terms disappears - "Grammar" for tactics becomes "Tactic Notation" - "Syntax" disappears -- Introduction of a notion of interpretation scope allowing to use the +- Introduction of a notion of notation scope allowing to use the same notations in various contexts without using specific delimiters (e.g the same expression "4<=3+x" is interpreted either in "nat", "positive", "N" (previously "entier"), "Z", "R", depending on which - interpretation scope is currently open) [see documentation for details] -- Notation now mandatorily requires a precedence and associativity + Notation scope is currently open) [see documentation for details] +- Notation now requires a precedence and associativity (default was to set precedence to 1 and associativity to none) Revision of the standard library @@ -6324,7 +6375,7 @@ New syntax with no dependency of t1 and t2 in the arguments of the constructors; this may cause incompatibilities for files translated using coq 8.0beta -Interpretation scopes +Notation scopes - Delimiting key %bool for bool_scope added - Import no more needed to activate argument scopes from a module diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py index 2ed9ec21b3..db1340eacb 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -183,18 +183,9 @@ todo_include_todos = False nitpicky = True nitpick_ignore = [ ('token', token) for token in [ - 'assums', 'binders', 'collection', - 'dirpath', - 'ind_body', 'modpath', - 'module', - 'simple_tactic', - 'symbol', - 'term_pattern', - 'term_pattern_string', - 'toplevel_selector', ]] # -- Options for HTML output ---------------------------------------------- diff --git a/doc/sphinx/coq-attrindex.rst b/doc/sphinx/coq-attrindex.rst new file mode 100644 index 0000000000..f2ace20374 --- /dev/null +++ b/doc/sphinx/coq-attrindex.rst @@ -0,0 +1,5 @@ +:orphan: + +--------------- +Attribute index +--------------- diff --git a/doc/sphinx/coqdoc.css b/doc/sphinx/coqdoc.css deleted file mode 100644 index a325a33842..0000000000 --- a/doc/sphinx/coqdoc.css +++ /dev/null @@ -1,338 +0,0 @@ -/************************************************************************/ -/* * The Coq Proof Assistant / The Coq Development Team */ -/* v * Copyright INRIA, CNRS and contributors */ -/* <O___,, * (see version control and CREDITS file for authors & dates) */ -/* \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) */ -/************************************************************************/ -body { padding: 0px 0px; - margin: 0px 0px; - background-color: white } - -#page { display: block; - padding: 0px; - margin: 0px; - padding-bottom: 10px; } - -#header { display: block; - position: relative; - padding: 0; - margin: 0; - vertical-align: middle; - border-bottom-style: solid; - border-width: thin } - -#header h1 { padding: 0; - margin: 0;} - - -/* Contents */ - -#main{ display: block; - padding: 10px; - font-family: sans-serif; - font-size: 100%; - line-height: 100% } - -#main h1 { line-height: 95% } /* allow for multi-line headers */ - -#main a.idref:visited {color : #416DFF; text-decoration : none; } -#main a.idref:link {color : #416DFF; text-decoration : none; } -#main a.idref:hover {text-decoration : none; } -#main a.idref:active {text-decoration : none; } - -#main a.modref:visited {color : #416DFF; text-decoration : none; } -#main a.modref:link {color : #416DFF; text-decoration : none; } -#main a.modref:hover {text-decoration : none; } -#main a.modref:active {text-decoration : none; } - -#main .keyword { color : #cf1d1d } -#main { color: black } - -.section { background-color: rgb(60%,60%,100%); - padding-top: 13px; - padding-bottom: 13px; - padding-left: 3px; - margin-top: 5px; - margin-bottom: 5px; - font-size : 175% } - -h2.section { background-color: rgb(80%,80%,100%); - padding-left: 3px; - padding-top: 12px; - padding-bottom: 10px; - font-size : 130% } - -h3.section { background-color: rgb(90%,90%,100%); - padding-left: 3px; - padding-top: 7px; - padding-bottom: 7px; - font-size : 115% } - -h4.section { -/* - background-color: rgb(80%,80%,80%); - max-width: 20em; - padding-left: 5px; - padding-top: 5px; - padding-bottom: 5px; -*/ - background-color: white; - padding-left: 0px; - padding-top: 0px; - padding-bottom: 0px; - font-size : 100%; - font-weight : bold; - text-decoration : underline; - } - -#main .doc { margin: 0px; - font-family: sans-serif; - font-size: 100%; - line-height: 125%; - max-width: 40em; - color: black; - padding: 10px; - background-color: #90bdff } - -.inlinecode { - display: inline; -/* font-size: 125%; */ - color: #666666; - font-family: monospace } - -.doc .inlinecode { - display: inline; - font-size: 120%; - color: rgb(30%,30%,70%); - font-family: monospace } - -.doc .inlinecode .id { - color: rgb(30%,30%,70%); -} - -.inlinecodenm { - display: inline; - color: #444444; -} - -.doc .code { - display: inline; - font-size: 120%; - color: rgb(30%,30%,70%); - font-family: monospace } - -.comment { - display: inline; - font-family: monospace; - color: rgb(50%,50%,80%); -} - -.code { - display: block; -/* padding-left: 15px; */ - font-size: 110%; - font-family: monospace; - } - -table.infrule { - border: 0px; - margin-left: 50px; - margin-top: 10px; - margin-bottom: 10px; -} - -td.infrule { - font-family: monospace; - text-align: center; -/* color: rgb(35%,35%,70%); */ - padding: 0px; - line-height: 100%; -} - -tr.infrulemiddle hr { - margin: 1px 0 1px 0; -} - -.infrulenamecol { - color: rgb(60%,60%,60%); - font-size: 80%; - padding-left: 1em; - padding-bottom: 0.1em -} - -/* Pied de page */ - -#footer { font-size: 65%; - font-family: sans-serif; } - -/* Identifiers: <span class="id" title="...">) */ - -.id { display: inline; } - -.id[title="constructor"] { - color: rgb(60%,0%,0%); -} - -.id[title="var"] { - color: rgb(40%,0%,40%); -} - -.id[title="variable"] { - color: rgb(40%,0%,40%); -} - -.id[title="definition"] { - color: rgb(0%,40%,0%); -} - -.id[title="abbreviation"] { - color: rgb(0%,40%,0%); -} - -.id[title="lemma"] { - color: rgb(0%,40%,0%); -} - -.id[title="instance"] { - color: rgb(0%,40%,0%); -} - -.id[title="projection"] { - color: rgb(0%,40%,0%); -} - -.id[title="method"] { - color: rgb(0%,40%,0%); -} - -.id[title="inductive"] { - color: rgb(0%,0%,80%); -} - -.id[title="record"] { - color: rgb(0%,0%,80%); -} - -.id[title="class"] { - color: rgb(0%,0%,80%); -} - -.id[title="keyword"] { - color : #cf1d1d; -/* color: black; */ -} - -/* Deprecated rules using the 'type' attribute of <span> (not xhtml valid) */ - -.id[type="constructor"] { - color: rgb(60%,0%,0%); -} - -.id[type="var"] { - color: rgb(40%,0%,40%); -} - -.id[type="variable"] { - color: rgb(40%,0%,40%); -} - -.id[type="definition"] { - color: rgb(0%,40%,0%); -} - -.id[type="abbreviation"] { - color: rgb(0%,40%,0%); -} - -.id[type="lemma"] { - color: rgb(0%,40%,0%); -} - -.id[type="instance"] { - color: rgb(0%,40%,0%); -} - -.id[type="projection"] { - color: rgb(0%,40%,0%); -} - -.id[type="method"] { - color: rgb(0%,40%,0%); -} - -.id[type="inductive"] { - color: rgb(0%,0%,80%); -} - -.id[type="record"] { - color: rgb(0%,0%,80%); -} - -.id[type="class"] { - color: rgb(0%,0%,80%); -} - -.id[type="keyword"] { - color : #cf1d1d; -/* color: black; */ -} - -.inlinecode .id { - color: rgb(0%,0%,0%); -} - - -/* TOC */ - -#toc h2 { - padding: 10px; - background-color: rgb(60%,60%,100%); -} - -#toc li { - padding-bottom: 8px; -} - -/* Index */ - -#index { - margin: 0; - padding: 0; - width: 100%; -} - -#index #frontispiece { - margin: 1em auto; - padding: 1em; - width: 60%; -} - -.booktitle { font-size : 140% } -.authors { font-size : 90%; - line-height: 115%; } -.moreauthors { font-size : 60% } - -#index #entrance { - text-align: center; -} - -#index #entrance .spacer { - margin: 0 30px 0 30px; -} - -#index #footer { - position: absolute; - bottom: 0; -} - -.paragraph { - height: 0.75em; -} - -ul.doclist { - margin-top: 0em; - margin-bottom: 0em; -} diff --git a/doc/sphinx/history.rst b/doc/sphinx/history.rst index 153dc1f368..02821613cc 100644 --- a/doc/sphinx/history.rst +++ b/doc/sphinx/history.rst @@ -210,7 +210,7 @@ definitions of “inversion predicates”. Version 1 ~~~~~~~~~ -This software is a prototype type-checker for a higher-order logical +This software is a prototype type checker for a higher-order logical formalism known as the Theory of Constructions, presented in his PhD thesis by Thierry Coquand, with influences from Girard's system F and de Bruijn's Automath. The metamathematical analysis of the system is @@ -409,7 +409,7 @@ synthesized with the help of tactics, it was entirely re-checked by the engine. Thus there was no need to certify the tactics, and the system took advantage of this fact by having tactics ignore the universe levels, universe consistency check being relegated to the -final type-checking pass. This induced a certain puzzlement in early +final type checking pass. This induced a certain puzzlement in early users who saw, after a successful proof search, their ``QED`` followed by silence, followed by a failure message due to a universe inconsistency… @@ -1396,7 +1396,7 @@ Tactics Extraction (See details in plugins/extraction/CHANGES and README): - An experimental Scheme extraction is provided. -- Concerning Ocaml, extracted code is now ensured to always type-check, +- Concerning OCaml, extracted code is now ensured to always type check, thanks to automatic inserting of Obj.magic. - Experimental extraction of Coq new modules to Ocaml modules. diff --git a/doc/sphinx/language/core/index.rst b/doc/sphinx/language/core/index.rst index 07dcfff444..5ee960d99b 100644 --- a/doc/sphinx/language/core/index.rst +++ b/doc/sphinx/language/core/index.rst @@ -32,6 +32,8 @@ will have to check their output. ../gallina-specification-language ../cic + records ../../addendum/universe-polymorphism ../../addendum/sprop + sections ../module-system diff --git a/doc/sphinx/language/core/records.rst b/doc/sphinx/language/core/records.rst new file mode 100644 index 0000000000..928378f55e --- /dev/null +++ b/doc/sphinx/language/core/records.rst @@ -0,0 +1,312 @@ +.. _record-types: + +Record types +---------------- + +The :cmd:`Record` construction is a macro allowing the definition of +records as is done in many programming languages. Its syntax is +described in the grammar below. In fact, the :cmd:`Record` macro is more general +than the usual record types, since it allows also for “manifest” +expressions. In this sense, the :cmd:`Record` construction allows defining +“signatures”. + +.. _record_grammar: + +.. cmd:: {| Record | Structure } @record_definition {* with @record_definition } + :name: Record; Structure + + .. insertprodn record_definition field_body + + .. prodn:: + record_definition ::= {? > } @ident_decl {* @binder } {? : @type } {? @ident } %{ {*; @record_field } %} {? @decl_notations } + record_field ::= {* #[ {*, @attr } ] } @name {? @field_body } {? %| @num } {? @decl_notations } + field_body ::= {* @binder } @of_type + | {* @binder } @of_type := @term + | {* @binder } := @term + + Each :n:`@record_definition` defines a record named by :n:`@ident_decl`. + The constructor name is given by :n:`@ident`. + If the constructor name is not specified, then the default name :n:`Build_@ident` is used, + where :n:`@ident` is the record name. + + If :n:`@type` is + omitted, the default type is :math:`\Type`. The identifiers inside the brackets are the field names. + The type of each field :n:`@ident` is :n:`forall {* @binder }, @type`. + Notice that the type of an identifier can depend on a previously-given identifier. Thus the + order of the fields is important. :n:`@binder` parameters may be applied to the record as a whole + or to individual fields. + + Notations can be attached to fields using the :n:`@decl_notations` annotation. + + :cmd:`Record` and :cmd:`Structure` are synonyms. + + This command supports the :attr:`universes(polymorphic)`, + :attr:`universes(monomorphic)`, :attr:`universes(template)`, + :attr:`universes(notemplate)`, :attr:`universes(cumulative)`, + :attr:`universes(noncumulative)` and :attr:`private(matching)` + attributes. + +More generally, a record may have explicitly defined (a.k.a. manifest) +fields. For instance, we might have: +:n:`Record @ident {* @binder } : @sort := { @ident__1 : @type__1 ; @ident__2 := @term__2 ; @ident__3 : @type__3 }`. +in which case the correctness of :n:`@type__3` may rely on the instance :n:`@term__2` of :n:`@ident__2` and :n:`@term__2` may in turn depend on :n:`@ident__1`. + +.. example:: + + The set of rational numbers may be defined as: + + .. coqtop:: reset all + + Record Rat : Set := mkRat + { sign : bool + ; top : nat + ; bottom : nat + ; Rat_bottom_cond : 0 <> bottom + ; Rat_irred_cond : + forall x y z:nat, (x * y) = top /\ (x * z) = bottom -> x = 1 + }. + + Note here that the fields ``Rat_bottom_cond`` depends on the field ``bottom`` + and ``Rat_irred_cond`` depends on both ``top`` and ``bottom``. + +Let us now see the work done by the ``Record`` macro. First the macro +generates a variant type definition with just one constructor: +:n:`Variant @ident {* @binder } : @sort := @ident__0 {* @binder }`. + +To build an object of type :token:`ident`, one should provide the constructor +:n:`@ident__0` with the appropriate number of terms filling the fields of the record. + +.. example:: + + Let us define the rational :math:`1/2`: + + .. coqtop:: in + + Theorem one_two_irred : forall x y z:nat, x * y = 1 /\ x * z = 2 -> x = 1. + Admitted. + + Definition half := mkRat true 1 2 (O_S 1) one_two_irred. + Check half. + +Alternatively, the following syntax allows creating objects by using named fields, as +shown in this grammar. The fields do not have to be in any particular order, nor do they have +to be all present if the missing ones can be inferred or prompted for +(see :ref:`programs`). + +.. coqtop:: all + + Definition half' := + {| sign := true; + Rat_bottom_cond := O_S 1; + Rat_irred_cond := one_two_irred |}. + +The following settings let you control the display format for types: + +.. flag:: Printing Records + + If set, use the record syntax (shown above) as the default display format. + +You can override the display format for specified types by adding entries to these tables: + +.. table:: Printing Record @qualid + :name: Printing Record + + Specifies a set of qualids which are displayed as records. Use the + :cmd:`Add` and :cmd:`Remove` commands to update the set of qualids. + +.. table:: Printing Constructor @qualid + :name: Printing Constructor + + Specifies a set of qualids which are displayed as constructors. Use the + :cmd:`Add` and :cmd:`Remove` commands to update the set of qualids. + +This syntax can also be used for pattern matching. + +.. coqtop:: all + + Eval compute in ( + match half with + | {| sign := true; top := n |} => n + | _ => 0 + end). + +The macro generates also, when it is possible, the projection +functions for destructuring an object of type :token:`ident`. These +projection functions are given the names of the corresponding +fields. If a field is named `_` then no projection is built +for it. In our example: + +.. coqtop:: all + + Eval compute in top half. + Eval compute in bottom half. + Eval compute in Rat_bottom_cond half. + +An alternative syntax for projections based on a dot notation is +available: + +.. coqtop:: all + + Eval compute in half.(top). + +.. flag:: Printing Projections + + This flag activates the dot notation for printing. + + .. example:: + + .. coqtop:: all + + Set Printing Projections. + Check top half. + +.. FIXME: move this to the main grammar in the spec chapter + +.. _record_projections_grammar: + + .. insertprodn term_projection term_projection + + .. prodn:: + term_projection ::= @term0 .( @qualid {* @arg } ) + | @term0 .( @ @qualid {* @term1 } ) + + Syntax of Record projections + +The corresponding grammar rules are given in the preceding grammar. When :token:`qualid` +denotes a projection, the syntax :n:`@term0.(@qualid)` is equivalent to :n:`@qualid @term0`, +the syntax :n:`@term0.(@qualid {+ @arg })` to :n:`@qualid {+ @arg } @term0`. +and the syntax :n:`@term0.(@@qualid {+ @term0 })` to :n:`@@qualid {+ @term0 } @term0`. +In each case, :token:`term0` is the object projected and the +other arguments are the parameters of the inductive type. + + +.. note:: Records defined with the ``Record`` keyword are not allowed to be + recursive (references to the record's name in the type of its field + raises an error). To define recursive records, one can use the ``Inductive`` + and ``CoInductive`` keywords, resulting in an inductive or co-inductive record. + Definition of mutually inductive or co-inductive records are also allowed, as long + as all of the types in the block are records. + +.. note:: Induction schemes are automatically generated for inductive records. + Automatic generation of induction schemes for non-recursive records + defined with the ``Record`` keyword can be activated with the + :flag:`Nonrecursive Elimination Schemes` flag (see :ref:`proofschemes-induction-principles`). + +.. warn:: @ident cannot be defined. + + It can happen that the definition of a projection is impossible. + This message is followed by an explanation of this impossibility. + There may be three reasons: + + #. The name :token:`ident` already exists in the environment (see :cmd:`Axiom`). + #. The body of :token:`ident` uses an incorrect elimination for + :token:`ident` (see :cmd:`Fixpoint` and :ref:`Destructors`). + #. The type of the projections :token:`ident` depends on previous + projections which themselves could not be defined. + +.. exn:: Records declared with the keyword Record or Structure cannot be recursive. + + The record name :token:`ident` appears in the type of its fields, but uses + the keyword ``Record``. Use the keyword ``Inductive`` or ``CoInductive`` instead. + +.. exn:: Cannot handle mutually (co)inductive records. + + Records cannot be defined as part of mutually inductive (or + co-inductive) definitions, whether with records only or mixed with + standard definitions. + +During the definition of the one-constructor inductive definition, all +the errors of inductive definitions, as described in Section +:ref:`gallina-inductive-definitions`, may also occur. + +.. seealso:: Coercions and records in section :ref:`coercions-classes-as-records` of the chapter devoted to coercions. + +.. _primitive_projections: + +Primitive Projections +~~~~~~~~~~~~~~~~~~~~~ + +.. flag:: Primitive Projections + + Turns on the use of primitive + projections when defining subsequent records (even through the ``Inductive`` + and ``CoInductive`` commands). 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 + 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 + for the usual defined ones, although there are a few notable differences. + +.. flag:: Printing Primitive Projection Parameters + + This compatibility flag reconstructs internally omitted parameters at + printing time (even though they are absent in the actual AST manipulated + by the kernel). + +Primitive Record Types +++++++++++++++++++++++ + +When the :flag:`Primitive Projections` flag is on, definitions of +record types change meaning. When a type is declared with primitive +projections, its :g:`match` construct is disabled (see :ref:`primitive_projections` though). +To eliminate the (co-)inductive type, one must use its defined primitive projections. + +.. The following paragraph is quite redundant with what is above + +For compatibility, the parameters still appear to the user when +printing terms even though they are absent in the actual AST +manipulated by the kernel. This can be changed by unsetting the +:flag:`Printing Primitive Projection Parameters` flag. + +There are currently two ways to introduce primitive records types: + +#. Through the ``Record`` command, in which case the type has to be + non-recursive. The defined type enjoys eta-conversion definitionally, + that is the generalized form of surjective pairing for records: + `r` ``= Build_``\ `R` ``(``\ `r`\ ``.(``\ |p_1|\ ``) …`` `r`\ ``.(``\ |p_n|\ ``))``. + Eta-conversion allows to define dependent elimination for these types as well. +#. Through the ``Inductive`` and ``CoInductive`` commands, when + the body of the definition is a record declaration of the form + ``Build_``\ `R` ``{`` |p_1| ``:`` |t_1|\ ``; … ;`` |p_n| ``:`` |t_n| ``}``. + In this case the types can be recursive and eta-conversion is disallowed. These kind of record types + differ from their traditional versions in the sense that dependent + elimination is not available for them and only non-dependent case analysis + can be defined. + +Reduction ++++++++++ + +The basic reduction rule of a primitive projection is +|p_i| ``(Build_``\ `R` |t_1| … |t_n|\ ``)`` :math:`{\rightarrow_{\iota}}` |t_i|. +However, to take the :math:`{\delta}` flag into +account, projections can be in two states: folded or unfolded. An +unfolded primitive projection application obeys the rule above, while +the folded version delta-reduces to the unfolded version. This allows to +precisely mimic the usual unfolding rules of constants. Projections +obey the usual ``simpl`` flags of the ``Arguments`` command in particular. +There is currently no way to input unfolded primitive projections at the +user-level, and there is no way to display unfolded projections differently +from folded ones. + + +Compatibility Projections and :g:`match` +++++++++++++++++++++++++++++++++++++++++ + +To ease compatibility with ordinary record types, each primitive +projection is also defined as a ordinary constant taking parameters and +an object of the record type as arguments, and whose body is an +application of the unfolded primitive projection of the same name. These +constants are used when elaborating partial applications of the +projection. One can distinguish them from applications of the primitive +projection if the :flag:`Printing Primitive Projection Parameters` flag +is off: For a primitive projection application, parameters are printed +as underscores while for the compatibility projections they are printed +as usual. + +Additionally, user-written :g:`match` constructs on primitive records +are desugared into substitution of the projections, they cannot be +printed back as :g:`match` constructs. diff --git a/doc/sphinx/language/core/sections.rst b/doc/sphinx/language/core/sections.rst new file mode 100644 index 0000000000..df50dbafe3 --- /dev/null +++ b/doc/sphinx/language/core/sections.rst @@ -0,0 +1,104 @@ +.. _section-mechanism: + +Section mechanism +----------------- + +Sections create local contexts which can be shared across multiple definitions. + +.. example:: + + Sections are opened by the :cmd:`Section` command, and closed by :cmd:`End`. + + .. coqtop:: all + + Section s1. + + Inside a section, local parameters can be introduced using :cmd:`Variable`, + :cmd:`Hypothesis`, or :cmd:`Context` (there are also plural variants for + the first two). + + .. coqtop:: all + + Variables x y : nat. + + The command :cmd:`Let` introduces section-wide :ref:`let-in`. These definitions + won't persist when the section is closed, and all persistent definitions which + depend on `y'` will be prefixed with `let y' := y in`. + + .. coqtop:: in + + Let y' := y. + Definition x' := S x. + Definition x'' := x' + y'. + + .. coqtop:: all + + Print x'. + Print x''. + + End s1. + + Print x'. + Print x''. + + Notice the difference between the value of :g:`x'` and :g:`x''` inside section + :g:`s1` and outside. + +.. cmd:: Section @ident + + This command is used to open a section named :token:`ident`. + Section names do not need to be unique. + + +.. cmd:: End @ident + + This command closes the section or module named :token:`ident`. + See :ref:`Terminating an interactive module or module type definition<terminating_module>` + for a description of its use with modules. + + After closing the + section, the local declarations (variables and local definitions, see :cmd:`Variable`) are + *discharged*, meaning that they stop being visible and that all global + objects defined in the section are generalized with respect to the + variables and local definitions they each depended on in the section. + + .. exn:: There is nothing to end. + :undocumented: + + .. exn:: Last block to end has name @ident. + :undocumented: + +.. note:: + Most commands, like :cmd:`Hint`, :cmd:`Notation`, option management, … which + appear inside a section are canceled when the section is closed. + +.. cmd:: Let @ident_decl @def_body + Let Fixpoint @fix_definition {* with @fix_definition } + Let CoFixpoint @cofix_definition {* with @cofix_definition } + :name: Let; Let Fixpoint; Let CoFixpoint + + These commands behave like :cmd:`Definition`, :cmd:`Fixpoint` and :cmd:`CoFixpoint`, except that + the declared constant is local to the current section. + When the section is closed, all persistent + definitions and theorems within it that depend on the constant + will be wrapped with a :n:`@term_let` with the same declaration. + + As for :cmd:`Definition`, :cmd:`Fixpoint` and :cmd:`CoFixpoint`, + if :n:`@term` is omitted, :n:`@type` is required and Coq enters proof editing mode. + This can be used to define a term incrementally, in particular by relying on the :tacn:`refine` tactic. + In this case, the proof should be terminated with :cmd:`Defined` in order to define a constant + for which the computational behavior is relevant. See :ref:`proof-editing-mode`. + +.. cmd:: Context {+ @binder } + + Declare variables in the context of the current section, like :cmd:`Variable`, + but also allowing implicit variables, :ref:`implicit-generalization`, and + let-binders. + + .. coqdoc:: + + Context {A : Type} (a b : A). + Context `{EqDec A}. + Context (b' := b). + +.. seealso:: Section :ref:`binders`. Section :ref:`contexts` in chapter :ref:`typeclasses`. diff --git a/doc/sphinx/language/extensions/arguments-command.rst b/doc/sphinx/language/extensions/arguments-command.rst new file mode 100644 index 0000000000..34a48b368b --- /dev/null +++ b/doc/sphinx/language/extensions/arguments-command.rst @@ -0,0 +1,440 @@ +.. _ArgumentsCommand: + +Setting properties of a function's arguments +++++++++++++++++++++++++++++++++++++++++++++ + +.. cmd:: Arguments @smart_qualid {* @arg_specs } {* , {* @implicits_alt } } {? : {+, @args_modifier } } + :name: Arguments + + .. insertprodn smart_qualid args_modifier + + .. prodn:: + smart_qualid ::= @qualid + | @by_notation + by_notation ::= @string {? % @scope_key } + argument_spec ::= {? ! } @name {? % @scope_key } + arg_specs ::= @argument_spec + | / + | & + | ( {+ @argument_spec } ) {? % @scope_key } + | [ {+ @argument_spec } ] {? % @scope_key } + | %{ {+ @argument_spec } %} {? % @scope_key } + implicits_alt ::= @name + | [ {+ @name } ] + | %{ {+ @name } %} + args_modifier ::= simpl nomatch + | simpl never + | default implicits + | clear implicits + | clear scopes + | clear bidirectionality hint + | rename + | assert + | extra scopes + | clear scopes and implicits + | clear implicits and scopes + + Specifies properties of the arguments of a function after the function has already + been defined. It gives fine-grained + control over the elaboration process (i.e. the translation of Gallina language + extensions into the core language used by the kernel). The command's effects include: + + * Making arguments implicit. Afterward, implicit arguments + must be omitted in any expression that applies :token:`smart_qualid`. + * Declaring that some arguments of a given function should + be interpreted in a given scope. + * Affecting when the :tacn:`simpl` and :tacn:`cbn` tactics unfold the function. + See :ref:`Args_effect_on_unfolding`. + * Providing bidirectionality hints. See :ref:`bidirectionality_hints`. + + This command supports the :attr:`local` and :attr:`global` attributes. + Default behavior is to limit the effect to the current section but also to + extend their effect outside the current module or library file. + Applying :attr:`local` limits the effect of the command to the current module if + it's not in a section. Applying :attr:`global` within a section extends the + effect outside the current sections and current module in which the command appears. + + `/` + the function will be unfolded only if it's applied to at least the + arguments appearing before the `/`. See :ref:`Args_effect_on_unfolding`. + + .. exn:: The / modifier may only occur once. + :undocumented: + + `&` + tells the type checking algorithm to first type check the arguments + before the `&` and then to propagate information from that typing context + to type check the remaining arguments. See :ref:`bidirectionality_hints`. + + .. exn:: The & modifier may only occur once. + :undocumented: + + :n:`( ... ) {? % @scope }` + :n:`(@name__1 @name__2 ...)%@scope` is shorthand for :n:`@name__1%@scope @name__2%@scope ...` + + :n:`[ ... ] {? % @scope }` + declares the enclosed names as implicit, non-maximally inserted. + :n:`[@name__1 @name__2 ... ]%@scope` is equivalent to :n:`[@name__1]%@scope [@name__2]%@scope ...` + + :n:`%{ ... %} {? % @scope }` + declares the enclosed names as implicit, maximally inserted. + :n:`%{@name__1 @name__2 ... %}%@scope` is equivalent to :n:`%{@name__1%}%@scope %{@name__2%}%@scope ...` + + `!` + the function will be unfolded only if all the arguments marked with `!` + evaulate to constructors. See :ref:`Args_effect_on_unfolding`. + + :n:`@name {? % @scope }` + a *formal parameter* of the function :n:`@smart_qualid` (i.e. + the parameter name used in the function definition). Unless `rename` is specified, + the list of :n:`@name`\s must be a prefix of the formal parameters, including all implicit + arguments. `_` can be used to skip over a formal parameter. + :token:`scope` can be either a scope name or its delimiting key. See :ref:`binding_to_scope`. + + `clear implicits` + makes all implicit arguments into explicit arguments + `default implicits` + automatically determine the implicit arguments of the object. + See :ref:`auto_decl_implicit_args`. + `rename` + rename implicit arguments for the object. See the example :ref:`here <renaming_implicit_arguments>`. + `assert` + assert that the object has the expected number of arguments with the + expected names. See the example here: :ref:`renaming_implicit_arguments`. + + .. warn:: This command is just asserting the names of arguments of @qualid. If this is what you want, add ': assert' to silence the warning. If you want to clear implicit arguments, add ': clear implicits'. If you want to clear notation scopes, add ': clear scopes' + :undocumented: + + `clear scopes` + clears argument scopes of :n:`@smart_qualid` + `extra scopes` + defines extra argument scopes, to be used in case of coercion to ``Funclass`` + (see the :ref:`implicitcoercions` chapter) or with a computed type. + `simpl nomatch` + prevents performing a simplification step for :n:`@smart_qualid` + that would expose a match construct in the head position. See :ref:`Args_effect_on_unfolding`. + `simpl never` + prevents performing a simplification step for :n:`@smart_qualid`. See :ref:`Args_effect_on_unfolding`. + + `clear bidirectionality hint` + removes the bidirectionality hint, the `&` + + :n:`@implicits_alt` + use to specify alternative implicit argument declarations + for functions that can only be + applied to a fixed number of arguments (excluding, for instance, + functions whose type is polymorphic). + For parsing, the longest list of implicit arguments matching the function application + is used to select which implicit arguments are inserted. + For printing, the alternative with the most implicit arguments is used; the + implict arguments will be omitted if :flag:`Printing Implicit` is not set. + See the example :ref:`here<example_more_implicits>`. + + .. todo the above feature seems a bit unnatural and doesn't play well with partial + application. See https://github.com/coq/coq/pull/11718#discussion_r408841762 + + Use :cmd:`About` to view the current implicit arguments setting for a :token:`smart_qualid`. + + Or use the :cmd:`Print Implicit` command to see the implicit arguments + of an object (see :ref:`displaying-implicit-args`). + +Manual declaration of implicit arguments +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +.. example:: + + .. coqtop:: reset all + + Inductive list (A : Type) : Type := + | nil : list A + | cons : A -> list A -> list A. + + Check (cons nat 3 (nil nat)). + + Arguments cons [A] _ _. + + Arguments nil {A}. + + Check (cons 3 nil). + + Fixpoint map (A B : Type) (f : A -> B) (l : list A) : list B := + match l with nil => nil | cons a t => cons (f a) (map A B f t) end. + + Fixpoint length (A : Type) (l : list A) : nat := + match l with nil => 0 | cons _ m => S (length A m) end. + + Arguments map [A B] f l. + + Arguments length {A} l. (* A has to be maximally inserted *) + + Check (fun l:list (list nat) => map length l). + +.. _example_more_implicits: + +.. example:: Multiple alternatives with :n:`@implicits_alt` + + .. coqtop:: all + + Arguments map [A B] f l, [A] B f l, A B f l. + + Check (fun l => map length l = map (list nat) nat length l). + +.. _auto_decl_implicit_args: + +Automatic declaration of implicit arguments +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + The ":n:`default implicits`" :token:`args_modifier` clause tells |Coq| to automatically determine the + implicit arguments of the object. + + Auto-detection is governed by flags specifying whether strict, + contextual, or reversible-pattern implicit arguments must be + considered or not (see :ref:`controlling-strict-implicit-args`, :ref:`controlling-contextual-implicit-args`, + :ref:`controlling-rev-pattern-implicit-args` and also :ref:`controlling-insertion-implicit-args`). + +.. example:: Default implicits + + .. coqtop:: reset all + + Inductive list (A:Set) : Set := + | nil : list A + | cons : A -> list A -> list A. + + Arguments cons : default implicits. + + Print Implicit cons. + + Arguments nil : default implicits. + + Print Implicit nil. + + Set Contextual Implicit. + + Arguments nil : default implicits. + + Print Implicit nil. + +The computation of implicit arguments takes account of the unfolding +of constants. For instance, the variable ``p`` below has type +``(Transitivity R)`` which is reducible to +``forall x,y:U, R x y -> forall z:U, R y z -> R x z``. As the variables ``x``, ``y`` and ``z`` +appear strictly in the body of the type, they are implicit. + +.. coqtop:: all + + Parameter X : Type. + + Definition Relation := X -> X -> Prop. + + Definition Transitivity (R:Relation) := forall x y:X, R x y -> forall z:X, R y z -> R x z. + + Parameters (R : Relation) (p : Transitivity R). + + Arguments p : default implicits. + + Print p. + + Print Implicit p. + + Parameters (a b c : X) (r1 : R a b) (r2 : R b c). + + Check (p r1 r2). + + +.. _renaming_implicit_arguments: + +Renaming implicit arguments +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +.. example:: (continued) Renaming implicit arguments + + .. coqtop:: all + + Arguments p [s t] _ [u] _: rename. + + Check (p r1 (u:=c)). + + Check (p (s:=a) (t:=b) r1 (u:=c) r2). + + Fail Arguments p [s t] _ [w] _ : assert. + +.. _binding_to_scope: + +Binding arguments to a scope +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + The following command declares that the first two arguments of :g:`plus_fct` + are in the :token:`scope` delimited by the key ``F`` (``Rfun_scope``) and the third + argument is in the scope delimited by the key ``R`` (``R_scope``). + + .. coqdoc:: + + Arguments plus_fct (f1 f2)%F x%R. + + When interpreting a term, if some of the arguments of :token:`smart_qualid` are built + from a notation, then this notation is interpreted in the scope stack + extended by the scope bound (if any) to this argument. The effect of + the scope is limited to the argument itself. It does not propagate to + subterms but the subterms that, after interpretation of the notation, + turn to be themselves arguments of a reference are interpreted + accordingly to the argument scopes bound to this reference. + +.. note:: + + In notations, the subterms matching the identifiers of the + notations are interpreted in the scope in which the identifiers + occurred at the time of the declaration of the notation. Here is an + example: + + .. coqtop:: all + + Parameter g : bool -> bool. + Declare Scope mybool_scope. + + Notation "@@" := true (only parsing) : bool_scope. + Notation "@@" := false (only parsing): mybool_scope. + + Bind Scope bool_scope with bool. + Notation "# x #" := (g x) (at level 40). + Check # @@ #. + Arguments g _%mybool_scope. + Check # @@ #. + Delimit Scope mybool_scope with mybool. + Check # @@%mybool #. + +.. _Args_effect_on_unfolding: + +Effects of :cmd:`Arguments` on unfolding +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ++ `simpl never` indicates that a constant should never be unfolded by :tacn:`cbn`, + :tacn:`simpl` or :tacn:`hnf`: + + .. example:: + + .. coqtop:: all + + Arguments minus n m : simpl never. + + After that command an expression like :g:`(minus (S x) y)` is left + untouched by the tactics :tacn:`cbn` and :tacn:`simpl`. + ++ A constant can be marked to be unfolded only if it's applied to at least + the arguments appearing before the `/` in a :cmd:`Arguments` command. + + .. example:: + + .. coqtop:: all + + Definition fcomp A B C f (g : A -> B) (x : A) : C := f (g x). + Arguments fcomp {A B C} f g x /. + Notation "f \o g" := (fcomp f g) (at level 50). + + After that command the expression :g:`(f \o g)` is left untouched by + :tacn:`simpl` while :g:`((f \o g) t)` is reduced to :g:`(f (g t))`. + The same mechanism can be used to make a constant volatile, i.e. + always unfolded. + + .. example:: + + .. coqtop:: all + + Definition volatile := fun x : nat => x. + Arguments volatile / x. + ++ A constant can be marked to be unfolded only if an entire set of + arguments evaluates to a constructor. The ``!`` symbol can be used to mark + such arguments. + + .. example:: + + .. coqtop:: all + + Arguments minus !n !m. + + After that command, the expression :g:`(minus (S x) y)` is left untouched + by :tacn:`simpl`, while :g:`(minus (S x) (S y))` is reduced to :g:`(minus x y)`. + ++ `simpl nomatch` indicates that a constant should not be unfolded if it would expose + a `match` construct in the head position. This affects the :tacn:`cbn`, + :tacn:`simpl` and :tacn:`hnf` tactics. + + .. example:: + + .. coqtop:: all + + Arguments minus n m : simpl nomatch. + + In this case, :g:`(minus (S (S x)) (S y))` is simplified to :g:`(minus (S x) y)` + even if an extra simplification is possible. + + In detail: the tactic :tacn:`simpl` first applies :math:`\beta`:math:`\iota`-reduction. Then, it + expands transparent constants and tries to reduce further using :math:`\beta`:math:`\iota`-reduction. + But, when no :math:`\iota` rule is applied after unfolding then + :math:`\delta`-reductions are not applied. For instance trying to use :tacn:`simpl` on + :g:`(plus n O) = n` changes nothing. + + +.. _bidirectionality_hints: + +Bidirectionality hints +~~~~~~~~~~~~~~~~~~~~~~ + +When type-checking an application, Coq normally does not use information from +the context to infer the types of the arguments. It only checks after the fact +that the type inferred for the application is coherent with the expected type. +Bidirectionality hints make it possible to specify that after type-checking the +first arguments of an application, typing information should be propagated from +the context to help inferring the types of the remaining arguments. + +.. todo the following text is a start on better wording but not quite complete. + See https://github.com/coq/coq/pull/11718#discussion_r410219992 + + .. + Two common methods to determine the type of a construct are: + + * *type checking*, which is verifying that a construct matches a known type, and + * *type inference*, with is inferring the type of a construct by analyzing the construct. + + Methods that combine these approaches are known as *bidirectional typing*. + Coq normally uses only the first approach to infer the types of arguments, + then later verifies that the inferred type is consistent with the expected type. + *Bidirectionality hints* specify to use both methods: after type checking the + first arguments of an application (appearing before the `&` in :cmd:`Arguments`), + typing information from them is propagated to the remaining arguments to help infer their types. + +An :cmd:`Arguments` command containing :n:`@arg_specs__1 & @arg_specs__2` +provides bidirectionality hints. +It tells the typechecking algorithm, when type checking +applications of :n:`@qualid`, to first type check the arguments in +:n:`@arg_specs__1` and then propagate information from the typing context to +type check the remaining arguments (in :n:`@arg_specs__2`). + +.. example:: Bidirectionality hints + + In a context where a coercion was declared from ``bool`` to ``nat``: + + .. coqtop:: in reset + + Definition b2n (b : bool) := if b then 1 else 0. + Coercion b2n : bool >-> nat. + + Coq cannot automatically coerce existential statements over ``bool`` to + statements over ``nat``, because the need for inserting a coercion is known + only from the expected type of a subterm: + + .. coqtop:: all + + Fail Check (ex_intro _ true _ : exists n : nat, n > 0). + + However, a suitable bidirectionality hint makes the example work: + + .. coqtop:: all + + Arguments ex_intro _ _ & _ _. + Check (ex_intro _ true _ : exists n : nat, n > 0). + +Coq will attempt to produce a term which uses the arguments you +provided, but in some cases involving Program mode the arguments after +the bidirectionality starts may be replaced by convertible but +syntactically different terms. diff --git a/doc/sphinx/language/extensions/implicit-arguments.rst b/doc/sphinx/language/extensions/implicit-arguments.rst new file mode 100644 index 0000000000..d93dc00e24 --- /dev/null +++ b/doc/sphinx/language/extensions/implicit-arguments.rst @@ -0,0 +1,703 @@ +.. _ImplicitArguments: + +Implicit arguments +------------------ + +An implicit argument of a function is an argument which can be +inferred from contextual knowledge. There are different kinds of +implicit arguments that can be considered implicit in different ways. +There are also various commands to control the setting or the +inference of implicit arguments. + + +The different kinds of implicit arguments +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Implicit arguments inferable from the knowledge of other arguments of a function +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +The first kind of implicit arguments covers the arguments that are +inferable from the knowledge of the type of other arguments of the +function, or of the type of the surrounding context of the +application. Especially, such implicit arguments correspond to +parameters dependent in the type of the function. Typical implicit +arguments are the type arguments in polymorphic functions. There are +several kinds of such implicit arguments. + +**Strict Implicit Arguments** + +An implicit argument can be either strict or non strict. An implicit +argument is said to be *strict* if, whatever the other arguments of the +function are, it is still inferable from the type of some other +argument. Technically, an implicit argument is strict if it +corresponds to a parameter which is not applied to a variable which +itself is another parameter of the function (since this parameter may +erase its arguments), not in the body of a match, and not itself +applied or matched against patterns (since the original form of the +argument can be lost by reduction). + +For instance, the first argument of +:: + + cons: forall A:Set, A -> list A -> list A + +in module ``List.v`` is strict because :g:`list` is an inductive type and :g:`A` +will always be inferable from the type :g:`list A` of the third argument of +:g:`cons`. Also, the first argument of :g:`cons` is strict with respect to the second one, +since the first argument is exactly the type of the second argument. +On the contrary, the second argument of a term of type +:: + + forall P:nat->Prop, forall n:nat, P n -> ex nat P + +is implicit but not strict, since it can only be inferred from the +type :g:`P n` of the third argument and if :g:`P` is, e.g., :g:`fun _ => True`, it +reduces to an expression where ``n`` does not occur any longer. The first +argument :g:`P` is implicit but not strict either because it can only be +inferred from :g:`P n` and :g:`P` is not canonically inferable from an arbitrary +:g:`n` and the normal form of :g:`P n`. Consider, e.g., that :g:`n` is :math:`0` and the third +argument has type :g:`True`, then any :g:`P` of the form +:: + + fun n => match n with 0 => True | _ => anything end + +would be a solution of the inference problem. + +**Contextual Implicit Arguments** + +An implicit argument can be *contextual* or not. An implicit argument +is said *contextual* if it can be inferred only from the knowledge of +the type of the context of the current expression. For instance, the +only argument of:: + + nil : forall A:Set, list A` + +is contextual. Similarly, both arguments of a term of type:: + + forall P:nat->Prop, forall n:nat, P n \/ n = 0 + +are contextual (moreover, :g:`n` is strict and :g:`P` is not). + +**Reversible-Pattern Implicit Arguments** + +There is another class of implicit arguments that can be reinferred +unambiguously if all the types of the remaining arguments are known. +This is the class of implicit arguments occurring in the type of +another argument in position of reversible pattern, which means it is +at the head of an application but applied only to uninstantiated +distinct variables. Such an implicit argument is called *reversible- +pattern implicit argument*. A typical example is the argument :g:`P` of +nat_rec in +:: + + nat_rec : forall P : nat -> Set, P 0 -> + (forall n : nat, P n -> P (S n)) -> forall x : nat, P x + +(:g:`P` is reinferable by abstracting over :g:`n` in the type :g:`P n`). + +See :ref:`controlling-rev-pattern-implicit-args` for the automatic declaration of reversible-pattern +implicit arguments. + +Implicit arguments inferable by resolution +++++++++++++++++++++++++++++++++++++++++++ + +This corresponds to a class of non-dependent implicit arguments that +are solved based on the structure of their type only. + + +Maximal and non-maximal insertion of implicit arguments +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When a function is partially applied and the next argument to +apply is an implicit argument, the application can be interpreted in two ways. +If the next argument is declared as *maximally inserted*, the partial +application will include that argument. Otherwise, the argument is +*non-maximally inserted* and the partial application will not include that argument. + +Each implicit argument can be declared to be inserted maximally or non +maximally. In Coq, maximally inserted implicit arguments are written between curly braces +"{ }" and non-maximally inserted implicit arguments are written in square brackets "[ ]". + +.. seealso:: :flag:`Maximal Implicit Insertion` + +Trailing Implicit Arguments ++++++++++++++++++++++++++++ + +An implicit argument is considered *trailing* when all following arguments are +implicit. Trailing implicit arguments must be declared as maximally inserted; +otherwise they would never be inserted. + +.. exn:: Argument @name is a trailing implicit, so it can't be declared non maximal. Please use %{ %} instead of [ ]. + + For instance: + + .. coqtop:: all fail + + Fail Definition double [n] := n + n. + + +Casual use of implicit arguments +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +If an argument of a function application can be inferred from the type +of the other arguments, the user can force inference of the argument +by replacing it with `_`. + +.. exn:: Cannot infer a term for this placeholder. + :name: Cannot infer a term for this placeholder. (Casual use of implicit arguments) + + |Coq| was not able to deduce an instantiation of a “_”. + +.. _declare-implicit-args: + +Declaration of implicit arguments +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Implicit arguments can be declared when a function is declared or +afterwards, using the :cmd:`Arguments` command. + +Implicit Argument Binders ++++++++++++++++++++++++++ + +.. insertprodn implicit_binders implicit_binders + +.. prodn:: + implicit_binders ::= %{ {+ @name } {? : @type } %} + | [ {+ @name } {? : @type } ] + +In the context of a function definition, these forms specify that +:token:`name` is an implicit argument. The first form, with curly +braces, makes :token:`name` a maximally inserted implicit argument. The second +form, with square brackets, makes :token:`name` a non-maximally inserted implicit argument. + +For example: + +.. coqtop:: all + + Definition id {A : Type} (x : A) : A := x. + +declares the argument `A` of `id` as a maximally +inserted implicit argument. `A` may be omitted +in applications of `id` but may be specified if needed: + +.. coqtop:: all + + Definition compose {A B C} (g : B -> C) (f : A -> B) := fun x => g (f x). + + Goal forall A, compose id id = id (A:=A). + +For non-maximally inserted implicit arguments, use square brackets: + +.. coqtop:: all + + Fixpoint map [A B : Type] (f : A -> B) (l : list A) : list B := + match l with + | nil => nil + | cons a t => cons (f a) (map f t) + end. + + Print Implicit map. + +For (co-)inductive datatype +declarations, the semantics are the following: an inductive parameter +declared as an implicit argument need not be repeated in the inductive +definition and will become implicit for the inductive type and the constructors. +For example: + +.. coqtop:: all + + Inductive list {A : Type} : Type := + | nil : list + | cons : A -> list -> list. + + Print list. + +One can always specify the parameter if it is not uniform using the +usual implicit arguments disambiguation syntax. + +The syntax is also supported in internal binders. For instance, in the +following kinds of expressions, the type of each declaration present +in :token:`binders` can be bracketed to mark the declaration as +implicit: +* :n:`fun (@ident:forall {* @binder }, @type) => @term`, +* :n:`forall (@ident:forall {* @binder }, @type), @type`, +* :n:`let @ident {* @binder } := @term in @term`, +* :n:`fix @ident {* @binder } := @term in @term` and +* :n:`cofix @ident {* @binder } := @term in @term`. + +Here is an example: + +.. coqtop:: all + + Axiom Ax : + forall (f:forall {A} (a:A), A * A), + let g {A} (x y:A) := (x,y) in + f 0 = g 0 0. + +.. warn:: Ignoring implicit binder declaration in unexpected position + + This is triggered when setting an argument implicit in an + expression which does not correspond to the type of an assumption + or to the body of a definition. Here is an example: + + .. coqtop:: all warn + + Definition f := forall {y}, y = 0. + +.. warn:: Making shadowed name of implicit argument accessible by position + + This is triggered when two variables of same name are set implicit + in the same block of binders, in which case the first occurrence is + considered to be unnamed. Here is an example: + + .. coqtop:: all warn + + Check let g {x:nat} (H:x=x) {x} (H:x=x) := x in 0. + +Mode for automatic declaration of implicit arguments +++++++++++++++++++++++++++++++++++++++++++++++++++++ + +.. flag:: Implicit Arguments + + This flag (off by default) allows to systematically declare implicit + the arguments detectable as such. Auto-detection of implicit arguments is + governed by flags controlling whether strict and contextual implicit + arguments have to be considered or not. + +.. _controlling-strict-implicit-args: + +Controlling strict implicit arguments ++++++++++++++++++++++++++++++++++++++ + +.. flag:: Strict Implicit + + When the mode for automatic declaration of implicit arguments is on, + the default is to automatically set implicit only the strict implicit + arguments plus, for historical reasons, a small subset of the non-strict + implicit arguments. To relax this constraint and to set + implicit all non strict implicit arguments by default, you can turn this + flag off. + +.. flag:: Strongly Strict Implicit + + Use this flag (off by default) to capture exactly the strict implicit + arguments and no more than the strict implicit arguments. + +.. _controlling-contextual-implicit-args: + +Controlling contextual implicit arguments ++++++++++++++++++++++++++++++++++++++++++ + +.. flag:: Contextual Implicit + + By default, |Coq| does not automatically set implicit the contextual + implicit arguments. You can turn this flag on to tell |Coq| to also + infer contextual implicit argument. + +.. _controlling-rev-pattern-implicit-args: + +Controlling reversible-pattern implicit arguments ++++++++++++++++++++++++++++++++++++++++++++++++++ + +.. flag:: Reversible Pattern Implicit + + By default, |Coq| does not automatically set implicit the reversible-pattern + implicit arguments. You can turn this flag on to tell |Coq| to also infer + reversible-pattern implicit argument. + +.. _controlling-insertion-implicit-args: + +Controlling the insertion of implicit arguments not followed by explicit arguments +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +.. flag:: Maximal Implicit Insertion + + Assuming the implicit argument mode is on, this flag (off by default) + declares implicit arguments to be automatically inserted when a + function is partially applied and the next argument of the function is + an implicit one. + +Combining manual declaration and automatic declaration +++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +When some arguments are manually specified implicit with binders in a definition +and the automatic declaration mode in on, the manual implicit arguments are added to the +automatically declared ones. + +In that case, and when the flag :flag:`Maximal Implicit Insertion` is set to off, +some trailing implicit arguments can be inferred to be non-maximally inserted. In +this case, they are converted to maximally inserted ones. + +.. example:: + + .. coqtop:: all + + Set Implicit Arguments. + Axiom eq0_le0 : forall (n : nat) (x : n = 0), n <= 0. + Print Implicit eq0_le0. + Axiom eq0_le0' : forall (n : nat) {x : n = 0}, n <= 0. + Print Implicit eq0_le0'. + + +.. _explicit-applications: + +Explicit applications +~~~~~~~~~~~~~~~~~~~~~ + +In presence of non-strict or contextual arguments, or in presence of +partial applications, the synthesis of implicit arguments may fail, so +one may have to explicitly give certain implicit arguments of an +application. Use the :n:`(@ident := @term)` form of :token:`arg` to do so, +where :token:`ident` is the name of the implicit argument and :token:`term` +is its corresponding explicit term. Alternatively, one can deactivate +the hiding of implicit arguments for a single function application using the +:n:`@ @qualid {? @univ_annot } {* @term1 }` form of :token:`term10`. + +.. example:: Syntax for explicitly giving implicit arguments (continued) + + .. coqtop:: all + + Parameter X : Type. + Definition Relation := X -> X -> Prop. + Definition Transitivity (R:Relation) := forall x y:X, R x y -> forall z:X, R y z -> R x z. + Parameters (R : Relation) (p : Transitivity R). + Arguments p : default implicits. + Print Implicit p. + Parameters (a b c : X) (r1 : R a b) (r2 : R b c). + Check (p r1 (z:=c)). + + Check (p (x:=a) (y:=b) r1 (z:=c) r2). + +.. _displaying-implicit-args: + +Displaying implicit arguments +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +.. cmd:: Print Implicit @smart_qualid + + Displays the implicit arguments associated with an object, + identifying which arguments are applied maximally or not. + + +Displaying implicit arguments when pretty-printing +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +.. flag:: Printing Implicit + + By default, the basic pretty-printing rules hide the inferrable implicit + arguments of an application. Turn this flag on to force printing all + implicit arguments. + +.. flag:: Printing Implicit Defensive + + By default, the basic pretty-printing rules display implicit + arguments that are not detected as strict implicit arguments. This + “defensive” mode can quickly make the display cumbersome so this can + be deactivated by turning this flag off. + +.. seealso:: :flag:`Printing All`. + +Interaction with subtyping +~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When an implicit argument can be inferred from the type of more than +one of the other arguments, then only the type of the first of these +arguments is taken into account, and not an upper type of all of them. +As a consequence, the inference of the implicit argument of “=” fails +in + +.. coqtop:: all + + Fail Check nat = Prop. + +but succeeds in + +.. coqtop:: all + + Check Prop = nat. + + +Deactivation of implicit arguments for parsing +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +.. flag:: Parsing Explicit + + Turning this flag on (it is off by default) deactivates the use of implicit arguments. + + In this case, all arguments of constants, inductive types, + constructors, etc, including the arguments declared as implicit, have + to be given as if no arguments were implicit. By symmetry, this also + affects printing. + +.. _canonical-structure-declaration: + +Canonical structures +~~~~~~~~~~~~~~~~~~~~ + +A canonical structure is an instance of a record/structure type that +can be used to solve unification problems involving a projection +applied to an unknown structure instance (an implicit argument) and a +value. The complete documentation of canonical structures can be found +in :ref:`canonicalstructures`; here only a simple example is given. + +.. cmd:: Canonical {? Structure } @smart_qualid + Canonical {? Structure } @ident_decl @def_body + :name: Canonical Structure; _ + + The first form of this command declares an existing :n:`@smart_qualid` as a + canonical instance of a structure (a record). + + The second form defines a new constant as if the :cmd:`Definition` command + had been used, then declares it as a canonical instance as if the first + form had been used on the defined object. + + This command supports the :attr:`local` attribute. When used, the + structure is canonical only within the :cmd:`Section` containing it. + + Assume that :token:`qualid` denotes an object ``(Build_struct`` |c_1| … |c_n| ``)`` in the + structure :g:`struct` of which the fields are |x_1|, …, |x_n|. + Then, each time an equation of the form ``(``\ |x_i| ``_)`` |eq_beta_delta_iota_zeta| |c_i| has to be + solved during the type checking process, :token:`qualid` is used as a solution. + Otherwise said, :token:`qualid` is canonically used to extend the field |c_i| + into a complete structure built on |c_i|. + + Canonical structures are particularly useful when mixed with coercions + and strict implicit arguments. + + .. example:: + + Here is an example. + + .. coqtop:: all reset + + Require Import Relations. + + Require Import EqNat. + + Set Implicit Arguments. + + Unset Strict Implicit. + + Structure Setoid : Type := {Carrier :> Set; Equal : relation Carrier; + Prf_equiv : equivalence Carrier Equal}. + + Definition is_law (A B:Setoid) (f:A -> B) := forall x y:A, Equal x y -> Equal (f x) (f y). + + Axiom eq_nat_equiv : equivalence nat eq_nat. + + Definition nat_setoid : Setoid := Build_Setoid eq_nat_equiv. + + Canonical nat_setoid. + + Thanks to :g:`nat_setoid` declared as canonical, the implicit arguments :g:`A` + and :g:`B` can be synthesized in the next statement. + + .. coqtop:: all abort + + Lemma is_law_S : is_law S. + + .. note:: + If a same field occurs in several canonical structures, then + only the structure declared first as canonical is considered. + + .. attr:: canonical(false) + + To prevent a field from being involved in the inference of + canonical instances, its declaration can be annotated with the + :attr:`canonical(false)` attribute (cf. the syntax of + :n:`@record_field`). + + .. example:: + + For instance, when declaring the :g:`Setoid` structure above, the + :g:`Prf_equiv` field declaration could be written as follows. + + .. coqdoc:: + + #[canonical(false)] Prf_equiv : equivalence Carrier Equal + + See :ref:`canonicalstructures` for a more realistic example. + +.. attr:: canonical + + This attribute can decorate a :cmd:`Definition` or :cmd:`Let` command. + It is equivalent to having a :cmd:`Canonical Structure` declaration just + after the command. + +.. cmd:: Print Canonical Projections {* @smart_qualid } + + This displays the list of global names that are components of some + canonical structure. For each of them, the canonical structure of + which it is a projection is indicated. If constants are given as + its arguments, only the unification rules that involve or are + synthesized from simultaneously all given constants will be shown. + + .. example:: + + For instance, the above example gives the following output: + + .. coqtop:: all + + Print Canonical Projections. + + .. coqtop:: all + + Print Canonical Projections nat. + + .. note:: + + The last line in the first example would not show up if the + corresponding projection (namely :g:`Prf_equiv`) were annotated as not + canonical, as described above. + +Implicit types of variables +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +It is possible to bind variable names to a given type (e.g. in a +development using arithmetic, it may be convenient to bind the names :g:`n` +or :g:`m` to the type :g:`nat` of natural numbers). + +.. cmd:: Implicit {| Type | Types } @reserv_list + :name: Implicit Type; Implicit Types + + .. insertprodn reserv_list simple_reserv + + .. prodn:: + reserv_list ::= {+ ( @simple_reserv ) } + | @simple_reserv + simple_reserv ::= {+ @ident } : @type + + Sets the type of bound + variables starting with :token:`ident` (either :token:`ident` itself or + :token:`ident` followed by one or more single quotes, underscore or + digits) to :token:`type` (unless the bound variable is already declared + with an explicit type, in which case, that type will be used). + +.. example:: + + .. coqtop:: all + + Require Import List. + + Implicit Types m n : nat. + + Lemma cons_inj_nat : forall m n l, n :: l = m :: l -> n = m. + Proof. intros m n. Abort. + + Lemma cons_inj_bool : forall (m n:bool) l, n :: l = m :: l -> n = m. + Abort. + +.. flag:: Printing Use Implicit Types + + By default, the type of bound variables is not printed when + the variable name is associated to an implicit type which matches the + actual type of the variable. This feature can be deactivated by + turning this flag off. + +.. _implicit-generalization: + +Implicit generalization +~~~~~~~~~~~~~~~~~~~~~~~ + +.. index:: `{ } +.. index:: `[ ] +.. index:: `( ) +.. index:: `{! } +.. index:: `[! ] +.. index:: `(! ) + +.. insertprodn generalizing_binder typeclass_constraint + +.. prodn:: + generalizing_binder ::= `( {+, @typeclass_constraint } ) + | `%{ {+, @typeclass_constraint } %} + | `[ {+, @typeclass_constraint } ] + typeclass_constraint ::= {? ! } @term + | %{ @name %} : {? ! } @term + | @name : {? ! } @term + + +Implicit generalization is an automatic elaboration of a statement +with free variables into a closed statement where these variables are +quantified explicitly. Use the :cmd:`Generalizable` command to designate +which variables should be generalized. + +It is activated for a binder by prefixing a \`, and for terms by +surrounding it with \`{ }, or \`[ ] or \`( ). + +Terms surrounded by \`{ } introduce their free variables as maximally +inserted implicit arguments, terms surrounded by \`[ ] introduce them as +non-maximally inserted implicit arguments and terms surrounded by \`( ) +introduce them as explicit arguments. + +Generalizing binders always introduce their free variables as +maximally inserted implicit arguments. The binder itself introduces +its argument as usual. + +In the following statement, ``A`` and ``y`` are automatically +generalized, ``A`` is implicit and ``x``, ``y`` and the anonymous +equality argument are explicit. + +.. coqtop:: all reset + + Generalizable All Variables. + + Definition sym `(x:A) : `(x = y -> y = x) := fun _ p => eq_sym p. + + Print sym. + +Dually to normal binders, the name is optional but the type is required: + +.. coqtop:: all + + Check (forall `{x = y :> A}, y = x). + +When generalizing a binder whose type is a typeclass, its own class +arguments are omitted from the syntax and are generalized using +automatic names, without instance search. Other arguments are also +generalized unless provided. This produces a fully general statement. +this behaviour may be disabled by prefixing the type with a ``!`` or +by forcing the typeclass name to be an explicit application using +``@`` (however the later ignores implicit argument information). + +.. coqtop:: all + + Class Op (A:Type) := op : A -> A -> A. + + Class Commutative (A:Type) `(Op A) := commutative : forall x y, op x y = op y x. + Instance nat_op : Op nat := plus. + + Set Printing Implicit. + Check (forall `{Commutative }, True). + Check (forall `{Commutative nat}, True). + Fail Check (forall `{Commutative nat _}, True). + Fail Check (forall `{!Commutative nat}, True). + Arguments Commutative _ {_}. + Check (forall `{!Commutative nat}, True). + Check (forall `{@Commutative nat plus}, True). + +Multiple binders can be merged using ``,`` as a separator: + +.. coqtop:: all + + Check (forall `{Commutative A, Hnat : !Commutative nat}, True). + +.. cmd:: Generalizable {| {| Variable | Variables } {+ @ident } | All Variables | No Variables } + + Controls the set of generalizable identifiers. By default, no variables are + generalizable. + + This command supports the :attr:`global` attribute. + + The :n:`{| Variable | Variables } {+ @ident }` form allows generalization of only the given :n:`@ident`\s. + Using this command multiple times adds to the allowed identifiers. The other forms clear + the list of :n:`@ident`\s. + + The :n:`All Variables` form generalizes all free variables in + the context that appear under a + generalization delimiter. This may result in confusing errors in case + of typos. In such cases, the context will probably contain some + unexpected generalized variables. + + The :n:`No Variables` form disables implicit generalization entirely. This is + the default behavior (before any :cmd:`Generalizable` command has been entered). diff --git a/doc/sphinx/language/extensions/index.rst b/doc/sphinx/language/extensions/index.rst index f22927d627..fc2ce03093 100644 --- a/doc/sphinx/language/extensions/index.rst +++ b/doc/sphinx/language/extensions/index.rst @@ -17,8 +17,10 @@ language presented in the :ref:`previous chapter <core-language>`. :maxdepth: 1 ../gallina-extensions + implicit-arguments ../../addendum/extended-pattern-matching ../../user-extensions/syntax-extensions + arguments-command ../../addendum/implicit-coercions ../../addendum/type-classes ../../addendum/canonical-structures diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index 18b05e47d3..51dc169def 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -6,319 +6,6 @@ Extensions of |Gallina| |Gallina| is the kernel language of |Coq|. We describe here extensions of |Gallina|’s syntax. -.. _record-types: - -Record types ----------------- - -The :cmd:`Record` construction is a macro allowing the definition of -records as is done in many programming languages. Its syntax is -described in the grammar below. In fact, the :cmd:`Record` macro is more general -than the usual record types, since it allows also for “manifest” -expressions. In this sense, the :cmd:`Record` construction allows defining -“signatures”. - -.. _record_grammar: - -.. cmd:: {| Record | Structure } @record_definition {* with @record_definition } - :name: Record; Structure - - .. insertprodn record_definition field_body - - .. prodn:: - record_definition ::= {? > } @ident_decl {* @binder } {? : @type } {? @ident } %{ {*; @record_field } %} {? @decl_notations } - record_field ::= {* #[ {*, @attr } ] } @name {? @field_body } {? %| @num } {? @decl_notations } - field_body ::= {* @binder } @of_type - | {* @binder } @of_type := @term - | {* @binder } := @term - - Each :n:`@record_definition` defines a record named by :n:`@ident_decl`. - The constructor name is given by :n:`@ident`. - If the constructor name is not specified, then the default name :n:`Build_@ident` is used, - where :n:`@ident` is the record name. - - If :n:`@type` is - omitted, the default type is :math:`\Type`. The identifiers inside the brackets are the field names. - The type of each field :n:`@ident` is :n:`forall {* @binder }, @type`. - Notice that the type of an identifier can depend on a previously-given identifier. Thus the - order of the fields is important. :n:`@binder` parameters may be applied to the record as a whole - or to individual fields. - - Notations can be attached to fields using the :n:`@decl_notations` annotation. - - :cmd:`Record` and :cmd:`Structure` are synonyms. - - This command supports the :attr:`universes(polymorphic)`, - :attr:`universes(monomorphic)`, :attr:`universes(template)`, - :attr:`universes(notemplate)`, :attr:`universes(cumulative)`, - :attr:`universes(noncumulative)` and :attr:`private(matching)` - attributes. - -More generally, a record may have explicitly defined (a.k.a. manifest) -fields. For instance, we might have: -:n:`Record @ident {* @binder } : @sort := { @ident__1 : @type__1 ; @ident__2 := @term__2 ; @ident__3 : @type__3 }`. -in which case the correctness of :n:`@type__3` may rely on the instance :n:`@term__2` of :n:`@ident__2` and :n:`@term__2` may in turn depend on :n:`@ident__1`. - -.. example:: - - The set of rational numbers may be defined as: - - .. coqtop:: reset all - - Record Rat : Set := mkRat - { sign : bool - ; top : nat - ; bottom : nat - ; Rat_bottom_cond : 0 <> bottom - ; Rat_irred_cond : - forall x y z:nat, (x * y) = top /\ (x * z) = bottom -> x = 1 - }. - - Note here that the fields ``Rat_bottom_cond`` depends on the field ``bottom`` - and ``Rat_irred_cond`` depends on both ``top`` and ``bottom``. - -Let us now see the work done by the ``Record`` macro. First the macro -generates a variant type definition with just one constructor: -:n:`Variant @ident {* @binder } : @sort := @ident__0 {* @binder }`. - -To build an object of type :token:`ident`, one should provide the constructor -:n:`@ident__0` with the appropriate number of terms filling the fields of the record. - -.. example:: - - Let us define the rational :math:`1/2`: - - .. coqtop:: in - - Theorem one_two_irred : forall x y z:nat, x * y = 1 /\ x * z = 2 -> x = 1. - Admitted. - - Definition half := mkRat true 1 2 (O_S 1) one_two_irred. - Check half. - -Alternatively, the following syntax allows creating objects by using named fields, as -shown in this grammar. The fields do not have to be in any particular order, nor do they have -to be all present if the missing ones can be inferred or prompted for -(see :ref:`programs`). - -.. coqtop:: all - - Definition half' := - {| sign := true; - Rat_bottom_cond := O_S 1; - Rat_irred_cond := one_two_irred |}. - -The following settings let you control the display format for types: - -.. flag:: Printing Records - - If set, use the record syntax (shown above) as the default display format. - -You can override the display format for specified types by adding entries to these tables: - -.. table:: Printing Record @qualid - :name: Printing Record - - Specifies a set of qualids which are displayed as records. Use the - :cmd:`Add @table` and :cmd:`Remove @table` commands to update the set of qualids. - -.. table:: Printing Constructor @qualid - :name: Printing Constructor - - Specifies a set of qualids which are displayed as constructors. Use the - :cmd:`Add @table` and :cmd:`Remove @table` commands to update the set of qualids. - -This syntax can also be used for pattern matching. - -.. coqtop:: all - - Eval compute in ( - match half with - | {| sign := true; top := n |} => n - | _ => 0 - end). - -The macro generates also, when it is possible, the projection -functions for destructuring an object of type :token:`ident`. These -projection functions are given the names of the corresponding -fields. If a field is named `_` then no projection is built -for it. In our example: - -.. coqtop:: all - - Eval compute in top half. - Eval compute in bottom half. - Eval compute in Rat_bottom_cond half. - -An alternative syntax for projections based on a dot notation is -available: - -.. coqtop:: all - - Eval compute in half.(top). - -.. flag:: Printing Projections - - This flag activates the dot notation for printing. - - .. example:: - - .. coqtop:: all - - Set Printing Projections. - Check top half. - -.. FIXME: move this to the main grammar in the spec chapter - -.. _record_projections_grammar: - - .. insertprodn term_projection term_projection - - .. prodn:: - term_projection ::= @term0 .( @qualid {* @arg } ) - | @term0 .( @ @qualid {* @term1 } ) - - Syntax of Record projections - -The corresponding grammar rules are given in the preceding grammar. When :token:`qualid` -denotes a projection, the syntax :n:`@term0.(@qualid)` is equivalent to :n:`@qualid @term0`, -the syntax :n:`@term0.(@qualid {+ @arg })` to :n:`@qualid {+ @arg } @term0`. -and the syntax :n:`@term0.(@@qualid {+ @term0 })` to :n:`@@qualid {+ @term0 } @term0`. -In each case, :token:`term0` is the object projected and the -other arguments are the parameters of the inductive type. - - -.. note:: Records defined with the ``Record`` keyword are not allowed to be - recursive (references to the record's name in the type of its field - raises an error). To define recursive records, one can use the ``Inductive`` - and ``CoInductive`` keywords, resulting in an inductive or co-inductive record. - Definition of mutually inductive or co-inductive records are also allowed, as long - as all of the types in the block are records. - -.. note:: Induction schemes are automatically generated for inductive records. - Automatic generation of induction schemes for non-recursive records - defined with the ``Record`` keyword can be activated with the - :flag:`Nonrecursive Elimination Schemes` flag (see :ref:`proofschemes-induction-principles`). - -.. warn:: @ident cannot be defined. - - It can happen that the definition of a projection is impossible. - This message is followed by an explanation of this impossibility. - There may be three reasons: - - #. The name :token:`ident` already exists in the environment (see :cmd:`Axiom`). - #. The body of :token:`ident` uses an incorrect elimination for - :token:`ident` (see :cmd:`Fixpoint` and :ref:`Destructors`). - #. The type of the projections :token:`ident` depends on previous - projections which themselves could not be defined. - -.. exn:: Records declared with the keyword Record or Structure cannot be recursive. - - The record name :token:`ident` appears in the type of its fields, but uses - the keyword ``Record``. Use the keyword ``Inductive`` or ``CoInductive`` instead. - -.. exn:: Cannot handle mutually (co)inductive records. - - Records cannot be defined as part of mutually inductive (or - co-inductive) definitions, whether with records only or mixed with - standard definitions. - -During the definition of the one-constructor inductive definition, all -the errors of inductive definitions, as described in Section -:ref:`gallina-inductive-definitions`, may also occur. - -.. seealso:: Coercions and records in section :ref:`coercions-classes-as-records` of the chapter devoted to coercions. - -.. _primitive_projections: - -Primitive Projections -~~~~~~~~~~~~~~~~~~~~~ - -.. flag:: Primitive Projections - - Turns on the use of primitive - projections when defining subsequent records (even through the ``Inductive`` - and ``CoInductive`` commands). 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 - 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 - for the usual defined ones, although there are a few notable differences. - -.. flag:: Printing Primitive Projection Parameters - - This compatibility flag reconstructs internally omitted parameters at - printing time (even though they are absent in the actual AST manipulated - by the kernel). - -Primitive Record Types -++++++++++++++++++++++ - -When the :flag:`Primitive Projections` flag is on, definitions of -record types change meaning. When a type is declared with primitive -projections, its :g:`match` construct is disabled (see :ref:`primitive_projections` though). -To eliminate the (co-)inductive type, one must use its defined primitive projections. - -.. The following paragraph is quite redundant with what is above - -For compatibility, the parameters still appear to the user when -printing terms even though they are absent in the actual AST -manipulated by the kernel. This can be changed by unsetting the -:flag:`Printing Primitive Projection Parameters` flag. - -There are currently two ways to introduce primitive records types: - -#. Through the ``Record`` command, in which case the type has to be - non-recursive. The defined type enjoys eta-conversion definitionally, - that is the generalized form of surjective pairing for records: - `r` ``= Build_``\ `R` ``(``\ `r`\ ``.(``\ |p_1|\ ``) …`` `r`\ ``.(``\ |p_n|\ ``))``. - Eta-conversion allows to define dependent elimination for these types as well. -#. Through the ``Inductive`` and ``CoInductive`` commands, when - the body of the definition is a record declaration of the form - ``Build_``\ `R` ``{`` |p_1| ``:`` |t_1|\ ``; … ;`` |p_n| ``:`` |t_n| ``}``. - In this case the types can be recursive and eta-conversion is disallowed. These kind of record types - differ from their traditional versions in the sense that dependent - elimination is not available for them and only non-dependent case analysis - can be defined. - -Reduction -+++++++++ - -The basic reduction rule of a primitive projection is -|p_i| ``(Build_``\ `R` |t_1| … |t_n|\ ``)`` :math:`{\rightarrow_{\iota}}` |t_i|. -However, to take the :math:`{\delta}` flag into -account, projections can be in two states: folded or unfolded. An -unfolded primitive projection application obeys the rule above, while -the folded version delta-reduces to the unfolded version. This allows to -precisely mimic the usual unfolding rules of constants. Projections -obey the usual ``simpl`` flags of the ``Arguments`` command in particular. -There is currently no way to input unfolded primitive projections at the -user-level, and there is no way to display unfolded projections differently -from folded ones. - - -Compatibility Projections and :g:`match` -++++++++++++++++++++++++++++++++++++++++ - -To ease compatibility with ordinary record types, each primitive -projection is also defined as a ordinary constant taking parameters and -an object of the record type as arguments, and whose body is an -application of the unfolded primitive projection of the same name. These -constants are used when elaborating partial applications of the -projection. One can distinguish them from applications of the primitive -projection if the :flag:`Printing Primitive Projection Parameters` flag -is off: For a primitive projection application, parameters are printed -as underscores while for the compatibility projections they are printed -as usual. - -Additionally, user-written :g:`match` constructs on primitive records -are desugared into substitution of the projections, they cannot be -printed back as :g:`match` constructs. - Variants and extensions of :g:`match` ------------------------------------- @@ -551,7 +238,7 @@ written using the first destructuring let syntax. Note that this only applies to pattern matching instances entered with :g:`match`. It doesn't affect pattern matching explicitly entered with a destructuring :g:`let`. - Use the :cmd:`Add @table` and :cmd:`Remove @table` commands to update this set. + Use the :cmd:`Add` and :cmd:`Remove` commands to update this set. Printing matching on booleans @@ -565,7 +252,7 @@ which types are written this way: :name: Printing If Specifies a set of qualids for which pattern matching is displayed using - ``if`` … ``then`` … ``else`` …. Use the :cmd:`Add @table` and :cmd:`Remove @table` + ``if`` … ``then`` … ``else`` …. Use the :cmd:`Add` and :cmd:`Remove` commands to update this set. This example emphasizes what the printing settings offer. @@ -590,278 +277,6 @@ This example emphasizes what the printing settings offer. Print snd. -.. _advanced-recursive-functions: - -Advanced recursive functions ----------------------------- - -The following command is available when the ``FunInd`` library has been loaded via ``Require Import FunInd``: - -.. cmd:: Function @fix_definition {* with @fix_definition } - - This command is a generalization of :cmd:`Fixpoint`. It is a wrapper - for several ways of defining a function *and* other useful related - objects, namely: an induction principle that reflects the recursive - structure of the function (see :tacn:`function induction`) and its fixpoint equality. - This defines a function similar to those defined by :cmd:`Fixpoint`. - As in :cmd:`Fixpoint`, the decreasing argument must - be given (unless the function is not recursive), but it might not - necessarily be *structurally* decreasing. Use the :n:`@fixannot` clause - to name the decreasing argument *and* to describe which kind of - decreasing criteria to use to ensure termination of recursive - calls. - - :cmd:`Function` also supports the :n:`with` clause to create - mutually recursive definitions, however this feature is limited - to structurally recursive functions (i.e. when :n:`@fixannot` is a :n:`struct` - clause). - - See :tacn:`function induction` and :cmd:`Functional Scheme` for how to use - the induction principle to reason easily about the function. - - The form of the :n:`@fixannot` clause determines which definition mechanism :cmd:`Function` uses. - (Note that references to :n:`ident` below refer to the name of the function being defined.): - - * If :n:`@fixannot` is not specified, :cmd:`Function` - defines the nonrecursive function :token:`ident` as if it was declared with - :cmd:`Definition`. In addition, the following are defined: - - + :token:`ident`\ ``_rect``, :token:`ident`\ ``_rec`` and :token:`ident`\ ``_ind``, - which reflect the pattern matching structure of :token:`term` (see :cmd:`Inductive`); - + The inductive :n:`R_@ident` corresponding to the graph of :token:`ident` (silently); - + :token:`ident`\ ``_complete`` and :token:`ident`\ ``_correct`` which - are inversion information linking the function and its graph. - - * If :n:`{ struct ... }` is specified, :cmd:`Function` - defines the structural recursive function :token:`ident` as if it was declared - with :cmd:`Fixpoint`. In addition, the following are defined: - - + The same objects as above; - + The fixpoint equation of :token:`ident`: :n:`@ident`\ ``_equation``. - - * If :n:`{ measure ... }` or :n:`{ wf ... }` are specified, :cmd:`Function` - defines a recursive function by well-founded recursion. The module ``Recdef`` - of the standard library must be loaded for this feature. - - + :n:`{measure @one_term__1 {? @ident } {? @one_term__2 } }`\: where :n:`@ident` is the decreasing argument - and :n:`@one_term__1` is a function from the type of :n:`@ident` to :g:`nat` for which - the decreasing argument decreases (for the :g:`lt` order on :g:`nat`) - for each recursive call of the function. The parameters of the function are - bound in :n:`@one_term__1`. - + :n:`{wf @one_term @ident }`\: where :n:`@ident` is the decreasing argument and - :n:`@one_term` is an ordering relation on the type of :n:`@ident` (i.e. of type - `T`\ :math:`_{\sf ident}` → `T`\ :math:`_{\sf ident}` → ``Prop``) for which the decreasing argument - decreases for each recursive call of the function. The order must be well-founded. - The parameters of the function are bound in :n:`@one_term`. - - If the clause is ``measure`` or ``wf``, the user is left with some proof - obligations that will be used to define the function. These proofs - are: proofs that each recursive call is actually decreasing with - respect to the given criteria, and (if the criteria is `wf`) a proof - that the ordering relation is well-founded. Once proof obligations are - discharged, the following objects are defined: - - + The same objects as with the ``struct`` clause; - + The lemma :n:`@ident`\ ``_tcc`` which collects all proof obligations in one - property; - + The lemmas :n:`@ident`\ ``_terminate`` and :n:`@ident`\ ``_F`` which will be inlined - during extraction of :n:`@ident`. - - The way this recursive function is defined is the subject of several - papers by Yves Bertot and Antonia Balaa on the one hand, and Gilles - Barthe, Julien Forest, David Pichardie, and Vlad Rusu on the other - hand. - -.. note:: - - To obtain the right principle, it is better to put rigid - parameters of the function as first arguments. For example it is - better to define plus like this: - - .. coqtop:: reset none - - Require Import FunInd. - - .. coqtop:: all - - Function plus (m n : nat) {struct n} : nat := - match n with - | 0 => m - | S p => S (plus m p) - end. - - than like this: - - .. coqtop:: reset none - - Require Import FunInd. - - .. coqtop:: all - - Function plus (n m : nat) {struct n} : nat := - match n with - | 0 => m - | S p => S (plus p m) - end. - - -*Limitations* - -:token:`term` must be built as a *pure pattern matching tree* (:g:`match … with`) -with applications only *at the end* of each branch. - -:cmd:`Function` does not support partial application of the function being -defined. Thus, the following example cannot be accepted due to the -presence of partial application of :g:`wrong` in the body of :g:`wrong`: - -.. coqtop:: none - - Require List. - Import List.ListNotations. - -.. coqtop:: all fail - - Function wrong (C:nat) : nat := - List.hd 0 (List.map wrong (C::nil)). - -For now, dependent cases are not treated for non structurally -terminating functions. - -.. exn:: The recursive argument must be specified. - :undocumented: - -.. exn:: No argument name @ident. - :undocumented: - -.. exn:: Cannot use mutual definition with well-founded recursion or measure. - :undocumented: - -.. warn:: Cannot define graph for @ident. - - The generation of the graph relation (:n:`R_@ident`) used to compute the induction scheme of ident - raised a typing error. Only :token:`ident` is defined; the induction scheme - will not be generated. This error happens generally when: - - - the definition uses pattern matching on dependent types, - which :cmd:`Function` cannot deal with yet. - - the definition is not a *pattern matching tree* as explained above. - -.. warn:: Cannot define principle(s) for @ident. - - The generation of the graph relation (:n:`R_@ident`) succeeded but the induction principle - could not be built. Only :token:`ident` is defined. Please report. - -.. warn:: Cannot build functional inversion principle. - - :tacn:`functional inversion` will not be available for the function. - -.. seealso:: :ref:`functional-scheme` and :tacn:`function induction` - -.. _section-mechanism: - -Section mechanism ------------------ - -Sections create local contexts which can be shared across multiple definitions. - -.. example:: - - Sections are opened by the :cmd:`Section` command, and closed by :cmd:`End`. - - .. coqtop:: all - - Section s1. - - Inside a section, local parameters can be introduced using :cmd:`Variable`, - :cmd:`Hypothesis`, or :cmd:`Context` (there are also plural variants for - the first two). - - .. coqtop:: all - - Variables x y : nat. - - The command :cmd:`Let` introduces section-wide :ref:`let-in`. These definitions - won't persist when the section is closed, and all persistent definitions which - depend on `y'` will be prefixed with `let y' := y in`. - - .. coqtop:: in - - Let y' := y. - Definition x' := S x. - Definition x'' := x' + y'. - - .. coqtop:: all - - Print x'. - Print x''. - - End s1. - - Print x'. - Print x''. - - Notice the difference between the value of :g:`x'` and :g:`x''` inside section - :g:`s1` and outside. - -.. cmd:: Section @ident - - This command is used to open a section named :token:`ident`. - Section names do not need to be unique. - - -.. cmd:: End @ident - - This command closes the section or module named :token:`ident`. - See :ref:`Terminating an interactive module or module type definition<terminating_module>` - for a description of its use with modules. - - After closing the - section, the local declarations (variables and local definitions, see :cmd:`Variable`) are - *discharged*, meaning that they stop being visible and that all global - objects defined in the section are generalized with respect to the - variables and local definitions they each depended on in the section. - - .. exn:: There is nothing to end. - :undocumented: - - .. exn:: Last block to end has name @ident. - :undocumented: - -.. note:: - Most commands, like :cmd:`Hint`, :cmd:`Notation`, option management, … which - appear inside a section are canceled when the section is closed. - -.. cmd:: Let @ident @def_body - Let Fixpoint @fix_definition {* with @fix_definition } - Let CoFixpoint @cofix_definition {* with @cofix_definition } - :name: Let; Let Fixpoint; Let CoFixpoint - - These commands behave like :cmd:`Definition`, :cmd:`Fixpoint` and :cmd:`CoFixpoint`, except that - the declared constant is local to the current section. - When the section is closed, all persistent - definitions and theorems within it that depend on the constant - will be wrapped with a :n:`@term_let` with the same declaration. - - As for :cmd:`Definition`, :cmd:`Fixpoint` and :cmd:`CoFixpoint`, - if :n:`@term` is omitted, :n:`@type` is required and Coq enters proof editing mode. - This can be used to define a term incrementally, in particular by relying on the :tacn:`refine` tactic. - In this case, the proof should be terminated with :cmd:`Defined` in order to define a constant - for which the computational behavior is relevant. See :ref:`proof-editing-mode`. - -.. cmd:: Context {+ @binder } - - Declare variables in the context of the current section, like :cmd:`Variable`, - but also allowing implicit variables, :ref:`implicit-generalization`, and - let-binders. - - .. coqdoc:: - - Context {A : Type} (a b : A). - Context `{EqDec A}. - Context (b' := b). - -.. seealso:: Section :ref:`binders`. Section :ref:`contexts` in chapter :ref:`typeclasses`. - Module system ------------- @@ -901,11 +316,11 @@ together, as well as a means of massive abstraction. parameters given by the :n:`@module_binder`\s. (A *functor* is a function from modules to modules.) - .. todo: would like to find a better term than "interactive", not very descriptive - :n:`@of_module_type` specifies the module type. :n:`{+ <: @module_type_inl }` starts a module that satisfies each :n:`@module_type_inl`. + .. todo: would like to find a better term than "interactive", not very descriptive + :n:`:= {+<+ @module_expr_inl }` specifies the body of a module or functor definition. If it's not specified, then the module is defined *interactively*, meaning that the module is defined as a series of commands terminated with :cmd:`End` @@ -1007,7 +422,12 @@ are now available through the dot notation. If :n:`@module_binder`\s are specified, declares a functor with parameters given by the list of :token:`module_binder`\s. -.. cmd:: Import {+ @qualid } +.. cmd:: Import {+ @filtered_import } + + .. insertprodn filtered_import filtered_import + + .. prodn:: + filtered_import ::= @qualid {? ( {+, @qualid {? ( .. ) } } ) } If :token:`qualid` denotes a valid basic module (i.e. its module type is a signature), makes its components available by their short names. @@ -1050,12 +470,50 @@ are now available through the dot notation. Check B.T. -.. cmd:: Export {+ @qualid } + Appending a module name with a parenthesized list of names will + make only those names available with short names, not other names + defined in the module nor will it activate other features. + + The names to import may be constants, inductive types and + constructors, and notation aliases (for instance, Ltac definitions + cannot be selectively imported). If they are from an inner module + to the one being imported, they must be prefixed by the inner path. + + The name of an inductive type may also be followed by ``(..)`` to + import it, its constructors and its eliminators if they exist. For + this purpose "eliminator" means a constant in the same module whose + name is the inductive type's name suffixed by one of ``_sind``, + ``_ind``, ``_rec`` or ``_rect``. + + .. example:: + + .. coqtop:: reset in + + Module A. + Module B. + Inductive T := C. + Definition U := nat. + End B. + Definition Z := Prop. + End A. + Import A(B.T(..), Z). + + .. coqtop:: all + + Check B.T. + Check B.C. + Check Z. + Fail Check B.U. + Check A.B.U. + +.. cmd:: Export {+ @filtered_import } :name: Export Similar to :cmd:`Import`, except that when the module containing this command is imported, the :n:`{+ @qualid }` are imported as well. + The selective import syntax also works with Export. + .. exn:: @qualid is not a module. :undocumented: @@ -1148,12 +606,9 @@ module can be accessed using the dot notation: Parameter x : T. End SIG. -The following definition of :g:`N` using the module type expression :g:`SIG` with +The definition of :g:`N` using the module type expression :g:`SIG` with :g:`Definition T := nat` is equivalent to the following one: -.. todo: what is other definition referred to above? - "Module N' : SIG with Definition T := nat. End N`." is not it. - .. coqtop:: in Module Type SIG'. @@ -1304,7 +759,7 @@ accessible, absolute names can never be hidden. Locate nat. -.. seealso:: Commands :cmd:`Locate` and :cmd:`Locate Library`. +.. seealso:: Commands :cmd:`Locate`. .. _libraries-and-filesystem: @@ -1369,911 +824,6 @@ subdirectories of path). See the command :cmd:`Declare ML Module` in See :ref:`command-line-options` for a more general view over the |Coq| command line options. -.. _ImplicitArguments: - -Implicit arguments ------------------- - -An implicit argument of a function is an argument which can be -inferred from contextual knowledge. There are different kinds of -implicit arguments that can be considered implicit in different ways. -There are also various commands to control the setting or the -inference of implicit arguments. - - -The different kinds of implicit arguments -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Implicit arguments inferable from the knowledge of other arguments of a function -++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -The first kind of implicit arguments covers the arguments that are -inferable from the knowledge of the type of other arguments of the -function, or of the type of the surrounding context of the -application. Especially, such implicit arguments correspond to -parameters dependent in the type of the function. Typical implicit -arguments are the type arguments in polymorphic functions. There are -several kinds of such implicit arguments. - -**Strict Implicit Arguments** - -An implicit argument can be either strict or non strict. An implicit -argument is said to be *strict* if, whatever the other arguments of the -function are, it is still inferable from the type of some other -argument. Technically, an implicit argument is strict if it -corresponds to a parameter which is not applied to a variable which -itself is another parameter of the function (since this parameter may -erase its arguments), not in the body of a match, and not itself -applied or matched against patterns (since the original form of the -argument can be lost by reduction). - -For instance, the first argument of -:: - - cons: forall A:Set, A -> list A -> list A - -in module ``List.v`` is strict because :g:`list` is an inductive type and :g:`A` -will always be inferable from the type :g:`list A` of the third argument of -:g:`cons`. Also, the first argument of :g:`cons` is strict with respect to the second one, -since the first argument is exactly the type of the second argument. -On the contrary, the second argument of a term of type -:: - - forall P:nat->Prop, forall n:nat, P n -> ex nat P - -is implicit but not strict, since it can only be inferred from the -type :g:`P n` of the third argument and if :g:`P` is, e.g., :g:`fun _ => True`, it -reduces to an expression where ``n`` does not occur any longer. The first -argument :g:`P` is implicit but not strict either because it can only be -inferred from :g:`P n` and :g:`P` is not canonically inferable from an arbitrary -:g:`n` and the normal form of :g:`P n`. Consider, e.g., that :g:`n` is :math:`0` and the third -argument has type :g:`True`, then any :g:`P` of the form -:: - - fun n => match n with 0 => True | _ => anything end - -would be a solution of the inference problem. - -**Contextual Implicit Arguments** - -An implicit argument can be *contextual* or not. An implicit argument -is said *contextual* if it can be inferred only from the knowledge of -the type of the context of the current expression. For instance, the -only argument of:: - - nil : forall A:Set, list A` - -is contextual. Similarly, both arguments of a term of type:: - - forall P:nat->Prop, forall n:nat, P n \/ n = 0 - -are contextual (moreover, :g:`n` is strict and :g:`P` is not). - -**Reversible-Pattern Implicit Arguments** - -There is another class of implicit arguments that can be reinferred -unambiguously if all the types of the remaining arguments are known. -This is the class of implicit arguments occurring in the type of -another argument in position of reversible pattern, which means it is -at the head of an application but applied only to uninstantiated -distinct variables. Such an implicit argument is called *reversible- -pattern implicit argument*. A typical example is the argument :g:`P` of -nat_rec in -:: - - nat_rec : forall P : nat -> Set, P 0 -> - (forall n : nat, P n -> P (S n)) -> forall x : nat, P x - -(:g:`P` is reinferable by abstracting over :g:`n` in the type :g:`P n`). - -See :ref:`controlling-rev-pattern-implicit-args` for the automatic declaration of reversible-pattern -implicit arguments. - -Implicit arguments inferable by resolution -++++++++++++++++++++++++++++++++++++++++++ - -This corresponds to a class of non-dependent implicit arguments that -are solved based on the structure of their type only. - - -Maximal or non maximal insertion of implicit arguments -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In case a function is partially applied, and the next argument to be -applied is an implicit argument, two disciplines are applicable. In -the first case, the function is considered to have no arguments -furtherly: one says that the implicit argument is not maximally -inserted. In the second case, the function is considered to be -implicitly applied to the implicit arguments it is waiting for: one -says that the implicit argument is maximally inserted. - -Each implicit argument can be declared to be inserted maximally or non -maximally. In Coq, maximally-inserted implicit arguments are written between curly braces -"{ }" and non-maximally-inserted implicit arguments are written in square brackets "[ ]". - -.. seealso:: :flag:`Maximal Implicit Insertion` - -Trailing Implicit Arguments -+++++++++++++++++++++++++++ - -An implicit argument is considered trailing when all following arguments are declared -implicit. Trailing implicit arguments cannot be declared non maximally inserted, -otherwise they would never be inserted. - -.. exn:: Argument @name is a trailing implicit, so it can't be declared non maximal. Please use %{ %} instead of [ ]. - - For instance: - - .. coqtop:: all fail - - Fail Definition double [n] := n + n. - - -Casual use of implicit arguments -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In a given expression, if it is clear that some argument of a function -can be inferred from the type of the other arguments, the user can -force the given argument to be guessed by replacing it by “_”. If -possible, the correct argument will be automatically generated. - -.. exn:: Cannot infer a term for this placeholder. - :name: Cannot infer a term for this placeholder. (Casual use of implicit arguments) - - |Coq| was not able to deduce an instantiation of a “_”. - -.. _declare-implicit-args: - -Declaration of implicit arguments -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In case one wants that some arguments of a given object (constant, -inductive types, constructors, assumptions, local or not) are always -inferred by |Coq|, one may declare once and for all which are the -expected implicit arguments of this object. There are two ways to do -this, *a priori* and *a posteriori*. - - -Implicit Argument Binders -+++++++++++++++++++++++++ - -.. insertprodn implicit_binders implicit_binders - -.. prodn:: - implicit_binders ::= %{ {+ @name } {? : @type } %} - | [ {+ @name } {? : @type } ] - -In the first setting, one wants to explicitly give the implicit -arguments of a declared object as part of its definition. To do this, -one has to surround the bindings of implicit arguments by curly -braces or square braces: - -.. coqtop:: all - - Definition id {A : Type} (x : A) : A := x. - -This automatically declares the argument A of id as a maximally -inserted implicit argument. One can then do as-if the argument was -absent in every situation but still be able to specify it if needed: - -.. coqtop:: all - - Definition compose {A B C} (g : B -> C) (f : A -> B) := fun x => g (f x). - - Goal forall A, compose id id = id (A:=A). - -For non maximally inserted implicit arguments, use square brackets: - -.. coqtop:: all - - Fixpoint map [A B : Type] (f : A -> B) (l : list A) : list B := - match l with - | nil => nil - | cons a t => cons (f a) (map f t) - end. - - Print Implicit map. - -The syntax is supported in all top-level definitions: -:cmd:`Definition`, :cmd:`Fixpoint`, :cmd:`Lemma` and so on. For (co-)inductive datatype -declarations, the semantics are the following: an inductive parameter -declared as an implicit argument need not be repeated in the inductive -definition and will become implicit for the inductive type and the constructors. -For example: - -.. coqtop:: all - - Inductive list {A : Type} : Type := - | nil : list - | cons : A -> list -> list. - - Print list. - -One can always specify the parameter if it is not uniform using the -usual implicit arguments disambiguation syntax. - -The syntax is also supported in internal binders. For instance, in the -following kinds of expressions, the type of each declaration present -in :token:`binders` can be bracketed to mark the declaration as -implicit: -:n:`fun (@ident:forall {* @binder }, @type) => @term`, -:n:`forall (@ident:forall {* @binder }, @type), @type`, -:n:`let @ident {* @binder } := @term in @term`, -:n:`fix @ident {* @binder } := @term in @term` and -:n:`cofix @ident {* @binder } := @term in @term`. -Here is an example: - -.. coqtop:: all - - Axiom Ax : - forall (f:forall {A} (a:A), A * A), - let g {A} (x y:A) := (x,y) in - f 0 = g 0 0. - -.. warn:: Ignoring implicit binder declaration in unexpected position - - This is triggered when setting an argument implicit in an - expression which does not correspond to the type of an assumption - or to the body of a definition. Here is an example: - - .. coqtop:: all warn - - Definition f := forall {y}, y = 0. - -.. warn:: Making shadowed name of implicit argument accessible by position - - This is triggered when two variables of same name are set implicit - in the same block of binders, in which case the first occurrence is - considered to be unnamed. Here is an example: - - .. coqtop:: all warn - - Check let g {x:nat} (H:x=x) {x} (H:x=x) := x in 0. - - -Declaring Implicit Arguments -++++++++++++++++++++++++++++ - - - -.. cmd:: Arguments @smart_qualid {* @argument_spec_block } {* , {* @more_implicits_block } } {? : {+, @arguments_modifier } } - :name: Arguments - - .. insertprodn smart_qualid arguments_modifier - - .. prodn:: - smart_qualid ::= @qualid - | @by_notation - by_notation ::= @string {? % @ident } - argument_spec_block ::= @argument_spec - | / - | & - | ( {+ @argument_spec } ) {? % @ident } - | [ {+ @argument_spec } ] {? % @ident } - | %{ {+ @argument_spec } %} {? % @ident } - argument_spec ::= {? ! } @name {? % @ident } - more_implicits_block ::= @name - | [ {+ @name } ] - | %{ {+ @name } %} - arguments_modifier ::= simpl nomatch - | simpl never - | default implicits - | clear bidirectionality hint - | clear implicits - | clear scopes - | clear scopes and implicits - | clear implicits and scopes - | rename - | assert - | extra scopes - - This command sets implicit arguments *a posteriori*, - where the list of :n:`@name`\s is a prefix of the list of - arguments of :n:`@smart_qualid`. Arguments in square - brackets are declared as implicit and arguments in curly brackets are declared as - maximally inserted. - - After the command is issued, implicit arguments can and must be - omitted in any expression that applies :token:`qualid`. - - This command supports the :attr:`local` and :attr:`global` attributes. - Default behavior is to limit the effect to the current section but also to - extend their effect outside the current module or library file. - Applying :attr:`local` limits the effect of the command to the current module if - it's not in a section. Applying :attr:`global` within a section extends the - effect outside the current sections and current module if the command occurs. - - A command containing :n:`@argument_spec_block & @argument_spec_block` - provides :ref:`bidirectionality_hints`. - - Use the :n:`@more_implicits_block` to specify multiple implicit arguments declarations - for names of constants, inductive types, constructors and lemmas that can only be - applied to a fixed number of arguments (excluding, for instance, - constants whose type is polymorphic). - The longest applicable list of implicit arguments will be used to select which - implicit arguments are inserted. - For printing, the omitted arguments are the ones of the longest list of implicit - arguments of the sequence. See the example :ref:`here<example_more_implicits>`. - - The :n:`@arguments_modifier` values have various effects: - - * :n:`clear implicits` - clears implicit arguments - * :n:`default implicits` - automatically determine the implicit arguments of the object. - See :ref:`auto_decl_implicit_args`. - * :n:`rename` - rename implicit arguments for the object - * :n:`assert` - assert that the object has the expected number of arguments with the - expected names. See the example here: :ref:`renaming_implicit_arguments`. - -.. exn:: The / modifier may only occur once. - :undocumented: - -.. exn:: The & modifier may only occur once. - :undocumented: - -.. example:: - - .. coqtop:: reset all - - Inductive list (A : Type) : Type := - | nil : list A - | cons : A -> list A -> list A. - - Check (cons nat 3 (nil nat)). - - Arguments cons [A] _ _. - - Arguments nil {A}. - - Check (cons 3 nil). - - Fixpoint map (A B : Type) (f : A -> B) (l : list A) : list B := - match l with nil => nil | cons a t => cons (f a) (map A B f t) end. - - Fixpoint length (A : Type) (l : list A) : nat := - match l with nil => 0 | cons _ m => S (length A m) end. - - Arguments map [A B] f l. - - Arguments length {A} l. (* A has to be maximally inserted *) - - Check (fun l:list (list nat) => map length l). - -.. _example_more_implicits: - -.. example:: Multiple implicit arguments with :n:`@more_implicits_block` - - .. coqtop:: all - - Arguments map [A B] f l, [A] B f l, A B f l. - - Check (fun l => map length l = map (list nat) nat length l). - -.. note:: - Use the :cmd:`Print Implicit` command to see the implicit arguments - of an object (see :ref:`displaying-implicit-args`). - -.. _auto_decl_implicit_args: - -Automatic declaration of implicit arguments -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - The :n:`default implicits @arguments_modifier` clause tells |Coq| to automatically determine the - implicit arguments of the object. - - Auto-detection is governed by flags specifying whether strict, - contextual, or reversible-pattern implicit arguments must be - considered or not (see :ref:`controlling-strict-implicit-args`, :ref:`controlling-contextual-implicit-args`, - :ref:`controlling-rev-pattern-implicit-args` and also :ref:`controlling-insertion-implicit-args`). - -.. example:: Default implicits - - .. coqtop:: reset all - - Inductive list (A:Set) : Set := - | nil : list A - | cons : A -> list A -> list A. - - Arguments cons : default implicits. - - Print Implicit cons. - - Arguments nil : default implicits. - - Print Implicit nil. - - Set Contextual Implicit. - - Arguments nil : default implicits. - - Print Implicit nil. - -The computation of implicit arguments takes account of the unfolding -of constants. For instance, the variable ``p`` below has type -``(Transitivity R)`` which is reducible to -``forall x,y:U, R x y -> forall z:U, R y z -> R x z``. As the variables ``x``, ``y`` and ``z`` -appear strictly in the body of the type, they are implicit. - -.. coqtop:: all - - Parameter X : Type. - - Definition Relation := X -> X -> Prop. - - Definition Transitivity (R:Relation) := forall x y:X, R x y -> forall z:X, R y z -> R x z. - - Parameters (R : Relation) (p : Transitivity R). - - Arguments p : default implicits. - - Print p. - - Print Implicit p. - - Parameters (a b c : X) (r1 : R a b) (r2 : R b c). - - Check (p r1 r2). - - -Mode for automatic declaration of implicit arguments -++++++++++++++++++++++++++++++++++++++++++++++++++++ - -.. flag:: Implicit Arguments - - This flag (off by default) allows to systematically declare implicit - the arguments detectable as such. Auto-detection of implicit arguments is - governed by flags controlling whether strict and contextual implicit - arguments have to be considered or not. - -.. _controlling-strict-implicit-args: - -Controlling strict implicit arguments -+++++++++++++++++++++++++++++++++++++ - -.. flag:: Strict Implicit - - When the mode for automatic declaration of implicit arguments is on, - the default is to automatically set implicit only the strict implicit - arguments plus, for historical reasons, a small subset of the non-strict - implicit arguments. To relax this constraint and to set - implicit all non strict implicit arguments by default, you can turn this - flag off. - -.. flag:: Strongly Strict Implicit - - Use this flag (off by default) to capture exactly the strict implicit - arguments and no more than the strict implicit arguments. - -.. _controlling-contextual-implicit-args: - -Controlling contextual implicit arguments -+++++++++++++++++++++++++++++++++++++++++ - -.. flag:: Contextual Implicit - - By default, |Coq| does not automatically set implicit the contextual - implicit arguments. You can turn this flag on to tell |Coq| to also - infer contextual implicit argument. - -.. _controlling-rev-pattern-implicit-args: - -Controlling reversible-pattern implicit arguments -+++++++++++++++++++++++++++++++++++++++++++++++++ - -.. flag:: Reversible Pattern Implicit - - By default, |Coq| does not automatically set implicit the reversible-pattern - implicit arguments. You can turn this flag on to tell |Coq| to also infer - reversible-pattern implicit argument. - -.. _controlling-insertion-implicit-args: - -Controlling the insertion of implicit arguments not followed by explicit arguments -++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -.. flag:: Maximal Implicit Insertion - - Assuming the implicit argument mode is on, this flag (off by default) - declares implicit arguments to be automatically inserted when a - function is partially applied and the next argument of the function is - an implicit one. - -Combining manual declaration and automatic declaration -++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -When some arguments are manually specified implicit with binders in a definition -and the automatic declaration mode in on, the manual implicit arguments are added to the -automatically declared ones. - -In that case, and when the flag :flag:`Maximal Implicit Insertion` is set to off, -some trailing implicit arguments can be inferred to be non maximally inserted. In -this case, they are converted to maximally inserted ones. - -.. example:: - - .. coqtop:: all - - Set Implicit Arguments. - Axiom eq0_le0 : forall (n : nat) (x : n = 0), n <= 0. - Print Implicit eq0_le0. - Axiom eq0_le0' : forall (n : nat) {x : n = 0}, n <= 0. - Print Implicit eq0_le0'. - - -.. _explicit-applications: - -Explicit applications -~~~~~~~~~~~~~~~~~~~~~ - -In presence of non-strict or contextual arguments, or in presence of -partial applications, the synthesis of implicit arguments may fail, so -one may have to explicitly give certain implicit arguments of an -application. Use the :n:`(@ident := @term)` form of :token:`arg` to do so, -where :token:`ident` is the name of the implicit argument and :token:`term` -is its corresponding explicit term. Alternatively, one can deactivate -the hiding of implicit arguments for a single function application using the -:n:`@ @qualid {? @univ_annot } {* @term1 }` form of :token:`term10`. - -.. example:: Syntax for explicitly giving implicit arguments (continued) - - .. coqtop:: all - - Check (p r1 (z:=c)). - - Check (p (x:=a) (y:=b) r1 (z:=c) r2). - - -.. _renaming_implicit_arguments: - -Renaming implicit arguments -~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -.. example:: (continued) Renaming implicit arguments - - .. coqtop:: all - - Arguments p [s t] _ [u] _: rename. - - Check (p r1 (u:=c)). - - Check (p (s:=a) (t:=b) r1 (u:=c) r2). - - Fail Arguments p [s t] _ [w] _ : assert. - -.. _displaying-implicit-args: - -Displaying implicit arguments -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -.. cmd:: Print Implicit @smart_qualid - - Displays the implicit arguments associated with an object, - identifying which arguments are applied maximally or not. - - -Displaying implicit arguments when pretty-printing -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -.. flag:: Printing Implicit - - By default, the basic pretty-printing rules hide the inferrable implicit - arguments of an application. Turn this flag on to force printing all - implicit arguments. - -.. flag:: Printing Implicit Defensive - - By default, the basic pretty-printing rules display implicit - arguments that are not detected as strict implicit arguments. This - “defensive” mode can quickly make the display cumbersome so this can - be deactivated by turning this flag off. - -.. seealso:: :flag:`Printing All`. - -Interaction with subtyping -~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When an implicit argument can be inferred from the type of more than -one of the other arguments, then only the type of the first of these -arguments is taken into account, and not an upper type of all of them. -As a consequence, the inference of the implicit argument of “=” fails -in - -.. coqtop:: all - - Fail Check nat = Prop. - -but succeeds in - -.. coqtop:: all - - Check Prop = nat. - - -Deactivation of implicit arguments for parsing -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -.. flag:: Parsing Explicit - - Turning this flag on (it is off by default) deactivates the use of implicit arguments. - - In this case, all arguments of constants, inductive types, - constructors, etc, including the arguments declared as implicit, have - to be given as if no arguments were implicit. By symmetry, this also - affects printing. - -.. _canonical-structure-declaration: - -Canonical structures -~~~~~~~~~~~~~~~~~~~~ - -A canonical structure is an instance of a record/structure type that -can be used to solve unification problems involving a projection -applied to an unknown structure instance (an implicit argument) and a -value. The complete documentation of canonical structures can be found -in :ref:`canonicalstructures`; here only a simple example is given. - -.. cmd:: Canonical {? Structure } @smart_qualid - Canonical {? Structure } @ident_decl @def_body - :name: Canonical Structure; _ - - The first form of this command declares an existing :n:`@smart_qualid` as a - canonical instance of a structure (a record). - - The second form defines a new constant as if the :cmd:`Definition` command - had been used, then declares it as a canonical instance as if the first - form had been used on the defined object. - - This command supports the :attr:`local` attribute. When used, the - structure is canonical only within the :cmd:`Section` containing it. - - Assume that :token:`qualid` denotes an object ``(Build_struct`` |c_1| … |c_n| ``)`` in the - structure :g:`struct` of which the fields are |x_1|, …, |x_n|. - Then, each time an equation of the form ``(``\ |x_i| ``_)`` |eq_beta_delta_iota_zeta| |c_i| has to be - solved during the type checking process, :token:`qualid` is used as a solution. - Otherwise said, :token:`qualid` is canonically used to extend the field |c_i| - into a complete structure built on |c_i|. - - Canonical structures are particularly useful when mixed with coercions - and strict implicit arguments. - - .. example:: - - Here is an example. - - .. coqtop:: all - - Require Import Relations. - - Require Import EqNat. - - Set Implicit Arguments. - - Unset Strict Implicit. - - Structure Setoid : Type := {Carrier :> Set; Equal : relation Carrier; - Prf_equiv : equivalence Carrier Equal}. - - Definition is_law (A B:Setoid) (f:A -> B) := forall x y:A, Equal x y -> Equal (f x) (f y). - - Axiom eq_nat_equiv : equivalence nat eq_nat. - - Definition nat_setoid : Setoid := Build_Setoid eq_nat_equiv. - - Canonical nat_setoid. - - Thanks to :g:`nat_setoid` declared as canonical, the implicit arguments :g:`A` - and :g:`B` can be synthesized in the next statement. - - .. coqtop:: all abort - - Lemma is_law_S : is_law S. - - .. note:: - If a same field occurs in several canonical structures, then - only the structure declared first as canonical is considered. - - .. attr:: canonical(false) - - To prevent a field from being involved in the inference of - canonical instances, its declaration can be annotated with the - :attr:`canonical(false)` attribute (cf. the syntax of - :n:`@record_field`). - - .. example:: - - For instance, when declaring the :g:`Setoid` structure above, the - :g:`Prf_equiv` field declaration could be written as follows. - - .. coqdoc:: - - #[canonical(false)] Prf_equiv : equivalence Carrier Equal - - See :ref:`canonicalstructures` for a more realistic example. - -.. attr:: canonical - - This attribute can decorate a :cmd:`Definition` or :cmd:`Let` command. - It is equivalent to having a :cmd:`Canonical Structure` declaration just - after the command. - -.. cmd:: Print Canonical Projections {* @smart_qualid } - - This displays the list of global names that are components of some - canonical structure. For each of them, the canonical structure of - which it is a projection is indicated. If constants are given as - its arguments, only the unification rules that involve or are - synthesized from simultaneously all given constants will be shown. - - .. example:: - - For instance, the above example gives the following output: - - .. coqtop:: all - - Print Canonical Projections. - - .. coqtop:: all - - Print Canonical Projections nat. - - .. note:: - - The last line in the first example would not show up if the - corresponding projection (namely :g:`Prf_equiv`) were annotated as not - canonical, as described above. - -Implicit types of variables -~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -It is possible to bind variable names to a given type (e.g. in a -development using arithmetic, it may be convenient to bind the names :g:`n` -or :g:`m` to the type :g:`nat` of natural numbers). - -.. cmd:: Implicit {| Type | Types } @reserv_list - :name: Implicit Type; Implicit Types - - .. insertprodn reserv_list simple_reserv - - .. prodn:: - reserv_list ::= {+ ( @simple_reserv ) } - | @simple_reserv - simple_reserv ::= {+ @ident } : @type - - Sets the type of bound - variables starting with :token:`ident` (either :token:`ident` itself or - :token:`ident` followed by one or more single quotes, underscore or - digits) to :token:`type` (unless the bound variable is already declared - with an explicit type, in which case, that type will be used). - -.. example:: - - .. coqtop:: all - - Require Import List. - - Implicit Types m n : nat. - - Lemma cons_inj_nat : forall m n l, n :: l = m :: l -> n = m. - Proof. intros m n. Abort. - - Lemma cons_inj_bool : forall (m n:bool) l, n :: l = m :: l -> n = m. - Abort. - -.. flag:: Printing Use Implicit Types - - By default, the type of bound variables is not printed when - the variable name is associated to an implicit type which matches the - actual type of the variable. This feature can be deactivated by - turning this flag off. - -.. _implicit-generalization: - -Implicit generalization -~~~~~~~~~~~~~~~~~~~~~~~ - -.. index:: `{ } -.. index:: `[ ] -.. index:: `( ) -.. index:: `{! } -.. index:: `[! ] -.. index:: `(! ) - -.. insertprodn generalizing_binder typeclass_constraint - -.. prodn:: - generalizing_binder ::= `( {+, @typeclass_constraint } ) - | `%{ {+, @typeclass_constraint } %} - | `[ {+, @typeclass_constraint } ] - typeclass_constraint ::= {? ! } @term - | %{ @name %} : {? ! } @term - | @name : {? ! } @term - - -Implicit generalization is an automatic elaboration of a statement -with free variables into a closed statement where these variables are -quantified explicitly. Use the :cmd:`Generalizable` command to designate -which variables should be generalized. - -It is activated for a binder by prefixing a \`, and for terms by -surrounding it with \`{ }, or \`[ ] or \`( ). - -Terms surrounded by \`{ } introduce their free variables as maximally -inserted implicit arguments, terms surrounded by \`[ ] introduce them as -non maximally inserted implicit arguments and terms surrounded by \`( ) -introduce them as explicit arguments. - -Generalizing binders always introduce their free variables as -maximally inserted implicit arguments. The binder itself introduces -its argument as usual. - -In the following statement, ``A`` and ``y`` are automatically -generalized, ``A`` is implicit and ``x``, ``y`` and the anonymous -equality argument are explicit. - -.. coqtop:: all reset - - Generalizable All Variables. - - Definition sym `(x:A) : `(x = y -> y = x) := fun _ p => eq_sym p. - - Print sym. - -Dually to normal binders, the name is optional but the type is required: - -.. coqtop:: all - - Check (forall `{x = y :> A}, y = x). - -When generalizing a binder whose type is a typeclass, its own class -arguments are omitted from the syntax and are generalized using -automatic names, without instance search. Other arguments are also -generalized unless provided. This produces a fully general statement. -this behaviour may be disabled by prefixing the type with a ``!`` or -by forcing the typeclass name to be an explicit application using -``@`` (however the later ignores implicit argument information). - -.. coqtop:: all - - Class Op (A:Type) := op : A -> A -> A. - - Class Commutative (A:Type) `(Op A) := commutative : forall x y, op x y = op y x. - Instance nat_op : Op nat := plus. - - Set Printing Implicit. - Check (forall `{Commutative }, True). - Check (forall `{Commutative nat}, True). - Fail Check (forall `{Commutative nat _}, True). - Fail Check (forall `{!Commutative nat}, True). - Arguments Commutative _ {_}. - Check (forall `{!Commutative nat}, True). - Check (forall `{@Commutative nat plus}, True). - -Multiple binders can be merged using ``,`` as a separator: - -.. coqtop:: all - - Check (forall `{Commutative A, Hnat : !Commutative nat}, True). - -.. cmd:: Generalizable {| {| Variable | Variables } {+ @ident } | All Variables | No Variables } - - Controls the set of generalizable identifiers. By default, no variables are - generalizable. - - This command supports the :attr:`global` attribute. - - The :n:`{| Variable | Variables } {+ @ident }` form allows generalization of only the given :n:`@ident`\s. - Using this command multiple times adds to the allowed identifiers. The other forms clear - the list of :n:`@ident`\s. - - The :n:`All Variables` form generalizes all free variables in - the context that appear under a - generalization delimiter. This may result in confusing errors in case - of typos. In such cases, the context will probably contain some - unexpected generalized variables. - - The :n:`No Variables` form disables implicit generalization entirely. This is - the default behavior (before any :cmd:`Generalizable` command has been entered). - - .. _Coercions: Coercions @@ -2302,7 +852,7 @@ Printing constructions in full .. flag:: Printing All Coercions, implicit arguments, the type of pattern matching, but also - notations (see :ref:`syntaxextensionsandinterpretationscopes`) can obfuscate the behavior of some + notations (see :ref:`syntaxextensionsandnotationscopes`) can obfuscate the behavior of some tactics (typically the tactics applying to occurrences of subterms are sensitive to the implicit arguments). Turning this flag on deactivates all high-level printing features such as coercions, @@ -2313,6 +863,16 @@ Printing constructions in full :flag:`Printing Projections`, and :flag:`Printing Notations`. To reactivate the high-level printing features, use the command ``Unset Printing All``. + .. note:: In some cases, setting :flag:`Printing All` may display terms + that are so big they become very hard to read. One technique to work around + this is use :cmd:`Undelimit Scope` and/or :cmd:`Close Scope` to turn off the + printing of notations bound to particular scope(s). This can be useful when + notations in a given scope are getting in the way of understanding + a goal, but turning off all notations with :flag:`Printing All` would make + the goal unreadable. + + .. see a contrived example here: https://github.com/coq/coq/pull/11718#discussion_r415481854 + .. _printing-universes: Printing universes @@ -2546,51 +1106,3 @@ Literal values (of type :g:`Float64.t`) are extracted to literal OCaml values (of type :g:`float`) written in hexadecimal notation and wrapped into the :g:`Float64.of_float` constructor, e.g.: :g:`Float64.of_float (0x1p+0)`. - -.. _bidirectionality_hints: - -Bidirectionality hints ----------------------- - -When type-checking an application, Coq normally does not use information from -the context to infer the types of the arguments. It only checks after the fact -that the type inferred for the application is coherent with the expected type. -Bidirectionality hints make it possible to specify that after type-checking the -first arguments of an application, typing information should be propagated from -the context to help inferring the types of the remaining arguments. - -An :cmd:`Arguments` command containing :n:`@argument_spec_block__1 & @argument_spec_block__2` -provides :ref:`bidirectionality_hints`. -It tells the typechecking algorithm, when type-checking -applications of :n:`@qualid`, to first type-check the arguments in -:n:`@argument_spec_block__1` and then propagate information from the typing context to -type-check the remaining arguments (in :n:`@argument_spec_block__2`). - -.. example:: Bidirectionality hints - - In a context where a coercion was declared from ``bool`` to ``nat``: - - .. coqtop:: in reset - - Definition b2n (b : bool) := if b then 1 else 0. - Coercion b2n : bool >-> nat. - - Coq cannot automatically coerce existential statements over ``bool`` to - statements over ``nat``, because the need for inserting a coercion is known - only from the expected type of a subterm: - - .. coqtop:: all - - Fail Check (ex_intro _ true _ : exists n : nat, n > 0). - - However, a suitable bidirectionality hint makes the example work: - - .. coqtop:: all - - Arguments ex_intro _ _ & _ _. - Check (ex_intro _ true _ : exists n : nat, n > 0). - -Coq will attempt to produce a term which uses the arguments you -provided, but in some cases involving Program mode the arguments after -the bidirectionality starts may be replaced by convertible but -syntactically different terms. diff --git a/doc/sphinx/language/gallina-specification-language.rst b/doc/sphinx/language/gallina-specification-language.rst index f4592f8f37..186a23897d 100644 --- a/doc/sphinx/language/gallina-specification-language.rst +++ b/doc/sphinx/language/gallina-specification-language.rst @@ -139,7 +139,7 @@ The following grammars describe the basic syntax of the terms of the *Calculus of Inductive Constructions* (also called Cic). The formal presentation of Cic is given in Chapter :ref:`calculusofinductiveconstructions`. Extensions of this syntax are given in Chapter :ref:`extensionsofgallina`. How to customize the syntax -is described in Chapter :ref:`syntaxextensionsandinterpretationscopes`. +is described in Chapter :ref:`syntaxextensionsandnotationscopes`. .. insertprodn term field_def @@ -161,7 +161,7 @@ is described in Chapter :ref:`syntaxextensionsandinterpretationscopes`. one_term ::= @term1 | @ @qualid {? @univ_annot } term1 ::= @term_projection - | @term0 % @ident + | @term0 % @scope_key | @term0 term0 ::= @qualid {? @univ_annot } | @sort @@ -225,7 +225,7 @@ Numerals and strings Numerals and strings have no predefined semantics in the calculus. They are merely notations that can be bound to objects through the notation mechanism -(see Chapter :ref:`syntaxextensionsandinterpretationscopes` for details). +(see Chapter :ref:`syntaxextensionsandnotationscopes` for details). Initially, numerals are bound to Peano’s representation of natural numbers (see :ref:`datatypes`). @@ -373,12 +373,10 @@ the propositional implication and function types. Applications ------------ -The expression :n:`@term__fun @term` denotes the application of -:n:`@term__fun` (which is expected to have a function type) to -:token:`term`. +:n:`@term__fun @term` denotes applying the function :n:`@term__fun` to :token:`term`. -The expression :n:`@term__fun {+ @term__i }` denotes the application -of the term :n:`@term__fun` to the arguments :n:`@term__i`. It is +:n:`@term__fun {+ @term__i }` denotes applying +:n:`@term__fun` to the arguments :n:`@term__i`. It is equivalent to :n:`( … ( @term__fun @term__1 ) … ) @term__n`: associativity is to the left. @@ -458,7 +456,7 @@ Definition by cases: match pattern10 ::= @pattern1 as @name | @pattern1 {* @pattern1 } | @ @qualid {* @pattern1 } - pattern1 ::= @pattern0 % @ident + pattern1 ::= @pattern0 % @scope_key | @pattern0 pattern0 ::= @qualid | %{%| {* @qualid := @pattern } %|%} @@ -636,13 +634,18 @@ co-recursion. It is the local counterpart of the :cmd:`CoFixpoint` command. When The Vernacular ============== -.. insertprodn vernacular vernacular +.. insertprodn vernacular sentence .. prodn:: - vernacular ::= {* {? @all_attrs } {| @command | @ltac_expr } . } - -The top-level input to |Coq| is a series of :production:`command`\s and :production:`tactic`\s, -each terminated with a period + vernacular ::= {* @sentence } + sentence ::= {? @all_attrs } @command . + | {? @all_attrs } {? @num : } @query_command . + | {? @all_attrs } {? @toplevel_selector } @ltac_expr {| . | ... } + | @control_command + +The top-level input to |Coq| is a series of :n:`@sentence`\s, +which are :production:`tactic`\s or :production:`command`\s, +generally terminated with a period and optionally decorated with :ref:`gallina-attributes`. :n:`@ltac_expr` syntax supports both simple and compound tactics. For example: ``split`` is a simple tactic while ``split; auto`` combines two simple tactics. @@ -718,7 +721,7 @@ has type :n:`@type`. :name: @ident already exists. (Axiom) :undocumented: -.. warn:: @ident is declared as a local axiom [local-declaration,scope] +.. warn:: @ident is declared as a local axiom Warning generated when using :cmd:`Variable` or its equivalent instead of :n:`Local Parameter` or its equivalent. @@ -1243,7 +1246,7 @@ The ability to define co-inductive types by constructors, hereafter called a bit long: this is due to dependent pattern-matching which implies propositional η-equality, which itself would require full η-conversion for subject reduction to hold, but full η-conversion is not acceptable as it would -make type-checking undecidable. +make type checking undecidable. Since the introduction of primitive records in Coq 8.5, an alternative presentation is available, called *negative co-inductive types*. This consists diff --git a/doc/sphinx/practical-tools/coq-commands.rst b/doc/sphinx/practical-tools/coq-commands.rst index aa4b6edd7d..545bba4930 100644 --- a/doc/sphinx/practical-tools/coq-commands.rst +++ b/doc/sphinx/practical-tools/coq-commands.rst @@ -164,6 +164,8 @@ and ``coqtop``, unless stated otherwise: it is executed. :-load-vernac-object *qualid*: Load |Coq| compiled library :n:`@qualid`. This is equivalent to running :cmd:`Require` :n:`qualid`. +:-rfrom *dirpath* *qualid*: Load |Coq| compiled library :n:`@qualid`. + This is equivalent to running :n:`From` :n:`@dirpath` :cmd:`Require Import` :n:`@qualid`. :-ri *qualid*, -require-import *qualid*: Load |Coq| compiled library :n:`@qualid` and import it. This is equivalent to running :cmd:`Require Import` :n:`@qualid`. :-re *qualid*, -require-export *qualid*: Load |Coq| compiled library :n:`@qualid` and transitively import it. @@ -172,7 +174,6 @@ and ``coqtop``, unless stated otherwise: This is equivalent to running :n:`From` :n:`@dirpath` :cmd:`Require Import` :n:`@qualid`. :-refrom *dirpath* *qualid*, -require-export-from *dirpath* *qualid*: Load |Coq| compiled library :n:`@qualid` and transitively import it. This is equivalent to running :n:`From` :n:`@dirpath` :cmd:`Require Export` :n:`@qualid`. -:-require *qualid*: Deprecated; use ``-ri`` *qualid*. :-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 @@ -379,7 +380,7 @@ Compiled libraries checker (coqchk) ---------------------------------------- The ``coqchk`` command takes a list of library paths as argument, described either -by their logical name or by their physical filename, hich must end in ``.vo``. The +by their logical name or by their physical filename, which must end in ``.vo``. The corresponding compiled libraries (``.vo`` files) are searched in the path, recursively processing the libraries they depend on. The content of all these libraries is then type checked. The effect of ``coqchk`` is only to return with diff --git a/doc/sphinx/practical-tools/coqide.rst b/doc/sphinx/practical-tools/coqide.rst index b1f392c337..4e8a2b0879 100644 --- a/doc/sphinx/practical-tools/coqide.rst +++ b/doc/sphinx/practical-tools/coqide.rst @@ -1,3 +1,5 @@ +.. |GtkSourceView| replace:: :smallcaps:`GtkSourceView` + .. _coqintegrateddevelopmentenvironment: |Coq| Integrated Development Environment @@ -98,19 +100,6 @@ processed color, though their preceding proofs have the processed color. Notice that for all these buttons, except for the "gears" button, their operations are also available in the menu, where their keyboard shortcuts are given. -Proof folding ------------------- - -As your script grows bigger and bigger, it might be useful to hide the -proofs of your theorems and lemmas. - -This feature is toggled via the Hide entry of the Navigation menu. The -proof shall be enclosed between ``Proof.`` and ``Qed.``, both with their final -dots. The proof that shall be hidden or revealed is the first one -whose beginning statement (such as ``Theorem``) precedes the insertion -cursor. - - Vernacular commands, templates ----------------------------------- @@ -158,7 +147,18 @@ presented as a notebook. The first section is for selecting the text font used for scripts, goal and message windows. -The second and third sections are for controlling colors and style. +The second and third sections are for controlling colors and style of +the three main buffers. A predefined |Coq| highlighting style as well +as standard |GtkSourceView| styles are available. Other styles can be +added e.g. in ``$HOME/.local/share/gtksourceview-3.0/styles/`` (see +the general documentation about |GtkSourceView| for the various +possibilities). Note that the style of the rest of graphical part of +Coqide is not under the control of |GtkSourceView| but of GTK+ and +governed by files such as ``settings.ini`` and ``gtk.css`` in +``$XDG_CONFIG_HOME/gtk-3.0`` or files in +``$HOME/.themes/NameOfTheme/gtk-3.0``, as well as the environment +variable ``GTK_THEME`` (search on internet for the various +possibilities). The fourth section is for customizing the editor. It includes in particular the ability to activate an Emacs mode named @@ -206,7 +206,7 @@ Displaying Unicode symbols ~~~~~~~~~~~~~~~~~~~~~~~~~~ You just need to define suitable notations as described in the chapter -:ref:`syntaxextensionsandinterpretationscopes`. For example, to use the +:ref:`syntaxextensionsandnotationscopes`. For example, to use the mathematical symbols ∀ and ∃, you may define: .. coqtop:: in diff --git a/doc/sphinx/practical-tools/utilities.rst b/doc/sphinx/practical-tools/utilities.rst index d61e5ddce7..408f8fc3ec 100644 --- a/doc/sphinx/practical-tools/utilities.rst +++ b/doc/sphinx/practical-tools/utilities.rst @@ -42,6 +42,8 @@ As of today it is possible to build Coq projects using two tools: - coq_makefile, which is distributed by Coq and is based on generating a makefile, - Dune, the standard OCaml build tool, which, since version 1.9, supports building Coq libraries. +.. _coq_makefile: + Building a |Coq| project with coq_makefile ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -243,16 +245,17 @@ file timing data: COQDEP Fast.v COQDEP Slow.v COQC Slow.v - Slow (user: 0.34 mem: 395448 ko) + Slow.vo (user: 0.34 mem: 395448 ko) COQC Fast.v - Fast (user: 0.01 mem: 45184 ko) + Fast.vo (user: 0.01 mem: 45184 ko) + ``pretty-timed`` this target stores the output of ``make TIMED=1`` into - ``time-of-build.log``, and displays a table of the times, sorted from - slowest to fastest, which is also stored in ``time-of-build-pretty.log``. - If you want to construct the ``log`` for targets other than the default - one, you can pass them via the variable ``TGTS``, e.g., ``make pretty-timed + ``time-of-build.log``, and displays a table of the times and peak + memory usages, sorted from slowest to fastest, which is also + stored in ``time-of-build-pretty.log``. If you want to construct + the ``log`` for targets other than the default one, you can pass + them via the variable ``TGTS``, e.g., ``make pretty-timed TGTS="a.vo b.vo"``. .. note:: @@ -269,24 +272,29 @@ file timing data: ``TIMING_REAL=1`` to ``make pretty-timed`` will use real times rather than user times in the table. + .. note:: + Passing ``TIMING_INCLUDE_MEM=0`` to ``make`` will result in the + tables not including peak memory usage information. Passing + ``TIMING_SORT_BY_MEM=1`` to ``make`` will result in the tables + be sorted by peak memory usage rather than by the time taken. + .. example:: For example, the output of ``make pretty-timed`` may look like this: :: - COQDEP Fast.v - COQDEP Slow.v + COQDEP VFILES COQC Slow.v - Slow (user: 0.36 mem: 393912 ko) + Slow.vo (real: 0.52, user: 0.39, sys: 0.12, mem: 394648 ko) COQC Fast.v - Fast (user: 0.05 mem: 45992 ko) - Time | File Name - -------------------- - 0m00.41s | Total - -------------------- - 0m00.36s | Slow - 0m00.05s | Fast + Fast.vo (real: 0.06, user: 0.02, sys: 0.03, mem: 56980 ko) + Time | Peak Mem | File Name + -------------------------------------------- + 0m00.41s | 394648 ko | Total Time / Peak Mem + -------------------------------------------- + 0m00.39s | 394648 ko | Slow.vo + 0m00.02s | 56980 ko | Fast.vo + ``print-pretty-timed-diff`` @@ -323,7 +331,15 @@ file timing data: .. note:: Just like ``pretty-timed``, this table defaults to using user - times. Pass ``TIMING_REAL=1`` to ``make`` on the command line to show real times instead. + times. Pass ``TIMING_REAL=1`` to ``make`` on the command line + to show real times instead. + + .. note:: + Just like ``pretty-timed``, passing ``TIMING_INCLUDE_MEM=0`` to + ``make`` will result in the tables not including peak memory + usage information. Passing ``TIMING_SORT_BY_MEM=1`` to + ``make`` will result in the tables be sorted by peak memory + usage rather than by the time taken. .. example:: @@ -332,12 +348,12 @@ file timing data: :: - After | File Name | Before || Change | % Change - -------------------------------------------------------- - 0m00.39s | Total | 0m00.35s || +0m00.03s | +11.42% - -------------------------------------------------------- - 0m00.37s | Slow | 0m00.01s || +0m00.36s | +3600.00% - 0m00.02s | Fast | 0m00.34s || -0m00.32s | -94.11% + After | Peak Mem | File Name | Before | Peak Mem || Change || Change (mem) | % Change | % Change (mem) + ----------------------------------------------------------------------------------------------------------------------------- + 0m00.43s | 394700 ko | Total Time / Peak Mem | 0m00.41s | 394648 ko || +0m00.01s || 52 ko | +4.87% | +0.01% + ----------------------------------------------------------------------------------------------------------------------------- + 0m00.39s | 394700 ko | Fast.vo | 0m00.02s | 56980 ko || +0m00.37s || 337720 ko | +1850.00% | +592.69% + 0m00.04s | 56772 ko | Slow.vo | 0m00.39s | 394648 ko || -0m00.35s || -337876 ko | -89.74% | -85.61% The following targets and ``Makefile`` variables allow collection of per- diff --git a/doc/sphinx/proof-engine/detailed-tactic-examples.rst b/doc/sphinx/proof-engine/detailed-tactic-examples.rst index 0ace9ef5b9..b63ae32311 100644 --- a/doc/sphinx/proof-engine/detailed-tactic-examples.rst +++ b/doc/sphinx/proof-engine/detailed-tactic-examples.rst @@ -353,7 +353,7 @@ the optional tactic of the ``Hint Rewrite`` command. .. coqtop:: in reset - Require Import Omega. + Require Import Lia. .. coqtop:: in @@ -367,7 +367,7 @@ the optional tactic of the ``Hint Rewrite`` command. .. coqtop:: in - Hint Rewrite g0 g1 g2 using omega : base1. + Hint Rewrite g0 g1 g2 using lia : base1. .. coqtop:: in diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index b2b426ada5..c1eb1f974c 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -258,6 +258,9 @@ following form: Goal selectors ~~~~~~~~~~~~~~ +.. todo: mention this applies to Print commands and the Info command + + We can restrict the application of a tactic to a subset of the currently focused goals with: @@ -471,7 +474,7 @@ Soft cut ~~~~~~~~ Another way of restricting backtracking is to restrict a tactic to a -single success *a posteriori*: +single success: .. tacn:: once @ltac_expr :name: once @@ -1712,6 +1715,7 @@ performance issue. .. coqtop:: reset in + Set Warnings "-omega-is-deprecated". Require Import Coq.omega.Omega. Ltac mytauto := tauto. diff --git a/doc/sphinx/proof-engine/ltac2.rst b/doc/sphinx/proof-engine/ltac2.rst index 06106a6b4c..35062e0057 100644 --- a/doc/sphinx/proof-engine/ltac2.rst +++ b/doc/sphinx/proof-engine/ltac2.rst @@ -510,9 +510,9 @@ Static semantics **************** During internalization, Coq variables are resolved and antiquotations are -type-checked as Ltac2 terms, effectively producing a ``glob_constr`` in Coq +type checked as Ltac2 terms, effectively producing a ``glob_constr`` in Coq implementation terminology. Note that although it went through the -type-checking of **Ltac2**, the resulting term has not been fully computed and +type checking of **Ltac2**, the resulting term has not been fully computed and is potentially ill-typed as a runtime **Coq** term. .. example:: @@ -523,12 +523,12 @@ is potentially ill-typed as a runtime **Coq** term. Ltac2 myconstr () := constr:(nat -> 0). -Term antiquotations are type-checked in the enclosing Ltac2 typing context +Term antiquotations are type checked in the enclosing Ltac2 typing context of the corresponding term expression. .. example:: - The following will type-check, with type `constr`. + The following will type check, with type `constr`. .. coqdoc:: @@ -539,7 +539,7 @@ expanded by the Coq binders from the term. .. example:: - The following Ltac2 expression will **not** type-check:: + The following Ltac2 expression will **not** type check:: `constr:(fun x : nat => ltac2:(exact x))` `(* Error: Unbound variable 'x' *)` @@ -583,7 +583,7 @@ Dynamic semantics ***************** During evaluation, a quoted term is fully evaluated to a kernel term, and is -in particular type-checked in the current environment. +in particular type checked in the current environment. Evaluation of a quoted term goes as follows. @@ -602,7 +602,7 @@ whole expression will thus evaluate to the term :g:`fun H : nat => H`. `let tac () := hyp @H in constr:(fun H : nat => ltac2:(tac ()))` -Many standard tactics perform type-checking of their argument before going +Many standard tactics perform type checking of their argument before going further. It is your duty to ensure that terms are well-typed when calling such tactics. Failure to do so will result in non-recoverable exceptions. @@ -700,7 +700,7 @@ The following scopes are built-in. + parses :n:`c = @term` and produces :n:`constr:(c)` - This scope can be parameterized by a list of delimiting keys of interpretation + This scope can be parameterized by a list of delimiting keys of notation scopes (as described in :ref:`LocalInterpretationRulesForNotations`), describing how to interpret the parsed term. For instance, :n:`constr(A, B)` parses :n:`c = @term` and produces :n:`constr:(c%A%B)`. diff --git a/doc/sphinx/proof-engine/proof-handling.rst b/doc/sphinx/proof-engine/proof-handling.rst index 03eebc32f9..3b5233502d 100644 --- a/doc/sphinx/proof-engine/proof-handling.rst +++ b/doc/sphinx/proof-engine/proof-handling.rst @@ -41,8 +41,8 @@ terms are called *proof terms*. .. _proof-editing-mode: -Switching on/off the proof editing mode -------------------------------------------- +Entering and leaving proof editing mode +--------------------------------------- The proof editing mode is entered by asserting a statement, which typically is the assertion of a theorem using an assertion command like :cmd:`Theorem`. The diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index 90a991794f..28c5359a04 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -1624,9 +1624,15 @@ previous :token:`i_item` have been performed. The second entry in the :token:`i_view` grammar rule, ``/ltac:(`` :token:`tactic` ``)``, executes :token:`tactic`. -Notations can be used to name tactics, for example:: +Notations can be used to name tactics, for example - Notation myop := (ltac:(some ltac code)) : ssripat_scope. +.. coqtop:: none + + Tactic Notation "my" "ltac" "code" := idtac. + +.. coqtop:: in warn + + Notation "'myop'" := (ltac:(my ltac code)) : ssripat_scope. lets one write just ``/myop`` in the intro pattern. Note the scope annotation: views are interpreted opening the ``ssripat`` scope. @@ -2607,7 +2613,7 @@ After the :token:`i_pattern`, a list of binders is allowed. .. coqtop:: reset none From Coq Require Import ssreflect. - From Coq Require Import Omega. + From Coq Require Import ZArith Lia. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. @@ -2615,7 +2621,7 @@ After the :token:`i_pattern`, a list of binders is allowed. .. coqtop:: all Lemma test : True. - have H x (y : nat) : 2 * x + y = x + x + y by omega. + have H x (y : nat) : 2 * x + y = x + x + y by lia. A proof term provided after ``:=`` can mention these bound variables (that are automatically introduced with the given names). @@ -2625,7 +2631,7 @@ with parentheses even if no type is specified: .. coqtop:: all restart - have (x) : 2 * x = x + x by omega. + have (x) : 2 * x = x + x by lia. The :token:`i_item` and :token:`s_item` can be used to interpret the asserted hypothesis with views (see section :ref:`views_and_reflection_ssr`) or simplify the resulting @@ -2668,9 +2674,9 @@ context entry name. Arguments Sub {_} _ _. Lemma test n m (H : m + 1 < n) : True. - have @i : 'I_n by apply: (Sub m); omega. + have @i : 'I_n by apply: (Sub m); lia. -Note that the subterm produced by :tacn:`omega` is in general huge and +Note that the subterm produced by :tacn:`lia` is in general huge and uninteresting, and hence one may want to hide it. For this purpose the ``[: name ]`` intro pattern and the tactic ``abstract`` (see :ref:`abstract_ssr`) are provided. @@ -2680,7 +2686,7 @@ For this purpose the ``[: name ]`` intro pattern and the tactic .. coqtop:: all abort Lemma test n m (H : m + 1 < n) : True. - have [:pm] @i : 'I_n by apply: (Sub m); abstract: pm; omega. + have [:pm] @i : 'I_n by apply: (Sub m); abstract: pm; lia. The type of ``pm`` can be cleaned up by its annotation ``(*1*)`` by just simplifying it. The annotations are there for technical reasons only. @@ -2694,7 +2700,7 @@ with have and an explicit term, they must be used as follows: Lemma test n m (H : m + 1 < n) : True. have [:pm] @i : 'I_n := Sub m pm. - by omega. + by lia. In this case the abstract constant ``pm`` is assigned by using it in the term that follows ``:=`` and its corresponding goal is left to be @@ -2712,7 +2718,7 @@ makes use of it). .. coqtop:: all abort Lemma test n m (H : m + 1 < n) : True. - have [:pm] @i k : 'I_(n+k) by apply: (Sub m); abstract: pm k; omega. + have [:pm] @i k : 'I_(n+k) by apply: (Sub m); abstract: pm k; lia. Last, notice that the use of intro patterns for abstract constants is orthogonal to the transparent flag ``@`` for have. @@ -2963,7 +2969,7 @@ illustrated in the following example. .. coqtop:: reset none - From Coq Require Import ssreflect Omega. + From Coq Require Import ssreflect Lia. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 19573eee43..8989dd29ab 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -51,6 +51,11 @@ specified, the default selector is used. tactic_invocation : `toplevel_selector` : `tactic`. : `tactic`. +.. todo: fully describe selectors. At the moment, ltac has a fairly complete description + +.. todo: mention selectors can be applied to some commands, such as + Check, Search, SearchHead, SearchPattern, SearchRewrite. + .. opt:: Default Goal Selector "@toplevel_selector" :name: Default Goal Selector @@ -1870,6 +1875,7 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) Lemma induction_test : forall n:nat, n = n -> n <= n. intros n H. induction n. + exact (le_n 0). .. exn:: Not an inductive product. :undocumented: @@ -2071,7 +2077,7 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) Now we are in a contradictory context and the proof can be solved. - .. coqtop:: all + .. coqtop:: all abort inversion H. @@ -2099,68 +2105,7 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) See also the larger example of :tacn:`dependent induction` and an explanation of the underlying technique. -.. tacn:: function induction (@qualid {+ @term}) - :name: function induction - - The tactic functional induction performs case analysis and induction - following the definition of a function. It makes use of a principle - generated by ``Function`` (see :ref:`advanced-recursive-functions`) or - ``Functional Scheme`` (see :ref:`functional-scheme`). - Note that this tactic is only available after a ``Require Import FunInd``. - -.. example:: - - .. coqtop:: reset all - - Require Import FunInd. - Functional Scheme minus_ind := Induction for minus Sort Prop. - Check minus_ind. - Lemma le_minus (n m:nat) : n - m <= n. - functional induction (minus n m) using minus_ind; simpl; auto. - Qed. - -.. note:: - :n:`(@qualid {+ @term})` must be a correct full application - of :n:`@qualid`. In particular, the rules for implicit arguments are the - same as usual. For example use :n:`@qualid` if you want to write implicit - arguments explicitly. - -.. note:: - Parentheses around :n:`@qualid {+ @term}` are not mandatory and can be skipped. - -.. note:: - :n:`functional induction (f x1 x2 x3)` is actually a wrapper for - :n:`induction x1, x2, x3, (f x1 x2 x3) using @qualid` followed by a cleaning - phase, where :n:`@qualid` is the induction principle registered for :g:`f` - (by the ``Function`` (see :ref:`advanced-recursive-functions`) or - ``Functional Scheme`` (see :ref:`functional-scheme`) - command) corresponding to the sort of the goal. Therefore - ``functional induction`` may fail if the induction scheme :n:`@qualid` is not - defined. See also :ref:`advanced-recursive-functions` for the function - terms accepted by ``Function``. - -.. note:: - There is a difference between obtaining an induction scheme - for a function by using :g:`Function` (see :ref:`advanced-recursive-functions`) - and by using :g:`Functional Scheme` after a normal definition using - :g:`Fixpoint` or :g:`Definition`. See :ref:`advanced-recursive-functions` - for details. - -.. seealso:: :ref:`advanced-recursive-functions`, :ref:`functional-scheme` and :tacn:`inversion` - -.. exn:: Cannot find induction information on @qualid. - :undocumented: - -.. exn:: Not the right number of induction arguments. - :undocumented: - -.. 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 - the values of dependent premises of the elimination scheme, including - *predicates* for mutual induction when :n:`@qualid` is part of a mutually - recursive definition. +.. seealso:: :tacn:`functional induction` .. tacn:: discriminate @term :name: discriminate @@ -2667,6 +2612,8 @@ and an explanation of the underlying technique. assumption. Qed. +.. seealso:: :tacn:`functional inversion` + .. tacn:: fix @ident @num :name: fix @@ -3032,8 +2979,8 @@ following: For backward compatibility, the notation :n:`in {+ @ident}` performs the conversion in hypotheses :n:`{+ @ident}`. -.. tacn:: cbv {* @flag} - lazy {* @flag} +.. tacn:: {? @strategy_flag } + lazy {? @strategy_flag } :name: cbv; lazy These parameterized reduction tactics apply to any goal and perform @@ -3129,8 +3076,10 @@ the conversion in hypotheses :n:`{+ @ident}`. .. flag:: NativeCompute Timing This flag causes all calls to the native compiler to print - timing information for the compilation, execution, and - reification phases of native compilation. + timing information for the conversion to native code, + compilation, execution, and reification phases of native + compilation. Timing is printed in units of seconds of + wall-clock time. .. flag:: NativeCompute Profiling @@ -3180,6 +3129,7 @@ the conversion in hypotheses :n:`{+ @ident}`. head normal form according to the :math:`\beta`:math:`\delta`:math:`\iota`:math:`\zeta`-reduction rules, i.e. it reduces the head of the goal until it becomes a product or an irreducible term. All inner :math:`\beta`:math:`\iota`-redexes are also reduced. + The behavior of both :tacn:`hnf` can be tuned using the :cmd:`Arguments` command. Example: The term :g:`fun n : nat => S n + S n` is not reduced by :n:`hnf`. @@ -3206,76 +3156,10 @@ the conversion in hypotheses :n:`{+ @ident}`. The :tacn:`cbn` tactic accepts the same flags as :tacn:`cbv` and :tacn:`lazy`. The behavior of both :tacn:`simpl` and :tacn:`cbn` - can be tuned using the Arguments vernacular command as follows: - - + A constant can be marked to be never unfolded by :tacn:`cbn` or - :tacn:`simpl`: - - .. example:: - - .. coqtop:: all - - Arguments minus n m : simpl never. - - After that command an expression like :g:`(minus (S x) y)` is left - untouched by the tactics :tacn:`cbn` and :tacn:`simpl`. - - + A constant can be marked to be unfolded only if applied to enough - arguments. The number of arguments required can be specified using the - ``/`` symbol in the argument list of the :cmd:`Arguments` command. + can be tuned using the :cmd:`Arguments` command. - .. example:: - - .. coqtop:: all - - Definition fcomp A B C f (g : A -> B) (x : A) : C := f (g x). - Arguments fcomp {A B C} f g x /. - Notation "f \o g" := (fcomp f g) (at level 50). - - After that command the expression :g:`(f \o g)` is left untouched by - :tacn:`simpl` while :g:`((f \o g) t)` is reduced to :g:`(f (g t))`. - The same mechanism can be used to make a constant volatile, i.e. - always unfolded. - - .. example:: - - .. coqtop:: all - - Definition volatile := fun x : nat => x. - Arguments volatile / x. - - + A constant can be marked to be unfolded only if an entire set of - arguments evaluates to a constructor. The ``!`` symbol can be used to mark - such arguments. - - .. example:: - - .. coqtop:: all - - Arguments minus !n !m. - - After that command, the expression :g:`(minus (S x) y)` is left untouched - by :tacn:`simpl`, while :g:`(minus (S x) (S y))` is reduced to :g:`(minus x y)`. - - + A special heuristic to determine if a constant has to be unfolded - can be activated with the following command: - - .. example:: - - .. coqtop:: all - - Arguments minus n m : simpl nomatch. - - The heuristic avoids to perform a simplification step that would expose a - match construct in head position. For example the expression - :g:`(minus (S (S x)) (S y))` is simplified to :g:`(minus (S x) y)` - even if an extra simplification is possible. - - In detail, the tactic :tacn:`simpl` first applies :math:`\beta`:math:`\iota`-reduction. Then, it - expands transparent constants and tries to reduce further using :math:`\beta`:math:`\iota`-reduction. - But, when no :math:`\iota` rule is applied after unfolding then - :math:`\delta`-reductions are not applied. For instance trying to use :tacn:`simpl` on - :g:`(plus n O) = n` changes nothing. + .. todo add "See <subsection about controlling the behavior of reduction strategies>" + to TBA section Notice that only transparent constants whose name can be reused in the recursive calls are possibly unfolded by :tacn:`simpl`. For instance a @@ -4003,10 +3887,10 @@ At Coq startup, only the core database is nonempty and can be used. :arith: This database contains all lemmas about Peano’s arithmetic proved in the directories Init and Arith. -:zarith: contains lemmas about binary signed integers from the directories - theories/ZArith. When required, the module Omega also extends the - database zarith with a high-cost hint that calls ``omega`` on equations - and inequalities in ``nat`` or ``Z``. +:zarith: contains lemmas about binary signed integers from the + directories theories/ZArith. The database also contains + high-cost hints that call :tacn:`lia` on equations and + inequalities in ``nat`` or ``Z``. :bool: contains lemmas about booleans, mostly from directory theories/Bool. @@ -4597,42 +4481,6 @@ symbol :g:`=`. Analogous to :tacn:`dependent rewrite ->` but uses the equality from right to left. -Inversion ---------- - -.. tacn:: functional inversion @ident - :name: functional inversion - - :tacn:`functional inversion` is a tactic that performs inversion on hypothesis - :n:`@ident` of the form :n:`@qualid {+ @term} = @term` or :n:`@term = @qualid - {+ @term}` where :n:`@qualid` must have been defined using Function (see - :ref:`advanced-recursive-functions`). Note that this tactic is only - available after a ``Require Import FunInd``. - - .. exn:: Hypothesis @ident must contain at least one Function. - :undocumented: - - .. exn:: Cannot find inversion information for hypothesis @ident. - - This error may be raised when some inversion lemma failed to be generated by - Function. - - - .. tacv:: functional inversion @num - - This does the same thing as :n:`intros until @num` followed by - :n:`functional inversion @ident` where :token:`ident` is the - identifier for the last introduced hypothesis. - - .. tacv:: functional inversion @ident @qualid - functional inversion @num @qualid - - If the hypothesis :token:`ident` (or :token:`num`) has a type of the form - :n:`@qualid__1 {+ @term__i } = @qualid__2 {+ @term__j }` where - :n:`@qualid__1` and :n:`@qualid__2` are valid candidates to - functional inversion, this variant allows choosing which :token:`qualid` - is inverted. - Classical tactics ----------------- @@ -4689,18 +4537,6 @@ Automating The goal is not of the form :g:`t = u`. Especially note that :tacn:`btauto` doesn't introduce variables into the context on its own. -.. tacn:: omega - :name: omega - - The tactic :tacn:`omega`, due to Pierre Crégut, is an automatic decision - procedure for Presburger arithmetic. It solves quantifier-free - formulas built with `~`, `\\/`, `/\\`, `->` on top of equalities, - inequalities and disequalities on both the type :g:`nat` of natural numbers - and :g:`Z` of binary integers. This tactic must be loaded by the command - ``Require Import Omega``. See the additional documentation about omega - (see Chapter :ref:`omega`). - - .. tacn:: ring :name: ring diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index b22c5286fe..3d69126b2d 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -6,18 +6,28 @@ Vernacular commands .. _displaying: Displaying --------------- +---------- .. _Print: -.. cmd:: Print @qualid - :name: Print +.. cmd:: Print {? Term } @smart_qualid {? @univ_name_list } + + .. insertprodn univ_name_list univ_name_list + + .. prodn:: + univ_name_list ::= @%{ {* @name } %} - This command displays on the screen information about the declared or - defined object referred by :n:`@qualid`. + Displays definitions of terms, including opaque terms, for the object :n:`@smart_qualid`. - Error messages: + * :n:`Term` - a syntactic marker to allow printing a term + that is the same as one of the various :n:`Print` commands. For example, + :cmd:`Print All` is a different command, while :n:`Print Term All` shows + information on the object whose name is ":n:`All`". + + * :n:`@univ_name_list` - locally renames the + polymorphic universes of :n:`@smart_qualid`. + The name `_` means the usual name is printed. .. exn:: @qualid not a defined object. :undocumented: @@ -29,48 +39,22 @@ Displaying :undocumented: - .. cmdv:: Print Term @qualid - :name: Print Term - - This is a synonym of :cmd:`Print` :n:`@qualid` when :n:`@qualid` - denotes a global constant. - - .. cmdv:: Print {? Term } @qualid\@@name - - This locally renames the polymorphic universes of :n:`@qualid`. - An underscore means the usual name is printed. - - -.. cmd:: About @qualid - :name: About - - This displays various information about the object - denoted by :n:`@qualid`: its kind (module, constant, assumption, inductive, - constructor, abbreviation, …), long name, type, implicit arguments and - argument scopes. It does not print the body of definitions or proofs. - - .. cmdv:: About @qualid\@@name - - This locally renames the polymorphic universes of :n:`@qualid`. - An underscore means the usual name is printed. - - .. cmd:: Print All This command displays information about the current state of the environment, including sections and modules. - .. cmdv:: Inspect @num - :name: Inspect +.. cmd:: Inspect @num - This command displays the :n:`@num` last objects of the - current environment, including sections and modules. + This command displays the :n:`@num` last objects of the + current environment, including sections and modules. - .. cmdv:: Print Section @ident +.. cmd:: Print Section @qualid - The name :n:`@ident` should correspond to a currently open section, - this command displays the objects defined since the beginning of this - section. + Displays the objects defined since the beginning of the section named :n:`@qualid`. + + .. todo: "A.B" is permitted but unnecessary for modules/sections. + should the command just take an @ident? .. _flags-options-tables: @@ -81,9 +65,9 @@ Flags, Options and Tables Coq has many settings to control its behavior. Setting types include flags, options and tables: -* A :production:`flag` has a boolean value, such as :flag:`Asymmetric Patterns`. -* An :production:`option` generally has a numeric or string value, such as :opt:`Firstorder Depth`. -* A :production:`table` contains a set of strings or qualids. +* A *flag* has a boolean value, such as :flag:`Asymmetric Patterns`. +* An *option* generally has a numeric or string value, such as :opt:`Firstorder Depth`. +* A *table* contains a set of strings or qualids. * In addition, some commands provide settings, such as :cmd:`Extraction Language`. .. FIXME Convert "Extraction Language" to an option. @@ -91,68 +75,84 @@ and tables: Flags, options and tables are identified by a series of identifiers, each with an initial capital letter. -.. cmd:: Set @flag +.. cmd:: Set @setting_name {? {| @int | @string } } :name: Set - Sets :token:`flag` on. - -.. cmd:: Unset @flag - :name: Unset + .. insertprodn setting_name setting_name - Sets :token:`flag` off. + .. prodn:: + setting_name ::= {+ @ident } -.. cmd:: Test @flag + If :n:`@setting_name` is a flag, no value may be provided; the flag + is set to on. + If :n:`@setting_name` is an option, a value of the appropriate type + must be provided; the option is set to the specified value. - Prints the current value of :token:`flag`. + This command supports the :attr:`local`, :attr:`global` and :attr:`export` attributes. + They are described :ref:`here <set_unset_scope_qualifiers>`. + .. warn:: There is no flag or option with this name: "@setting_name". -.. cmd:: Set @option {| @num | @string } - :name: Set @option + This warning message can be raised by :cmd:`Set` and + :cmd:`Unset` when :n:`@setting_name` is unknown. It is a + warning rather than an error because this helps library authors + produce Coq code that is compatible with several Coq versions. + To preserve the same behavior, they may need to set some + compatibility flags or options that did not exist in previous + Coq versions. - Sets :token:`option` to the specified value. +.. cmd:: Unset @setting_name + :name: Unset -.. cmd:: Unset @option - :name: Unset @option + If :n:`@setting_name` is a flag, it is set to off. If :n:`@setting_name` is an option, it is + set to its default value. - Sets :token:`option` to its default value. + This command supports the :attr:`local`, :attr:`global` and :attr:`export` attributes. + They are described :ref:`here <set_unset_scope_qualifiers>`. -.. cmd:: Test @option +.. cmd:: Add @setting_name {+ {| @qualid | @string } } - Prints the current value of :token:`option`. + Adds the specified values to the table :n:`@setting_name`. -.. cmd:: Print Options - - Prints the current value of all flags and options, and the names of all tables. +.. cmd:: Remove @setting_name {+ {| @qualid | @string } } + Removes the specified value from the table :n:`@setting_name`. -.. cmd:: Add @table {| @string | @qualid } - :name: Add @table +.. cmd:: Test @setting_name {? for {+ {| @qualid | @string } } } - Adds the specified value to :token:`table`. + If :n:`@setting_name` is a flag or option, prints its current value. + If :n:`@setting_name` is a table: if the `for` clause is specified, reports + whether the table contains each specified value, otherise this is equivalent to + :cmd:`Print Table`. The `for` clause is not valid for flags and options. -.. cmd:: Remove @table {| @string | @qualid } - :name: Remove @table + .. exn:: There is no flag, option or table with this name: "@setting_name". - Removes the specified value from :token:`table`. + This error message is raised when calling the :cmd:`Test` + command (without the `for` clause), or the :cmd:`Print Table` + command, for an unknown :n:`@setting_name`. -.. cmd:: Test @table for {| @string | @qualid } - :name: Test @table for + .. exn:: There is no qualid-valued table with this name: "@setting_name". + There is no string-valued table with this name: "@setting_name". - Reports whether :token:`table` contains the specified value. + These error messages are raised when calling the :cmd:`Add` or + :cmd:`Remove` commands, or the :cmd:`Test` command with the + `for` clause, if :n:`@setting_name` is unknown or does not have + the right type. -.. cmd:: Print Table @table - :name: Print Table @table +.. cmd:: Print Options - Prints the values in :token:`table`. + Prints the current value of all flags and options, and the names of all tables. -.. cmd:: Test @table +.. cmd:: Print Table @setting_name - A synonym for :cmd:`Print Table @table`. + Prints the values in the table :n:`@setting_name`. .. cmd:: Print Tables A synonym for :cmd:`Print Options`. +.. _set_unset_scope_qualifiers: + Locality attributes supported by :cmd:`Set` and :cmd:`Unset` ```````````````````````````````````````````````````````````` @@ -185,194 +185,129 @@ Newly opened modules and sections inherit the current settings. arguments ``-set`` and ``-unset`` for setting flags and options (cf. :ref:`command-line-options`). -.. _requests-to-the-environment: - -Requests to the environment -------------------------------- +Query commands +-------------- -.. cmd:: Check @term +Unlike other commands, :production:`query_command`\s may be prefixed with +a goal selector (:n:`@num:`) to specify which goal context it applies to. +If no selector is provided, +the command applies to the current goal. If no proof is open, then the command only applies +to accessible objects. (see Section :ref:`invocation-of-tactics`). - This command displays the type of :n:`@term`. When called in proof mode, the - term is checked in the local context of the current subgoal. +.. cmd:: About @smart_qualid {? @univ_name_list } - .. cmdv:: @selector: Check @term + Displays information about the :n:`@smart_qualid` object, which, + if a proof is open, may be a hypothesis of the selected goal, + or an accessible theorem, axiom, etc.: + its kind (module, constant, assumption, inductive, + constructor, abbreviation, …), long name, type, implicit arguments and + argument scopes (as set in the definition of :token:`smart_qualid` or + subsequently with the :cmd:`Arguments` command). It does not print the body of definitions or proofs. - This variant specifies on which subgoal to perform typing - (see Section :ref:`invocation-of-tactics`). +.. cmd:: Check @term + Displays the type of :n:`@term`. When called in proof mode, the + term is checked in the local context of the selected goal. .. cmd:: Eval @red_expr in @term - This command performs the specified reduction on :n:`@term`, and displays - the resulting term with its type. The term to be reduced may depend on - hypothesis introduced in the first subgoal (if a proof is in - progress). + Performs the specified reduction on :n:`@term` and displays + the resulting term with its type. If a proof is open, :n:`@term` + may reference hypotheses of the selected goal. .. seealso:: Section :ref:`performingcomputations`. .. cmd:: Compute @term - This command performs a call-by-value evaluation of term by using the - bytecode-based virtual machine. It is a shortcut for ``Eval vm_compute in`` - :n:`@term`. + Evaluates :n:`@term` using the bytecode-based virtual machine. + It is a shortcut for :cmd:`Eval` :n:`vm_compute in @term`. .. seealso:: Section :ref:`performingcomputations`. +.. cmd:: Search {+ {? - } @search_item } {? {| inside | outside } {+ @qualid } } -.. cmd:: Print Assumptions @qualid - - This commands display all the assumptions (axioms, parameters and - variables) a theorem or definition depends on. Especially, it informs - on the assumptions with respect to which the validity of a theorem - relies. + .. insertprodn search_item search_item - .. cmdv:: Print Opaque Dependencies @qualid - :name: Print Opaque Dependencies + .. prodn:: + search_item ::= @one_term + | @string {? % @scope_key } - Displays the set of opaque constants :n:`@qualid` relies on in addition to - the assumptions. + Displays the name and type of all hypotheses of the + selected goal (if any) and theorems of the current context + matching :n:`@search_item`\s. + It's useful for finding the names of library lemmas. - .. cmdv:: Print Transparent Dependencies @qualid - :name: Print Transparent Dependencies + * :n:`@one_term` - Search for objects containing a subterm matching the pattern + :n:`@one_term` in which holes of the pattern are indicated by `_` or :n:`?@ident`. + If the same :n:`?@ident` occurs more than once in the pattern, all occurrences must + match the same value. - Displays the set of transparent constants :n:`@qualid` relies on - in addition to the assumptions. + * :n:`@string` - If :n:`@string` is a substring of a valid identifier, + search for objects whose name contains :n:`@string`. If :n:`@string` is a notation + string associated with a :n:`@qualid`, that's equivalent to :cmd:`Search` :n:`@qualid`. + For example, specifying `"+"` or `"_ + _"`, which are notations for `Nat.add`, are equivalent + to :cmd:`Search` `Nat.add`. - .. cmdv:: Print All Dependencies @qualid - :name: Print All Dependencies + * :n:`% @scope` - limits the search to the scope bound to + the delimiting key :n:`@scope`, such as, for example, :n:`%nat`. + This clause may be used only if :n:`@string` contains a notation string. + (see Section :ref:`LocalInterpretationRulesForNotations`) - Displays all assumptions and constants :n:`@qualid` relies on. + If you specify multiple :n:`@search_item`\s, all the conditions must be satisfied + for the object to be displayed. The minus sign `-` excludes objects that contain + the :n:`@search_item`. + Additional clauses: -.. cmd:: Search @qualid + * :n:`inside {+ @qualid }` - limit the search to the specified modules + * :n:`outside {+ @qualid }` - exclude the specified modules from the search - This command displays the name and type of all objects (hypothesis of - the current goal, theorems, axioms, etc) of the current context whose - statement contains :n:`@qualid`. This command is useful to remind the user - of the name of library lemmas. - - .. exn:: The reference @qualid was not found in the current environment. - - There is no constant in the environment named qualid. - - .. cmdv:: Search @string - - If :n:`@string` is a valid identifier, this command - displays the name and type of all objects (theorems, axioms, etc) of - the current context whose name contains string. If string is a - notation’s string denoting some reference :n:`@qualid` (referred to by its - main symbol as in `"+"` or by its notation’s string as in `"_ + _"` or - `"_ 'U' _"`, see Section :ref:`notations`), the command works like ``Search`` :n:`@qualid`. - - .. cmdv:: Search @string%@ident - - The string string must be a notation or the main - symbol of a notation which is then interpreted in the scope bound to - the delimiting key :token:`ident` (see Section :ref:`LocalInterpretationRulesForNotations`). - - .. cmdv:: Search @term_pattern - - This searches for all statements or types of - definition that contains a subterm that matches the pattern - :token:`term_pattern` (holes of the pattern are either denoted by `_` or by - :n:`?@ident` when non linear patterns are expected). - - .. cmdv:: Search {+ {? -}@term_pattern_string} - - where - :n:`@term_pattern_string` is a term_pattern, a string, or a string followed - by a scope delimiting key `%key`. This generalization of ``Search`` searches - for all objects whose statement or type contains a subterm matching - :n:`@term_pattern` (or :n:`@qualid` if :n:`@string` is the notation for a reference - qualid) and whose name contains all string of the request that - correspond to valid identifiers. If a term_pattern or a string is - prefixed by `-`, the search excludes the objects that mention that - term_pattern or that string. - - .. cmdv:: Search {+ {? -}@term_pattern_string} inside {+ @qualid } - - This restricts the search to constructions defined in the modules - named by the given :n:`qualid` sequence. - - .. cmdv:: Search {+ {? -}@term_pattern_string} outside {+ @qualid } - - This restricts the search to constructions not defined in the modules - named by the given :n:`qualid` sequence. - - .. cmdv:: @selector: Search {+ {? -}@term_pattern_string} - - This specifies the goal on which to search hypothesis (see - Section :ref:`invocation-of-tactics`). - By default the 1st goal is searched. This variant can - be combined with other variants presented here. + .. exn:: Module/section @qualid not found. - .. example:: + There is no constant in the environment named :n:`@qualid`, where :n:`@qualid` + is in an `inside` or `outside` clause. - .. coqtop:: in + .. example:: :cmd:`Search` examples - Require Import ZArith. + .. coqtop:: in - .. coqtop:: all + Require Import ZArith. - Search Z.mul Z.add "distr". + .. coqtop:: all - Search "+"%Z "*"%Z "distr" -positive -Prop. + Search Z.mul Z.add "distr". + Search "+"%Z "*"%Z "distr" -Prop. + Search (?x * _ + ?x * _)%Z outside OmegaLemmas. - Search (?x * _ + ?x * _)%Z outside OmegaLemmas. +.. cmd:: SearchHead @one_term {? {| inside | outside } {+ @qualid } } -.. cmd:: SearchHead @term + Displays the name and type of all hypotheses of the + selected goal (if any) and theorems of the current context that have the + form :n:`{? forall {* @binder }, } {* P__i -> } C` where :n:`@one_term` + matches a prefix of `C`. For example, a :n:`@one_term` of `f _ b` + matches `f a b`, which is a prefix of `C` when `C` is `f a b c`. - This command displays the name and type of all hypothesis of the - current goal (if any) and theorems of the current context whose - statement’s conclusion has the form `(term t1 .. tn)`. This command is - useful to remind the user of the name of library lemmas. + See :cmd:`Search` for an explanation of the `inside`/`outside` clauses. - .. example:: + .. example:: :cmd:`SearchHead` examples .. coqtop:: reset all SearchHead le. - SearchHead (@eq bool). - .. cmdv:: SearchHead @term inside {+ @qualid } - - This restricts the search to constructions defined in the modules named - by the given :n:`qualid` sequence. - - .. cmdv:: SearchHead @term outside {+ @qualid } - - This restricts the search to constructions not defined in the modules - named by the given :n:`qualid` sequence. - - .. exn:: Module/section @qualid not found. - - No module :n:`@qualid` has been required (see Section :ref:`compiled-files`). - - .. cmdv:: @selector: SearchHead @term - - This specifies the goal on which to - search hypothesis (see Section :ref:`invocation-of-tactics`). - By default the 1st goal is searched. This variant can be combined - with other variants presented here. +.. cmd:: SearchPattern @one_term {? {| inside | outside } {+ @qualid } } - .. note:: Up to |Coq| version 8.4, ``SearchHead`` was named ``Search``. + Displays the name and type of all hypotheses of the + selected goal (if any) and theorems of the current context + ending with :n:`{? forall {* @binder }, } {* P__i -> } C` that match the pattern + :n:`@one_term`. + See :cmd:`Search` for an explanation of the `inside`/`outside` clauses. -.. cmd:: SearchPattern @term - - This command displays the name and type of all hypothesis of the - current goal (if any) and theorems of the current context whose - statement’s conclusion or last hypothesis and conclusion matches the - expressionterm where holes in the latter are denoted by `_`. - It is a variant of :n:`Search @term_pattern` that does not look for subterms - but searches for statements whose conclusion has exactly the expected - form, or whose statement finishes by the given series of - hypothesis/conclusion. - - .. example:: + .. example:: :cmd:`SearchPattern` examples .. coqtop:: in @@ -381,123 +316,118 @@ Requests to the environment .. coqtop:: all SearchPattern (_ + _ = _ + _). - SearchPattern (nat -> bool). - SearchPattern (forall l : list _, _ l l). - Patterns need not be linear: you can express that the same expression - must occur in two places by using pattern variables `?ident`. - - - .. example:: - .. coqtop:: all SearchPattern (?X1 + _ = _ + ?X1). - .. cmdv:: SearchPattern @term inside {+ @qualid } +.. cmd:: SearchRewrite @one_term {? {| inside | outside } {+ @qualid } } - This restricts the search to constructions defined in the modules - named by the given :n:`qualid` sequence. + Displays the name and type of all hypotheses of the + selected goal (if any) and theorems of the current context that have the form + :n:`{? forall {* @binder }, } {* P__i -> } LHS = RHS` where :n:`@one_term` + matches either `LHS` or `RHS`. - .. cmdv:: SearchPattern @term outside {+ @qualid } + See :cmd:`Search` for an explanation of the `inside`/`outside` clauses. - This restricts the search to constructions not defined in the modules - named by the given :n:`qualid` sequence. + .. example:: :cmd:`SearchRewrite` examples - .. cmdv:: @selector: SearchPattern @term + .. coqtop:: in - This specifies the goal on which to - search hypothesis (see Section :ref:`invocation-of-tactics`). - By default the 1st goal is - searched. This variant can be combined with other variants presented - here. + Require Import Arith. + .. coqtop:: all -.. cmd:: SearchRewrite @term + SearchRewrite (_ + _ + _). - This command displays the name and type of all hypothesis of the - current goal (if any) and theorems of the current context whose - statement’s conclusion is an equality of which one side matches the - expression term. Holes in term are denoted by “_”. +.. table:: Search Blacklist @string + :name: Search Blacklist - .. example:: + Specifies a set of strings used to exclude lemmas from the results of :cmd:`Search`, + :cmd:`SearchHead`, :cmd:`SearchPattern` and :cmd:`SearchRewrite` queries. A lemma whose + fully-qualified name contains any of the strings will be excluded from the + search results. The default blacklisted substrings are ``_subterm``, ``_subproof`` and + ``Private_``. - .. coqtop:: in + Use the :cmd:`Add` and :cmd:`Remove` commands to update the set of + blacklisted strings. - Require Import Arith. - .. coqtop:: all +.. _requests-to-the-environment: - SearchRewrite (_ + _ + _). +Requests to the environment +------------------------------- - .. cmdv:: SearchRewrite @term inside {+ @qualid } +.. cmd:: Print Assumptions @smart_qualid - This restricts the search to constructions defined in the modules - named by the given :n:`qualid` sequence. + Displays all the assumptions (axioms, parameters and + variables) a theorem or definition depends on. - .. cmdv:: SearchRewrite @term outside {+ @qualid } + The message "Closed under the global context" indicates that the theorem or + definition has no dependencies. - This restricts the search to constructions not defined in the modules - named by the given :n:`qualid` sequence. +.. cmd:: Print Opaque Dependencies @smart_qualid - .. cmdv:: @selector: SearchRewrite @term + Displays the assumptions and opaque constants that :n:`@smart_qualid` depends on. - This specifies the goal on which to - search hypothesis (see Section :ref:`invocation-of-tactics`). - By default the 1st goal is - searched. This variant can be combined with other variants presented - here. +.. cmd:: Print Transparent Dependencies @smart_qualid -.. note:: + Displays the assumptions and transparent constants that :n:`@smart_qualid` depends on. - .. table:: Search Blacklist @string - :name: Search Blacklist +.. cmd:: Print All Dependencies @smart_qualid - Specifies a set of strings used to exclude lemmas from the results of :cmd:`Search`, - :cmd:`SearchHead`, :cmd:`SearchPattern` and :cmd:`SearchRewrite` queries. A lemma whose - fully-qualified name contains any of the strings will be excluded from the - search results. The default blacklisted substrings are ``_subterm``, ``_subproof`` and - ``Private_``. + Displays all the assumptions and constants :n:`@smart_qualid` depends on. - Use the :cmd:`Add @table` and :cmd:`Remove @table` commands to update the set of - blacklisted strings. +.. cmd:: Locate @smart_qualid -.. cmd:: Locate @qualid + Displays the full name of objects from |Coq|'s various qualified namespaces such as terms, + modules and Ltac. It also displays notation definitions. - This command displays the full name of objects whose name is a prefix - of the qualified identifier :n:`@qualid`, and consequently the |Coq| module in - which they are defined. It searches for objects from the different - qualified namespaces of |Coq|: terms, modules, Ltac, etc. + If the argument is: - .. example:: + * :n:`@qualid` - displays the full name of objects that + end with :n:`@qualid`, thereby showing the module they are defined in. + * :n:`@string {? "%" @ident }` - displays the definition of a notation. :n:`@string` + can be a single token in the notation such as "`->`" or a pattern that matches the + notation. See :ref:`locating-notations`. - .. coqtop:: all + .. todo somewhere we should list all the qualified namespaces - Locate nat. +.. cmd:: Locate Term @smart_qualid - Locate Datatypes.O. + Like :cmd:`Locate`, but limits the search to terms - Locate Init.Datatypes.O. +.. cmd:: Locate Module @qualid - Locate Coq.Init.Datatypes.O. + Like :cmd:`Locate`, but limits the search to modules - Locate I.Dont.Exist. +.. cmd:: Locate Ltac @qualid - .. cmdv:: Locate Term @qualid + Like :cmd:`Locate`, but limits the search to tactics - As Locate but restricted to terms. +.. cmd:: Locate Library @qualid - .. cmdv:: Locate Module @qualid + Displays the full name, status and file system path of the module :n:`@qualid`, whether loaded or not. - As Locate but restricted to modules. +.. cmd:: Locate File @string - .. cmdv:: Locate Ltac @qualid + Displays the file system path of the file ending with :n:`@string`. + Typically, :n:`@string` has a suffix such as ``.cmo`` or ``.vo`` or ``.v`` file, such as :n:`Nat.v`. - As Locate but restricted to tactics. + .. todo: also works for directory names such as "Data" (parent of Nat.v) + also "Data/Nat.v" works, but not a substring match -.. seealso:: Section :ref:`locating-notations` +.. example:: Locate examples + + .. coqtop:: all + + Locate nat. + Locate Datatypes.O. + Locate Init.Datatypes.O. + Locate Coq.Init.Datatypes.O. + Locate I.Dont.Exist. .. _printing-flags: @@ -522,35 +452,32 @@ Loading files |Coq| offers the possibility of loading different parts of a whole development stored in separate files. Their contents will be loaded as if they were entered from the keyboard. This means that the loaded -files are ASCII files containing sequences of commands for |Coq|’s +files are text files containing sequences of commands for |Coq|’s toplevel. This kind of file is called a *script* for |Coq|. The standard (and default) extension of |Coq|’s script files is .v. -.. cmd:: Load @ident +.. cmd:: Load {? Verbose } {| @string | @ident } - This command loads the file named :n:`ident`.v, searching successively in + Loads a file. If :n:`@ident` is specified, the command loads a file + named :n:`@ident.v`, searching successively in each of the directories specified in the *loadpath*. (see Section :ref:`libraries-and-filesystem`) - Files loaded this way cannot leave proofs open, and the ``Load`` - command cannot be used inside a proof either. - - .. cmdv:: Load @string - - Loads the file denoted by the string :n:`@string`, where - string is any complete filename. Then the `~` and .. abbreviations are - allowed as well as shell variables. If no extension is specified, |Coq| - will use the default extension ``.v``. + If :n:`@string` is specified, it must specify a complete filename. + `~` and .. abbreviations are + allowed as well as shell variables. If no extension is specified, |Coq| + will use the default extension ``.v``. - .. cmdv:: Load Verbose @ident - Load Verbose @string + Files loaded this way can't leave proofs open, nor can :cmd:`Load` + be used inside a proof. - Display, while loading, - the answers of |Coq| to each command (including tactics) contained in - the loaded file. + We discourage the use of :cmd:`Load`; use :cmd:`Require` instead. + :cmd:`Require` loads `.vo` files that were previously + compiled from `.v` files. - .. seealso:: Section :ref:`controlling-display`. + :n:`Verbose` displays the |Coq| output for each command and tactic + in the loaded file, as if the commands and tactics were entered interactively. .. exn:: Can’t find file @ident on loadpath. :undocumented: @@ -568,67 +495,50 @@ Compiled files This section describes the commands used to load compiled files (see Chapter :ref:`thecoqcommands` for documentation on how to compile a file). A compiled -file is a particular case of module called *library file*. - - -.. cmd:: Require @qualid - - This command looks in the loadpath for a file containing module :n:`@qualid` - and adds the corresponding module to the environment of |Coq|. As - library files have dependencies in other library files, the command - :cmd:`Require` :n:`@qualid` recursively requires all library files the module - qualid depends on and adds the corresponding modules to the - environment of |Coq| too. |Coq| assumes that the compiled files have been - produced by a valid |Coq| compiler and their contents are then not - replayed nor rechecked. - - To locate the file in the file system, :n:`@qualid` is decomposed under the - form :n:`dirpath.@ident` and the file :n:`@ident.vo` is searched in the physical - directory of the file system that is mapped in |Coq| loadpath to the - logical path dirpath (see Section :ref:`libraries-and-filesystem`). The mapping between - physical directories and logical names at the time of requiring the - file must be consistent with the mapping used to compile the file. If - several files match, one of them is picked in an unspecified fashion. +file is a particular case of a module called a *library file*. + +.. cmd:: Require {? {| Import | Export } } {+ @qualid } + :name: Require; Require Import; Require Export - .. cmdv:: Require Import @qualid - :name: Require Import + Loads compiled modules into the |Coq| environment. For each :n:`@qualid`, which has the form + :n:`{* @ident__prefix . } @ident`, the command searches for the logical name represented + by the :n:`@ident__prefix`\s and loads the compiled file :n:`@ident.vo` from the associated + filesystem directory. - This loads and declares the module :n:`@qualid` - and its dependencies then imports the contents of :n:`@qualid` as described - for :cmd:`Import`. It does not import the modules that - :n:`@qualid` depends on unless these modules were themselves required in module - :n:`@qualid` - using :cmd:`Require Export`, or recursively required - through a series of :cmd:`Require Export`. If the module required has - already been loaded, :cmd:`Require Import` :n:`@qualid` simply imports it, as - :cmd:`Import` :n:`@qualid` would. + The process is applied recursively to all the loaded files; + if they contain :cmd:`Require` commands, those commands are executed as well. + The compiled files must have been compiled with the same version of |Coq|. + The compiled files are neither replayed nor rechecked. - .. cmdv:: Require Export @qualid - :name: Require Export + * :n:`Import` - additionally does an :cmd:`Import` on the loaded module, making components defined + in the module available by their short names + * :n:`Export` - additionally does an :cmd:`Export` on the loaded module, making components defined + in the module available by their short names *and* marking them to be exported by the current + module - This command acts as :cmd:`Require Import` :n:`@qualid`, - but if a further module, say `A`, contains a command :cmd:`Require Export` `B`, - then the command :cmd:`Require Import` `A` also imports the module `B.` + If the required module has already been loaded, :n:`Import` and :n:`Export` make the command + equivalent to :cmd:`Import` or :cmd:`Export`. + + The loadpath must contain the same mapping used to compile the file + (see Section :ref:`libraries-and-filesystem`). If + several files match, one of them is picked in an unspecified fashion. + Therefore, library authors should use a unique name for each module and + users are encouraged to use fully-qualified names + or the :cmd:`From ... Require` command to load files. - .. cmdv:: Require {| Import | Export } {+ @qualid } - This loads the - modules named by the :token:`qualid` sequence and their recursive - dependencies. If - ``Import`` or ``Export`` is given, it also imports these modules and - all the recursive dependencies that were marked or transitively marked - as ``Export``. + .. todo common user error on dirpaths see https://github.com/coq/coq/pull/11961#discussion_r402852390 - .. cmdv:: From @dirpath Require @qualid - :name: From ... Require ... + .. cmd:: From @dirpath Require {? {| Import | Export } } {+ @qualid } + :name: From ... Require - This command acts as :cmd:`Require`, but picks - any library whose absolute name is of the form :n:`@dirpath.@dirpath’.@qualid` - for some :n:`@dirpath’`. This is useful to ensure that the :token:`qualid` library - comes from a given package by making explicit its absolute root. + Works like :cmd:`Require`, but loads, for each :n:`@qualid`, + the library whose fully-qualified name matches :n:`@dirpath.{* @ident . }@qualid` + for some :n:`{* @ident . }`. This is useful to ensure that the :n:`@qualid` library + comes from a particular package. - .. exn:: Cannot load qualid: no physical path bound to dirpath. + .. exn:: Cannot load @qualid: no physical path bound to @dirpath. :undocumented: .. exn:: Cannot find library foo in loadpath. @@ -637,7 +547,7 @@ file is a particular case of module called *library file*. file foo.vo. Either foo.v exists but is not compiled or foo.vo is in a directory which is not in your LoadPath (see Section :ref:`libraries-and-filesystem`). - .. exn:: Compiled library @ident.vo makes inconsistent assumptions over library qualid. + .. exn:: Compiled library @ident.vo makes inconsistent assumptions over library @qualid. The command tried to load library file :n:`@ident`.vo that depends on some specific version of library :n:`@qualid` which is not the @@ -651,13 +561,13 @@ file is a particular case of module called *library file*. |Coq| compiled module, or it was compiled with an incompatible version of |Coq|. - .. exn:: The file :n:`@ident.vo` contains library dirpath and not library dirpath’. - - The library file :n:`@dirpath’` is indirectly required by the - ``Require`` command but it is bound in the current loadpath to the - file :n:`@ident.vo` which was bound to a different library name :token:`dirpath` at - the time it was compiled. + .. exn:: The file @ident.vo contains library @qualid__1 and not library @qualid__2. + The library :n:`@qualid__2` is indirectly required by a :cmd:`Require` or + :cmd:`From ... Require` command. The loadpath maps :n:`@qualid__2` to :n:`@ident.vo`, + which was compiled using a loadpath that bound it to :n:`@qualid__1`. Usually + the appropriate solution is to recompile :n:`@ident.v` using the correct loadpath. + See :ref:`libraries-and-filesystem`. .. warn:: Require inside a module is deprecated and strongly discouraged. You can Require a module at toplevel and optionally Import it inside another one. @@ -668,33 +578,26 @@ file is a particular case of module called *library file*. .. cmd:: Print Libraries This command displays the list of library files loaded in the - current |Coq| session. For each of these libraries, it also tells if it - is imported. - + current |Coq| session. .. cmd:: Declare ML Module {+ @string } - This commands loads the OCaml compiled files - with names given by the :token:`string` sequence - (dynamic link). It is mainly used to load tactics dynamically. The - files are searched into the current OCaml loadpath (see the - command :cmd:`Add ML Path`). - Loading of OCaml files is only possible under the bytecode version of - ``coqtop`` (i.e. ``coqtop`` called with option ``-byte``, see chapter - :ref:`thecoqcommands`), or when |Coq| has been compiled with a - version of OCaml that supports native Dynlink (≥ 3.11). + This commands dynamically loads OCaml compiled code from + a :n:`.mllib` file. + It is used to load plugins dynamically. The + files must be accessible in the current OCaml loadpath (see the + command :cmd:`Add ML Path`). The :n:`.mllib` suffix may be omitted. - .. cmdv:: Local Declare ML Module {+ @string } + This command is reserved for plugin developers, who should provide + a .v file containing the command. Users of the plugins will then generally + load the .v file. - This variant is not exported to the modules that import the module - where they occur, even if outside a section. + This command supports the :attr:`local` attribute. If present, + the listed files are not exported, even if they're outside a section. .. exn:: File not found on loadpath: @string. :undocumented: - .. exn:: Loading of ML object file forbidden in a native Coq. - :undocumented: - .. cmd:: Print ML Modules @@ -709,7 +612,7 @@ Loadpath ------------ Loadpaths are preferably managed using |Coq| command line options (see -Section `libraries-and-filesystem`) but there remain vernacular commands to manage them +Section :ref:`libraries-and-filesystem`) but there remain vernacular commands to manage them for practical purposes. Such commands are only meant to be issued in the toplevel, and using them in source files is discouraged. @@ -719,22 +622,27 @@ the toplevel, and using them in source files is discouraged. This command displays the current working directory. -.. cmd:: Cd @string +.. cmd:: Cd {? @string } - This command changes the current directory according to :token:`string` which - can be any valid path. + If :n:`@string` is specified, changes the current directory according to :token:`string` which + can be any valid path. Otherwise, it displays the current directory. - .. cmdv:: Cd - Is equivalent to Pwd. +.. cmd:: Add LoadPath @string as @dirpath + .. insertprodn dirpath dirpath -.. cmd:: Add LoadPath @string as @dirpath + .. prodn:: + dirpath ::= {* @ident . } @ident This command is equivalent to the command line option - :n:`-Q @string @dirpath`. It adds the physical directory string to the current - |Coq| loadpath and maps it to the logical directory dirpath. + :n:`-Q @string @dirpath`. It adds a mapping to the loadpath from + the logical name :n:`@dirpath` to the file system directory :n:`@string`. + * :n:`@dirpath` is a prefix of a module name. The module name hierarchy + follows the file system hierarchy. On Linux, for example, the prefix + `A.B.C` maps to the directory :n:`@string/B/C`. Avoid using spaces after a `.` in the + path because the parser will interpret that as the end of a command or tactic. .. cmd:: Add Rec LoadPath @string as @dirpath @@ -748,42 +656,24 @@ the toplevel, and using them in source files is discouraged. This command removes the path :n:`@string` from the current |Coq| loadpath. -.. cmd:: Print LoadPath - - This command displays the current |Coq| loadpath. - - .. cmdv:: Print LoadPath @dirpath +.. cmd:: Print LoadPath {? @dirpath } - Works as :cmd:`Print LoadPath` but displays only - the paths that extend the :n:`@dirpath` prefix. + This command displays the current |Coq| loadpath. If :n:`@dirpath` is specified, + displays only the paths that extend that prefix. .. cmd:: Add ML Path @string This command adds the path :n:`@string` to the current OCaml - loadpath (see the command `Declare ML Module`` in Section :ref:`compiled-files`). + loadpath (cf. :cmd:`Declare ML Module`). -.. cmd:: Print ML Path @string +.. cmd:: Print ML Path This command displays the current OCaml loadpath. This command makes sense only under the bytecode version of ``coqtop``, i.e. using option ``-byte`` - (see the command Declare ML Module in Section :ref:`compiled-files`). - -.. _locate-file: - -.. cmd:: Locate File @string - - This command displays the location of file string in the current - loadpath. Typically, string is a ``.cmo`` or ``.vo`` or ``.v`` file. - - -.. cmd:: Locate Library @dirpath - - This command gives the status of the |Coq| module dirpath. It tells if - the module is loaded and if not searches in the load path for a module - of logical name :n:`@dirpath`. + (cf. :cmd:`Declare ML Module`). .. _backtracking: @@ -806,30 +696,22 @@ interactively, they cannot be part of a vernacular file loaded via .. exn:: @ident: no such entry. :undocumented: - .. cmdv:: Reset Initial - - Goes back to the initial state, just after the start - of the interactive session. - +.. cmd:: Reset Initial -.. cmd:: Back + Goes back to the initial state, just after the start + of the interactive session. - This command undoes all the effects of the last vernacular command. - Commands read from a vernacular file via a :cmd:`Load` are considered as a - single command. Proof management commands are also handled by this - command (see Chapter :ref:`proofhandling`). For that, Back may have to undo more than - one command in order to reach a state where the proof management - information is available. For instance, when the last command is a - :cmd:`Qed`, the management information about the closed proof has been - discarded. In this case, :cmd:`Back` will then undo all the proof steps up to - the statement of this proof. - .. cmdv:: Back @num +.. cmd:: Back {? @num } - Undo :n:`@num` vernacular commands. As for Back, some extra - commands may be undone in order to reach an adequate state. For - instance Back :n:`@num` will not re-enter a closed proof, but rather go just - before that proof. + Undoes all the effects of the last :n:`@num @sentence`\s. If + :n:`@num` is not specified, the command undoes one sentence. + Sentences read from a `.v` file via a :cmd:`Load` are considered a + single sentence. While :cmd:`Back` can undo tactics and commands executed + within proof mode, once you exit proof mode, such as with :cmd:`Qed`, all + the statements executed within are thereafter considered a single sentence. + :cmd:`Back` immediately following :cmd:`Qed` gets you back to the state + just after the statement of the proof. .. exn:: Invalid backtrack. @@ -850,18 +732,17 @@ interactively, they cannot be part of a vernacular file loaded via Quitting and debugging -------------------------- - .. cmd:: Quit - This command permits to quit |Coq|. + Causes |Coq| to exit. Valid only in coqtop. .. cmd:: Drop - This is used mostly as a debug facility by |Coq|’s implementers and does - not concern the casual user. This command permits to leave |Coq| - temporarily and enter the OCaml toplevel. The OCaml - command: + This command temporarily enters the OCaml toplevel. + It is a debug facility used by |Coq|’s implementers. Valid only in the + bytecode version of coqtop. + The OCaml command: :: @@ -886,49 +767,53 @@ Quitting and debugging (see Section `customization-by-environment-variables`). -.. TODO : command is not a syntax entry - -.. cmd:: Time @command +.. cmd:: Time @sentence - This command executes the vernacular command :n:`@command` and displays the + Executes :n:`@sentence` and displays the time needed to execute it. -.. cmd:: Redirect @string @command +.. cmd:: Redirect @string @sentence - This command executes the vernacular command :n:`@command`, redirecting its - output to ":n:`@string`.out". + Executes :n:`@sentence`, redirecting its + output to the file ":n:`@string`.out". -.. cmd:: Timeout @num @command +.. cmd:: Timeout @num @sentence - This command executes the vernacular command :n:`@command`. If the command - has not terminated after the time specified by the :n:`@num` (time - expressed in seconds), then it is interrupted and an error message is + Executes :n:`@sentence`. If the operation + has not terminated after :n:`@num` seconds, then it is interrupted and an error message is displayed. .. opt:: Default Timeout @num :name: Default Timeout - This option controls a default timeout for subsequent commands, as if they - were passed to a :cmd:`Timeout` command. Commands already starting by a - :cmd:`Timeout` are unaffected. + If set, each :n:`@sentence` is treated as if it was prefixed with :cmd:`Timeout` :n:`@num`, + except for :cmd:`Timeout` commands themselves. If unset, + no timeout is applied. -.. cmd:: Fail @command +.. cmd:: Fail @sentence For debugging scripts, sometimes it is desirable to know whether a - command or a tactic fails. If the given :n:`@command` fails, then - :n:`Fail @command` succeeds (excepts in the case of - critical errors, like a "stack overflow"), without changing the - proof state, and in interactive mode, the system prints a message + command or a tactic fails. If :n:`@sentence` fails, then + :n:`Fail @sentence` succeeds (except for + critical errors, such as "stack overflow"), without changing the + proof state. In interactive mode, the system prints a message confirming the failure. .. exn:: The command has not failed! - If the given :n:`@command` succeeds, then :n:`Fail @command` + If the given :n:`@command` succeeds, then :n:`Fail @sentence` fails with this error message. +.. note:: + + :cmd:`Time`, :cmd:`Redirect`, :cmd:`Timeout` and :cmd:`Fail` are + :production:`control_command`\s. For these commands, attributes and goal + selectors, when specified, are part of the :n:`@sentence` argument, and thus come after + the control command prefix and before the inner command or tactic. For + example: `Time #[ local ] Definition foo := 0.` or `Fail Timeout 10 all: auto.` .. _controlling-display: @@ -1010,13 +895,16 @@ as numbers, and for reflection-based tactics. The commands to fine- tune the reduction strategies and the lazy conversion algorithm are described first. -.. cmd:: Opaque {+ @qualid } +.. cmd:: Opaque {+ @smart_qualid } + + This command accepts the :attr:`global` attribute. By default, the scope + of :cmd:`Opaque` is limited to the current section or module. This command has an effect on unfoldable constants, i.e. on constants defined by :cmd:`Definition` or :cmd:`Let` (with an explicit body), or by a command assimilated to a definition such as :cmd:`Fixpoint`, :cmd:`Program Definition`, etc, or by a proof ended by :cmd:`Defined`. The command tells not to unfold the - constants in the :n:`@qualid` sequence in tactics using δ-conversion (unfolding + constants in the :n:`@smart_qualid` sequence in tactics using δ-conversion (unfolding a constant is replacing it by its definition). :cmd:`Opaque` has also an effect on the conversion algorithm of |Coq|, telling @@ -1024,24 +912,15 @@ described first. has to check the conversion (see Section :ref:`conversion-rules`) of two distinct applied constants. - .. cmdv:: Global Opaque {+ @qualid } - :name: Global Opaque - - The scope of :cmd:`Opaque` is limited to the current section, or current - file, unless the variant :cmd:`Global Opaque` is used. - .. seealso:: Sections :ref:`performingcomputations`, :ref:`tactics-automating`, :ref:`proof-editing-mode` - .. exn:: The reference @qualid was not found in the current environment. +.. cmd:: Transparent {+ @smart_qualid } - There is no constant referred by :n:`@qualid` in the environment. - Nevertheless, if you asked :cmd:`Opaque` `foo` `bar` and if `bar` does - not exist, `foo` is set opaque. - -.. cmd:: Transparent {+ @qualid } + This command accepts the :attr:`global` attribute. By default, the scope + of :cmd:`Transparent` is limited to the current section or module. This command is the converse of :cmd:`Opaque` and it applies on unfoldable constants to restore their unfoldability after an Opaque command. @@ -1054,16 +933,9 @@ described first. the usual defined constants, whose actual values are of course relevant in general. - .. cmdv:: Global Transparent {+ @qualid } - :name: Global Transparent - - The scope of Transparent is limited to the current section, or current - file, unless the variant :cmd:`Global Transparent` is - used. - .. exn:: The reference @qualid was not found in the current environment. - There is no constant referred by :n:`@qualid` in the environment. + There is no constant named :n:`@qualid` in the environment. .. seealso:: @@ -1072,63 +944,66 @@ described first. .. _vernac-strategy: -.. cmd:: Strategy @level [ {+ @qualid } ] +.. cmd:: Strategy {+ @strategy_level [ {+ @smart_qualid } ] } + + .. insertprodn strategy_level strategy_level - This command generalizes the behavior of Opaque and Transparent + .. prodn:: + strategy_level ::= opaque + | @int + | expand + | transparent + + This command accepts the :attr:`local` attribute, which limits its effect + to the current section or module, in which case the section and module + behavior is the same as :cmd:`Opaque` and :cmd:`Transparent` (without :attr:`global`). + + This command generalizes the behavior of the :cmd:`Opaque` and :cmd:`Transparent` commands. It is used to fine-tune the strategy for unfolding constants, both at the tactic level and at the kernel level. This - command associates a level to the qualified names in the :n:`@qualid` + command associates a :n:`@strategy_level` with the qualified names in the :n:`@smart_qualid` sequence. Whenever two expressions with two distinct head constants are compared (for instance, this comparison can be triggered by a type cast), the one with lower level is expanded first. In case of a tie, the second one (appearing in the cast type) is expanded. - .. prodn:: level ::= {| opaque | @num | expand } - Levels can be one of the following (higher to lower): + ``opaque`` : level of opaque constants. They cannot be expanded by tactics (behaves like +∞, see next item). - + :n:`@num` : levels indexed by an integer. Level 0 corresponds to the + + :n:`@int` : levels indexed by an integer. Level 0 corresponds to the default behavior, which corresponds to transparent constants. This - level can also be referred to as transparent. Negative levels + level can also be referred to as ``transparent``. Negative levels correspond to constants to be expanded before normal transparent constants, while positive levels correspond to constants to be expanded after normal transparent constants. + ``expand`` : level of constants that should be expanded first (behaves like −∞) + + ``transparent`` : Equivalent to level 0 - .. cmdv:: Local Strategy @level [ {+ @qualid } ] - - These directives survive section and module closure, unless the - command is prefixed by ``Local``. In the latter case, the behavior - regarding sections and modules is the same as for the :cmd:`Transparent` and - :cmd:`Opaque` commands. +.. cmd:: Print Strategy @smart_qualid - -.. cmd:: Print Strategy @qualid - - This command prints the strategy currently associated to :n:`@qualid`. It - fails if :n:`@qualid` is not an unfoldable reference, that is, neither a + This command prints the strategy currently associated with :n:`@smart_qualid`. It + fails if :n:`@smart_qualid` is not an unfoldable reference, that is, neither a variable nor a constant. .. exn:: The reference is not unfoldable. :undocumented: - .. cmdv:: Print Strategies +.. cmd:: Print Strategies - Print all the currently non-transparent strategies. + Print all the currently non-transparent strategies. .. cmd:: Declare Reduction @ident := @red_expr - This command allows giving a short name to a reduction expression, for + Declares a short name for the reduction expression :n:`@red_expr`, for instance ``lazy beta delta [foo bar]``. This short name can then be used - in :n:`Eval @ident in` or ``eval`` directives. This command - accepts the - ``Local`` modifier, for discarding this reduction name at the end of the - file or module. For the moment, the name is not qualified. In + in :n:`Eval @ident in` or ``eval`` constructs. This command + accepts the :attr:`local` attribute, which indicates that the reduction + will be discarded at the end of the + file or module. The name is not qualified. In particular declaring the same name in several modules or in several functor applications will be rejected if these declarations are not local. The name :n:`@ident` cannot be used directly as an Ltac tactic, but @@ -1222,6 +1097,8 @@ Controlling Typing Flags Print the status of the three typing flags: guard checking, positivity checking and universe checking. +See also :flag:`Cumulative StrictProp` in the |SProp| chapter. + .. example:: .. coqtop:: all reset @@ -1274,14 +1151,15 @@ in support libraries of plug-ins. .. _exposing-constants-to-ocaml-libraries: Exposing constants to OCaml libraries -```````````````````````````````````````````````````````````````` +````````````````````````````````````` .. cmd:: Register @qualid__1 as @qualid__2 - This command exposes the constant :n:`@qualid__1` to OCaml libraries under - the name :n:`@qualid__2`. This constant can then be dynamically located - calling :n:`Coqlib.lib_ref "@qualid__2"`; i.e., there is no need to known - where is the constant defined (file, module, library, etc.). + Makes the constant :n:`@qualid__1` accessible to OCaml libraries under + the name :n:`@qualid__2`. The constant can then be dynamically located + in OCaml code by + calling :n:`Coqlib.lib_ref "@qualid__2"`. The OCaml code doesn't need + to know where the constant is defined (what file, module, library, etc.). As a special case, when the first segment of :n:`@qualid__2` is :g:`kernel`, the constant is exposed to the kernel. For instance, the `Int63` module @@ -1291,27 +1169,41 @@ Exposing constants to OCaml libraries Register bool as kernel.ind_bool. - This makes the kernel aware of what is the type of boolean values. This - information is used for instance to define the return type of the - :g:`#int63_eq` primitive. + This makes the kernel aware of the `bool` type, which is used, for example, + to define the return type of the :g:`#int63_eq` primitive. .. seealso:: :ref:`primitive-integers` Inlining hints for the fast reduction machines -```````````````````````````````````````````````````````````````` +`````````````````````````````````````````````` .. cmd:: Register Inline @qualid - This command gives as a hint to the reduction machines (VM and native) that + Gives a hint to the reduction machines (VM and native) that the body of the constant :n:`@qualid` should be inlined in the generated code. Registering primitive operations ```````````````````````````````` -.. cmd:: Primitive @ident__1 := #@ident__2. +.. cmd:: Primitive @ident {? : @term } := #@ident__prim + + Makes the primitive type or primitive operator :n:`#@ident__prim` defined in OCaml + accessible in |Coq| commands and tactics. + For internal use by implementors of |Coq|'s standard library or standard library + replacements. No space is allowed after the `#`. Invalid values give a syntax + error. + + For example, the standard library files `Int63.v` and `PrimFloat.v` use :cmd:`Primitive` + to support, respectively, the features described in :ref:`primitive-integers` and + :ref:`primitive-floats`. + + The types associated with an operator must be declared to the kernel before declaring operations + that use the type. Do this with :cmd:`Primitive` for primitive types and + :cmd:`Register` with the :g:`kernel` prefix for other types. For example, + in `Int63.v`, `#int63_type` must be declared before the associated operations. + + .. exn:: The type @ident must be registered before this construction can be typechecked. + :undocumented: - Declares :n:`@ident__1` as the primitive operator :n:`#@ident__2`. When - running this command, the type of the primitive should be already known by - the kernel (this is achieved through this command for primitive types and - through the :cmd:`Register` command with the :g:`kernel` name-space for other - types). + The type must be defined with :cmd:`Primitive` command before this + :cmd:`Primitive` command (declaring an operation using the type) will succeed. diff --git a/doc/sphinx/std-glossindex.rst b/doc/sphinx/std-glossindex.rst new file mode 100644 index 0000000000..3f085ca737 --- /dev/null +++ b/doc/sphinx/std-glossindex.rst @@ -0,0 +1,7 @@ +:orphan: + +.. hack to get index in TOC + +-------------- +Glossary index +-------------- diff --git a/doc/sphinx/user-extensions/proof-schemes.rst b/doc/sphinx/user-extensions/proof-schemes.rst index 34197c4fcf..e05be7c2c2 100644 --- a/doc/sphinx/user-extensions/proof-schemes.rst +++ b/doc/sphinx/user-extensions/proof-schemes.rst @@ -190,146 +190,7 @@ Combined Scheme Check tree_forest_mutrect. -.. _functional-scheme: - -Generation of induction principles with ``Functional`` ``Scheme`` ------------------------------------------------------------------ - - -.. cmd:: Functional Scheme @ident__0 := Induction for @ident' Sort @sort {* with @ident__i := Induction for @ident__i' Sort @sort} - - This command is a high-level experimental tool for - generating automatically induction principles corresponding to - (possibly mutually recursive) functions. First, it must be made - available via ``Require Import FunInd``. - Each :n:`@ident__i` is a different mutually defined function - name (the names must be in the same order as when they were defined). This - command generates the induction principle for each :n:`@ident__i`, following - the recursive structure and case analyses of the corresponding function - :n:`@ident__i'`. - -.. warning:: - - There is a difference between induction schemes generated by the command - :cmd:`Functional Scheme` and these generated by the :cmd:`Function`. Indeed, - :cmd:`Function` generally produces smaller principles that are closer to how - a user would implement them. See :ref:`advanced-recursive-functions` for details. - -.. example:: - - Induction scheme for div2. - - We define the function div2 as follows: - - .. coqtop:: all - - Require Import FunInd. - Require Import Arith. - - Fixpoint div2 (n:nat) : nat := - match n with - | O => 0 - | S O => 0 - | S (S n') => S (div2 n') - end. - - The definition of a principle of induction corresponding to the - recursive structure of `div2` is defined by the command: - - .. coqtop:: all - - Functional Scheme div2_ind := Induction for div2 Sort Prop. - - You may now look at the type of div2_ind: - - .. coqtop:: all - - Check div2_ind. - - We can now prove the following lemma using this principle: - - .. coqtop:: all - - Lemma div2_le' : forall n:nat, div2 n <= n. - intro n. - pattern n, (div2 n). - apply div2_ind; intros. - auto with arith. - auto with arith. - simpl; auto with arith. - Qed. - - We can use directly the functional induction (:tacn:`function induction`) tactic instead - of the pattern/apply trick: - - .. coqtop:: all - - Reset div2_le'. - - Lemma div2_le : forall n:nat, div2 n <= n. - intro n. - functional induction (div2 n). - auto with arith. - auto with arith. - auto with arith. - Qed. - -.. example:: - - Induction scheme for tree_size. - - We define trees by the following mutual inductive type: - - .. original LaTeX had "Variable" instead of "Axiom", which generates an ugly warning - - .. coqtop:: reset all - - Axiom A : Set. - - Inductive tree : Set := - node : A -> forest -> tree - with forest : Set := - | empty : forest - | cons : tree -> forest -> forest. - - We define the function tree_size that computes the size of a tree or a - forest. Note that we use ``Function`` which generally produces better - principles. - - .. coqtop:: all - - Require Import FunInd. - - Function tree_size (t:tree) : nat := - match t with - | node A f => S (forest_size f) - end - with forest_size (f:forest) : nat := - match f with - | empty => 0 - | cons t f' => (tree_size t + forest_size f') - end. - - Notice that the induction principles ``tree_size_ind`` and ``forest_size_ind`` - generated by ``Function`` are not mutual. - - .. coqtop:: all - - Check tree_size_ind. - - Mutual induction principles following the recursive structure of ``tree_size`` - and ``forest_size`` can be generated by the following command: - - .. coqtop:: all - - Functional Scheme tree_size_ind2 := Induction for tree_size Sort Prop - with forest_size_ind2 := Induction for forest_size Sort Prop. - - You may now look at the type of `tree_size_ind2`: - - .. coqtop:: all - - Check tree_size_ind2. +.. seealso:: :ref:`functional-scheme` .. _derive-inversion: diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index 669975ba7e..93d2439412 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -1,7 +1,7 @@ -.. _syntaxextensionsandinterpretationscopes: +.. _syntaxextensionsandnotationscopes: -Syntax extensions and interpretation scopes -======================================================== +Syntax extensions and notation scopes +===================================== In this chapter, we introduce advanced commands to modify the way Coq parses and prints objects, i.e. the translations between the concrete @@ -14,7 +14,7 @@ variant of :cmd:`Notation` which does not modify the parser; this provides a form of :ref:`abbreviation <Abbreviations>`. It is sometimes expected that the same symbolic notation has different meanings in different contexts; to achieve this form of overloading, |Coq| offers a notion -of :ref:`interpretation scopes <Scopes>`. +of :ref:`notation scopes <Scopes>`. The main command to provide custom notations for tactics is :cmd:`Tactic Notation`. .. coqtop:: none @@ -26,33 +26,43 @@ The main command to provide custom notations for tactics is :cmd:`Tactic Notatio Notations --------- + Basic notations ~~~~~~~~~~~~~~~ -.. cmd:: Notation +.. cmd:: Notation @string := @one_term {? ( {+, @syntax_modifier } ) } {? : @scope_name } + + Defines a *notation*, an alternate syntax for entering or displaying + a specific term or term pattern. + + This command supports the :attr:`local` attribute, which limits its effect to the + current module. + If the command is inside a section, its effect is limited to the section. - A *notation* is a symbolic expression denoting some term or term - pattern. + Specifying :token:`scope_name` associates the notation with that scope. Otherwise + it is a *lonely notation*, that is, not associated with a scope. -A typical notation is the use of the infix symbol ``/\`` to denote the -logical conjunction (and). Such a notation is declared by + .. todo indentation of this chapter is not consistent with other chapters. Do we have a standard? + +For example, the following definition permits using the infix expression :g:`A /\ B` +to represent :g:`(and A B)`: .. coqtop:: in Notation "A /\ B" := (and A B). -The expression :g:`(and A B)` is the abbreviated term and the string :g:`"A /\ B"` -(called a *notation*) tells how it is symbolically written. +:g:`"A /\ B"` is a *notation*, which tells how to represent the abbreviated term +:g:`(and A B)`. -A notation is always surrounded by double quotes (except when the +Notations must be in double quotes, except when the abbreviation has the form of an ordinary applicative expression; -see :ref:`Abbreviations`). The notation is composed of *tokens* separated by -spaces. Identifiers in the string (such as ``A`` and ``B``) are the *parameters* -of the notation. Each of them must occur at least once in the denoted term. The +see :ref:`Abbreviations`. The notation consists of *tokens* separated by +spaces. Alphanumeric strings (such as ``A`` and ``B``) are the *parameters* +of the notation. Each of them must occur at least once in the abbreviated term. The other elements of the string (such as ``/\``) are the *symbols*. -An identifier can be used as a symbol but it must be surrounded by -single quotes to avoid the confusion with a parameter. Similarly, +Substrings enclosed in single quotes are treated as literals. This is necessary +for substrings that would otherwise be interpreted as :n:`@ident`\s. Similarly, every symbol of at least 3 characters and starting with a simple quote must be quoted (then it starts by two single quotes). Here is an example. @@ -63,7 +73,8 @@ example. A notation binds a syntactic expression to a term. Unless the parser and pretty-printer of Coq already know how to deal with the syntactic -expression (see :ref:`ReservingNotations`), explicit precedences and +expression (such as through :cmd:`Reserved Notation` or for notations +that contain only literals), explicit precedences and associativity rules have to be given. .. note:: @@ -104,13 +115,12 @@ Similarly, an associativity is needed to decide whether :g:`True /\ False /\ Fal defaults to :g:`True /\ (False /\ False)` (right associativity) or to :g:`(True /\ False) /\ False` (left associativity). We may even consider that the expression is not well-formed and that parentheses are mandatory (this is a “no -associativity”) [#no_associativity]_. We do not know of a special convention of -the associativity of disjunction and conjunction, so let us apply for instance a +associativity”) [#no_associativity]_. We do not know of a special convention for +the associativity of disjunction and conjunction, so let us apply right associativity (which is the choice of Coq). -Precedence levels and associativity rules of notations have to be -given between parentheses in a list of :token:`modifiers` that the :cmd:`Notation` -command understands. Here is how the previous examples refine. +Precedence levels and associativity rules of notations are specified with a list of +parenthesized :n:`@syntax_modifier`\s. Here is how the previous examples refine: .. coqtop:: in @@ -158,8 +168,8 @@ One can also define notations for binders. Notation "{ x : A | P }" := (sig A (fun x => P)). In the last case though, there is a conflict with the notation for -type casts. The notation for types casts, as shown by the command :cmd:`Print -Grammar constr` is at level 100. To avoid ``x : A`` being parsed as a type cast, +type casts. The notation for type casts, as shown by the command :cmd:`Print +Grammar` `constr` is at level 100. To avoid ``x : A`` being parsed as a type cast, it is necessary to put ``x`` at a level below 100, typically 99. Hence, a correct definition is the following: @@ -204,16 +214,6 @@ have to be observed for notations starting with a symbol, e.g., rules starting with “\ ``{``\ ” or “\ ``(``\ ” should be put at level 0. The list of Coq predefined notations can be found in the chapter on :ref:`thecoqlibrary`. -.. cmd:: Print Grammar constr. - - This command displays the current state of the Coq term parser. - -.. cmd:: Print Grammar pattern. - - This displays the state of the subparser of patterns (the parser used in the - grammar of the ``match with`` constructions). - - Displaying symbolic notations ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -252,8 +252,7 @@ bar of the notation. Check (sig (fun x : nat => x=x)). -The second, more powerful control on printing is by using the format -:token:`modifier`. Here is an example +The second, more powerful control on printing is by using :n:`@syntax_modifier`\s. Here is an example .. coqtop:: all @@ -301,8 +300,8 @@ expression is performed at definition time. Type checking is done only at the time of use of the notation. .. note:: Sometimes, a notation is expected only for the parser. To do - so, the option ``only parsing`` is allowed in the list of :token:`modifiers` - of :cmd:`Notation`. Conversely, the ``only printing`` :token:`modifier` can be + so, the option ``only parsing`` is allowed in the list of :n:`@syntax_modifier`\s + in :cmd:`Notation`. Conversely, the ``only printing`` :n:`@syntax_modifier` can be used to declare that a notation should only be used for printing and should not declare a parsing rule. In particular, such notations do not modify the parser. @@ -313,13 +312,14 @@ The Infix command The :cmd:`Infix` command is a shortcut for declaring notations for infix symbols. -.. cmd:: Infix @string := @term {? (@modifiers) } +.. cmd:: Infix @string := @one_term {? ( {+, @syntax_modifier } ) } {? : @scope_name } This command is equivalent to - :n:`Notation "x @symbol y" := (@term x y) {? (@modifiers) }.` + :n:`Notation "x @string y" := (@one_term x y) {? ( {+, @syntax_modifier } ) } {? : @scope_name }` - where ``x`` and ``y`` are fresh names. Here is an example. + where ``x`` and ``y`` are fresh names and omitting the quotes around :n:`@string`. + Here is an example: .. coqtop:: in @@ -330,7 +330,7 @@ symbols. Reserving notations ~~~~~~~~~~~~~~~~~~~ -.. cmd:: Reserved Notation @string {? (@modifiers) } +.. cmd:: Reserved Notation @string {? ( {+, @syntax_modifier } ) } A given notation may be used in different contexts. Coq expects all uses of the notation to be defined at the same precedence and with the @@ -349,26 +349,34 @@ Reserving notations .. note:: The notations mentioned in the module :ref:`init-notations` are reserved. Hence their precedence and associativity cannot be changed. - .. cmdv:: Reserved Infix "@symbol" {* @modifiers} + .. cmd:: Reserved Infix @string {? ( {+, @syntax_modifier } ) } This command declares an infix parsing rule without giving its interpretation. - When a format is attached to a reserved notation, it is used by + When a format is attached to a reserved notation (with the `format` + :token:`syntax_modifier`), it is used by default by all subsequent interpretations of the corresponding - notation. A specific interpretation can provide its own format - overriding the default format though. + notation. Individual interpretations can override the format. Simultaneous definition of terms and notations ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Thanks to reserved notations, the inductive, co-inductive, record, recursive and -corecursive definitions can benefit from customized notations. To do this, insert -a ``where`` notation clause after the definition of the (co)inductive type or +Thanks to reserved notations, inductive, co-inductive, record, recursive and +corecursive definitions can use customized notations. To do this, insert +a :token:`decl_notations` clause after the definition of the (co)inductive type or (co)recursive term (or after the definition of each of them in case of mutual definitions). The exact syntax is given by :n:`@decl_notation` for inductive, co-inductive, recursive and corecursive definitions and in :ref:`record-types` -for records. Here are examples: +for records. + + .. insertprodn decl_notations decl_notation + + .. prodn:: + decl_notations ::= where @decl_notation {* and @decl_notation } + decl_notation ::= @string := @one_term {? ( only parsing ) } {? : @scope_name } + +Here are examples: .. coqtop:: in @@ -403,8 +411,31 @@ Displaying information about notations .. seealso:: - :flag:`Printing All` - To disable other elements in addition to notations. + :flag:`Printing All` to disable other elements in addition to notations. + + +.. cmd:: Print Grammar @ident + + Shows the grammar for the nonterminal :token:`ident`, which must be one of the following: + + - `constr` - for :token:`term`\s + - `pattern` - for :token:`pattern`\s + - `tactic` - for currently-defined tactic notations, :token:`tactic`\s and tacticals + (corresponding to :token:`ltac_expr` in the documentation). + - `vernac` - for :token:`command`\s + + The first three of these give the precedence and associativity for each construct. + For example, these lines printed by `Print Grammar tactic` indicates that the `try` construct + is at level 3 and right-associative. `SELF` represents the `tactic_expr` nonterminal + at level 5 (the top level):: + + | "3" RIGHTA + [ IDENT "try"; SELF + + Note that the productions printed by this command are represented in the form used by + |Coq|'s parser (coqpp), which differs from how productions are shown in the documentation. The grammar + described in this documentation is equivalent to the grammar of the |Coq| parser, but has been + heavily edited to improve readability and presentation. .. _locating-notations: @@ -427,7 +458,7 @@ Inheritance of the properties of arguments of constants bound to a notation If the right-hand side of a notation is a partially applied constant, the notation inherits the implicit arguments (see -:ref:`ImplicitArguments`) and interpretation scopes (see +:ref:`ImplicitArguments`) and notation scopes (see :ref:`Scopes`) of the constant. For instance: .. coqtop:: in reset @@ -441,7 +472,7 @@ the notation inherits the implicit arguments (see As an exception, if the right-hand side is just of the form :n:`@@qualid`, this conventionally stops the inheritance of implicit -arguments (but not of interpretation scopes). +arguments (but not of notation scopes). Notations and binders ~~~~~~~~~~~~~~~~~~~~~ @@ -471,7 +502,7 @@ application of the notation: Check sigma z : nat, z = 0. -Notice the :token:`modifier` ``x ident`` in the declaration of the +Note the :n:`@syntax_modifier x ident` in the declaration of the notation. It tells to parse :g:`x` as a single identifier. Binders bound in the notation and parsed as patterns @@ -491,7 +522,7 @@ binder. Here is an example: Check subset '(x,y), x+y=0. -The :token:`modifier` ``p pattern`` in the declaration of the notation tells to parse +The :n:`@syntax_modifier p pattern` in the declaration of the notation tells to parse :g:`p` as a pattern. Note that a single variable is both an identifier and a pattern, so, e.g., the following also works: @@ -501,7 +532,7 @@ pattern, so, e.g., the following also works: If one wants to prevent such a notation to be used for printing when the pattern is reduced to a single identifier, one has to use instead -the :token:`modifier` ``p strict pattern``. For parsing, however, a +the :n:`@syntax_modifier p strict pattern`. For parsing, however, a ``strict pattern`` will continue to include the case of a variable. Here is an example showing the difference: @@ -541,7 +572,7 @@ that ``x`` is parsed as a term at level 99 (as done in the notation for :g:`sumbool`), but that this term has actually to be an identifier. The notation :g:`{ x | P }` is already defined in the standard -library with the ``as ident`` :token:`modifier`. We cannot redefine it but +library with the ``as ident`` :n:`@syntax_modifier`. We cannot redefine it but one can define an alternative notation, say :g:`{ p such that P }`, using instead ``as pattern``. @@ -561,7 +592,7 @@ is just an identifier, one could have said ``p at level 99 as strict pattern``. Note also that in the absence of a ``as ident``, ``as strict pattern`` or -``as pattern`` :token:`modifier`\s, the default is to consider sub-expressions occurring +``as pattern`` :n:`@syntax_modifier`\s, the default is to consider sub-expressions occurring in binding position and parsed as terms to be ``as ident``. .. _NotationsWithBinders: @@ -640,7 +671,7 @@ and the terminating expression is ``nil``. Here are other examples: Notations with recursive patterns can be reserved like standard notations, they can also be declared within -:ref:`interpretation scopes <Scopes>`. +:ref:`notation scopes <Scopes>`. .. _RecursiveNotationsWithBinders: @@ -662,7 +693,7 @@ except that in the iterator position of the binding variable of a ``fun`` or a ``forall``. To specify that the part “``x .. y``” of the notation parses a sequence of -binders, ``x`` and ``y`` must be marked as ``binder`` in the list of :token:`modifiers` +binders, ``x`` and ``y`` must be marked as ``binder`` in the list of :n:`@syntax_modifier`\s of the notation. The binders of the parsed sequence are used to fill the occurrences of the first placeholder of the iterating pattern which is repeatedly nested as many times as the number of binders generated. If ever the @@ -740,10 +771,13 @@ Custom entries .. cmd:: Declare Custom Entry @ident - This command allows to define new grammar entries, called *custom + Defines new grammar entries, called *custom entries*, that can later be referred to using the entry name :n:`custom @ident`. + This command supports the :attr:`local` attribute, which limits the entry to the + current module. + .. example:: For instance, we may want to define an ad hoc @@ -887,67 +921,48 @@ gives a way to let any arbitrary expression which is not handled by the custom entry ``expr`` be parsed or printed by the main grammar of term up to the insertion of a pair of curly brackets. -.. cmd:: Print Custom Grammar @ident. +.. cmd:: Print Custom Grammar @ident :name: Print Custom Grammar This displays the state of the grammar for terms associated to the custom entry :token:`ident`. -Summary -~~~~~~~ - .. _NotationSyntax: -Syntax of notations -+++++++++++++++++++ - -The different syntactic forms taken by the commands declaring -notations are given below. The optional :production:`scope` is described in -:ref:`Scopes`. - -.. productionlist:: coq - notation : [Local] Notation `string` := `term` [(`modifiers`)] [: `scope`]. - : [Local] Infix `string` := `qualid` [(`modifiers`)] [: `scope`]. - : [Local] Reserved Notation `string` [(`modifiers`)] . - : Inductive `ind_body` [`decl_notations`] with … with `ind_body` [`decl_notations`]. - : CoInductive `ind_body` [`decl_notations`] with … with `ind_body` [`decl_notations`]. - : Fixpoint `fix_body` [`decl_notations`] with … with `fix_body` [`decl_notations`]. - : CoFixpoint `fix_body` [`decl_notations`] with … with `fix_body` [`decl_notations`]. - : [Local] Declare Custom Entry `ident`. - modifiers : `modifier`, … , `modifier` - modifier : 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` - 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`] - binderinterp : as ident - : as pattern - : as strict pattern - -.. insertprodn decl_notations decl_notation - -.. prodn:: - decl_notations ::= where @decl_notation {* and @decl_notation } - decl_notation ::= @string := @one_term {? ( only parsing ) } {? : @ident } +Syntax +~~~~~~~ + +Here are the syntax elements used by the various notation commands. + + .. insertprodn syntax_modifier level + + .. prodn:: + syntax_modifier ::= at level @num + | in custom @ident {? at level @num } + | {+, @ident } at @level + | @ident at @level {? @binder_interp } + | @ident @explicit_subentry + | @ident @binder_interp + | left associativity + | right associativity + | no associativity + | only parsing + | only printing + | format @string {? @string } + explicit_subentry ::= ident + | global + | bigint + | strict pattern {? at level @num } + | binder + | closed binder + | constr {? at @level } {? @binder_interp } + | custom @ident {? at @level } {? @binder_interp } + | pattern {? at level @num } + binder_interp ::= as ident + | as pattern + | as strict pattern + level ::= level @num + | next level .. 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. @@ -981,101 +996,86 @@ notations are given below. The optional :production:`scope` is described in due to legacy notation in the Coq standard library. It can be turned on with the ``-w disj-pattern-notation`` flag. -Persistence of notations -++++++++++++++++++++++++ - -Notations disappear when a section is closed. - -.. cmd:: Local Notation @notation +.. _Scopes: - Notations survive modules unless the command ``Local Notation`` is used instead - of :cmd:`Notation`. +Notation scopes +--------------- -.. cmd:: Local Declare Custom Entry @ident +A *notation scope* is a set of notations for terms with their +interpretations. Notation scopes provide a weak, purely +syntactic form of notation overloading: a symbol may +refer to different definitions depending on which notation scopes +are currently open. For instance, the infix symbol ``+`` can be +used to refer to distinct definitions of the addition operator, +such as for natural numbers, integers or reals. +Notation scopes can include an interpretation for numerals and +strings with the :cmd:`Numeral Notation` and :cmd:`String Notation` commands. - Custom entries survive modules unless the command ``Local Declare - Custom Entry`` is used instead of :cmd:`Declare Custom Entry`. + .. insertprodn scope scope_key -.. _Scopes: + .. prodn:: + scope ::= @scope_name + | @scope_key + scope_name ::= @ident + scope_key ::= @ident -Interpretation scopes ----------------------- +Each notation scope has a single :token:`scope_name`, which by convention +ends with the suffix "_scope", as in "nat_scope". One or more :token:`scope_key`\s +(delimiting keys) may be associated with a notation scope with the :cmd:`Delimit Scope` command. +Most commands use :token:`scope_name`; :token:`scope_key`\s are used within :token:`term`\s. -An *interpretation scope* is a set of notations for terms with their -interpretations. Interpretation scopes provide a weak, purely -syntactical form of notation overloading: the same notation, for -instance the infix symbol ``+``, can be used to denote distinct -definitions of the additive operator. Depending on which interpretation -scopes are currently open, the interpretation is different. -Interpretation scopes can include an interpretation for numerals and -strings, either at the OCaml level or using :cmd:`Numeral Notation` -or :cmd:`String Notation`. +.. cmd:: Declare Scope @scope_name -.. cmd:: Declare Scope @scope - - This adds a new scope named :n:`@scope`. Note that the initial - state of Coq declares by default the following interpretation scopes: + Declares a new notation scope. Note that the initial + state of Coq declares the following notation scopes: ``core_scope``, ``type_scope``, ``function_scope``, ``nat_scope``, ``bool_scope``, ``list_scope``, ``int_scope``, ``uint_scope``. -The syntax to associate a notation to a scope is given -:ref:`above <NotationSyntax>`. Here is a typical example which declares the -notation for conjunction in the scope ``type_scope``. - -.. coqtop:: in - - Notation "A /\ B" := (and A B) : type_scope. - -.. note:: A notation not defined in a scope is called a *lonely* - notation. No example of lonely notations can be found in the - initial state of Coq though. - + Use commands such as :cmd:`Notation` to add notations to the scope. Global interpretation rules for notations ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ At any time, the interpretation of a notation for a term is done within -a *stack* of interpretation scopes and lonely notations. In case a -notation has several interpretations, the actual interpretation is the -one defined by (or in) the more recently declared (or opened) lonely -notation (or interpretation scope) which defines this notation. -Typically if a given notation is defined in some scope ``scope`` but has -also an interpretation not assigned to a scope, then, if ``scope`` is open -before the lonely interpretation is declared, then the lonely -interpretation is used (and this is the case even if the -interpretation of the notation in scope is given after the lonely -interpretation: otherwise said, only the order of lonely -interpretations and opening of scopes matters, and not the declaration -of interpretations within a scope). +a *stack* of notation scopes and lonely notations. If a +notation is defined in multiple scopes, |Coq| uses the interpretation from +the most recently opened notation scope or declared lonely notation. -.. cmd:: Open Scope @scope +Note that "stack" is a misleading name. Each scope or lonely notation can only appear in +the stack once. New items are pushed onto the top of the stack, except that +adding a item that's already in the stack moves it to the top of the stack instead. +Scopes are removed by name (e.g. by :cmd:`Close Scope`) wherever they are in the +stack, rather than through "pop" operations. - The command to add a scope to the interpretation scope stack is - :n:`Open Scope @scope`. +Use the :cmd:`Print Visibility` command to display the current notation scope stack. -.. cmd:: Close Scope @scope +.. cmd:: Open Scope @scope - It is also possible to remove a scope from the interpretation scope - stack by using the command :n:`Close Scope @scope`. + Adds a scope to the notation scope stack. If the scope is already present, + the command moves it to the top of the stack. - Notice that this command does not only cancel the last :n:`Open Scope @scope` - but all its invocations. + If the command appears in a section: By default, the scope is only added within the + section. Specifying :attr:`global` marks the scope for export as part of the current + module. Specifying :attr:`local` behaves like the default. -.. note:: ``Open Scope`` and ``Close Scope`` do not survive the end of sections - where they occur. When defined outside of a section, they are exported - to the modules that import the module where they occur. + If the command does not appear in a section: By default, the scope marks the scope for + export as part of the current module. Specifying :attr:`local` prevents exporting the scope. + Specifying :attr:`global` behaves like the default. -.. cmd:: Local Open Scope @scope. - Local Close Scope @scope. +.. cmd:: Close Scope @scope - These variants are not exported to the modules that import the module where - they occur, even if outside a section. + Removes a scope from the notation scope stack. -.. cmd:: Global Open Scope @scope. - Global Close Scope @scope. + If the command appears in a section: By default, the scope is only removed within the + section. Specifying :attr:`global` marks the scope removal for export as part of the current + module. Specifying :attr:`local` behaves like the default. - These variants survive sections. They behave as if Global were absent when - not inside a section. + If the command does not appear in a section: By default, the scope marks the scope removal for + export as part of the current module. Specifying :attr:`local` prevents exporting the removal. + Specifying :attr:`global` behaves like the default. + + .. todo: Strange notion, exporting something that _removes_ a scope. + See https://github.com/coq/coq/pull/11718#discussion_r413667817 .. _LocalInterpretationRulesForNotations: @@ -1085,123 +1085,35 @@ Local interpretation rules for notations In addition to the global rules of interpretation of notations, some ways to change the interpretation of subterms are available. -Local opening of an interpretation scope -+++++++++++++++++++++++++++++++++++++++++ +Opening a notation scope locally +++++++++++++++++++++++++++++++++ -It is possible to locally extend the interpretation scope stack using the syntax -:n:`(@term)%@ident` (or simply :n:`@term%@ident` for atomic terms), where :token:`ident` is a -special identifier called *delimiting key* and bound to a given scope. +The notation scope stack can be locally extended within +a :token:`term` with the syntax +:n:`(@term)%@scope_key` (or simply :n:`@term%@scope_key` for atomic terms). -In such a situation, the term term, and all its subterms, are +In this case, :n:`@term` is interpreted in the scope stack extended with the scope bound to :token:`ident`. -.. cmd:: Delimit Scope @scope with @ident - - To bind a delimiting key to a scope, use the command - :n:`Delimit Scope @scope with @ident` +.. cmd:: Delimit Scope @scope_name with @scope_key -.. cmd:: Undelimit Scope @scope + Binds the delimiting key :token:`scope_key` to a scope. - To remove a delimiting key of a scope, use the command - :n:`Undelimit Scope @scope` +.. cmd:: Undelimit Scope @scope_name -Binding arguments of a constant to an interpretation scope -+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + Removes the delimiting keys associated with a scope. -.. cmd:: Arguments @qualid {+ @name%@ident} - :name: Arguments (scopes) +Binding types or coercion classes to a notation scope +++++++++++++++++++++++++++++++++++++++++++++++++++++++ - It is possible to set in advance that some arguments of a given constant have - to be interpreted in a given scope. The command is - :n:`Arguments @qualid {+ @name%@ident}` where the list is a prefix of the - arguments of ``qualid`` optionally annotated with their scope :token:`ident`. Grouping - round parentheses can be used to decorate multiple arguments with the same - scope. :token:`ident` can be either a scope name or its delimiting key. For - example the following command puts the first two arguments of :g:`plus_fct` - in the scope delimited by the key ``F`` (``Rfun_scope``) and the last - argument in the scope delimited by the key ``R`` (``R_scope``). +.. cmd:: Bind Scope @scope_name with {+ @class } - .. coqdoc:: - - Arguments plus_fct (f1 f2)%F x%R. - - The ``Arguments`` command accepts scopes decoration to all grouping - parentheses. In the following example arguments A and B are marked as - maximally inserted implicit arguments and are put into the ``type_scope`` scope. - - .. coqdoc:: - - Arguments respectful {A B}%type (R R')%signature _ _. - - When interpreting a term, if some of the arguments of :token:`qualid` are built - from a notation, then this notation is interpreted in the scope stack - extended by the scope bound (if any) to this argument. The effect of - the scope is limited to the argument itself. It does not propagate to - subterms but the subterms that, after interpretation of the notation, - turn to be themselves arguments of a reference are interpreted - accordingly to the argument scopes bound to this reference. - - .. cmdv:: Arguments @qualid : clear scopes - - This command can be used to clear argument scopes of :token:`qualid`. - - .. cmdv:: Arguments @qualid {+ @name%@ident} : extra scopes - - Defines extra argument scopes, to be used in case of coercion to ``Funclass`` - (see the :ref:`implicitcoercions` chapter) or with a computed type. - - .. cmdv:: Global Arguments @qualid {+ @name%@ident} - - This behaves like :n:`Arguments qualid {+ @name%@ident}` but survives when a - section is closed instead of stopping working at section closing. Without the - ``Global`` modifier, the effect of the command stops when the section it belongs - to ends. - - .. cmdv:: Local Arguments @qualid {+ @name%@ident} - - This behaves like :n:`Arguments @qualid {+ @name%@ident}` but does not - survive modules and files. Without the ``Local`` modifier, the effect of the - command is visible from within other modules or files. - -.. seealso:: - - The command :cmd:`About` can be used to show the scopes bound to the - arguments of a function. - -.. note:: - - In notations, the subterms matching the identifiers of the - notations are interpreted in the scope in which the identifiers - occurred at the time of the declaration of the notation. Here is an - example: - - .. coqtop:: all - - Parameter g : bool -> bool. - Declare Scope mybool_scope. - - Notation "@@" := true (only parsing) : bool_scope. - Notation "@@" := false (only parsing): mybool_scope. - - Bind Scope bool_scope with bool. - Notation "# x #" := (g x) (at level 40). - Check # @@ #. - Arguments g _%mybool_scope. - Check # @@ #. - Delimit Scope mybool_scope with mybool. - Check # @@%mybool #. - -Binding types of arguments to an interpretation scope -+++++++++++++++++++++++++++++++++++++++++++++++++++++ - -.. cmd:: Bind Scope @ident with {+ @class } - - When an interpretation scope is naturally associated to a type (e.g. the - scope of operations on the natural numbers), it may be convenient to bind it - to this type. When a scope :token:`scope` is bound to a type :token:`type`, any function - gets its arguments of type :token:`type` interpreted by default in scope :token:`scope` - (this default behavior can however be overwritten by explicitly using the - command :cmd:`Arguments <Arguments (scopes)>`). + Binds the notation scope :token:`scope_name` to the type or coercion class :token:`class`. + When bound, arguments of that type for any function will be interpreted in + that scope by default. This default can be overridden for individual functions + with the :cmd:`Arguments` command. The association may be convenient + when a notation scope is naturally associated with a :token:`type` (e.g. + `nat` and the natural numbers). Whether the argument of a function has some type ``type`` is determined statically. For instance, if ``f`` is a polymorphic function of type @@ -1209,10 +1121,6 @@ Binding types of arguments to an interpretation scope then :g:`a` of type :g:`t` in :g:`f t a` is not recognized as an argument to be interpreted in scope ``scope``. - More generally, any coercion :n:`@class` (see the :ref:`implicitcoercions` chapter) - can be bound to an interpretation scope. The command to do it is - :n:`Bind Scope @scope with @class` - .. coqtop:: in reset Parameter U : Set. @@ -1232,13 +1140,13 @@ Binding types of arguments to an interpretation scope .. note:: When active, a bound scope has effect on all defined functions (even if they are defined after the :cmd:`Bind Scope` directive), except if argument scopes were assigned explicitly using the - :cmd:`Arguments <Arguments (scopes)>` command. + :cmd:`Arguments` command. .. note:: The scopes ``type_scope`` and ``function_scope`` also have a local effect on interpretation. See the next section. -The ``type_scope`` interpretation scope -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The ``type_scope`` notation scope +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ .. index:: type_scope @@ -1253,8 +1161,8 @@ the type of a binder, the domain and codomain of implication, the codomain of products, and more generally any type argument of a declared or defined constant. -The ``function_scope`` interpretation scope -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The ``function_scope`` notation scope +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ .. index:: function_scope @@ -1264,8 +1172,8 @@ recognized to be a ``Funclass`` instance, i.e., of type :g:`forall x:A, B` or :g:`A -> B`. -Interpretation scopes used in the standard library of Coq -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Notation scopes used in the standard library of Coq +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We give an overview of the scopes used in the standard library of Coq. For a complete list of notations in each scope, use the commands :cmd:`Print @@ -1351,40 +1259,52 @@ Scopes` or :cmd:`Print Scope`. Displaying information about scopes ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. cmd:: Print Visibility +.. cmd:: Print Visibility {? @scope_name } - This displays the current stack of notations in scopes and lonely - notations that is used to interpret a notation. The top of the stack + Displays the current notation scope stack. The top of the stack is displayed last. Notations in scopes whose interpretation is hidden by the same notation in a more recently opened scope are not displayed. Hence each notation is displayed only once. - .. cmdv:: Print Visibility @scope - - This displays the current stack of notations in scopes and lonely - notations assuming that :token:`scope` is pushed on top of the stack. This is - useful to know how a subterm locally occurring in the scope :token:`scope` is - interpreted. + If :n:`@scope_name` is specified, + displays the current notation scope stack + as if the scope :n:`@scope_name` is pushed on top of the stack. This is + useful to see how a subterm occurring locally in the scope is + interpreted. .. cmd:: Print Scopes - This displays all the notations, delimiting keys and corresponding - classes of all the existing interpretation scopes. It also displays the - lonely notations. + Displays, for each existing notation scope, all accessible notations + (whether or not currently in the notation scope stack), + the most-recently defined delimiting key and the class the notation scope is bound to. + The display also includes lonely notations. + + .. todo should the command report all delimiting keys? - .. cmdv:: Print Scope @scope - :name: Print Scope + Use the :cmd:`Print Visibility` command to display the current notation scope stack. - This displays all the notations defined in the interpretation scope :token:`scope`. - It also displays the delimiting key if any and the class to which the - scope is bound, if any. +.. cmd:: Print Scope @scope_name + :name: Print Scope + + Displays all notations defined in the notation scope :n:`@scope_name`. + It also displays the delimiting key and the class to which the + scope is bound, if any. .. _Abbreviations: Abbreviations -------------- -.. cmd:: {? Local} Notation @ident {+ @ident} := @term {? (only parsing)}. +.. cmd:: Notation @ident {* @ident__parm } := @one_term {? ( only parsing ) } + :name: Notation (abbreviation) + + .. todo: for some reason, Sphinx doesn't complain about a duplicate name if + :name: is omitted + + Defines an abbreviation :token:`ident` with the parameters :n:`@ident__parm`. + + This command supports the :attr:`local` attribute, which limits the notation to the + current module. An *abbreviation* is a name, possibly applied to arguments, that denotes a (presumably) more complex expression. Here are examples: @@ -1412,6 +1332,14 @@ Abbreviations Check forall A:Prop, A <-> A. Check reflexive iff. + .. coqtop:: in + + Notation Plus1 B := (Nat.add B 1). + + .. coqtop:: all + + Compute (Plus1 3). + An abbreviation expects no precedence nor associativity, since it is parsed as an usual application. Abbreviations are used as much as possible by the Coq printers unless the modifier ``(only @@ -1448,7 +1376,7 @@ Abbreviations Like for notations, if the right-hand side of an abbreviation is a partially applied constant, the abbreviation inherits the implicit - arguments and interpretation scopes of the constant. As an + arguments and notation scopes of the constant. As an exception, if the right-hand side is just of the form :n:`@@qualid`, this conventionally stops the inheritance of implicit arguments. @@ -1457,64 +1385,88 @@ Abbreviations Numeral notations ----------------- -.. cmd:: Numeral Notation @ident__1 @ident__2 @ident__3 : @scope. +.. cmd:: Numeral Notation @qualid @qualid__parse @qualid__print : @scope_name {? @numeral_modifier } :name: Numeral Notation + .. insertprodn numeral_modifier numeral_modifier + + .. prodn:: + numeral_modifier ::= ( warning after @numeral ) + | ( abstract after @numeral ) + This command allows the user to customize the way numeral literals are parsed and printed. - The token :n:`@ident__1` should be the name of an inductive type, - while :n:`@ident__2` and :n:`@ident__3` should be the names of the - parsing and printing functions, respectively. The parsing function - :n:`@ident__2` should have one of the following types: - - * :n:`Decimal.int -> @ident__1` - * :n:`Decimal.int -> option @ident__1` - * :n:`Decimal.uint -> @ident__1` - * :n:`Decimal.uint -> option @ident__1` - * :n:`Z -> @ident__1` - * :n:`Z -> option @ident__1` - * :n:`Decimal.decimal -> @ident__1` - * :n:`Decimal.decimal -> option @ident__1` - - And the printing function :n:`@ident__3` should have one of the - following types: - - * :n:`@ident__1 -> Decimal.int` - * :n:`@ident__1 -> option Decimal.int` - * :n:`@ident__1 -> Decimal.uint` - * :n:`@ident__1 -> option Decimal.uint` - * :n:`@ident__1 -> Z` - * :n:`@ident__1 -> option Z` - * :n:`@ident__1 -> Decimal.decimal` - * :n:`@ident__1 -> option Decimal.decimal` - - When parsing, the application of the parsing function - :n:`@ident__2` to the number will be fully reduced, and universes - of the resulting term will be refreshed. - - Note that only fully-reduced ground terms (terms containing only - function application, constructors, inductive type families, - sorts, and primitive integers) will be considered for printing. - - .. cmdv:: Numeral Notation @ident__1 @ident__2 @ident__3 : @scope (warning after @num). - - When a literal larger than :token:`num` is parsed, a warning - message about possible stack overflow, resulting from evaluating - :n:`@ident__2`, will be displayed. - - .. cmdv:: Numeral Notation @ident__1 @ident__2 @ident__3 : @scope (abstract after @num). - - When a literal :g:`m` larger than :token:`num` is parsed, the - result will be :n:`(@ident__2 m)`, without reduction of this - application to a normal form. Here :g:`m` will be a - :g:`Decimal.int` or :g:`Decimal.uint` or :g:`Z`, depending on the - type of the parsing function :n:`@ident__2`. This allows for a - more compact representation of literals in types such as :g:`nat`, - and limits parse failures due to stack overflow. Note that a - warning will be emitted when an integer larger than :token:`num` - is parsed. Note that :n:`(abstract after @num)` has no effect - when :n:`@ident__2` lands in an :g:`option` type. + :n:`@qualid` + the name of an inductive type, + while :n:`@qualid__parse` and :n:`@qualid__print` should be the names of the + parsing and printing functions, respectively. The parsing function + :n:`@qualid__parse` should have one of the following types: + + * :n:`Decimal.int -> @qualid` + * :n:`Decimal.int -> option @qualid` + * :n:`Decimal.uint -> @qualid` + * :n:`Decimal.uint -> option @qualid` + * :n:`Z -> @qualid` + * :n:`Z -> option @qualid` + * :n:`Decimal.decimal -> @qualid` + * :n:`Decimal.decimal -> option @qualid` + + And the printing function :n:`@qualid__print` should have one of the + following types: + + * :n:`@qualid -> Decimal.int` + * :n:`@qualid -> option Decimal.int` + * :n:`@qualid -> Decimal.uint` + * :n:`@qualid -> option Decimal.uint` + * :n:`@qualid -> Z` + * :n:`@qualid -> option Z` + * :n:`@qualid -> Decimal.decimal` + * :n:`@qualid -> option Decimal.decimal` + + When parsing, the application of the parsing function + :n:`@qualid__parse` to the number will be fully reduced, and universes + of the resulting term will be refreshed. + + Note that only fully-reduced ground terms (terms containing only + function application, constructors, inductive type families, + sorts, and primitive integers) will be considered for printing. + + :n:`( warning after @numeral )` + displays a warning message about a possible stack + overflow when calling :n:`@qualid__parse` to parse a literal larger than :n:`@numeral`. + + .. warn:: Stack overflow or segmentation fault happens when working with large numbers in @type (threshold may vary depending on your system limits and on the command executed). + + When a :cmd:`Numeral Notation` is registered in the current scope + with :n:`(warning after @numeral)`, this warning is emitted when + parsing a numeral greater than or equal to :token:`numeral`. + + :n:`( abstract after @numeral )` + returns :n:`(@qualid__parse m)` when parsing a literal + :n:`m` that's greater than :n:`@numeral` rather than reducing it to a normal form. + Here :g:`m` will be a + :g:`Decimal.int` or :g:`Decimal.uint` or :g:`Z`, depending on the + type of the parsing function :n:`@qualid__parse`. This allows for a + more compact representation of literals in types such as :g:`nat`, + and limits parse failures due to stack overflow. Note that a + warning will be emitted when an integer larger than :token:`numeral` + is parsed. Note that :n:`(abstract after @numeral)` has no effect + when :n:`@qualid__parse` lands in an :g:`option` type. + + .. warn:: To avoid stack overflow, large numbers in @type are interpreted as applications of @qualid__parse. + + When a :cmd:`Numeral Notation` is registered in the current scope + with :n:`(abstract after @numeral)`, this warning is emitted when + parsing a numeral greater than or equal to :token:`numeral`. + Typically, this indicates that the fully computed representation + of numerals can be so large that non-tail-recursive OCaml + functions run out of stack space when trying to walk them. + + .. warn:: The 'abstract after' directive has no effect when the parsing function (@qualid__parse) targets an option type. + + As noted above, the :n:`(abstract after @num)` directive has no + effect when :n:`@qualid__parse` lands in an :g:`option` type. .. exn:: Cannot interpret this number as a value of type @type @@ -1524,22 +1476,16 @@ Numeral notations only for integers or non-negative integers, and the given numeral has a fractional or exponent part or is negative. - - .. exn:: @ident should go from Decimal.int to @type or (option @type). Instead of Decimal.int, the types Decimal.uint or Z or Int63.int or Decimal.decimal could be used (you may need to require BinNums or Decimal or Int63 first). + .. exn:: @qualid__parse should go from Decimal.int to @type or (option @type). Instead of Decimal.int, the types Decimal.uint or Z or Int63.int or Decimal.decimal could be used (you may need to require BinNums or Decimal or Int63 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 or Int63.int or Decimal.decimal could be used (you may need to require BinNums or Decimal or Int63 first). + .. exn:: @qualid__print should go from @type to Decimal.int or (option Decimal.int). Instead of Decimal.int, the types Decimal.uint or Z or Int63.int or Decimal.decimal could be used (you may need to require BinNums or Decimal or Int63 first). The printing function given to the :cmd:`Numeral Notation` vernacular is not of the right type. - .. exn:: @type is not an inductive type. - - Numeral notations can only be declared for inductive types with no - arguments. - .. exn:: Unexpected term @term while parsing a numeral notation. Parsing functions must always return ground terms, made up of @@ -1554,98 +1500,39 @@ Numeral notations concrete numeral expressed as a decimal. They may not return opaque constants. - .. exn:: Cannot interpret in @scope because @ident could not be found in the current environment. - - The inductive type used to register the numeral notation is no - longer available in the environment. Most likely, this is because - the numeral notation was declared inside a functor for an - inductive type inside the functor. This use case is not currently - supported. - - Alternatively, you might be trying to use a primitive token - notation from a plugin which forgot to specify which module you - must :g:`Require` for access to that notation. - - .. exn:: Syntax error: [prim:reference] expected after 'Notation' (in [vernac:command]). - - The type passed to :cmd:`Numeral Notation` must be a single - identifier. - - .. exn:: Syntax error: [prim:reference] expected after [prim:reference] (in [vernac:command]). - - Both functions passed to :cmd:`Numeral Notation` must be single - identifiers. - - .. exn:: The reference @ident was not found in the current environment. - - Identifiers passed to :cmd:`Numeral Notation` must exist in the - global environment. - - .. exn:: @ident is bound to a notation that does not denote a reference. - - Identifiers passed to :cmd:`Numeral Notation` must be global - references, or notations which denote to single identifiers. - - .. warn:: Stack overflow or segmentation fault happens when working with large numbers in @type (threshold may vary depending on your system limits and on the command executed). - - When a :cmd:`Numeral Notation` is registered in the current scope - with :n:`(warning after @num)`, this warning is emitted when - parsing a numeral greater than or equal to :token:`num`. - - .. warn:: To avoid stack overflow, large numbers in @type are interpreted as applications of @ident__2. - - When a :cmd:`Numeral Notation` is registered in the current scope - with :n:`(abstract after @num)`, this warning is emitted when - parsing a numeral greater than or equal to :token:`num`. - Typically, this indicates that the fully computed representation - of numerals can be so large that non-tail-recursive OCaml - functions run out of stack space when trying to walk them. - - For example - - .. coqtop:: all warn - - Check 90000. - - .. warn:: The 'abstract after' directive has no effect when the parsing function (@ident__2) targets an option type. - - As noted above, the :n:`(abstract after @num)` directive has no - effect when :n:`@ident__2` lands in an :g:`option` type. - String notations ----------------- -.. cmd:: String Notation @ident__1 @ident__2 @ident__3 : @scope. +.. cmd:: String Notation @qualid @qualid__parse @qualid__print : @scope_name :name: String Notation - This command allows the user to customize the way strings are parsed - and printed. + Allows the user to customize how strings are parsed and printed. - The token :n:`@ident__1` should be the name of an inductive type, - while :n:`@ident__2` and :n:`@ident__3` should be the names of the + The token :n:`@qualid` should be the name of an inductive type, + while :n:`@qualid__parse` and :n:`@qualid__print` should be the names of the parsing and printing functions, respectively. The parsing function - :n:`@ident__2` should have one of the following types: + :n:`@qualid__parse` should have one of the following types: - * :n:`Byte.byte -> @ident__1` - * :n:`Byte.byte -> option @ident__1` - * :n:`list Byte.byte -> @ident__1` - * :n:`list Byte.byte -> option @ident__1` + * :n:`Byte.byte -> @qualid` + * :n:`Byte.byte -> option @qualid` + * :n:`list Byte.byte -> @qualid` + * :n:`list Byte.byte -> option @qualid` - And the printing function :n:`@ident__3` should have one of the + The printing function :n:`@qualid__print` should have one of the following types: - * :n:`@ident__1 -> Byte.byte` - * :n:`@ident__1 -> option Byte.byte` - * :n:`@ident__1 -> list Byte.byte` - * :n:`@ident__1 -> option (list Byte.byte)` + * :n:`@qualid -> Byte.byte` + * :n:`@qualid -> option Byte.byte` + * :n:`@qualid -> list Byte.byte` + * :n:`@qualid -> option (list Byte.byte)` - When parsing, the application of the parsing function - :n:`@ident__2` to the string will be fully reduced, and universes - of the resulting term will be refreshed. + When parsing, the application of the parsing function + :n:`@qualid__parse` to the string will be fully reduced, and universes + of the resulting term will be refreshed. - Note that only fully-reduced ground terms (terms containing only - function application, constructors, inductive type families, - sorts, and primitive integers) will be considered for printing. + Note that only fully-reduced ground terms (terms containing only + function application, constructors, inductive type families, + sorts, and primitive integers) will be considered for printing. .. exn:: Cannot interpret this string as a value of type @type @@ -1653,21 +1540,16 @@ String notations the given string. This error is given when the interpretation function returns :g:`None`. - .. exn:: @ident should go from Byte.byte or (list Byte.byte) to @type or (option @type). + .. exn:: @qualid__parse should go from Byte.byte or (list Byte.byte) to @type or (option @type). The parsing function given to the :cmd:`String Notation` vernacular is not of the right type. - .. exn:: @ident should go from @type to Byte.byte or (option Byte.byte) or (list Byte.byte) or (option (list Byte.byte)). + .. exn:: @qualid__print should go from @type to Byte.byte or (option Byte.byte) or (list Byte.byte) or (option (list Byte.byte)). The printing function given to the :cmd:`String Notation` vernacular is not of the right type. - .. exn:: @type is not an inductive type. - - String notations can only be declared for inductive types with no - arguments. - .. exn:: Unexpected term @term while parsing a string notation. Parsing functions must always return ground terms, made up of @@ -1682,11 +1564,18 @@ String notations concrete string expressed as a decimal. They may not return opaque constants. - .. exn:: Cannot interpret in @scope because @ident could not be found in the current environment. +The following errors apply to both string and numeral notations: + + .. exn:: @type is not an inductive type. + + String and numeral notations can only be declared for inductive types with no + arguments. - The inductive type used to register the string notation is no + .. exn:: Cannot interpret in @scope_name because @qualid could not be found in the current environment. + + The inductive type used to register the string or numeral notation is no longer available in the environment. Most likely, this is because - the string notation was declared inside a functor for an + the notation was declared inside a functor for an inductive type inside the functor. This use case is not currently supported. @@ -1696,131 +1585,184 @@ String notations .. exn:: Syntax error: [prim:reference] expected after 'Notation' (in [vernac:command]). - The type passed to :cmd:`String Notation` must be a single + The type passed to :cmd:`String Notation` or :cmd:`Numeral Notation` must be a single qualified identifier. .. exn:: Syntax error: [prim:reference] expected after [prim:reference] (in [vernac:command]). - Both functions passed to :cmd:`String Notation` must be single + Both functions passed to :cmd:`String Notation` or :cmd:`Numeral Notation` must be single qualified identifiers. - .. exn:: The reference @ident was not found in the current environment. + .. todo: generally we don't document syntax errors. Is this a good execption? - Identifiers passed to :cmd:`String Notation` must exist in the - global environment. + .. exn:: @qualid is bound to a notation that does not denote a reference. - .. exn:: @ident is bound to a notation that does not denote a reference. + Identifiers passed to :cmd:`String Notation` or :cmd:`Numeral Notation` must be global + references, or notations which evaluate to single qualified identifiers. - Identifiers passed to :cmd:`String Notation` must be global - references, or notations which denote to single identifiers. + .. todo note on "single qualified identifiers" https://github.com/coq/coq/pull/11718#discussion_r415076703 .. _TacticNotation: Tactic Notations ----------------- -Tactic notations allow to customize the syntax of tactics. They have the following syntax: +Tactic notations allow customizing the syntax of tactics. + +.. todo move to the Ltac chapter + +.. todo to discuss after moving to the ltac chapter: + any words of wisdom on when to use tactic notation vs ltac? + can you run into problems if you shadow another tactic or tactic notation? + If so, how to avoid ambiguity? + +.. cmd:: Tactic Notation {? ( at level @num ) } {+ @ltac_production_item } := @ltac_expr + + .. insertprodn ltac_production_item ltac_production_item + + .. prodn:: + ltac_production_item ::= @string + | @ident {? ( @ident {? , @string } ) } + + Defines a *tactic notation*, which extends the parsing and pretty-printing of tactics. -.. productionlist:: coq - 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 + This command supports the :attr:`local` attribute, which limits the notation to the + current module. -.. cmd:: Tactic Notation {? (at level @num)} {+ @prod_item} := @tactic. + :token:`num` + The parsing precedence to assign to the notation. This information is particularly + relevant for notations for tacticals. Levels can be in the range 0 .. 5 (default is 5). - A tactic notation extends the parser and pretty-printer of tactics with a new - rule made of the list of production items. It then evaluates into the - tactic expression ``tactic``. For simple tactics, it is recommended to use - a terminal symbol, i.e. a string, for the first production item. The - tactic level indicates the parsing precedence of the tactic notation. - This information is particularly relevant for notations of tacticals. - Levels 0 to 5 are available (default is 5). + :n:`{+ @ltac_production_item }` + The notation syntax. Notations for simple tactics should begin with a :token:`string`. + Note that `Tactic Notation foo := idtac` is not valid; it should be `Tactic Notation "foo" := idtac`. - .. cmd:: Print Grammar tactic + .. todo: "Tactic Notation constr := idtac" gives a nice message, would be good to show + that message for the "foo" example above. - To know the parsing precedences of the existing tacticals, use the command - ``Print Grammar tactic``. + :token:`string` + represents a literal value in the notation - Each type of tactic argument has a specific semantic regarding how it - is parsed and how it is interpreted. The semantic is described in the - following table. The last command gives examples of tactics which use - the corresponding kind of argument. + :n:`@ident` + is the name of a grammar nonterminal listed in the table below. In a few cases, + to maintain backward compatibility, the name differs from the nonterminal name + used elsewhere in the documentation. + + :n:`( @ident__parm {? , @string__s } )` + :n:`@ident__parm` is the parameter name associated with :n:`@ident`. The :n:`@string__s` + is the separator string to use when :n:`@ident` specifies a list with separators + (i.e. :n:`@ident` ends with `_list_sep`). + + :n:`@ltac_expr` + The tactic expression to substitute for the notation. :n:`@ident__parm` + tokens appearing in :n:`@ltac_expr` are substituted with the associated + nonterminal value. + + For example, the following command defines a notation with a single parameter `x`. + + .. coqtop:: in + + Tactic Notation "destruct_with_eqn" constr(x) := destruct x eqn:?. + + For a complex example, examine the 16 `Tactic Notation "setoid_replace"`\s + defined in :file:`$COQLIB/theories/Classes/SetoidTactics.v`, which are designed + to accept any subset of 4 optional parameters. + + The nonterminals that can specified in the tactic notation are: + + .. todo uconstr represents a type with holes. At the moment uconstr doesn't + appear in the documented grammar. Maybe worth ressurecting with a better name, + maybe "open_term"? + see https://github.com/coq/coq/pull/11718#discussion_r413721234 + + .. todo 'open_constr' appears to be another possible value based on the + the message from "Tactic Notation open_constr := idtac". + Also (at least) "ref", "string", "preident", "int" and "ssrpatternarg". + (from reading .v files). + Looks like any string passed to "make0" in the code is valid. But do + we want to support all these? + @JasonGross's opinion here: https://github.com/coq/coq/pull/11718#discussion_r415387421 .. list-table:: :header-rows: 1 - * - Tactic argument type - - parsed as - - interpreted as + * - Specified :token:`ident` + - Parsed as + - Interpreted as - as in tactic * - ``ident`` - - identifier + - :token:`ident` - a user-given name - - intro + - :tacn:`intro` * - ``simple_intropattern`` - - simple_intropattern + - :token:`simple_intropattern` - an introduction pattern - - assert as + - :tacn:`assert` `as` * - ``hyp`` - - identifier + - :token:`ident` - a hypothesis defined in context - - clear + - :tacn:`clear` * - ``reference`` - - qualified identifier + - :token:`qualid` - a global reference of term - - unfold + - :tacn:`unfold` * - ``constr`` - - term + - :token:`term` - a term - - exact + - :tacn:`exact` * - ``uconstr`` - - term + - :token:`term` - an untyped term - - refine + - :tacn:`refine` * - ``integer`` - - integer + - :token:`int` - an integer - * - ``int_or_var`` - - identifier or integer + - :token:`int_or_var` - an integer - - do + - :tacn:`do` * - ``tactic`` - - tactic at level 5 + - :token:`ltac_expr` - a tactic - - * - ``tacticn`` - - tactic at level n - - a tactic + * - ``tactic``\ *n* (*n* in 0..5) + - :token:`ltac_expr`\ *n* + - a tactic at level *n* - * - *entry*\ ``_list`` - - list of *entry* + - :n:`{* entry }` - a list of how *entry* is interpreted - * - ``ne_``\ *entry*\ ``_list`` - - non-empty list of *entry* + - :n:`{+ entry }` - a list of how *entry* is interpreted - + * - *entry*\ ``_list_sep`` + - :n:`{*s entry }` + - a list of how *entry* is interpreted + - + + * - ``ne_``\ *entry*\ ``_list_sep`` + - :n:`{+s entry }` + - a list of how *entry* is interpreted + - + + .. todo: notation doesn't support italics + .. note:: In order to be bound in tactic definitions, each syntactic entry for argument type must include the case of a simple |Ltac| identifier as part of what it parses. This is naturally the case for @@ -1829,16 +1771,11 @@ Tactic notations allow to customize the syntax of tactics. They have the followi evaluates to integers only but which syntactically includes identifiers in order to be usable in tactic definitions. - .. note:: The *entry*\ ``_list`` and ``ne_``\ *entry*\ ``_list`` entries can be used in + .. note:: The *entry*\ ``_list*`` and ``ne_``\ *entry*\ ``_list*`` entries can be used in primitive tactics or in other notations at places where a list of the underlying entry can be used: entry is either ``constr``, ``hyp``, ``integer`` or ``int_or_var``. -.. cmdv:: Local Tactic Notation - - Tactic notations disappear when a section is closed. They survive when - a module is closed unless the command ``Local Tactic Notation`` is used instead - of :cmd:`Tactic Notation`. .. rubric:: Footnotes diff --git a/doc/sphinx/using/libraries/funind.rst b/doc/sphinx/using/libraries/funind.rst new file mode 100644 index 0000000000..40f9eedcf0 --- /dev/null +++ b/doc/sphinx/using/libraries/funind.rst @@ -0,0 +1,400 @@ +Functional induction +==================== + +.. _advanced-recursive-functions: + +Advanced recursive functions +---------------------------- + +The following command is available when the ``FunInd`` library has been loaded via ``Require Import FunInd``: + +.. cmd:: Function @fix_definition {* with @fix_definition } + + This command is a generalization of :cmd:`Fixpoint`. It is a wrapper + for several ways of defining a function *and* other useful related + objects, namely: an induction principle that reflects the recursive + structure of the function (see :tacn:`functional induction`) and its fixpoint equality. + This defines a function similar to those defined by :cmd:`Fixpoint`. + As in :cmd:`Fixpoint`, the decreasing argument must + be given (unless the function is not recursive), but it might not + necessarily be *structurally* decreasing. Use the :n:`@fixannot` clause + to name the decreasing argument *and* to describe which kind of + decreasing criteria to use to ensure termination of recursive + calls. + + :cmd:`Function` also supports the :n:`with` clause to create + mutually recursive definitions, however this feature is limited + to structurally recursive functions (i.e. when :n:`@fixannot` is a :n:`struct` + clause). + + See :tacn:`functional induction` and :cmd:`Functional Scheme` for how to use + the induction principle to reason easily about the function. + + The form of the :n:`@fixannot` clause determines which definition mechanism :cmd:`Function` uses. + (Note that references to :n:`ident` below refer to the name of the function being defined.): + + * If :n:`@fixannot` is not specified, :cmd:`Function` + defines the nonrecursive function :token:`ident` as if it was declared with + :cmd:`Definition`. In addition, the following are defined: + + + :token:`ident`\ ``_rect``, :token:`ident`\ ``_rec`` and :token:`ident`\ ``_ind``, + which reflect the pattern matching structure of :token:`term` (see :cmd:`Inductive`); + + The inductive :n:`R_@ident` corresponding to the graph of :token:`ident` (silently); + + :token:`ident`\ ``_complete`` and :token:`ident`\ ``_correct`` which + are inversion information linking the function and its graph. + + * If :n:`{ struct ... }` is specified, :cmd:`Function` + defines the structural recursive function :token:`ident` as if it was declared + with :cmd:`Fixpoint`. In addition, the following are defined: + + + The same objects as above; + + The fixpoint equation of :token:`ident`: :n:`@ident`\ ``_equation``. + + * If :n:`{ measure ... }` or :n:`{ wf ... }` are specified, :cmd:`Function` + defines a recursive function by well-founded recursion. The module ``Recdef`` + of the standard library must be loaded for this feature. + + + :n:`{measure @one_term__1 {? @ident } {? @one_term__2 } }`\: where :n:`@ident` is the decreasing argument + and :n:`@one_term__1` is a function from the type of :n:`@ident` to :g:`nat` for which + the decreasing argument decreases (for the :g:`lt` order on :g:`nat`) + for each recursive call of the function. The parameters of the function are + bound in :n:`@one_term__1`. + + :n:`{wf @one_term @ident }`\: where :n:`@ident` is the decreasing argument and + :n:`@one_term` is an ordering relation on the type of :n:`@ident` (i.e. of type + `T`\ :math:`_{\sf ident}` → `T`\ :math:`_{\sf ident}` → ``Prop``) for which the decreasing argument + decreases for each recursive call of the function. The order must be well-founded. + The parameters of the function are bound in :n:`@one_term`. + + If the clause is ``measure`` or ``wf``, the user is left with some proof + obligations that will be used to define the function. These proofs + are: proofs that each recursive call is actually decreasing with + respect to the given criteria, and (if the criteria is `wf`) a proof + that the ordering relation is well-founded. Once proof obligations are + discharged, the following objects are defined: + + + The same objects as with the ``struct`` clause; + + The lemma :n:`@ident`\ ``_tcc`` which collects all proof obligations in one + property; + + The lemmas :n:`@ident`\ ``_terminate`` and :n:`@ident`\ ``_F`` which will be inlined + during extraction of :n:`@ident`. + + The way this recursive function is defined is the subject of several + papers by Yves Bertot and Antonia Balaa on the one hand, and Gilles + Barthe, Julien Forest, David Pichardie, and Vlad Rusu on the other + hand. + +.. note:: + + To obtain the right principle, it is better to put rigid + parameters of the function as first arguments. For example it is + better to define plus like this: + + .. coqtop:: reset none + + Require Import FunInd. + + .. coqtop:: all + + Function plus (m n : nat) {struct n} : nat := + match n with + | 0 => m + | S p => S (plus m p) + end. + + than like this: + + .. coqtop:: reset none + + Require Import FunInd. + + .. coqtop:: all + + Function plus (n m : nat) {struct n} : nat := + match n with + | 0 => m + | S p => S (plus p m) + end. + + +*Limitations* + +:token:`term` must be built as a *pure pattern matching tree* (:g:`match … with`) +with applications only *at the end* of each branch. + +:cmd:`Function` does not support partial application of the function being +defined. Thus, the following example cannot be accepted due to the +presence of partial application of :g:`wrong` in the body of :g:`wrong`: + +.. coqtop:: none + + Require List. + Import List.ListNotations. + +.. coqtop:: all fail + + Function wrong (C:nat) : nat := + List.hd 0 (List.map wrong (C::nil)). + +For now, dependent cases are not treated for non structurally +terminating functions. + +.. exn:: The recursive argument must be specified. + :undocumented: + +.. exn:: No argument name @ident. + :undocumented: + +.. exn:: Cannot use mutual definition with well-founded recursion or measure. + :undocumented: + +.. warn:: Cannot define graph for @ident. + + The generation of the graph relation (:n:`R_@ident`) used to compute the induction scheme of ident + raised a typing error. Only :token:`ident` is defined; the induction scheme + will not be generated. This error happens generally when: + + - the definition uses pattern matching on dependent types, + which :cmd:`Function` cannot deal with yet. + - the definition is not a *pattern matching tree* as explained above. + +.. warn:: Cannot define principle(s) for @ident. + + The generation of the graph relation (:n:`R_@ident`) succeeded but the induction principle + could not be built. Only :token:`ident` is defined. Please report. + +.. warn:: Cannot build functional inversion principle. + + :tacn:`functional inversion` will not be available for the function. + +Tactics +------- + +.. tacn:: functional induction (@qualid {+ @term}) + :name: functional induction + + The tactic functional induction performs case analysis and induction + following the definition of a function. It makes use of a principle + generated by :cmd:`Function` or :cmd:`Functional Scheme`. + Note that this tactic is only available after a ``Require Import FunInd``. + + .. example:: + + .. coqtop:: reset all + + Require Import FunInd. + Functional Scheme minus_ind := Induction for minus Sort Prop. + Check minus_ind. + Lemma le_minus (n m:nat) : n - m <= n. + functional induction (minus n m) using minus_ind; simpl; auto. + Qed. + + .. note:: + :n:`(@qualid {+ @term})` must be a correct full application + of :n:`@qualid`. In particular, the rules for implicit arguments are the + same as usual. For example use :n:`@qualid` if you want to write implicit + arguments explicitly. + + .. note:: + Parentheses around :n:`@qualid {+ @term}` are not mandatory and can be skipped. + + .. note:: + :n:`functional induction (f x1 x2 x3)` is actually a wrapper for + :n:`induction x1, x2, x3, (f x1 x2 x3) using @qualid` followed by a cleaning + phase, where :n:`@qualid` is the induction principle registered for :g:`f` + (by the :cmd:`Function` or :cmd:`Functional Scheme` command) + corresponding to the sort of the goal. Therefore + :tacn:`functional induction` may fail if the induction scheme :n:`@qualid` is not + defined. + + .. note:: + There is a difference between obtaining an induction scheme + for a function by using :cmd:`Function` + and by using :cmd:`Functional Scheme` after a normal definition using + :cmd:`Fixpoint` or :cmd:`Definition`. + + .. exn:: Cannot find induction information on @qualid. + :undocumented: + + .. exn:: Not the right number of induction arguments. + :undocumented: + + .. 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 + the values of dependent premises of the elimination scheme, including + *predicates* for mutual induction when :n:`@qualid` is part of a mutually + recursive definition. + +.. tacn:: functional inversion @ident + :name: functional inversion + + :tacn:`functional inversion` is a tactic that performs inversion on hypothesis + :n:`@ident` of the form :n:`@qualid {+ @term} = @term` or :n:`@term = @qualid + {+ @term}` where :n:`@qualid` must have been defined using :cmd:`Function`. + Note that this tactic is only available after a ``Require Import FunInd``. + + .. exn:: Hypothesis @ident must contain at least one Function. + :undocumented: + + .. exn:: Cannot find inversion information for hypothesis @ident. + + This error may be raised when some inversion lemma failed to be generated by + Function. + + + .. tacv:: functional inversion @num + + This does the same thing as :n:`intros until @num` followed by + :n:`functional inversion @ident` where :token:`ident` is the + identifier for the last introduced hypothesis. + + .. tacv:: functional inversion @ident @qualid + functional inversion @num @qualid + + If the hypothesis :token:`ident` (or :token:`num`) has a type of the form + :n:`@qualid__1 {+ @term__i } = @qualid__2 {+ @term__j }` where + :n:`@qualid__1` and :n:`@qualid__2` are valid candidates to + functional inversion, this variant allows choosing which :token:`qualid` + is inverted. + +.. _functional-scheme: + +Generation of induction principles with ``Functional`` ``Scheme`` +----------------------------------------------------------------- + + +.. cmd:: Functional Scheme @ident__0 := Induction for @ident' Sort @sort {* with @ident__i := Induction for @ident__i' Sort @sort} + + This command is a high-level experimental tool for + generating automatically induction principles corresponding to + (possibly mutually recursive) functions. First, it must be made + available via ``Require Import FunInd``. + Each :n:`@ident__i` is a different mutually defined function + name (the names must be in the same order as when they were defined). This + command generates the induction principle for each :n:`@ident__i`, following + the recursive structure and case analyses of the corresponding function + :n:`@ident__i'`. + +.. warning:: + + There is a difference between induction schemes generated by the command + :cmd:`Functional Scheme` and these generated by the :cmd:`Function`. Indeed, + :cmd:`Function` generally produces smaller principles that are closer to how + a user would implement them. See :ref:`advanced-recursive-functions` for details. + +.. example:: + + Induction scheme for div2. + + We define the function div2 as follows: + + .. coqtop:: all + + Require Import FunInd. + Require Import Arith. + + Fixpoint div2 (n:nat) : nat := + match n with + | O => 0 + | S O => 0 + | S (S n') => S (div2 n') + end. + + The definition of a principle of induction corresponding to the + recursive structure of `div2` is defined by the command: + + .. coqtop:: all + + Functional Scheme div2_ind := Induction for div2 Sort Prop. + + You may now look at the type of div2_ind: + + .. coqtop:: all + + Check div2_ind. + + We can now prove the following lemma using this principle: + + .. coqtop:: all + + Lemma div2_le' : forall n:nat, div2 n <= n. + intro n. + pattern n, (div2 n). + apply div2_ind; intros. + auto with arith. + auto with arith. + simpl; auto with arith. + Qed. + + We can use directly the functional induction (:tacn:`functional induction`) tactic instead + of the pattern/apply trick: + + .. coqtop:: all + + Reset div2_le'. + + Lemma div2_le : forall n:nat, div2 n <= n. + intro n. + functional induction (div2 n). + auto with arith. + auto with arith. + auto with arith. + Qed. + +.. example:: + + Induction scheme for tree_size. + + We define trees by the following mutual inductive type: + + .. original LaTeX had "Variable" instead of "Axiom", which generates an ugly warning + + .. coqtop:: reset all + + Axiom A : Set. + + Inductive tree : Set := + node : A -> forest -> tree + with forest : Set := + | empty : forest + | cons : tree -> forest -> forest. + + We define the function tree_size that computes the size of a tree or a + forest. Note that we use ``Function`` which generally produces better + principles. + + .. coqtop:: all + + Require Import FunInd. + + Function tree_size (t:tree) : nat := + match t with + | node A f => S (forest_size f) + end + with forest_size (f:forest) : nat := + match f with + | empty => 0 + | cons t f' => (tree_size t + forest_size f') + end. + + Notice that the induction principles ``tree_size_ind`` and ``forest_size_ind`` + generated by ``Function`` are not mutual. + + .. coqtop:: all + + Check tree_size_ind. + + Mutual induction principles following the recursive structure of ``tree_size`` + and ``forest_size`` can be generated by the following command: + + .. coqtop:: all + + Functional Scheme tree_size_ind2 := Induction for tree_size Sort Prop + with forest_size_ind2 := Induction for forest_size Sort Prop. + + You may now look at the type of `tree_size_ind2`: + + .. coqtop:: all + + Check tree_size_ind2. diff --git a/doc/sphinx/using/libraries/index.rst b/doc/sphinx/using/libraries/index.rst index d0848e6c3f..ad10869439 100644 --- a/doc/sphinx/using/libraries/index.rst +++ b/doc/sphinx/using/libraries/index.rst @@ -22,3 +22,4 @@ installed with the `opam package manager ../../language/coq-library ../../addendum/extraction ../../addendum/miscellaneous-extensions + funind diff --git a/doc/sphinx/using/tools/coqdoc.rst b/doc/sphinx/using/tools/coqdoc.rst index cada680895..b4b14fb392 100644 --- a/doc/sphinx/using/tools/coqdoc.rst +++ b/doc/sphinx/using/tools/coqdoc.rst @@ -248,6 +248,27 @@ shown using such comments: The latter cannot be used around some inner parts of a proof, but can be used around a whole proof. +Lastly, it is possible to adopt a middle-ground approach when the +desired output is HTML, where a given snippet of Coq material is +hidden by default, but can be made visible with user interaction. + +:: + + + (* begin details *) + *some Coq material* + (* end details *) + + +There is also an alternative syntax available. + +:: + + + (* begin details : Some summary describing the snippet *) + *some Coq material* + (* end details *) + Usage ~~~~~ diff --git a/doc/stdlib/hidden-files b/doc/stdlib/hidden-files index 67d0b37e81..3af16cb731 100644 --- a/doc/stdlib/hidden-files +++ b/doc/stdlib/hidden-files @@ -44,6 +44,7 @@ theories/micromega/Refl.v theories/micromega/RingMicromega.v theories/micromega/Tauto.v theories/micromega/VarMap.v +theories/micromega/ZArith_hints.v theories/micromega/ZCoeff.v theories/micromega/ZMicromega.v theories/micromega/ZifyInst.v @@ -52,6 +53,7 @@ theories/micromega/ZifyComparison.v theories/micromega/ZifyClasses.v theories/micromega/ZifyPow.v theories/micromega/Zify.v +theories/nsatz/NsatzTactic.v theories/nsatz/Nsatz.v theories/omega/Omega.v theories/omega/OmegaLemmas.v diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index e64b4be454..b2c9c936c9 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -13,6 +13,7 @@ through the <tt>Require Import</tt> command.</p> The core library (automatically loaded when starting Coq) </dt> <dd> + theories/Init/Ltac.v theories/Init/Notations.v theories/Init/Datatypes.v theories/Init/Logic.v @@ -444,6 +445,7 @@ through the <tt>Require Import</tt> command.</p> theories/Sorting/PermutSetoid.v theories/Sorting/Mergesort.v theories/Sorting/Sorted.v + theories/Sorting/CPermutation.v </dd> <dt> <b>Wellfounded</b>: @@ -558,6 +560,7 @@ through the <tt>Require Import</tt> command.</p> theories/Reals/Rtrigo_fun.v theories/Reals/Rtrigo1.v theories/Reals/Rtrigo.v + theories/Reals/Rtrigo_facts.v theories/Reals/Ratan.v theories/Reals/Machin.v theories/Reals/SplitAbsolu.v diff --git a/doc/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index 6332c4c81d..9d51d2198a 100644 --- a/doc/tools/coqrst/coqdomain.py +++ b/doc/tools/coqrst/coqdomain.py @@ -188,20 +188,19 @@ class CoqObject(ObjectDescription): def _add_index_entry(self, name, target): """Add `name` (pointing to `target`) to the main index.""" assert isinstance(name, str) - if not name.startswith("_"): - # remove trailing . , found in commands, but not ... (ellipsis) - trim = name.endswith(".") and not name.endswith("...") - index_text = name[:-1] if trim else name - if self.index_suffix: - index_text += " " + self.index_suffix - self.indexnode['entries'].append(('single', index_text, target, '', None)) + # remove trailing . , found in commands, but not ... (ellipsis) + trim = name.endswith(".") and not name.endswith("...") + index_text = name[:-1] if trim else name + if self.index_suffix: + index_text += " " + self.index_suffix + self.indexnode['entries'].append(('single', index_text, target, '', None)) aliases = None # additional indexed names for a command or other object def add_target_and_index(self, name, _, signode): """Attach a link target to `signode` and an index entry for `name`. This is only called (from ``ObjectDescription.run``) if ``:noindex:`` isn't specified.""" - if name: + if name and not (isinstance(name, str) and name.startswith('_')): target = self._add_target(signode, name) self._add_index_entry(name, target) if self.aliases is not None: @@ -473,8 +472,7 @@ class ProductionObject(CoqObject): op = "|" rhs = parts[1].strip() else: - nsplits = 2 - parts = signature.split(maxsplit=nsplits) + parts = signature.split(maxsplit=2) if len(parts) != 3: loc = os.path.basename(get_node_location(signode)) raise ExtensionError(ProductionObject.SIG_ERROR.format(loc, signature)) @@ -1092,7 +1090,6 @@ class CoqVernacIndex(CoqSubdomainsIndex): class CoqTacticIndex(CoqSubdomainsIndex): name, localname, shortname, subdomains = "tacindex", "Tactic Index", "tactics", ["tacn"] -# Attribute index is generated but not included in output class CoqAttributeIndex(CoqSubdomainsIndex): name, localname, shortname, subdomains = "attrindex", "Attribute Index", "attributes", ["attr"] @@ -1118,6 +1115,19 @@ class IndexXRefRole(XRefRole): title = index.localname return title, target +class StdGlossaryIndex(Index): + name, localname, shortname = "glossindex", "Glossary", "terms" + + def generate(self, docnames=None): + content = defaultdict(list) + + for ((type, itemname), (docname, anchor)) in self.domain.data['objects'].items(): + if type == 'term': + entries = content[itemname[0].lower()] + entries.append([itemname, 0, docname, anchor, '', '', '']) + content = sorted(content.items()) + return content, False + def GrammarProductionRole(typ, rawtext, text, lineno, inliner, options={}, content=[]): """A grammar production not included in a ``productionlist`` directive. @@ -1134,7 +1144,7 @@ def GrammarProductionRole(typ, rawtext, text, lineno, inliner, options={}, conte """ #pylint: disable=dangerous-default-value, unused-argument env = inliner.document.settings.env - targetid = 'grammar-token-{}'.format(text) + targetid = nodes.make_id('grammar-token-{}'.format(text)) target = nodes.target('', '', ids=[targetid]) inliner.document.note_explicit_target(target) code = nodes.literal(rawtext, text, role=typ.lower()) @@ -1145,6 +1155,35 @@ def GrammarProductionRole(typ, rawtext, text, lineno, inliner, options={}, conte GrammarProductionRole.role_name = "production" + +def GlossaryDefRole(typ, rawtext, text, lineno, inliner, options={}, content=[]): + """Marks the definition of a glossary term inline in the text. Matching :term:`XXX` + constructs will link to it. The term will also appear in the Glossary Index. + + Example:: + + A :gdef:`prime` number is divisible only by itself and 1. + """ + #pylint: disable=dangerous-default-value, unused-argument + env = inliner.document.settings.env + std = env.domaindata['std']['objects'] + key = ('term', text) + + if key in std: + MSG = 'Duplicate object: {}; other is at {}' + msg = MSG.format(text, env.doc2path(std[key][0])) + inliner.document.reporter.warning(msg, line=lineno) + + targetid = nodes.make_id('term-{}'.format(text)) + std[key] = (env.docname, targetid) + target = nodes.target('', '', ids=[targetid], names=[text]) + inliner.document.note_explicit_target(target) + node = nodes.inline(rawtext, '', target, nodes.Text(text), classes=['term-defn']) + set_role_source_info(inliner, lineno, node) + return [node], [] + +GlossaryDefRole.role_name = "gdef" + class CoqDomain(Domain): """A domain to document Coq code. @@ -1217,7 +1256,7 @@ class CoqDomain(Domain): 'g': CoqCodeRole } - indices = [CoqVernacIndex, CoqTacticIndex, CoqOptionIndex, CoqGallinaIndex, CoqExceptionIndex] + indices = [CoqVernacIndex, CoqTacticIndex, CoqOptionIndex, CoqGallinaIndex, CoqExceptionIndex, CoqAttributeIndex] data_version = 1 initial_data = { @@ -1307,18 +1346,23 @@ COQ_ADDITIONAL_DIRECTIVES = [CoqtopDirective, InferenceDirective, PreambleDirective] -COQ_ADDITIONAL_ROLES = [GrammarProductionRole] +COQ_ADDITIONAL_ROLES = [GrammarProductionRole, + GlossaryDefRole] def setup(app): """Register the Coq domain""" # A few sanity checks: subdomains = set(obj.subdomain for obj in CoqDomain.directives.values()) - assert subdomains.issuperset(chain(*(idx.subdomains for idx in CoqDomain.indices))) - assert subdomains.issubset(CoqDomain.roles.keys()) + found = set (obj for obj in chain(*(idx.subdomains for idx in CoqDomain.indices))) + assert subdomains.issuperset(found), "Missing subdomains: {}".format(found.difference(subdomains)) + + assert subdomains.issubset(CoqDomain.roles.keys()), \ + "Missing from CoqDomain.roles: {}".format(subdomains.difference(CoqDomain.roles.keys())) # Add domain, directives, and roles app.add_domain(CoqDomain) + app.add_index_to_domain('std', StdGlossaryIndex) for role in COQ_ADDITIONAL_ROLES: app.add_role(role.role_name, role) diff --git a/doc/tools/docgram/common.edit_mlg b/doc/tools/docgram/common.edit_mlg index 60b845c4be..6111eaa160 100644 --- a/doc/tools/docgram/common.edit_mlg +++ b/doc/tools/docgram/common.edit_mlg @@ -151,8 +151,7 @@ fields: [ | DELETENT ] dirpath: [ | REPLACE ident LIST0 field -| WITH ident -| dirpath field_ident +| WITH LIST0 ( ident "." ) ident ] binders: [ @@ -220,6 +219,23 @@ tactic_expr0: [ | WITH "[>" tactic_then_gen "]" ] +(* lexer token *) +IDENT: [ +| ident +] + +scope_key: [ +| IDENT +] + +scope_name: [ +| IDENT +] + +scope: [ +| scope_name | scope_key +] + operconstr100: [ | MOVETO term_cast operconstr99 "<:" operconstr200 | MOVETO term_cast operconstr99 "<<:" operconstr200 @@ -240,7 +256,9 @@ operconstr9: [ operconstr1: [ | REPLACE operconstr0 ".(" global LIST0 appl_arg ")" -| WITH operconstr0 ".(" global LIST0 appl_arg ")" +| WITH operconstr0 ".(" global LIST0 appl_arg ")" (* huh? *) +| REPLACE operconstr0 "%" IDENT +| WITH operconstr0 "%" scope_key | MOVETO term_projection operconstr0 ".(" global LIST0 appl_arg ")" | MOVETO term_projection operconstr0 ".(" "@" global LIST0 ( operconstr9 ) ")" ] @@ -364,6 +382,11 @@ pattern10: [ | DELETE pattern1 ] +pattern1: [ +| REPLACE pattern0 "%" IDENT +| WITH pattern0 "%" scope_key +] + pattern0: [ | REPLACE "(" pattern200 ")" | WITH "(" LIST1 pattern200 SEP "|" ")" @@ -419,6 +442,8 @@ gallina: [ | WITH "Let" "CoFixpoint" corec_definition LIST0 ( "with" corec_definition ) | REPLACE "Scheme" LIST1 scheme SEP "with" | WITH "Scheme" scheme LIST0 ( "with" scheme ) +| REPLACE "Primitive" identref OPT [ ":" lconstr ] ":=" register_token +| WITH "Primitive" identref OPT [ ":" lconstr ] ":=" "#" identref ] constructor_list_or_record_decl: [ @@ -494,8 +519,10 @@ strategy_flag: [ | OPTINREF ] -export_token: [ -| OPTINREF +filtered_import: [ +| REPLACE global "(" LIST1 one_import_filter_name SEP "," ")" +| WITH global OPT [ "(" LIST1 one_import_filter_name SEP "," ")" ] +| DELETE global ] functor_app_annot: [ @@ -536,20 +563,23 @@ gallina_ext: [ | REPLACE "Generalizable" [ "All" "Variables" | "No" "Variables" | [ "Variable" | "Variables" ] LIST1 identref ] | WITH "Generalizable" [ [ "Variable" | "Variables" ] LIST1 identref | "All" "Variables" | "No" "Variables" ] +(* don't show Export for Set, Unset *) | REPLACE "Export" "Set" option_table option_setting -| WITH OPT "Export" "Set" option_table option_setting +| WITH "Set" option_table option_setting | REPLACE "Export" "Unset" option_table -| WITH OPT "Export" "Unset" option_table +| WITH "Unset" option_table | REPLACE "Instance" instance_name ":" operconstr200 hint_info [ ":=" "{" record_declaration "}" | ":=" lconstr | ] | WITH "Instance" instance_name ":" operconstr200 hint_info OPT [ ":=" "{" record_declaration "}" | ":=" lconstr ] +| REPLACE "From" global "Require" export_token LIST1 global +| WITH "From" dirpath "Require" export_token LIST1 global ] -(* lexer stuff *) -IDENT: [ -| ident +export_token: [ +| OPTINREF ] +(* lexer stuff *) integer: [ | DELETENT ] RENAME: [ | integer int (* todo: review uses in .mlg files, some should be "natural" *) @@ -857,8 +887,14 @@ bar_cbrace: [ ] printable: [ +| REPLACE "Scope" IDENT +| WITH "Scope" scope_name +| REPLACE "Visibility" OPT IDENT +| WITH "Visibility" OPT scope_name | REPLACE [ "Sorted" | ] "Universes" OPT printunivs_subgraph OPT ne_string | WITH OPT "Sorted" "Universes" OPT printunivs_subgraph OPT ne_string +| DELETE "Term" smart_global OPT univ_name_list (* readded in commands *) + | INSERTALL "Print" ] @@ -878,16 +914,19 @@ command: [ | DELETE "Back" | REPLACE "Back" natural | WITH "Back" OPT natural -| REPLACE "Test" option_table "for" LIST1 option_ref_value -| WITH "Test" option_table OPT ( "for" LIST1 option_ref_value ) -| DELETE "Test" option_table | REPLACE "Load" [ "Verbose" | ] [ ne_string | IDENT ] | WITH "Load" OPT "Verbose" [ ne_string | IDENT ] | DELETE "Unset" option_table -| DELETE "Set" option_table option_setting -| REPLACE "Add" IDENT IDENT LIST1 option_ref_value -| WITH "Add" IDENT OPT IDENT LIST1 option_ref_value -| DELETE "Add" IDENT LIST1 option_ref_value +| REPLACE "Set" option_table option_setting +| WITH OPT "Export" "Set" option_table (* set flag *) +| REPLACE "Test" option_table "for" LIST1 table_value +| WITH "Test" option_table OPT ( "for" LIST1 table_value ) +| DELETE "Test" option_table + +(* hide the fact that table names are limited to 2 IDENTs *) +| REPLACE "Add" IDENT IDENT LIST1 table_value +| WITH "Add" option_table LIST1 table_value +| DELETE "Add" IDENT LIST1 table_value | DELETE "Add" "Parametric" "Relation" binders ":" constr constr "reflexivity" "proved" "by" constr "symmetry" "proved" "by" constr "as" ident | DELETE "Add" "Parametric" "Relation" binders ":" constr constr "reflexivity" "proved" "by" constr "as" ident | DELETE "Add" "Parametric" "Relation" binders ":" constr constr "reflexivity" "proved" "by" constr "transitivity" "proved" "by" constr "as" ident @@ -941,7 +980,11 @@ command: [ | REPLACE "Preterm" "of" ident | WITH "Preterm" OPT ( "of" ident ) | DELETE "Preterm" -| EDIT "Remove" ADD_OPT IDENT IDENT LIST1 option_ref_value + +(* hide the fact that table names are limited to 2 IDENTs *) +| REPLACE "Remove" IDENT IDENT LIST1 table_value +| WITH "Remove" option_table LIST1 table_value +| DELETE "Remove" IDENT LIST1 table_value | DELETE "Restore" "State" IDENT | DELETE "Restore" "State" ne_string | "Restore" "State" [ IDENT | ne_string ] @@ -976,23 +1019,66 @@ command: [ | REPLACE "Abort" identref | WITH "Abort" OPT [ "All" | identref ] +(* show the locate options as separate commands *) +| DELETE "Locate" locatable +| locatable +| REPLACE "Print" smart_global OPT univ_name_list +| WITH "Print" OPT "Term" smart_global OPT univ_name_list + +| REPLACE "Declare" "Scope" IDENT +| WITH "Declare" "Scope" scope_name + +(* odd that these are in command while other notation-related ones are in syntax *) +| REPLACE "Numeral" "Notation" reference reference reference ":" ident numnotoption +| WITH "Numeral" "Notation" reference reference reference ":" scope_name numnotoption +| REPLACE "String" "Notation" reference reference reference ":" ident +| WITH "String" "Notation" reference reference reference ":" scope_name + ] -only_parsing: [ +option_setting: [ | OPTINREF ] syntax: [ +| REPLACE "Open" "Scope" IDENT +| WITH "Open" "Scope" scope +| REPLACE "Close" "Scope" IDENT +| WITH "Close" "Scope" scope +| REPLACE "Delimit" "Scope" IDENT; "with" IDENT +| WITH "Delimit" "Scope" scope_name; "with" scope_key +| REPLACE "Undelimit" "Scope" IDENT +| WITH "Undelimit" "Scope" scope_name +| REPLACE "Bind" "Scope" IDENT; "with" LIST1 class_rawexpr +| WITH "Bind" "Scope" scope_name; "with" LIST1 class_rawexpr | REPLACE "Infix" ne_lstring ":=" constr [ "(" LIST1 syntax_modifier SEP "," ")" | ] OPT [ ":" IDENT ] -| WITH "Infix" ne_lstring ":=" constr OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] OPT [ ":" IDENT ] +| WITH "Infix" ne_lstring ":=" constr OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] OPT [ ":" scope_name ] | REPLACE "Notation" lstring ":=" constr [ "(" LIST1 syntax_modifier SEP "," ")" | ] OPT [ ":" IDENT ] -| WITH "Notation" lstring ":=" constr OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] OPT [ ":" IDENT ] +| WITH "Notation" lstring ":=" constr OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] OPT [ ":" scope_name ] | REPLACE "Reserved" "Infix" ne_lstring [ "(" LIST1 syntax_modifier SEP "," ")" | ] | WITH "Reserved" "Infix" ne_lstring OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] | REPLACE "Reserved" "Notation" ne_lstring [ "(" LIST1 syntax_modifier SEP "," ")" | ] | WITH "Reserved" "Notation" ne_lstring OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] ] +syntax_modifier: [ +| DELETE "in" "custom" IDENT +| REPLACE "in" "custom" IDENT; "at" "level" natural +| WITH "in" "custom" IDENT OPT ( "at" "level" natural ) +| REPLACE IDENT; "," LIST1 IDENT SEP "," "at" level +| WITH LIST1 IDENT SEP "," "at" level +] + +syntax_extension_type: [ +| REPLACE "strict" "pattern" "at" "level" natural +| WITH "strict" "pattern" OPT ( "at" "level" natural ) +| DELETE "strict" "pattern" +| DELETE "pattern" +| REPLACE "pattern" "at" "level" natural +| WITH "pattern" OPT ( "at" "level" natural ) +| DELETE "constr" (* covered by another prod *) +] + numnotoption: [ | OPTINREF ] @@ -1062,9 +1148,7 @@ legacy_attr: [ | DELETE "NonCumulative" ] -vernacular: [ -| LIST0 ( OPT all_attrs [ command | tactic ] "." ) -] +sentence: [ ] (* productions defined below *) rec_definition: [ | REPLACE ident_decl binders_fixannot type_cstr OPT [ ":=" lconstr ] decl_notations @@ -1124,7 +1208,7 @@ query_command: [ | REPLACE "SearchRewrite" constr_pattern in_or_out_modules "." | WITH "SearchRewrite" constr_pattern in_or_out_modules | REPLACE "Search" searchabout_query searchabout_queries "." -| WITH "Search" searchabout_query searchabout_queries +| WITH "Search" searchabout_queries ] vernac_toplevel: [ @@ -1142,37 +1226,25 @@ vernac_toplevel: [ | DELETE vernac_control ] -positive_search_mark: [ -| OPTINREF -] - in_or_out_modules: [ | OPTINREF ] -searchabout_queries: [ -| OPTINREF -] - vernac_control: [ (* replacing vernac_control with command is cheating a little; they can't refer to the vernac_toplevel commands. cover this the descriptions of these commands *) | REPLACE "Time" vernac_control -| WITH "Time" command +| WITH "Time" sentence | REPLACE "Redirect" ne_string vernac_control -| WITH "Redirect" ne_string command +| WITH "Redirect" ne_string sentence | REPLACE "Timeout" natural vernac_control -| WITH "Timeout" natural command +| WITH "Timeout" natural sentence | REPLACE "Fail" vernac_control -| WITH "Fail" command +| WITH "Fail" sentence | DELETE decorated_vernac ] -option_setting: [ -| OPTINREF -] - orient: [ | OPTINREF ] @@ -1351,6 +1423,68 @@ module_expr: [ | DELETE module_expr module_expr_atom ] +locatable: [ +| INSERTALL "Locate" +] + +ne_in_or_out_modules: [ +| REPLACE "inside" LIST1 global +| WITH [ "inside" | "outside" ] LIST1 global +| DELETE "outside" LIST1 global +] + +searchabout_query: [ +| REPLACE positive_search_mark ne_string OPT scope_delimiter +| WITH ne_string OPT scope_delimiter +| REPLACE positive_search_mark constr_pattern +| WITH constr_pattern +] + +searchabout_queries: [ +| DELETE ne_in_or_out_modules +| REPLACE searchabout_query searchabout_queries +| WITH LIST1 ( positive_search_mark searchabout_query ) OPT ne_in_or_out_modules +| DELETE (* empty *) +] + +positive_search_mark: [ +| OPTINREF +] + +by_notation: [ +| REPLACE ne_string OPT [ "%" IDENT ] +| WITH ne_string OPT [ "%" scope_key ] +] + +scope_delimiter: [ +| REPLACE "%" IDENT +| WITH "%" scope_key +] + +(* Don't show these details *) +DELETE: [ +| register_token +| register_prim_token +| register_type_token +] + + +decl_notation: [ +| REPLACE ne_lstring ":=" constr only_parsing OPT [ ":" IDENT ] +| WITH ne_lstring ":=" constr only_parsing OPT [ ":" scope_name ] +] + + +only_parsing: [ +| OPTINREF +] + +ltac_production_item: [ +| REPLACE ident "(" ident OPT ltac_production_sep ")" +| WITH ident OPT ( "(" ident OPT ltac_production_sep ")" ) +| DELETE ident +] + SPLICE: [ | noedit_mode | bigint @@ -1435,9 +1569,7 @@ SPLICE: [ | mode | mult_pattern | open_constr -| option_table | record_declaration -| register_type_token | tactic | uconstr | impl_ident_head @@ -1466,14 +1598,12 @@ SPLICE: [ | assum_coe | inline | occs -| univ_name_list | ltac_info | field_mods | ltac_production_sep | ltac_tactic_level | printunivs_subgraph | ring_mods -| scope_delimiter | eliminator (* todo: splice or not? *) | quoted_attributes (* todo: splice or not? *) | printable @@ -1483,10 +1613,9 @@ SPLICE: [ | constructor_type | record_binder | at_level_opt -| option_ref_value +| table_value | positive_search_mark | in_or_out_modules -| register_prim_token | option_setting | orient | with_bindings @@ -1518,6 +1647,12 @@ SPLICE: [ | ltac_def_kind | intropatterns | instance_name +| ne_in_or_out_modules +| searchabout_queries +| locatable +| scope_delimiter +| bignat +| one_import_filter_name ] (* end SPLICE *) RENAME: [ @@ -1567,8 +1702,18 @@ RENAME: [ | record_binder_body field_body | class_rawexpr class | smart_global smart_qualid +| searchabout_query search_item +| option_table setting_name +| argument_spec_block arg_specs +| more_implicits_block implicits_alt +| arguments_modifier args_modifier +| constr_as_binder_kind binder_interp +| syntax_extension_type explicit_subentry +| numnotoption numeral_modifier ] +(* todo: positive_search_mark is a lousy name for OPT "-" *) + (* todo: doesn't work if up above... maybe because 'clause' doesn't exist? *) clause_dft_concl: [ | OPTINREF @@ -1656,3 +1801,18 @@ SPLICE: [ | tactic_notation_tactics ] (* todo: ssrreflect*.rst ref to fix_body is incorrect *) + +(* not included in insertprodn; defined in rst with :production: *) +control_command: [ ] +query_command: [ ] (* re-add since previously spliced *) + +sentence: [ +| OPT all_attrs command "." +| OPT all_attrs OPT ( num ":" ) query_command "." +| OPT all_attrs OPT toplevel_selector ltac_expr [ "." | "..." ] +| control_command +] + +vernacular: [ +| LIST0 sentence +] diff --git a/doc/tools/docgram/doc_grammar.ml b/doc/tools/docgram/doc_grammar.ml index eea1d5081d..98f826cd29 100644 --- a/doc/tools/docgram/doc_grammar.ml +++ b/doc/tools/docgram/doc_grammar.ml @@ -189,6 +189,9 @@ let rec db_output_prodn = function and db_out_list prod = sprintf "(%s)" (map_and_concat db_output_prodn prod) and db_out_prods prods = sprintf "( %s )" (map_and_concat ~delim:" | " db_out_list prods) +(* identify special chars that don't get a trailing space in output *) +let omit_space s = List.mem s ["?"; "."; "#"] + let rec output_prod plist need_semi = function | Sterm s -> if plist then sprintf "%s" s else sprintf "\"%s\"" s | Snterm s -> @@ -225,7 +228,7 @@ let rec output_prod plist need_semi = function and prod_to_str_r plist prod = match prod with - | Sterm s :: Snterm "ident" :: tl when List.mem s ["?"; "."] && plist -> + | Sterm s :: Snterm "ident" :: tl when omit_space s && plist -> (sprintf "%s`ident`" s) :: (prod_to_str_r plist tl) | p :: tl -> let need_semi = @@ -282,7 +285,7 @@ and output_sep sep = and prod_to_prodn_r prod = match prod with - | Sterm s :: Snterm "ident" :: tl when List.mem s ["?"; "."] -> + | Sterm s :: Snterm "ident" :: tl when omit_space s -> (sprintf "%s@ident" s) :: (prod_to_prodn_r tl) | p :: tl -> (output_prodn p) :: (prod_to_prodn_r tl) | [] -> [] @@ -1621,6 +1624,7 @@ let open_temp_bin file = open_out_bin (sprintf "%s.new" file) let match_cmd_regex = Str.regexp "[a-zA-Z0-9_ ]+" +let match_subscripts = Str.regexp "__[a-zA-Z0-9]+" let find_longest_match prods str = let get_pfx str = String.trim (if Str.string_match match_cmd_regex str 0 then Str.matched_string str else "") in @@ -1634,19 +1638,26 @@ let find_longest_match prods str = in aux 0 in + let remove_subscrs str = Str.global_replace match_subscripts "" str in let slen = String.length str in let str_pfx = get_pfx str in + let no_subscrs = remove_subscrs str in + let has_subscrs = no_subscrs <> str in let rec longest best multi best_len prods = match prods with | [] -> best, multi, best_len | prod :: tl -> let pstr = String.trim prod in (* todo: should be pretrimmed *) let clen = common_prefix_len str pstr in - if str_pfx = "" || str_pfx <> get_pfx pstr then + if has_subscrs && no_subscrs = pstr then + str, false, clen (* exact match ignoring subscripts *) + else if pstr = str then + pstr, false, clen (* exact match of full line *) + else if str_pfx = "" || str_pfx <> get_pfx pstr then longest best multi best_len tl (* prefixes don't match *) else if clen = slen && slen = String.length pstr then - pstr, false, clen (* exact match *) + pstr, false, clen (* exact match on prefix *) else if clen > best_len then longest pstr false clen tl (* better match *) else if clen = best_len then @@ -1654,7 +1665,11 @@ let find_longest_match prods str = else longest best multi best_len tl (* worse match *) in - longest "" false 0 prods + let mtch, multi, _ = longest "" false 0 prods in + if has_subscrs && mtch <> str then + "", multi, mtch (* no match for subscripted entry *) + else + mtch, multi, "" type seen = { nts: (string * int) NTMap.t; @@ -1753,8 +1768,16 @@ let process_rst g file args seen tac_prods cmd_prods = (* in*) let cmd_replace_files = [ + "doc/sphinx/language/core/records.rst"; + "doc/sphinx/language/core/sections.rst"; + "doc/sphinx/language/extensions/implicit-arguments.rst"; + "doc/sphinx/language/extensions/arguments-command.rst"; + "doc/sphinx/language/using/libraries/funind.rst"; + "doc/sphinx/language/gallina-specification-language.rst"; - "doc/sphinx/language/gallina-extensions.rst" + "doc/sphinx/language/gallina-extensions.rst"; + "doc/sphinx/proof-engine/vernacular-commands.rst"; + "doc/sphinx/user-extensions/syntax-extensions.rst" ] in @@ -1763,11 +1786,14 @@ let process_rst g file args seen tac_prods cmd_prods = if StringSet.is_empty prods || not (List.mem file cmd_replace_files) then rhs (* no change *) else - let mtch, multi, len = find_longest_match prods rhs in + let mtch, multi, best = find_longest_match prods rhs in +(* Printf.printf "mtch = '%s' rhs = '%s'\n" mtch rhs;*) if mtch = rhs then rhs (* no change *) else if mtch = "" then begin warn "%s line %d: NO MATCH `%s`\n" file !linenum rhs; + if best <> "" then + warn "%s line %d: BEST `%s`\n" file !linenum best; rhs end else if multi then begin warn "%s line %d: MULTIMATCH `%s`\n" file !linenum rhs; diff --git a/doc/tools/docgram/dune b/doc/tools/docgram/dune index fba4856241..a533a6d367 100644 --- a/doc/tools/docgram/dune +++ b/doc/tools/docgram/dune @@ -43,9 +43,6 @@ orderedGrammar) (action (progn - (bash "for f in fullGrammar orderedGrammar; do cp ${f} ${f}.old; done") - (chdir %{project_root} (run doc_grammar -check-cmds %{input})) - (bash "for f in fullGrammar orderedGrammar; do cp ${f} ${f}.new; done") - (bash "for f in fullGrammar orderedGrammar; do cp ${f}.old ${f}; done") + (chdir %{project_root} (run doc_grammar -check-cmds -no-update %{input})) (diff? fullGrammar fullGrammar.new) (diff? orderedGrammar orderedGrammar.new)))) diff --git a/doc/tools/docgram/fullGrammar b/doc/tools/docgram/fullGrammar index 272d17bb35..4274dccb40 100644 --- a/doc/tools/docgram/fullGrammar +++ b/doc/tools/docgram/fullGrammar @@ -524,12 +524,12 @@ command: [ | "Set" option_table option_setting | "Unset" option_table | "Print" "Table" option_table -| "Add" IDENT IDENT LIST1 option_ref_value -| "Add" IDENT LIST1 option_ref_value -| "Test" option_table "for" LIST1 option_ref_value +| "Add" IDENT IDENT LIST1 table_value +| "Add" IDENT LIST1 table_value +| "Test" option_table "for" LIST1 table_value | "Test" option_table -| "Remove" IDENT IDENT LIST1 option_ref_value -| "Remove" IDENT LIST1 option_ref_value +| "Remove" IDENT IDENT LIST1 table_value +| "Remove" IDENT LIST1 table_value | "Write" "State" IDENT | "Write" "State" ne_string | "Restore" "State" IDENT @@ -773,7 +773,7 @@ gallina: [ | assumption_token inline assum_list | assumptions_token inline assum_list | def_token ident_decl def_body -| "Let" identref def_body +| "Let" ident_decl def_body | finite_token LIST1 inductive_definition SEP "with" | "Fixpoint" LIST1 rec_definition SEP "with" | "Let" "Fixpoint" LIST1 rec_definition SEP "with" @@ -1027,13 +1027,12 @@ gallina_ext: [ | "Module" "Type" identref LIST0 module_binder check_module_types is_module_type | "Declare" "Module" export_token identref LIST0 module_binder ":" module_type_inl | "Section" identref -| "Chapter" identref | "End" identref | "Collection" identref ":=" section_subset_expr | "Require" export_token LIST1 global | "From" global "Require" export_token LIST1 global -| "Import" LIST1 global -| "Export" LIST1 global +| "Import" LIST1 filtered_import +| "Export" LIST1 filtered_import | "Include" module_type_inl LIST0 ext_module_expr | "Include" "Type" module_type_inl LIST0 ext_module_type | "Transparent" LIST1 smart_global @@ -1058,6 +1057,15 @@ gallina_ext: [ | "Export" "Unset" option_table ] +filtered_import: [ +| global +| global "(" LIST1 one_import_filter_name SEP "," ")" +] + +one_import_filter_name: [ +| global OPT [ "(" ".." ")" ] +] + export_token: [ | "Import" | "Export" @@ -1310,7 +1318,7 @@ option_setting: [ | STRING ] -option_ref_value: [ +table_value: [ | global | STRING ] diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index 0c9d7a853b..2a30c03dd2 100644 --- a/doc/tools/docgram/orderedGrammar +++ b/doc/tools/docgram/orderedGrammar @@ -47,7 +47,7 @@ one_term: [ term1: [ | term_projection -| term0 "%" ident +| term0 "%" scope_key | term0 ] @@ -159,7 +159,20 @@ where: [ ] vernacular: [ -| LIST0 ( OPT all_attrs [ command | ltac_expr ] "." ) +| LIST0 sentence +] + +sentence: [ +| OPT all_attrs command "." +| OPT all_attrs OPT ( num ":" ) query_command "." +| OPT all_attrs OPT toplevel_selector ltac_expr [ "." | "..." ] +| control_command +] + +control_command: [ +] + +query_command: [ ] tacticals: [ @@ -330,7 +343,7 @@ pattern10: [ ] pattern1: [ -| pattern0 "%" ident +| pattern0 "%" scope_key | pattern0 ] @@ -359,61 +372,6 @@ fix_definition: [ | ident_decl LIST0 binder OPT fixannot OPT ( ":" type ) OPT [ ":=" term ] OPT decl_notations ] -decl_notations: [ -| "where" decl_notation LIST0 ( "and" decl_notation ) -] - -decl_notation: [ -| string ":=" one_term OPT ( "(" "only" "parsing" ")" ) OPT [ ":" ident ] -] - -register_token: [ -| "#int63_type" -| "#float64_type" -| "#int63_head0" -| "#int63_tail0" -| "#int63_add" -| "#int63_sub" -| "#int63_mul" -| "#int63_div" -| "#int63_mod" -| "#int63_lsr" -| "#int63_lsl" -| "#int63_land" -| "#int63_lor" -| "#int63_lxor" -| "#int63_addc" -| "#int63_subc" -| "#int63_addcarryc" -| "#int63_subcarryc" -| "#int63_mulc" -| "#int63_diveucl" -| "#int63_div21" -| "#int63_addmuldiv" -| "#int63_eq" -| "#int63_lt" -| "#int63_le" -| "#int63_compare" -| "#float64_opp" -| "#float64_abs" -| "#float64_eq" -| "#float64_lt" -| "#float64_le" -| "#float64_compare" -| "#float64_classify" -| "#float64_add" -| "#float64_sub" -| "#float64_mul" -| "#float64_div" -| "#float64_sqrt" -| "#float64_of_int63" -| "#float64_normfr_mantissa" -| "#float64_frshiftexp" -| "#float64_ldshiftexp" -| "#float64_next_up" -| "#float64_next_down" -] - thm_token: [ | "Theorem" | "Lemma" @@ -531,6 +489,10 @@ constructor: [ | ident LIST0 binder OPT of_type ] +filtered_import: [ +| qualid OPT [ "(" LIST1 ( qualid OPT [ "(" ".." ")" ] ) SEP "," ")" ] +] + cofix_definition: [ | ident_decl LIST0 binder OPT ( ":" type ) OPT [ ":=" term ] OPT decl_notations ] @@ -601,46 +563,59 @@ smart_qualid: [ ] by_notation: [ -| string OPT [ "%" ident ] +| string OPT [ "%" scope_key ] +] + +argument_spec: [ +| OPT "!" name OPT ( "%" scope_key ) ] -argument_spec_block: [ +arg_specs: [ | argument_spec | "/" | "&" -| "(" LIST1 argument_spec ")" OPT ( "%" ident ) -| "[" LIST1 argument_spec "]" OPT ( "%" ident ) -| "{" LIST1 argument_spec "}" OPT ( "%" ident ) +| "(" LIST1 argument_spec ")" OPT ( "%" scope_key ) +| "[" LIST1 argument_spec "]" OPT ( "%" scope_key ) +| "{" LIST1 argument_spec "}" OPT ( "%" scope_key ) ] -argument_spec: [ -| OPT "!" name OPT ( "%" ident ) -] - -more_implicits_block: [ +implicits_alt: [ | name | "[" LIST1 name "]" | "{" LIST1 name "}" ] -arguments_modifier: [ +args_modifier: [ | "simpl" "nomatch" | "simpl" "never" | "default" "implicits" -| "clear" "bidirectionality" "hint" | "clear" "implicits" | "clear" "scopes" -| "clear" "scopes" "and" "implicits" -| "clear" "implicits" "and" "scopes" +| "clear" "bidirectionality" "hint" | "rename" | "assert" | "extra" "scopes" +| "clear" "scopes" "and" "implicits" +| "clear" "implicits" "and" "scopes" +] + +scope: [ +| scope_name +| scope_key +] + +scope_name: [ +| ident +] + +scope_key: [ +| ident ] strategy_level: [ -| "expand" | "opaque" | int +| "expand" | "transparent" ] @@ -655,17 +630,20 @@ simple_reserv: [ command: [ | "Goal" term -| "Declare" "Scope" ident | "Pwd" | "Cd" OPT string | "Load" OPT "Verbose" [ string | ident ] | "Declare" "ML" "Module" LIST1 string -| "Locate" locatable +| "Locate" smart_qualid +| "Locate" "Term" smart_qualid +| "Locate" "Module" qualid +| "Locate" "Ltac" qualid +| "Locate" "Library" qualid +| "Locate" "File" string | "Add" "LoadPath" string "as" dirpath | "Add" "Rec" "LoadPath" string "as" dirpath | "Remove" "LoadPath" string | "Type" term -| "Print" "Term" smart_qualid OPT ( "@{" LIST0 name "}" ) | "Print" "All" | "Print" "Section" qualid | "Print" "Grammar" ident @@ -691,8 +669,8 @@ command: [ | "Print" "Hint" "*" | "Print" "HintDb" ident | "Print" "Scopes" -| "Print" "Scope" ident -| "Print" "Visibility" OPT ident +| "Print" "Scope" scope_name +| "Print" "Visibility" OPT scope_name | "Print" "Implicit" smart_qualid | "Print" OPT "Sorted" "Universes" OPT ( "Subgraph" "(" LIST0 qualid ")" ) OPT string | "Print" "Assumptions" smart_qualid @@ -702,18 +680,17 @@ command: [ | "Print" "Strategy" smart_qualid | "Print" "Strategies" | "Print" "Registered" -| "Print" smart_qualid OPT ( "@{" LIST0 name "}" ) +| "Print" OPT "Term" smart_qualid OPT univ_name_list | "Print" "Module" "Type" qualid | "Print" "Module" qualid | "Print" "Namespace" dirpath | "Inspect" num | "Add" "ML" "Path" string -| OPT "Export" "Set" LIST1 ident OPT [ int | string ] -| OPT "Export" "Unset" LIST1 ident -| "Print" "Table" LIST1 ident -| "Add" ident OPT ident LIST1 [ qualid | string ] -| "Test" LIST1 ident OPT ( "for" LIST1 [ qualid | string ] ) -| "Remove" OPT ident ident LIST1 [ qualid | string ] +| OPT "Export" "Set" setting_name +| "Print" "Table" setting_name +| "Add" setting_name LIST1 [ qualid | string ] +| "Test" setting_name OPT ( "for" LIST1 [ qualid | string ] ) +| "Remove" setting_name LIST1 [ qualid | string ] | "Write" "State" [ ident | string ] | "Restore" "State" [ ident | string ] | "Reset" "Initial" @@ -751,6 +728,7 @@ command: [ | "Hint" hint OPT ( ":" LIST1 ident ) | "Comments" LIST0 comment | "Declare" "Instance" ident_decl LIST0 binder ":" term OPT hint_info +| "Declare" "Scope" scope_name | "Obligation" int OPT ( "of" ident ) OPT ( ":" term OPT ( "with" ltac_expr ) ) | "Next" "Obligation" OPT ( "of" ident ) OPT ( "with" ltac_expr ) | "Solve" "Obligation" int OPT ( "of" ident ) "with" ltac_expr @@ -806,7 +784,6 @@ command: [ | "Tactic" "Notation" OPT ( "(" "at" "level" num ")" ) LIST1 ltac_production_item ":=" ltac_expr | "Print" "Rewrite" "HintDb" ident | "Print" "Ltac" qualid -| "Locate" "Ltac" qualid | "Ltac" tacdef_body LIST0 ( "with" tacdef_body ) | "Print" "Ltac" "Signatures" | "Set" "Firstorder" "Solver" ltac_expr @@ -845,13 +822,13 @@ command: [ | "Print" "Rings" (* setoid_ring plugin *) | "Add" "Field" ident ":" one_term OPT ( "(" LIST1 field_mod SEP "," ")" ) (* setoid_ring plugin *) | "Print" "Fields" (* setoid_ring plugin *) -| "Numeral" "Notation" qualid qualid qualid ":" ident OPT numnotoption -| "String" "Notation" qualid qualid qualid ":" ident +| "Numeral" "Notation" qualid qualid qualid ":" scope_name OPT numeral_modifier +| "String" "Notation" qualid qualid qualid ":" scope_name | "SubClass" ident_decl def_body | thm_token ident_decl LIST0 binder ":" type LIST0 [ "with" ident_decl LIST0 binder ":" type ] | assumption_token OPT ( "Inline" OPT ( "(" num ")" ) ) [ LIST1 ( "(" assumpt ")" ) | assumpt ] | [ "Definition" | "Example" ] ident_decl def_body -| "Let" ident def_body +| "Let" ident_decl def_body | "Inductive" inductive_definition LIST0 ( "with" inductive_definition ) | "Fixpoint" fix_definition LIST0 ( "with" fix_definition ) | "Let" "Fixpoint" fix_definition LIST0 ( "with" fix_definition ) @@ -861,7 +838,7 @@ command: [ | "Combined" "Scheme" ident "from" LIST1 ident SEP "," | "Register" qualid "as" qualid | "Register" "Inline" qualid -| "Primitive" ident OPT [ ":" term ] ":=" register_token +| "Primitive" ident OPT [ ":" term ] ":=" "#" ident | "Universe" LIST1 ident | "Universes" LIST1 ident | "Constraint" LIST1 univ_constraint SEP "," @@ -873,13 +850,12 @@ command: [ | "Module" "Type" ident LIST0 module_binder LIST0 ( "<:" module_type_inl ) OPT ( ":=" LIST1 module_type_inl SEP "<+" ) | "Declare" "Module" OPT [ "Import" | "Export" ] ident LIST0 module_binder ":" module_type_inl | "Section" ident -| "Chapter" ident | "End" ident | "Collection" ident ":=" section_subset_expr | "Require" OPT [ "Import" | "Export" ] LIST1 qualid -| "From" qualid "Require" OPT [ "Import" | "Export" ] LIST1 qualid -| "Import" LIST1 qualid -| "Export" LIST1 qualid +| "From" dirpath "Require" OPT [ "Import" | "Export" ] LIST1 qualid +| "Import" LIST1 filtered_import +| "Export" LIST1 filtered_import | "Include" module_type_inl LIST0 ( "<+" module_expr_inl ) | "Include" "Type" LIST1 module_type_inl SEP "<+" | "Transparent" LIST1 smart_qualid @@ -896,32 +872,34 @@ command: [ | "Existing" "Instance" qualid OPT hint_info | "Existing" "Instances" LIST1 qualid OPT [ "|" num ] | "Existing" "Class" qualid -| "Arguments" smart_qualid LIST0 argument_spec_block LIST0 [ "," LIST0 more_implicits_block ] OPT [ ":" LIST1 arguments_modifier SEP "," ] +| "Arguments" smart_qualid LIST0 arg_specs LIST0 [ "," LIST0 implicits_alt ] OPT [ ":" LIST1 args_modifier SEP "," ] | "Implicit" [ "Type" | "Types" ] reserv_list | "Generalizable" [ [ "Variable" | "Variables" ] LIST1 ident | "All" "Variables" | "No" "Variables" ] -| "Open" "Scope" ident -| "Close" "Scope" ident -| "Delimit" "Scope" ident "with" ident -| "Undelimit" "Scope" ident -| "Bind" "Scope" ident "with" LIST1 class -| "Infix" string ":=" one_term OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] OPT [ ":" ident ] +| "Set" setting_name OPT [ int | string ] +| "Unset" setting_name +| "Open" "Scope" scope +| "Close" "Scope" scope +| "Delimit" "Scope" scope_name "with" scope_key +| "Undelimit" "Scope" scope_name +| "Bind" "Scope" scope_name "with" LIST1 class +| "Infix" string ":=" one_term OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] OPT [ ":" scope_name ] | "Notation" ident LIST0 ident ":=" one_term OPT ( "(" "only" "parsing" ")" ) -| "Notation" string ":=" one_term OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] OPT [ ":" ident ] +| "Notation" string ":=" one_term OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] OPT [ ":" scope_name ] | "Format" "Notation" string string string | "Reserved" "Infix" string OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] | "Reserved" "Notation" string OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] | "Eval" red_expr "in" term | "Compute" term | "Check" term -| "About" smart_qualid OPT ( "@{" LIST0 name "}" ) -| "SearchHead" one_term OPT ne_in_or_out_modules -| "SearchPattern" one_term OPT ne_in_or_out_modules -| "SearchRewrite" one_term OPT ne_in_or_out_modules -| "Search" searchabout_query OPT searchabout_queries -| "Time" command -| "Redirect" string command -| "Timeout" num command -| "Fail" command +| "About" smart_qualid OPT univ_name_list +| "SearchHead" one_term OPT ( [ "inside" | "outside" ] LIST1 qualid ) +| "SearchPattern" one_term OPT ( [ "inside" | "outside" ] LIST1 qualid ) +| "SearchRewrite" one_term OPT ( [ "inside" | "outside" ] LIST1 qualid ) +| "Search" LIST1 ( OPT "-" search_item ) OPT ( [ "inside" | "outside" ] LIST1 qualid ) +| "Time" sentence +| "Redirect" string sentence +| "Timeout" num sentence +| "Fail" sentence | "Drop" | "Quit" | "BackTo" num @@ -960,20 +938,11 @@ starredidentref: [ ] dirpath: [ -| ident -| dirpath field_ident +| LIST0 ( ident "." ) ident ] -bignat: [ -| numeral -] - -locatable: [ -| smart_qualid -| "Term" smart_qualid -| "File" string -| "Library" qualid -| "Module" qualid +setting_name: [ +| LIST1 ident ] comment: [ @@ -982,6 +951,15 @@ comment: [ | num ] +search_item: [ +| one_term +| string OPT ( "%" scope_key ) +] + +univ_name_list: [ +| "@{" LIST0 name "}" +] + hint: [ | "Resolve" LIST1 [ qualid | one_term ] OPT hint_info | "Resolve" "->" LIST1 qualid OPT num @@ -1006,13 +984,7 @@ tacdef_body: [ ltac_production_item: [ | string -| ident "(" ident OPT ( "," string ) ")" -| ident -] - -numnotoption: [ -| "(" "warning" "after" bignat ")" -| "(" "abstract" "after" bignat ")" +| ident OPT ( "(" ident OPT ( "," string ) ")" ) ] int_or_id: [ @@ -1052,6 +1024,11 @@ field_mod: [ | "completeness" one_term (* setoid_ring plugin *) ] +numeral_modifier: [ +| "(" "warning" "after" numeral ")" +| "(" "abstract" "after" numeral ")" +] + hints_path: [ | "(" hints_path ")" | hints_path "*" @@ -1069,61 +1046,50 @@ class: [ | smart_qualid ] -ne_in_or_out_modules: [ -| "inside" LIST1 qualid -| "outside" LIST1 qualid -] - -searchabout_query: [ -| OPT "-" string OPT ( "%" ident ) -| OPT "-" one_term -] - -searchabout_queries: [ -| ne_in_or_out_modules -| searchabout_query searchabout_queries -] - -level: [ -| "level" num -| "next" "level" -] - syntax_modifier: [ | "at" "level" num -| "in" "custom" ident -| "in" "custom" ident "at" "level" num +| "in" "custom" ident OPT ( "at" "level" num ) +| LIST1 ident SEP "," "at" level +| ident "at" level OPT binder_interp +| ident explicit_subentry +| ident binder_interp | "left" "associativity" | "right" "associativity" | "no" "associativity" -| "only" "printing" | "only" "parsing" +| "only" "printing" | "format" string OPT string -| ident "," LIST1 ident SEP "," "at" level -| ident "at" level OPT constr_as_binder_kind -| ident constr_as_binder_kind -| ident syntax_extension_type ] -constr_as_binder_kind: [ -| "as" "ident" -| "as" "pattern" -| "as" "strict" "pattern" -] - -syntax_extension_type: [ +explicit_subentry: [ | "ident" | "global" | "bigint" +| "strict" "pattern" OPT ( "at" "level" num ) | "binder" -| "constr" -| "constr" OPT ( "at" level ) OPT constr_as_binder_kind -| "pattern" -| "pattern" "at" "level" num -| "strict" "pattern" -| "strict" "pattern" "at" "level" num | "closed" "binder" -| "custom" ident OPT ( "at" level ) OPT constr_as_binder_kind +| "constr" OPT ( "at" level ) OPT binder_interp +| "custom" ident OPT ( "at" level ) OPT binder_interp +| "pattern" OPT ( "at" "level" num ) +] + +binder_interp: [ +| "as" "ident" +| "as" "pattern" +| "as" "strict" "pattern" +] + +level: [ +| "level" num +| "next" "level" +] + +decl_notations: [ +| "where" decl_notation LIST0 ( "and" decl_notation ) +] + +decl_notation: [ +| string ":=" one_term OPT ( "(" "only" "parsing" ")" ) OPT [ ":" scope_name ] ] simple_tactic: [ @@ -18,29 +18,10 @@ ; ; (_ (flags :standard -rectypes))) -; Rules for coq_dune -(rule - (targets .vfiles.d) - (deps - (source_tree theories) - (source_tree plugins) - (source_tree user-contrib)) - (action - (with-stdout-to .vfiles.d - (bash "%{bin:coqdep} -dyndep both -noglob -boot -R theories Coq -Q user-contrib/Ltac2 Ltac2 -I user-contrib/Ltac2 \ - `find plugins/ -maxdepth 1 -mindepth 1 -type d -printf '-I %p '` \ - `find theories user-contrib -type f -name *.v`")))) - -(alias - (name vodeps) - (deps tools/coq_dune.exe .vfiles.d)) - ; (action (run coq_dune .vfiles.d)))) - (install (section lib) (package coq) - (files - revision)) + (files revision)) (rule (targets revision) diff --git a/dune-project b/dune-project index fa05f5fb41..873d03e8dd 100644 --- a/dune-project +++ b/dune-project @@ -1,11 +1,10 @@ -(lang dune 2.0) +(lang dune 2.5) (name coq) -(using coq 0.1) +(using coq 0.2) (formatting (enabled_for ocaml)) -; We cannot set this to true until as long as the build is not -; properly bootstrapped [that is, we remove the voboot target] +; TODO ; ; (generate_opam_files true) diff --git a/engine/eConstr.ml b/engine/eConstr.ml index 4508633858..ca681e58f8 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -355,7 +355,7 @@ let iter_with_full_binders sigma g f n c = | Lambda (na,t,c) -> f n t; f (g (LocalAssum (na, t)) n) c | LetIn (na,b,t,c) -> f n b; f n t; f (g (LocalDef (na, b, t)) n) c | App (c,l) -> f n c; Array.Fun1.iter f n l - | Evar (_,l) -> Array.Fun1.iter f n l + | Evar (_,l) -> List.iter (fun c -> f n c) l | Case (_,p,c,bl) -> f n p; f n c; Array.Fun1.iter f n bl | Proj (p,c) -> f n c | Fix (_,(lna,tl,bl)) -> @@ -717,7 +717,7 @@ let val_of_named_context e = val_of_named_context (cast_named_context unsafe_eq let named_context_of_val e = cast_named_context (sym unsafe_eq) (named_context_of_val e) let of_existential : Constr.existential -> existential = - let gen : type a b. (a,b) eq -> 'c * b array -> 'c * a array = fun Refl x -> x in + let gen : type a b. (a,b) eq -> 'c * b list -> 'c * a list = fun Refl x -> x in gen unsafe_eq let lookup_rel i e = cast_rel_decl (sym unsafe_eq) (lookup_rel i e) diff --git a/engine/evarutil.ml b/engine/evarutil.ml index fdcdfe11f4..5fcadfcef7 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -200,7 +200,7 @@ let make_pure_subst evi args = match args with | a::rest -> (rest, (NamedDecl.get_id decl, a)::l) | _ -> anomaly (Pp.str "Instance does not match its signature.")) - (evar_filtered_context evi) (Array.rev_to_list args,[])) + (evar_filtered_context evi) (List.rev args,[])) (*------------------------------------* * functional operations on evar sets * @@ -448,7 +448,7 @@ let new_evar_instance ?src ?filter ?abstract_arguments ?candidates ?naming ?type assert (not !Flags.debug || List.distinct (ids_of_named_context (named_context_of_val sign))); let (evd, newevk) = new_pure_evar sign evd ?src ?filter ?abstract_arguments ?candidates ?naming ?typeclass_candidate ?principal typ in - evd, mkEvar (newevk,Array.of_list instance) + evd, mkEvar (newevk, instance) let new_evar_from_context ?src ?filter ?candidates ?naming ?typeclass_candidate ?principal sign evd typ = let instance = List.map (NamedDecl.get_id %> EConstr.mkVar) (named_context_of_val sign) in @@ -506,7 +506,7 @@ let generalize_evar_over_rels sigma (ev,args) = List.fold_left2 (fun (c,inst as x) a d -> if isRel sigma a then (mkNamedProd_or_LetIn d c,a::inst) else x) - (evi.evar_concl,[]) (Array.to_list args) sign + (evi.evar_concl,[]) args sign (************************************) (* Removing a dependency in an evar *) @@ -594,7 +594,7 @@ let rec check_and_clear_in_constr env evdref err ids global c = (* No dependency at all, we can keep this ev's context hyp *) (ri, true::filter) with Depends id -> (Id.Map.add (NamedDecl.get_id h) id ri, false::filter)) - ctxt (Array.to_list l) (Id.Map.empty,[]) in + ctxt l (Id.Map.empty,[]) in (* Check if some rid to clear in the context of ev has dependencies in the type of ev and adjust the source of the dependency *) let _nconcl = @@ -736,7 +736,7 @@ let undefined_evars_of_term evd t = match EConstr.kind evd c with | Evar (n, l) -> let acc = Evar.Set.add n acc in - Array.fold_left evrec acc l + List.fold_left evrec acc l | _ -> EConstr.fold evd evrec acc c in evrec Evar.Set.empty t diff --git a/engine/evarutil.mli b/engine/evarutil.mli index 1dec63aaf0..b5c7ccb283 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -88,7 +88,7 @@ val new_evar_instance : named_context_val -> evar_map -> types -> constr list -> evar_map * constr -val make_pure_subst : evar_info -> 'a array -> (Id.t * 'a) list +val make_pure_subst : evar_info -> 'a list -> (Id.t * 'a) list val safe_evar_value : evar_map -> Constr.existential -> Constr.constr option diff --git a/engine/evd.ml b/engine/evd.ml index 65fe261ff4..5642145f6d 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -233,32 +233,27 @@ exception NotInstantiatedEvar (* Note: let-in contributes to the instance *) let evar_instance_array test_id info args = - let len = Array.length args in - let rec instrec filter ctxt i = match filter, ctxt with - | [], [] -> - if Int.equal i len then [] - else instance_mismatch () - | false :: filter, _ :: ctxt -> - instrec filter ctxt i - | true :: filter, d :: ctxt -> - if i < len then - let c = Array.unsafe_get args i in - if test_id d c then instrec filter ctxt (succ i) - else (NamedDecl.get_id d, c) :: instrec filter ctxt (succ i) - else instance_mismatch () + let rec instrec filter ctxt args = match filter, ctxt, args with + | [], [], [] -> [] + | false :: filter, _ :: ctxt, args -> + instrec filter ctxt args + | true :: filter, d :: ctxt, c :: args -> + if test_id d c then instrec filter ctxt args + else (NamedDecl.get_id d, c) :: instrec filter ctxt args | _ -> instance_mismatch () in match Filter.repr (evar_filter info) with | None -> - let map i d = - if (i < len) then - let c = Array.unsafe_get args i in - if test_id d c then None else Some (NamedDecl.get_id d, c) - else instance_mismatch () + let rec instance ctxt args = match ctxt, args with + | [], [] -> [] + | d :: ctxt, c :: args -> + if test_id d c then instance ctxt args + else (NamedDecl.get_id d, c) :: instance ctxt args + | _ -> instance_mismatch () in - List.map_filter_i map (evar_context info) + instance (evar_context info) args | Some filter -> - instrec filter (evar_context info) 0 + instrec filter (evar_context info) args let make_evar_instance_array info args = evar_instance_array (NamedDecl.get_id %> isVarId) info args @@ -794,7 +789,7 @@ let restrict evk filter ?candidates ?src evd = | _ -> Evar.Set.add evk evd.last_mods in let evar_names = EvNames.reassign_name_defined evk evk' evd.evar_names in let ctxt = Filter.filter_list filter (evar_context evar_info) in - let id_inst = Array.map_of_list (NamedDecl.get_id %> mkVar) ctxt in + let id_inst = List.map (NamedDecl.get_id %> mkVar) ctxt in let body = mkEvar(evk',id_inst) in let (defn_evars, undf_evars) = define_aux evd.defn_evars evd.undf_evars evk body in let evar_flags = declare_restricted_evar evd.evar_flags evk evk' in @@ -1405,7 +1400,7 @@ let evars_of_term evd c = let rec evrec acc c = let c = MiniEConstr.whd_evar evd c in match kind c with - | Evar (n, l) -> Evar.Set.add n (Array.fold_left evrec acc l) + | Evar (n, l) -> Evar.Set.add n (List.fold_left evrec acc l) | _ -> Constr.fold evrec acc c in evrec Evar.Set.empty c @@ -1413,7 +1408,7 @@ let evars_of_term evd c = let evar_nodes_of_term c = let rec evrec acc c = match kind c with - | Evar (n, l) -> Evar.Set.add n (Array.fold_left evrec acc l) + | Evar (n, l) -> Evar.Set.add n (List.fold_left evrec acc l) | _ -> Constr.fold evrec acc c in evrec Evar.Set.empty c diff --git a/engine/evd.mli b/engine/evd.mli index bbdb63a467..c6c4a71b22 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -247,9 +247,9 @@ val existential_opt_value : evar_map -> econstr pexistential -> econstr option val existential_opt_value0 : evar_map -> existential -> constr option val evar_instance_array : (Constr.named_declaration -> 'a -> bool) -> evar_info -> - 'a array -> (Id.t * 'a) list + 'a list -> (Id.t * 'a) list -val instantiate_evar_array : evar_info -> econstr -> econstr array -> econstr +val instantiate_evar_array : evar_info -> econstr -> econstr list -> econstr val evars_reset_evd : ?with_conv_pbs:bool -> ?with_univs:bool -> evar_map -> evar_map -> evar_map diff --git a/engine/namegen.ml b/engine/namegen.ml index 370f35f6ed..c4472050f8 100644 --- a/engine/namegen.ml +++ b/engine/namegen.ml @@ -219,22 +219,22 @@ let get_mangle_names = ~key:["Mangle";"Names"] ~value:false -let mangle_names_prefix = ref (Id.of_string "_0") - -let set_prefix x = mangle_names_prefix := forget_subscript x - -let () = Goptions.( - declare_string_option - { optdepr = false; - optkey = ["Mangle";"Names";"Prefix"]; - optread = (fun () -> Id.to_string !mangle_names_prefix); - optwrite = begin fun x -> - set_prefix - (try Id.of_string x - with CErrors.UserError _ -> CErrors.user_err Pp.(str ("Not a valid identifier: \"" ^ x ^ "\"."))) - end }) - -let mangle_id id = if get_mangle_names () then !mangle_names_prefix else id +let mangle_names_prefix = + Goptions.declare_interpreted_string_option_and_ref + ~depr:false + ~key:["Mangle";"Names";"Prefix"] + ~value:(Id.of_string "_0") + (fun x -> + (try + Id.of_string x + with + | CErrors.UserError _ -> + CErrors.user_err Pp.(str ("Not a valid identifier: \"" ^ x ^ "\".")) + ) |> forget_subscript + ) + (fun x -> Id.to_string x) + +let mangle_id id = if get_mangle_names () then mangle_names_prefix () else id (* Looks for next "good" name by lifting subscript *) diff --git a/engine/termops.ml b/engine/termops.ml index 16f2a87c1e..6d779e6a35 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -636,8 +636,8 @@ let map_constr_with_binders_left_to_right sigma g f l c = if b' == b then c else mkProj (p, b') | Evar (e,al) -> - let al' = Array.map_left (f l) al in - if Array.for_all2 (==) al' al then c + let al' = List.map_left (f l) al in + if List.for_all2 (==) al' al then c else mkEvar (e, al') | Case (ci,p,b,bl) -> (* In v8 concrete syntax, predicate is after the term to match! *) @@ -707,8 +707,8 @@ let map_constr_with_full_binders_gen userview sigma g f l cstr = let c' = f l c in if c' == c then cstr else mkProj (p, c') | Evar (e,al) -> - let al' = Array.map (f l) al in - if Array.for_all2 (==) al al' then cstr else mkEvar (e, al') + let al' = List.map (f l) al in + if List.for_all2 (==) al al' then cstr else mkEvar (e, al') | Case (ci,p,c,bl) when userview -> let p' = map_return_predicate_with_full_binders sigma g f l ci p in let c' = f l c in diff --git a/engine/uState.ml b/engine/uState.ml index d532129dc5..00649ce042 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -39,7 +39,7 @@ type t = uctx_weak_constraints : UPairSet.t } -let initial_sprop_cumulative = UGraph.make_sprop_cumulative UGraph.initial_universes +let initial_sprop_cumulative = UGraph.set_cumulative_sprop true UGraph.initial_universes let empty = { uctx_names = UNameMap.empty, LMap.empty; @@ -57,11 +57,11 @@ let elaboration_sprop_cumul = ~key:["Elaboration";"StrictProp";"Cumulativity"] ~value:true let make ~lbound u = - let u = if elaboration_sprop_cumul () then UGraph.make_sprop_cumulative u else u in - { empty with - uctx_universes = u; - uctx_universes_lbound = lbound; - uctx_initial_universes = u} + let u = UGraph.set_cumulative_sprop (elaboration_sprop_cumul ()) u in + { empty with + uctx_universes = u; + uctx_universes_lbound = lbound; + uctx_initial_universes = u} let is_empty ctx = ContextSet.is_empty ctx.uctx_local && @@ -176,8 +176,11 @@ let instantiate_variable l b v = exception UniversesDiffer -let drop_weak_constraints = ref false - +let drop_weak_constraints = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["Cumulativity";"Weak";"Constraints"] + ~value:false let process_universe_constraints ctx cstrs = let open UnivSubst in @@ -270,7 +273,7 @@ let process_universe_constraints ctx cstrs = | ULub (l, r) -> equalize_variables true (Universe.make l) l (Universe.make r) r local | UWeak (l, r) -> - if not !drop_weak_constraints then weak := UPairSet.add (l,r) !weak; local + if not (drop_weak_constraints ()) then weak := UPairSet.add (l,r) !weak; local | UEq (l, r) -> equalize_universes l r local in let local = @@ -524,6 +527,14 @@ let demote_seff_univs univs uctx = let seff = LSet.union uctx.uctx_seff_univs univs in { uctx with uctx_seff_univs = seff } +let demote_global_univs env uctx = + let env_ugraph = Environ.universes env in + let global_univs = UGraph.domain env_ugraph in + let global_constraints, _ = UGraph.constraints_of_universes env_ugraph in + let promoted_uctx = + ContextSet.(of_set global_univs |> add_constraints global_constraints) in + { uctx with uctx_local = ContextSet.diff uctx.uctx_local promoted_uctx } + let merge_seff uctx ctx' = let levels = ContextSet.levels ctx' in let declare g = @@ -544,10 +555,11 @@ let emit_side_effects eff u = merge_seff u uctx let update_sigma_env uctx env = - let univs = UGraph.make_sprop_cumulative (Environ.universes env) in + let univs = UGraph.set_cumulative_sprop (elaboration_sprop_cumul()) (Environ.universes env) in let eunivs = - { uctx with uctx_initial_universes = univs; - uctx_universes = univs } + { uctx with + uctx_initial_universes = univs; + uctx_universes = univs } in merge_seff eunivs eunivs.uctx_local diff --git a/engine/uState.mli b/engine/uState.mli index 3959373ead..6707826aae 100644 --- a/engine/uState.mli +++ b/engine/uState.mli @@ -69,8 +69,6 @@ val univ_entry : poly:bool -> t -> Entries.universes_entry (** {5 Constraints handling} *) -val drop_weak_constraints : bool ref - val add_constraints : t -> Univ.Constraint.t -> t (** @raise UniversesDiffer when universes differ @@ -112,6 +110,11 @@ val merge : ?loc:Loc.t -> sideff:bool -> rigid -> t -> Univ.ContextSet.t -> t val merge_subst : t -> UnivSubst.universe_opt_subst -> t val emit_side_effects : Safe_typing.private_constants -> t -> t +val demote_global_univs : Environ.env -> t -> t +(** Removes from the uctx_local part of the UState the universes and constraints + that are present in the universe graph in the input env (supposedly the + global ones *) + val demote_seff_univs : Univ.LSet.t -> t -> t (** Mark the universes as not local any more, because they have been globally declared by some side effect. You should be using diff --git a/engine/univSubst.ml b/engine/univSubst.ml index 6000650ad9..a691239ee2 100644 --- a/engine/univSubst.ml +++ b/engine/univSubst.ml @@ -131,7 +131,7 @@ let nf_evars_and_universes_opt_subst f subst = let rec aux c = match kind c with | Evar (evk, args) -> - let args = Array.map aux args in + let args = List.map aux args in (match try f (evk, args) with Not_found -> None with | None -> mkEvar (evk, args) | Some c -> aux c) diff --git a/ide/coqide.ml b/ide/coqide.ml index fddc294f68..ab2a17798e 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -787,25 +787,28 @@ let coqtop_arguments sn = let dialog = GWindow.dialog ~title:"Coqtop arguments" () in let coqtop = sn.coqtop in (* Text entry *) - let args = Coq.get_arguments coqtop in - let text = String.concat " " args in + let text = Ideutils.encode_string_list (Coq.get_arguments coqtop) in let entry = GEdit.entry ~text ~packing:dialog#vbox#add () in (* Buttons *) let box = dialog#action_area in let ok = GButton.button ~stock:`OK ~packing:box#add () in + let fail s = + let msg = Printf.sprintf "Invalid arguments: %s" s in + let () = sn.messages#default_route#clear in + sn.messages#default_route#push Feedback.Error (Pp.str msg) in let ok_cb () = - let nargs = String.split_on_char ' ' entry#text in - if nargs <> args then + let ntext = entry#text in + if ntext <> text then + match try Util.Inr (Ideutils.decode_string_list ntext) with Failure s -> Util.Inl s with + | Util.Inl s -> fail s + | Util.Inr nargs -> let failed = Coq.filter_coq_opts nargs in match failed with | [] -> let () = Coq.set_arguments coqtop nargs in dialog#destroy () | args -> - let args = String.concat " " args in - let msg = Printf.sprintf "Invalid arguments: %s" args in - let () = sn.messages#default_route#clear in - sn.messages#default_route#push Feedback.Error (Pp.str msg) + fail (String.concat " " args) else dialog#destroy () in let _ = entry#connect#activate ~callback:ok_cb in @@ -1290,7 +1293,10 @@ let build_ui () = (* Initializing hooks *) let refresh_style style = let style = style_manager#style_scheme style in - let iter_session v = v.script#source_buffer#set_style_scheme style in + let iter_session v = + v.script#source_buffer#set_style_scheme style; + v.proof#source_buffer#set_style_scheme style; + v.messages#default_route#source_buffer#set_style_scheme style in List.iter iter_session notebook#pages in let refresh_language lang = diff --git a/ide/coqide_WIN32.ml.in b/ide/coqide_WIN32.ml.in index 2d3964f210..be8aab9e49 100644 --- a/ide/coqide_WIN32.ml.in +++ b/ide/coqide_WIN32.ml.in @@ -44,6 +44,7 @@ let () = Coq.gio_channel_of_descr_socket := Glib.Io.channel_of_descr_socket; set_win32_path (); Coq.interrupter := win32_interrupt; - reroute_stdout_stderr () + reroute_stdout_stderr (); + try ignore (Unix.getenv "GTK_CSD") with Not_found -> Unix.putenv "GTK_CSD" "0" let init () = () diff --git a/ide/idetop.ml b/ide/idetop.ml index 0ef7fca41f..fa458e7c6e 100644 --- a/ide/idetop.ml +++ b/ide/idetop.ml @@ -232,32 +232,32 @@ let goals () = let doc = get_doc () in set_doc @@ Stm.finish ~doc; try - let newp = Vernacstate.Proof_global.give_me_the_proof () in + let newp = Vernacstate.Declare.give_me_the_proof () in if Proof_diffs.show_diffs () then begin let oldp = Stm.get_prev_proof ~doc (Stm.get_current_state ~doc) in let diff_goal_map = Proof_diffs.make_goal_map oldp newp in Some (export_pre_goals Proof.(data newp) (process_goal_diffs diff_goal_map oldp)) end else Some (export_pre_goals Proof.(data newp) process_goal) - with Vernacstate.Proof_global.NoCurrentProof -> None + with Vernacstate.Declare.NoCurrentProof -> None [@@ocaml.warning "-3"];; let evars () = try let doc = get_doc () in set_doc @@ Stm.finish ~doc; - let pfts = Vernacstate.Proof_global.give_me_the_proof () in + let pfts = Vernacstate.Declare.give_me_the_proof () in let Proof.{ sigma } = Proof.data pfts in let exl = Evar.Map.bindings (Evd.undefined_map sigma) in let map_evar ev = { Interface.evar_info = string_of_ppcmds (pr_evar sigma ev); } in let el = List.map map_evar exl in Some el - with Vernacstate.Proof_global.NoCurrentProof -> None + with Vernacstate.Declare.NoCurrentProof -> None [@@ocaml.warning "-3"] let hints () = try - let pfts = Vernacstate.Proof_global.give_me_the_proof () in + let pfts = Vernacstate.Declare.give_me_the_proof () in let Proof.{ goals; sigma } = Proof.data pfts in match goals with | [] -> None @@ -266,7 +266,7 @@ let hints () = let get_hint_hyp env d accu = hyp_next_tac sigma env d :: accu in let hint_hyps = List.rev (Environ.fold_named_context get_hint_hyp env ~init: []) in Some (hint_hyps, concl_next_tac) - with Vernacstate.Proof_global.NoCurrentProof -> None + with Vernacstate.Declare.NoCurrentProof -> None [@@ocaml.warning "-3"] (** Other API calls *) @@ -287,11 +287,11 @@ let status force = List.rev_map Names.Id.to_string l in let proof = - try Some (Names.Id.to_string (Vernacstate.Proof_global.get_current_proof_name ())) - with Vernacstate.Proof_global.NoCurrentProof -> None + try Some (Names.Id.to_string (Vernacstate.Declare.get_current_proof_name ())) + with Vernacstate.Declare.NoCurrentProof -> None in let allproofs = - let l = Vernacstate.Proof_global.get_all_proof_names () in + let l = Vernacstate.Declare.get_all_proof_names () in List.map Names.Id.to_string l in { @@ -340,7 +340,7 @@ let import_search_constraint = function | Interface.Include_Blacklist -> Search.Include_Blacklist let search flags = - let pstate = Vernacstate.Proof_global.get_pstate () in + let pstate = Vernacstate.Declare.get_pstate () in List.map export_coq_object (Search.interface_search ?pstate ( List.map (fun (c, b) -> (import_search_constraint c, b)) flags) ) diff --git a/ide/ideutils.ml b/ide/ideutils.ml index eeb818ce5f..482cecc1f8 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -536,3 +536,72 @@ let rec is_valid (s : Pp.t) = match Pp.repr s with | Pp.Ppcmd_comment s -> List.for_all Glib.Utf8.validate s let validate s = if is_valid s then s else Pp.str "This error massage can't be printed." + +(** encoding list of strings as a string in a shell-like compatible way: + string with spaces and no ' -> '...' + string with spaces and ' -> split string into substrings separated with \' + ' -> \' + \ -> \\ + *) + +let decode_string_list s = + let l = String.length s in + let fail_backslash () = + failwith "Backslash is used to quote single quotes in quoted strings; it should otherwise be doubled" in + let rec find_word quoted b i = + if i = l then + if quoted then failwith "Unmatched single quote" + else i + else + let c = s.[i] in + if c = ' ' && not quoted then i+1 + else if c = '\'' then find_word (not quoted) b (i+1) + else if c = '\\' && not quoted then + if i = l-1 then fail_backslash () + else + let c = s.[i+1] in + if c = '\'' || c = '\\' then + (Buffer.add_char b c; find_word quoted b (i+2)) + else fail_backslash () + else + (Buffer.add_char b c; + find_word quoted b (i+1)) in + let rec collect_words i = + if i = l then [] else + let b = Buffer.create l in + let i = find_word false b i in + Buffer.contents b :: collect_words i in + collect_words 0 + +let needs_quote s i = + (* Tells if there is a space and if a space, before the next single quote *) + match CString.index_from_opt s i ' ', CString.index_from_opt s i '\'' with + | Some _, None -> true + | Some i, Some j -> i < j + | _ -> false + +let encode_string s = + (* Could be optimized so that "a b'c" is "'a b'\'c" rather than "'a b'\''c'" *) + let l = String.length s in + let b = Buffer.create (l + 10) in + let close quoted = if quoted then Buffer.add_char b '\'' in + let rec aux quoted i = + if i = l then close quoted + else + let c = s.[i] in + if c = '\'' then + (close quoted; + Buffer.add_string b "\\'"; + start (i+1)) + else if c = '\\' && not quoted then + (Buffer.add_string b "\\\\"; aux quoted (i+1)) + else + (Buffer.add_char b c; aux quoted (i+1)) + and start i = + let q = needs_quote s i in + if q then Buffer.add_char b '\''; + aux q i in + start 0; + Buffer.contents b + +let encode_string_list l = String.concat " " (List.map encode_string l) diff --git a/ide/ideutils.mli b/ide/ideutils.mli index b080f5b8ed..9a17eb1402 100644 --- a/ide/ideutils.mli +++ b/ide/ideutils.mli @@ -102,3 +102,19 @@ val run_command : (* Checks if an error message is printable, it not replaces it with * a printable error *) val validate : Pp.t -> Pp.t + +(** [encode_string_list l] encodes a list of strings into a single + string using a "shell"-like encoding: it quotes strings + containing space by surrounding them with single quotes, and, + outside quoted strings, quotes both single quote and backslash + by prefixing them with backslash; the encoding tries to be + minimalistic. *) + +val encode_string_list : string list -> string + +(** [decode_string_list l] decodes the encoding of a string list as + a string; it fails with a Failure if a single quote is unmatched + or if a backslash in unquoted part is not followed by a single + quote or another backslash. *) + +val decode_string_list : string -> string list diff --git a/ide/session.ml b/ide/session.ml index b16af9c317..09391b7f50 100644 --- a/ide/session.ml +++ b/ide/session.ml @@ -151,7 +151,7 @@ let set_buffer_handlers else if it#has_tag Tags.Script.processed then Some old else if it#has_tag Tags.Script.error_bg then aux it it#backward_char else None in - aux it it in + aux it it#copy in let insert_cb it s = if String.length s = 0 then () else begin Minilib.log ("insert_cb " ^ string_of_int it#offset); let text_mark = add_mark it in diff --git a/ide/wg_MessageView.ml b/ide/wg_MessageView.ml index b99e5f8069..6e22172d05 100644 --- a/ide/wg_MessageView.ml +++ b/ide/wg_MessageView.ml @@ -28,6 +28,7 @@ end class type message_view = object inherit GObj.widget + method source_buffer : GSourceView3.source_buffer method connect : message_view_signals method clear : unit method add : Pp.t -> unit @@ -44,7 +45,8 @@ class type message_view = let message_view () : message_view = let buffer = GSourceView3.source_buffer ~highlight_matching_brackets:true - ~tag_table:Tags.Message.table () + ~tag_table:Tags.Message.table + ?style_scheme:(style_manager#style_scheme source_style#get) () in let mark = buffer#create_mark ~left_gravity:false buffer#start_iter in let box = GPack.vbox () in @@ -88,6 +90,8 @@ let message_view () : message_view = val push = new GUtil.signal () + method source_buffer = buffer + method connect = new message_view_signals_impl box#as_widget push diff --git a/ide/wg_MessageView.mli b/ide/wg_MessageView.mli index 21c11b2754..054dd0e571 100644 --- a/ide/wg_MessageView.mli +++ b/ide/wg_MessageView.mli @@ -18,6 +18,7 @@ end class type message_view = object inherit GObj.widget + method source_buffer : GSourceView3.source_buffer method connect : message_view_signals method clear : unit method add : Pp.t -> unit diff --git a/ide/wg_ProofView.ml b/ide/wg_ProofView.ml index 3e03ef11f7..1de63953af 100644 --- a/ide/wg_ProofView.ml +++ b/ide/wg_ProofView.ml @@ -15,6 +15,7 @@ open Ideutils class type proof_view = object inherit GObj.widget + method source_buffer : GSourceView3.source_buffer method buffer : GText.buffer method refresh : force:bool -> unit method clear : unit -> unit @@ -195,7 +196,8 @@ let display mode (view : #GText.view_skel) goals hints evars = let proof_view () = let buffer = GSourceView3.source_buffer ~highlight_matching_brackets:true - ~tag_table:Tags.Proof.table () + ~tag_table:Tags.Proof.table + ?style_scheme:(style_manager#style_scheme source_style#get) () in let text_buffer = new GText.buffer buffer#as_buffer in let view = GSourceView3.source_view @@ -217,6 +219,8 @@ let proof_view () = val mutable evars = None val mutable last_width = -1 + method source_buffer = buffer + method buffer = text_buffer method clear () = buffer#set_text "" diff --git a/ide/wg_ProofView.mli b/ide/wg_ProofView.mli index db6fb9e9cd..8217f72066 100644 --- a/ide/wg_ProofView.mli +++ b/ide/wg_ProofView.mli @@ -11,6 +11,7 @@ class type proof_view = object inherit GObj.widget + method source_buffer : GSourceView3.source_buffer method buffer : GText.buffer method refresh : force:bool -> unit method clear : unit -> unit diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index d4369e9bd1..d6097304ec 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -121,9 +121,10 @@ let rec constr_expr_eq e1 e2 = constr_expr_eq a1 a2 && Option.equal constr_expr_eq t1 t2 && constr_expr_eq b1 b2 - | CAppExpl((proj1,r1,_),al1), CAppExpl((proj2,r2,_),al2) -> + | CAppExpl((proj1,r1,u1),al1), CAppExpl((proj2,r2,u2),al2) -> Option.equal Int.equal proj1 proj2 && qualid_eq r1 r2 && + eq_universes u1 u2 && List.equal constr_expr_eq al1 al2 | CApp((proj1,e1),al1), CApp((proj2,e2),al2) -> Option.equal Int.equal proj1 proj2 && @@ -158,8 +159,8 @@ let rec constr_expr_eq e1 e2 = Id.equal id1 id2 && List.equal instance_eq c1 c2 | CSort s1, CSort s2 -> Glob_ops.glob_sort_eq s1 s2 - | CCast(t1,c1), CCast(t2,c2) -> - constr_expr_eq t1 t2 && cast_expr_eq c1 c2 + | CCast(t1,c1), CCast(t2,c2) -> + constr_expr_eq t1 t2 && cast_expr_eq c1 c2 | CNotation(inscope1, n1, s1), CNotation(inscope2, n2, s2) -> Option.equal notation_with_optional_scope_eq inscope1 inscope2 && notation_eq n1 n2 && diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 7a14ca3e48..a37bac3275 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -282,9 +282,9 @@ let insert_pat_alias ?loc p = function | Anonymous -> p | Name _ as na -> CAst.make ?loc @@ CPatAlias (p,(CAst.make ?loc na)) -let rec insert_coercion ?loc l c = match l with +let rec insert_entry_coercion ?loc l c = match l with | [] -> c - | (inscope,ntn)::l -> CAst.make ?loc @@ CNotation (Some inscope,ntn,([insert_coercion ?loc l c],[],[],[])) + | (inscope,ntn)::l -> CAst.make ?loc @@ CNotation (Some inscope,ntn,([insert_entry_coercion ?loc l c],[],[],[])) let rec insert_pat_coercion ?loc l c = match l with | [] -> c @@ -453,7 +453,8 @@ let rec extern_cases_pattern_in_scope (custom,scopes as allscopes) vars pat = with No_match -> let loc = pat.CAst.loc in match DAst.get pat with - | PatVar (Name id) when entry_has_ident custom -> CAst.make ?loc (CPatAtom (Some (qualid_of_ident ?loc id))) + | PatVar (Name id) when entry_has_global custom || entry_has_ident custom -> + CAst.make ?loc (CPatAtom (Some (qualid_of_ident ?loc id))) | pat -> match availability_of_entry_coercion custom InConstrEntrySomeLevel with | None -> raise No_match @@ -615,6 +616,10 @@ let is_projection nargs r = let is_hole = function CHole _ | CEvar _ -> true | _ -> false +let isCRef_no_univ = function + | CRef (_,None) -> true + | _ -> false + let is_significant_implicit a = not (is_hole (a.CAst.v)) @@ -849,7 +854,7 @@ let extern_possible_prim_token (custom,scopes) r = | Some coercion -> match availability_of_prim_token n sc scopes with | None -> raise No_match - | Some key -> insert_coercion coercion (insert_delimiters (CAst.make ?loc:(loc_of_glob_constr r) @@ CPrim n) key) + | Some key -> insert_entry_coercion coercion (insert_delimiters (CAst.make ?loc:(loc_of_glob_constr r) @@ CPrim n) key) let filter_enough_applied nargs l = match nargs with @@ -931,7 +936,8 @@ let rec extern inctx ?impargs scopes vars r = match DAst.get r with | GRef (ref,us) when entry_has_global (fst scopes) -> CAst.make ?loc (extern_ref vars ref us) - | GVar id when entry_has_ident (fst scopes) -> CAst.make ?loc (extern_var ?loc id) + | GVar id when entry_has_global (fst scopes) || entry_has_ident (fst scopes) -> + CAst.make ?loc (extern_var ?loc id) | c -> @@ -1081,7 +1087,7 @@ let rec extern inctx ?impargs scopes vars r = | GFloat f -> extern_float f (snd scopes) - in insert_coercion coercion (CAst.make ?loc c) + in insert_entry_coercion coercion (CAst.make ?loc c) and extern_typ ?impargs (subentry,(_,scopes)) = extern true ?impargs (subentry,(Notation.current_type_scope_name (),scopes)) @@ -1279,14 +1285,11 @@ and extern_notation (custom,scopes as allscopes) vars t rules = pi3 (extern_local_binder (subentry,(scopt,scl@scopes')) vars bl)) binderlists in let c = make_notation loc specific_ntn (l,ll,bl,bll) in - let c = insert_coercion coercion (insert_delimiters c key) in + let c = insert_entry_coercion coercion (insert_delimiters c key) in let args = fill_arg_scopes args argsscopes allscopes in let args = extern_args (extern true) vars args in CAst.make ?loc @@ extern_applied_notation nallargs argsimpls c args) | SynDefRule kn -> - match availability_of_entry_coercion custom InConstrEntrySomeLevel with - | None -> raise No_match - | Some coercion -> let l = List.map (fun (c,(subentry,(scopt,scl))) -> extern true (subentry,(scopt,scl@snd scopes)) vars c) @@ -1296,7 +1299,10 @@ and extern_notation (custom,scopes as allscopes) vars t rules = let args = fill_arg_scopes args argsscopes allscopes in let args = extern_args (extern true) vars args in let c = CAst.make ?loc @@ extern_applied_syntactic_definition nallargs argsimpls (a,cf) l args in - insert_coercion coercion c + if isCRef_no_univ c.CAst.v && entry_has_global custom then c + else match availability_of_entry_coercion custom InConstrEntrySomeLevel with + | None -> raise No_match + | Some coercion -> insert_entry_coercion coercion c with No_match -> extern_notation allscopes vars t rules diff --git a/interp/constrintern.ml b/interp/constrintern.ml index a071ba7ec9..f82783f47d 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -48,22 +48,27 @@ open NumTok types and recursive definitions and of projection names in records *) type var_internalization_type = - | Inductive of Id.t list (* list of params *) * bool (* true = check for possible capture *) + | Inductive | Recursive | Method | Variable +type var_unique_id = string + +let var_uid = + let count = ref 0 in + fun id -> incr count; Id.to_string id ^ ":" ^ string_of_int !count + type var_internalization_data = (* type of the "free" variable, for coqdoc, e.g. while typing the constructor of JMeq, "JMeq" behaves as a variable of type Inductive *) var_internalization_type * - (* impargs to automatically add to the variable, e.g. for "JMeq A a B b" - in implicit mode, this is [A;B] and this adds (A:=A) and (B:=B) *) - Id.t list * (* signature of impargs of the variable *) Impargs.implicit_status list * (* subscopes of the args of the variable *) - scope_name option list + scope_name option list * + (* unique ID for coqdoc links *) + var_unique_id type internalization_env = (var_internalization_data) Id.Map.t @@ -180,26 +185,18 @@ let parsing_explicit = ref false let empty_internalization_env = Id.Map.empty -let compute_explicitable_implicit imps = function - | Inductive (params,_) -> - (* In inductive types, the parameters are fixed implicit arguments *) - let sub_impl,_ = List.chop (List.length params) imps in - let sub_impl' = List.filter is_status_implicit sub_impl in - List.map name_of_implicit sub_impl' - | Recursive | Method | Variable -> - (* Unable to know in advance what the implicit arguments will be *) - [] - -let compute_internalization_data env sigma ty typ impl = +let compute_internalization_data env sigma id ty typ impl = let impl = compute_implicits_with_manual env sigma typ (is_implicit_args()) impl in - let expls_impl = compute_explicitable_implicit impl ty in - (ty, expls_impl, impl, compute_arguments_scope sigma typ) + (ty, impl, compute_arguments_scope sigma typ, var_uid id) let compute_internalization_env env sigma ?(impls=empty_internalization_env) ty = List.fold_left3 - (fun map id typ impl -> Id.Map.add id (compute_internalization_data env sigma ty typ impl) map) + (fun map id typ impl -> Id.Map.add id (compute_internalization_data env sigma id ty typ impl) map) impls +let extend_internalization_data (r, impls, scopes, uid) impl scope = + (r, impls@[impl], scopes@[scope], uid) + (**********************************************************************) (* Contracting "{ _ }" in notations *) @@ -355,7 +352,7 @@ let impls_binder_list = let impls_type_list n ?(args = []) = let rec aux acc n c = match DAst.get c with | GProd (na,bk,_,c) -> aux (build_impls n bk na acc) (n+1) c - | _ -> (Variable,[],List.rev acc,[]) + | _ -> List.rev acc in aux args n let impls_term_list n ?(args = []) = @@ -365,7 +362,7 @@ let impls_term_list n ?(args = []) = let nb = match fix_kind with |GFix (_, n) -> n | GCoFix n -> n in let n,acc' = List.fold_left (fun (n,acc) (na, bk, _, _) -> (n+1,build_impls n bk na acc)) (n,acc) args.(nb) in aux acc' n bds.(nb) - |_ -> (Variable,[],List.rev acc,[]) + |_ -> List.rev acc in aux args n (* Check if in binder "(x1 x2 .. xn : t)", none of x1 .. xn-1 occurs in t *) @@ -429,20 +426,6 @@ let locate_if_hole ?loc na c = match DAst.get c with with Not_found -> DAst.make ?loc @@ GHole (Evar_kinds.BinderType na, naming, arg)) | _ -> c -let reset_hidden_inductive_implicit_test env = - { env with impls = Id.Map.map (function - | (Inductive (params,_),b,c,d) -> (Inductive (params,false),b,c,d) - | x -> x) env.impls } - -let check_hidden_implicit_parameters ?loc id impls = - if Id.Map.exists (fun _ -> function - | (Inductive (indparams,check),_,_,_) when check -> Id.List.mem id indparams - | _ -> false) impls - then - user_err ?loc (Id.print id ++ strbrk " is already used as name of " ++ - strbrk "a parameter of the inductive type; bound variables in " ++ - strbrk "the type of a constructor shall use a different name.") - let pure_push_name_env (id,implargs) env = {env with ids = Id.Set.add id env.ids; @@ -456,12 +439,12 @@ let push_name_env ntnvars implargs env = | { loc; v = Anonymous } -> env | { loc; v = Name id } -> - check_hidden_implicit_parameters ?loc id env.impls ; if Id.Map.is_empty ntnvars && Id.equal id ldots_var then error_ldots_var ?loc; set_var_scope ?loc id false (env.tmp_scope,env.scopes) ntnvars; - Dumpglob.dump_binding ?loc id; - pure_push_name_env (id,implargs) env + let uid = var_uid id in + Dumpglob.dump_binding ?loc uid; + pure_push_name_env (id,(Variable,implargs,[],uid)) env let remember_binders_impargs env bl = List.map_filter (fun (na,_,_,_) -> @@ -492,7 +475,7 @@ let intern_generalized_binder intern_type ntnvars let ty' = intern_type {env with ids = ids; unb = true} ty in let fvs = Implicit_quantifiers.generalizable_vars_of_glob_constr ~bound:ids ~allowed:ids' ty' in let env' = List.fold_left - (fun env {loc;v=x} -> push_name_env ntnvars (Variable,[],[],[])(*?*) env (make ?loc @@ Name x)) + (fun env {loc;v=x} -> push_name_env ntnvars [](*?*) env (make ?loc @@ Name x)) env fvs in let b' = check_implicit_meaningful ?loc b' env in let bl = List.map @@ -559,7 +542,7 @@ let intern_cases_pattern_as_binder ?loc ntnvars env p = user_err ?loc (str "Unsupported nested \"as\" clause."); il,disjpat in - let env = List.fold_right (fun {loc;v=id} env -> push_name_env ntnvars (Variable,[],[],[]) env (make ?loc @@ Name id)) il env in + let env = List.fold_right (fun {loc;v=id} env -> push_name_env ntnvars [] env (make ?loc @@ Name id)) il env in let na = alias_of_pat (List.hd disjpat) in let ienv = Name.fold_right Id.Set.remove na env.ids in let id = Namegen.next_name_away_with_default "pat" na ienv in @@ -615,7 +598,7 @@ let intern_generalization intern env ntnvars loc bk ak c = GLambda (Name id, bk, DAst.make ?loc:loc' @@ GHole (Evar_kinds.BinderType (Name id), IntroAnonymous, None), acc)) in List.fold_right (fun ({loc;v=id} as lid) (env, acc) -> - let env' = push_name_env ntnvars (Variable,[],[],[]) env CAst.(make @@ Name id) in + let env' = push_name_env ntnvars [] env CAst.(make @@ Name id) in (env', abs lid acc)) fvs (env,c) in c' @@ -706,7 +689,7 @@ let traverse_binder intern_pat ntnvars (terms,_,binders,_ as subst) avoid (renam if onlyident then (* Do not try to interpret a variable as a constructor *) let na = out_patvar pat in - let env = push_name_env ntnvars (Variable,[],[],[]) env (make ?loc:pat.loc na) in + let env = push_name_env ntnvars [] env (make ?loc:pat.loc na) in (renaming,env), None, na else (* Interpret as a pattern *) @@ -909,9 +892,6 @@ let instantiate_notation_constr loc intern intern_pat ntnvars subst infos c = try let pat,(onlyident,scopes) = Id.Map.find id binders in let env = set_env_scopes env scopes in - (* We deactivate impls to avoid the check on hidden parameters *) - (* 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_patvar pat) else @@ -1015,13 +995,13 @@ let intern_notation intern env ntnvars loc ntn fullargs = (* Discriminating between bound variables and global references *) let string_of_ty = function - | Inductive _ -> "ind" + | Inductive -> "ind" | Recursive -> "def" | Method -> "meth" | Variable -> "var" let gvar (loc, id) us = match us with -| None -> DAst.make ?loc @@ GVar id +| None | Some [] -> DAst.make ?loc @@ GVar id | Some _ -> user_err ?loc (str "Variable " ++ Id.print id ++ str " cannot have a universe instance") @@ -1031,27 +1011,25 @@ let intern_var env (ltacvars,ntnvars) namedctx loc id us = if Id.Map.mem id ntnvars then begin if not (Id.Map.mem id env.impls) then set_var_scope ?loc id true (env.tmp_scope,env.scopes) ntnvars; - gvar (loc,id) us, [], [], [] + gvar (loc,id) us, [], [] end else (* Is [id] registered with implicit arguments *) try - let ty,expl_impls,impls,argsc = Id.Map.find id env.impls in - let expl_impls = List.map - (fun id -> CAst.make ?loc @@ CRef (qualid_of_ident ?loc id,None), Some (make ?loc @@ ExplByName id)) expl_impls in + let ty,impls,argsc,uid = Id.Map.find id env.impls in let tys = string_of_ty ty in - Dumpglob.dump_reference ?loc "<>" (Id.to_string id) tys; - gvar (loc,id) us, make_implicits_list impls, argsc, expl_impls + Dumpglob.dump_reference ?loc "<>" uid tys; + gvar (loc,id) us, make_implicits_list impls, argsc with Not_found -> (* Is [id] bound in current term or is an ltac var bound to constr *) if Id.Set.mem id env.ids || Id.Set.mem id ltacvars.ltac_vars then - gvar (loc,id) us, [], [], [] + gvar (loc,id) us, [], [] else if Id.equal id ldots_var (* Is [id] the special variable for recursive notations? *) then if Id.Map.is_empty ntnvars then error_ldots_var ?loc - else gvar (loc,id) us, [], [], [] + else gvar (loc,id) us, [], [] else if Id.Set.mem id ltacvars.ltac_bound then (* Is [id] bound to a free name in ltac (this is an ltac error message) *) user_err ?loc ~hdr:"intern_var" @@ -1067,17 +1045,17 @@ let intern_var env (ltacvars,ntnvars) namedctx loc id us = let scopes = find_arguments_scope ref in Dumpglob.dump_secvar ?loc id; (* this raises Not_found when not a section variable *) (* Someday we should stop relying on Dumglob raising exceptions *) - DAst.make ?loc @@ GRef (ref, us), impls, scopes, [] + DAst.make ?loc @@ GRef (ref, us), impls, scopes with e when CErrors.noncritical e -> (* [id] a goal variable *) - gvar (loc,id) us, [], [], [] + gvar (loc,id) us, [], [] let find_appl_head_data c = match DAst.get c with | GRef (ref,_) -> let impls = implicits_of_global ref in let scopes = find_arguments_scope ref in - c, impls, scopes, [] + c, impls, scopes | GApp (r, l) -> begin match DAst.get r with | GRef (ref,_) -> @@ -1085,10 +1063,10 @@ let find_appl_head_data c = let impls = implicits_of_global ref in let scopes = find_arguments_scope ref in c, (if n = 0 then [] else List.map (drop_first_implicits n) impls), - List.skipn_at_least n scopes,[] - | _ -> c,[],[],[] + List.skipn_at_least n scopes + | _ -> c,[],[] end - | _ -> c,[],[],[] + | _ -> c,[],[] let error_not_enough_arguments ?loc = user_err ?loc (str "Abbreviation is not applied enough.") @@ -1196,13 +1174,12 @@ let intern_applied_reference ~isproj intern env namedctx (_, ntnvars as lvar) us try let r, realref, args2 = intern_qualid ~no_secvar:true qid intern env ntnvars us args in check_applied_projection isproj realref qid; - let x, imp, scopes, l = find_appl_head_data r in - (x,imp,scopes,l), args2 + find_appl_head_data r, args2 with Not_found -> (* Extra allowance for non globalizing functions *) if !interning_grammar || env.unb then (* check_applied_projection ?? *) - (gvar (loc,qualid_basename qid) us, [], [], []), args + (gvar (loc,qualid_basename qid) us, [], []), args else Nametab.error_global_not_found qid else let r,realref,args2 = @@ -1210,11 +1187,10 @@ let intern_applied_reference ~isproj intern env namedctx (_, ntnvars as lvar) us with Not_found -> Nametab.error_global_not_found qid in check_applied_projection isproj realref qid; - let x, imp, scopes, l = find_appl_head_data r in - (x,imp,scopes,l), args2 + find_appl_head_data r, args2 let interp_reference vars r = - let (r,_,_,_),_ = + let (r,_,_),_ = intern_applied_reference ~isproj:None (fun _ -> error_not_enough_arguments ?loc:None) {ids = Id.Set.empty; unb = false ; tmp_scope = None; scopes = []; impls = empty_internalization_env; @@ -1452,62 +1428,28 @@ let inductive_of_record loc record = let sort_fields ~complete loc fields completer = match fields with | [] -> None - | (first_field_ref, first_field_value):: other_fields -> + | (first_field_ref, _):: _ -> let (first_field_glob_ref, record) = try let gr = locate_reference first_field_ref in + Dumpglob.add_glob ?loc:first_field_ref.CAst.loc gr; (gr, Recordops.find_projection gr) with Not_found -> - raise (InternalizationError(loc, NotAProjection first_field_ref)) + raise (InternalizationError(first_field_ref.CAst.loc, NotAProjection first_field_ref)) in (* the number of parameters *) let nparams = record.Recordops.s_EXPECTEDPARAM in (* the reference constructor of the record *) - let base_constructor = - let global_record_id = GlobRef.ConstructRef record.Recordops.s_CONST in - try Nametab.shortest_qualid_of_global ?loc Id.Set.empty global_record_id - with Not_found -> - anomaly (str "Environment corruption for records.") in + let base_constructor = GlobRef.ConstructRef record.Recordops.s_CONST in let () = check_duplicate ?loc fields in - let (end_index, (* one past the last field index *) - first_field_index, (* index of the first field of the record *) - proj_list) (* list of projections *) - = - (* eliminate the first field from the projections, - but keep its index *) - let rec build_proj_list projs proj_kinds idx ~acc_first_idx acc = - match projs with - | [] -> (idx, acc_first_idx, acc) - | (Some field_glob_id) :: projs -> - let field_glob_ref = GlobRef.ConstRef field_glob_id in - let first_field = GlobRef.equal field_glob_ref first_field_glob_ref in - begin match proj_kinds with - | [] -> anomaly (Pp.str "Number of projections mismatch.") - | { Recordops.pk_true_proj = regular } :: proj_kinds -> - (* "regular" is false when the field is defined - by a let-in in the record declaration - (its value is fixed from other fields). *) - if first_field && not regular && complete then - user_err ?loc (str "No local fields allowed in a record construction.") - else if first_field then - build_proj_list projs proj_kinds (idx+1) ~acc_first_idx:idx acc - else if not regular && complete then - (* skip non-regular fields *) - build_proj_list projs proj_kinds idx ~acc_first_idx acc - else - build_proj_list projs proj_kinds (idx+1) ~acc_first_idx - ((idx, field_glob_id) :: acc) - end - | None :: projs -> - if complete then - (* we don't want anonymous fields *) - user_err ?loc (str "This record contains anonymous fields.") - else - (* anonymous arguments don't appear in proj_kinds *) - build_proj_list projs proj_kinds (idx+1) ~acc_first_idx acc - in - build_proj_list record.Recordops.s_PROJ record.Recordops.s_PROJKIND 1 ~acc_first_idx:0 [] - in + let build_proj idx proj kind = + if proj = None && complete then + (* we don't want anonymous fields *) + user_err ?loc (str "This record contains anonymous fields.") + else + (idx, proj, kind.Recordops.pk_true_proj) in + let proj_list = + List.map2_i build_proj 1 record.Recordops.s_PROJ record.Recordops.s_PROJKIND in (* now we want to have all fields assignments indexed by their place in the constructor *) let rec index_fields fields remaining_projs acc = @@ -1515,34 +1457,43 @@ let sort_fields ~complete loc fields completer = | (field_ref, field_value) :: fields -> let field_glob_ref = try locate_reference field_ref with Not_found -> - user_err ?loc ~hdr:"intern" + user_err ?loc:field_ref.CAst.loc ~hdr:"intern" (str "The field \"" ++ pr_qualid field_ref ++ str "\" does not exist.") in - let this_field_record = try Recordops.find_projection field_glob_ref - with Not_found -> - let inductive_ref = inductive_of_record loc record in - raise (InternalizationError(loc, NotAProjectionOf (field_ref, inductive_ref))) - in - let remaining_projs, (field_index, _) = - let the_proj (idx, glob_id) = GlobRef.equal field_glob_ref (GlobRef.ConstRef glob_id) in + let remaining_projs, (field_index, _, regular) = + let the_proj = function + | (idx, Some glob_id, _) -> GlobRef.equal field_glob_ref (GlobRef.ConstRef glob_id) + | (idx, None, _) -> false in try CList.extract_first the_proj remaining_projs with Not_found -> - let ind1 = inductive_of_record loc record in - let ind2 = inductive_of_record loc this_field_record in + let floc = field_ref.CAst.loc in + let this_field_record = + try Recordops.find_projection field_glob_ref + with Not_found -> + let inductive_ref = inductive_of_record floc record in + raise (InternalizationError(floc, NotAProjectionOf (field_ref, inductive_ref))) in + let ind1 = inductive_of_record floc record in + let ind2 = inductive_of_record floc this_field_record in raise (InternalizationError(loc, ProjectionsOfDifferentRecords (ind1, ind2))) in + if not regular && complete then + (* "regular" is false when the field is defined + by a let-in in the record declaration + (its value is fixed from other fields). *) + user_err ?loc (str "No local fields allowed in a record construction."); + Dumpglob.add_glob ?loc:field_ref.CAst.loc field_glob_ref; index_fields fields remaining_projs ((field_index, field_value) :: acc) | [] -> - (* the order does not matter as we sort them next, - List.rev_* is just for efficiency *) let remaining_fields = - let complete_field (idx, field_ref) = (idx, - completer idx field_ref record.Recordops.s_CONST) in - List.rev_map complete_field remaining_projs in + let complete_field (idx, field_ref, regular) = + if not regular && complete then + (* For terms, we keep only regular fields *) + None + else + Some (idx, completer idx field_ref record.Recordops.s_CONST) in + List.map_filter complete_field remaining_projs in List.rev_append remaining_fields acc in - let unsorted_indexed_fields = - index_fields other_fields proj_list - [(first_field_index, first_field_value)] in + let unsorted_indexed_fields = index_fields fields proj_list [] in let sorted_indexed_fields = let cmp_by_index (i, _) (j, _) = Int.compare i j in List.sort cmp_by_index unsorted_indexed_fields in @@ -1701,9 +1652,9 @@ let drop_notations_pattern looked_for genv = if get_asymmetric_patterns () then pl else let pars = List.make n (CAst.make ?loc @@ CPatAtom None) in List.rev_append pars pl in - match drop_syndef top scopes head pl with - | Some (a,b,c) -> DAst.make ?loc @@ RCPatCstr(a, b, c) - | None -> raise (InternalizationError (loc,NotAConstructor head)) + let (_,argscs) = find_remaining_scopes [] pl head in + let pats = List.map2 (in_pat_sc scopes) argscs pl in + DAst.make ?loc @@ RCPatCstr(head, [], pats) end | CPatCstr (head, None, pl) -> begin @@ -1882,18 +1833,6 @@ let intern_ind_pattern genv ntnvars scopes pat = (**********************************************************************) (* Utilities for application *) -let merge_impargs l args = - let test x = function - | (_, Some {v=y}) -> explicitation_eq x y - | _ -> false - in - List.fold_right (fun a l -> - match a with - | (_, Some {v=ExplByName id as x}) when - List.exists (test x) args -> l - | _ -> a::l) - l args - let get_implicit_name n imps = Some (Impargs.name_of_implicit (List.nth imps (n-1))) @@ -1954,11 +1893,11 @@ let extract_explicit_arg imps args = let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let rec intern env = CAst.with_loc_val (fun ?loc -> function | CRef (ref,us) -> - let (c,imp,subscopes,l),_ = + let (c,imp,subscopes),_ = intern_applied_reference ~isproj:None intern env (Environ.named_context_val globalenv) lvar us [] ref in - apply_impargs c env imp subscopes l loc + apply_impargs c env imp subscopes [] loc | CFix ({ CAst.loc = locid; v = iddef}, dl) -> let lf = List.map (fun ({CAst.v = id},_,_,_,_) -> id) dl in @@ -2053,8 +1992,8 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = | CNotation (_,(InConstrEntrySomeLevel,"( _ )"),([a],[],[],[])) -> intern env a | CNotation (_,ntn,args) -> let c = intern_notation intern env ntnvars loc ntn args in - let x, impl, scopes, l = find_appl_head_data c in - apply_impargs x env impl scopes l loc + let x, impl, scopes = find_appl_head_data c in + apply_impargs x env impl scopes [] loc | CGeneralization (b,a,c) -> intern_generalization intern env ntnvars loc b a c | CPrim p -> @@ -2063,7 +2002,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = intern {env with tmp_scope = None; scopes = find_delimiters_scope ?loc key :: env.scopes} e | CAppExpl ((isproj,ref,us), args) -> - let (f,_,args_scopes,_),args = + let (f,_,args_scopes),args = let args = List.map (fun a -> (a,None)) args in intern_applied_reference ~isproj intern env (Environ.named_context_val globalenv) lvar us args ref @@ -2074,25 +2013,24 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = smart_gapp f loc (intern_args env args_scopes (List.map fst args)) | CApp ((isproj,f), args) -> - let isproj,f,args = match f.CAst.v with - (* Compact notations like "t.(f args') args" *) - | CApp ((Some _ as isproj',f), args') when not (Option.has_some isproj) -> - isproj',f,args'@args - (* Don't compact "(f args') args" to resolve implicits separately *) - | _ -> isproj,f,args in - let (c,impargs,args_scopes,l),args = - match f.CAst.v with - | CRef (ref,us) -> - intern_applied_reference ~isproj intern env - (Environ.named_context_val globalenv) lvar us args ref - | CNotation (_,ntn,ntnargs) -> - assert (Option.is_empty isproj); - let c = intern_notation intern env ntnvars loc ntn ntnargs in - let x, impl, scopes, l = find_appl_head_data c in - (x,impl,scopes,l), args - | _ -> assert (Option.is_empty isproj); (intern_no_implicit env f,[],[],[]), args in - apply_impargs c env impargs args_scopes - (merge_impargs l args) loc + let isproj,f,args = match f.CAst.v with + (* Compact notations like "t.(f args') args" *) + | CApp ((Some _ as isproj',f), args') when not (Option.has_some isproj) -> + isproj',f,args'@args + (* Don't compact "(f args') args" to resolve implicits separately *) + | _ -> isproj,f,args in + let (c,impargs,args_scopes),args = + match f.CAst.v with + | CRef (ref,us) -> + intern_applied_reference ~isproj intern env + (Environ.named_context_val globalenv) lvar us args ref + | CNotation (_,ntn,ntnargs) -> + assert (Option.is_empty isproj); + let c = intern_notation intern env ntnvars loc ntn ntnargs in + find_appl_head_data c, args + | _ -> assert (Option.is_empty isproj); (intern_no_implicit env f,[],[]), args in + apply_impargs c env impargs args_scopes + args loc | CRecord fs -> let st = Evar_kinds.Define (not (Program.get_proofs_transparency ())) in @@ -2101,7 +2039,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = (fun _idx fieldname constructorname -> let open Evar_kinds in let fieldinfo : Evar_kinds.record_field = - {fieldname=fieldname; recordname=inductive_of_constructor constructorname} + {fieldname=Option.get fieldname; recordname=inductive_of_constructor constructorname} in CAst.make ?loc @@ CHole (Some (Evar_kinds.QuestionMark { Evar_kinds.default_question_mark with @@ -2113,10 +2051,12 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = match fields with | None -> user_err ?loc ~hdr:"intern" (str"No constructor inference.") | Some (n, constrname, args) -> + let args_scopes = find_arguments_scope constrname in let pars = List.make n (CAst.make ?loc @@ CHole (None, IntroAnonymous, None)) in - let app = CAst.make ?loc @@ CAppExpl ((None, constrname,None), List.rev_append pars args) in - intern env app - end + let args = intern_args env args_scopes (List.rev_append pars args) in + let hd = DAst.make @@ GRef (constrname,None) in + DAst.make ?loc @@ GApp (hd, args) + end | CCases (sty, rtnpo, tms, eqns) -> let as_in_vars = List.fold_left (fun acc (_,na,inb) -> (Option.fold_left (fun acc { CAst.v = y } -> Name.fold_right Id.Set.add y acc) acc na)) @@ -2133,9 +2073,10 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = 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)) + (fun var bli -> push_name_env ntnvars [] bli (CAst.make @@ Name var)) (Id.Set.union ex_ids as_in_vars) - (reset_hidden_inductive_implicit_test (restart_lambda_binders env)) in + (restart_lambda_binders env) + in (* PatVars before a real pattern do not need to be matched *) let stripped_match_from_in = let rec aux = function @@ -2170,17 +2111,17 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = (* "in" is None so no match to add *) let ((b',(na',_)),_,_) = intern_case_item env' Id.Set.empty (b,na,None) in let p' = Option.map (fun u -> - let env'' = push_name_env ntnvars (Variable,[],[],[]) (reset_hidden_inductive_implicit_test env') + let env'' = push_name_env ntnvars [] env' (CAst.make na') in intern_type (slide_binders env'') u) po in DAst.make ?loc @@ GLetTuple (List.map (fun { CAst.v } -> v) nal, (na', p'), b', - intern (List.fold_left (push_name_env ntnvars (Variable,[],[],[])) (reset_hidden_inductive_implicit_test env) nal) c) + intern (List.fold_left (push_name_env ntnvars []) env nal) c) | CIf (c, (na,po), b1, b2) -> let env' = reset_tmp_scope env in let ((c',(na',_)),_,_) = intern_case_item env' Id.Set.empty (c,na,None) in (* no "in" no match to ad too *) let p' = Option.map (fun p -> - let env'' = push_name_env ntnvars (Variable,[],[],[]) (reset_hidden_inductive_implicit_test env) + let env'' = push_name_env ntnvars [] env (CAst.make na') in intern_type (slide_binders env'') p) po in DAst.make ?loc @@ @@ -2478,22 +2419,23 @@ let interp_open_constr ?(expected_type=WithoutTypeConstraint) env sigma c = (* Not all evars expected to be resolved and computation of implicit args *) -let interp_constr_evars_gen_impls ?(program_mode=false) env sigma +let interp_constr_evars_gen_impls ?(flags=Pretyping.all_no_fail_flags) env sigma ?(impls=empty_internalization_env) expected_type c = let c = intern_gen expected_type ~impls env sigma c in let imps = Implicit_quantifiers.implicits_of_glob_constr ~with_products:(expected_type == IsType) c in - let flags = { Pretyping.all_no_fail_flags with program_mode } in let sigma, c = understand_tcc ~flags env sigma ~expected_type c in sigma, (c, imps) -let interp_constr_evars_impls ?program_mode env sigma ?(impls=empty_internalization_env) c = - interp_constr_evars_gen_impls ?program_mode env sigma ~impls WithoutTypeConstraint c +let interp_constr_evars_impls ?(program_mode=false) env sigma ?(impls=empty_internalization_env) c = + let flags = { Pretyping.all_no_fail_flags with program_mode } in + interp_constr_evars_gen_impls ~flags env sigma ~impls WithoutTypeConstraint c -let interp_casted_constr_evars_impls ?program_mode env evdref ?(impls=empty_internalization_env) c typ = - interp_constr_evars_gen_impls ?program_mode env evdref ~impls (OfType typ) c +let interp_casted_constr_evars_impls ?(program_mode=false) env evdref ?(impls=empty_internalization_env) c typ = + let flags = { Pretyping.all_no_fail_flags with program_mode } in + interp_constr_evars_gen_impls ~flags env evdref ~impls (OfType typ) c -let interp_type_evars_impls ?program_mode env sigma ?(impls=empty_internalization_env) c = - interp_constr_evars_gen_impls ?program_mode env sigma ~impls IsType c +let interp_type_evars_impls ?(flags=Pretyping.all_no_fail_flags) env sigma ?(impls=empty_internalization_env) c = + interp_constr_evars_gen_impls ~flags env sigma ~impls IsType c (* Not all evars expected to be resolved, with side-effect on evars *) diff --git a/interp/constrintern.mli b/interp/constrintern.mli index 9d36bf2151..2eb96aad56 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -38,35 +38,33 @@ open Pretyping of [env] *) type var_internalization_type = - | Inductive of Id.t list (* list of params *) * bool (* true = check for possible capture *) + | Inductive | Recursive | Method | Variable -type var_internalization_data = - var_internalization_type * - (* type of the "free" variable, for coqdoc, e.g. while typing the - constructor of JMeq, "JMeq" behaves as a variable of type Inductive *) - - Id.t list * - (* impargs to automatically add to the variable, e.g. for "JMeq A a B b" - in implicit mode, this is [A;B] and this adds (A:=A) and (B:=B) *) - - Impargs.implicit_status list * (* signature of impargs of the variable *) - Notation_term.scope_name option list (* subscopes of the args of the variable *) +(** This collects relevant information for interning local variables: + - their coqdoc kind (a recursive call in a inductive, fixpoint of class; or a bound variable) + e.g. while typing the constructor of JMeq, "JMeq" behaves as a variable of type Inductive + - their implicit arguments + - their argument scopes *) +type var_internalization_data (** A map of free variables to their implicit arguments and scopes *) type internalization_env = var_internalization_data Id.Map.t val empty_internalization_env : internalization_env -val compute_internalization_data : env -> evar_map -> var_internalization_type -> +val compute_internalization_data : env -> evar_map -> Id.t -> var_internalization_type -> types -> Impargs.manual_implicits -> var_internalization_data val compute_internalization_env : env -> evar_map -> ?impls:internalization_env -> var_internalization_type -> Id.t list -> types list -> Impargs.manual_implicits list -> internalization_env +val extend_internalization_data : + var_internalization_data -> Impargs.implicit_status -> scope_name option -> var_internalization_data + type ltac_sign = { ltac_vars : Id.Set.t; (** Variables of Ltac which may be bound to a term *) @@ -132,7 +130,7 @@ val interp_casted_constr_evars_impls : ?program_mode:bool -> env -> evar_map -> ?impls:internalization_env -> constr_expr -> types -> evar_map * (constr * Impargs.manual_implicits) -val interp_type_evars_impls : ?program_mode:bool -> env -> evar_map -> +val interp_type_evars_impls : ?flags:inference_flags -> env -> evar_map -> ?impls:internalization_env -> constr_expr -> evar_map * (types * Impargs.manual_implicits) diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml index e659a5ac5c..57ec708b07 100644 --- a/interp/dumpglob.ml +++ b/interp/dumpglob.ml @@ -246,8 +246,6 @@ let add_glob_kn ?loc kn = let lib_dp = Lib.dp_of_mp (mp_of_kn kn) in add_glob_gen ?loc sp lib_dp "syndef" -let dump_binding ?loc id = () - let dump_def ?loc ty secpath id = Option.iter (fun loc -> if !glob_output = Feedback then Feedback.feedback (Feedback.GlobDef (loc, id, secpath, ty)) @@ -275,3 +273,6 @@ let dump_notation (loc,(df,_)) sc sec = Option.iter (fun loc -> let location = (Loc.make_loc (i, i+1)) in dump_def ~loc:location "not" (Names.DirPath.to_string (Lib.current_dirpath sec)) (cook_notation df sc) ) loc + +let dump_binding ?loc uid = + dump_def ?loc "binder" "<>" uid diff --git a/interp/dumpglob.mli b/interp/dumpglob.mli index 5409b20472..14e5a81308 100644 --- a/interp/dumpglob.mli +++ b/interp/dumpglob.mli @@ -36,7 +36,7 @@ val dump_secvar : ?loc:Loc.t -> Names.Id.t -> unit val dump_libref : ?loc:Loc.t -> Names.DirPath.t -> string -> unit val dump_notation_location : (int * int) list -> Constrexpr.notation -> (Notation.notation_location * Notation_term.scope_name option) -> unit -val dump_binding : ?loc:Loc.t -> Names.Id.Set.elt -> unit +val dump_binding : ?loc:Loc.t -> string -> unit val dump_notation : (Constrexpr.notation * Notation.notation_location) Loc.located -> Notation_term.scope_name option -> bool -> unit diff --git a/interp/notation.ml b/interp/notation.ml index 6291a88bb0..0afbb9cd62 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -206,7 +206,7 @@ let classify_scope (local,_,_ as o) = let inScope : bool * bool * scope_item -> obj = declare_object {(default_object "SCOPE") with cache_function = cache_scope; - open_function = open_scope; + open_function = simple_open open_scope; subst_function = subst_scope; discharge_function = discharge_scope; classify_function = classify_scope } @@ -980,9 +980,12 @@ let subst_prim_token_interpretation (subs,infos) = let classify_prim_token_interpretation infos = if infos.pt_local then Dispose else Substitute infos +let open_prim_token_interpretation i o = + if Int.equal i 1 then cache_prim_token_interpretation o + let inPrimTokenInterp : prim_token_infos -> obj = declare_object {(default_object "PRIM-TOKEN-INTERP") with - open_function = (fun i o -> if Int.equal i 1 then cache_prim_token_interpretation o); + open_function = simple_open open_prim_token_interpretation; cache_function = cache_prim_token_interpretation; subst_function = subst_prim_token_interpretation; classify_function = classify_prim_token_interpretation} diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml index 767c69e3b6..7184f5ea29 100644 --- a/interp/syntax_def.ml +++ b/interp/syntax_def.ml @@ -67,11 +67,18 @@ let subst_syntax_constant (subst,(local,syndef)) = let classify_syntax_constant (local,_ as o) = if local then Dispose else Substitute o +let filtered_open_syntax_constant f i ((_,kn),_ as o) = + let in_f = match f with + | Unfiltered -> true + | Names ns -> Globnames.(ExtRefSet.mem (SynDef kn) ns) + in + if in_f then open_syntax_constant i o + let in_syntax_constant : (bool * syndef) -> obj = declare_object {(default_object "SYNDEF") with cache_function = cache_syntax_constant; load_function = load_syntax_constant; - open_function = open_syntax_constant; + open_function = filtered_open_syntax_constant; subst_function = subst_syntax_constant; classify_function = classify_syntax_constant } diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index 1316dfe069..de02882370 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -613,7 +613,7 @@ let rec to_constr lfts v = subst_constr subs f) | FEvar ((ev,args),env) -> let subs = comp_subs lfts env in - mkEvar(ev,Array.map (fun a -> subst_constr subs a) args) + mkEvar(ev,List.map (fun a -> subst_constr subs a) args) | FLIFT (k,a) -> to_constr (el_shft k lfts) a | FInt i -> @@ -678,6 +678,8 @@ let rec zip m stk = let fapp_stack (m,stk) = zip m stk +let term_of_process c stk = term_of_fconstr (zip c stk) + (*********************************************************************) (* The assertions in the functions below are granted because they are @@ -1406,7 +1408,7 @@ and norm_head info tab m = Array.Fun1.map mk_clos (subs_liftn (Array.length na) e) bds in mkFix(n,(na, CArray.map (kl info tab) ftys, CArray.map (kl info tab) fbds)) | FEvar((i,args),env) -> - mkEvar(i, Array.map (fun a -> kl info tab (mk_clos env a)) args) + mkEvar(i, List.map (fun a -> kl info tab (mk_clos env a)) args) | FProj (p,c) -> mkProj (p, kl info tab c) | FLOCKED | FRel _ | FAtom _ | FFlex _ | FInd _ | FConstruct _ diff --git a/kernel/cClosure.mli b/kernel/cClosure.mli index 9e94248113..79092813bc 100644 --- a/kernel/cClosure.mli +++ b/kernel/cClosure.mli @@ -227,6 +227,10 @@ val kni: clos_infos -> clos_tab -> fconstr -> stack -> fconstr * stack val knr: clos_infos -> clos_tab -> fconstr -> stack -> fconstr * stack val kl : clos_infos -> clos_tab -> fconstr -> constr +val zip : fconstr -> stack -> fconstr + +val term_of_process : fconstr -> stack -> constr + val to_constr : lift -> fconstr -> constr (** End of cbn debug section i*) diff --git a/kernel/clambda.ml b/kernel/clambda.ml index 8c7aa6b17a..65de52c0f6 100644 --- a/kernel/clambda.ml +++ b/kernel/clambda.ml @@ -670,7 +670,7 @@ let rec lambda_of_constr env c = match Constr.kind c with | Meta _ -> raise (Invalid_argument "Cbytegen.lambda_of_constr: Meta") | Evar (evk, args) -> - let args = lambda_of_args env 0 args in + let args = Array.map_of_list (fun c -> lambda_of_constr env c) args in Levar (evk, args) | Cast (c, _, _) -> lambda_of_constr env c @@ -799,9 +799,6 @@ and lambda_of_args env start args = (fun i -> lambda_of_constr env args.(start + i)) else empty_args - - - (*********************************) let dump_lambda = ref false diff --git a/kernel/constr.ml b/kernel/constr.ml index ade03fdf93..703e3616a0 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -71,7 +71,7 @@ type case_info = (* [constr array] is an instance matching definitional [named_context] in the same order (i.e. last argument first) *) -type 'constr pexistential = existential_key * 'constr array +type 'constr pexistential = existential_key * 'constr list type ('constr, 'types) prec_declaration = Name.t binder_annot array * 'types array * 'constr array type ('constr, 'types) pfixpoint = @@ -110,7 +110,7 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = type t = (t, t, Sorts.t, Instance.t) kind_of_term type constr = t -type existential = existential_key * constr array +type existential = existential_key * constr list type types = constr @@ -470,7 +470,7 @@ let fold f acc c = match kind c with | LetIn (_,b,t,c) -> f (f (f acc b) t) c | App (c,l) -> Array.fold_left f (f acc c) l | Proj (_p,c) -> f acc c - | Evar (_,l) -> Array.fold_left f acc l + | Evar (_,l) -> List.fold_left f acc l | Case (_,p,c,bl) -> Array.fold_left f (f (f acc p) c) bl | Fix (_,(_lna,tl,bl)) -> Array.fold_left2 (fun acc t b -> f (f acc t) b) acc tl bl @@ -490,7 +490,7 @@ let iter f c = match kind c with | LetIn (_,b,t,c) -> f b; f t; f c | App (c,l) -> f c; Array.iter f l | Proj (_p,c) -> f c - | Evar (_,l) -> Array.iter f l + | Evar (_,l) -> List.iter f l | Case (_,p,c,bl) -> f p; f c; Array.iter f bl | Fix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl | CoFix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl @@ -509,7 +509,7 @@ let iter_with_binders g f n c = match kind c with | Lambda (_,t,c) -> f n t; f (g n) c | LetIn (_,b,t,c) -> f n b; f n t; f (g n) c | App (c,l) -> f n c; Array.Fun1.iter f n l - | Evar (_,l) -> Array.Fun1.iter f n l + | Evar (_,l) -> List.iter (fun c -> f n c) l | Case (_,p,c,bl) -> f n p; f n c; Array.Fun1.iter f n bl | Proj (_p,c) -> f n c | Fix (_,(_,tl,bl)) -> @@ -536,7 +536,7 @@ let fold_constr_with_binders g f n acc c = | LetIn (_na,b,t,c) -> f (g n) (f n (f n acc b) t) c | App (c,l) -> Array.fold_left (f n) (f n acc c) l | Proj (_p,c) -> f n acc c - | Evar (_,l) -> Array.fold_left (f n) acc l + | Evar (_,l) -> List.fold_left (f n) acc l | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl | Fix (_,(_,tl,bl)) -> let n' = iterate g (Array.length tl) n in @@ -657,7 +657,7 @@ let map_gen userview f c = match kind c with if t' == t then c else mkProj (p, t') | Evar (e,l) -> - let l' = Array.Smart.map f l in + let l' = List.Smart.map f l in if l'==l then c else mkEvar (e, l') | Case (ci,p,b,bl) when userview -> @@ -722,7 +722,8 @@ let fold_map f accu c = match kind c with if t' == t then accu, c else accu, mkProj (p, t') | Evar (e,l) -> - let accu, l' = Array.Smart.fold_left_map f accu l in + (* Doesn't matter, we should not hashcons evars anyways *) + let accu, l' = List.fold_left_map f accu l in if l'==l then accu, c else accu, mkEvar (e, l') | Case (ci,p,b,bl) -> @@ -782,7 +783,7 @@ let map_with_binders g f l c0 = match kind c0 with if t' == t then c0 else mkProj (p, t') | Evar (e, al) -> - let al' = Array.Fun1.Smart.map f l al in + let al' = List.Smart.map (fun c -> f l c) al in if al' == al then c0 else mkEvar (e, al') | Case (ci, p, c, bl) -> @@ -834,7 +835,7 @@ let fold_with_full_binders g f n acc c = | LetIn (na,b,t,c) -> f (g (LocalDef (na,b,t)) n) (f n (f n acc b) t) c | App (c,l) -> Array.fold_left (f n) (f n acc c) l | Proj (_,c) -> f n acc c - | Evar (_,l) -> Array.fold_left (f n) acc l + | Evar (_,l) -> List.fold_left (f n) acc l | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl | Fix (_,(lna,tl,bl)) -> let n' = CArray.fold_left2_i (fun i c n t -> g (LocalAssum (n,lift i t)) c) n lna tl in @@ -880,7 +881,7 @@ let compare_head_gen_leq_with kind1 kind2 leq_universes leq_sorts eq leq nargs t Int.equal len (Array.length l2) && leq (nargs+len) c1 c2 && Array.equal_norefl (eq 0) l1 l2 | Proj (p1,c1), Proj (p2,c2) -> Projection.equal p1 p2 && eq 0 c1 c2 - | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && Array.equal (eq 0) l1 l2 + | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && List.equal (eq 0) l1 l2 | Const (c1,u1), Const (c2,u2) -> (* The args length currently isn't used but may as well pass it. *) Constant.equal c1 c2 && leq_universes (GlobRef.ConstRef c1) nargs u1 u2 @@ -1039,7 +1040,7 @@ let constr_ord_int f t1 t2 = | Meta m1, Meta m2 -> Int.compare m1 m2 | Meta _, _ -> -1 | _, Meta _ -> 1 | Evar (e1,l1), Evar (e2,l2) -> - (Evar.compare =? (Array.compare f)) e1 e2 l1 l2 + (Evar.compare =? (List.compare f)) e1 e2 l1 l2 | Evar _, _ -> -1 | _, Evar _ -> 1 | Sort s1, Sort s2 -> Sorts.compare s1 s2 | Sort _, _ -> -1 | _, Sort _ -> 1 @@ -1141,7 +1142,7 @@ let hasheq t1 t2 = n1 == n2 && b1 == b2 && t1 == t2 && c1 == c2 | App (c1,l1), App (c2,l2) -> c1 == c2 && array_eqeq l1 l2 | Proj (p1,c1), Proj(p2,c2) -> p1 == p2 && c1 == c2 - | Evar (e1,l1), Evar (e2,l2) -> e1 == e2 && array_eqeq l1 l2 + | Evar (e1,l1), Evar (e2,l2) -> e1 == e2 && List.equal (==) l1 l2 | Const (c1,u1), Const (c2,u2) -> c1 == c2 && u1 == u2 | Ind (ind1,u1), Ind (ind2,u2) -> ind1 == ind2 && u1 == u2 | Construct (cstr1,u1), Construct (cstr2,u2) -> cstr1 == cstr2 && u1 == u2 @@ -1221,7 +1222,7 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = let l, hl = hash_term_array l in (App (c,l), combinesmall 7 (combine hl hc)) | Evar (e,l) -> - let l, hl = hash_term_array l in + let l, hl = hash_list_array l in (Evar (e,l), combinesmall 8 (combine (Evar.hash e) hl)) | Const (c,u) -> let c' = sh_con c in @@ -1289,6 +1290,14 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = let h = !accu land 0x3FFFFFFF in (HashsetTermArray.repr h t term_array_table, h) + and hash_list_array l = + let fold accu c = + let c, h = sh_rec c in + (combine accu h, c) + in + let h, l = List.fold_left_map fold 0 l in + (l, h land 0x3FFFFFFF) + in (* Make sure our statically allocated Rels (1 to 16) are considered as canonical, and hence hash-consed to themselves *) @@ -1316,7 +1325,7 @@ let rec hash t = | App (c,l) -> combinesmall 7 (combine (hash_term_array l) (hash c)) | Evar (e,l) -> - combinesmall 8 (combine (Evar.hash e) (hash_term_array l)) + combinesmall 8 (combine (Evar.hash e) (hash_term_list l)) | Const (c,u) -> combinesmall 9 (combine (Constant.hash c) (Instance.hash u)) | Ind (ind,u) -> @@ -1339,6 +1348,9 @@ let rec hash t = and hash_term_array t = Array.fold_left (fun acc t -> combine acc (hash t)) 0 t +and hash_term_list t = + List.fold_left (fun acc t -> combine (hash t) acc) 0 t + module CaseinfoHash = struct type t = case_info @@ -1458,7 +1470,7 @@ let rec debug_print c = prlist_with_sep spc debug_print (Array.to_list l) ++ str")") | Evar (e,l) -> hov 1 (str"Evar#" ++ int (Evar.repr e) ++ str"{" ++ - prlist_with_sep spc debug_print (Array.to_list l) ++str"}") + prlist_with_sep spc debug_print l ++str"}") | Const (c,u) -> str"Cst(" ++ pr_puniverses (Constant.debug_print c) u ++ str")" | Ind ((sp,i),u) -> str"Ind(" ++ pr_puniverses (MutInd.print sp ++ str"," ++ int i) u ++ str")" | Construct (((sp,i),j),u) -> diff --git a/kernel/constr.mli b/kernel/constr.mli index 16919b705a..00051d7551 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -83,7 +83,7 @@ val mkFloat : Float64.t -> constr val mkMeta : metavariable -> constr (** Constructs an existential variable *) -type existential = Evar.t * constr array +type existential = Evar.t * constr list val mkEvar : existential -> constr (** Construct a sort *) @@ -203,9 +203,9 @@ val mkCoFix : cofixpoint -> constr (** {6 Concrete type for making pattern-matching. } *) -(** [constr array] is an instance matching definitional [named_context] in +(** [constr list] is an instance matching definitional [named_context] in the same order (i.e. last argument first) *) -type 'constr pexistential = Evar.t * 'constr array +type 'constr pexistential = Evar.t * 'constr list type ('constr, 'types, 'sort, 'univs) kind_of_term = | Rel of int (** Gallina-variable introduced by [forall], [fun], [let-in], [fix], or [cofix]. *) diff --git a/kernel/declarations.ml b/kernel/declarations.ml index 244cd2865d..2f6a870c8a 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -92,6 +92,8 @@ type typing_flags = { indices_matter: bool; (** The universe of an inductive type must be above that of its indices. *) + cumulative_sprop : bool; + (** SProp <= Type *) } (* some contraints are in constant_constraints, some other may be in @@ -293,8 +295,6 @@ and 'a generic_module_body = mod_expr : 'a; (** implementation *) mod_type : module_signature; (** expanded type *) mod_type_alg : module_expression option; (** algebraic type *) - mod_constraints : Univ.ContextSet.t; (** - set of all universes constraints in the module *) mod_delta : Mod_subst.delta_resolver; (** quotiented set of equivalent constants and inductive names *) mod_retroknowledge : 'a module_retroknowledge } diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 20dc21900c..0ab99cab35 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -26,6 +26,7 @@ let safe_flags oracle = { enable_VM = true; enable_native_compiler = true; indices_matter = true; + cumulative_sprop = false; } (** {6 Arities } *) @@ -390,7 +391,6 @@ and hcons_generic_module_body : let expr' = hcons_impl mb.mod_expr in let type' = hcons_module_signature mb.mod_type in let type_alg' = mb.mod_type_alg in - let constraints' = Univ.hcons_universe_context_set mb.mod_constraints in let delta' = mb.mod_delta in let retroknowledge' = mb.mod_retroknowledge in @@ -399,7 +399,6 @@ and hcons_generic_module_body : mb.mod_expr == expr' && mb.mod_type == type' && mb.mod_type_alg == type_alg' && - mb.mod_constraints == constraints' && mb.mod_delta == delta' && mb.mod_retroknowledge == retroknowledge' then mb @@ -408,7 +407,6 @@ and hcons_generic_module_body : mod_expr = expr'; mod_type = type'; mod_type_alg = type_alg'; - mod_constraints = constraints'; mod_delta = delta'; mod_retroknowledge = retroknowledge'; } diff --git a/kernel/environ.ml b/kernel/environ.ml index 2d2c9a454b..d6d52dbc2b 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -128,7 +128,7 @@ let empty_env = { env_nb_rel = 0; env_stratification = { env_universes = UGraph.initial_universes; - env_sprop_allowed = false; + env_sprop_allowed = true; env_universes_lbound = Univ.Level.set; env_engagement = PredicativeSet }; env_typing_flags = Declareops.safe_flags Conv_oracle.empty; @@ -279,6 +279,9 @@ let indices_matter env = env.env_typing_flags.indices_matter let universes env = env.env_stratification.env_universes let universes_lbound env = env.env_stratification.env_universes_lbound +let set_universes g env = + {env with env_stratification = {env.env_stratification with env_universes=g}} + let set_universes_lbound env lbound = let env_stratification = { env.env_stratification with env_universes_lbound = lbound } in { env with env_stratification } @@ -431,7 +434,7 @@ let push_subgraph (levels,csts) env = in map_universes add_subgraph env -let set_engagement c env = (* Unsafe *) +let set_engagement c env = { env with env_stratification = { env.env_stratification with env_engagement = c } } @@ -445,6 +448,7 @@ let same_flags { share_reduction; enable_VM; enable_native_compiler; + cumulative_sprop; } alt = check_guarded == alt.check_guarded && check_positive == alt.check_positive && @@ -453,14 +457,18 @@ let same_flags { indices_matter == alt.indices_matter && share_reduction == alt.share_reduction && enable_VM == alt.enable_VM && - enable_native_compiler == alt.enable_native_compiler + enable_native_compiler == alt.enable_native_compiler && + cumulative_sprop == alt.cumulative_sprop [@warning "+9"] -let set_typing_flags c env = (* Unsafe *) +let set_cumulative_sprop b = map_universes (UGraph.set_cumulative_sprop b) + +let set_typing_flags c env = if same_flags env.env_typing_flags c then env - else { env with env_typing_flags = c } + else set_cumulative_sprop c.cumulative_sprop { env with env_typing_flags = c } -let make_sprop_cumulative = map_universes UGraph.make_sprop_cumulative +let set_cumulative_sprop b env = + set_typing_flags {env.env_typing_flags with cumulative_sprop=b} env let set_allow_sprop b env = { env with env_stratification = diff --git a/kernel/environ.mli b/kernel/environ.mli index 25ecdfd852..7a46538772 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -102,6 +102,8 @@ val rel_context : env -> Constr.rel_context val named_context : env -> Constr.named_context val named_context_val : env -> named_context_val +val set_universes : UGraph.t -> env -> env + val opaque_tables : env -> Opaqueproof.opaquetab val set_opaque_tables : env -> Opaqueproof.opaquetab -> env @@ -310,7 +312,7 @@ val push_subgraph : Univ.ContextSet.t -> env -> env val set_engagement : engagement -> env -> env val set_typing_flags : typing_flags -> env -> env -val make_sprop_cumulative : env -> env +val set_cumulative_sprop : bool -> env -> env val set_allow_sprop : bool -> env -> env val sprop_allowed : env -> bool diff --git a/kernel/inferCumulativity.ml b/kernel/inferCumulativity.ml index f987164d52..662ad550b8 100644 --- a/kernel/inferCumulativity.ml +++ b/kernel/inferCumulativity.ml @@ -99,7 +99,7 @@ let rec infer_fterm cv_pb infos variances hd stk = end | FEvar ((_,args),e) -> let variances = infer_stack infos variances stk in - infer_vect infos variances (Array.map (mk_clos e) args) + infer_list infos variances (List.map (mk_clos e) args) | FRel _ -> infer_stack infos variances stk | FInt _ -> infer_stack infos variances stk | FFloat _ -> infer_stack infos variances stk @@ -168,6 +168,9 @@ and infer_stack infos variances (stk:CClosure.stack) = and infer_vect infos variances v = Array.fold_left (fun variances c -> infer_fterm CONV infos variances c []) variances v +and infer_list infos variances v = + List.fold_left (fun variances c -> infer_fterm CONV infos variances c []) variances v + let infer_term cv_pb env variances c = let open CClosure in let infos = (create_clos_infos all env, create_tab ()) in diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index aa513c1536..317141e324 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -405,7 +405,7 @@ let rec map_kn f f' c = if (ct'== ct && l'==l) then c else mkApp (ct',l') | Evar (e,l) -> - let l' = Array.Smart.map func l in + let l' = List.Smart.map func l in if (l'==l) then c else mkEvar (e,l') | Fix (ln,(lna,tl,bl)) -> diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index 76e2a584bd..44b010204b 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -23,7 +23,7 @@ open Modops open Mod_subst type 'alg translation = - module_signature * 'alg * delta_resolver * Univ.ContextSet.t + module_signature * 'alg * delta_resolver * Univ.Constraint.t let rec mp_from_mexpr = function | MEident mp -> mp @@ -54,8 +54,6 @@ let rec rebuild_mp mp l = | []-> mp | i::r -> rebuild_mp (MPdot(mp,Label.of_id i)) r -let (+++) = Univ.ContextSet.union - let rec check_with_def env struc (idl,(c,ctx)) mp equiv = let lab,idl = match idl with | [] -> assert false @@ -173,10 +171,10 @@ let rec check_with_mod env struc (idl,mp1) mp equiv = | Abstract -> let mtb_old = module_type_of_module old in let chk_cst = Subtyping.check_subtypes env' mtb_mp1 mtb_old in - Univ.ContextSet.add_constraints chk_cst old.mod_constraints + chk_cst | Algebraic (NoFunctor (MEident(mp'))) -> check_modpath_equiv env' mp1 mp'; - old.mod_constraints + Univ.Constraint.empty | _ -> error_generative_module_expected lab in let mp' = MPdot (mp,lab) in @@ -185,7 +183,7 @@ let rec check_with_mod env struc (idl,mp1) mp equiv = { new_mb with mod_mp = mp'; mod_expr = Algebraic (NoFunctor (MEident mp1)); - mod_constraints = cst } + } in let new_equiv = add_delta_resolver equiv new_mb.mod_delta in (* we propagate the new equality in the rest of the signature @@ -219,7 +217,7 @@ let rec check_with_mod env struc (idl,mp1) mp equiv = | Algebraic (NoFunctor (MEident mp0)) -> let mpnew = rebuild_mp mp0 idl in check_modpath_equiv env' mpnew mp; - before@(lab,spec)::after, equiv, Univ.ContextSet.empty + before@(lab,spec)::after, equiv, Univ.Constraint.empty | _ -> error_generative_module_expected lab end with @@ -231,11 +229,11 @@ let check_with env mp (sign,alg,reso,cst) = function let struc = destr_nofunctor sign in let struc', c', cst' = check_with_def env struc (idl, (c, ctx)) mp reso in let wd' = WithDef (idl, (c', ctx)) in - NoFunctor struc', MEwith (alg,wd'), reso, Univ.ContextSet.add_constraints cst' cst + NoFunctor struc', MEwith (alg,wd'), reso, Univ.Constraint.union cst' cst |WithMod(idl,mp1) as wd -> let struc = destr_nofunctor sign in let struc',reso',cst' = check_with_mod env struc (idl,mp1) mp reso in - NoFunctor struc', MEwith (alg,wd), reso', cst+++cst' + NoFunctor struc', MEwith (alg,wd), reso', Univ.Constraint.union cst' cst let translate_apply env inl (sign,alg,reso,cst1) mp1 mkalg = let farg_id, farg_b, fbody_b = destr_functor sign in @@ -247,7 +245,7 @@ let translate_apply env inl (sign,alg,reso,cst1) mp1 mkalg = let body = subst_signature subst fbody_b in let alg' = mkalg alg mp1 in let reso' = subst_codom_delta_resolver subst reso in - body,alg',reso', Univ.ContextSet.add_constraints cst2 cst1 + body,alg',reso', Univ.Constraint.union cst2 cst1 (** Translation of a module struct entry : - We translate to a module when a [module_path] is given, @@ -266,7 +264,7 @@ let rec translate_mse env mpo inl = function let mt = lookup_modtype mp1 env in module_body_of_type mt.mod_mp mt in - mb.mod_type, me, mb.mod_delta, Univ.ContextSet.empty + mb.mod_type, me, mb.mod_delta, Univ.Constraint.empty |MEapply (fe,mp1) -> translate_apply env inl (translate_mse env mpo inl fe) mp1 mk_alg_app |MEwith(me, with_decl) -> @@ -274,17 +272,16 @@ let rec translate_mse env mpo inl = function let mp = mp_from_mexpr me in check_with env mp (translate_mse env None inl me) with_decl -let mk_mod mp e ty cst reso = +let mk_mod mp e ty reso = { mod_mp = mp; mod_expr = e; mod_type = ty; mod_type_alg = None; - mod_constraints = cst; mod_delta = reso; mod_retroknowledge = ModBodyRK []; } -let mk_modtype mp ty cst reso = - let mb = mk_mod mp Abstract ty cst reso in +let mk_modtype mp ty reso = + let mb = mk_mod mp Abstract ty reso in { mb with mod_expr = (); mod_retroknowledge = ModTypeRK } let rec translate_mse_funct env mpo inl mse = function @@ -293,45 +290,45 @@ let rec translate_mse_funct env mpo inl mse = function sign, NoFunctor alg, reso, cst |(mbid, ty) :: params -> let mp_id = MPbound mbid in - let mtb = translate_modtype env mp_id inl ([],ty) in + let mtb, cst = translate_modtype env mp_id inl ([],ty) in let env' = add_module_type mp_id mtb env in - let sign,alg,reso,cst = translate_mse_funct env' mpo inl mse params in + let sign,alg,reso,cst' = translate_mse_funct env' mpo inl mse params in let alg' = MoreFunctor (mbid,mtb,alg) in - MoreFunctor (mbid, mtb, sign), alg',reso, cst +++ mtb.mod_constraints + MoreFunctor (mbid, mtb, sign), alg',reso, Univ.Constraint.union cst cst' and translate_modtype env mp inl (params,mte) = let sign,alg,reso,cst = translate_mse_funct env None inl mte params in - let mtb = mk_modtype (mp_from_mexpr mte) sign cst reso in + let mtb = mk_modtype (mp_from_mexpr mte) sign reso in let mtb' = subst_modtype_and_resolver mtb mp in - { mtb' with mod_type_alg = Some alg } + { mtb' with mod_type_alg = Some alg }, cst (** [finalize_module] : from an already-translated (or interactive) implementation and an (optional) signature entry, produces a final [module_body] *) -let finalize_module env mp (sign,alg,reso,cst) restype = match restype with - |None -> +let finalize_module env mp (sign,alg,reso,cst1) restype = match restype with + | None -> let impl = match alg with Some e -> Algebraic e | None -> FullStruct in - mk_mod mp impl sign cst reso - |Some (params_mte,inl) -> - let res_mtb = translate_modtype env mp inl params_mte in - let auto_mtb = mk_modtype mp sign Univ.ContextSet.empty reso in - let cst' = Subtyping.check_subtypes env auto_mtb res_mtb in + mk_mod mp impl sign reso, cst1 + | Some (params_mte,inl) -> + let res_mtb, cst2 = translate_modtype env mp inl params_mte in + let auto_mtb = mk_modtype mp sign reso in + let cst3 = Subtyping.check_subtypes env auto_mtb res_mtb in let impl = match alg with Some e -> Algebraic e | None -> Struct sign in { res_mtb with mod_mp = mp; mod_expr = impl; mod_retroknowledge = ModBodyRK []; - (** cst from module body typing, - cst' from subtyping, - constraints from module type. *) - mod_constraints = - Univ.ContextSet.add_constraints cst' (cst +++ res_mtb.mod_constraints) } + }, + (** cst from module body typing, + cst' from subtyping, + constraints from module type. *) + Univ.Constraint.(union cst1 (union cst2 cst3)) let translate_module env mp inl = function |MType (params,ty) -> - let mtb = translate_modtype env mp inl (params,ty) in - module_body_of_type mp mtb + let mtb, cst = translate_modtype env mp inl (params,ty) in + module_body_of_type mp mtb, cst |MExpr (params,mse,oty) -> let (sg,alg,reso,cst) = translate_mse_funct env (Some mp) inl mse params in let restype = Option.map (fun ty -> ((params,ty),inl)) oty in @@ -364,7 +361,7 @@ let rec translate_mse_inclmod env mp inl = function |MEident mp1 -> let mb = strengthen_and_subst_mb (lookup_module mp1 env) mp true in let sign = clean_bounded_mod_expr mb.mod_type in - sign,(),mb.mod_delta,Univ.ContextSet.empty + sign,(),mb.mod_delta,Univ.Constraint.empty |MEapply (fe,arg) -> let ftrans = translate_mse_inclmod env mp inl fe in translate_apply env inl ftrans arg (fun _ _ -> ()) @@ -375,6 +372,6 @@ let translate_mse_incl is_mod env mp inl me = let () = forbid_incl_signed_functor env me in translate_mse_inclmod env mp inl me else - let mtb = translate_modtype env mp inl ([],me) in + let mtb, cst = translate_modtype env mp inl ([],me) in let sign = clean_bounded_mod_expr mtb.mod_type in - sign,(),mtb.mod_delta,mtb.mod_constraints + sign, (), mtb.mod_delta, cst diff --git a/kernel/mod_typing.mli b/kernel/mod_typing.mli index fd5421aefe..94a4b17df3 100644 --- a/kernel/mod_typing.mli +++ b/kernel/mod_typing.mli @@ -23,13 +23,13 @@ open Names *) val translate_module : - env -> ModPath.t -> inline -> module_entry -> module_body + env -> ModPath.t -> inline -> module_entry -> module_body * Univ.Constraint.t (** [translate_modtype] produces a [module_type_body] whose [mod_type_alg] cannot be [None] (and of course [mod_expr] is [Abstract]). *) val translate_modtype : - env -> ModPath.t -> inline -> module_type_entry -> module_type_body + env -> ModPath.t -> inline -> module_type_entry -> module_type_body * Univ.Constraint.t (** Low-level function for translating a module struct entry : - We translate to a module when a [ModPath.t] is given, @@ -39,7 +39,7 @@ val translate_modtype : the extraction. *) type 'alg translation = - module_signature * 'alg * delta_resolver * Univ.ContextSet.t + module_signature * 'alg * delta_resolver * Univ.Constraint.t val translate_mse : env -> ModPath.t option -> inline -> module_struct_entry -> @@ -51,7 +51,7 @@ val translate_mse : val finalize_module : env -> ModPath.t -> (module_expression option) translation -> (module_type_entry * inline) option -> - module_body + module_body * Univ.Constraint.t (** [translate_mse_incl] translate the mse of a module or module type given to an Include *) diff --git a/kernel/modops.ml b/kernel/modops.ml index 301af328e4..77ef38dfd5 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -225,8 +225,7 @@ and subst_body : 'a. _ -> _ -> (_ -> 'a -> 'a) -> _ -> 'a generic_module_body -> && retro==retro' && delta'==mb.mod_delta then mb else - { mb with - mod_mp = mp'; + { mod_mp = mp'; mod_expr = me'; mod_type = ty'; mod_type_alg = aty'; diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index 9ed0f6f411..02ee501f5f 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -474,7 +474,7 @@ let rec lambda_of_constr cache env sigma c = | Evar (evk,args as ev) -> (match evar_value sigma ev with | None -> - let args = Array.map (lambda_of_constr cache env sigma) args in + let args = Array.map_of_list (fun c -> lambda_of_constr cache env sigma c) args in Levar(evk, args) | Some t -> lambda_of_constr cache env sigma t) diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml index dde1274152..494282d4e1 100644 --- a/kernel/nativelib.ml +++ b/kernel/nativelib.ml @@ -37,7 +37,7 @@ let ( / ) = Filename.concat let my_temp_dir = lazy (CUnix.mktemp_dir "Coq_native" "") let () = at_exit (fun () -> - if Lazy.is_val my_temp_dir then + if not !Flags.debug && Lazy.is_val my_temp_dir then try let d = Lazy.force my_temp_dir in Array.iter (fun f -> Sys.remove (Filename.concat d f)) (Sys.readdir d); diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index 6cfe44c5ff..a5fcfae1fc 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -96,14 +96,14 @@ let mk_accu (a : atom) : t = else let data = { data with acc_arg = x :: data.acc_arg } in let ans = Obj.repr (accumulate data) in - let () = Obj.set_tag ans accumulate_tag [@ocaml.alert "--deprecated"] in + let () = Obj.set_tag ans accumulate_tag [@ocaml.warning "-3"] in ans in let acc = { acc_atm = a; acc_arg = [] } in let ans = Obj.repr (accumulate acc) in (** FIXME: use another representation for accumulators, this causes naked pointers. *) - let () = Obj.set_tag ans accumulate_tag [@ocaml.alert "--deprecated"] in + let () = Obj.set_tag ans accumulate_tag [@ocaml.warning "-3"] in (Obj.obj ans : t) let get_accu (k : accumulator) = diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 469d5ccaa2..4ff90dd70d 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -354,7 +354,8 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = (match kind a1, kind a2 with | (Sort s1, Sort s2) -> if not (is_empty_stack v1 && is_empty_stack v2) then - anomaly (Pp.str "conversion was given ill-typed terms (Sort)."); + (* May happen because we convert application right to left *) + raise NotConvertible; sort_cmp_universes (info_env infos.cnv_inf) cv_pb s1 s2 cuniv | (Meta n, Meta m) -> if Int.equal n m @@ -366,9 +367,9 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = let el1 = el_stack lft1 v1 in let el2 = el_stack lft2 v2 in let cuniv = convert_stacks l2r infos lft1 lft2 v1 v2 cuniv in - convert_vect l2r infos el1 el2 - (Array.map (mk_clos env1) args1) - (Array.map (mk_clos env2) args2) cuniv + convert_list l2r infos el1 el2 + (List.map (mk_clos env1) args1) + (List.map (mk_clos env2) args2) cuniv else raise NotConvertible (* 2 index known to be bound to no constant *) @@ -471,7 +472,8 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = | (FProd (x1, c1, c2, e), FProd (_, c'1, c'2, e')) -> if not (is_empty_stack v1 && is_empty_stack v2) then - anomaly (Pp.str "conversion was given ill-typed terms (FProd)."); + (* May happen because we convert application right to left *) + raise NotConvertible; (* Luo's system *) let el1 = el_stack lft1 v1 in let el2 = el_stack lft2 v2 in @@ -700,6 +702,13 @@ and convert_branches l2r infos ci e1 e2 lft1 lft2 br1 br2 cuniv = in Array.fold_right3 fold ci.ci_cstr_nargs br1 br2 cuniv +and convert_list l2r infos lft1 lft2 v1 v2 cuniv = match v1, v2 with +| [], [] -> cuniv +| c1 :: v1, c2 :: v2 -> + let cuniv = ccnv CONV l2r infos lft1 lft2 c1 c2 cuniv in + convert_list l2r infos lft1 lft2 v1 v2 cuniv +| _, _ -> raise NotConvertible + let clos_gen_conv trans cv_pb l2r evars env univs t1 t2 = let reds = CClosure.RedFlags.red_add_transparent betaiotazeta trans in let infos = create_clos_infos ~evars reds env in diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 181ec4860c..93337fca5d 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -113,11 +113,23 @@ type library_info = DirPath.t * vodigest (** Functor and funsig parameters, most recent first *) type module_parameters = (MBId.t * module_type_body) list +type compiled_library = { + comp_name : DirPath.t; + comp_mod : module_body; + comp_univs : Univ.ContextSet.t; + comp_deps : library_info array; + comp_enga : engagement; + comp_natsymbs : Nativevalues.symbols +} + +type reimport = compiled_library * Univ.ContextSet.t * vodigest + (** Part of the safe_env at a section opening time to be backtracked *) type section_data = { rev_env : Environ.env; rev_univ : Univ.ContextSet.t; rev_objlabels : Label.Set.t; + rev_reimport : reimport list; } type safe_environment = @@ -232,8 +244,6 @@ let set_native_compiler b senv = let flags = Environ.typing_flags senv.env in set_typing_flags { flags with enable_native_compiler = b } senv -let make_sprop_cumulative senv = { senv with env = Environ.make_sprop_cumulative senv.env } - let set_allow_sprop b senv = { senv with env = Environ.set_allow_sprop b senv.env } (** Check that the engagement [c] expected by a library matches @@ -301,6 +311,7 @@ sig type t val repr : t -> side_effect list val empty : t + val is_empty : t -> bool val add : side_effect -> t -> t val concat : t -> t -> t end = @@ -319,6 +330,7 @@ type t = { seff : side_effect list; elts : SeffSet.t } let repr eff = eff.seff let empty = { seff = []; elts = SeffSet.empty } +let is_empty { seff; elts } = List.is_empty seff && SeffSet.is_empty elts let add x es = if SeffSet.mem x es.elts then es else { seff = x :: es.seff; elts = SeffSet.add x es.elts } @@ -349,6 +361,7 @@ let push_private_constants env eff = List.fold_left add_if_undefined env eff let empty_private_constants = SideEffects.empty +let is_empty_private_constants c = SideEffects.is_empty c let concat_private = SideEffects.concat let universes_of_private eff = @@ -552,8 +565,7 @@ let constraints_of_sfb sfb = match sfb with | SFBconst cb -> globalize_constant_universes cb | SFBmind mib -> globalize_mind_universes mib - | SFBmodtype mtb -> [mtb.mod_constraints] - | SFBmodule mb -> [mb.mod_constraints] + | SFBmodtype _ | SFBmodule _ -> [] let add_retroknowledge pttc senv = { senv with @@ -972,103 +984,35 @@ let add_mind l mie senv = let add_modtype l params_mte inl senv = let mp = MPdot(senv.modpath, l) in - let mtb = Mod_typing.translate_modtype senv.env mp inl params_mte in + let mtb, cst = Mod_typing.translate_modtype senv.env mp inl params_mte in + let senv = push_context_set ~strict:true (Univ.LSet.empty,cst) senv in let mtb = Declareops.hcons_module_type mtb in - let senv' = add_field (l,SFBmodtype mtb) MT senv in - mp, senv' + let senv = add_field (l,SFBmodtype mtb) MT senv in + mp, senv (** full_add_module adds module with universes and constraints *) let full_add_module mb senv = - let senv = add_constraints (Now mb.mod_constraints) senv in let dp = ModPath.dp mb.mod_mp in let linkinfo = Nativecode.link_info_of_dirpath dp in { senv with env = Modops.add_linked_module mb linkinfo senv.env } let full_add_module_type mp mt senv = - let senv = add_constraints (Now mt.mod_constraints) senv in { senv with env = Modops.add_module_type mp mt senv.env } (** Insertion of modules *) let add_module l me inl senv = let mp = MPdot(senv.modpath, l) in - let mb = Mod_typing.translate_module senv.env mp inl me in + let mb, cst = Mod_typing.translate_module senv.env mp inl me in + let senv = push_context_set ~strict:true (Univ.LSet.empty,cst) senv in let mb = Declareops.hcons_module_body mb in - let senv' = add_field (l,SFBmodule mb) M senv in - let senv'' = - if Modops.is_functor mb.mod_type then senv' - else update_resolver (Mod_subst.add_delta_resolver mb.mod_delta) senv' - in - (mp,mb.mod_delta),senv'' - -(** {6 Interactive sections *) - -let open_section senv = - let custom = { - rev_env = senv.env; - rev_univ = senv.univ; - rev_objlabels = senv.objlabels; - } in - let sections = Section.open_section ~custom senv.sections in - { senv with sections=Some sections } - -let close_section senv = - let open Section in - let sections0 = get_section senv.sections in - let env0 = senv.env in - (* First phase: revert the declarations added in the section *) - let sections, entries, cstrs, revert = Section.close_section sections0 in - let rec pop_revstruct accu entries revstruct = match entries, revstruct with - | [], revstruct -> accu, revstruct - | _ :: _, [] -> - CErrors.anomaly (Pp.str "Unmatched section data") - | entry :: entries, (lbl, leaf) :: revstruct -> - let data = match entry, leaf with - | SecDefinition kn, SFBconst cb -> - let () = assert (Label.equal lbl (Constant.label kn)) in - `Definition (kn, cb) - | SecInductive ind, SFBmind mib -> - let () = assert (Label.equal lbl (MutInd.label ind)) in - `Inductive (ind, mib) - | (SecDefinition _ | SecInductive _), (SFBconst _ | SFBmind _) -> - CErrors.anomaly (Pp.str "Section content mismatch") - | (SecDefinition _ | SecInductive _), (SFBmodule _ | SFBmodtype _) -> - CErrors.anomaly (Pp.str "Module inside a section") - in - pop_revstruct (data :: accu) entries revstruct - in - let redo, revstruct = pop_revstruct [] entries senv.revstruct in - (* Don't revert the delayed constraints. If some delayed constraints were - forced inside the section, they have been turned into global monomorphic - that are going to be replayed. Those that are not forced are not readded - by {!add_constant_aux}. *) - let { rev_env = env; rev_univ = univ; rev_objlabels = objlabels } = revert in - (* Do not revert the opaque table, the discharged opaque constants are - referring to it. *) - let env = Environ.set_opaque_tables env (Environ.opaque_tables senv.env) in - let senv = { senv with env; revstruct; sections; univ; objlabels; } in - (* Second phase: replay the discharged section contents *) - let senv = push_context_set ~strict:true cstrs senv in - let modlist = Section.replacement_context env0 sections0 in - let cooking_info seg = - let { abstr_ctx; abstr_subst; abstr_uctx } = seg in - let abstract = (abstr_ctx, abstr_subst, abstr_uctx) in - { Opaqueproof.modlist; abstract } - in - let fold senv = function - | `Definition (kn, cb) -> - let info = cooking_info (Section.segment_of_constant env0 kn sections0) in - let r = { Cooking.from = cb; info } in - let cb = Term_typing.translate_recipe senv.env kn r in - (* Delayed constants are already in the global environment *) - add_constant_aux senv (kn, cb) - | `Inductive (ind, mib) -> - let info = cooking_info (Section.segment_of_inductive env0 ind sections0) in - let mib = Cooking.cook_inductive info mib in - add_checked_mind ind mib senv + let senv = add_field (l,SFBmodule mb) M senv in + let senv = + if Modops.is_functor mb.mod_type then senv + else update_resolver (Mod_subst.add_delta_resolver mb.mod_delta) senv in - List.fold_left fold senv redo + (mp,mb.mod_delta),senv (** {6 Starting / ending interactive modules and module types } *) @@ -1100,7 +1044,8 @@ let start_modtype l senv = let add_module_parameter mbid mte inl senv = let () = check_empty_struct senv in let mp = MPbound mbid in - let mtb = Mod_typing.translate_modtype senv.env mp inl ([],mte) in + let mtb, cst = Mod_typing.translate_modtype senv.env mp inl ([],mte) in + let senv = push_context_set ~strict:true (Univ.LSet.empty,cst) senv in let senv = full_add_module_type mp mtb senv in let new_variant = match senv.modvariant with | STRUCT (params,oldenv) -> STRUCT ((mbid,mtb) :: params, oldenv) @@ -1138,12 +1083,12 @@ let functorize_module params mb = let build_module_body params restype senv = let struc = NoFunctor (List.rev senv.revstruct) in let restype' = Option.map (fun (ty,inl) -> (([],ty),inl)) restype in - let mb = + let mb, cst = Mod_typing.finalize_module senv.env senv.modpath - (struc,None,senv.modresolver,senv.univ) restype' + (struc,None,senv.modresolver,Univ.Constraint.empty) restype' in let mb' = functorize_module params mb in - { mb' with mod_retroknowledge = ModBodyRK senv.local_retroknowledge } + { mb' with mod_retroknowledge = ModBodyRK senv.local_retroknowledge }, cst (** Returning back to the old pre-interactive-module environment, with one extra component and some updated fields @@ -1183,15 +1128,13 @@ let end_module l restype senv = let () = check_current_label l mp in let () = check_empty_context senv in let mbids = List.rev_map fst params in - let mb = build_module_body params restype senv in + let mb, cst = build_module_body params restype senv in + let senv = push_context_set ~strict:true (Univ.LSet.empty,cst) senv in let newenv = Environ.set_opaque_tables oldsenv.env (Environ.opaque_tables senv.env) in let newenv = Environ.set_native_symbols newenv senv.env.Environ.native_symbols in let newenv = set_engagement_opt newenv senv.engagement in - let senv'= - propagate_loads { senv with - env = newenv; - univ = Univ.ContextSet.union senv.univ mb.mod_constraints} in - let newenv = Environ.push_context_set ~strict:true mb.mod_constraints senv'.env in + let newenv = Environ.set_universes (Environ.universes senv.env) newenv in + let senv' = propagate_loads { senv with env = newenv } in let newenv = Modops.add_module mb newenv in let newresolver = if Modops.is_functor mb.mod_type then oldsenv.modresolver @@ -1200,12 +1143,11 @@ let end_module l restype senv = (mp,mbids,mb.mod_delta), propagate_senv (l,SFBmodule mb) newenv newresolver senv' oldsenv -let build_mtb mp sign cst delta = +let build_mtb mp sign delta = { mod_mp = mp; mod_expr = (); mod_type = sign; mod_type_alg = None; - mod_constraints = cst; mod_delta = delta; mod_retroknowledge = ModTypeRK } @@ -1217,11 +1159,11 @@ let end_modtype l senv = let mbids = List.rev_map fst params in let newenv = Environ.set_opaque_tables oldsenv.env (Environ.opaque_tables senv.env) in let newenv = Environ.set_native_symbols newenv senv.env.Environ.native_symbols in - let newenv = Environ.push_context_set ~strict:true senv.univ newenv in let newenv = set_engagement_opt newenv senv.engagement in + let newenv = Environ.set_universes (Environ.universes senv.env) newenv in let senv' = propagate_loads {senv with env=newenv} in let auto_tb = functorize params (NoFunctor (List.rev senv.revstruct)) in - let mtb = build_mtb mp auto_tb senv'.univ senv.modresolver in + let mtb = build_mtb mp auto_tb senv.modresolver in let newenv = Environ.add_modtype mtb senv'.env in let newresolver = oldsenv.modresolver in (mp,mbids), @@ -1235,7 +1177,7 @@ let add_include me is_module inl senv = let sign,(),resolver,cst = translate_mse_incl is_module senv.env mp_sup inl me in - let senv = add_constraints (Now cst) senv in + let senv = push_context_set ~strict:true (Univ.LSet.empty,cst) senv in (* Include Self support *) let rec compute_sign sign mb resolver senv = match sign with @@ -1255,7 +1197,7 @@ let add_include me is_module inl senv = in let resolver,str,senv = let struc = NoFunctor (List.rev senv.revstruct) in - let mtb = build_mtb mp_sup struc Univ.ContextSet.empty senv.modresolver in + let mtb = build_mtb mp_sup struc senv.modresolver in compute_sign sign mtb resolver senv in let senv = update_resolver (Mod_subst.add_delta_resolver resolver) senv @@ -1275,16 +1217,10 @@ let add_include me is_module inl senv = (** {6 Libraries, i.e. compiled modules } *) -type compiled_library = { - comp_name : DirPath.t; - comp_mod : module_body; - comp_deps : library_info array; - comp_enga : engagement; - comp_natsymbs : Nativevalues.symbols -} - let module_of_library lib = lib.comp_mod +let univs_of_library lib = lib.comp_univs + type native_library = Nativecode.global list (** FIXME: MS: remove?*) @@ -1313,7 +1249,6 @@ let export ?except ~output_native_objects senv dir = mod_expr = FullStruct; mod_type = str; mod_type_alg = None; - mod_constraints = senv.univ; mod_delta = senv.modresolver; mod_retroknowledge = ModBodyRK senv.local_retroknowledge } @@ -1326,6 +1261,7 @@ let export ?except ~output_native_objects senv dir = let lib = { comp_name = dir; comp_mod = mb; + comp_univs = senv.univ; comp_deps = Array.of_list (DPmap.bindings senv.required); comp_enga = Environ.engagement senv.env; comp_natsymbs = symbols } @@ -1333,7 +1269,7 @@ let export ?except ~output_native_objects senv dir = mp, lib, ast (* cst are the constraints that were computed by the vi2vo step and hence are - * not part of the mb.mod_constraints field (but morally should be) *) + * not part of the [lib.comp_univs] field (but morally should be) *) let import lib cst vodigest senv = check_required senv.required lib.comp_deps; check_engagement senv.env lib.comp_enga; @@ -1343,22 +1279,101 @@ let import lib cst vodigest senv = let mp = MPfile lib.comp_name in let mb = lib.comp_mod in let env = Environ.push_context_set ~strict:true - (Univ.ContextSet.union mb.mod_constraints cst) - senv.env + (Univ.ContextSet.union lib.comp_univs cst) + senv.env in let env = let linkinfo = Nativecode.link_info_of_dirpath lib.comp_name in Modops.add_linked_module mb linkinfo env in let env = Environ.add_native_symbols lib.comp_name lib.comp_natsymbs env in + let sections = + Option.map (Section.map_custom (fun custom -> + {custom with rev_reimport = (lib,cst,vodigest) :: custom.rev_reimport})) + senv.sections + in mp, { senv with env; modresolver = Mod_subst.add_delta_resolver mb.mod_delta senv.modresolver; required = DPmap.add lib.comp_name vodigest senv.required; loads = (mp,mb)::senv.loads; + sections; } +(** {6 Interactive sections *) + +let open_section senv = + let custom = { + rev_env = senv.env; + rev_univ = senv.univ; + rev_objlabels = senv.objlabels; + rev_reimport = []; + } in + let sections = Section.open_section ~custom senv.sections in + { senv with sections=Some sections } + +let close_section senv = + let open Section in + let sections0 = get_section senv.sections in + let env0 = senv.env in + (* First phase: revert the declarations added in the section *) + let sections, entries, cstrs, revert = Section.close_section sections0 in + let rec pop_revstruct accu entries revstruct = match entries, revstruct with + | [], revstruct -> accu, revstruct + | _ :: _, [] -> + CErrors.anomaly (Pp.str "Unmatched section data") + | entry :: entries, (lbl, leaf) :: revstruct -> + let data = match entry, leaf with + | SecDefinition kn, SFBconst cb -> + let () = assert (Label.equal lbl (Constant.label kn)) in + `Definition (kn, cb) + | SecInductive ind, SFBmind mib -> + let () = assert (Label.equal lbl (MutInd.label ind)) in + `Inductive (ind, mib) + | (SecDefinition _ | SecInductive _), (SFBconst _ | SFBmind _) -> + CErrors.anomaly (Pp.str "Section content mismatch") + | (SecDefinition _ | SecInductive _), (SFBmodule _ | SFBmodtype _) -> + CErrors.anomaly (Pp.str "Module inside a section") + in + pop_revstruct (data :: accu) entries revstruct + in + let redo, revstruct = pop_revstruct [] entries senv.revstruct in + (* Don't revert the delayed constraints. If some delayed constraints were + forced inside the section, they have been turned into global monomorphic + that are going to be replayed. Those that are not forced are not readded + by {!add_constant_aux}. *) + let { rev_env = env; rev_univ = univ; rev_objlabels = objlabels; rev_reimport } = revert in + (* Do not revert the opaque table, the discharged opaque constants are + referring to it. *) + let env = Environ.set_opaque_tables env (Environ.opaque_tables senv.env) in + let senv = { senv with env; revstruct; sections; univ; objlabels; } in + (* Second phase: replay Requires *) + let senv = List.fold_left (fun senv (lib,cst,vodigest) -> snd (import lib cst vodigest senv)) + senv (List.rev rev_reimport) + in + (* Third phase: replay the discharged section contents *) + let senv = push_context_set ~strict:true cstrs senv in + let modlist = Section.replacement_context env0 sections0 in + let cooking_info seg = + let { abstr_ctx; abstr_subst; abstr_uctx } = seg in + let abstract = (abstr_ctx, abstr_subst, abstr_uctx) in + { Opaqueproof.modlist; abstract } + in + let fold senv = function + | `Definition (kn, cb) -> + let info = cooking_info (Section.segment_of_constant env0 kn sections0) in + let r = { Cooking.from = cb; info } in + let cb = Term_typing.translate_recipe senv.env kn r in + (* Delayed constants are already in the global environment *) + add_constant_aux senv (kn, cb) + | `Inductive (ind, mib) -> + let info = cooking_info (Section.segment_of_inductive env0 ind sections0) in + let mib = Cooking.cook_inductive info mib in + add_checked_mind ind mib senv + in + List.fold_left fold senv redo + (** {6 Safe typing } *) type judgment = Environ.unsafe_judgment diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index f8d5d319a9..b601279e87 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -50,6 +50,8 @@ type 'a safe_transformer = safe_environment -> 'a * safe_environment type private_constants val empty_private_constants : private_constants +val is_empty_private_constants : private_constants -> bool + val concat_private : private_constants -> private_constants -> private_constants (** [concat_private e1 e2] adds the constants of [e1] to [e2], i.e. constants in [e1] must be more recent than those of [e2]. *) @@ -133,7 +135,6 @@ val set_check_positive : bool -> safe_transformer0 val set_check_universes : bool -> safe_transformer0 val set_VM : bool -> safe_transformer0 val set_native_compiler : bool -> safe_transformer0 -val make_sprop_cumulative : safe_transformer0 val set_allow_sprop : bool -> safe_transformer0 val check_engagement : Environ.env -> Declarations.set_predicativity -> unit @@ -193,6 +194,7 @@ type compiled_library type native_library = Nativecode.global list val module_of_library : compiled_library -> Declarations.module_body +val univs_of_library : compiled_library -> Univ.ContextSet.t val start_library : DirPath.t -> ModPath.t safe_transformer diff --git a/kernel/section.ml b/kernel/section.ml index 948a967f96..8c36f16799 100644 --- a/kernel/section.ml +++ b/kernel/section.ml @@ -45,6 +45,8 @@ let has_poly_univs sec = sec.has_poly_univs let all_poly_univs sec = sec.all_poly_univs +let map_custom f sec = {sec with sec_custom = f sec.sec_custom} + let find_emap e (cmap, imap) = match e with | SecDefinition con -> Cmap.find con cmap | SecInductive ind -> Mindmap.find ind imap diff --git a/kernel/section.mli b/kernel/section.mli index 89739c7da2..2ebb4564b3 100644 --- a/kernel/section.mli +++ b/kernel/section.mli @@ -19,6 +19,9 @@ type 'a t val depth : 'a t -> int (** Number of nested sections. *) +val map_custom : ('a -> 'a) -> 'a t -> 'a t +(** Modify the custom data *) + (** {6 Manipulating sections} *) type section_entry = diff --git a/kernel/sorts.ml b/kernel/sorts.ml index 466fbacca4..3a89b73bd5 100644 --- a/kernel/sorts.ml +++ b/kernel/sorts.ml @@ -12,6 +12,8 @@ open Univ type family = InSProp | InProp | InSet | InType +let all_families = [InSProp; InProp; InSet; InType] + type t = | SProp | Prop diff --git a/kernel/sorts.mli b/kernel/sorts.mli index 49549e224d..fe939b1d95 100644 --- a/kernel/sorts.mli +++ b/kernel/sorts.mli @@ -12,6 +12,8 @@ type family = InSProp | InProp | InSet | InType +val all_families : family list + type t = private | SProp | Prop diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index 3f81a62956..28baa82666 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -336,7 +336,6 @@ and check_modtypes cst env mtb1 mtb2 subst1 subst2 equiv = mod_expr = Abstract; mod_type = subst_signature subst1 body_t1; mod_type_alg = None; - mod_constraints = mtb1.mod_constraints; mod_retroknowledge = ModBodyRK []; mod_delta = mtb1.mod_delta} env in @@ -347,7 +346,6 @@ and check_modtypes cst env mtb1 mtb2 subst1 subst2 equiv = let check_subtypes env sup super = let env = add_module_type sup.mod_mp sup env in - let env = Environ.push_context_set ~strict:true super.mod_constraints env in check_modtypes Univ.Constraint.empty env (strengthen sup sup.mod_mp) super empty_subst (map_mp super.mod_mp sup.mod_mp sup.mod_delta) false diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index 449cd0f0f9..5f5f0ef8cd 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -37,7 +37,7 @@ let g_map f g = if g.graph == g' then g else {g with graph=g'} -let make_sprop_cumulative g = {g with sprop_cumulative=true} +let set_cumulative_sprop b g = {g with sprop_cumulative=b} let check_smaller_expr g (u,n) (v,m) = let diff = n - m in diff --git a/kernel/uGraph.mli b/kernel/uGraph.mli index 8a8c09e911..8d9afb0990 100644 --- a/kernel/uGraph.mli +++ b/kernel/uGraph.mli @@ -13,8 +13,8 @@ open Univ (** {6 Graphs of universes. } *) type t -val make_sprop_cumulative : t -> t -(** Don't use this in the kernel, it makes the system incomplete. *) +val set_cumulative_sprop : bool -> t -> t +(** Makes the system incomplete. *) type 'a check_function = t -> 'a -> 'a -> bool diff --git a/lib/cErrors.ml b/lib/cErrors.ml index d1548ab12e..62d465c703 100644 --- a/lib/cErrors.ml +++ b/lib/cErrors.ml @@ -106,8 +106,10 @@ let print_gen ~anomaly (e, info) = try print_gen ~anomaly ~extra_msg !handle_stack e with exn -> + let exn, info = Exninfo.capture exn in (* exception in error printer *) - str "<in exception printer>" ++ fnl () ++ print_anomaly anomaly exn + str "<in exception printer>:" ++ print_backtrace info ++ + str "<original exception:" ++ print_anomaly anomaly exn (** The standard exception printer *) let iprint (e, info) = diff --git a/lib/flags.ml b/lib/flags.ml index 2832ddd27a..1d9d6d49bc 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -82,3 +82,11 @@ let get_inline_level () = !inline_level let profile_ltac = ref false let profile_ltac_cutoff = ref 2.0 + +let native_compiler = ref None +let get_native_compiler () = match !native_compiler with +| None -> assert false +| Some b -> b +let set_native_compiler b = + let () = assert (!native_compiler == None) in + native_compiler := Some b diff --git a/lib/flags.mli b/lib/flags.mli index a68be196d7..30d1b5b2bd 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -90,6 +90,11 @@ val without_option : bool ref -> ('a -> 'b) -> 'a -> 'b (** Temporarily extends the reference to a list *) val with_extra_values : 'c list ref -> 'c list -> ('a -> 'b) -> 'a -> 'b +(** Native compilation flag *) +val get_native_compiler : unit -> bool +val set_native_compiler : bool -> unit +(** Must be set exactly once at initialization time. *) + (** Level of inlining during a functor application *) val set_inline_level : int -> unit val get_inline_level : unit -> int diff --git a/lib/lib.mllib b/lib/lib.mllib index 2db59712b9..4e08e87084 100644 --- a/lib/lib.mllib +++ b/lib/lib.mllib @@ -14,6 +14,7 @@ CWarnings AcyclicGraph Rtree System +ObjFile Explore CProfile Future diff --git a/lib/objFile.ml b/lib/objFile.ml new file mode 100644 index 0000000000..96db51a010 --- /dev/null +++ b/lib/objFile.ml @@ -0,0 +1,229 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \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 Pp +open System + +let magic_number = 0x436F7121l (* "Coq!" *) + +let error_corrupted file s = + CErrors.user_err ~hdr:"System" (str file ++ str ": " ++ str s ++ str ". Try to rebuild it.") + +let open_trapping_failure name = + try open_out_bin name + with e when CErrors.noncritical e -> + CErrors.user_err ~hdr:"System.open" (str "Can't open " ++ str name) + +(* + +int32: big-endian, 4 bytes +int64: big-endian, 8 bytes + +-- string -- +int32 | length of the next field +data | + +-- segment summary -- +string | name +int64 | absolute position +int64 | length (without hash) +hash | MD5 (16 bytes) + +-- segment -- +... | binary data +hash | MD5 (16 bytes) + +-- summary -- +int32 | number of segment summaries +s1 | +... | segment summaries +sn | + +-- vo -- +int32 | magic number +int32 | Coq version +int64 | absolute position of the summary +... | segments +summary | + +*) + +type segment = { + name : string; + pos : int64; + len : int64; + hash : Digest.t; +} + +type in_handle = { + in_filename : string; + in_channel : in_channel; + in_segments : segment CString.Map.t; +} + +type out_handle = { + out_filename : string; + out_channel : out_channel; + mutable out_segments : segment CString.Map.t; +} + +let input_int32 ch = + let accu = ref 0l in + for _i = 0 to 3 do + let c = input_byte ch in + accu := Int32.add (Int32.shift_left !accu 8) (Int32.of_int c) + done; + !accu + +let input_int64 ch = + let accu = ref 0L in + for _i = 0 to 7 do + let c = input_byte ch in + accu := Int64.add (Int64.shift_left !accu 8) (Int64.of_int c) + done; + !accu + +let output_int32 ch n = + for i = 0 to 3 do + output_byte ch (Int32.to_int (Int32.shift_right_logical n (24 - 8 * i))) + done + +let output_int64 ch n = + for i = 0 to 7 do + output_byte ch (Int64.to_int (Int64.shift_right_logical n (56 - 8 * i))) + done + +let input_segment_summary ch = + let nlen = input_int32 ch in + let name = really_input_string ch (Int32.to_int nlen) in + let pos = input_int64 ch in + let len = input_int64 ch in + let hash = Digest.input ch in + { name; pos; len; hash } + +let output_segment_summary ch seg = + let nlen = Int32.of_int (String.length seg.name) in + let () = output_int32 ch nlen in + let () = output_string ch seg.name in + let () = output_int64 ch seg.pos in + let () = output_int64 ch seg.len in + let () = Digest.output ch seg.hash in + () + +let rec input_segment_summaries ch n accu = + if Int32.equal n 0l then accu + else + let s = input_segment_summary ch in + let accu = CString.Map.add s.name s accu in + input_segment_summaries ch (Int32.pred n) accu + +let marshal_in_segment (type a) h ~segment : a * Digest.t = + let { in_channel = ch } = h in + let s = CString.Map.find segment h.in_segments in + let () = LargeFile.seek_in ch s.pos in + let (v : a) = marshal_in h.in_filename ch in + let () = assert (Int64.equal (LargeFile.pos_in ch) (Int64.add s.pos s.len)) in + let h = Digest.input ch in + let () = assert (String.equal h s.hash) in + (v, s.hash) + +let marshal_out_segment h ~segment v = + let { out_channel = ch } = h in + let () = assert (not (CString.Map.mem segment h.out_segments)) in + let pos = LargeFile.pos_out ch in + let () = Marshal.to_channel ch v [] in + let () = flush ch in + let pos' = LargeFile.pos_out ch in + let len = Int64.sub pos' pos in + let hash = + let in_ch = open_in_bin h.out_filename in + let () = LargeFile.seek_in in_ch pos in + let digest = Digest.channel in_ch (Int64.to_int len) in + let () = close_in in_ch in + digest + in + let () = Digest.output ch hash in + let s = { name = segment; pos; len; hash } in + let () = h.out_segments <- CString.Map.add segment s h.out_segments in + () + +let marshal_out_binary h ~segment = + let { out_channel = ch } = h in + let () = assert (not (CString.Map.mem segment h.out_segments)) in + let pos = LargeFile.pos_out ch in + let finish () = + let () = flush ch in + let pos' = LargeFile.pos_out ch in + let len = Int64.sub pos' pos in + let hash = + let in_ch = open_in_bin h.out_filename in + let () = LargeFile.seek_in in_ch pos in + let digest = Digest.channel in_ch (Int64.to_int len) in + let () = close_in in_ch in + digest + in + let () = Digest.output ch hash in + let s = { name = segment; pos; len; hash } in + h.out_segments <- CString.Map.add segment s h.out_segments + in + ch, finish + +let open_in ~file = + try + let ch = open_in_bin file in + let magic = input_int32 ch in + let version = input_int32 ch in + let () = + if not (Int32.equal magic magic_number) then + let e = { filename = file; actual = version; expected = magic_number } in + raise (Bad_magic_number e) + in + let () = + let expected = Coq_config.vo_version in + if not (Int32.equal version expected) then + let e = { filename = file; actual = version; expected } in + raise (Bad_version_number e) + in + let summary_pos = input_int64 ch in + let () = LargeFile.seek_in ch summary_pos in + let nsum = input_int32 ch in + let seg = input_segment_summaries ch nsum CString.Map.empty in + { in_filename = file; in_channel = ch; in_segments = seg } + with + | End_of_file -> error_corrupted file "premature end of file" + | Failure s | Sys_error s -> error_corrupted file s + +let close_in ch = + close_in ch.in_channel + +let get_segment ch ~segment = + CString.Map.find segment ch.in_segments + +let segments ch = ch.in_segments + +let open_out ~file = + let ch = open_trapping_failure file in + let () = output_int32 ch magic_number in + let () = output_int32 ch Coq_config.vo_version in + let () = output_int64 ch 0L (* placeholder *) in + { out_channel = ch; out_segments = CString.Map.empty; out_filename = file } + +let close_out { out_channel = ch; out_segments = seg } = + let () = flush ch in + let pos = LargeFile.pos_out ch in + (* Write the segment summary *) + let () = output_int32 ch (Int32.of_int (CString.Map.cardinal seg)) in + let iter _ s = output_segment_summary ch s in + let () = CString.Map.iter iter seg in + (* Overwrite the position place holder *) + let () = LargeFile.seek_out ch 8L in + let () = output_int64 ch pos in + let () = flush ch in + close_out ch diff --git a/lib/objFile.mli b/lib/objFile.mli new file mode 100644 index 0000000000..b15b04ee54 --- /dev/null +++ b/lib/objFile.mli @@ -0,0 +1,37 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \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) *) +(************************************************************************) + +val magic_number : int32 + +type segment = { + name : string; + pos : int64; + len : int64; + hash : Digest.t; +} + +type in_handle +type out_handle + +val open_in : file:string -> in_handle +val close_in : in_handle -> unit +val marshal_in_segment : in_handle -> segment:string -> 'a * Digest.t +val get_segment : in_handle -> segment:string -> segment +val segments : in_handle -> segment CString.Map.t + +val open_out : file:string -> out_handle +val close_out : out_handle -> unit +val marshal_out_segment : out_handle -> segment:string -> 'a -> unit +val marshal_out_binary : out_handle -> segment:string -> out_channel * (unit -> unit) +(** [marshal_out_binary oh segment] is a low level, stateful, API returning + [oc, stop]. Once called no other API can be used on the same [oh] and only + [Stdlib.output_*] APIs should be used on [oc]. [stop ()] must be invoked in + order to signal that all data was written to [oc] (which should not be used + afterwards). Only after calling [stop] the other API can be used on [oh]. *) diff --git a/lib/system.ml b/lib/system.ml index d7f5fa26ab..4e98651d6e 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -182,36 +182,9 @@ let marshal_in filename ch = | End_of_file -> error_corrupted filename "premature end of file" | Failure s -> error_corrupted filename s -let digest_out = Digest.output -let digest_in filename ch = - try Digest.input ch - with - | End_of_file -> error_corrupted filename "premature end of file" - | Failure s -> error_corrupted filename s - -let marshal_out_segment f ch v = - let start = pos_out ch in - output_binary_int ch 0; (* dummy value for stop *) - marshal_out ch v; - let stop = pos_out ch in - seek_out ch start; - output_binary_int ch stop; - seek_out ch stop; - digest_out ch (Digest.file f) - -let marshal_in_segment f ch = - let stop = (input_binary_int f ch : int) in - let v = marshal_in f ch in - let digest = digest_in f ch in - v, stop, digest - -let skip_in_segment f ch = - let stop = (input_binary_int f ch : int) in - seek_in ch stop; - stop, digest_in f ch - -type magic_number_error = {filename: string; actual: int; expected: int} +type magic_number_error = {filename: string; actual: int32; expected: int32} exception Bad_magic_number of magic_number_error +exception Bad_version_number of magic_number_error let raw_extern_state magic filename = let channel = open_trapping_failure filename in @@ -225,8 +198,8 @@ let raw_intern_state magic filename = if not (Int.equal actual_magic magic) then raise (Bad_magic_number { filename=filename; - actual=actual_magic; - expected=magic}); + actual=Int32.of_int actual_magic; + expected=Int32.of_int magic}); channel with | End_of_file -> error_corrupted filename "premature end of file" @@ -256,10 +229,14 @@ let intern_state magic filename = let with_magic_number_check f a = try f a - with Bad_magic_number {filename=fname;actual=actual;expected=expected} -> + with + | Bad_magic_number {filename=fname; _} -> + CErrors.user_err ~hdr:"with_magic_number_check" + (str"File " ++ str fname ++ strbrk" is corrupted.") + | Bad_version_number {filename=fname;actual=actual;expected=expected} -> CErrors.user_err ~hdr:"with_magic_number_check" - (str"File " ++ str fname ++ strbrk" has bad magic number " ++ - int actual ++ str" (expected " ++ int expected ++ str")." ++ + (str"File " ++ str fname ++ strbrk" has bad version number " ++ + (str @@ Int32.to_string actual) ++ str" (expected " ++ (str @@ Int32.to_string expected) ++ str")." ++ spc () ++ strbrk "It is corrupted or was compiled with another version of Coq.") diff --git a/lib/system.mli b/lib/system.mli index 00701379bd..4a8c35b6ea 100644 --- a/lib/system.mli +++ b/lib/system.mli @@ -68,8 +68,9 @@ val file_exists_respecting_case : string -> string -> bool when the check fails, with the full file name and expected/observed magic numbers. *) -type magic_number_error = {filename: string; actual: int; expected: int} +type magic_number_error = {filename: string; actual: int32; expected: int32} exception Bad_magic_number of magic_number_error +exception Bad_version_number of magic_number_error val raw_extern_state : int -> string -> out_channel @@ -87,15 +88,6 @@ val with_magic_number_check : ('a -> 'b) -> 'a -> 'b val marshal_out : out_channel -> 'a -> unit val marshal_in : string -> in_channel -> 'a -(** Clones of Digest.output and Digest.input (with nice error message) *) - -val digest_out : out_channel -> Digest.t -> unit -val digest_in : string -> in_channel -> Digest.t - -val marshal_out_segment : string -> out_channel -> 'a -> unit -val marshal_in_segment : string -> in_channel -> 'a * int * Digest.t -val skip_in_segment : string -> in_channel -> int * Digest.t - (** {6 Time stamps.} *) type time diff --git a/library/global.ml b/library/global.ml index abc04a5e14..5c847fda96 100644 --- a/library/global.ml +++ b/library/global.ml @@ -99,7 +99,9 @@ let set_check_guarded c = globalize0 (Safe_typing.set_check_guarded c) let set_check_positive c = globalize0 (Safe_typing.set_check_positive c) let set_check_universes c = globalize0 (Safe_typing.set_check_universes c) let typing_flags () = Environ.typing_flags (env ()) -let make_sprop_cumulative () = globalize0 Safe_typing.make_sprop_cumulative +let set_cumulative_sprop b = + set_typing_flags {(typing_flags()) with Declarations.cumulative_sprop = b} +let is_cumulative_sprop () = (typing_flags()).Declarations.cumulative_sprop let set_allow_sprop b = globalize0 (Safe_typing.set_allow_sprop b) let sprop_allowed () = Environ.sprop_allowed (env()) let export_private_constants cd = globalize (Safe_typing.export_private_constants cd) diff --git a/library/global.mli b/library/global.mli index e7133a1034..2acd7e2a67 100644 --- a/library/global.mli +++ b/library/global.mli @@ -36,7 +36,8 @@ val set_check_guarded : bool -> unit val set_check_positive : bool -> unit val set_check_universes : bool -> unit val typing_flags : unit -> Declarations.typing_flags -val make_sprop_cumulative : unit -> unit +val set_cumulative_sprop : bool -> unit +val is_cumulative_sprop : unit -> bool val set_allow_sprop : bool -> unit val sprop_allowed : unit -> bool diff --git a/library/globnames.ml b/library/globnames.ml index 9126a467bf..bc24fbf096 100644 --- a/library/globnames.ml +++ b/library/globnames.ml @@ -117,3 +117,10 @@ module ExtRefOrdered = struct | SynDef kn -> combinesmall 2 (KerName.hash kn) end + +module ExtRefMap = HMap.Make(ExtRefOrdered) +module ExtRefSet = ExtRefMap.Set + +let subst_extended_reference sub = function + | SynDef kn -> SynDef (subst_kn sub kn) + | TrueGlobal gr -> TrueGlobal (subst_global_reference sub gr) diff --git a/library/globnames.mli b/library/globnames.mli index fb1583e16c..8acea5ef28 100644 --- a/library/globnames.mli +++ b/library/globnames.mli @@ -61,3 +61,10 @@ module ExtRefOrdered : sig val equal : t -> t -> bool val hash : t -> int end + +module ExtRefSet : CSig.SetS with type elt = extended_global_reference +module ExtRefMap : CMap.ExtS + with type key = extended_global_reference + and module Set := ExtRefSet + +val subst_extended_reference : substitution -> extended_global_reference -> extended_global_reference diff --git a/library/goptions.ml b/library/goptions.ml index 75eef5b411..f096c5d749 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -24,6 +24,10 @@ type option_value = | StringValue of string | StringOptValue of string option +type table_value = + | StringRefValue of string + | QualidRefValue of qualid + (** Summary of an option status *) type option_state = { opt_depr : bool; @@ -35,8 +39,13 @@ type option_state = { let nickname table = String.concat " " table +let error_no_table_of_this_type ~kind key = + user_err ~hdr:"Goptions" + (str ("There is no " ^ kind ^ "-valued table with this name: \"" ^ nickname key ^ "\".")) + let error_undeclared_key key = - user_err ~hdr:"Goptions" (str (nickname key) ++ str ": no table or option of this type") + user_err ~hdr:"Goptions" + (str ("There is no flag, option or table with this name: \"" ^ nickname key ^ "\".")) (****************************************************************************) (* 1- Tables *) @@ -90,7 +99,7 @@ module MakeTable = let inGo : option_mark * A.t -> obj = Libobject.declare_object {(Libobject.default_object nick) with Libobject.load_function = load_options; - Libobject.open_function = load_options; + Libobject.open_function = simple_open load_options; Libobject.cache_function = cache_options; Libobject.subst_function = subst_options; Libobject.classify_function = (fun x -> Substitute x)} @@ -184,6 +193,23 @@ end module MakeRefTable = functor (A : RefConvertArg) -> MakeTable (RefConvert(A)) +type iter_table_aux = { aux : 'a. 'a table_of_A -> Environ.env -> 'a -> unit } + +let iter_table f key lv = + let aux = function + | StringRefValue s -> + begin + try f.aux (get_string_table key) (Global.env()) s + with Not_found -> error_no_table_of_this_type ~kind:"string" key + end + | QualidRefValue locqid -> + begin + try f.aux (get_ref_table key) (Global.env()) locqid + with Not_found -> error_no_table_of_this_type ~kind:"qualid" key + end + in + List.iter aux lv + (****************************************************************************) (* 2- Flags. *) @@ -262,7 +288,7 @@ let declare_option cast uncast append ?(preprocess = fun x -> x) declare_object { (default_object (nickname key)) with load_function = load_options; - open_function = open_options; + open_function = simple_open open_options; cache_function = cache_options; subst_function = subst_options; discharge_function = discharge_options; @@ -296,6 +322,48 @@ let declare_stringopt_option = (function StringOptValue v -> v | _ -> anomaly (Pp.str "async_option.")) (fun _ _ -> anomaly (Pp.str "async_option.")) + +type 'a opt_decl = depr:bool -> key:option_name -> 'a + +let declare_int_option_and_ref ~depr ~key ~(value:int) = + let r_opt = ref value in + let optwrite v = r_opt := Option.default value v in + let optread () = Some !r_opt in + let _ = declare_int_option { + optdepr = depr; + optkey = key; + optread; optwrite + } in + fun () -> !r_opt + +let declare_intopt_option_and_ref ~depr ~key = + let r_opt = ref None in + let optwrite v = r_opt := v in + let optread () = !r_opt in + let _ = declare_int_option { + optdepr = depr; + optkey = key; + optread; optwrite + } in + optread + +let declare_nat_option_and_ref ~depr ~key ~(value:int) = + assert (value >= 0); + let r_opt = ref value in + let optwrite v = + let v = Option.default value v in + if v < 0 then + CErrors.user_err Pp.(str "This option expects a non-negative value."); + r_opt := v + in + let optread () = Some !r_opt in + let _ = declare_int_option { + optdepr = depr; + optkey = key; + optread; optwrite + } in + fun () -> !r_opt + let declare_bool_option_and_ref ~depr ~key ~(value:bool) = let r_opt = ref value in let optwrite v = r_opt := v in @@ -307,14 +375,48 @@ let declare_bool_option_and_ref ~depr ~key ~(value:bool) = } in optread +let declare_string_option_and_ref ~depr ~key ~(value:string) = + let r_opt = ref value in + let optwrite v = r_opt := Option.default value v in + let optread () = Some !r_opt in + let _ = declare_stringopt_option { + optdepr = depr; + optkey = key; + optread; optwrite + } in + fun () -> !r_opt + +let declare_stringopt_option_and_ref ~depr ~key = + let r_opt = ref None in + let optwrite v = r_opt := v in + let optread () = !r_opt in + let _ = declare_stringopt_option { + optdepr = depr; + optkey = key; + optread; optwrite + } in + optread + +let declare_interpreted_string_option_and_ref ~depr ~key ~(value:'a) from_string to_string = + let r_opt = ref value in + let optwrite v = r_opt := Option.default value @@ Option.map from_string v in + let optread () = Some (to_string !r_opt) in + let _ = declare_stringopt_option { + optdepr = depr; + optkey = key; + optread; optwrite + } in + fun () -> !r_opt + (* 3- User accessible commands *) (* Setting values of options *) let warn_unknown_option = - CWarnings.create ~name:"unknown-option" ~category:"option" - (fun key -> strbrk "There is no option " ++ - str (nickname key) ++ str ".") + CWarnings.create + ~name:"unknown-option" ~category:"option" + (fun key -> strbrk "There is no flag or option with this name: \"" ++ + str (nickname key) ++ str "\".") let set_option_value ?(locality = OptDefault) check_and_cast key v = let opt = try Some (get_option key) with Not_found -> None in @@ -323,38 +425,38 @@ let set_option_value ?(locality = OptDefault) check_and_cast key v = | Some (depr, (read,write,append)) -> write locality (check_and_cast v (read ())) -let show_value_type = function - | BoolValue _ -> "bool" - | IntValue _ -> "int" - | StringValue _ -> "string" - | StringOptValue _ -> "string" - -let bad_type_error opt_value actual_type = +let bad_type_error ~expected ~got = user_err Pp.(str "Bad type of value for this option:" ++ spc() ++ - str "expected " ++ str (show_value_type opt_value) ++ - str ", got " ++ str actual_type ++ str ".") + str "expected " ++ str expected ++ + str ", got " ++ str got ++ str ".") + +let error_flag () = + user_err Pp.(str "This is a flag. It does not take a value.") let check_int_value v = function + | BoolValue _ -> error_flag () | IntValue _ -> IntValue v - | optv -> bad_type_error optv "int" + | StringValue _ | StringOptValue _ -> + bad_type_error ~expected:"string" ~got:"int" let check_bool_value v = function | BoolValue _ -> BoolValue v - | optv -> bad_type_error optv "bool" + | _ -> user_err Pp.(str "This is an option. A value must be provided.") let check_string_value v = function + | BoolValue _ -> error_flag () + | IntValue _ -> bad_type_error ~expected:"int" ~got:"string" | StringValue _ -> StringValue v | StringOptValue _ -> StringOptValue (Some v) - | optv -> bad_type_error optv "string" let check_unset_value v = function | BoolValue _ -> BoolValue false | IntValue _ -> IntValue None | StringOptValue _ -> StringOptValue None - | optv -> bad_type_error optv "nothing" + | StringValue _ -> user_err Pp.(str "This option does not support the \"Unset\" command.") (* Nota: For compatibility reasons, some errors are treated as - warning. This allows a script to refer to an option that doesn't + warnings. This allows a script to refer to an option that doesn't exist anymore *) let set_int_option_value_gen ?locality = diff --git a/library/goptions.mli b/library/goptions.mli index 8fcc258d47..150954cbac 100644 --- a/library/goptions.mli +++ b/library/goptions.mli @@ -104,9 +104,15 @@ end (** {6 Options. } *) -(** These types and function are for declaring a new option of name [key] - and access functions [read] and [write]; the parameter [name] is the option name - used when printing the option value (command "Print Toto Titi." *) +(** These types and function are for declaring a new option of name + [key] and access functions [read] and [write]; the parameter [name] + is the option name used when printing the option value (command + "Print Toto Titi." + + The declare_*_option functions are low-level, to be used when + implementing complex option workflows, e.g. when setting one option + changes the value of another. For most use cases, you should use + the helper functions declare_*_option_and_ref. *) type 'a option_sig = { optdepr : bool; @@ -118,7 +124,11 @@ type 'a option_sig = { } (** The [preprocess] function is triggered before setting the option. It can be - used to emit a warning on certain values, and clean-up the final value. *) + used to emit a warning on certain values, and clean-up the final value. + + [declare_stringopt_option] should be preferred to [declare_string_option] + because it supports "Unset". + Only "Warnings" option is declared using the latter.*) val declare_int_option : ?preprocess:(int option -> int option) -> int option option_sig -> unit @@ -129,9 +139,18 @@ val declare_string_option: ?preprocess:(string -> string) -> val declare_stringopt_option: ?preprocess:(string option -> string option) -> string option option_sig -> unit -(** Helper to declare a reference controlled by an option. Read-only +(** Helpers to declare a reference controlled by an option. Read-only as to avoid races. *) -val declare_bool_option_and_ref : depr:bool -> key:option_name -> value:bool -> (unit -> bool) +type 'a opt_decl = depr:bool -> key:option_name -> 'a + +val declare_int_option_and_ref : (value:int -> (unit -> int)) opt_decl +val declare_intopt_option_and_ref : (unit -> int option) opt_decl +val declare_nat_option_and_ref : (value:int -> (unit -> int)) opt_decl +val declare_bool_option_and_ref : (value:bool -> (unit -> bool)) opt_decl +val declare_string_option_and_ref : (value:string -> (unit -> string)) opt_decl +val declare_stringopt_option_and_ref : (unit -> string option) opt_decl +val declare_interpreted_string_option_and_ref : + (value:'a -> (string -> 'a) -> ('a -> string) -> (unit -> 'a)) opt_decl (** {6 Special functions supposed to be used only in vernacentries.ml } *) @@ -168,6 +187,10 @@ type option_value = | StringValue of string | StringOptValue of string option +type table_value = + | StringRefValue of string + | QualidRefValue of qualid + val set_option_value : ?locality:option_locality -> ('a -> option_value -> option_value) -> option_name -> 'a -> unit (** [set_option_value ?locality f name v] sets [name] to the result of @@ -185,4 +208,7 @@ type option_state = { val get_tables : unit -> option_state OptionMap.t val print_tables : unit -> Pp.t +type iter_table_aux = { aux : 'a. 'a table_of_A -> Environ.env -> 'a -> unit } +val iter_table : iter_table_aux -> option_name -> table_value list -> unit + val error_undeclared_key : option_name -> 'a diff --git a/library/lib.ml b/library/lib.ml index e7e6dc640a..830777003b 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -46,7 +46,7 @@ let iter_objects f i prefix = List.iter (fun (id,obj) -> f i (make_oname prefix id, obj)) let load_atomic_objects i pr = iter_objects load_object i pr -let open_atomic_objects i pr = iter_objects open_object i pr +let open_atomic_objects f i pr = iter_objects (open_object f) i pr let subst_atomic_objects subst seg = let subst_one = fun (id,obj as node) -> diff --git a/library/lib.mli b/library/lib.mli index 949b5e26c2..56ea35ec60 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -35,7 +35,8 @@ type lib_objects = (Id.t * Libobject.t) list (** {6 Object iteration functions. } *) -val open_atomic_objects : int -> Nametab.object_prefix -> lib_atomic_objects -> unit +val open_atomic_objects : Libobject.open_filter + -> int -> Nametab.object_prefix -> lib_atomic_objects -> unit val load_atomic_objects : int -> Nametab.object_prefix -> lib_atomic_objects -> unit val subst_atomic_objects : Mod_subst.substitution -> lib_atomic_objects -> lib_atomic_objects (*val load_and_subst_objects : int -> Libnames.Nametab.object_prefix -> Mod_subst.substitution -> lib_objects -> lib_objects*) diff --git a/library/libobject.ml b/library/libobject.ml index 0681e12449..c38e0d891b 100644 --- a/library/libobject.ml +++ b/library/libobject.ml @@ -18,11 +18,36 @@ type 'a substitutivity = type object_name = Libnames.full_path * Names.KerName.t +module NSet = Globnames.ExtRefSet + +type open_filter = + | Unfiltered + | Names of NSet.t + +let simple_open f filter i o = match filter with + | Unfiltered -> f i o + | Names _ -> () + +let filter_and f1 f2 = match f1, f2 with + | Unfiltered, f | f, Unfiltered -> Some f + | Names n1, Names n2 -> + let n = NSet.inter n1 n2 in + if NSet.is_empty n then None + else Some (Names n) + +let filter_or f1 f2 = match f1, f2 with + | Unfiltered, f | f, Unfiltered -> Unfiltered + | Names n1, Names n2 -> Names (NSet.union n1 n2) + +let in_filter_ref gr = function + | Unfiltered -> true + | Names ns -> NSet.mem (Globnames.TrueGlobal gr) ns + type 'a object_declaration = { object_name : string; cache_function : object_name * 'a -> unit; load_function : int -> object_name * 'a -> unit; - open_function : int -> object_name * 'a -> unit; + open_function : open_filter -> int -> object_name * 'a -> unit; classify_function : 'a -> 'a substitutivity; subst_function : Mod_subst.substitution * 'a -> 'a; discharge_function : object_name * 'a -> 'a option; @@ -32,7 +57,7 @@ let default_object s = { object_name = s; cache_function = (fun _ -> ()); load_function = (fun _ _ -> ()); - open_function = (fun _ _ -> ()); + open_function = (fun _ _ _ -> ()); subst_function = (fun _ -> CErrors.anomaly (str "The object " ++ str s ++ str " does not know how to substitute!")); classify_function = (fun atomic_obj -> Keep atomic_obj); @@ -75,7 +100,7 @@ and t = | ModuleTypeObject of substitutive_objects | IncludeObject of algebraic_objects | KeepObject of objects - | ExportObject of { mpl : ModPath.t list } + | ExportObject of { mpl : (open_filter * ModPath.t) list } | AtomicObject of obj and objects = (Names.Id.t * t) list @@ -105,9 +130,9 @@ let load_object i (sp, Dyn.Dyn (tag, v)) = let decl = DynMap.find tag !cache_tab in decl.load_function i (sp, v) -let open_object i (sp, Dyn.Dyn (tag, v)) = +let open_object f i (sp, Dyn.Dyn (tag, v)) = let decl = DynMap.find tag !cache_tab in - decl.open_function i (sp, v) + decl.open_function f i (sp, v) let subst_object (subs, Dyn.Dyn (tag, v)) = let decl = DynMap.find tag !cache_tab in @@ -147,7 +172,7 @@ let global_object_nodischarge s ~cache ~subst = let import i o = if Int.equal i 1 then cache o in { (default_object s) with cache_function = cache; - open_function = import; + open_function = simple_open import; subst_function = (match subst with | None -> fun _ -> CErrors.anomaly (str "The object " ++ str s ++ str " does not know how to substitute!") | Some subst -> subst; diff --git a/library/libobject.mli b/library/libobject.mli index 24cadc2223..1c82349bb6 100644 --- a/library/libobject.mli +++ b/library/libobject.mli @@ -72,16 +72,28 @@ type 'a substitutivity = type object_name = full_path * Names.KerName.t +type open_filter = Unfiltered | Names of Globnames.ExtRefSet.t + type 'a object_declaration = { object_name : string; cache_function : object_name * 'a -> unit; load_function : int -> object_name * 'a -> unit; - open_function : int -> object_name * 'a -> unit; + open_function : open_filter -> int -> object_name * 'a -> unit; classify_function : 'a -> 'a substitutivity; subst_function : substitution * 'a -> 'a; discharge_function : object_name * 'a -> 'a option; rebuild_function : 'a -> 'a } +val simple_open : (int -> object_name * 'a -> unit) -> open_filter -> int -> object_name * 'a -> unit +(** Combinator for making objects which are only opened by unfiltered Import *) + +val filter_and : open_filter -> open_filter -> open_filter option +(** Returns [None] when the intersection is empty. *) + +val filter_or : open_filter -> open_filter -> open_filter + +val in_filter_ref : Names.GlobRef.t -> open_filter -> bool + (** The default object is a "Keep" object with empty methods. Object creators are advised to use the construction [{(default_object "MY_OBJECT") with @@ -114,7 +126,7 @@ and t = | ModuleTypeObject of substitutive_objects | IncludeObject of algebraic_objects | KeepObject of objects - | ExportObject of { mpl : Names.ModPath.t list } + | ExportObject of { mpl : (open_filter * Names.ModPath.t) list } | AtomicObject of obj and objects = (Names.Id.t * t) list @@ -129,7 +141,7 @@ val declare_object : val cache_object : object_name * obj -> unit val load_object : int -> object_name * obj -> unit -val open_object : int -> object_name * obj -> unit +val open_object : open_filter -> int -> object_name * obj -> unit val subst_object : substitution * obj -> obj val classify_object : obj -> obj substitutivity val discharge_object : object_name * obj -> obj option diff --git a/library/nametab.ml b/library/nametab.ml index 523fe8af50..d9b4dc9122 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -352,10 +352,8 @@ let the_univtab = Summary.ref ~name:"univtab" (UnivTab.empty : univtab) (* Reversed name tables ***************************************************) (* This table translates extended_global_references back to section paths *) -module Globrevtab = HMap.Make(ExtRefOrdered) - -type globrevtab = full_path Globrevtab.t -let the_globrevtab = Summary.ref ~name:"globrevtab" (Globrevtab.empty : globrevtab) +type globrevtab = full_path ExtRefMap.t +let the_globrevtab = Summary.ref ~name:"globrevtab" (ExtRefMap.empty : globrevtab) type mprevtab = DirPath.t MPmap.t @@ -386,7 +384,7 @@ let push_xref visibility sp xref = match visibility with | Until _ -> the_ccitab := ExtRefTab.push visibility sp xref !the_ccitab; - the_globrevtab := Globrevtab.add xref sp !the_globrevtab + the_globrevtab := ExtRefMap.add xref sp !the_globrevtab | _ -> begin if ExtRefTab.exists sp !the_ccitab then @@ -520,7 +518,7 @@ let path_of_global ref = let open GlobRef in match ref with | VarRef id -> make_path DirPath.empty id - | _ -> Globrevtab.find (TrueGlobal ref) !the_globrevtab + | _ -> ExtRefMap.find (TrueGlobal ref) !the_globrevtab let dirpath_of_global ref = fst (repr_path (path_of_global ref)) @@ -529,7 +527,7 @@ let basename_of_global ref = snd (repr_path (path_of_global ref)) let path_of_syndef kn = - Globrevtab.find (SynDef kn) !the_globrevtab + ExtRefMap.find (SynDef kn) !the_globrevtab let dirpath_of_module mp = MPmap.find mp !the_modrevtab @@ -547,7 +545,7 @@ let shortest_qualid_of_global ?loc ctx ref = match ref with | VarRef id -> make_qualid ?loc DirPath.empty id | _ -> - let sp = Globrevtab.find (TrueGlobal ref) !the_globrevtab in + let sp = ExtRefMap.find (TrueGlobal ref) !the_globrevtab in ExtRefTab.shortest_qualid ?loc ctx sp !the_ccitab let shortest_qualid_of_syndef ?loc ctx kn = diff --git a/man/coqide.1 b/man/coqide.1 index 62a102af03..c1af046019 100644 --- a/man/coqide.1 +++ b/man/coqide.1 @@ -69,7 +69,7 @@ Load Coq library (Require .IR path .). .TP -.BI \-require\ path +.BI \-require-import\ path Load Coq library .IR path and import it (Require Import diff --git a/man/coqtop.1 b/man/coqtop.1 index 25d0ef7718..e799bc7748 100644 --- a/man/coqtop.1 +++ b/man/coqtop.1 @@ -79,7 +79,7 @@ load Coq library (Require path.) .TP -.BI \-require \ path +.BI \-require-import \ path load Coq library .I path and import it (Require Import path.) diff --git a/plugins/btauto/plugin_base.dune b/plugins/btauto/dune index 6a024358c3..d2f5b65980 100644 --- a/plugins/btauto/plugin_base.dune +++ b/plugins/btauto/dune @@ -3,3 +3,5 @@ (public_name coq.plugins.btauto) (synopsis "Coq's btauto plugin") (libraries coq.plugins.ltac)) + +(coq.pp (modules g_btauto)) diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 74043d6bc8..6f5c910297 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -25,19 +25,14 @@ open Util let init_size=5 -let cc_verbose=ref false +let cc_verbose= + declare_bool_option_and_ref + ~depr:false + ~key:["Congruence";"Verbose"] + ~value:false let debug x = - if !cc_verbose then Feedback.msg_debug (x ()) - -let () = - let gdopt= - { optdepr=false; - optkey=["Congruence";"Verbose"]; - optread=(fun ()-> !cc_verbose); - optwrite=(fun b -> cc_verbose := b)} - in - declare_bool_option gdopt + if cc_verbose () then Feedback.msg_debug (x ()) (* Signature table *) diff --git a/plugins/cc/plugin_base.dune b/plugins/cc/dune index 2a92996d2a..f7fa3adb56 100644 --- a/plugins/cc/plugin_base.dune +++ b/plugins/cc/dune @@ -3,3 +3,5 @@ (public_name coq.plugins.cc) (synopsis "Coq's congruence closure plugin") (libraries coq.plugins.ltac)) + +(coq.pp (modules g_congruence)) diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index dca69f06ca..f09b35a6d1 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -42,6 +42,6 @@ let start_deriving f suchthat name : Lemmas.t = let info = Lemmas.Info.make ~proof_ending:(Lemmas.Proof_ending.(End_derive {f; name})) ~kind () in let lemma = Lemmas.start_dependent_lemma ~name ~poly ~info goals in - Lemmas.pf_map (Proof_global.map_proof begin fun p -> + Lemmas.pf_map (Declare.Proof.map_proof begin fun p -> Util.pi1 @@ Proof.run_tactic env Proofview.(tclFOCUS 1 2 shelve) p end) lemma diff --git a/plugins/derive/plugin_base.dune b/plugins/derive/dune index ba9cd595ce..1931339471 100644 --- a/plugins/derive/plugin_base.dune +++ b/plugins/derive/dune @@ -3,3 +3,5 @@ (public_name coq.plugins.derive) (synopsis "Coq's derive plugin") (libraries coq.plugins.ltac)) + +(coq.pp (modules g_derive)) diff --git a/plugins/extraction/plugin_base.dune b/plugins/extraction/dune index 037b0d5053..0c01dcd488 100644 --- a/plugins/extraction/plugin_base.dune +++ b/plugins/extraction/dune @@ -3,3 +3,5 @@ (public_name coq.plugins.extraction) (synopsis "Coq's extraction plugin") (libraries num coq.plugins.ltac)) + +(coq.pp (modules g_extraction)) diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 3a90d24c97..f7d78551d8 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -163,7 +163,8 @@ let expand_mexpr env mpo me = let expand_modtype env mp me = let inl = Some (Flags.get_inline_level()) in - Mod_typing.translate_modtype env mp inl ([],me) + let mtb, _cst = Mod_typing.translate_modtype env mp inl ([],me) in + mtb let no_delta = Mod_subst.empty_delta_resolver @@ -728,13 +729,13 @@ let extract_and_compile l = (* Show the extraction of the current ongoing proof *) let show_extraction ~pstate = init ~inner:true false false; - let prf = Proof_global.get_proof pstate in - let sigma, env = Pfedit.get_current_context pstate in + let prf = Declare.Proof.get_proof pstate in + let sigma, env = Declare.get_current_context pstate in let trms = Proof.partial_proof prf in let extr_term t = let ast, ty = extract_constr env sigma t in let mp = Lib.current_mp () in - let l = Label.of_id (Proof_global.get_proof_name pstate) in + let l = Label.of_id (Declare.Proof.get_proof_name pstate) in let fake_ref = GlobRef.ConstRef (Constant.make2 mp l) in let decl = Dterm (fake_ref, ast, ty) in print_one_decl [] mp decl diff --git a/plugins/extraction/extract_env.mli b/plugins/extraction/extract_env.mli index edbc1f5ea7..06cc475200 100644 --- a/plugins/extraction/extract_env.mli +++ b/plugins/extraction/extract_env.mli @@ -40,4 +40,4 @@ val structure_for_compute : (* Show the extraction of the current ongoing proof *) -val show_extraction : pstate:Proof_global.t -> unit +val show_extraction : pstate:Declare.Proof.t -> unit diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index a53c2395f0..f8449bcda1 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -498,16 +498,8 @@ let info_file f = (* The objects defined below should survive an arbitrary time, so we register them to coq save/undo mechanism. *) -let my_bool_option name initval = - let flag = ref initval in - let access = fun () -> !flag in - let () = declare_bool_option - {optdepr = false; - optkey = ["Extraction"; name]; - optread = access; - optwrite = (:=) flag } - in - access +let my_bool_option name value = + declare_bool_option_and_ref ~depr:false ~key:["Extraction"; name] ~value (*s Extraction AccessOpaque *) @@ -588,25 +580,18 @@ let () = declare_int_option (* This option controls whether "dummy lambda" are removed when a toplevel constant is defined. *) -let conservative_types_ref = ref false -let conservative_types () = !conservative_types_ref - -let () = declare_bool_option - {optdepr = false; - optkey = ["Extraction"; "Conservative"; "Types"]; - optread = (fun () -> !conservative_types_ref); - optwrite = (fun b -> conservative_types_ref := b) } - +let conservative_types = + declare_bool_option_and_ref + ~depr:false + ~key:["Extraction"; "Conservative"; "Types"] + ~value:false (* Allows to print a comment at the beginning of the output files *) -let file_comment_ref = ref "" -let file_comment () = !file_comment_ref - -let () = declare_string_option - {optdepr = false; - optkey = ["Extraction"; "File"; "Comment"]; - optread = (fun () -> !file_comment_ref); - optwrite = (fun s -> file_comment_ref := s) } +let file_comment = + declare_string_option_and_ref + ~depr:false + ~key:["Extraction"; "File"; "Comment"] + ~value:"" (*s Extraction Lang *) diff --git a/plugins/firstorder/plugin_base.dune b/plugins/firstorder/dune index d88daa23fc..1b05452d8f 100644 --- a/plugins/firstorder/plugin_base.dune +++ b/plugins/firstorder/dune @@ -3,3 +3,5 @@ (public_name coq.plugins.firstorder) (synopsis "Coq's first order logic solver plugin") (libraries coq.plugins.ltac)) + +(coq.pp (modules g_ground)) diff --git a/plugins/firstorder/g_ground.mlg b/plugins/firstorder/g_ground.mlg index 49e4c91182..6ddc6ba21e 100644 --- a/plugins/firstorder/g_ground.mlg +++ b/plugins/firstorder/g_ground.mlg @@ -31,20 +31,8 @@ DECLARE PLUGIN "ground_plugin" { -let ground_depth=ref 3 - -let ()= - let gdopt= - { optdepr=false; - optkey=["Firstorder";"Depth"]; - optread=(fun ()->Some !ground_depth); - optwrite= - (function - None->ground_depth:=3 - | Some i->ground_depth:=(max i 0))} - in - declare_int_option gdopt - +let ground_depth = + declare_nat_option_and_ref ~depr:false ~key:["Firstorder";"Depth"] ~value:3 let default_intuition_tac = let tac _ _ = Auto.h_auto None [] (Some []) in @@ -85,7 +73,7 @@ let gen_ground_tac flag taco ids bases = | None-> snd (default_solver ()) in let startseq k = Proofview.Goal.enter begin fun gl -> - let seq=empty_seq !ground_depth in + let seq=empty_seq (ground_depth ()) in let seq, sigma = extend_with_ref_list (pf_env gl) (project gl) ids seq in let seq, sigma = extend_with_auto_hints (pf_env gl) sigma bases seq in tclTHEN (Proofview.Unsafe.tclEVARS sigma) (k seq) diff --git a/plugins/funind/.ocamlformat b/plugins/funind/.ocamlformat new file mode 100644 index 0000000000..a22a2ff88c --- /dev/null +++ b/plugins/funind/.ocamlformat @@ -0,0 +1 @@ +disable=false diff --git a/plugins/funind/plugin_base.dune b/plugins/funind/dune index 6ccf15df29..e594ffbd02 100644 --- a/plugins/funind/plugin_base.dune +++ b/plugins/funind/dune @@ -3,3 +3,5 @@ (public_name coq.plugins.funind) (synopsis "Coq's functional induction plugin") (libraries coq.plugins.extraction)) + +(coq.pp (modules g_indfun)) diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 9749af1e66..7b2ce671a3 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -15,280 +15,265 @@ open Tactics open Indfun_common open Libnames open Context.Rel.Declaration - module RelDecl = Context.Rel.Declaration -let list_chop ?(msg="") n l = - try - List.chop n l - with Failure (msg') -> - failwith (msg ^ msg') +let list_chop ?(msg = "") n l = + try List.chop n l with Failure msg' -> failwith (msg ^ msg') let pop t = Vars.lift (-1) t -let make_refl_eq constructor type_of_t t = -(* let refl_equal_term = Lazy.force refl_equal in *) - mkApp(constructor,[|type_of_t;t|]) - +let make_refl_eq constructor type_of_t t = + (* let refl_equal_term = Lazy.force refl_equal in *) + mkApp (constructor, [|type_of_t; t|]) type pte_info = - { - proving_tac : (Id.t list -> Tacmach.tactic); - is_valid : constr -> bool - } + {proving_tac : Id.t list -> Tacmach.tactic; is_valid : constr -> bool} type ptes_info = pte_info Id.Map.t type 'a dynamic_info = - { - nb_rec_hyps : int; - rec_hyps : Id.t list ; - eq_hyps : Id.t list; - info : 'a - } + {nb_rec_hyps : int; rec_hyps : Id.t list; eq_hyps : Id.t list; info : 'a} type body_info = constr dynamic_info let observe_tac s = observe_tac (fun _ _ -> Pp.str s) let finish_proof dynamic_infos g = - observe_tac "finish" - (Proofview.V82.of_tactic assumption) - g - + observe_tac "finish" (Proofview.V82.of_tactic assumption) g let refine c = Refiner.refiner ~check:true EConstr.Unsafe.(to_constr c) - let thin l = Proofview.V82.of_tactic (Tactics.clear l) - let eq_constr sigma u v = EConstr.eq_constr_nounivs sigma u v let is_trivial_eq sigma t = - let res = try - begin + let res = + try match EConstr.kind sigma t with - | App(f,[|_;t1;t2|]) when eq_constr sigma f (Lazy.force eq) -> - eq_constr sigma t1 t2 - | App(f,[|t1;a1;t2;a2|]) when eq_constr sigma f (jmeq ()) -> - eq_constr sigma t1 t2 && eq_constr sigma a1 a2 - | _ -> false - end - with e when CErrors.noncritical e -> false + | App (f, [|_; t1; t2|]) when eq_constr sigma f (Lazy.force eq) -> + eq_constr sigma t1 t2 + | App (f, [|t1; a1; t2; a2|]) when eq_constr sigma f (jmeq ()) -> + eq_constr sigma t1 t2 && eq_constr sigma a1 a2 + | _ -> false + with e when CErrors.noncritical e -> false in -(* observe (str "is_trivial_eq " ++ Printer.pr_lconstr t ++ (if res then str " true" else str " false")); *) + (* observe (str "is_trivial_eq " ++ Printer.pr_lconstr t ++ (if res then str " true" else str " false")); *) res let rec incompatible_constructor_terms sigma t1 t2 = - let c1,arg1 = decompose_app sigma t1 - and c2,arg2 = decompose_app sigma t2 - in - (not (eq_constr sigma t1 t2)) && - isConstruct sigma c1 && isConstruct sigma c2 && - ( - not (eq_constr sigma c1 c2) || - List.exists2 (incompatible_constructor_terms sigma) arg1 arg2 - ) + let c1, arg1 = decompose_app sigma t1 and c2, arg2 = decompose_app sigma t2 in + (not (eq_constr sigma t1 t2)) + && isConstruct sigma c1 && isConstruct sigma c2 + && ( (not (eq_constr sigma c1 c2)) + || List.exists2 (incompatible_constructor_terms sigma) arg1 arg2 ) let is_incompatible_eq env sigma t = let res = try match EConstr.kind sigma t with - | App(f,[|_;t1;t2|]) when eq_constr sigma f (Lazy.force eq) -> - incompatible_constructor_terms sigma t1 t2 - | App(f,[|u1;t1;u2;t2|]) when eq_constr sigma f (jmeq ()) -> - (eq_constr sigma u1 u2 && - incompatible_constructor_terms sigma t1 t2) - | _ -> false + | App (f, [|_; t1; t2|]) when eq_constr sigma f (Lazy.force eq) -> + incompatible_constructor_terms sigma t1 t2 + | App (f, [|u1; t1; u2; t2|]) when eq_constr sigma f (jmeq ()) -> + eq_constr sigma u1 u2 && incompatible_constructor_terms sigma t1 t2 + | _ -> false with e when CErrors.noncritical e -> false in if res then observe (str "is_incompatible_eq " ++ pr_leconstr_env env sigma t); res let change_hyp_with_using msg hyp_id t tac : tactic = - fun g -> - let prov_id = pf_get_new_id hyp_id g in - tclTHENS - ((* observe_tac msg *) Proofview.V82.of_tactic (assert_by (Name prov_id) t (Proofview.V82.tactic (tclCOMPLETE tac)))) - [tclTHENLIST - [ - (* observe_tac "change_hyp_with_using thin" *) (thin [hyp_id]); - (* observe_tac "change_hyp_with_using rename " *) (Proofview.V82.of_tactic (rename_hyp [prov_id,hyp_id])) - ]] g + fun g -> + let prov_id = pf_get_new_id hyp_id g in + tclTHENS + ((* observe_tac msg *) Proofview.V82.of_tactic + (assert_by (Name prov_id) t (Proofview.V82.tactic (tclCOMPLETE tac)))) + [ tclTHENLIST + [ (* observe_tac "change_hyp_with_using thin" *) + thin [hyp_id] + ; (* observe_tac "change_hyp_with_using rename " *) + Proofview.V82.of_tactic (rename_hyp [(prov_id, hyp_id)]) ] ] + g exception TOREMOVE - -let prove_trivial_eq h_id context (constructor,type_of_term,term) = +let prove_trivial_eq h_id context (constructor, type_of_term, term) = let nb_intros = List.length context in tclTHENLIST - [ - tclDO nb_intros (Proofview.V82.of_tactic intro); (* introducing context *) + [ tclDO nb_intros (Proofview.V82.of_tactic intro) + ; (* introducing context *) (fun g -> - let context_hyps = - fst (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g)) - in - let context_hyps' = - (mkApp(constructor,[|type_of_term;term|])):: - (List.map mkVar context_hyps) - in - let to_refine = applist(mkVar h_id,List.rev context_hyps') in - refine to_refine g - ) - ] - - + let context_hyps = + fst + (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g)) + in + let context_hyps' = + mkApp (constructor, [|type_of_term; term|]) + :: List.map mkVar context_hyps + in + let to_refine = applist (mkVar h_id, List.rev context_hyps') in + refine to_refine g) ] let find_rectype env sigma c = - let (t, l) = decompose_app sigma (Reductionops.whd_betaiotazeta sigma c) in + let t, l = decompose_app sigma (Reductionops.whd_betaiotazeta sigma c) in match EConstr.kind sigma t with | Ind ind -> (t, l) - | Construct _ -> (t,l) + | Construct _ -> (t, l) | _ -> raise Not_found - -let isAppConstruct ?(env=Global.env ()) sigma t = +let isAppConstruct ?(env = Global.env ()) sigma t = try - let t',l = find_rectype env sigma t in - observe (str "isAppConstruct : " ++ Printer.pr_leconstr_env env sigma t ++ str " -> " ++ - Printer.pr_leconstr_env env sigma (applist (t',l))); + let t', l = find_rectype env sigma t in + observe + ( str "isAppConstruct : " + ++ Printer.pr_leconstr_env env sigma t + ++ str " -> " + ++ Printer.pr_leconstr_env env sigma (applist (t', l)) ); true with Not_found -> false exception NoChange -let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = - let nochange ?t' msg = - begin - observe (str ("Not treating ( "^msg^" )") ++ pr_leconstr_env env sigma t ++ str " " ++ - match t' with None -> str "" | Some t -> Printer.pr_leconstr_env env sigma t ); - raise NoChange; - end +let change_eq env sigma hyp_id (context : rel_context) x t end_of_type = + let nochange ?t' msg = + observe + ( str ("Not treating ( " ^ msg ^ " )") + ++ pr_leconstr_env env sigma t + ++ str " " + ++ + match t' with + | None -> str "" + | Some t -> Printer.pr_leconstr_env env sigma t ); + raise NoChange in let eq_constr c1 c2 = - try ignore(Evarconv.unify_delay env sigma c1 c2); true - with Evarconv.UnableToUnify _ -> false in - if not (noccurn sigma 1 end_of_type) - then nochange "dependent"; (* if end_of_type depends on this term we don't touch it *) - if not (isApp sigma t) then nochange "not an equality"; - let f_eq,args = destApp sigma t in - let constructor,t1,t2,t1_typ = + try + ignore (Evarconv.unify_delay env sigma c1 c2); + true + with Evarconv.UnableToUnify _ -> false + in + if not (noccurn sigma 1 end_of_type) then nochange "dependent"; + (* if end_of_type depends on this term we don't touch it *) + if not (isApp sigma t) then nochange "not an equality"; + let f_eq, args = destApp sigma t in + let constructor, t1, t2, t1_typ = + try + if eq_constr f_eq (Lazy.force eq) then + let t1 = (args.(1), args.(0)) + and t2 = (args.(2), args.(0)) + and t1_typ = args.(0) in + (Lazy.force refl_equal, t1, t2, t1_typ) + else if eq_constr f_eq (jmeq ()) then + (jmeq_refl (), (args.(1), args.(0)), (args.(3), args.(2)), args.(0)) + else nochange "not an equality" + with e when CErrors.noncritical e -> nochange "not an equality" + in + if not (closed0 sigma (fst t1) && closed0 sigma (snd t1)) then + nochange "not a closed lhs"; + let rec compute_substitution sub t1 t2 = + (* observe (str "compute_substitution : " ++ pr_lconstr t1 ++ str " === " ++ pr_lconstr t2); *) + if isRel sigma t2 then ( + let t2 = destRel sigma t2 in try - if (eq_constr f_eq (Lazy.force eq)) - then - let t1 = (args.(1),args.(0)) - and t2 = (args.(2),args.(0)) - and t1_typ = args.(0) - in - (Lazy.force refl_equal,t1,t2,t1_typ) - else - if (eq_constr f_eq (jmeq ())) - then - (jmeq_refl (),(args.(1),args.(0)),(args.(3),args.(2)),args.(0)) - else nochange "not an equality" - with e when CErrors.noncritical e -> nochange "not an equality" - in - if not ((closed0 sigma (fst t1)) && (closed0 sigma (snd t1)))then nochange "not a closed lhs"; - let rec compute_substitution sub t1 t2 = -(* observe (str "compute_substitution : " ++ pr_lconstr t1 ++ str " === " ++ pr_lconstr t2); *) - if isRel sigma t2 - then - let t2 = destRel sigma t2 in - begin - try - let t1' = Int.Map.find t2 sub in - if not (eq_constr t1 t1') then nochange "twice bound variable"; - sub - with Not_found -> - assert (closed0 sigma t1); - Int.Map.add t2 t1 sub - end - else if isAppConstruct sigma t1 && isAppConstruct sigma t2 - then - begin - let c1,args1 = find_rectype env sigma t1 - and c2,args2 = find_rectype env sigma t2 - in - if not (eq_constr c1 c2) then nochange "cannot solve (diff)"; - List.fold_left2 compute_substitution sub args1 args2 - end - else - if (eq_constr t1 t2) then sub else nochange ~t':(make_refl_eq constructor (Reductionops.whd_all env sigma t1) t2) "cannot solve (diff)" - in - let sub = compute_substitution Int.Map.empty (snd t1) (snd t2) in - let sub = compute_substitution sub (fst t1) (fst t2) in - let end_of_type_with_pop = pop end_of_type in (*the equation will be removed *) - let new_end_of_type = - (* Ugly hack to prevent Map.fold order change between ocaml-3.08.3 and ocaml-3.08.4 - Can be safely replaced by the next comment for Ocaml >= 3.08.4 - *) - let sub = Int.Map.bindings sub in - List.fold_left (fun end_of_type (i,t) -> liftn 1 i (substnl [t] (i-1) end_of_type)) - end_of_type_with_pop + let t1' = Int.Map.find t2 sub in + if not (eq_constr t1 t1') then nochange "twice bound variable"; sub - in - let old_context_length = List.length context + 1 in - let witness_fun = - mkLetIn(make_annot Anonymous Sorts.Relevant,make_refl_eq constructor t1_typ (fst t1),t, - mkApp(mkVar hyp_id,Array.init old_context_length (fun i -> mkRel (old_context_length - i))) - ) - in - let new_type_of_hyp,ctxt_size,witness_fun = - List.fold_left_i - (fun i (end_of_type,ctxt_size,witness_fun) decl -> - try - let witness = Int.Map.find i sub in - if is_local_def decl then anomaly (Pp.str "can not redefine a rel!"); - (pop end_of_type,ctxt_size,mkLetIn (RelDecl.get_annot decl, - witness, RelDecl.get_type decl, witness_fun)) - with Not_found -> - (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun) - ) - 1 - (new_end_of_type,0,witness_fun) - context - in - let new_type_of_hyp = - Reductionops.nf_betaiota env sigma new_type_of_hyp in - let new_ctxt,new_end_of_type = - decompose_prod_n_assum sigma ctxt_size new_type_of_hyp - in - let prove_new_hyp : tactic = - tclTHEN - (tclDO ctxt_size (Proofview.V82.of_tactic intro)) - (fun g -> - let all_ids = pf_ids_of_hyps g in - let new_ids,_ = list_chop ctxt_size all_ids in - let to_refine = applist(witness_fun,List.rev_map mkVar new_ids) in - let evm, _ = pf_apply Typing.type_of g to_refine in - tclTHEN (Refiner.tclEVARS evm) (refine to_refine) g - ) - in - let simpl_eq_tac = - change_hyp_with_using "prove_pattern_simplification" hyp_id new_type_of_hyp prove_new_hyp - in -(* observe (str "In " ++ Ppconstr.pr_id hyp_id ++ *) -(* str "removing an equation " ++ fnl ()++ *) -(* str "old_typ_of_hyp :=" ++ *) -(* Printer.pr_lconstr_env *) -(* env *) -(* (it_mkProd_or_LetIn ~init:end_of_type ((x,None,t)::context)) *) -(* ++ fnl () ++ *) -(* str "new_typ_of_hyp := "++ *) -(* Printer.pr_lconstr_env env new_type_of_hyp ++ fnl () *) -(* ++ str "old context := " ++ pr_rel_context env context ++ fnl () *) -(* ++ str "new context := " ++ pr_rel_context env new_ctxt ++ fnl () *) -(* ++ str "old type := " ++ pr_lconstr end_of_type ++ fnl () *) -(* ++ str "new type := " ++ pr_lconstr new_end_of_type ++ fnl () *) -(* ); *) - new_ctxt,new_end_of_type,simpl_eq_tac - - -let is_property sigma (ptes_info:ptes_info) t_x full_type_of_hyp = - if isApp sigma t_x - then - let pte,args = destApp sigma t_x in - if isVar sigma pte && Array.for_all (closed0 sigma) args - then + with Not_found -> + assert (closed0 sigma t1); + Int.Map.add t2 t1 sub ) + else if isAppConstruct sigma t1 && isAppConstruct sigma t2 then begin + let c1, args1 = find_rectype env sigma t1 + and c2, args2 = find_rectype env sigma t2 in + if not (eq_constr c1 c2) then nochange "cannot solve (diff)"; + List.fold_left2 compute_substitution sub args1 args2 + end + else if eq_constr t1 t2 then sub + else + nochange + ~t':(make_refl_eq constructor (Reductionops.whd_all env sigma t1) t2) + "cannot solve (diff)" + in + let sub = compute_substitution Int.Map.empty (snd t1) (snd t2) in + let sub = compute_substitution sub (fst t1) (fst t2) in + let end_of_type_with_pop = pop end_of_type in + (*the equation will be removed *) + let new_end_of_type = + (* Ugly hack to prevent Map.fold order change between ocaml-3.08.3 and ocaml-3.08.4 + Can be safely replaced by the next comment for Ocaml >= 3.08.4 + *) + let sub = Int.Map.bindings sub in + List.fold_left + (fun end_of_type (i, t) -> liftn 1 i (substnl [t] (i - 1) end_of_type)) + end_of_type_with_pop sub + in + let old_context_length = List.length context + 1 in + let witness_fun = + mkLetIn + ( make_annot Anonymous Sorts.Relevant + , make_refl_eq constructor t1_typ (fst t1) + , t + , mkApp + ( mkVar hyp_id + , Array.init old_context_length (fun i -> + mkRel (old_context_length - i)) ) ) + in + let new_type_of_hyp, ctxt_size, witness_fun = + List.fold_left_i + (fun i (end_of_type, ctxt_size, witness_fun) decl -> + try + let witness = Int.Map.find i sub in + if is_local_def decl then anomaly (Pp.str "can not redefine a rel!"); + ( pop end_of_type + , ctxt_size + , mkLetIn + ( RelDecl.get_annot decl + , witness + , RelDecl.get_type decl + , witness_fun ) ) + with Not_found -> + ( mkProd_or_LetIn decl end_of_type + , ctxt_size + 1 + , mkLambda_or_LetIn decl witness_fun )) + 1 + (new_end_of_type, 0, witness_fun) + context + in + let new_type_of_hyp = Reductionops.nf_betaiota env sigma new_type_of_hyp in + let new_ctxt, new_end_of_type = + decompose_prod_n_assum sigma ctxt_size new_type_of_hyp + in + let prove_new_hyp : tactic = + tclTHEN + (tclDO ctxt_size (Proofview.V82.of_tactic intro)) + (fun g -> + let all_ids = pf_ids_of_hyps g in + let new_ids, _ = list_chop ctxt_size all_ids in + let to_refine = applist (witness_fun, List.rev_map mkVar new_ids) in + let evm, _ = pf_apply Typing.type_of g to_refine in + tclTHEN (Refiner.tclEVARS evm) (refine to_refine) g) + in + let simpl_eq_tac = + change_hyp_with_using "prove_pattern_simplification" hyp_id new_type_of_hyp + prove_new_hyp + in + (* observe (str "In " ++ Ppconstr.pr_id hyp_id ++ *) + (* str "removing an equation " ++ fnl ()++ *) + (* str "old_typ_of_hyp :=" ++ *) + (* Printer.pr_lconstr_env *) + (* env *) + (* (it_mkProd_or_LetIn ~init:end_of_type ((x,None,t)::context)) *) + (* ++ fnl () ++ *) + (* str "new_typ_of_hyp := "++ *) + (* Printer.pr_lconstr_env env new_type_of_hyp ++ fnl () *) + (* ++ str "old context := " ++ pr_rel_context env context ++ fnl () *) + (* ++ str "new context := " ++ pr_rel_context env new_ctxt ++ fnl () *) + (* ++ str "old type := " ++ pr_lconstr end_of_type ++ fnl () *) + (* ++ str "new type := " ++ pr_lconstr new_end_of_type ++ fnl () *) + (* ); *) + (new_ctxt, new_end_of_type, simpl_eq_tac) + +let is_property sigma (ptes_info : ptes_info) t_x full_type_of_hyp = + if isApp sigma t_x then + let pte, args = destApp sigma t_x in + if isVar sigma pte && Array.for_all (closed0 sigma) args then try let info = Id.Map.find (destVar sigma pte) ptes_info in info.is_valid full_type_of_hyp @@ -297,19 +282,13 @@ let is_property sigma (ptes_info:ptes_info) t_x full_type_of_hyp = else false let isLetIn sigma t = - match EConstr.kind sigma t with - | LetIn _ -> true - | _ -> false - + match EConstr.kind sigma t with LetIn _ -> true | _ -> false let h_reduce_with_zeta cl = - Proofview.V82.of_tactic (reduce - (Genredexpr.Cbv - {Redops.all_flags - with Genredexpr.rDelta = false; - }) cl) - - + Proofview.V82.of_tactic + (reduce + (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false}) + cl) let rewrite_until_var arg_num eq_ids : tactic = (* tests if the declares recursive argument is neither a Constructor nor @@ -318,268 +297,247 @@ let rewrite_until_var arg_num eq_ids : tactic = *) let test_var g = let sigma = project g in - let _,args = destApp sigma (pf_concl g) in - not ((isConstruct sigma args.(arg_num)) || isAppConstruct sigma args.(arg_num)) + let _, args = destApp sigma (pf_concl g) in + not (isConstruct sigma args.(arg_num) || isAppConstruct sigma args.(arg_num)) in - let rec do_rewrite eq_ids g = - if test_var g - then tclIDTAC g + let rec do_rewrite eq_ids g = + if test_var g then tclIDTAC g else match eq_ids with - | [] -> anomaly (Pp.str "Cannot find a way to prove recursive property."); - | eq_id::eq_ids -> - tclTHEN - (tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar eq_id)))) - (do_rewrite eq_ids) - g + | [] -> anomaly (Pp.str "Cannot find a way to prove recursive property.") + | eq_id :: eq_ids -> + tclTHEN + (tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar eq_id)))) + (do_rewrite eq_ids) g in do_rewrite eq_ids - let rec_pte_id = Id.of_string "Hrec" + let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = - let coq_False = EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.False.type") in - let coq_True = EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.True.type") in - let coq_I = EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.True.I") in - let rec scan_type context type_of_hyp : tactic = + let coq_False = + EConstr.of_constr + (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.False.type") + in + let coq_True = + EConstr.of_constr + (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.True.type") + in + let coq_I = + EConstr.of_constr + (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.True.I") + in + let rec scan_type context type_of_hyp : tactic = if isLetIn sigma type_of_hyp then let real_type_of_hyp = it_mkProd_or_LetIn type_of_hyp context in - let reduced_type_of_hyp = Reductionops.nf_betaiotazeta env sigma real_type_of_hyp in + let reduced_type_of_hyp = + Reductionops.nf_betaiotazeta env sigma real_type_of_hyp + in (* length of context didn't change ? *) - let new_context,new_typ_of_hyp = - decompose_prod_n_assum sigma (List.length context) reduced_type_of_hyp + let new_context, new_typ_of_hyp = + decompose_prod_n_assum sigma (List.length context) reduced_type_of_hyp in + tclTHENLIST + [ h_reduce_with_zeta (Locusops.onHyp hyp_id) + ; scan_type new_context new_typ_of_hyp ] + else if isProd sigma type_of_hyp then + let x, t_x, t' = destProd sigma type_of_hyp in + let actual_real_type_of_hyp = it_mkProd_or_LetIn t' context in + if is_property sigma ptes_infos t_x actual_real_type_of_hyp then + let pte, pte_args = destApp sigma t_x in + let (* fix_info *) prove_rec_hyp = + (Id.Map.find (destVar sigma pte) ptes_infos).proving_tac + in + let popped_t' = pop t' in + let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in + let prove_new_type_of_hyp = + let context_length = List.length context in + tclTHENLIST + [ tclDO context_length (Proofview.V82.of_tactic intro) + ; (fun g -> + let context_hyps_ids = + fst + (list_chop ~msg:"rec hyp : context_hyps" context_length + (pf_ids_of_hyps g)) + in + let rec_pte_id = pf_get_new_id rec_pte_id g in + let to_refine = + applist + ( mkVar hyp_id + , List.rev_map mkVar (rec_pte_id :: context_hyps_ids) ) + in + (* observe_tac "rec hyp " *) + (tclTHENS + (Proofview.V82.of_tactic + (assert_before (Name rec_pte_id) t_x)) + [ (* observe_tac "prove rec hyp" *) + prove_rec_hyp eq_hyps + ; (* observe_tac "prove rec hyp" *) + refine to_refine ]) + g) ] + in tclTHENLIST - [ h_reduce_with_zeta (Locusops.onHyp hyp_id); - scan_type new_context new_typ_of_hyp ] - else if isProd sigma type_of_hyp - then - begin - let (x,t_x,t') = destProd sigma type_of_hyp in - let actual_real_type_of_hyp = it_mkProd_or_LetIn t' context in - if is_property sigma ptes_infos t_x actual_real_type_of_hyp then - begin - let pte,pte_args = (destApp sigma t_x) in - let (* fix_info *) prove_rec_hyp = (Id.Map.find (destVar sigma pte) ptes_infos).proving_tac in - let popped_t' = pop t' in - let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in - let prove_new_type_of_hyp = - let context_length = List.length context in - tclTHENLIST - [ - tclDO context_length (Proofview.V82.of_tactic intro); - (fun g -> - let context_hyps_ids = - fst (list_chop ~msg:"rec hyp : context_hyps" - context_length (pf_ids_of_hyps g)) - in - let rec_pte_id = pf_get_new_id rec_pte_id g in - let to_refine = - applist(mkVar hyp_id, - List.rev_map mkVar (rec_pte_id::context_hyps_ids) - ) - in -(* observe_tac "rec hyp " *) - (tclTHENS - (Proofview.V82.of_tactic (assert_before (Name rec_pte_id) t_x)) - [ - (* observe_tac "prove rec hyp" *) (prove_rec_hyp eq_hyps); -(* observe_tac "prove rec hyp" *) - (refine to_refine) - ]) - g - ) - ] - in - tclTHENLIST - [ -(* observe_tac "hyp rec" *) - (change_hyp_with_using "rec_hyp_tac" hyp_id real_type_of_hyp prove_new_type_of_hyp); - scan_type context popped_t' - ] - end - else if eq_constr sigma t_x coq_False then - begin -(* observe (str "Removing : "++ Ppconstr.pr_id hyp_id++ *) -(* str " since it has False in its preconds " *) -(* ); *) - raise TOREMOVE; (* False -> .. useless *) - end - else if is_incompatible_eq env sigma t_x then raise TOREMOVE (* t_x := C1 ... = C2 ... *) - else if eq_constr sigma t_x coq_True (* Trivial => we remove this precons *) - then -(* observe (str "In "++Ppconstr.pr_id hyp_id++ *) -(* str " removing useless precond True" *) -(* ); *) - let popped_t' = pop t' in - let real_type_of_hyp = - it_mkProd_or_LetIn popped_t' context - in - let prove_trivial = - let nb_intro = List.length context in - tclTHENLIST [ - tclDO nb_intro (Proofview.V82.of_tactic intro); - (fun g -> - let context_hyps = - fst (list_chop ~msg:"removing True : context_hyps "nb_intro (pf_ids_of_hyps g)) - in - let to_refine = - applist (mkVar hyp_id, - List.rev (coq_I::List.map mkVar context_hyps) - ) - in - refine to_refine g - ) - ] - in - tclTHENLIST[ - change_hyp_with_using "prove_trivial" hyp_id real_type_of_hyp - ((* observe_tac "prove_trivial" *) prove_trivial); - scan_type context popped_t' - ] - else if is_trivial_eq sigma t_x - then (* t_x := t = t => we remove this precond *) - let popped_t' = pop t' in - let real_type_of_hyp = - it_mkProd_or_LetIn popped_t' context - in - let hd,args = destApp sigma t_x in - let get_args hd args = - if eq_constr sigma hd (Lazy.force eq) - then (Lazy.force refl_equal,args.(0),args.(1)) - else (jmeq_refl (),args.(0),args.(1)) - in + [ (* observe_tac "hyp rec" *) + change_hyp_with_using "rec_hyp_tac" hyp_id real_type_of_hyp + prove_new_type_of_hyp + ; scan_type context popped_t' ] + else if eq_constr sigma t_x coq_False then + (* observe (str "Removing : "++ Ppconstr.pr_id hyp_id++ *) + (* str " since it has False in its preconds " *) + (* ); *) + raise TOREMOVE (* False -> .. useless *) + else if is_incompatible_eq env sigma t_x then raise TOREMOVE + (* t_x := C1 ... = C2 ... *) + else if + eq_constr sigma t_x coq_True (* Trivial => we remove this precons *) + then + (* observe (str "In "++Ppconstr.pr_id hyp_id++ *) + (* str " removing useless precond True" *) + (* ); *) + let popped_t' = pop t' in + let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in + let prove_trivial = + let nb_intro = List.length context in tclTHENLIST - [ - change_hyp_with_using - "prove_trivial_eq" - hyp_id - real_type_of_hyp - ((* observe_tac "prove_trivial_eq" *) - (prove_trivial_eq hyp_id context (get_args hd args))); - scan_type context popped_t' - ] - else - begin - try - let new_context,new_t',tac = change_eq env sigma hyp_id context x t_x t' in - tclTHEN - tac - (scan_type new_context new_t') - with NoChange -> - (* Last thing todo : push the rel in the context and continue *) - scan_type (LocalAssum (x,t_x) :: context) t' - end - end - else - tclIDTAC - in - try - scan_type [] (Typing.type_of_variable env hyp_id), [hyp_id] - with TOREMOVE -> - thin [hyp_id],[] - - -let clean_goal_with_heq ptes_infos continue_tac (dyn_infos:body_info) = - fun g -> - let env = pf_env g - and sigma = project g - in - let tac,new_hyps = - List.fold_left ( - fun (hyps_tac,new_hyps) hyp_id -> - let hyp_tac,new_hyp = - clean_hyp_with_heq ptes_infos dyn_infos.eq_hyps hyp_id env sigma + [ tclDO nb_intro (Proofview.V82.of_tactic intro) + ; (fun g -> + let context_hyps = + fst + (list_chop ~msg:"removing True : context_hyps " nb_intro + (pf_ids_of_hyps g)) + in + let to_refine = + applist + ( mkVar hyp_id + , List.rev (coq_I :: List.map mkVar context_hyps) ) + in + refine to_refine g) ] + in + tclTHENLIST + [ change_hyp_with_using "prove_trivial" hyp_id real_type_of_hyp + (* observe_tac "prove_trivial" *) prove_trivial + ; scan_type context popped_t' ] + else if is_trivial_eq sigma t_x then + (* t_x := t = t => we remove this precond *) + let popped_t' = pop t' in + let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in + let hd, args = destApp sigma t_x in + let get_args hd args = + if eq_constr sigma hd (Lazy.force eq) then + (Lazy.force refl_equal, args.(0), args.(1)) + else (jmeq_refl (), args.(0), args.(1)) + in + tclTHENLIST + [ change_hyp_with_using "prove_trivial_eq" hyp_id real_type_of_hyp + ((* observe_tac "prove_trivial_eq" *) + prove_trivial_eq hyp_id context (get_args hd args)) + ; scan_type context popped_t' ] + else + try + let new_context, new_t', tac = + change_eq env sigma hyp_id context x t_x t' in - (tclTHEN hyp_tac hyps_tac),new_hyp@new_hyps - ) - (tclIDTAC,[]) - dyn_infos.rec_hyps - in - let new_infos = - { dyn_infos with - rec_hyps = new_hyps; - nb_rec_hyps = List.length new_hyps - } - in - tclTHENLIST - [ - tac ; - (* observe_tac "clean_hyp_with_heq continue" *) (continue_tac new_infos) - ] - g + tclTHEN tac (scan_type new_context new_t') + with NoChange -> + (* Last thing todo : push the rel in the context and continue *) + scan_type (LocalAssum (x, t_x) :: context) t' + else tclIDTAC + in + try (scan_type [] (Typing.type_of_variable env hyp_id), [hyp_id]) + with TOREMOVE -> (thin [hyp_id], []) + +let clean_goal_with_heq ptes_infos continue_tac (dyn_infos : body_info) g = + let env = pf_env g and sigma = project g in + let tac, new_hyps = + List.fold_left + (fun (hyps_tac, new_hyps) hyp_id -> + let hyp_tac, new_hyp = + clean_hyp_with_heq ptes_infos dyn_infos.eq_hyps hyp_id env sigma + in + (tclTHEN hyp_tac hyps_tac, new_hyp @ new_hyps)) + (tclIDTAC, []) dyn_infos.rec_hyps + in + let new_infos = + {dyn_infos with rec_hyps = new_hyps; nb_rec_hyps = List.length new_hyps} + in + tclTHENLIST + [tac; (* observe_tac "clean_hyp_with_heq continue" *) continue_tac new_infos] + g let heq_id = Id.of_string "Heq" -let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = - fun g -> - let nb_first_intro = nb_prod - 1 - dyn_infos.nb_rec_hyps in - tclTHENLIST - [ - (* We first introduce the variables *) - tclDO nb_first_intro (Proofview.V82.of_tactic (intro_avoiding (Id.Set.of_list dyn_infos.rec_hyps))); - (* Then the equation itself *) - Proofview.V82.of_tactic (intro_using heq_id); - onLastHypId (fun heq_id -> tclTHENLIST [ - (* Then the new hypothesis *) - tclMAP (fun id -> Proofview.V82.of_tactic (introduction id)) dyn_infos.rec_hyps; - observe_tac "after_introduction" (fun g' -> - (* We get infos on the equations introduced*) - let new_term_value_eq = pf_get_hyp_typ g' heq_id in - (* compute the new value of the body *) - let new_term_value = - match EConstr.kind (project g') new_term_value_eq with - | App(f,[| _;_;args2 |]) -> args2 - | _ -> - observe (str "cannot compute new term value : " ++ pr_gls g' ++ fnl () ++ str "last hyp is" ++ - pr_leconstr_env (pf_env g') (project g') new_term_value_eq - ); - anomaly (Pp.str "cannot compute new term value.") - in - let g', termtyp = tac_type_of g' term in - let fun_body = - mkLambda(make_annot Anonymous Sorts.Relevant, - termtyp, - Termops.replace_term (project g') term (mkRel 1) dyn_infos.info - ) - in - let new_body = pf_nf_betaiota g' (mkApp(fun_body,[| new_term_value |])) in - let new_infos = - {dyn_infos with - info = new_body; - eq_hyps = heq_id::dyn_infos.eq_hyps - } - in - clean_goal_with_heq ptes_infos continue_tac new_infos g' - )]) - ] - g - +let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos g = + let nb_first_intro = nb_prod - 1 - dyn_infos.nb_rec_hyps in + tclTHENLIST + [ (* We first introduce the variables *) + tclDO nb_first_intro + (Proofview.V82.of_tactic + (intro_avoiding (Id.Set.of_list dyn_infos.rec_hyps))) + ; (* Then the equation itself *) + Proofview.V82.of_tactic (intro_using heq_id) + ; onLastHypId (fun heq_id -> + tclTHENLIST + [ (* Then the new hypothesis *) + tclMAP + (fun id -> Proofview.V82.of_tactic (introduction id)) + dyn_infos.rec_hyps + ; observe_tac "after_introduction" (fun g' -> + (* We get infos on the equations introduced*) + let new_term_value_eq = pf_get_hyp_typ g' heq_id in + (* compute the new value of the body *) + let new_term_value = + match EConstr.kind (project g') new_term_value_eq with + | App (f, [|_; _; args2|]) -> args2 + | _ -> + observe + ( str "cannot compute new term value : " + ++ pr_gls g' ++ fnl () ++ str "last hyp is" + ++ pr_leconstr_env (pf_env g') (project g') + new_term_value_eq ); + anomaly (Pp.str "cannot compute new term value.") + in + let g', termtyp = tac_type_of g' term in + let fun_body = + mkLambda + ( make_annot Anonymous Sorts.Relevant + , termtyp + , Termops.replace_term (project g') term (mkRel 1) + dyn_infos.info ) + in + let new_body = + pf_nf_betaiota g' (mkApp (fun_body, [|new_term_value|])) + in + let new_infos = + { dyn_infos with + info = new_body + ; eq_hyps = heq_id :: dyn_infos.eq_hyps } + in + clean_goal_with_heq ptes_infos continue_tac new_infos g') ]) + ] + g let my_orelse tac1 tac2 g = - try - tac1 g + try tac1 g with e when CErrors.noncritical e -> -(* observe (str "using snd tac since : " ++ CErrors.print e); *) + (* observe (str "using snd tac since : " ++ CErrors.print e); *) tac2 g -let instantiate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id = - let args = Array.of_list (List.map mkVar args_id) in +let instantiate_hyps_with_args (do_prove : Id.t list -> tactic) hyps args_id = + let args = Array.of_list (List.map mkVar args_id) in let instantiate_one_hyp hid = my_orelse - ( (* we instantiate the hyp if possible *) - fun g -> - let prov_hid = pf_get_new_id hid g in - let c = mkApp(mkVar hid,args) in - let evm, _ = pf_apply Typing.type_of g c in - tclTHENLIST[ - Refiner.tclEVARS evm; - Proofview.V82.of_tactic (pose_proof (Name prov_hid) c); - thin [hid]; - Proofview.V82.of_tactic (rename_hyp [prov_hid,hid]) - ] g - ) - ( (* + (fun (* we instantiate the hyp if possible *) + g -> + let prov_hid = pf_get_new_id hid g in + let c = mkApp (mkVar hid, args) in + let evm, _ = pf_apply Typing.type_of g c in + tclTHENLIST + [ Refiner.tclEVARS evm + ; Proofview.V82.of_tactic (pose_proof (Name prov_hid) c) + ; thin [hid] + ; Proofview.V82.of_tactic (rename_hyp [(prov_hid, hid)]) ] + g) + (fun (* if not then we are in a mutual function block and this hyp is a recursive hyp on an other function. @@ -587,350 +545,314 @@ let instantiate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id = principle so that we can trash it *) - (fun g -> -(* observe (str "Instantiation: removing hyp " ++ Ppconstr.pr_id hid); *) - thin [hid] g - ) - ) + g -> + (* observe (str "Instantiation: removing hyp " ++ Ppconstr.pr_id hid); *) + thin [hid] g) in - if List.is_empty args_id - then - tclTHENLIST [ - tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) hyps; - do_prove hyps - ] + if List.is_empty args_id then + tclTHENLIST + [ tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) hyps + ; do_prove hyps ] else tclTHENLIST - [ - tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) hyps; - tclMAP instantiate_one_hyp hyps; - (fun g -> - let all_g_hyps_id = - List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty - in - let remaining_hyps = - List.filter (fun id -> Id.Set.mem id all_g_hyps_id) hyps - in - do_prove remaining_hyps g - ) - ] + [ tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) hyps + ; tclMAP instantiate_one_hyp hyps + ; (fun g -> + let all_g_hyps_id = + List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty + in + let remaining_hyps = + List.filter (fun id -> Id.Set.mem id all_g_hyps_id) hyps + in + do_prove remaining_hyps g) ] -let build_proof - (interactive_proof:bool) - (fnames:Constant.t list) - ptes_infos - dyn_infos - : tactic = +let build_proof (interactive_proof : bool) (fnames : Constant.t list) ptes_infos + dyn_infos : tactic = let rec build_proof_aux do_finalize dyn_infos : tactic = - fun g -> - let env = pf_env g in - let sigma = project g in -(* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*) - match EConstr.kind sigma dyn_infos.info with - | Case(ci,ct,t,cb) -> - let do_finalize_t dyn_info' = - fun g -> - let t = dyn_info'.info in - let dyn_infos = {dyn_info' with info = - mkCase(ci,ct,t,cb)} in - let g_nb_prod = nb_prod (project g) (pf_concl g) in - let g, type_of_term = tac_type_of g t in - let term_eq = - make_refl_eq (Lazy.force refl_equal) type_of_term t - in - tclTHENLIST - [ - Proofview.V82.of_tactic (generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps))); - thin dyn_infos.rec_hyps; - Proofview.V82.of_tactic (pattern_option [Locus.AllOccurrencesBut [1],t] None); - (fun g -> observe_tac "toto" ( - tclTHENLIST [Proofview.V82.of_tactic (Simple.case t); - (fun g' -> - let g'_nb_prod = nb_prod (project g') (pf_concl g') in - let nb_instantiate_partial = g'_nb_prod - g_nb_prod in - observe_tac "treat_new_case" - (treat_new_case - ptes_infos - nb_instantiate_partial - (build_proof do_finalize) - t - dyn_infos) - g' - ) - - ]) g - ) - ] - g - in - build_proof do_finalize_t {dyn_infos with info = t} g - | Lambda(n,t,b) -> - begin - match EConstr.kind sigma (pf_concl g) with - | Prod _ -> - tclTHEN - (Proofview.V82.of_tactic intro) - (fun g' -> - let open Context.Named.Declaration in - let id = pf_last_hyp g' |> get_id in - let new_term = - pf_nf_betaiota g' - (mkApp(dyn_infos.info,[|mkVar id|])) - in - let new_infos = {dyn_infos with info = new_term} in - let do_prove new_hyps = - build_proof do_finalize - {new_infos with - rec_hyps = new_hyps; - nb_rec_hyps = List.length new_hyps - } - in -(* observe_tac "Lambda" *) (instantiate_hyps_with_args do_prove new_infos.rec_hyps [id]) g' - (* build_proof do_finalize new_infos g' *) - ) g - | _ -> - do_finalize dyn_infos g - end - | Cast(t,_,_) -> - build_proof do_finalize {dyn_infos with info = t} g - | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ | Float _ -> - do_finalize dyn_infos g - | App(_,_) -> - let f,args = decompose_app sigma dyn_infos.info in - begin - match EConstr.kind sigma f with - | Int _ -> user_err Pp.(str "integer cannot be applied") - | Float _ -> user_err Pp.(str "float cannot be applied") - | App _ -> assert false (* we have collected all the app in decompose_app *) - | Proj _ -> assert false (*FIXME*) - | Var _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ | Prod _ -> - let new_infos = - { dyn_infos with - info = (f,args) - } - in - build_proof_args env sigma do_finalize new_infos g - | Const (c,_) when not (List.mem_f Constant.equal c fnames) -> - let new_infos = - { dyn_infos with - info = (f,args) - } - in -(* Pp.msgnl (str "proving in " ++ pr_lconstr_env (pf_env g) dyn_infos.info); *) - build_proof_args env sigma do_finalize new_infos g - | Const _ -> - do_finalize dyn_infos g - | Lambda _ -> - let new_term = - Reductionops.nf_beta env sigma dyn_infos.info in - build_proof do_finalize {dyn_infos with info = new_term} - g - | LetIn _ -> - let new_infos = - { dyn_infos with info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info } - in - - tclTHENLIST - [tclMAP - (fun hyp_id -> - h_reduce_with_zeta (Locusops.onHyp hyp_id)) - dyn_infos.rec_hyps; - h_reduce_with_zeta Locusops.onConcl; - build_proof do_finalize new_infos - ] - g - | Cast(b,_,_) -> - build_proof do_finalize {dyn_infos with info = b } g - | Case _ | Fix _ | CoFix _ -> - let new_finalize dyn_infos = - let new_infos = - { dyn_infos with - info = dyn_infos.info,args - } - in - build_proof_args env sigma do_finalize new_infos - in - build_proof new_finalize {dyn_infos with info = f } g - end - | Fix _ | CoFix _ -> - user_err Pp.(str ( "Anonymous local (co)fixpoints are not handled yet")) - - - | Proj _ -> user_err Pp.(str "Prod") - | Prod _ -> do_finalize dyn_infos g - | LetIn _ -> - let new_infos = - { dyn_infos with - info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info - } - in - - tclTHENLIST - [tclMAP - (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) - dyn_infos.rec_hyps; - h_reduce_with_zeta Locusops.onConcl; - build_proof do_finalize new_infos - ] g - | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") - and build_proof do_finalize dyn_infos g = -(* observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *) - Indfun_common.observe_tac (fun env sigma -> - str "build_proof with " ++ pr_leconstr_env env sigma dyn_infos.info ) (build_proof_aux do_finalize dyn_infos) g - and build_proof_args env sigma do_finalize dyn_infos (* f_args' args *) :tactic = - fun g -> - let (f_args',args) = dyn_infos.info in - let tac : tactic = - fun g -> - match args with - | [] -> - do_finalize {dyn_infos with info = f_args'} g - | arg::args -> - (* observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *) - (* fnl () ++ *) - (* pr_goal (Tacmach.sig_it g) *) - (* ); *) - let do_finalize dyn_infos = - let new_arg = dyn_infos.info in - (* tclTRYD *) - (build_proof_args env sigma - do_finalize - {dyn_infos with info = (mkApp(f_args',[|new_arg|])), args} - ) - in + fun g -> + let env = pf_env g in + let sigma = project g in + (* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*) + match EConstr.kind sigma dyn_infos.info with + | Case (ci, ct, t, cb) -> + let do_finalize_t dyn_info' g = + let t = dyn_info'.info in + let dyn_infos = {dyn_info' with info = mkCase (ci, ct, t, cb)} in + let g_nb_prod = nb_prod (project g) (pf_concl g) in + let g, type_of_term = tac_type_of g t in + let term_eq = make_refl_eq (Lazy.force refl_equal) type_of_term t in + tclTHENLIST + [ Proofview.V82.of_tactic + (generalize (term_eq :: List.map mkVar dyn_infos.rec_hyps)) + ; thin dyn_infos.rec_hyps + ; Proofview.V82.of_tactic + (pattern_option [(Locus.AllOccurrencesBut [1], t)] None) + ; (fun g -> + observe_tac "toto" + (tclTHENLIST + [ Proofview.V82.of_tactic (Simple.case t) + ; (fun g' -> + let g'_nb_prod = nb_prod (project g') (pf_concl g') in + let nb_instantiate_partial = g'_nb_prod - g_nb_prod in + observe_tac "treat_new_case" + (treat_new_case ptes_infos nb_instantiate_partial + (build_proof do_finalize) t dyn_infos) + g') ]) + g) ] + g + in + build_proof do_finalize_t {dyn_infos with info = t} g + | Lambda (n, t, b) -> ( + match EConstr.kind sigma (pf_concl g) with + | Prod _ -> + tclTHEN + (Proofview.V82.of_tactic intro) + (fun g' -> + let open Context.Named.Declaration in + let id = pf_last_hyp g' |> get_id in + let new_term = + pf_nf_betaiota g' (mkApp (dyn_infos.info, [|mkVar id|])) + in + let new_infos = {dyn_infos with info = new_term} in + let do_prove new_hyps = build_proof do_finalize - {dyn_infos with info = arg } - g + { new_infos with + rec_hyps = new_hyps + ; nb_rec_hyps = List.length new_hyps } + in + (* observe_tac "Lambda" *) + (instantiate_hyps_with_args do_prove new_infos.rec_hyps [id]) g' + (* build_proof do_finalize new_infos g' *)) + g + | _ -> do_finalize dyn_infos g ) + | Cast (t, _, _) -> build_proof do_finalize {dyn_infos with info = t} g + | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ + |Float _ -> + do_finalize dyn_infos g + | App (_, _) -> ( + let f, args = decompose_app sigma dyn_infos.info in + match EConstr.kind sigma f with + | Int _ -> user_err Pp.(str "integer cannot be applied") + | Float _ -> user_err Pp.(str "float cannot be applied") + | App _ -> + assert false (* we have collected all the app in decompose_app *) + | Proj _ -> assert false (*FIXME*) + | Var _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ | Prod _ + -> + let new_infos = {dyn_infos with info = (f, args)} in + build_proof_args env sigma do_finalize new_infos g + | Const (c, _) when not (List.mem_f Constant.equal c fnames) -> + let new_infos = {dyn_infos with info = (f, args)} in + (* Pp.msgnl (str "proving in " ++ pr_lconstr_env (pf_env g) dyn_infos.info); *) + build_proof_args env sigma do_finalize new_infos g + | Const _ -> do_finalize dyn_infos g + | Lambda _ -> + let new_term = Reductionops.nf_beta env sigma dyn_infos.info in + build_proof do_finalize {dyn_infos with info = new_term} g + | LetIn _ -> + let new_infos = + { dyn_infos with + info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info } + in + tclTHENLIST + [ tclMAP + (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) + dyn_infos.rec_hyps + ; h_reduce_with_zeta Locusops.onConcl + ; build_proof do_finalize new_infos ] + g + | Cast (b, _, _) -> build_proof do_finalize {dyn_infos with info = b} g + | Case _ | Fix _ | CoFix _ -> + let new_finalize dyn_infos = + let new_infos = {dyn_infos with info = (dyn_infos.info, args)} in + build_proof_args env sigma do_finalize new_infos + in + build_proof new_finalize {dyn_infos with info = f} g ) + | Fix _ | CoFix _ -> + user_err Pp.(str "Anonymous local (co)fixpoints are not handled yet") + | Proj _ -> user_err Pp.(str "Prod") + | Prod _ -> do_finalize dyn_infos g + | LetIn _ -> + let new_infos = + { dyn_infos with + info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info } in - (* observe_tac "build_proof_args" *) (tac ) g + tclTHENLIST + [ tclMAP + (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) + dyn_infos.rec_hyps + ; h_reduce_with_zeta Locusops.onConcl + ; build_proof do_finalize new_infos ] + g + | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") + and build_proof do_finalize dyn_infos g = + (* observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *) + Indfun_common.observe_tac + (fun env sigma -> + str "build_proof with " ++ pr_leconstr_env env sigma dyn_infos.info) + (build_proof_aux do_finalize dyn_infos) + g + and build_proof_args env sigma do_finalize dyn_infos : tactic = + (* f_args' args *) + fun g -> + let f_args', args = dyn_infos.info in + let tac : tactic = + fun g -> + match args with + | [] -> do_finalize {dyn_infos with info = f_args'} g + | arg :: args -> + (* observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *) + (* fnl () ++ *) + (* pr_goal (Tacmach.sig_it g) *) + (* ); *) + let do_finalize dyn_infos = + let new_arg = dyn_infos.info in + (* tclTRYD *) + build_proof_args env sigma do_finalize + {dyn_infos with info = (mkApp (f_args', [|new_arg|]), args)} + in + build_proof do_finalize {dyn_infos with info = arg} g + in + (* observe_tac "build_proof_args" *) tac g in let do_finish_proof dyn_infos = - (* tclTRYD *) (clean_goal_with_heq - ptes_infos - finish_proof dyn_infos) + (* tclTRYD *) clean_goal_with_heq ptes_infos finish_proof dyn_infos in - (* observe_tac "build_proof" *) + (* observe_tac "build_proof" *) fun g -> build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos g - (* Proof of principles from structural functions *) type static_fix_info = - { - idx : int; - name : Id.t; - types : types; - offset : int; - nb_realargs : int; - body_with_param : constr; - num_in_block : int - } - - - -let prove_rec_hyp_for_struct fix_info = - (fun eq_hyps -> tclTHEN - (rewrite_until_var (fix_info.idx) eq_hyps) - (fun g -> - let _,pte_args = destApp (project g) (pf_concl g) in - let rec_hyp_proof = - mkApp(mkVar fix_info.name,array_get_start pte_args) - in - refine rec_hyp_proof g - )) + { idx : int + ; name : Id.t + ; types : types + ; offset : int + ; nb_realargs : int + ; body_with_param : constr + ; num_in_block : int } + +let prove_rec_hyp_for_struct fix_info eq_hyps = + tclTHEN (rewrite_until_var fix_info.idx eq_hyps) (fun g -> + let _, pte_args = destApp (project g) (pf_concl g) in + let rec_hyp_proof = + mkApp (mkVar fix_info.name, array_get_start pte_args) + in + refine rec_hyp_proof g) -let prove_rec_hyp fix_info = - { proving_tac = prove_rec_hyp_for_struct fix_info - ; - is_valid = fun _ -> true - } +let prove_rec_hyp fix_info = + {proving_tac = prove_rec_hyp_for_struct fix_info; is_valid = (fun _ -> true)} let generalize_non_dep hyp g = -(* observe (str "rec id := " ++ Ppconstr.pr_id hyp); *) + (* observe (str "rec id := " ++ Ppconstr.pr_id hyp); *) let hyps = [hyp] in let env = Global.env () in let hyp_typ = pf_get_hyp_typ g hyp in - let to_revert,_ = + let to_revert, _ = let open Context.Named.Declaration in - Environ.fold_named_context_reverse (fun (clear,keep) decl -> - let decl = map_named_decl EConstr.of_constr decl in - let hyp = get_id decl in - if Id.List.mem hyp hyps - || List.exists (Termops.occur_var_in_decl env (project g) hyp) keep - || Termops.occur_var env (project g) hyp hyp_typ - || Termops.is_section_variable hyp (* should be dangerous *) - then (clear,decl::keep) - else (hyp::clear,keep)) - ~init:([],[]) (pf_env g) + Environ.fold_named_context_reverse + (fun (clear, keep) decl -> + let decl = map_named_decl EConstr.of_constr decl in + let hyp = get_id decl in + if + Id.List.mem hyp hyps + || List.exists (Termops.occur_var_in_decl env (project g) hyp) keep + || Termops.occur_var env (project g) hyp hyp_typ + || Termops.is_section_variable hyp + (* should be dangerous *) + then (clear, decl :: keep) + else (hyp :: clear, keep)) + ~init:([], []) (pf_env g) in -(* observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *) + (* observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *) tclTHEN - ((* observe_tac "h_generalize" *) (Proofview.V82.of_tactic (generalize (List.map mkVar to_revert) ))) - ((* observe_tac "thin" *) (thin to_revert)) + ((* observe_tac "h_generalize" *) Proofview.V82.of_tactic + (generalize (List.map mkVar to_revert))) + ((* observe_tac "thin" *) thin to_revert) g let id_of_decl = RelDecl.get_name %> Nameops.Name.get_id let var_of_decl = id_of_decl %> mkVar + let revert idl = - tclTHEN - (Proofview.V82.of_tactic (generalize (List.map mkVar idl))) - (thin idl) + tclTHEN (Proofview.V82.of_tactic (generalize (List.map mkVar idl))) (thin idl) -let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num = -(* observe (str "nb_args := " ++ str (string_of_int nb_args)); *) -(* observe (str "nb_params := " ++ str (string_of_int nb_params)); *) -(* observe (str "rec_args_num := " ++ str (string_of_int (rec_args_num + 1) )); *) +let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num + = + (* observe (str "nb_args := " ++ str (string_of_int nb_args)); *) + (* observe (str "nb_params := " ++ str (string_of_int nb_params)); *) + (* observe (str "rec_args_num := " ++ str (string_of_int (rec_args_num + 1) )); *) let f_def = Global.lookup_constant (fst (destConst evd f)) in - let eq_lhs = mkApp(f,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i))) in - let (f_body, _, _) = Option.get (Global.body_of_constant_body Library.indirect_accessor f_def) in + let eq_lhs = + mkApp + ( f + , Array.init (nb_params + nb_args) (fun i -> + mkRel (nb_params + nb_args - i)) ) + in + let f_body, _, _ = + Option.get (Global.body_of_constant_body Library.indirect_accessor f_def) + in let f_body = EConstr.of_constr f_body in - let params,f_body_with_params = decompose_lam_n evd nb_params f_body in - let (_,num),(_,_,bodies) = destFix evd f_body_with_params in + let params, f_body_with_params = decompose_lam_n evd nb_params f_body in + let (_, num), (_, _, bodies) = destFix evd f_body_with_params in let fnames_with_params = - let params = Array.init nb_params (fun i -> mkRel(nb_params - i)) in - let fnames = List.rev (Array.to_list (Array.map (fun f -> mkApp(f,params)) fnames)) in + let params = Array.init nb_params (fun i -> mkRel (nb_params - i)) in + let fnames = + List.rev (Array.to_list (Array.map (fun f -> mkApp (f, params)) fnames)) + in fnames in -(* observe (str "fnames_with_params " ++ prlist_with_sep fnl pr_lconstr fnames_with_params); *) -(* observe (str "body " ++ pr_lconstr bodies.(num)); *) - let f_body_with_params_and_other_fun = substl fnames_with_params bodies.(num) in -(* observe (str "f_body_with_params_and_other_fun " ++ pr_lconstr f_body_with_params_and_other_fun); *) - let eq_rhs = Reductionops.nf_betaiotazeta (Global.env ()) evd (mkApp(compose_lam params f_body_with_params_and_other_fun,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i)))) in + (* observe (str "fnames_with_params " ++ prlist_with_sep fnl pr_lconstr fnames_with_params); *) + (* observe (str "body " ++ pr_lconstr bodies.(num)); *) + let f_body_with_params_and_other_fun = + substl fnames_with_params bodies.(num) + in + (* observe (str "f_body_with_params_and_other_fun " ++ pr_lconstr f_body_with_params_and_other_fun); *) + let eq_rhs = + Reductionops.nf_betaiotazeta (Global.env ()) evd + (mkApp + ( compose_lam params f_body_with_params_and_other_fun + , Array.init (nb_params + nb_args) (fun i -> + mkRel (nb_params + nb_args - i)) )) + in (* observe (str "eq_rhs " ++ pr_lconstr eq_rhs); *) - let (type_ctxt,type_of_f),evd = - let evd,t = Typing.type_of ~refresh:true (Global.env ()) evd f - in - decompose_prod_n_assum evd - (nb_params + nb_args) t,evd + let (type_ctxt, type_of_f), evd = + let evd, t = Typing.type_of ~refresh:true (Global.env ()) evd f in + (decompose_prod_n_assum evd (nb_params + nb_args) t, evd) in - let eqn = mkApp(Lazy.force eq,[|type_of_f;eq_lhs;eq_rhs|]) in + let eqn = mkApp (Lazy.force eq, [|type_of_f; eq_lhs; eq_rhs|]) in let lemma_type = it_mkProd_or_LetIn eqn type_ctxt in (* Pp.msgnl (str "lemma type " ++ Printer.pr_lconstr lemma_type ++ fnl () ++ str "f_body " ++ Printer.pr_lconstr f_body); *) let f_id = Label.to_id (Constant.label (fst (destConst evd f))) in let prove_replacement = tclTHENLIST - [ - tclDO (nb_params + rec_args_num + 1) (Proofview.V82.of_tactic intro); - observe_tac "" (fun g -> - let rec_id = pf_nth_hyp_id g 1 in - tclTHENLIST - [observe_tac "generalize_non_dep in generate_equation_lemma" (generalize_non_dep rec_id); - observe_tac "h_case" (Proofview.V82.of_tactic (simplest_case (mkVar rec_id))); - (Proofview.V82.of_tactic intros_reflexivity)] g - ) - ] + [ tclDO (nb_params + rec_args_num + 1) (Proofview.V82.of_tactic intro) + ; observe_tac "" (fun g -> + let rec_id = pf_nth_hyp_id g 1 in + tclTHENLIST + [ observe_tac "generalize_non_dep in generate_equation_lemma" + (generalize_non_dep rec_id) + ; observe_tac "h_case" + (Proofview.V82.of_tactic (simplest_case (mkVar rec_id))) + ; Proofview.V82.of_tactic intros_reflexivity ] + g) ] in (* Pp.msgnl (str "lemma type (2) " ++ Printer.pr_lconstr_env (Global.env ()) evd lemma_type); *) (*i The next call to mk_equation_id is valid since we are constructing the lemma Ensures by: obvious i*) - let lemma = Lemmas.start_lemma ~name:(mk_equation_id f_id) ~poly:false evd lemma_type in - let lemma,_ = Lemmas.by (Proofview.V82.tactic prove_replacement) lemma in - let () = Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Transparent ~idopt:None in + let lemma = + Lemmas.start_lemma ~name:(mk_equation_id f_id) ~poly:false evd lemma_type + in + let lemma, _ = Lemmas.by (Proofview.V82.tactic prove_replacement) lemma in + let () = + Lemmas.save_lemma_proved ~lemma ~opaque:Declare.Transparent ~idopt:None + in evd -let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num all_funs g = +let do_replace (evd : Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num + all_funs g = let equation_lemma = try let finfos = @@ -939,376 +861,366 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a | Some finfos -> finfos in mkConst (Option.get finfos.equation_lemma) - with (Not_found | Option.IsNone as e) -> + with (Not_found | Option.IsNone) as e -> let f_id = Label.to_id (Constant.label (fst (destConst !evd f))) in (*i The next call to mk_equation_id is valid since we will construct the lemma Ensures by: obvious i*) - let equation_lemma_id = (mk_equation_id f_id) in - evd := generate_equation_lemma !evd all_funs f fun_num (List.length params) (List.length rev_args_id) rec_arg_num; + let equation_lemma_id = mk_equation_id f_id in + evd := + generate_equation_lemma !evd all_funs f fun_num (List.length params) + (List.length rev_args_id) rec_arg_num; let _ = match e with - | Option.IsNone -> - let finfos = match find_Function_infos (fst (destConst !evd f)) with - | None -> raise Not_found - | Some finfos -> finfos - in - update_Function - {finfos with - equation_lemma = Some ( - match Nametab.locate (qualid_of_ident equation_lemma_id) with - | GlobRef.ConstRef c -> c - | _ -> CErrors.anomaly (Pp.str "Not a constant.") - ) - } - | _ -> () + | Option.IsNone -> + let finfos = + match find_Function_infos (fst (destConst !evd f)) with + | None -> raise Not_found + | Some finfos -> finfos + in + update_Function + { finfos with + equation_lemma = + Some + ( match Nametab.locate (qualid_of_ident equation_lemma_id) with + | GlobRef.ConstRef c -> c + | _ -> CErrors.anomaly (Pp.str "Not a constant.") ) } + | _ -> () in (* let res = Constrintern.construct_reference (pf_hyps g) equation_lemma_id in *) - let evd',res = - Evd.fresh_global - (Global.env ()) !evd + let evd', res = + Evd.fresh_global (Global.env ()) !evd (Constrintern.locate_reference (qualid_of_ident equation_lemma_id)) in - evd:=evd'; + evd := evd'; let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd res in evd := sigma; res in let nb_intro_to_do = nb_prod (project g) (pf_concl g) in - tclTHEN - (tclDO nb_intro_to_do (Proofview.V82.of_tactic intro)) - ( - fun g' -> - let just_introduced = nLastDecls nb_intro_to_do g' in - let open Context.Named.Declaration in - let just_introduced_id = List.map get_id just_introduced in - tclTHEN (Proofview.V82.of_tactic (Equality.rewriteLR equation_lemma)) - (revert just_introduced_id) g' - ) - g + tclTHEN + (tclDO nb_intro_to_do (Proofview.V82.of_tactic intro)) + (fun g' -> + let just_introduced = nLastDecls nb_intro_to_do g' in + let open Context.Named.Declaration in + let just_introduced_id = List.map get_id just_introduced in + tclTHEN + (Proofview.V82.of_tactic (Equality.rewriteLR equation_lemma)) + (revert just_introduced_id) + g') + g -let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnames all_funs _nparams : tactic = - fun g -> +let prove_princ_for_struct (evd : Evd.evar_map ref) interactive_proof fun_num + fnames all_funs _nparams : tactic = + fun g -> let princ_type = pf_concl g in (* Pp.msgnl (str "princ_type " ++ Printer.pr_lconstr princ_type); *) (* Pp.msgnl (str "all_funs "); *) (* Array.iter (fun c -> Pp.msgnl (Printer.pr_lconstr c)) all_funs; *) - let princ_info = compute_elim_sig (project g) princ_type in - let fresh_id = - let avoid = ref (pf_ids_of_hyps g) in - (fun na -> - let new_id = - match na with - Name id -> fresh_id !avoid (Id.to_string id) - | Anonymous -> fresh_id !avoid "H" - in - avoid := new_id :: !avoid; - (Name new_id) - ) - in - let fresh_decl = RelDecl.map_name fresh_id in - let princ_info : elim_scheme = - { princ_info with - params = List.map fresh_decl princ_info.params; - predicates = List.map fresh_decl princ_info.predicates; - branches = List.map fresh_decl princ_info.branches; - args = List.map fresh_decl princ_info.args - } - in - let get_body const = - match Global.body_of_constant Library.indirect_accessor const with - | Some (body, _, _) -> - let env = Global.env () in - let sigma = Evd.from_env env in - Tacred.cbv_norm_flags - (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) - env - sigma - (EConstr.of_constr body) - | None -> user_err Pp.(str "Cannot define a principle over an axiom ") - in - let fbody = get_body fnames.(fun_num) in - let f_ctxt,f_body = decompose_lam (project g) fbody in - let f_ctxt_length = List.length f_ctxt in - let diff_params = princ_info.nparams - f_ctxt_length in - let full_params,princ_params,fbody_with_full_params = - if diff_params > 0 - then - let princ_params,full_params = - list_chop diff_params princ_info.params - in - (full_params, (* real params *) - princ_params, (* the params of the principle which are not params of the function *) - substl (* function instantiated with real params *) - (List.map var_of_decl full_params) - f_body - ) - else - let f_ctxt_other,f_ctxt_params = - list_chop (- diff_params) f_ctxt in - let f_body = compose_lam f_ctxt_other f_body in - (princ_info.params, (* real params *) - [],(* all params are full params *) - substl (* function instantiated with real params *) - (List.map var_of_decl princ_info.params) - f_body - ) - in - observe (str "full_params := " ++ - prlist_with_sep spc (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) - full_params - ); - observe (str "princ_params := " ++ - prlist_with_sep spc (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) - princ_params - ); - observe (str "fbody_with_full_params := " ++ - pr_leconstr_env (Global.env ()) !evd fbody_with_full_params - ); - let all_funs_with_full_params = - Array.map (fun f -> applist(f, List.rev_map var_of_decl full_params)) all_funs - in - let fix_offset = List.length princ_params in - let ptes_to_fix,infos = - match EConstr.kind (project g) fbody_with_full_params with - | Fix((idxs,i),(names,typess,bodies)) -> - let bodies_with_all_params = - Array.map - (fun body -> - Reductionops.nf_betaiota (pf_env g) (project g) - (applist(substl (List.rev (Array.to_list all_funs_with_full_params)) body, - List.rev_map var_of_decl princ_params)) - ) - bodies + let princ_info = compute_elim_sig (project g) princ_type in + let fresh_id = + let avoid = ref (pf_ids_of_hyps g) in + fun na -> + let new_id = + match na with + | Name id -> fresh_id !avoid (Id.to_string id) + | Anonymous -> fresh_id !avoid "H" + in + avoid := new_id :: !avoid; + Name new_id + in + let fresh_decl = RelDecl.map_name fresh_id in + let princ_info : elim_scheme = + { princ_info with + params = List.map fresh_decl princ_info.params + ; predicates = List.map fresh_decl princ_info.predicates + ; branches = List.map fresh_decl princ_info.branches + ; args = List.map fresh_decl princ_info.args } + in + let get_body const = + match Global.body_of_constant Library.indirect_accessor const with + | Some (body, _, _) -> + let env = Global.env () in + let sigma = Evd.from_env env in + Tacred.cbv_norm_flags + (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) + env sigma (EConstr.of_constr body) + | None -> user_err Pp.(str "Cannot define a principle over an axiom ") + in + let fbody = get_body fnames.(fun_num) in + let f_ctxt, f_body = decompose_lam (project g) fbody in + let f_ctxt_length = List.length f_ctxt in + let diff_params = princ_info.nparams - f_ctxt_length in + let full_params, princ_params, fbody_with_full_params = + if diff_params > 0 then + let princ_params, full_params = list_chop diff_params princ_info.params in + ( full_params + , (* real params *) + princ_params + , (* the params of the principle which are not params of the function *) + substl (* function instantiated with real params *) + (List.map var_of_decl full_params) + f_body ) + else + let f_ctxt_other, f_ctxt_params = list_chop (-diff_params) f_ctxt in + let f_body = compose_lam f_ctxt_other f_body in + ( princ_info.params + , (* real params *) + [] + , (* all params are full params *) + substl (* function instantiated with real params *) + (List.map var_of_decl princ_info.params) + f_body ) + in + observe + ( str "full_params := " + ++ prlist_with_sep spc + (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) + full_params ); + observe + ( str "princ_params := " + ++ prlist_with_sep spc + (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) + princ_params ); + observe + ( str "fbody_with_full_params := " + ++ pr_leconstr_env (Global.env ()) !evd fbody_with_full_params ); + let all_funs_with_full_params = + Array.map + (fun f -> applist (f, List.rev_map var_of_decl full_params)) + all_funs + in + let fix_offset = List.length princ_params in + let ptes_to_fix, infos = + match EConstr.kind (project g) fbody_with_full_params with + | Fix ((idxs, i), (names, typess, bodies)) -> + let bodies_with_all_params = + Array.map + (fun body -> + Reductionops.nf_betaiota (pf_env g) (project g) + (applist + ( substl + (List.rev (Array.to_list all_funs_with_full_params)) + body + , List.rev_map var_of_decl princ_params ))) + bodies + in + let info_array = + Array.mapi + (fun i types -> + let types = + prod_applist (project g) types + (List.rev_map var_of_decl princ_params) in - let info_array = - Array.mapi - (fun i types -> - let types = prod_applist (project g) types (List.rev_map var_of_decl princ_params) in - { idx = idxs.(i) - fix_offset; - name = Nameops.Name.get_id (fresh_id names.(i).binder_name); - types = types; - offset = fix_offset; - nb_realargs = - List.length - (fst (decompose_lam (project g) bodies.(i))) - fix_offset; - body_with_param = bodies_with_all_params.(i); - num_in_block = i - } - ) - typess + { idx = idxs.(i) - fix_offset + ; name = Nameops.Name.get_id (fresh_id names.(i).binder_name) + ; types + ; offset = fix_offset + ; nb_realargs = + List.length (fst (decompose_lam (project g) bodies.(i))) + - fix_offset + ; body_with_param = bodies_with_all_params.(i) + ; num_in_block = i }) + typess + in + let pte_to_fix, rev_info = + List.fold_left_i + (fun i (acc_map, acc_info) decl -> + let pte = RelDecl.get_name decl in + let infos = info_array.(i) in + let type_args, _ = decompose_prod (project g) infos.types in + let nargs = List.length type_args in + let f = + applist + (mkConst fnames.(i), List.rev_map var_of_decl princ_info.params) in - let pte_to_fix,rev_info = - List.fold_left_i - (fun i (acc_map,acc_info) decl -> - let pte = RelDecl.get_name decl in - let infos = info_array.(i) in - let type_args,_ = decompose_prod (project g) infos.types in - let nargs = List.length type_args in - let f = applist(mkConst fnames.(i), List.rev_map var_of_decl princ_info.params) in - let first_args = Array.init nargs (fun i -> mkRel (nargs -i)) in - let app_f = mkApp(f,first_args) in - let pte_args = (Array.to_list first_args)@[app_f] in - let app_pte = applist(mkVar (Nameops.Name.get_id pte),pte_args) in - let body_with_param,num = - let body = get_body fnames.(i) in - let body_with_full_params = - Reductionops.nf_betaiota (pf_env g) (project g) ( - applist(body,List.rev_map var_of_decl full_params)) - in - match EConstr.kind (project g) body_with_full_params with - | Fix((_,num),(_,_,bs)) -> - Reductionops.nf_betaiota (pf_env g) (project g) - ( - (applist - (substl - (List.rev - (Array.to_list all_funs_with_full_params)) - bs.(num), - List.rev_map var_of_decl princ_params)) - ),num - | _ -> user_err Pp.(str "Not a mutual block") - in - let info = - {infos with - types = compose_prod type_args app_pte; - body_with_param = body_with_param; - num_in_block = num - } - in -(* observe (str "binding " ++ Ppconstr.pr_id (Nameops.Name.get_id pte) ++ *) -(* str " to " ++ Ppconstr.pr_id info.name); *) - (Id.Map.add (Nameops.Name.get_id pte) info acc_map,info::acc_info) - ) - 0 - (Id.Map.empty,[]) - (List.rev princ_info.predicates) + let first_args = Array.init nargs (fun i -> mkRel (nargs - i)) in + let app_f = mkApp (f, first_args) in + let pte_args = Array.to_list first_args @ [app_f] in + let app_pte = applist (mkVar (Nameops.Name.get_id pte), pte_args) in + let body_with_param, num = + let body = get_body fnames.(i) in + let body_with_full_params = + Reductionops.nf_betaiota (pf_env g) (project g) + (applist (body, List.rev_map var_of_decl full_params)) + in + match EConstr.kind (project g) body_with_full_params with + | Fix ((_, num), (_, _, bs)) -> + ( Reductionops.nf_betaiota (pf_env g) (project g) + (applist + ( substl + (List.rev (Array.to_list all_funs_with_full_params)) + bs.(num) + , List.rev_map var_of_decl princ_params )) + , num ) + | _ -> user_err Pp.(str "Not a mutual block") in - pte_to_fix,List.rev rev_info - | _ -> - Id.Map.empty,[] - in - let mk_fixes : tactic = - let pre_info,infos = list_chop fun_num infos in - match pre_info,infos with - | _,[] -> tclIDTAC - | _, this_fix_info::others_infos -> - let other_fix_infos = - List.map - (fun fi -> fi.name,fi.idx + 1 ,fi.types) - (pre_info@others_infos) + let info = + { infos with + types = compose_prod type_args app_pte + ; body_with_param + ; num_in_block = num } in - if List.is_empty other_fix_infos - then - if this_fix_info.idx + 1 = 0 - then tclIDTAC (* Someone tries to defined a principle on a fully parametric definition declared as a fixpoint (strange but ....) *) - else - Indfun_common.observe_tac (fun _ _ -> str "h_fix " ++ int (this_fix_info.idx +1)) - (Proofview.V82.of_tactic (fix this_fix_info.name (this_fix_info.idx +1))) - else - Proofview.V82.of_tactic (Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1) - other_fix_infos 0) - in - let first_tac : tactic = (* every operations until fix creations *) + (* observe (str "binding " ++ Ppconstr.pr_id (Nameops.Name.get_id pte) ++ *) + (* str " to " ++ Ppconstr.pr_id info.name); *) + (Id.Map.add (Nameops.Name.get_id pte) info acc_map, info :: acc_info)) + 0 (Id.Map.empty, []) + (List.rev princ_info.predicates) + in + (pte_to_fix, List.rev rev_info) + | _ -> (Id.Map.empty, []) + in + let mk_fixes : tactic = + let pre_info, infos = list_chop fun_num infos in + match (pre_info, infos) with + | _, [] -> tclIDTAC + | _, this_fix_info :: others_infos -> + let other_fix_infos = + List.map + (fun fi -> (fi.name, fi.idx + 1, fi.types)) + (pre_info @ others_infos) + in + if List.is_empty other_fix_infos then + if this_fix_info.idx + 1 = 0 then tclIDTAC + (* Someone tries to defined a principle on a fully parametric definition declared as a fixpoint (strange but ....) *) + else + Indfun_common.observe_tac + (fun _ _ -> str "h_fix " ++ int (this_fix_info.idx + 1)) + (Proofview.V82.of_tactic + (fix this_fix_info.name (this_fix_info.idx + 1))) + else + Proofview.V82.of_tactic + (Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1) + other_fix_infos 0) + in + let first_tac : tactic = + (* every operations until fix creations *) + tclTHENLIST + [ observe_tac "introducing params" + (Proofview.V82.of_tactic + (intros_using (List.rev_map id_of_decl princ_info.params))) + ; observe_tac "introducing predictes" + (Proofview.V82.of_tactic + (intros_using (List.rev_map id_of_decl princ_info.predicates))) + ; observe_tac "introducing branches" + (Proofview.V82.of_tactic + (intros_using (List.rev_map id_of_decl princ_info.branches))) + ; observe_tac "building fixes" mk_fixes ] + in + let intros_after_fixes : tactic = + fun gl -> + let ctxt, pte_app = decompose_prod_assum (project gl) (pf_concl gl) in + let pte, pte_args = decompose_app (project gl) pte_app in + try + let pte = + try destVar (project gl) pte + with DestKO -> anomaly (Pp.str "Property is not a variable.") + in + let fix_info = Id.Map.find pte ptes_to_fix in + let nb_args = fix_info.nb_realargs in tclTHENLIST - [ observe_tac "introducing params" (Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.params))); - observe_tac "introducing predictes" (Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.predicates))); - observe_tac "introducing branches" (Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.branches))); - observe_tac "building fixes" mk_fixes; - ] - in - let intros_after_fixes : tactic = - fun gl -> - let ctxt,pte_app = (decompose_prod_assum (project gl) (pf_concl gl)) in - let pte,pte_args = (decompose_app (project gl) pte_app) in - try - let pte = - try destVar (project gl) pte - with DestKO -> anomaly (Pp.str "Property is not a variable.") - in - let fix_info = Id.Map.find pte ptes_to_fix in - let nb_args = fix_info.nb_realargs in - tclTHENLIST - [ - (* observe_tac ("introducing args") *) (tclDO nb_args (Proofview.V82.of_tactic intro)); - (fun g -> (* replacement of the function by its body *) - let args = nLastDecls nb_args g in - let fix_body = fix_info.body_with_param in -(* observe (str "fix_body := "++ pr_lconstr_env (pf_env gl) fix_body); *) - let open Context.Named.Declaration in - let args_id = List.map get_id args in - let dyn_infos = - { - nb_rec_hyps = -100; - rec_hyps = []; - info = - Reductionops.nf_betaiota (pf_env g) (project g) - (applist(fix_body,List.rev_map mkVar args_id)); - eq_hyps = [] - } + [ (* observe_tac ("introducing args") *) + tclDO nb_args (Proofview.V82.of_tactic intro) + ; (fun g -> + (* replacement of the function by its body *) + let args = nLastDecls nb_args g in + let fix_body = fix_info.body_with_param in + (* observe (str "fix_body := "++ pr_lconstr_env (pf_env gl) fix_body); *) + let open Context.Named.Declaration in + let args_id = List.map get_id args in + let dyn_infos = + { nb_rec_hyps = -100 + ; rec_hyps = [] + ; info = + Reductionops.nf_betaiota (pf_env g) (project g) + (applist (fix_body, List.rev_map mkVar args_id)) + ; eq_hyps = [] } + in + tclTHENLIST + [ observe_tac "do_replace" + (do_replace evd full_params + (fix_info.idx + List.length princ_params) + ( args_id + @ List.map + (RelDecl.get_name %> Nameops.Name.get_id) + princ_params ) + all_funs.(fix_info.num_in_block) + fix_info.num_in_block all_funs) + ; (let do_prove = + build_proof interactive_proof (Array.to_list fnames) + (Id.Map.map prove_rec_hyp ptes_to_fix) in - tclTHENLIST - [ - observe_tac "do_replace" - (do_replace evd - full_params - (fix_info.idx + List.length princ_params) - (args_id@(List.map (RelDecl.get_name %> Nameops.Name.get_id) princ_params)) - (all_funs.(fix_info.num_in_block)) - fix_info.num_in_block - all_funs - ); - let do_prove = - build_proof - interactive_proof - (Array.to_list fnames) - (Id.Map.map prove_rec_hyp ptes_to_fix) - in - let prove_tac branches = - let dyn_infos = - {dyn_infos with - rec_hyps = branches; - nb_rec_hyps = List.length branches - } - in - observe_tac "cleaning" (clean_goal_with_heq - (Id.Map.map prove_rec_hyp ptes_to_fix) - do_prove - dyn_infos) - in -(* observe (str "branches := " ++ *) -(* prlist_with_sep spc (fun decl -> Ppconstr.pr_id (id_of_decl decl)) princ_info.branches ++ fnl () ++ *) -(* str "args := " ++ prlist_with_sep spc Ppconstr.pr_id args_id *) - -(* ); *) - (* observe_tac "instancing" *) (instantiate_hyps_with_args prove_tac - (List.rev_map id_of_decl princ_info.branches) - (List.rev args_id)) - ] - g - ); - ] gl - with Not_found -> - let nb_args = min (princ_info.nargs) (List.length ctxt) in - tclTHENLIST - [ - tclDO nb_args (Proofview.V82.of_tactic intro); - (fun g -> (* replacement of the function by its body *) - let args = nLastDecls nb_args g in - let open Context.Named.Declaration in - let args_id = List.map get_id args in - let dyn_infos = - { - nb_rec_hyps = -100; - rec_hyps = []; - info = - Reductionops.nf_betaiota (pf_env g) (project g) - (applist(fbody_with_full_params, - (List.rev_map var_of_decl princ_params)@ - (List.rev_map mkVar args_id) - )); - eq_hyps = [] - } + let prove_tac branches = + let dyn_infos = + { dyn_infos with + rec_hyps = branches + ; nb_rec_hyps = List.length branches } + in + observe_tac "cleaning" + (clean_goal_with_heq + (Id.Map.map prove_rec_hyp ptes_to_fix) + do_prove dyn_infos) in - let fname = destConst (project g) (fst (decompose_app (project g) (List.hd (List.rev pte_args)))) in - tclTHENLIST - [Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst fname))]); - let do_prove = - build_proof - interactive_proof - (Array.to_list fnames) - (Id.Map.map prove_rec_hyp ptes_to_fix) - in - let prove_tac branches = - let dyn_infos = - {dyn_infos with - rec_hyps = branches; - nb_rec_hyps = List.length branches - } - in - clean_goal_with_heq - (Id.Map.map prove_rec_hyp ptes_to_fix) - do_prove - dyn_infos - in - instantiate_hyps_with_args prove_tac - (List.rev_map id_of_decl princ_info.branches) - (List.rev args_id) - ] - g - ) - ] - gl - in - tclTHEN - first_tac - intros_after_fixes - g - - - - - + (* observe (str "branches := " ++ *) + (* prlist_with_sep spc (fun decl -> Ppconstr.pr_id (id_of_decl decl)) princ_info.branches ++ fnl () ++ *) + (* str "args := " ++ prlist_with_sep spc Ppconstr.pr_id args_id *) + + (* ); *) + (* observe_tac "instancing" *) + instantiate_hyps_with_args prove_tac + (List.rev_map id_of_decl princ_info.branches) + (List.rev args_id)) ] + g) ] + gl + with Not_found -> + let nb_args = min princ_info.nargs (List.length ctxt) in + tclTHENLIST + [ tclDO nb_args (Proofview.V82.of_tactic intro) + ; (fun g -> + (* replacement of the function by its body *) + let args = nLastDecls nb_args g in + let open Context.Named.Declaration in + let args_id = List.map get_id args in + let dyn_infos = + { nb_rec_hyps = -100 + ; rec_hyps = [] + ; info = + Reductionops.nf_betaiota (pf_env g) (project g) + (applist + ( fbody_with_full_params + , List.rev_map var_of_decl princ_params + @ List.rev_map mkVar args_id )) + ; eq_hyps = [] } + in + let fname = + destConst (project g) + (fst (decompose_app (project g) (List.hd (List.rev pte_args)))) + in + tclTHENLIST + [ Proofview.V82.of_tactic + (unfold_in_concl + [(Locus.AllOccurrences, Names.EvalConstRef (fst fname))]) + ; (let do_prove = + build_proof interactive_proof (Array.to_list fnames) + (Id.Map.map prove_rec_hyp ptes_to_fix) + in + let prove_tac branches = + let dyn_infos = + { dyn_infos with + rec_hyps = branches + ; nb_rec_hyps = List.length branches } + in + clean_goal_with_heq + (Id.Map.map prove_rec_hyp ptes_to_fix) + do_prove dyn_infos + in + instantiate_hyps_with_args prove_tac + (List.rev_map id_of_decl princ_info.branches) + (List.rev args_id)) ] + g) ] + gl + in + tclTHEN first_tac intros_after_fixes g (* Proof of principles of general functions *) (* let hrec_id = Recdef.hrec_id *) @@ -1319,132 +1231,119 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam (* and list_rewrite = Recdef.list_rewrite *) (* and evaluable_of_global_reference = Recdef.evaluable_of_global_reference *) - - - - let prove_with_tcc tcc_lemma_constr eqs : tactic = match !tcc_lemma_constr with | Undefined -> anomaly (Pp.str "No tcc proof !!") | Value lemma -> - fun gls -> -(* let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in *) -(* let ids = hid::pf_ids_of_hyps gls in *) - tclTHENLIST - [ -(* generalize [lemma]; *) -(* h_intro hid; *) -(* Elim.h_decompose_and (mkVar hid); *) - tclTRY(list_rewrite true eqs); -(* (fun g -> *) -(* let ids' = pf_ids_of_hyps g in *) -(* let ids = List.filter (fun id -> not (List.mem id ids)) ids' in *) -(* rewrite *) -(* ) *) - Proofview.V82.of_tactic (Eauto.gen_eauto (false,5) [] (Some [])) - ] - gls + fun gls -> + (* let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in *) + (* let ids = hid::pf_ids_of_hyps gls in *) + tclTHENLIST + [ (* generalize [lemma]; *) + (* h_intro hid; *) + (* Elim.h_decompose_and (mkVar hid); *) + tclTRY (list_rewrite true eqs) + ; (* (fun g -> *) + (* let ids' = pf_ids_of_hyps g in *) + (* let ids = List.filter (fun id -> not (List.mem id ids)) ids' in *) + (* rewrite *) + (* ) *) + Proofview.V82.of_tactic (Eauto.gen_eauto (false, 5) [] (Some [])) ] + gls | Not_needed -> tclIDTAC let backtrack_eqs_until_hrec hrec eqs : tactic = - fun gls -> - let eqs = List.map mkVar eqs in - let rewrite = - tclFIRST (List.map (fun x -> Proofview.V82.of_tactic (Equality.rewriteRL x)) eqs ) - in - let _,hrec_concl = decompose_prod (project gls) (pf_get_hyp_typ gls hrec) in - let f_app = Array.last (snd (destApp (project gls) hrec_concl)) in - let f = (fst (destApp (project gls) f_app)) in - let rec backtrack : tactic = - fun g -> - let f_app = Array.last (snd (destApp (project g) (pf_concl g))) in - match EConstr.kind (project g) f_app with - | App(f',_) when eq_constr (project g) f' f -> tclIDTAC g - | _ -> tclTHEN rewrite backtrack g - in - backtrack gls - + fun gls -> + let eqs = List.map mkVar eqs in + let rewrite = + tclFIRST + (List.map (fun x -> Proofview.V82.of_tactic (Equality.rewriteRL x)) eqs) + in + let _, hrec_concl = decompose_prod (project gls) (pf_get_hyp_typ gls hrec) in + let f_app = Array.last (snd (destApp (project gls) hrec_concl)) in + let f = fst (destApp (project gls) f_app) in + let rec backtrack : tactic = + fun g -> + let f_app = Array.last (snd (destApp (project g) (pf_concl g))) in + match EConstr.kind (project g) f_app with + | App (f', _) when eq_constr (project g) f' f -> tclIDTAC g + | _ -> tclTHEN rewrite backtrack g + in + backtrack gls let rec rewrite_eqs_in_eqs eqs = match eqs with - | [] -> tclIDTAC - | eq::eqs -> - - tclTHEN - (tclMAP - (fun id gl -> - observe_tac - (Format.sprintf "rewrite %s in %s " (Id.to_string eq) (Id.to_string id)) - (tclTRY (Proofview.V82.of_tactic (Equality.general_rewrite_in true Locus.AllOccurrences - true (* dep proofs also: *) true id (mkVar eq) false))) - gl - ) - eqs - ) - (rewrite_eqs_in_eqs eqs) + | [] -> tclIDTAC + | eq :: eqs -> + tclTHEN + (tclMAP + (fun id gl -> + observe_tac + (Format.sprintf "rewrite %s in %s " (Id.to_string eq) + (Id.to_string id)) + (tclTRY + (Proofview.V82.of_tactic + (Equality.general_rewrite_in true Locus.AllOccurrences true + (* dep proofs also: *) true id (mkVar eq) false))) + gl) + eqs) + (rewrite_eqs_in_eqs eqs) let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = - fun gls -> - (tclTHENLIST - [ - backtrack_eqs_until_hrec hrec eqs; - (* observe_tac ("new_prove_with_tcc ( applying "^(Id.to_string hrec)^" )" ) *) - (tclTHENS (* We must have exactly ONE subgoal !*) - (Proofview.V82.of_tactic (apply (mkVar hrec))) - [ tclTHENLIST - [ - (Proofview.V82.of_tactic (keep (tcc_hyps@eqs))); - (Proofview.V82.of_tactic (apply (Lazy.force acc_inv))); - (fun g -> - if is_mes - then - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference (delayed_force ltof_ref))]) g - else tclIDTAC g - ); - observe_tac "rew_and_finish" - (tclTHENLIST - [tclTRY(list_rewrite false (List.map (fun v -> (mkVar v,true)) eqs)); - observe_tac "rewrite_eqs_in_eqs" (rewrite_eqs_in_eqs eqs); - (observe_tac "finishing using" - ( - tclCOMPLETE( - Proofview.V82.of_tactic @@ - Eauto.eauto_with_bases - (true,5) + fun gls -> + (tclTHENLIST + [ backtrack_eqs_until_hrec hrec eqs + ; (* observe_tac ("new_prove_with_tcc ( applying "^(Id.to_string hrec)^" )" ) *) + tclTHENS (* We must have exactly ONE subgoal !*) + (Proofview.V82.of_tactic (apply (mkVar hrec))) + [ tclTHENLIST + [ Proofview.V82.of_tactic (keep (tcc_hyps @ eqs)) + ; Proofview.V82.of_tactic (apply (Lazy.force acc_inv)) + ; (fun g -> + if is_mes then + Proofview.V82.of_tactic + (unfold_in_concl + [ ( Locus.AllOccurrences + , evaluable_of_global_reference + (delayed_force ltof_ref) ) ]) + g + else tclIDTAC g) + ; observe_tac "rew_and_finish" + (tclTHENLIST + [ tclTRY + (list_rewrite false + (List.map (fun v -> (mkVar v, true)) eqs)) + ; observe_tac "rewrite_eqs_in_eqs" (rewrite_eqs_in_eqs eqs) + ; observe_tac "finishing using" + (tclCOMPLETE + ( Proofview.V82.of_tactic + @@ Eauto.eauto_with_bases (true, 5) [(fun _ sigma -> (sigma, Lazy.force refl_equal))] - [Hints.Hint_db.empty TransparentState.empty false] - ) - ) - ) - ] - ) - ] - ]) - ]) - gls - + [ Hints.Hint_db.empty TransparentState.empty + false ] )) ]) ] ] ]) + gls let is_valid_hypothesis sigma predicates_name = - let predicates_name = List.fold_right Id.Set.add predicates_name Id.Set.empty in + let predicates_name = + List.fold_right Id.Set.add predicates_name Id.Set.empty + in let is_pte typ = - if isApp sigma typ - then - let pte,_ = destApp sigma typ in - if isVar sigma pte - then Id.Set.mem (destVar sigma pte) predicates_name + if isApp sigma typ then + let pte, _ = destApp sigma typ in + if isVar sigma pte then Id.Set.mem (destVar sigma pte) predicates_name else false else false in let rec is_valid_hypothesis typ = - is_pte typ || - match EConstr.kind sigma typ with - | Prod(_,pte,typ') -> is_pte pte && is_valid_hypothesis typ' - | _ -> false + is_pte typ + || + match EConstr.kind sigma typ with + | Prod (_, pte, typ') -> is_pte pte && is_valid_hypothesis typ' + | _ -> false in is_valid_hypothesis -let prove_principle_for_gen - (f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes +let prove_principle_for_gen (f_ref, functional_ref, eq_ref) tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation gl = let princ_type = pf_concl gl in let princ_info = compute_elim_sig (project gl) princ_type in @@ -1452,9 +1351,9 @@ let prove_principle_for_gen let avoid = ref (pf_ids_of_hyps gl) in fun na -> let new_id = - match na with - | Name id -> fresh_id !avoid (Id.to_string id) - | Anonymous -> fresh_id !avoid "H" + match na with + | Name id -> fresh_id !avoid (Id.to_string id) + | Anonymous -> fresh_id !avoid "H" in avoid := new_id :: !avoid; Name new_id @@ -1462,200 +1361,182 @@ let prove_principle_for_gen let fresh_decl = map_name fresh_id in let princ_info : elim_scheme = { princ_info with - params = List.map fresh_decl princ_info.params; - predicates = List.map fresh_decl princ_info.predicates; - branches = List.map fresh_decl princ_info.branches; - args = List.map fresh_decl princ_info.args - } + params = List.map fresh_decl princ_info.params + ; predicates = List.map fresh_decl princ_info.predicates + ; branches = List.map fresh_decl princ_info.branches + ; args = List.map fresh_decl princ_info.args } in let wf_tac = - if is_mes - then - (fun b -> - Proofview.V82.of_tactic @@ - Recdef.tclUSER_if_not_mes Tacticals.New.tclIDTAC b None) + if is_mes then fun b -> + Proofview.V82.of_tactic + @@ Recdef.tclUSER_if_not_mes Tacticals.New.tclIDTAC b None else fun _ -> prove_with_tcc tcc_lemma_ref [] in let real_rec_arg_num = rec_arg_num - princ_info.nparams in let npost_rec_arg = princ_info.nargs - real_rec_arg_num + 1 in -(* observe ( *) -(* str "princ_type := " ++ pr_lconstr princ_type ++ fnl () ++ *) -(* str "princ_info.nparams := " ++ int princ_info.nparams ++ fnl () ++ *) - -(* str "princ_info.nargs := " ++ int princ_info.nargs ++ fnl () ++ *) -(* str "rec_arg_num := " ++ int rec_arg_num ++ fnl() ++ *) -(* str "real_rec_arg_num := " ++ int real_rec_arg_num ++ fnl () ++ *) -(* str "npost_rec_arg := " ++ int npost_rec_arg ); *) - let (post_rec_arg,pre_rec_arg) = + (* observe ( *) + (* str "princ_type := " ++ pr_lconstr princ_type ++ fnl () ++ *) + (* str "princ_info.nparams := " ++ int princ_info.nparams ++ fnl () ++ *) + + (* str "princ_info.nargs := " ++ int princ_info.nargs ++ fnl () ++ *) + (* str "rec_arg_num := " ++ int rec_arg_num ++ fnl() ++ *) + (* str "real_rec_arg_num := " ++ int real_rec_arg_num ++ fnl () ++ *) + (* str "npost_rec_arg := " ++ int npost_rec_arg ); *) + let post_rec_arg, pre_rec_arg = Util.List.chop npost_rec_arg princ_info.args in let rec_arg_id = match List.rev post_rec_arg with - | (LocalAssum ({binder_name=Name id},_) | LocalDef ({binder_name=Name id},_,_)) :: _ -> id - | _ -> assert false + | ( LocalAssum ({binder_name = Name id}, _) + | LocalDef ({binder_name = Name id}, _, _) ) + :: _ -> + id + | _ -> assert false + in + (* observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *) + let subst_constrs = + List.map + (get_name %> Nameops.Name.get_id %> mkVar) + (pre_rec_arg @ princ_info.params) in -(* observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *) - let subst_constrs = List.map (get_name %> Nameops.Name.get_id %> mkVar) (pre_rec_arg@princ_info.params) in let relation = substl subst_constrs relation in let input_type = substl subst_constrs rec_arg_type in let wf_thm_id = Nameops.Name.get_id (fresh_id (Name (Id.of_string "wf_R"))) in let acc_rec_arg_id = - Nameops.Name.get_id (fresh_id (Name (Id.of_string ("Acc_"^(Id.to_string rec_arg_id))))) + Nameops.Name.get_id + (fresh_id (Name (Id.of_string ("Acc_" ^ Id.to_string rec_arg_id)))) in let revert l = - tclTHEN (Proofview.V82.of_tactic (Tactics.generalize (List.map mkVar l))) (Proofview.V82.of_tactic (clear l)) + tclTHEN + (Proofview.V82.of_tactic (Tactics.generalize (List.map mkVar l))) + (Proofview.V82.of_tactic (clear l)) in let fix_id = Nameops.Name.get_id (fresh_id (Name hrec_id)) in let prove_rec_arg_acc g = - ((* observe_tac "prove_rec_arg_acc" *) - (tclCOMPLETE - (tclTHEN - (Proofview.V82.of_tactic (assert_by (Name wf_thm_id) - (mkApp (delayed_force well_founded,[|input_type;relation|])) - (Proofview.V82.tactic (fun g -> (* observe_tac "prove wf" *) (tclCOMPLETE (wf_tac is_mes)) g)))) - ( - (* observe_tac *) -(* "apply wf_thm" *) - Proofview.V82.of_tactic (Tactics.Simple.apply (mkApp(mkVar wf_thm_id,[|mkVar rec_arg_id|]))) - ) - ) - ) - ) + ((* observe_tac "prove_rec_arg_acc" *) + tclCOMPLETE + (tclTHEN + (Proofview.V82.of_tactic + (assert_by (Name wf_thm_id) + (mkApp (delayed_force well_founded, [|input_type; relation|])) + (Proofview.V82.tactic (fun g -> + (* observe_tac "prove wf" *) + (tclCOMPLETE (wf_tac is_mes)) g)))) + ((* observe_tac *) + (* "apply wf_thm" *) + Proofview.V82.of_tactic + (Tactics.Simple.apply + (mkApp (mkVar wf_thm_id, [|mkVar rec_arg_id|])))))) g in let args_ids = List.map (get_name %> Nameops.Name.get_id) princ_info.args in let lemma = match !tcc_lemma_ref with - | Undefined -> user_err Pp.(str "No tcc proof !!") - | Value lemma -> EConstr.of_constr lemma - | Not_needed -> EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.True.I") + | Undefined -> user_err Pp.(str "No tcc proof !!") + | Value lemma -> EConstr.of_constr lemma + | Not_needed -> + EConstr.of_constr + (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.True.I") in -(* let rec list_diff del_list check_list = *) -(* match del_list with *) -(* [] -> *) -(* [] *) -(* | f::r -> *) -(* if List.mem f check_list then *) -(* list_diff r check_list *) -(* else *) -(* f::(list_diff r check_list) *) -(* in *) + (* let rec list_diff del_list check_list = *) + (* match del_list with *) + (* [] -> *) + (* [] *) + (* | f::r -> *) + (* if List.mem f check_list then *) + (* list_diff r check_list *) + (* else *) + (* f::(list_diff r check_list) *) + (* in *) let tcc_list = ref [] in let start_tac gls = let hyps = pf_ids_of_hyps gls in - let hid = - next_ident_away_in_goal - (Id.of_string "prov") - (Id.Set.of_list hyps) - in - tclTHENLIST - [ - Proofview.V82.of_tactic (generalize [lemma]); - Proofview.V82.of_tactic (Simple.intro hid); - Proofview.V82.of_tactic (Elim.h_decompose_and (mkVar hid)); - (fun g -> - let new_hyps = pf_ids_of_hyps g in - tcc_list := List.rev (List.subtract Id.equal new_hyps (hid::hyps)); - if List.is_empty !tcc_list - then - begin - tcc_list := [hid]; - tclIDTAC g - end - else thin [hid] g - ) - ] - gls + let hid = + next_ident_away_in_goal (Id.of_string "prov") (Id.Set.of_list hyps) + in + tclTHENLIST + [ Proofview.V82.of_tactic (generalize [lemma]) + ; Proofview.V82.of_tactic (Simple.intro hid) + ; Proofview.V82.of_tactic (Elim.h_decompose_and (mkVar hid)) + ; (fun g -> + let new_hyps = pf_ids_of_hyps g in + tcc_list := List.rev (List.subtract Id.equal new_hyps (hid :: hyps)); + if List.is_empty !tcc_list then begin + tcc_list := [hid]; + tclIDTAC g + end + else thin [hid] g) ] + gls in tclTHENLIST - [ - observe_tac "start_tac" start_tac; - h_intros - (List.rev_map (get_name %> Nameops.Name.get_id) - (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params) - ); - Proofview.V82.of_tactic - (assert_by - (Name acc_rec_arg_id) - (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|])) - (Proofview.V82.tactic prove_rec_arg_acc)); - (revert (List.rev (acc_rec_arg_id::args_ids))); - (Proofview.V82.of_tactic (fix fix_id (List.length args_ids + 1))); - h_intros (List.rev (acc_rec_arg_id::args_ids)); - Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_ref)); - (fun gl' -> - let body = - let _,args = destApp (project gl') (pf_concl gl') in - Array.last args - in - let body_info rec_hyps = - { - nb_rec_hyps = List.length rec_hyps; - rec_hyps = rec_hyps; - eq_hyps = []; - info = body - } - in - let acc_inv = - lazy ( - mkApp ( - delayed_force acc_inv_id, - [|input_type;relation;mkVar rec_arg_id|] - ) - ) - in - let acc_inv = lazy (mkApp(Lazy.force acc_inv, [|mkVar acc_rec_arg_id|])) in - let predicates_names = - List.map (get_name %> Nameops.Name.get_id) princ_info.predicates - in - let pte_info = - { proving_tac = - (fun eqs -> -(* msgnl (str "tcc_list := "++ prlist_with_sep spc Ppconstr.pr_id !tcc_list); *) -(* msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.args)); *) -(* msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.params)); *) -(* msgnl (str "acc_rec_arg_id := "++ Ppconstr.pr_id acc_rec_arg_id); *) -(* msgnl (str "eqs := "++ prlist_with_sep spc Ppconstr.pr_id eqs); *) - - (* observe_tac "new_prove_with_tcc" *) - (new_prove_with_tcc - is_mes acc_inv fix_id - - (!tcc_list@(List.map - (get_name %> Nameops.Name.get_id) - (princ_info.args@princ_info.params) - )@ ([acc_rec_arg_id])) eqs - ) - - ); - is_valid = is_valid_hypothesis (project gl') predicates_names - } - in - let ptes_info : pte_info Id.Map.t = - List.fold_left - (fun map pte_id -> - Id.Map.add pte_id - pte_info - map - ) - Id.Map.empty - predicates_names - in - let make_proof rec_hyps = - build_proof - false - [f_ref] - ptes_info - (body_info rec_hyps) - in - (* observe_tac "instantiate_hyps_with_args" *) - (instantiate_hyps_with_args - make_proof - (List.map (get_name %> Nameops.Name.get_id) princ_info.branches) - (List.rev args_ids) - ) - gl' - ) - - ] + [ observe_tac "start_tac" start_tac + ; h_intros + (List.rev_map + (get_name %> Nameops.Name.get_id) + ( princ_info.args @ princ_info.branches @ princ_info.predicates + @ princ_info.params )) + ; Proofview.V82.of_tactic + (assert_by (Name acc_rec_arg_id) + (mkApp + (delayed_force acc_rel, [|input_type; relation; mkVar rec_arg_id|])) + (Proofview.V82.tactic prove_rec_arg_acc)) + ; revert (List.rev (acc_rec_arg_id :: args_ids)) + ; Proofview.V82.of_tactic (fix fix_id (List.length args_ids + 1)) + ; h_intros (List.rev (acc_rec_arg_id :: args_ids)) + ; Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_ref)) + ; (fun gl' -> + let body = + let _, args = destApp (project gl') (pf_concl gl') in + Array.last args + in + let body_info rec_hyps = + { nb_rec_hyps = List.length rec_hyps + ; rec_hyps + ; eq_hyps = [] + ; info = body } + in + let acc_inv = + lazy + (mkApp + ( delayed_force acc_inv_id + , [|input_type; relation; mkVar rec_arg_id|] )) + in + let acc_inv = + lazy (mkApp (Lazy.force acc_inv, [|mkVar acc_rec_arg_id|])) + in + let predicates_names = + List.map (get_name %> Nameops.Name.get_id) princ_info.predicates + in + let pte_info = + { proving_tac = + (fun eqs -> + (* msgnl (str "tcc_list := "++ prlist_with_sep spc Ppconstr.pr_id !tcc_list); *) + (* msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.args)); *) + (* msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.params)); *) + (* msgnl (str "acc_rec_arg_id := "++ Ppconstr.pr_id acc_rec_arg_id); *) + (* msgnl (str "eqs := "++ prlist_with_sep spc Ppconstr.pr_id eqs); *) + + (* observe_tac "new_prove_with_tcc" *) + new_prove_with_tcc is_mes acc_inv fix_id + ( !tcc_list + @ List.map + (get_name %> Nameops.Name.get_id) + (princ_info.args @ princ_info.params) + @ [acc_rec_arg_id] ) + eqs) + ; is_valid = is_valid_hypothesis (project gl') predicates_names } + in + let ptes_info : pte_info Id.Map.t = + List.fold_left + (fun map pte_id -> Id.Map.add pte_id pte_info map) + Id.Map.empty predicates_names + in + let make_proof rec_hyps = + build_proof false [f_ref] ptes_info (body_info rec_hyps) + in + (* observe_tac "instantiate_hyps_with_args" *) + (instantiate_hyps_with_args make_proof + (List.map (get_name %> Nameops.Name.get_id) princ_info.branches) + (List.rev args_ids)) + gl') ] gl diff --git a/plugins/funind/functional_principles_proofs.mli b/plugins/funind/functional_principles_proofs.mli index 64fbfaeedf..52089ca7fb 100644 --- a/plugins/funind/functional_principles_proofs.mli +++ b/plugins/funind/functional_principles_proofs.mli @@ -1,19 +1,27 @@ open Names val prove_princ_for_struct : - Evd.evar_map ref -> - bool -> - int -> Constant.t array -> EConstr.constr array -> int -> Tacmach.tactic - + Evd.evar_map ref + -> bool + -> int + -> Constant.t array + -> EConstr.constr array + -> int + -> Tacmach.tactic val prove_principle_for_gen : - Constant.t * Constant.t * Constant.t -> (* name of the function, the functional and the fixpoint equation *) - Indfun_common.tcc_lemma_value ref -> (* a pointer to the obligation proofs lemma *) - bool -> (* is that function uses measure *) - int -> (* the number of recursive argument *) - EConstr.types -> (* the type of the recursive argument *) - EConstr.constr -> (* the wf relation used to prove the function *) - Tacmach.tactic - + Constant.t * Constant.t * Constant.t + -> (* name of the function, the functional and the fixpoint equation *) + Indfun_common.tcc_lemma_value ref + -> (* a pointer to the obligation proofs lemma *) + bool + -> (* is that function uses measure *) + int + -> (* the number of recursive argument *) + EConstr.types + -> (* the type of the recursive argument *) + EConstr.constr + -> (* the wf relation used to prove the function *) + Tacmach.tactic (* val is_pte : rel_declaration -> bool *) diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 163645b719..1ab747ca09 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -20,16 +20,12 @@ open Pp open Tactics open Context.Rel.Declaration open Indfun_common - module RelDecl = Context.Rel.Declaration -exception Toberemoved_with_rel of int*constr +exception Toberemoved_with_rel of int * constr exception Toberemoved -let observe s = - if do_observe () - then Feedback.msg_debug s - +let observe s = if do_observe () then Feedback.msg_debug s let pop t = Vars.lift (-1) t (* @@ -42,203 +38,211 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let env = Global.env () in let env_with_params = EConstr.push_rel_context princ_type_info.params env in let tbl = Hashtbl.create 792 in - let rec change_predicates_names (avoid:Id.t list) (predicates:EConstr.rel_context) : EConstr.rel_context = + let rec change_predicates_names (avoid : Id.t list) + (predicates : EConstr.rel_context) : EConstr.rel_context = match predicates with | [] -> [] - | decl :: predicates -> - (match Context.Rel.Declaration.get_name decl with - | Name x -> - let id = Namegen.next_ident_away x (Id.Set.of_list avoid) in - Hashtbl.add tbl id x; - RelDecl.set_name (Name id) decl :: change_predicates_names (id::avoid) predicates - | Anonymous -> anomaly (Pp.str "Anonymous property binder.")) + | decl :: predicates -> ( + match Context.Rel.Declaration.get_name decl with + | Name x -> + let id = Namegen.next_ident_away x (Id.Set.of_list avoid) in + Hashtbl.add tbl id x; + RelDecl.set_name (Name id) decl + :: change_predicates_names (id :: avoid) predicates + | Anonymous -> anomaly (Pp.str "Anonymous property binder.") ) in - let avoid = (Termops.ids_of_context env_with_params ) in + let avoid = Termops.ids_of_context env_with_params in let princ_type_info = { princ_type_info with - predicates = change_predicates_names avoid princ_type_info.predicates - } + predicates = change_predicates_names avoid princ_type_info.predicates } in -(* observe (str "starting princ_type := " ++ pr_lconstr_env env princ_type); *) -(* observe (str "princ_infos : " ++ pr_elim_scheme princ_type_info); *) + (* observe (str "starting princ_type := " ++ pr_lconstr_env env princ_type); *) + (* observe (str "princ_infos : " ++ pr_elim_scheme princ_type_info); *) let change_predicate_sort i decl = let new_sort = sorts.(i) in - let args,_ = decompose_prod_assum (EConstr.Unsafe.to_constr (RelDecl.get_type decl)) in + let args, _ = + decompose_prod_assum (EConstr.Unsafe.to_constr (RelDecl.get_type decl)) + in let real_args = - if princ_type_info.indarg_in_concl - then List.tl args - else args + if princ_type_info.indarg_in_concl then List.tl args else args in - Context.Named.Declaration.LocalAssum (map_annot Nameops.Name.get_id (Context.Rel.Declaration.get_annot decl), - Term.it_mkProd_or_LetIn (mkSort new_sort) real_args) + Context.Named.Declaration.LocalAssum + ( map_annot Nameops.Name.get_id (Context.Rel.Declaration.get_annot decl) + , Term.it_mkProd_or_LetIn (mkSort new_sort) real_args ) in let new_predicates = - List.map_i - change_predicate_sort - 0 - princ_type_info.predicates + List.map_i change_predicate_sort 0 princ_type_info.predicates + in + let env_with_params_and_predicates = + List.fold_right Environ.push_named new_predicates env_with_params in - let env_with_params_and_predicates = List.fold_right Environ.push_named new_predicates env_with_params in let rel_as_kn = - fst (match princ_type_info.indref with - | Some (GlobRef.IndRef ind) -> ind - | _ -> user_err Pp.(str "Not a valid predicate") - ) + fst + ( match princ_type_info.indref with + | Some (GlobRef.IndRef ind) -> ind + | _ -> user_err Pp.(str "Not a valid predicate") ) in let ptes_vars = List.map Context.Named.Declaration.get_id new_predicates in let is_pte = let set = List.fold_right Id.Set.add ptes_vars Id.Set.empty in - fun t -> - match Constr.kind t with - | Var id -> Id.Set.mem id set - | _ -> false + fun t -> match Constr.kind t with Var id -> Id.Set.mem id set | _ -> false in let pre_princ = let open EConstr in it_mkProd_or_LetIn (it_mkProd_or_LetIn - (Option.fold_right - mkProd_or_LetIn - princ_type_info.indarg - princ_type_info.concl - ) - princ_type_info.args - ) + (Option.fold_right mkProd_or_LetIn princ_type_info.indarg + princ_type_info.concl) + princ_type_info.args) princ_type_info.branches in let pre_princ = EConstr.Unsafe.to_constr pre_princ in let pre_princ = substl (List.map mkVar ptes_vars) pre_princ in let is_dom c = match Constr.kind c with - | Ind((u,_),_) -> MutInd.equal u rel_as_kn - | Construct(((u,_),_),_) -> MutInd.equal u rel_as_kn - | _ -> false + | Ind ((u, _), _) -> MutInd.equal u rel_as_kn + | Construct (((u, _), _), _) -> MutInd.equal u rel_as_kn + | _ -> false in let get_fun_num c = match Constr.kind c with - | Ind((_,num),_) -> num - | Construct(((_,num),_),_) -> num - | _ -> assert false + | Ind ((_, num), _) -> num + | Construct (((_, num), _), _) -> num + | _ -> assert false in let dummy_var = mkVar (Id.of_string "________") in let mk_replacement c i args = - let res = mkApp(rel_to_fun.(i), Array.map pop (array_get_start args)) in - observe (str "replacing " ++ - pr_lconstr_env env Evd.empty c ++ str " by " ++ - pr_lconstr_env env Evd.empty res); + let res = mkApp (rel_to_fun.(i), Array.map pop (array_get_start args)) in + observe + ( str "replacing " + ++ pr_lconstr_env env Evd.empty c + ++ str " by " + ++ pr_lconstr_env env Evd.empty res ); res in - let rec compute_new_princ_type remove env pre_princ : types*(constr list) = - let (new_princ_type,_) as res = + let rec compute_new_princ_type remove env pre_princ : types * constr list = + let ((new_princ_type, _) as res) = match Constr.kind pre_princ with - | Rel n -> - begin - try match Environ.lookup_rel n env with - | LocalAssum (_,t) | LocalDef (_,_,t) when is_dom t -> raise Toberemoved - | _ -> pre_princ,[] - with Not_found -> assert false - end - | Prod(x,t,b) -> - compute_new_princ_type_for_binder remove mkProd env x t b - | Lambda(x,t,b) -> - compute_new_princ_type_for_binder remove mkLambda env x t b - | Ind _ | Construct _ when is_dom pre_princ -> raise Toberemoved - | App(f,args) when is_dom f -> - let var_to_be_removed = destRel (Array.last args) in - let num = get_fun_num f in - raise (Toberemoved_with_rel (var_to_be_removed,mk_replacement pre_princ num args)) - | App(f,args) -> - let args = - if is_pte f && remove - then array_get_start args - else args - in - let new_args,binders_to_remove = - Array.fold_right (compute_new_princ_type_with_acc remove env) - args - ([],[]) - in - let new_f,binders_to_remove_from_f = compute_new_princ_type remove env f in - applistc new_f new_args, - list_union_eq Constr.equal binders_to_remove_from_f binders_to_remove - | LetIn(x,v,t,b) -> - compute_new_princ_type_for_letin remove env x v t b - | _ -> pre_princ,[] + | Rel n -> ( + try + match Environ.lookup_rel n env with + | (LocalAssum (_, t) | LocalDef (_, _, t)) when is_dom t -> + raise Toberemoved + | _ -> (pre_princ, []) + with Not_found -> assert false ) + | Prod (x, t, b) -> + compute_new_princ_type_for_binder remove mkProd env x t b + | Lambda (x, t, b) -> + compute_new_princ_type_for_binder remove mkLambda env x t b + | (Ind _ | Construct _) when is_dom pre_princ -> raise Toberemoved + | App (f, args) when is_dom f -> + let var_to_be_removed = destRel (Array.last args) in + let num = get_fun_num f in + raise + (Toberemoved_with_rel + (var_to_be_removed, mk_replacement pre_princ num args)) + | App (f, args) -> + let args = if is_pte f && remove then array_get_start args else args in + let new_args, binders_to_remove = + Array.fold_right + (compute_new_princ_type_with_acc remove env) + args ([], []) + in + let new_f, binders_to_remove_from_f = + compute_new_princ_type remove env f + in + ( applistc new_f new_args + , list_union_eq Constr.equal binders_to_remove_from_f binders_to_remove + ) + | LetIn (x, v, t, b) -> + compute_new_princ_type_for_letin remove env x v t b + | _ -> (pre_princ, []) in -(* let _ = match Constr.kind pre_princ with *) -(* | Prod _ -> *) -(* observe(str "compute_new_princ_type for "++ *) -(* pr_lconstr_env env pre_princ ++ *) -(* str" is "++ *) -(* pr_lconstr_env env new_princ_type ++ fnl ()) *) -(* | _ -> () in *) + (* let _ = match Constr.kind pre_princ with *) + (* | Prod _ -> *) + (* observe(str "compute_new_princ_type for "++ *) + (* pr_lconstr_env env pre_princ ++ *) + (* str" is "++ *) + (* pr_lconstr_env env new_princ_type ++ fnl ()) *) + (* | _ -> () in *) res - and compute_new_princ_type_for_binder remove bind_fun env x t b = - begin - try - let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in - let new_x = map_annot (get_name (Termops.ids_of_context env)) x in - let new_env = Environ.push_rel (LocalAssum (x,t)) env in - let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in - if List.exists (Constr.equal (mkRel 1)) binders_to_remove_from_b - then (pop new_b), filter_map (Constr.equal (mkRel 1)) pop binders_to_remove_from_b - else - ( - bind_fun(new_x,new_t,new_b), - list_union_eq - Constr.equal - binders_to_remove_from_t - (List.map pop binders_to_remove_from_b) - ) - - with - | Toberemoved -> -(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) - let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in - new_b, List.map pop binders_to_remove_from_b - | Toberemoved_with_rel (n,c) -> -(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) - let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in - new_b, list_add_set_eq Constr.equal (mkRel n) (List.map pop binders_to_remove_from_b) - end + try + let new_t, binders_to_remove_from_t = + compute_new_princ_type remove env t + in + let new_x = map_annot (get_name (Termops.ids_of_context env)) x in + let new_env = Environ.push_rel (LocalAssum (x, t)) env in + let new_b, binders_to_remove_from_b = + compute_new_princ_type remove new_env b + in + if List.exists (Constr.equal (mkRel 1)) binders_to_remove_from_b then + ( pop new_b + , filter_map (Constr.equal (mkRel 1)) pop binders_to_remove_from_b ) + else + ( bind_fun (new_x, new_t, new_b) + , list_union_eq Constr.equal binders_to_remove_from_t + (List.map pop binders_to_remove_from_b) ) + with + | Toberemoved -> + (* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) + let new_b, binders_to_remove_from_b = + compute_new_princ_type remove env (substnl [dummy_var] 1 b) + in + (new_b, List.map pop binders_to_remove_from_b) + | Toberemoved_with_rel (n, c) -> + (* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) + let new_b, binders_to_remove_from_b = + compute_new_princ_type remove env (substnl [c] n b) + in + ( new_b + , list_add_set_eq Constr.equal (mkRel n) + (List.map pop binders_to_remove_from_b) ) and compute_new_princ_type_for_letin remove env x v t b = - begin - try - let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in - let new_v,binders_to_remove_from_v = compute_new_princ_type remove env v in - let new_x = map_annot (get_name (Termops.ids_of_context env)) x in - let new_env = Environ.push_rel (LocalDef (x,v,t)) env in - let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in - if List.exists (Constr.equal (mkRel 1)) binders_to_remove_from_b - then (pop new_b),filter_map (Constr.equal (mkRel 1)) pop binders_to_remove_from_b - else - ( - mkLetIn(new_x,new_v,new_t,new_b), - list_union_eq - Constr.equal - (list_union_eq Constr.equal binders_to_remove_from_t binders_to_remove_from_v) - (List.map pop binders_to_remove_from_b) - ) - - with - | Toberemoved -> -(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) - let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in - new_b, List.map pop binders_to_remove_from_b - | Toberemoved_with_rel (n,c) -> -(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) - let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in - new_b, list_add_set_eq Constr.equal (mkRel n) (List.map pop binders_to_remove_from_b) - end - and compute_new_princ_type_with_acc remove env e (c_acc,to_remove_acc) = - let new_e,to_remove_from_e = compute_new_princ_type remove env e - in - new_e::c_acc,list_union_eq Constr.equal to_remove_from_e to_remove_acc + try + let new_t, binders_to_remove_from_t = + compute_new_princ_type remove env t + in + let new_v, binders_to_remove_from_v = + compute_new_princ_type remove env v + in + let new_x = map_annot (get_name (Termops.ids_of_context env)) x in + let new_env = Environ.push_rel (LocalDef (x, v, t)) env in + let new_b, binders_to_remove_from_b = + compute_new_princ_type remove new_env b + in + if List.exists (Constr.equal (mkRel 1)) binders_to_remove_from_b then + ( pop new_b + , filter_map (Constr.equal (mkRel 1)) pop binders_to_remove_from_b ) + else + ( mkLetIn (new_x, new_v, new_t, new_b) + , list_union_eq Constr.equal + (list_union_eq Constr.equal binders_to_remove_from_t + binders_to_remove_from_v) + (List.map pop binders_to_remove_from_b) ) + with + | Toberemoved -> + (* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) + let new_b, binders_to_remove_from_b = + compute_new_princ_type remove env (substnl [dummy_var] 1 b) + in + (new_b, List.map pop binders_to_remove_from_b) + | Toberemoved_with_rel (n, c) -> + (* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) + let new_b, binders_to_remove_from_b = + compute_new_princ_type remove env (substnl [c] n b) + in + ( new_b + , list_add_set_eq Constr.equal (mkRel n) + (List.map pop binders_to_remove_from_b) ) + and compute_new_princ_type_with_acc remove env e (c_acc, to_remove_acc) = + let new_e, to_remove_from_e = compute_new_princ_type remove env e in + (new_e :: c_acc, list_union_eq Constr.equal to_remove_from_e to_remove_acc) in -(* observe (str "Computing new principe from " ++ pr_lconstr_env env_with_params_and_predicates pre_princ); *) - let pre_res,_ = - compute_new_princ_type princ_type_info.indarg_in_concl env_with_params_and_predicates pre_princ + (* observe (str "Computing new principe from " ++ pr_lconstr_env env_with_params_and_predicates pre_princ); *) + let pre_res, _ = + compute_new_princ_type princ_type_info.indarg_in_concl + env_with_params_and_predicates pre_princ in let pre_res = replace_vars @@ -246,12 +250,18 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = (lift (List.length ptes_vars) pre_res) in it_mkProd_or_LetIn - (it_mkProd_or_LetIn - pre_res (List.map (function - | Context.Named.Declaration.LocalAssum (id,b) -> - LocalAssum (map_annot (fun id -> Name.mk_name (Hashtbl.find tbl id)) id, b) - | Context.Named.Declaration.LocalDef (id,t,b) -> - LocalDef (map_annot (fun id -> Name.mk_name (Hashtbl.find tbl id)) id, t, b)) - new_predicates) - ) - (List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) princ_type_info.params) + (it_mkProd_or_LetIn pre_res + (List.map + (function + | Context.Named.Declaration.LocalAssum (id, b) -> + LocalAssum + (map_annot (fun id -> Name.mk_name (Hashtbl.find tbl id)) id, b) + | Context.Named.Declaration.LocalDef (id, t, b) -> + LocalDef + ( map_annot (fun id -> Name.mk_name (Hashtbl.find tbl id)) id + , t + , b )) + new_predicates)) + (List.map + (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) + princ_type_info.params) diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli index c870603a43..4bbb7180f0 100644 --- a/plugins/funind/functional_principles_types.mli +++ b/plugins/funind/functional_principles_types.mli @@ -8,8 +8,5 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -val compute_new_princ_type_from_rel - : Constr.constr array - -> Sorts.t array - -> Constr.t - -> Constr.types +val compute_new_princ_type_from_rel : + Constr.constr array -> Sorts.t array -> Constr.t -> Constr.types diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml index 446026c4c8..55e659d487 100644 --- a/plugins/funind/gen_principle.ml +++ b/plugins/funind/gen_principle.ml @@ -10,9 +10,7 @@ open Util open Names - open Indfun_common - module RelDecl = Context.Rel.Declaration let observe_tac s = observe_tac (fun _ _ -> Pp.str s) @@ -23,73 +21,92 @@ let observe_tac s = observe_tac (fun _ _ -> Pp.str s) *) let rec abstract_glob_constr c = function | [] -> c - | Constrexpr.CLocalDef (x,b,t)::bl -> Constrexpr_ops.mkLetInC(x,b,t,abstract_glob_constr c bl) - | Constrexpr.CLocalAssum (idl,k,t)::bl -> - List.fold_right (fun x b -> Constrexpr_ops.mkLambdaC([x],k,t,b)) idl + | Constrexpr.CLocalDef (x, b, t) :: bl -> + Constrexpr_ops.mkLetInC (x, b, t, abstract_glob_constr c bl) + | Constrexpr.CLocalAssum (idl, k, t) :: bl -> + List.fold_right + (fun x b -> Constrexpr_ops.mkLambdaC ([x], k, t, b)) + idl (abstract_glob_constr c bl) - | Constrexpr.CLocalPattern _::bl -> assert false + | Constrexpr.CLocalPattern _ :: bl -> assert false -let interp_casted_constr_with_implicits env sigma impls c = +let interp_casted_constr_with_implicits env sigma impls c = Constrintern.intern_gen Pretyping.WithoutTypeConstraint env sigma ~impls c let build_newrecursive lnameargsardef = - let env0 = Global.env() in + let env0 = Global.env () in let sigma = Evd.from_env env0 in - let (rec_sign,rec_impls) = + let rec_sign, rec_impls = List.fold_left - (fun (env,impls) { Vernacexpr.fname={CAst.v=recname}; binders; rtype } -> - let arityc = Constrexpr_ops.mkCProdN binders rtype in - let arity,ctx = Constrintern.interp_type env0 sigma arityc in - let evd = Evd.from_env env0 in - let evd, (_, (_, impls')) = Constrintern.interp_context_evars ~program_mode:false env evd binders in - let impl = Constrintern.compute_internalization_data env0 evd Constrintern.Recursive arity impls' in - let open Context.Named.Declaration in - let r = Sorts.Relevant in (* TODO relevance *) - (EConstr.push_named (LocalAssum (Context.make_annot recname r,arity)) env, Id.Map.add recname impl impls)) - (env0,Constrintern.empty_internalization_env) lnameargsardef in + (fun (env, impls) {Vernacexpr.fname = {CAst.v = recname}; binders; rtype} -> + let arityc = Constrexpr_ops.mkCProdN binders rtype in + let arity, _ctx = Constrintern.interp_type env0 sigma arityc in + let evd = Evd.from_env env0 in + let evd, (_, (_, impls')) = + Constrintern.interp_context_evars ~program_mode:false env evd binders + in + let impl = + Constrintern.compute_internalization_data env0 evd recname + Constrintern.Recursive arity impls' + in + let open Context.Named.Declaration in + let r = Sorts.Relevant in + (* TODO relevance *) + ( EConstr.push_named + (LocalAssum (Context.make_annot recname r, arity)) + env + , Id.Map.add recname impl impls )) + (env0, Constrintern.empty_internalization_env) + lnameargsardef + in let recdef = (* Declare local notations *) - let f { Vernacexpr.binders; body_def } = + let f {Vernacexpr.binders; body_def} = match body_def with | Some body_def -> let def = abstract_glob_constr body_def binders in - interp_casted_constr_with_implicits - rec_sign sigma rec_impls def - | None -> CErrors.user_err ~hdr:"Function" (Pp.str "Body of Function must be given") + interp_casted_constr_with_implicits rec_sign sigma rec_impls def + | None -> + CErrors.user_err ~hdr:"Function" + (Pp.str "Body of Function must be given") in States.with_state_protection (List.map f) lnameargsardef in - recdef,rec_impls + (recdef, rec_impls) (* Checks whether or not the mutual bloc is recursive *) let is_rec names = let open Glob_term in let names = List.fold_right Id.Set.add names Id.Set.empty in - let check_id id names = Id.Set.mem id names in - let rec lookup names gt = match DAst.get gt with - | GVar(id) -> check_id id names - | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ | GFloat _ -> false - | GCast(b,_) -> lookup names b + let check_id id names = Id.Set.mem id names in + let rec lookup names gt = + match DAst.get gt with + | GVar id -> check_id id names + | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ | GFloat _ -> + false + | GCast (b, _) -> lookup names b | GRec _ -> CErrors.user_err (Pp.str "GRec not handled") - | GIf(b,_,lhs,rhs) -> - (lookup names b) || (lookup names lhs) || (lookup names rhs) - | GProd(na,_,t,b) | GLambda(na,_,t,b) -> - lookup names t || lookup (Nameops.Name.fold_right Id.Set.remove na names) b - | GLetIn(na,b,t,c) -> - lookup names b || Option.cata (lookup names) true t || lookup (Nameops.Name.fold_right Id.Set.remove na names) c - | GLetTuple(nal,_,t,b) -> lookup names t || - lookup - (List.fold_left - (fun acc na -> Nameops.Name.fold_right Id.Set.remove na acc) - names - nal - ) - b - | GApp(f,args) -> List.exists (lookup names) (f::args) - | GCases(_,_,el,brl) -> - List.exists (fun (e,_) -> lookup names e) el || - List.exists (lookup_br names) brl - and lookup_br names {CAst.v=(idl,_,rt)} = + | GIf (b, _, lhs, rhs) -> + lookup names b || lookup names lhs || lookup names rhs + | GProd (na, _, t, b) | GLambda (na, _, t, b) -> + lookup names t + || lookup (Nameops.Name.fold_right Id.Set.remove na names) b + | GLetIn (na, b, t, c) -> + lookup names b + || Option.cata (lookup names) true t + || lookup (Nameops.Name.fold_right Id.Set.remove na names) c + | GLetTuple (nal, _, t, b) -> + lookup names t + || lookup + (List.fold_left + (fun acc na -> Nameops.Name.fold_right Id.Set.remove na acc) + names nal) + b + | GApp (f, args) -> List.exists (lookup names) (f :: args) + | GCases (_, _, el, brl) -> + List.exists (fun (e, _) -> lookup names e) el + || List.exists (lookup_br names) brl + and lookup_br names {CAst.v = idl, _, rt} = let new_names = List.fold_right Id.Set.remove idl names in lookup new_names rt in @@ -97,114 +114,138 @@ let is_rec names = let rec rebuild_bl aux bl typ = let open Constrexpr in - match bl,typ with - | [], _ -> List.rev aux,typ - | (CLocalAssum(nal,bk,_))::bl',typ -> - rebuild_nal aux bk bl' nal typ - | (CLocalDef(na,_,_))::bl',{ CAst.v = CLetIn(_,nat,ty,typ') } -> - rebuild_bl (Constrexpr.CLocalDef(na,nat,ty)::aux) - bl' typ' + match (bl, typ) with + | [], _ -> (List.rev aux, typ) + | CLocalAssum (nal, bk, _) :: bl', typ -> rebuild_nal aux bk bl' nal typ + | CLocalDef (na, _, _) :: bl', {CAst.v = CLetIn (_, nat, ty, typ')} -> + rebuild_bl (Constrexpr.CLocalDef (na, nat, ty) :: aux) bl' typ' | _ -> assert false + and rebuild_nal aux bk bl' nal typ = let open Constrexpr in - match nal,typ with - | _,{ CAst.v = CProdN([],typ) } -> rebuild_nal aux bk bl' nal typ + match (nal, typ) with + | _, {CAst.v = CProdN ([], typ)} -> rebuild_nal aux bk bl' nal typ | [], _ -> rebuild_bl aux bl' typ - | na::nal,{ CAst.v = CProdN(CLocalAssum(na'::nal',bk',nal't)::rest,typ') } -> - if Name.equal (na.CAst.v) (na'.CAst.v) || Name.is_anonymous (na'.CAst.v) - then - let assum = CLocalAssum([na],bk,nal't) in - let new_rest = if nal' = [] then rest else (CLocalAssum(nal',bk',nal't)::rest) in - rebuild_nal - (assum::aux) - bk - bl' - nal - (CAst.make @@ CProdN(new_rest,typ')) + | ( na :: nal + , {CAst.v = CProdN (CLocalAssum (na' :: nal', bk', nal't) :: rest, typ')} ) + -> + if Name.equal na.CAst.v na'.CAst.v || Name.is_anonymous na'.CAst.v then + let assum = CLocalAssum ([na], bk, nal't) in + let new_rest = + if nal' = [] then rest else CLocalAssum (nal', bk', nal't) :: rest + in + rebuild_nal (assum :: aux) bk bl' nal + (CAst.make @@ CProdN (new_rest, typ')) else - let assum = CLocalAssum([na'],bk,nal't) in - let new_rest = if nal' = [] then rest else (CLocalAssum(nal',bk',nal't)::rest) in - rebuild_nal - (assum::aux) - bk - bl' - (na::nal) - (CAst.make @@ CProdN(new_rest,typ')) - | _ -> - assert false + let assum = CLocalAssum ([na'], bk, nal't) in + let new_rest = + if nal' = [] then rest else CLocalAssum (nal', bk', nal't) :: rest + in + rebuild_nal (assum :: aux) bk bl' (na :: nal) + (CAst.make @@ CProdN (new_rest, typ')) + | _ -> assert false let rebuild_bl aux bl typ = rebuild_bl aux bl typ let recompute_binder_list fixpoint_exprl = let fixl = - List.map (fun fix -> Vernacexpr.{ - fix - with rec_order = ComFixpoint.adjust_rec_order ~structonly:false fix.binders fix.rec_order }) fixpoint_exprl in - let ((_,_,_,typel),_,ctx,_) = ComFixpoint.interp_fixpoint ~cofix:false fixl in + List.map + (fun fix -> + Vernacexpr. + { fix with + rec_order = + ComFixpoint.adjust_rec_order ~structonly:false fix.binders + fix.rec_order }) + fixpoint_exprl + in + let (_, _, _, typel), _, ctx, _ = + ComFixpoint.interp_fixpoint ~cofix:false fixl + in let constr_expr_typel = - with_full_print (List.map (fun c -> Constrextern.extern_constr (Global.env ()) (Evd.from_ctx ctx) (EConstr.of_constr c))) typel in + with_full_print + (List.map (fun c -> + Constrextern.extern_constr (Global.env ()) (Evd.from_ctx ctx) + (EConstr.of_constr c))) + typel + in let fixpoint_exprl_with_new_bl = - List.map2 (fun ({ Vernacexpr.binders } as fp) fix_typ -> + List.map2 + (fun ({Vernacexpr.binders} as fp) fix_typ -> let binders, rtype = rebuild_bl [] binders fix_typ in - { fp with Vernacexpr.binders; rtype } - ) fixpoint_exprl constr_expr_typel + {fp with Vernacexpr.binders; rtype}) + fixpoint_exprl constr_expr_typel in fixpoint_exprl_with_new_bl let rec local_binders_length = function (* Assume that no `{ ... } contexts occur *) | [] -> 0 - | Constrexpr.CLocalDef _::bl -> 1 + local_binders_length bl - | Constrexpr.CLocalAssum (idl,_,_)::bl -> List.length idl + local_binders_length bl - | Constrexpr.CLocalPattern _::bl -> assert false + | Constrexpr.CLocalDef _ :: bl -> 1 + local_binders_length bl + | Constrexpr.CLocalAssum (idl, _, _) :: bl -> + List.length idl + local_binders_length bl + | Constrexpr.CLocalPattern _ :: bl -> assert false -let prepare_body { Vernacexpr.binders } rt = +let prepare_body {Vernacexpr.binders} rt = let n = local_binders_length binders in (* Pp.msgnl (str "nb lambda to chop : " ++ str (string_of_int n) ++ fnl () ++Printer.pr_glob_constr rt); *) - let fun_args,rt' = chop_rlambda_n n rt in - (fun_args,rt') + let fun_args, rt' = chop_rlambda_n n rt in + (fun_args, rt') -let build_functional_principle ?(opaque=Proof_global.Transparent) (evd:Evd.evar_map ref) interactive_proof old_princ_type sorts funs i proof_tac hook = +let build_functional_principle ?(opaque = Declare.Transparent) + (evd : Evd.evar_map ref) old_princ_type sorts funs _i proof_tac hook = (* First we get the type of the old graph principle *) - let mutr_nparams = (Tactics.compute_elim_sig !evd (EConstr.of_constr old_princ_type)).Tactics.nparams in + let mutr_nparams = + (Tactics.compute_elim_sig !evd (EConstr.of_constr old_princ_type)) + .Tactics.nparams + in (* let time1 = System.get_time () in *) let new_principle_type = Functional_principles_types.compute_new_princ_type_from_rel (Array.map Constr.mkConstU funs) - sorts - old_princ_type + sorts old_princ_type in (* let time2 = System.get_time () in *) (* Pp.msgnl (str "computing principle type := " ++ System.fmt_time_difference time1 time2); *) let new_princ_name = - Namegen.next_ident_away_in_goal (Id.of_string "___________princ_________") Id.Set.empty + Namegen.next_ident_away_in_goal + (Id.of_string "___________princ_________") + Id.Set.empty + in + let sigma, _ = + Typing.type_of ~refresh:true (Global.env ()) !evd + (EConstr.of_constr new_principle_type) in - let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd (EConstr.of_constr new_principle_type) in evd := sigma; let hook = DeclareDef.Hook.make (hook new_principle_type) in let lemma = - Lemmas.start_lemma - ~name:new_princ_name - ~poly:false - !evd + Lemmas.start_lemma ~name:new_princ_name ~poly:false !evd (EConstr.of_constr new_principle_type) in (* let _tim1 = System.get_time () in *) let map (c, u) = EConstr.mkConstU (c, EConstr.EInstance.make u) in - let lemma,_ = Lemmas.by (Proofview.V82.tactic (proof_tac (Array.map map funs) mutr_nparams)) lemma in + let lemma, _ = + Lemmas.by + (Proofview.V82.tactic (proof_tac (Array.map map funs) mutr_nparams)) + lemma + in (* let _tim2 = System.get_time () in *) (* begin *) (* let dur1 = System.time_difference tim1 tim2 in *) (* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *) (* end; *) - - let open Proof_global in - let { name; entries } = Lemmas.pf_fold (close_proof ~opaque ~keep_body_ucst_separate:false (fun x -> x)) lemma in + let {Declare.entries} = + Lemmas.pf_fold + (Declare.close_proof ~opaque ~keep_body_ucst_separate:false) + lemma + in match entries with - | [entry] -> - entry, hook + | [entry] -> (entry, hook) | _ -> - CErrors.anomaly Pp.(str "[build_functional_principle] close_proof returned more than one proof term") + CErrors.anomaly + Pp.( + str + "[build_functional_principle] close_proof returned more than one \ + proof term") let change_property_sort evd toSort princ princName = let open Context.Rel.Declaration in @@ -212,212 +253,221 @@ let change_property_sort evd toSort princ princName = let princ_info = Tactics.compute_elim_sig evd princ in let change_sort_in_predicate decl = LocalAssum - (get_annot decl, - let args,ty = Term.decompose_prod (EConstr.Unsafe.to_constr (get_type decl)) in - let s = Constr.destSort ty in - Global.add_constraints (Univ.enforce_leq (Sorts.univ_of_sort toSort) (Sorts.univ_of_sort s) Univ.Constraint.empty); - Term.compose_prod args (Constr.mkSort toSort) - ) + ( get_annot decl + , let args, ty = + Term.decompose_prod (EConstr.Unsafe.to_constr (get_type decl)) + in + let s = Constr.destSort ty in + Global.add_constraints + (Univ.enforce_leq + (Sorts.univ_of_sort toSort) + (Sorts.univ_of_sort s) Univ.Constraint.empty); + Term.compose_prod args (Constr.mkSort toSort) ) + in + let evd, princName_as_constr = + Evd.fresh_global (Global.env ()) evd + (Constrintern.locate_reference (Libnames.qualid_of_ident princName)) in - let evd,princName_as_constr = - Evd.fresh_global - (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident princName)) in let init = - let nargs = (princ_info.Tactics.nparams + (List.length princ_info.Tactics.predicates)) in - Constr.mkApp(EConstr.Unsafe.to_constr princName_as_constr, - Array.init nargs - (fun i -> Constr.mkRel (nargs - i ))) + let nargs = + princ_info.Tactics.nparams + List.length princ_info.Tactics.predicates + in + Constr.mkApp + ( EConstr.Unsafe.to_constr princName_as_constr + , Array.init nargs (fun i -> Constr.mkRel (nargs - i)) ) in - evd, Term.it_mkLambda_or_LetIn - (Term.it_mkLambda_or_LetIn init - (List.map change_sort_in_predicate princ_info.Tactics.predicates) - ) - (List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) princ_info.Tactics.params) - -let generate_functional_principle (evd: Evd.evar_map ref) - interactive_proof - old_princ_type sorts new_princ_name funs i proof_tac - = + ( evd + , Term.it_mkLambda_or_LetIn + (Term.it_mkLambda_or_LetIn init + (List.map change_sort_in_predicate princ_info.Tactics.predicates)) + (List.map + (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) + princ_info.Tactics.params) ) + +let generate_functional_principle (evd : Evd.evar_map ref) old_princ_type sorts + new_princ_name funs i proof_tac = try - - let f = funs.(i) in - let sigma, type_sort = Evd.fresh_sort_in_family !evd Sorts.InType in - evd := sigma; - let new_sorts = - match sorts with - | None -> Array.make (Array.length funs) (type_sort) + let f = funs.(i) in + let sigma, type_sort = Evd.fresh_sort_in_family !evd Sorts.InType in + evd := sigma; + let new_sorts = + match sorts with + | None -> Array.make (Array.length funs) type_sort | Some a -> a - in - let base_new_princ_name,new_princ_name = - match new_princ_name with - | Some (id) -> id,id + in + let base_new_princ_name, new_princ_name = + match new_princ_name with + | Some id -> (id, id) | None -> - let id_of_f = Label.to_id (Constant.label (fst f)) in - id_of_f,Indrec.make_elimination_ident id_of_f (Sorts.family type_sort) - in - let names = ref [new_princ_name] in - let hook = - fun new_principle_type _ -> - if Option.is_empty sorts - then - (* let id_of_f = Label.to_id (con_label f) in *) - let register_with_sort fam_sort = - let evd' = Evd.from_env (Global.env ()) in - let evd',s = Evd.fresh_sort_in_family evd' fam_sort in - let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in - let evd',value = change_property_sort evd' s new_principle_type new_princ_name in - let evd' = fst (Typing.type_of ~refresh:true (Global.env ()) evd' (EConstr.of_constr value)) in - (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) - let univs = Evd.univ_entry ~poly:false evd' in - let ce = Declare.definition_entry ~univs value in - ignore( - Declare.declare_constant - ~name - ~kind:Decls.(IsDefinition Scheme) - (Declare.DefinitionEntry ce) - ); - Declare.definition_message name; - names := name :: !names - in - register_with_sort Sorts.InProp; - register_with_sort Sorts.InSet - in - let entry, hook = - build_functional_principle evd interactive_proof old_princ_type new_sorts funs i - proof_tac hook + let id_of_f = Label.to_id (Constant.label (fst f)) in + (id_of_f, Indrec.make_elimination_ident id_of_f (Sorts.family type_sort)) + in + let names = ref [new_princ_name] in + let hook new_principle_type _ = + if Option.is_empty sorts then ( + (* let id_of_f = Label.to_id (con_label f) in *) + let register_with_sort fam_sort = + let evd' = Evd.from_env (Global.env ()) in + let evd', s = Evd.fresh_sort_in_family evd' fam_sort in + let name = + Indrec.make_elimination_ident base_new_princ_name fam_sort + in + let evd', value = + change_property_sort evd' s new_principle_type new_princ_name + in + let evd' = + fst + (Typing.type_of ~refresh:true (Global.env ()) evd' + (EConstr.of_constr value)) + in + (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) + let univs = Evd.univ_entry ~poly:false evd' in + let ce = Declare.definition_entry ~univs value in + ignore + (Declare.declare_constant ~name + ~kind:Decls.(IsDefinition Scheme) + (Declare.DefinitionEntry ce)); + Declare.definition_message name; + names := name :: !names + in + register_with_sort Sorts.InProp; + register_with_sort Sorts.InSet ) + in + let entry, hook = + build_functional_principle evd old_princ_type new_sorts funs i proof_tac + hook + in + (* Pr 1278 : + Don't forget to close the goal if an error is raised !!!! + *) + let uctx = Evd.evar_universe_context sigma in + let (_ : Names.GlobRef.t) = + DeclareDef.declare_entry ~name:new_princ_name ~hook + ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) + ~kind:Decls.(IsProof Theorem) + ~impargs:[] ~uctx entry + in + () + with e when CErrors.noncritical e -> raise (Defining_principle e) + +let generate_principle (evd : Evd.evar_map ref) pconstants on_error is_general + do_built fix_rec_l recdefs + (continue_proof : + int + -> Names.Constant.t array + -> EConstr.constr array + -> int + -> Tacmach.tactic) : unit = + let names = + List.map (function {Vernacexpr.fname = {CAst.v = name}} -> name) fix_rec_l in - (* Pr 1278 : - Don't forget to close the goal if an error is raised !!!! - *) - let uctx = Evd.evar_universe_context sigma in - let hook_data = hook, uctx, [] in - let _ : Names.GlobRef.t = DeclareDef.declare_definition - ~name:new_princ_name ~hook_data - ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) - ~kind:Decls.(IsProof Theorem) - ~ubind:UnivNames.empty_binders - ~impargs:[] - entry in - () - with e when CErrors.noncritical e -> - raise (Defining_principle e) - -let generate_principle (evd:Evd.evar_map ref) pconstants on_error - is_general do_built fix_rec_l recdefs interactive_proof - (continue_proof : int -> Names.Constant.t array -> EConstr.constr array -> int -> - Tacmach.tactic) : unit = - let names = List.map (function { Vernacexpr.fname = {CAst.v=name} } -> name) fix_rec_l in let fun_bodies = List.map2 prepare_body fix_rec_l recdefs in let funs_args = List.map fst fun_bodies in - let funs_types = List.map (function { Vernacexpr.rtype } -> rtype) fix_rec_l in + let funs_types = + List.map (function {Vernacexpr.rtype} -> rtype) fix_rec_l + in try (* We then register the Inductive graphs of the functions *) - Glob_term_to_relation.build_inductive !evd pconstants funs_args funs_types recdefs; - if do_built - then - begin - (*i The next call to mk_rel_id is valid since we have just construct the graph - Ensures by : do_built - i*) - let f_R_mut = Libnames.qualid_of_ident @@ mk_rel_id (List.nth names 0) in - let ind_kn = - fst (locate_with_msg - Pp.(Libnames.pr_qualid f_R_mut ++ str ": Not an inductive type!") - locate_ind - f_R_mut) - in - let fname_kn { Vernacexpr.fname } = - let f_ref = Libnames.qualid_of_ident ?loc:fname.CAst.loc fname.CAst.v in - locate_with_msg - Pp.(Libnames.pr_qualid f_ref++str ": Not an inductive type!") - locate_constant - f_ref - in - let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in - let _ = - List.map_i - (fun i x -> - let env = Global.env () in - let princ = Indrec.lookup_eliminator env (ind_kn,i) (Sorts.InProp) in - let evd = ref (Evd.from_env env) in - let evd',uprinc = Evd.fresh_global env !evd princ in - let _ = evd := evd' in - let sigma, princ_type = Typing.type_of ~refresh:true env !evd uprinc in - evd := sigma; - let princ_type = EConstr.Unsafe.to_constr princ_type in - generate_functional_principle - evd - interactive_proof - princ_type - None - None - (Array.of_list pconstants) - (* funs_kn *) - i - (continue_proof 0 [|funs_kn.(i)|]) - ) - 0 - fix_rec_l - in - Array.iter (add_Function is_general) funs_kn; - () - end - with e when CErrors.noncritical e -> - on_error names e + Glob_term_to_relation.build_inductive !evd pconstants funs_args funs_types + recdefs; + if do_built then begin + (*i The next call to mk_rel_id is valid since we have just construct the graph + Ensures by : do_built + i*) + let f_R_mut = Libnames.qualid_of_ident @@ mk_rel_id (List.nth names 0) in + let ind_kn = + fst + (locate_with_msg + Pp.(Libnames.pr_qualid f_R_mut ++ str ": Not an inductive type!") + locate_ind f_R_mut) + in + let fname_kn {Vernacexpr.fname} = + let f_ref = Libnames.qualid_of_ident ?loc:fname.CAst.loc fname.CAst.v in + locate_with_msg + Pp.(Libnames.pr_qualid f_ref ++ str ": Not an inductive type!") + locate_constant f_ref + in + let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in + let _ = + List.map_i + (fun i _x -> + let env = Global.env () in + let princ = Indrec.lookup_eliminator env (ind_kn, i) Sorts.InProp in + let evd = ref (Evd.from_env env) in + let evd', uprinc = Evd.fresh_global env !evd princ in + let _ = evd := evd' in + let sigma, princ_type = + Typing.type_of ~refresh:true env !evd uprinc + in + evd := sigma; + let princ_type = EConstr.Unsafe.to_constr princ_type in + generate_functional_principle evd princ_type None None + (Array.of_list pconstants) (* funs_kn *) + i + (continue_proof 0 [|funs_kn.(i)|])) + 0 fix_rec_l + in + Array.iter (add_Function is_general) funs_kn; + () + end + with e when CErrors.noncritical e -> on_error names e let register_struct is_rec fixpoint_exprl = let open EConstr in match fixpoint_exprl with - | [{ Vernacexpr.fname; univs; binders; rtype; body_def }] when not is_rec -> + | [{Vernacexpr.fname; univs; binders; rtype; body_def}] when not is_rec -> let body = match body_def with | Some body -> body | None -> - CErrors.user_err ~hdr:"Function" Pp.(str "Body of Function must be given") in - ComDefinition.do_definition - ~program_mode:false - ~name:fname.CAst.v - ~poly:false + CErrors.user_err ~hdr:"Function" + Pp.(str "Body of Function must be given") + in + ComDefinition.do_definition ~name:fname.CAst.v ~poly:false ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) - ~kind:Decls.Definition univs - binders None body (Some rtype); - let evd,rev_pconstants = + ~kind:Decls.Definition univs binders None body (Some rtype); + let evd, rev_pconstants = List.fold_left - (fun (evd,l) { Vernacexpr.fname } -> - let evd,c = - Evd.fresh_global - (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname.CAst.v)) in - let (cst, u) = destConst evd c in - let u = EInstance.kind evd u in - evd,((cst, u) :: l) - ) - (Evd.from_env (Global.env ()),[]) + (fun (evd, l) {Vernacexpr.fname} -> + let evd, c = + Evd.fresh_global (Global.env ()) evd + (Constrintern.locate_reference + (Libnames.qualid_of_ident fname.CAst.v)) + in + let cst, u = destConst evd c in + let u = EInstance.kind evd u in + (evd, (cst, u) :: l)) + (Evd.from_env (Global.env ()), []) fixpoint_exprl in - None, evd,List.rev rev_pconstants + (None, evd, List.rev rev_pconstants) | _ -> - ComFixpoint.do_fixpoint ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) ~poly:false fixpoint_exprl; - let evd,rev_pconstants = + ComFixpoint.do_fixpoint + ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) ~poly:false + fixpoint_exprl; + let evd, rev_pconstants = List.fold_left - (fun (evd,l) { Vernacexpr.fname } -> - let evd,c = - Evd.fresh_global - (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname.CAst.v)) in - let (cst, u) = destConst evd c in - let u = EInstance.kind evd u in - evd,((cst, u) :: l) - ) - (Evd.from_env (Global.env ()),[]) + (fun (evd, l) {Vernacexpr.fname} -> + let evd, c = + Evd.fresh_global (Global.env ()) evd + (Constrintern.locate_reference + (Libnames.qualid_of_ident fname.CAst.v)) + in + let cst, u = destConst evd c in + let u = EInstance.kind evd u in + (evd, (cst, u) :: l)) + (Evd.from_env (Global.env ()), []) fixpoint_exprl in - None,evd,List.rev rev_pconstants + (None, evd, List.rev rev_pconstants) -let generate_correction_proof_wf f_ref tcc_lemma_ref - is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation - (_: int) (_:Names.Constant.t array) (_:EConstr.constr array) (_:int) : Tacmach.tactic = +let generate_correction_proof_wf f_ref tcc_lemma_ref is_mes functional_ref + eq_ref rec_arg_num rec_arg_type relation (_ : int) + (_ : Names.Constant.t array) (_ : EConstr.constr array) (_ : int) : + Tacmach.tactic = Functional_principles_proofs.prove_principle_for_gen - (f_ref,functional_ref,eq_ref) - tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation + (f_ref, functional_ref, eq_ref) + tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation (* [generate_type g_to_f f graph i] build the completeness (resp. correctness) lemma type if [g_to_f = true] (resp. g_to_f = false) where [graph] is the graph of [f] and is the [i]th function in the block. @@ -431,39 +481,43 @@ let generate_correction_proof_wf f_ref tcc_lemma_ref res = fv \rightarrow graph\ x_1\ldots x_n\ res\] decomposed as the context and the conclusion *) -let generate_type evd g_to_f f graph i = +let generate_type evd g_to_f f graph = let open Context.Rel.Declaration in let open EConstr in let open EConstr.Vars in (*i we deduce the number of arguments of the function and its returned type from the graph i*) - let evd',graph = - Evd.fresh_global (Global.env ()) !evd (GlobRef.IndRef (fst (destInd !evd graph))) + let evd', graph = + Evd.fresh_global (Global.env ()) !evd + (GlobRef.IndRef (fst (destInd !evd graph))) in - evd:=evd'; + evd := evd'; let sigma, graph_arity = Typing.type_of (Global.env ()) !evd graph in evd := sigma; - let ctxt,_ = decompose_prod_assum !evd graph_arity in - let fun_ctxt,res_type = + let ctxt, _ = decompose_prod_assum !evd graph_arity in + let fun_ctxt, res_type = match ctxt with | [] | [_] -> CErrors.anomaly (Pp.str "Not a valid context.") - | decl :: fun_ctxt -> fun_ctxt, RelDecl.get_type decl + | decl :: fun_ctxt -> (fun_ctxt, RelDecl.get_type decl) in let rec args_from_decl i accu = function | [] -> accu - | LocalDef _ :: l -> - args_from_decl (succ i) accu l + | LocalDef _ :: l -> args_from_decl (succ i) accu l | _ :: l -> let t = mkRel i in args_from_decl (succ i) (t :: accu) l in (*i We need to name the vars [res] and [fv] i*) - let filter = fun decl -> match RelDecl.get_name decl with - | Name id -> Some id - | Anonymous -> None + let filter decl = + match RelDecl.get_name decl with Name id -> Some id | Anonymous -> None in let named_ctxt = Id.Set.of_list (List.map_filter filter fun_ctxt) in - let res_id = Namegen.next_ident_away_in_goal (Id.of_string "_res") named_ctxt in - let fv_id = Namegen.next_ident_away_in_goal (Id.of_string "fv") (Id.Set.add res_id named_ctxt) in + let res_id = + Namegen.next_ident_away_in_goal (Id.of_string "_res") named_ctxt + in + let fv_id = + Namegen.next_ident_away_in_goal (Id.of_string "fv") + (Id.Set.add res_id named_ctxt) + in (*i we can then type the argument to be applied to the function [f] i*) let args_as_rels = Array.of_list (args_from_decl 1 [] fun_ctxt) in (*i @@ -472,7 +526,7 @@ let generate_type evd g_to_f f graph i = i*) let make_eq = make_eq () in let res_eq_f_of_args = - mkApp(make_eq ,[|lift 2 res_type;mkRel 1;mkRel 2|]) + mkApp (make_eq, [|lift 2 res_type; mkRel 1; mkRel 2|]) in (*i The hypothesis [graph\ x_1\ldots x_n\ res] can then be computed @@ -480,18 +534,29 @@ let generate_type evd g_to_f f graph i = i*) let args_and_res_as_rels = Array.of_list (args_from_decl 3 [] fun_ctxt) in let args_and_res_as_rels = Array.append args_and_res_as_rels [|mkRel 1|] in - let graph_applied = mkApp(graph, args_and_res_as_rels) in + let graph_applied = mkApp (graph, args_and_res_as_rels) in (*i The [pre_context] is the defined to be the context corresponding to \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, \] i*) let pre_ctxt = - LocalAssum (Context.make_annot (Name res_id) Sorts.Relevant, lift 1 res_type) :: - LocalDef (Context.make_annot (Name fv_id) Sorts.Relevant, mkApp (f,args_as_rels), res_type) :: fun_ctxt + LocalAssum (Context.make_annot (Name res_id) Sorts.Relevant, lift 1 res_type) + :: LocalDef + ( Context.make_annot (Name fv_id) Sorts.Relevant + , mkApp (f, args_as_rels) + , res_type ) + :: fun_ctxt in (*i and we can return the solution depending on which lemma type we are defining i*) - if g_to_f - then LocalAssum (Context.make_annot Anonymous Sorts.Relevant,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args),graph - else LocalAssum (Context.make_annot Anonymous Sorts.Relevant,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied),graph + if g_to_f then + ( LocalAssum (Context.make_annot Anonymous Sorts.Relevant, graph_applied) + :: pre_ctxt + , lift 1 res_eq_f_of_args + , graph ) + else + ( LocalAssum (Context.make_annot Anonymous Sorts.Relevant, res_eq_f_of_args) + :: pre_ctxt + , lift 1 graph_applied + , graph ) (** [find_induction_principle f] searches and returns the [body] and the [type] of [f_rect] @@ -499,21 +564,25 @@ let generate_type evd g_to_f f graph i = WARNING: while convertible, [type_of body] and [type] can be non equal *) let find_induction_principle evd f = - let f_as_constant,u = match EConstr.kind !evd f with + let f_as_constant, _u = + match EConstr.kind !evd f with | Constr.Const c' -> c' | _ -> CErrors.user_err Pp.(str "Must be used with a function") in match find_Function_infos f_as_constant with - | None -> - raise Not_found - | Some infos -> + | None -> raise Not_found + | Some infos -> ( match infos.rect_lemma with | None -> raise Not_found | Some rect_lemma -> - let evd',rect_lemma = Evd.fresh_global (Global.env ()) !evd (GlobRef.ConstRef rect_lemma) in - let evd',typ = Typing.type_of ~refresh:true (Global.env ()) evd' rect_lemma in - evd:=evd'; - rect_lemma,typ + let evd', rect_lemma = + Evd.fresh_global (Global.env ()) !evd (GlobRef.ConstRef rect_lemma) + in + let evd', typ = + Typing.type_of ~refresh:true (Global.env ()) evd' rect_lemma + in + evd := evd'; + (rect_lemma, typ) ) (* [prove_fun_correct funs_constr graphs_constr schemes lemmas_types_infos i ] is the tactic used to prove correctness lemma. @@ -540,13 +609,13 @@ let find_induction_principle evd f = *) let rec generate_fresh_id x avoid i = - if i == 0 - then [] + if i == 0 then [] else let id = Namegen.next_ident_away_in_goal x (Id.Set.of_list avoid) in - id::(generate_fresh_id x (id::avoid) (pred i)) + id :: generate_fresh_id x (id :: avoid) (pred i) -let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i : Tacmach.tactic = +let prove_fun_correct evd graphs_constr schemes lemmas_types_infos i : + Tacmach.tactic = let open Constr in let open EConstr in let open Context.Rel.Declaration in @@ -559,22 +628,25 @@ let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i \[fun (x_1:t_1)\ldots(x_n:t_n)=> fun fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\] *) (* we the get the definition of the graphs block *) - let graph_ind,u = destInd evd graphs_constr.(i) in + let graph_ind, u = destInd evd graphs_constr.(i) in let kn = fst graph_ind in - let mib,_ = Global.lookup_inductive graph_ind in + let mib, _ = Global.lookup_inductive graph_ind in (* and the principle to use in this lemma in $\zeta$ normal form *) - let f_principle,princ_type = schemes.(i) in + let f_principle, princ_type = schemes.(i) in let princ_type = Reductionops.nf_zeta (Global.env ()) evd princ_type in let princ_infos = Tactics.compute_elim_sig evd princ_type in (* The number of args of the function is then easily computable *) let nb_fun_args = Termops.nb_prod (project g) (pf_concl g) - 2 in let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in - let ids = args_names@(pf_ids_of_hyps g) in + let ids = args_names @ pf_ids_of_hyps g in (* Since we cannot ensure that the functional principle is defined in the environment and due to the bug #1174, we will need to pose the principle using a name *) - let principle_id = Namegen.next_ident_away_in_goal (Id.of_string "princ") (Id.Set.of_list ids) in + let principle_id = + Namegen.next_ident_away_in_goal (Id.of_string "princ") + (Id.Set.of_list ids) + in let ids = principle_id :: ids in (* We get the branches of the principle *) let branches = List.rev princ_infos.Tactics.branches in @@ -582,28 +654,28 @@ let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i let intro_pats = List.map (fun decl -> - List.map - (fun id -> CAst.make @@ Tactypes.IntroNaming (Namegen.IntroIdentifier id)) - (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum evd (RelDecl.get_type decl))))) - ) + List.map + (fun id -> + CAst.make @@ Tactypes.IntroNaming (Namegen.IntroIdentifier id)) + (generate_fresh_id (Id.of_string "y") ids + (List.length + (fst (decompose_prod_assum evd (RelDecl.get_type decl)))))) branches in (* before building the full intro pattern for the principle *) let eq_ind = make_eq () in let eq_construct = mkConstructUi (destInd evd eq_ind, 1) in (* The next to referencies will be used to find out which constructor to apply in each branch *) - let ind_number = ref 0 - and min_constr_number = ref 0 in + let ind_number = ref 0 and min_constr_number = ref 0 in (* The tactic to prove the ith branch of the principle *) let prove_branche i g = (* We get the identifiers of this branch *) let pre_args = List.fold_right - (fun {CAst.v=pat} acc -> - match pat with - | Tactypes.IntroNaming (Namegen.IntroIdentifier id) -> id::acc - | _ -> CErrors.anomaly (Pp.str "Not an identifier.") - ) + (fun {CAst.v = pat} acc -> + match pat with + | Tactypes.IntroNaming (Namegen.IntroIdentifier id) -> id :: acc + | _ -> CErrors.anomaly (Pp.str "Not an identifier.")) (List.nth intro_pats (pred i)) [] in @@ -618,32 +690,35 @@ let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i let constructor_args g = List.fold_right (fun hid acc -> - let type_of_hid = pf_get_hyp_typ g hid in - let sigma = project g in - match EConstr.kind sigma type_of_hid with - | Prod(_,_,t') -> - begin - match EConstr.kind sigma t' with - | Prod(_,t'',t''') -> - begin - match EConstr.kind sigma t'',EConstr.kind sigma t''' with - | App(eq,args), App(graph',_) - when - (EConstr.eq_constr sigma eq eq_ind) && - Array.exists (EConstr.eq_constr_nounivs sigma graph') graphs_constr -> - (args.(2)::(mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|])) - ::acc) - | _ -> mkVar hid :: acc - end - | _ -> mkVar hid :: acc - end - | _ -> mkVar hid :: acc - ) pre_args [] + let type_of_hid = pf_get_hyp_typ g hid in + let sigma = project g in + match EConstr.kind sigma type_of_hid with + | Prod (_, _, t') -> ( + match EConstr.kind sigma t' with + | Prod (_, t'', t''') -> ( + match (EConstr.kind sigma t'', EConstr.kind sigma t''') with + | App (eq, args), App (graph', _) + when EConstr.eq_constr sigma eq eq_ind + && Array.exists + (EConstr.eq_constr_nounivs sigma graph') + graphs_constr -> + args.(2) + :: mkApp + ( mkVar hid + , [| args.(2) + ; mkApp (eq_construct, [|args.(0); args.(2)|]) |] ) + :: acc + | _ -> mkVar hid :: acc ) + | _ -> mkVar hid :: acc ) + | _ -> mkVar hid :: acc) + pre_args [] in (* in fact we must also add the parameters to the constructor args *) let constructor_args g = - let params_id = fst (List.chop princ_infos.Tactics.nparams args_names) in - (List.map mkVar params_id)@((constructor_args g)) + let params_id = + fst (List.chop princ_infos.Tactics.nparams args_names) + in + List.map mkVar params_id @ constructor_args g in (* We then get the constructor corresponding to this branch and modifies the references has needed i.e. @@ -653,120 +728,136 @@ let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i *) let constructor = let constructor_num = i - !min_constr_number in - let length = Array.length (mib.Declarations.mind_packets.(!ind_number).Declarations.mind_consnames) in - if constructor_num <= length - then - begin - (kn,!ind_number),constructor_num - end - else - begin - incr ind_number; - min_constr_number := !min_constr_number + length ; - (kn,!ind_number),1 - end + let length = + Array.length + mib.Declarations.mind_packets.(!ind_number) + .Declarations.mind_consnames + in + if constructor_num <= length then ((kn, !ind_number), constructor_num) + else begin + incr ind_number; + min_constr_number := !min_constr_number + length; + ((kn, !ind_number), 1) + end in (* we can then build the final proof term *) - let app_constructor g = applist((mkConstructU(constructor,u)),constructor_args g) in + let app_constructor g = + applist (mkConstructU (constructor, u), constructor_args g) + in (* an apply the tactic *) - let res,hres = - match generate_fresh_id (Id.of_string "z") (ids(* @this_branche_ids *)) 2 with - | [res;hres] -> res,hres + let res, hres = + match + generate_fresh_id (Id.of_string "z") ids (* @this_branche_ids *) 2 + with + | [res; hres] -> (res, hres) | _ -> assert false in (* observe (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor); *) - ( - tclTHENLIST - [ - observe_tac ("h_intro_patterns ") (let l = (List.nth intro_pats (pred i)) in - match l with - | [] -> tclIDTAC - | _ -> Proofview.V82.of_tactic (intro_patterns false l)); - (* unfolding of all the defined variables introduced by this branch *) - (* observe_tac "unfolding" pre_tac; *) - (* $zeta$ normalizing of the conclusion *) - Proofview.V82.of_tactic (reduce - (Genredexpr.Cbv - { Redops.all_flags with - Genredexpr.rDelta = false ; - Genredexpr.rConst = [] - } - ) - Locusops.onConcl); - observe_tac ("toto ") tclIDTAC; - - (* introducing the result of the graph and the equality hypothesis *) - observe_tac "introducing" (tclMAP (fun x -> Proofview.V82.of_tactic (Simple.intro x)) [res;hres]); - (* replacing [res] with its value *) - observe_tac "rewriting res value" (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar hres))); - (* Conclusion *) - observe_tac "exact" (fun g -> - Proofview.V82.of_tactic (exact_check (app_constructor g)) g) - ] - ) + (tclTHENLIST + [ observe_tac "h_intro_patterns " + (let l = List.nth intro_pats (pred i) in + match l with + | [] -> tclIDTAC + | _ -> Proofview.V82.of_tactic (intro_patterns false l)) + ; (* unfolding of all the defined variables introduced by this branch *) + (* observe_tac "unfolding" pre_tac; *) + (* $zeta$ normalizing of the conclusion *) + Proofview.V82.of_tactic + (reduce + (Genredexpr.Cbv + { Redops.all_flags with + Genredexpr.rDelta = false + ; Genredexpr.rConst = [] }) + Locusops.onConcl) + ; observe_tac "toto " tclIDTAC + ; (* introducing the result of the graph and the equality hypothesis *) + observe_tac "introducing" + (tclMAP + (fun x -> Proofview.V82.of_tactic (Simple.intro x)) + [res; hres]) + ; (* replacing [res] with its value *) + observe_tac "rewriting res value" + (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar hres))) + ; (* Conclusion *) + observe_tac "exact" (fun g -> + Proofview.V82.of_tactic (exact_check (app_constructor g)) g) ]) g in (* end of branche proof *) let lemmas = Array.map - (fun ((_,(ctxt,concl))) -> - match ctxt with - | [] | [_] | [_;_] -> CErrors.anomaly (Pp.str "bad context.") - | hres::res::decl::ctxt -> - let res = EConstr.it_mkLambda_or_LetIn - (EConstr.it_mkProd_or_LetIn concl [hres;res]) - (LocalAssum (RelDecl.get_annot decl, RelDecl.get_type decl) :: ctxt) - in - res) + (fun (_, (ctxt, concl)) -> + match ctxt with + | [] | [_] | [_; _] -> CErrors.anomaly (Pp.str "bad context.") + | hres :: res :: decl :: ctxt -> + let res = + EConstr.it_mkLambda_or_LetIn + (EConstr.it_mkProd_or_LetIn concl [hres; res]) + ( LocalAssum (RelDecl.get_annot decl, RelDecl.get_type decl) + :: ctxt ) + in + res) lemmas_types_infos in let param_names = fst (List.chop princ_infos.nparams args_names) in let params = List.map mkVar param_names in - let lemmas = Array.to_list (Array.map (fun c -> applist(c,params)) lemmas) in + let lemmas = + Array.to_list (Array.map (fun c -> applist (c, params)) lemmas) + in (* The bindings of the principle that is the params of the principle and the different lemma types *) let bindings = - let params_bindings,avoid = + let params_bindings, avoid = List.fold_left2 - (fun (bindings,avoid) decl p -> - let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) (Id.Set.of_list avoid) in - p::bindings,id::avoid - ) - ([],pf_ids_of_hyps g) - princ_infos.params - (List.rev params) + (fun (bindings, avoid) decl p -> + let id = + Namegen.next_ident_away + (Nameops.Name.get_id (RelDecl.get_name decl)) + (Id.Set.of_list avoid) + in + (p :: bindings, id :: avoid)) + ([], pf_ids_of_hyps g) + princ_infos.params (List.rev params) in let lemmas_bindings = - List.rev (fst (List.fold_left2 - (fun (bindings,avoid) decl p -> - let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) (Id.Set.of_list avoid) in - (Reductionops.nf_zeta (pf_env g) (project g) p)::bindings,id::avoid) - ([],avoid) - princ_infos.predicates - (lemmas))) + List.rev + (fst + (List.fold_left2 + (fun (bindings, avoid) decl p -> + let id = + Namegen.next_ident_away + (Nameops.Name.get_id (RelDecl.get_name decl)) + (Id.Set.of_list avoid) + in + ( Reductionops.nf_zeta (pf_env g) (project g) p :: bindings + , id :: avoid )) + ([], avoid) princ_infos.predicates lemmas)) in - (params_bindings@lemmas_bindings) + params_bindings @ lemmas_bindings in tclTHENLIST - [ - observe_tac "principle" (Proofview.V82.of_tactic (assert_by - (Name principle_id) - princ_type - (exact_check f_principle))); - observe_tac "intro args_names" (tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) args_names); - (* observe_tac "titi" (pose_proof (Name (Id.of_string "__")) (Reductionops.nf_beta Evd.empty ((mkApp (mkVar principle_id,Array.of_list bindings))))); *) - observe_tac "idtac" tclIDTAC; - tclTHEN_i - (observe_tac - "functional_induction" ( - (fun gl -> - let term = mkApp (mkVar principle_id,Array.of_list bindings) in - let gl', _ty = pf_eapply (Typing.type_of ~refresh:true) gl term in - Proofview.V82.of_tactic (apply term) gl') - )) - (fun i g -> observe_tac ("proving branche "^string_of_int i) (prove_branche i) g ) - ] + [ observe_tac "principle" + (Proofview.V82.of_tactic + (assert_by (Name principle_id) princ_type + (exact_check f_principle))) + ; observe_tac "intro args_names" + (tclMAP + (fun id -> Proofview.V82.of_tactic (Simple.intro id)) + args_names) + ; (* observe_tac "titi" (pose_proof (Name (Id.of_string "__")) (Reductionops.nf_beta Evd.empty ((mkApp (mkVar principle_id,Array.of_list bindings))))); *) + observe_tac "idtac" tclIDTAC + ; tclTHEN_i + (observe_tac "functional_induction" (fun gl -> + let term = mkApp (mkVar principle_id, Array.of_list bindings) in + let gl', _ty = + pf_eapply (Typing.type_of ~refresh:true) gl term + in + Proofview.V82.of_tactic (apply term) gl')) + (fun i g -> + observe_tac + ("proving branche " ^ string_of_int i) + (prove_branche i) g) ] g (* [prove_fun_complete funs graphs schemes lemmas_types_infos i] @@ -803,13 +894,12 @@ let thin ids gl = Proofview.V82.of_tactic (Tactics.clear ids) gl *) let tauto = let open Ltac_plugin in - let dp = List.map Id.of_string ["Tauto" ; "Init"; "Coq"] in + let dp = List.map Id.of_string ["Tauto"; "Init"; "Coq"] in let mp = ModPath.MPfile (DirPath.make dp) in let kn = KerName.make mp (Label.make "tauto") in - Proofview.tclBIND (Proofview.tclUNIT ()) begin fun () -> - let body = Tacenv.interp_ltac kn in - Tacinterp.eval_tactic body - end + Proofview.tclBIND (Proofview.tclUNIT ()) (fun () -> + let body = Tacenv.interp_ltac kn in + Tacinterp.eval_tactic body) (* [generalize_dependent_of x hyp g] generalize every hypothesis which depends of [x] but [hyp] @@ -820,16 +910,18 @@ let generalize_dependent_of x hyp g = let open Tacticals in tclMAP (function - | LocalAssum ({Context.binder_name=id},t) when not (Id.equal id hyp) && - (Termops.occur_var (pf_env g) (project g) x t) -> - tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [EConstr.mkVar id])) (thin [id]) - | _ -> tclIDTAC - ) - (pf_hyps g) - g + | LocalAssum ({Context.binder_name = id}, t) + when (not (Id.equal id hyp)) + && Termops.occur_var (pf_env g) (project g) x t -> + tclTHEN + (Proofview.V82.of_tactic (Tactics.generalize [EConstr.mkVar id])) + (thin [id]) + | _ -> tclIDTAC) + (pf_hyps g) g let rec intros_with_rewrite g = observe_tac "intros_with_rewrite" intros_with_rewrite_aux g + and intros_with_rewrite_aux : Tacmach.tactic = let open Constr in let open EConstr in @@ -840,88 +932,111 @@ and intros_with_rewrite_aux : Tacmach.tactic = let eq_ind = make_eq () in let sigma = project g in match EConstr.kind sigma (pf_concl g) with - | Prod(_,t,t') -> - begin - match EConstr.kind sigma t with - | App(eq,args) when (EConstr.eq_constr sigma eq eq_ind) -> - if Reductionops.is_conv (pf_env g) (project g) args.(1) args.(2) - then - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); thin [id]; intros_with_rewrite ] g - else if isVar sigma args.(1) && (Environ.evaluable_named (destVar sigma args.(1)) (pf_env g)) - then tclTHENLIST[ - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(1)))]); - tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(1)))] ((destVar sigma args.(1)),Locus.InHyp) ))) - (pf_ids_of_hyps g); - intros_with_rewrite - ] g - else if isVar sigma args.(2) && (Environ.evaluable_named (destVar sigma args.(2)) (pf_env g)) - then tclTHENLIST[ - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(2)))]); - tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(2)))] ((destVar sigma args.(2)),Locus.InHyp) ))) - (pf_ids_of_hyps g); - intros_with_rewrite - ] g - else if isVar sigma args.(1) - then - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); - generalize_dependent_of (destVar sigma args.(1)) id; - tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))); - intros_with_rewrite - ] - g - else if isVar sigma args.(2) - then - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); - generalize_dependent_of (destVar sigma args.(2)) id; - tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar id))); - intros_with_rewrite - ] - g - else - begin - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST[ - Proofview.V82.of_tactic (Simple.intro id); - tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))); - intros_with_rewrite - ] g - end - | Ind _ when EConstr.eq_constr sigma t (EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.False.type")) -> - Proofview.V82.of_tactic tauto g - | Case(_,_,v,_) -> - tclTHENLIST[ - Proofview.V82.of_tactic (simplest_case v); - intros_with_rewrite - ] g - | LetIn _ -> - tclTHENLIST[ - Proofview.V82.of_tactic (reduce - (Genredexpr.Cbv - {Redops.all_flags - with Genredexpr.rDelta = false; - }) - Locusops.onConcl) - ; - intros_with_rewrite - ] g - | _ -> - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id);intros_with_rewrite] g - end + | Prod (_, t, t') -> ( + match EConstr.kind sigma t with + | App (eq, args) when EConstr.eq_constr sigma eq eq_ind -> + if Reductionops.is_conv (pf_env g) (project g) args.(1) args.(2) then + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST + [ Proofview.V82.of_tactic (Simple.intro id) + ; thin [id] + ; intros_with_rewrite ] + g + else if + isVar sigma args.(1) + && Environ.evaluable_named (destVar sigma args.(1)) (pf_env g) + then + tclTHENLIST + [ Proofview.V82.of_tactic + (unfold_in_concl + [ ( Locus.AllOccurrences + , Names.EvalVarRef (destVar sigma args.(1)) ) ]) + ; tclMAP + (fun id -> + tclTRY + (Proofview.V82.of_tactic + (unfold_in_hyp + [ ( Locus.AllOccurrences + , Names.EvalVarRef (destVar sigma args.(1)) ) ] + (destVar sigma args.(1), Locus.InHyp)))) + (pf_ids_of_hyps g) + ; intros_with_rewrite ] + g + else if + isVar sigma args.(2) + && Environ.evaluable_named (destVar sigma args.(2)) (pf_env g) + then + tclTHENLIST + [ Proofview.V82.of_tactic + (unfold_in_concl + [ ( Locus.AllOccurrences + , Names.EvalVarRef (destVar sigma args.(2)) ) ]) + ; tclMAP + (fun id -> + tclTRY + (Proofview.V82.of_tactic + (unfold_in_hyp + [ ( Locus.AllOccurrences + , Names.EvalVarRef (destVar sigma args.(2)) ) ] + (destVar sigma args.(2), Locus.InHyp)))) + (pf_ids_of_hyps g) + ; intros_with_rewrite ] + g + else if isVar sigma args.(1) then + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST + [ Proofview.V82.of_tactic (Simple.intro id) + ; generalize_dependent_of (destVar sigma args.(1)) id + ; tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))) + ; intros_with_rewrite ] + g + else if isVar sigma args.(2) then + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST + [ Proofview.V82.of_tactic (Simple.intro id) + ; generalize_dependent_of (destVar sigma args.(2)) id + ; tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar id))) + ; intros_with_rewrite ] + g + else + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST + [ Proofview.V82.of_tactic (Simple.intro id) + ; tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))) + ; intros_with_rewrite ] + g + | Ind _ + when EConstr.eq_constr sigma t + (EConstr.of_constr + ( UnivGen.constr_of_monomorphic_global + @@ Coqlib.lib_ref "core.False.type" )) -> + Proofview.V82.of_tactic tauto g + | Case (_, _, v, _) -> + tclTHENLIST + [Proofview.V82.of_tactic (simplest_case v); intros_with_rewrite] + g + | LetIn _ -> + tclTHENLIST + [ Proofview.V82.of_tactic + (reduce + (Genredexpr.Cbv + {Redops.all_flags with Genredexpr.rDelta = false}) + Locusops.onConcl) + ; intros_with_rewrite ] + g + | _ -> + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST + [Proofview.V82.of_tactic (Simple.intro id); intros_with_rewrite] + g ) | LetIn _ -> - tclTHENLIST[ - Proofview.V82.of_tactic (reduce - (Genredexpr.Cbv - {Redops.all_flags - with Genredexpr.rDelta = false; - }) - Locusops.onConcl) - ; - intros_with_rewrite - ] g + tclTHENLIST + [ Proofview.V82.of_tactic + (reduce + (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false}) + Locusops.onConcl) + ; intros_with_rewrite ] + g | _ -> tclIDTAC g let rec reflexivity_with_destruct_cases g = @@ -932,52 +1047,66 @@ let rec reflexivity_with_destruct_cases g = let open Tacticals in let destruct_case () = try - match EConstr.kind (project g) (snd (destApp (project g) (pf_concl g))).(2) with - | Case(_,_,v,_) -> - tclTHENLIST[ - Proofview.V82.of_tactic (simplest_case v); - Proofview.V82.of_tactic intros; - observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases - ] + match + EConstr.kind (project g) (snd (destApp (project g) (pf_concl g))).(2) + with + | Case (_, _, v, _) -> + tclTHENLIST + [ Proofview.V82.of_tactic (simplest_case v) + ; Proofview.V82.of_tactic intros + ; observe_tac "reflexivity_with_destruct_cases" + reflexivity_with_destruct_cases ] | _ -> Proofview.V82.of_tactic reflexivity with e when CErrors.noncritical e -> Proofview.V82.of_tactic reflexivity in let eq_ind = make_eq () in - let my_inj_flags = Some { - Equality.keep_proof_equalities = false; - injection_in_context = false; (* for compatibility, necessary *) - injection_pattern_l2r_order = false; (* probably does not matter; except maybe with dependent hyps *) - } in + let my_inj_flags = + Some + { Equality.keep_proof_equalities = false + ; injection_in_context = false + ; (* for compatibility, necessary *) + injection_pattern_l2r_order = + false (* probably does not matter; except maybe with dependent hyps *) + } + in let discr_inject = - Tacticals.onAllHypsAndConcl ( - fun sc g -> + Tacticals.onAllHypsAndConcl (fun sc g -> match sc with - None -> tclIDTAC g - | Some id -> + | None -> tclIDTAC g + | Some id -> ( match EConstr.kind (project g) (pf_get_hyp_typ g id) with - | App(eq,[|_;t1;t2|]) when EConstr.eq_constr (project g) eq eq_ind -> - if Equality.discriminable (pf_env g) (project g) t1 t2 - then Proofview.V82.of_tactic (Equality.discrHyp id) g - else if Equality.injectable (pf_env g) (project g) ~keep_proofs:None t1 t2 - then tclTHENLIST [Proofview.V82.of_tactic (Equality.injHyp my_inj_flags None id);thin [id];intros_with_rewrite] g + | App (eq, [|_; t1; t2|]) when EConstr.eq_constr (project g) eq eq_ind + -> + if Equality.discriminable (pf_env g) (project g) t1 t2 then + Proofview.V82.of_tactic (Equality.discrHyp id) g + else if + Equality.injectable (pf_env g) (project g) ~keep_proofs:None t1 t2 + then + tclTHENLIST + [ Proofview.V82.of_tactic (Equality.injHyp my_inj_flags None id) + ; thin [id] + ; intros_with_rewrite ] + g else tclIDTAC g - | _ -> tclIDTAC g - ) + | _ -> tclIDTAC g )) in (tclFIRST - [ observe_tac "reflexivity_with_destruct_cases : reflexivity" (Proofview.V82.of_tactic reflexivity); - observe_tac "reflexivity_with_destruct_cases : destruct_case" ((destruct_case ())); - (* We reach this point ONLY if - the same value is matched (at least) two times - along binding path. - In this case, either we have a discriminable hypothesis and we are done, - either at least an injectable one and we do the injection before continuing + [ observe_tac "reflexivity_with_destruct_cases : reflexivity" + (Proofview.V82.of_tactic reflexivity) + ; observe_tac "reflexivity_with_destruct_cases : destruct_case" + (destruct_case ()) + ; (* We reach this point ONLY if + the same value is matched (at least) two times + along binding path. + In this case, either we have a discriminable hypothesis and we are done, + either at least an injectable one and we do the injection before continuing *) - observe_tac "reflexivity_with_destruct_cases : others" (tclTHEN (tclPROGRESS discr_inject ) reflexivity_with_destruct_cases) - ]) + observe_tac "reflexivity_with_destruct_cases : others" + (tclTHEN (tclPROGRESS discr_inject) reflexivity_with_destruct_cases) ]) g -let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tactic = +let prove_fun_complete funcs graphs schemes lemmas_types_infos i : + Tacmach.tactic = let open EConstr in let open Tacmach in let open Tactics in @@ -988,12 +1117,17 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tacti *) let lemmas = Array.map - (fun (_,(ctxt,concl)) -> Reductionops.nf_zeta (pf_env g) (project g) (EConstr.it_mkLambda_or_LetIn concl ctxt)) + (fun (_, (ctxt, concl)) -> + Reductionops.nf_zeta (pf_env g) (project g) + (EConstr.it_mkLambda_or_LetIn concl ctxt)) lemmas_types_infos in (* We get the constant and the principle corresponding to this lemma *) let f = funcs.(i) in - let graph_principle = Reductionops.nf_zeta (pf_env g) (project g) (EConstr.of_constr schemes.(i)) in + let graph_principle = + Reductionops.nf_zeta (pf_env g) (project g) + (EConstr.of_constr schemes.(i)) + in let g, princ_type = tac_type_of g graph_principle in let princ_infos = Tactics.compute_elim_sig (project g) princ_type in (* Then we get the number of argument of the function @@ -1001,24 +1135,24 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tacti *) let nb_fun_args = Termops.nb_prod (project g) (pf_concl g) - 2 in let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in - let ids = args_names@(pf_ids_of_hyps g) in + let ids = args_names @ pf_ids_of_hyps g in (* and fresh names for res H and the principle (cf bug bug #1174) *) - let res,hres,graph_principle_id = + let res, hres, graph_principle_id = match generate_fresh_id (Id.of_string "z") ids 3 with - | [res;hres;graph_principle_id] -> res,hres,graph_principle_id + | [res; hres; graph_principle_id] -> (res, hres, graph_principle_id) | _ -> assert false in - let ids = res::hres::graph_principle_id::ids in + let ids = res :: hres :: graph_principle_id :: ids in (* we also compute fresh names for each hyptohesis of each branch of the principle *) let branches = List.rev princ_infos.branches in let intro_pats = List.map (fun decl -> - List.map - (fun id -> id) - (generate_fresh_id (Id.of_string "y") ids (Termops.nb_prod (project g) (RelDecl.get_type decl))) - ) + List.map + (fun id -> id) + (generate_fresh_id (Id.of_string "y") ids + (Termops.nb_prod (project g) (RelDecl.get_type decl)))) branches in (* We will need to change the function by its body @@ -1027,34 +1161,38 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tacti *) let rewrite_tac j ids : Tacmach.tactic = let graph_def = graphs.(j) in - let infos = match find_Function_infos (fst (destConst (project g) funcs.(j))) with - | None -> - CErrors.user_err Pp.(str "No graph found") + let infos = + match find_Function_infos (fst (destConst (project g) funcs.(j))) with + | None -> CErrors.user_err Pp.(str "No graph found") | Some infos -> infos in - if infos.is_general || Rtree.is_infinite Declareops.eq_recarg graph_def.Declarations.mind_recargs + if + infos.is_general + || Rtree.is_infinite Declareops.eq_recarg + graph_def.Declarations.mind_recargs then let eq_lemma = - try Option.get (infos).equation_lemma - with Option.IsNone -> CErrors.anomaly (Pp.str "Cannot find equation lemma.") + try Option.get infos.equation_lemma + with Option.IsNone -> + CErrors.anomaly (Pp.str "Cannot find equation lemma.") in - tclTHENLIST[ - tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) ids; - Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_lemma)); - (* Don't forget to $\zeta$ normlize the term since the principles - have been $\zeta$-normalized *) - Proofview.V82.of_tactic (reduce - (Genredexpr.Cbv - {Redops.all_flags - with Genredexpr.rDelta = false; - }) - Locusops.onConcl) - ; - Proofview.V82.of_tactic (generalize (List.map mkVar ids)); - thin ids - ] + tclTHENLIST + [ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) ids + ; Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_lemma)) + ; (* Don't forget to $\zeta$ normlize the term since the principles + have been $\zeta$-normalized *) + Proofview.V82.of_tactic + (reduce + (Genredexpr.Cbv + {Redops.all_flags with Genredexpr.rDelta = false}) + Locusops.onConcl) + ; Proofview.V82.of_tactic (generalize (List.map mkVar ids)) + ; thin ids ] else - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst (destConst (project g) f)))]) + Proofview.V82.of_tactic + (unfold_in_concl + [ ( Locus.AllOccurrences + , Names.EvalConstRef (fst (destConst (project g) f)) ) ]) in (* The proof of each branche itself *) let ind_number = ref 0 in @@ -1063,40 +1201,49 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tacti (* we fist compute the inductive corresponding to the branch *) let this_ind_number = let constructor_num = i - !min_constr_number in - let length = Array.length (graphs.(!ind_number).Declarations.mind_consnames) in - if constructor_num <= length - then !ind_number - else - begin - incr ind_number; - min_constr_number := !min_constr_number + length; - !ind_number - end + let length = + Array.length graphs.(!ind_number).Declarations.mind_consnames + in + if constructor_num <= length then !ind_number + else begin + incr ind_number; + min_constr_number := !min_constr_number + length; + !ind_number + end in let this_branche_ids = List.nth intro_pats (pred i) in - tclTHENLIST[ - (* we expand the definition of the function *) - observe_tac "rewrite_tac" (rewrite_tac this_ind_number this_branche_ids); - (* introduce hypothesis with some rewrite *) - observe_tac "intros_with_rewrite (all)" intros_with_rewrite; - (* The proof is (almost) complete *) - observe_tac "reflexivity" (reflexivity_with_destruct_cases) - ] + tclTHENLIST + [ (* we expand the definition of the function *) + observe_tac "rewrite_tac" + (rewrite_tac this_ind_number this_branche_ids) + ; (* introduce hypothesis with some rewrite *) + observe_tac "intros_with_rewrite (all)" intros_with_rewrite + ; (* The proof is (almost) complete *) + observe_tac "reflexivity" reflexivity_with_destruct_cases ] g in let params_names = fst (List.chop princ_infos.nparams args_names) in let open EConstr in let params = List.map mkVar params_names in tclTHENLIST - [ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) (args_names@[res;hres]); - observe_tac "h_generalize" - (Proofview.V82.of_tactic (generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)])); - Proofview.V82.of_tactic (Simple.intro graph_principle_id); - observe_tac "" (tclTHEN_i - (observe_tac "elim" (Proofview.V82.of_tactic (elim false None (mkVar hres, Tactypes.NoBindings) - (Some (mkVar graph_principle_id, Tactypes.NoBindings))))) - (fun i g -> observe_tac "prove_branche" (prove_branche i) g )) - ] + [ tclMAP + (fun id -> Proofview.V82.of_tactic (Simple.intro id)) + (args_names @ [res; hres]) + ; observe_tac "h_generalize" + (Proofview.V82.of_tactic + (generalize + [ mkApp + ( applist (graph_principle, params) + , Array.map (fun c -> applist (c, params)) lemmas ) ])) + ; Proofview.V82.of_tactic (Simple.intro graph_principle_id) + ; observe_tac "" + (tclTHEN_i + (observe_tac "elim" + (Proofview.V82.of_tactic + (elim false None + (mkVar hres, Tactypes.NoBindings) + (Some (mkVar graph_principle_id, Tactypes.NoBindings))))) + (fun i g -> observe_tac "prove_branche" (prove_branche i) g)) ] g exception No_graph_found @@ -1104,35 +1251,35 @@ exception No_graph_found let get_funs_constant mp = let open Constr in let exception Not_Rec in - let get_funs_constant const e : (Names.Constant.t*int) array = + let get_funs_constant const e : (Names.Constant.t * int) array = match Constr.kind (Term.strip_lam e) with - | Fix((_,(na,_,_))) -> + | Fix (_, (na, _, _)) -> Array.mapi (fun i na -> - match na.Context.binder_name with - | Name id -> - let const = Constant.make2 mp (Label.of_id id) in - const,i - | Anonymous -> - CErrors.anomaly (Pp.str "Anonymous fix.") - ) + match na.Context.binder_name with + | Name id -> + let const = Constant.make2 mp (Label.of_id id) in + (const, i) + | Anonymous -> CErrors.anomaly (Pp.str "Anonymous fix.")) na - | _ -> [|const,0|] + | _ -> [|(const, 0)|] in - function const -> + function + | const -> let find_constant_body const = match Global.body_of_constant Library.indirect_accessor const with - | Some (body, _, _) -> - let body = Tacred.cbv_norm_flags - (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) - (Global.env ()) - (Evd.from_env (Global.env ())) - (EConstr.of_constr body) - in - let body = EConstr.Unsafe.to_constr body in - body - | None -> - CErrors.user_err Pp.(str ( "Cannot define a principle over an axiom ")) + | Some (body, _, _) -> + let body = + Tacred.cbv_norm_flags + (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) + (Global.env ()) + (Evd.from_env (Global.env ())) + (EConstr.of_constr body) + in + let body = EConstr.Unsafe.to_constr body in + body + | None -> + CErrors.user_err Pp.(str "Cannot define a principle over an axiom ") in let f = find_constant_body const in let l_const = get_funs_constant const f in @@ -1140,17 +1287,24 @@ let get_funs_constant mp = We need to check that all the functions found are in the same block to prevent Reset strange thing *) - let l_bodies = List.map find_constant_body (Array.to_list (Array.map fst l_const)) in - let l_params,l_fixes = List.split (List.map Term.decompose_lam l_bodies) in + let l_bodies = + List.map find_constant_body (Array.to_list (Array.map fst l_const)) + in + let l_params, _l_fixes = + List.split (List.map Term.decompose_lam l_bodies) + in (* all the parameters must be equal*) let _check_params = - let first_params = List.hd l_params in + let first_params = List.hd l_params in List.iter (fun params -> - if not (List.equal (fun (n1, c1) (n2, c2) -> - Context.eq_annot Name.equal n1 n2 && Constr.equal c1 c2) first_params params) - then CErrors.user_err Pp.(str "Not a mutal recursive block") - ) + if + not + (List.equal + (fun (n1, c1) (n2, c2) -> + Context.eq_annot Name.equal n1 n2 && Constr.equal c1 c2) + first_params params) + then CErrors.user_err Pp.(str "Not a mutal recursive block")) l_params in (* The bodies has to be very similar *) @@ -1158,27 +1312,30 @@ let get_funs_constant mp = try let extract_info is_first body = match Constr.kind body with - | Fix((idxs,_),(na,ta,ca)) -> (idxs,na,ta,ca) - | _ -> - if is_first && Int.equal (List.length l_bodies) 1 - then raise Not_Rec - else CErrors.user_err Pp.(str "Not a mutal recursive block") + | Fix ((idxs, _), (na, ta, ca)) -> (idxs, na, ta, ca) + | _ -> + if is_first && Int.equal (List.length l_bodies) 1 then raise Not_Rec + else CErrors.user_err Pp.(str "Not a mutal recursive block") in let first_infos = extract_info true (List.hd l_bodies) in - let check body = (* Hope this is correct *) + let check body = + (* Hope this is correct *) let eq_infos (ia1, na1, ta1, ca1) (ia2, na2, ta2, ca2) = - Array.equal Int.equal ia1 ia2 && Array.equal (Context.eq_annot Name.equal) na1 na2 && - Array.equal Constr.equal ta1 ta2 && Array.equal Constr.equal ca1 ca2 + Array.equal Int.equal ia1 ia2 + && Array.equal (Context.eq_annot Name.equal) na1 na2 + && Array.equal Constr.equal ta1 ta2 + && Array.equal Constr.equal ca1 ca2 in - if not (eq_infos first_infos (extract_info false body)) - then CErrors.user_err Pp.(str "Not a mutal recursive block") + if not (eq_infos first_infos (extract_info false body)) then + CErrors.user_err Pp.(str "Not a mutal recursive block") in List.iter check l_bodies with Not_Rec -> () in l_const -let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : Evd.side_effects Declare.proof_entry list = +let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : + Evd.side_effects Declare.proof_entry list = let exception Found_type of int in let env = Global.env () in let funs = List.map fst fas in @@ -1190,42 +1347,47 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : Evd.side_ef | Some finfos -> fst finfos.graph_ind in let this_block_funs_indexes = get_funs_constant funs_mp (fst first_fun) in - let this_block_funs = Array.map (fun (c,_) -> (c,snd first_fun)) this_block_funs_indexes in + let this_block_funs = + Array.map (fun (c, _) -> (c, snd first_fun)) this_block_funs_indexes + in let prop_sort = Sorts.InProp in let funs_indexes = let this_block_funs_indexes = Array.to_list this_block_funs_indexes in List.map - (function cst -> List.assoc_f Constant.equal (fst cst) this_block_funs_indexes) + (function + | cst -> List.assoc_f Constant.equal (fst cst) this_block_funs_indexes) funs in let ind_list = List.map - (fun (idx) -> - let ind = first_fun_kn,idx in - (ind,snd first_fun),true,prop_sort - ) + (fun idx -> + let ind = (first_fun_kn, idx) in + ((ind, snd first_fun), true, prop_sort)) funs_indexes in - let sigma, schemes = - Indrec.build_mutual_induction_scheme env !evd ind_list - in + let sigma, schemes = Indrec.build_mutual_induction_scheme env !evd ind_list in let _ = evd := sigma in let l_schemes = - List.map (EConstr.of_constr %> Retyping.get_type_of env sigma %> EConstr.Unsafe.to_constr) schemes + List.map + ( EConstr.of_constr + %> Retyping.get_type_of env sigma + %> EConstr.Unsafe.to_constr ) + schemes in let i = ref (-1) in let sorts = - List.rev_map (fun (_,x) -> + List.rev_map + (fun (_, x) -> let sigma, fs = Evd.fresh_sort_in_family !evd x in - evd := sigma; fs - ) + evd := sigma; + fs) fas in (* We create the first principle by tactic *) - let first_type,other_princ_types = + let first_type, other_princ_types = match l_schemes with - s::l_schemes -> s,l_schemes - | _ -> CErrors.anomaly (Pp.str "") + | s :: l_schemes -> (s, l_schemes) + | _ -> CErrors.anomaly (Pp.str "") in let opaque = let finfos = @@ -1233,282 +1395,298 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : Evd.side_ef | None -> raise Not_found | Some finfos -> finfos in - let open Proof_global in + let open Declare in match finfos.equation_lemma with | None -> Transparent (* non recursive definition *) | Some equation -> - if Declareops.is_opaque (Global.lookup_constant equation) then Opaque else Transparent + if Declareops.is_opaque (Global.lookup_constant equation) then Opaque + else Transparent in let entry, _hook = try - build_functional_principle ~opaque evd false - first_type - (Array.of_list sorts) - this_block_funs - 0 - (Functional_principles_proofs.prove_princ_for_struct evd false 0 (Array.of_list (List.map fst funs))) + build_functional_principle ~opaque evd first_type (Array.of_list sorts) + this_block_funs 0 + (Functional_principles_proofs.prove_princ_for_struct evd false 0 + (Array.of_list (List.map fst funs))) (fun _ _ -> ()) - with e when CErrors.noncritical e -> - raise (Defining_principle e) - + with e when CErrors.noncritical e -> raise (Defining_principle e) in incr i; (* The others are just deduced *) - if List.is_empty other_princ_types - then [entry] + if List.is_empty other_princ_types then [entry] else let other_fun_princ_types = let funs = Array.map Constr.mkConstU this_block_funs in let sorts = Array.of_list sorts in - List.map (Functional_principles_types.compute_new_princ_type_from_rel funs sorts) other_princ_types + List.map + (Functional_principles_types.compute_new_princ_type_from_rel funs sorts) + other_princ_types in - let first_princ_body,first_princ_type = Declare.(entry.proof_entry_body, entry.proof_entry_type) in - let ctxt,fix = Term.decompose_lam_assum (fst(fst(Future.force first_princ_body))) in (* the principle has for forall ...., fix .*) - let (idxs,_),(_,ta,_ as decl) = Constr.destFix fix in + let first_princ_body = entry.Declare.proof_entry_body in + let ctxt, fix = + Term.decompose_lam_assum (fst (fst (Future.force first_princ_body))) + in + (* the principle has for forall ...., fix .*) + let (idxs, _), ((_, ta, _) as decl) = Constr.destFix fix in let other_result = List.map (* we can now compute the other principles *) (fun scheme_type -> - incr i; - observe (Printer.pr_lconstr_env env sigma scheme_type); - let type_concl = (Term.strip_prod_assum scheme_type) in - let applied_f = List.hd (List.rev (snd (Constr.decompose_app type_concl))) in - let f = fst (Constr.decompose_app applied_f) in - try (* we search the number of the function in the fix block (name of the function) *) - Array.iteri - (fun j t -> - let t = (Term.strip_prod_assum t) in - let applied_g = List.hd (List.rev (snd (Constr.decompose_app t))) in + incr i; + observe (Printer.pr_lconstr_env env sigma scheme_type); + let type_concl = Term.strip_prod_assum scheme_type in + let applied_f = + List.hd (List.rev (snd (Constr.decompose_app type_concl))) + in + let f = fst (Constr.decompose_app applied_f) in + try + (* we search the number of the function in the fix block (name of the function) *) + Array.iteri + (fun j t -> + let t = Term.strip_prod_assum t in + let applied_g = + List.hd (List.rev (snd (Constr.decompose_app t))) + in let g = fst (Constr.decompose_app applied_g) in - if Constr.equal f g - then raise (Found_type j); - observe Pp.(Printer.pr_lconstr_env env sigma f ++ str " <> " ++ - Printer.pr_lconstr_env env sigma g) - - ) - ta; - (* If we reach this point, the two principle are not mutually recursive - We fall back to the previous method - *) - let entry, _hook = - build_functional_principle - evd - false - (List.nth other_princ_types (!i - 1)) - (Array.of_list sorts) - this_block_funs - !i - (Functional_principles_proofs.prove_princ_for_struct evd false !i (Array.of_list (List.map fst funs))) - (fun _ _ -> ()) - in - entry - with Found_type i -> - let princ_body = - Termops.it_mkLambda_or_LetIn (Constr.mkFix((idxs,i),decl)) ctxt - in - Declare.definition_entry ~types:scheme_type princ_body - ) - other_fun_princ_types + if Constr.equal f g then raise (Found_type j); + observe + Pp.( + Printer.pr_lconstr_env env sigma f + ++ str " <> " + ++ Printer.pr_lconstr_env env sigma g)) + ta; + (* If we reach this point, the two principle are not mutually recursive + We fall back to the previous method + *) + let entry, _hook = + build_functional_principle evd + (List.nth other_princ_types (!i - 1)) + (Array.of_list sorts) this_block_funs !i + (Functional_principles_proofs.prove_princ_for_struct evd false + !i + (Array.of_list (List.map fst funs))) + (fun _ _ -> ()) + in + entry + with Found_type i -> + let princ_body = + Termops.it_mkLambda_or_LetIn (Constr.mkFix ((idxs, i), decl)) ctxt + in + Declare.definition_entry ~types:scheme_type princ_body) + other_fun_princ_types in - entry::other_result + entry :: other_result (* [derive_correctness funs graphs] create correctness and completeness lemmas for each function in [funs] w.r.t. [graphs] *) -let derive_correctness (funs: Constr.pconstant list) (graphs:inductive list) = +let derive_correctness (funs : Constr.pconstant list) (graphs : inductive list) + = let open EConstr in assert (funs <> []); assert (graphs <> []); let funs = Array.of_list funs and graphs = Array.of_list graphs in let map (c, u) = mkConstU (c, EInstance.make u) in - let funs_constr = Array.map map funs in + let funs_constr = Array.map map funs in (* XXX STATE Why do we need this... why is the toplevel protection not enough *) funind_purify (fun () -> - let env = Global.env () in - let evd = ref (Evd.from_env env) in - let graphs_constr = Array.map mkInd graphs in - let lemmas_types_infos = - Util.Array.map2_i - (fun i f_constr graph -> - (* let const_of_f,u = destConst f_constr in *) - let (type_of_lemma_ctxt,type_of_lemma_concl,graph) = - generate_type evd false f_constr graph i - in - let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in - graphs_constr.(i) <- graph; - let type_of_lemma = EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in - let sigma, _ = Typing.type_of (Global.env ()) !evd type_of_lemma in - evd := sigma; - let type_of_lemma = Reductionops.nf_zeta (Global.env ()) !evd type_of_lemma in - observe Pp.(str "type_of_lemma := " ++ Printer.pr_leconstr_env (Global.env ()) !evd type_of_lemma); - type_of_lemma,type_info - ) - funs_constr - graphs_constr - in - let schemes = - (* The functional induction schemes are computed and not saved if there is more that one function - if the block contains only one function we can safely reuse [f_rect] - *) - try - if not (Int.equal (Array.length funs_constr) 1) then raise Not_found; - [| find_induction_principle evd funs_constr.(0) |] - with Not_found -> - ( - - Array.of_list - (List.map - (fun entry -> - (EConstr.of_constr (fst (fst (Future.force entry.Declare.proof_entry_body))), - EConstr.of_constr (Option.get entry.Declare.proof_entry_type )) - ) - (make_scheme evd (Array.map_to_list (fun const -> const,Sorts.InType) funs)) - ) - ) - in - let proving_tac = - prove_fun_correct !evd funs_constr graphs_constr schemes lemmas_types_infos - in - Array.iteri - (fun i f_as_constant -> - let f_id = Label.to_id (Constant.label (fst f_as_constant)) in - (*i The next call to mk_correct_id is valid since we are constructing the lemma - Ensures by: obvious - i*) - let lem_id = mk_correct_id f_id in - let (typ,_) = lemmas_types_infos.(i) in - let lemma = Lemmas.start_lemma ~name:lem_id ~poly:false !evd typ in - let lemma = fst @@ Lemmas.by - (Proofview.V82.tactic (proving_tac i)) lemma in - let () = Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Transparent ~idopt:None in - let finfo = - match find_Function_infos (fst f_as_constant) with - | None -> raise Not_found - | Some finfo -> finfo + let env = Global.env () in + let evd = ref (Evd.from_env env) in + let graphs_constr = Array.map mkInd graphs in + let lemmas_types_infos = + Util.Array.map2_i + (fun i f_constr graph -> + let type_of_lemma_ctxt, type_of_lemma_concl, graph = + generate_type evd false f_constr graph in - (* let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in *) - let _,lem_cst_constr = Evd.fresh_global - (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in - let (lem_cst,_) = EConstr.destConst !evd lem_cst_constr in - update_Function {finfo with correctness_lemma = Some lem_cst}; - - ) - funs; - let lemmas_types_infos = - Util.Array.map2_i - (fun i f_constr graph -> - let (type_of_lemma_ctxt,type_of_lemma_concl,graph) = - generate_type evd true f_constr graph i - in - let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in - graphs_constr.(i) <- graph; - let type_of_lemma = - EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt - in - let type_of_lemma = Reductionops.nf_zeta env !evd type_of_lemma in - observe Pp.(str "type_of_lemma := " ++ Printer.pr_leconstr_env env !evd type_of_lemma); - type_of_lemma,type_info - ) - funs_constr - graphs_constr - in - - let (kn,_) as graph_ind,u = (destInd !evd graphs_constr.(0)) in - let mib,mip = Global.lookup_inductive graph_ind in - let sigma, scheme = - (Indrec.build_mutual_induction_scheme (Global.env ()) !evd - (Array.to_list - (Array.mapi - (fun i _ -> ((kn,i), EInstance.kind !evd u),true, Sorts.InType) - mib.Declarations.mind_packets - ) - ) - ) - in - let schemes = - Array.of_list scheme - in - let proving_tac = - prove_fun_complete funs_constr mib.Declarations.mind_packets schemes lemmas_types_infos - in - Array.iteri - (fun i f_as_constant -> - let f_id = Label.to_id (Constant.label (fst f_as_constant)) in - (*i The next call to mk_complete_id is valid since we are constructing the lemma - Ensures by: obvious - i*) - let lem_id = mk_complete_id f_id in - let lemma = Lemmas.start_lemma ~name:lem_id ~poly:false sigma (fst lemmas_types_infos.(i)) in - let lemma = fst (Lemmas.by - (Proofview.V82.tactic (observe_tac ("prove completeness ("^(Id.to_string f_id)^")") - (proving_tac i))) lemma) in - let () = Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Transparent ~idopt:None in - let finfo = - match find_Function_infos (fst f_as_constant) with - | None -> raise Not_found - | Some finfo -> finfo + let type_info = (type_of_lemma_ctxt, type_of_lemma_concl) in + graphs_constr.(i) <- graph; + let type_of_lemma = + EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in - let _,lem_cst_constr = Evd.fresh_global - (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in - let (lem_cst,_) = destConst !evd lem_cst_constr in - update_Function {finfo with completeness_lemma = Some lem_cst} - ) - funs) + let sigma, _ = Typing.type_of (Global.env ()) !evd type_of_lemma in + evd := sigma; + let type_of_lemma = + Reductionops.nf_zeta (Global.env ()) !evd type_of_lemma + in + observe + Pp.( + str "type_of_lemma := " + ++ Printer.pr_leconstr_env (Global.env ()) !evd type_of_lemma); + (type_of_lemma, type_info)) + funs_constr graphs_constr + in + let schemes = + (* The functional induction schemes are computed and not saved if there is more that one function + if the block contains only one function we can safely reuse [f_rect] + *) + try + if not (Int.equal (Array.length funs_constr) 1) then raise Not_found; + [|find_induction_principle evd funs_constr.(0)|] + with Not_found -> + Array.of_list + (List.map + (fun entry -> + ( EConstr.of_constr + (fst (fst (Future.force entry.Declare.proof_entry_body))) + , EConstr.of_constr (Option.get entry.Declare.proof_entry_type) + )) + (make_scheme evd + (Array.map_to_list (fun const -> (const, Sorts.InType)) funs))) + in + let proving_tac = + prove_fun_correct !evd graphs_constr schemes lemmas_types_infos + in + Array.iteri + (fun i f_as_constant -> + let f_id = Label.to_id (Constant.label (fst f_as_constant)) in + (*i The next call to mk_correct_id is valid since we are constructing the lemma + Ensures by: obvious + i*) + let lem_id = mk_correct_id f_id in + let typ, _ = lemmas_types_infos.(i) in + let lemma = Lemmas.start_lemma ~name:lem_id ~poly:false !evd typ in + let lemma = + fst @@ Lemmas.by (Proofview.V82.tactic (proving_tac i)) lemma + in + let () = + Lemmas.save_lemma_proved ~lemma ~opaque:Declare.Transparent + ~idopt:None + in + let finfo = + match find_Function_infos (fst f_as_constant) with + | None -> raise Not_found + | Some finfo -> finfo + in + (* let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in *) + let _, lem_cst_constr = + Evd.fresh_global (Global.env ()) !evd + (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) + in + let lem_cst, _ = EConstr.destConst !evd lem_cst_constr in + update_Function {finfo with correctness_lemma = Some lem_cst}) + funs; + let lemmas_types_infos = + Util.Array.map2_i + (fun i f_constr graph -> + let type_of_lemma_ctxt, type_of_lemma_concl, graph = + generate_type evd true f_constr graph + in + let type_info = (type_of_lemma_ctxt, type_of_lemma_concl) in + graphs_constr.(i) <- graph; + let type_of_lemma = + EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt + in + let type_of_lemma = Reductionops.nf_zeta env !evd type_of_lemma in + observe + Pp.( + str "type_of_lemma := " + ++ Printer.pr_leconstr_env env !evd type_of_lemma); + (type_of_lemma, type_info)) + funs_constr graphs_constr + in + let ((kn, _) as graph_ind), u = destInd !evd graphs_constr.(0) in + let mib, _mip = Global.lookup_inductive graph_ind in + let sigma, scheme = + Indrec.build_mutual_induction_scheme (Global.env ()) !evd + (Array.to_list + (Array.mapi + (fun i _ -> + (((kn, i), EInstance.kind !evd u), true, Sorts.InType)) + mib.Declarations.mind_packets)) + in + let schemes = Array.of_list scheme in + let proving_tac = + prove_fun_complete funs_constr mib.Declarations.mind_packets schemes + lemmas_types_infos + in + Array.iteri + (fun i f_as_constant -> + let f_id = Label.to_id (Constant.label (fst f_as_constant)) in + (*i The next call to mk_complete_id is valid since we are constructing the lemma + Ensures by: obvious + i*) + let lem_id = mk_complete_id f_id in + let lemma = + Lemmas.start_lemma ~name:lem_id ~poly:false sigma + (fst lemmas_types_infos.(i)) + in + let lemma = + fst + (Lemmas.by + (Proofview.V82.tactic + (observe_tac + ("prove completeness (" ^ Id.to_string f_id ^ ")") + (proving_tac i))) + lemma) + in + let () = + Lemmas.save_lemma_proved ~lemma ~opaque:Declare.Transparent + ~idopt:None + in + let finfo = + match find_Function_infos (fst f_as_constant) with + | None -> raise Not_found + | Some finfo -> finfo + in + let _, lem_cst_constr = + Evd.fresh_global (Global.env ()) !evd + (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) + in + let lem_cst, _ = destConst !evd lem_cst_constr in + update_Function {finfo with completeness_lemma = Some lem_cst}) + funs) () let warn_funind_cannot_build_inversion = CWarnings.create ~name:"funind-cannot-build-inversion" ~category:"funind" - Pp.(fun e' -> strbrk "Cannot build inversion information" ++ - if do_observe () then (fnl() ++ CErrors.print e') else mt ()) + Pp.( + fun e' -> + strbrk "Cannot build inversion information" + ++ if do_observe () then fnl () ++ CErrors.print e' else mt ()) let derive_inversion fix_names = try let evd' = Evd.from_env (Global.env ()) in (* we first transform the fix_names identifier into their corresponding constant *) - let evd',fix_names_as_constant = + let evd', fix_names_as_constant = List.fold_right - (fun id (evd,l) -> - let evd,c = - Evd.fresh_global - (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident id)) in - let (cst, u) = EConstr.destConst evd c in - evd, (cst, EConstr.EInstance.kind evd u) :: l - ) - fix_names - (evd',[]) + (fun id (evd, l) -> + let evd, c = + Evd.fresh_global (Global.env ()) evd + (Constrintern.locate_reference (Libnames.qualid_of_ident id)) + in + let cst, u = EConstr.destConst evd c in + (evd, (cst, EConstr.EInstance.kind evd u) :: l)) + fix_names (evd', []) in (* Then we check that the graphs have been defined If one of the graphs haven't been defined we do nothing *) - List.iter (fun c -> ignore (find_Function_infos (fst c))) fix_names_as_constant ; + List.iter + (fun c -> ignore (find_Function_infos (fst c))) + fix_names_as_constant; try - let evd', lind = + let _evd', lind = List.fold_right - (fun id (evd,l) -> - let evd,id = - Evd.fresh_global - (Global.env ()) evd - (Constrintern.locate_reference (Libnames.qualid_of_ident (mk_rel_id id))) - in - evd,(fst (EConstr.destInd evd id))::l - ) - fix_names - (evd',[]) + (fun id (evd, l) -> + let evd, id = + Evd.fresh_global (Global.env ()) evd + (Constrintern.locate_reference + (Libnames.qualid_of_ident (mk_rel_id id))) + in + (evd, fst (EConstr.destInd evd id) :: l)) + fix_names (evd', []) in - derive_correctness - fix_names_as_constant - lind; - with e when CErrors.noncritical e -> - warn_funind_cannot_build_inversion e - with e when CErrors.noncritical e -> - warn_funind_cannot_build_inversion e - -let register_wf interactive_proof ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas args ret_type body - pre_hook - = + derive_correctness fix_names_as_constant lind + with e when CErrors.noncritical e -> warn_funind_cannot_build_inversion e + with e when CErrors.noncritical e -> warn_funind_cannot_build_inversion e + +let register_wf interactive_proof ?(is_mes = false) fname rec_impls wf_rel_expr + wf_arg using_lemmas args ret_type body pre_hook = let type_of_f = Constrexpr_ops.mkCProdN args ret_type in let rec_arg_num = let names = @@ -1520,229 +1698,233 @@ let register_wf interactive_proof ?(is_mes=false) fname rec_impls wf_rel_expr wf in let unbounded_eq = let f_app_args = - CAst.make @@ Constrexpr.CAppExpl( - (None, Libnames.qualid_of_ident fname,None) , - (List.map - (function - | {CAst.v=Anonymous} -> assert false - | {CAst.v=Name e} -> (Constrexpr_ops.mkIdentC e) - ) - (Constrexpr_ops.names_of_local_assums args) - ) - ) + CAst.make + @@ Constrexpr.CAppExpl + ( (None, Libnames.qualid_of_ident fname, None) + , List.map + (function + | {CAst.v = Anonymous} -> assert false + | {CAst.v = Name e} -> Constrexpr_ops.mkIdentC e) + (Constrexpr_ops.names_of_local_assums args) ) in - CAst.make @@ Constrexpr.CApp ((None,Constrexpr_ops.mkRefC (Libnames.qualid_of_string "Logic.eq")), - [(f_app_args,None);(body,None)]) + CAst.make + @@ Constrexpr.CApp + ( (None, Constrexpr_ops.mkRefC (Libnames.qualid_of_string "Logic.eq")) + , [(f_app_args, None); (body, None)] ) in let eq = Constrexpr_ops.mkCProdN args unbounded_eq in - let hook ((f_ref,_) as fconst) tcc_lemma_ref (functional_ref,_) (eq_ref,_) rec_arg_num rec_arg_type - nb_args relation = + let hook ((f_ref, _) as fconst) tcc_lemma_ref (functional_ref, _) (eq_ref, _) + rec_arg_num rec_arg_type _nb_args relation = try pre_hook [fconst] - (generate_correction_proof_wf f_ref tcc_lemma_ref is_mes - functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation - ); + (generate_correction_proof_wf f_ref tcc_lemma_ref is_mes functional_ref + eq_ref rec_arg_num rec_arg_type relation); derive_inversion [fname] - with e when CErrors.noncritical e -> - (* No proof done *) - () + with e when CErrors.noncritical e -> (* No proof done *) + () in - Recdef.recursive_definition ~interactive_proof - ~is_mes fname rec_impls - type_of_f - wf_rel_expr - rec_arg_num - eq - hook - using_lemmas - -let register_mes interactive_proof fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas args ret_type body = - let wf_arg_type,wf_arg = + Recdef.recursive_definition ~interactive_proof ~is_mes fname rec_impls + type_of_f wf_rel_expr rec_arg_num eq hook using_lemmas + +let register_mes interactive_proof fname rec_impls wf_mes_expr wf_rel_expr_opt + wf_arg using_lemmas args ret_type body = + let wf_arg_type, wf_arg = match wf_arg with - | None -> - begin - match args with - | [Constrexpr.CLocalAssum ([{CAst.v=Name x}],k,t)] -> t,x - | _ -> CErrors.user_err (Pp.str "Recursive argument must be specified") - end - | Some wf_args -> + | None -> ( + match args with + | [Constrexpr.CLocalAssum ([{CAst.v = Name x}], _k, t)] -> (t, x) + | _ -> CErrors.user_err (Pp.str "Recursive argument must be specified") ) + | Some wf_args -> ( try match List.find (function - | Constrexpr.CLocalAssum(l,k,t) -> + | Constrexpr.CLocalAssum (l, _k, t) -> List.exists - (function {CAst.v=Name id} -> Id.equal id wf_args | _ -> false) + (function + | {CAst.v = Name id} -> Id.equal id wf_args | _ -> false) l - | _ -> false - ) + | _ -> false) args with - | Constrexpr.CLocalAssum(_,k,t) -> t,wf_args + | Constrexpr.CLocalAssum (_, _k, t) -> (t, wf_args) | _ -> assert false - with Not_found -> assert false + with Not_found -> assert false ) in - let wf_rel_from_mes,is_mes = + let wf_rel_from_mes, is_mes = match wf_rel_expr_opt with | None -> let ltof = let make_dir l = DirPath.make (List.rev_map Id.of_string l) in Libnames.qualid_of_path - (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (Id.of_string "ltof")) + (Libnames.make_path + (make_dir ["Arith"; "Wf_nat"]) + (Id.of_string "ltof")) in let fun_from_mes = let applied_mes = - Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC wf_arg]) in - Constrexpr_ops.mkLambdaC ([CAst.make @@ Name wf_arg],Constrexpr_ops.default_binder_kind,wf_arg_type,applied_mes) + Constrexpr_ops.mkAppC (wf_mes_expr, [Constrexpr_ops.mkIdentC wf_arg]) + in + Constrexpr_ops.mkLambdaC + ( [CAst.make @@ Name wf_arg] + , Constrexpr_ops.default_binder_kind + , wf_arg_type + , applied_mes ) in let wf_rel_from_mes = - Constrexpr_ops.mkAppC(Constrexpr_ops.mkRefC ltof,[wf_arg_type;fun_from_mes]) + Constrexpr_ops.mkAppC + (Constrexpr_ops.mkRefC ltof, [wf_arg_type; fun_from_mes]) in - wf_rel_from_mes,true + (wf_rel_from_mes, true) | Some wf_rel_expr -> let wf_rel_with_mes = let a = Names.Id.of_string "___a" in let b = Names.Id.of_string "___b" in - Constrexpr_ops.mkLambdaC( - [CAst.make @@ Name a; CAst.make @@ Name b], - Constrexpr.Default Glob_term.Explicit, - wf_arg_type, - Constrexpr_ops.mkAppC(wf_rel_expr, - [ - Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC a]); - Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC b]) - ]) - ) + Constrexpr_ops.mkLambdaC + ( [CAst.make @@ Name a; CAst.make @@ Name b] + , Constrexpr.Default Glob_term.Explicit + , wf_arg_type + , Constrexpr_ops.mkAppC + ( wf_rel_expr + , [ Constrexpr_ops.mkAppC + (wf_mes_expr, [Constrexpr_ops.mkIdentC a]) + ; Constrexpr_ops.mkAppC + (wf_mes_expr, [Constrexpr_ops.mkIdentC b]) ] ) ) in - wf_rel_with_mes,false + (wf_rel_with_mes, false) in - register_wf interactive_proof ~is_mes:is_mes fname rec_impls wf_rel_from_mes wf_arg + register_wf interactive_proof ~is_mes fname rec_impls wf_rel_from_mes wf_arg using_lemmas args ret_type body -let do_generate_principle_aux pconstants on_error register_built interactive_proof fixpoint_exprl : Lemmas.t option = - List.iter (fun { Vernacexpr.notations } -> - if not (List.is_empty notations) - then CErrors.user_err (Pp.str "Function does not support notations for now")) fixpoint_exprl; +let do_generate_principle_aux pconstants on_error register_built + interactive_proof fixpoint_exprl : Lemmas.t option = + List.iter + (fun {Vernacexpr.notations} -> + if not (List.is_empty notations) then + CErrors.user_err (Pp.str "Function does not support notations for now")) + fixpoint_exprl; let lemma, _is_struct = match fixpoint_exprl with - | [{ Vernacexpr.rec_order = Some {CAst.v = Constrexpr.CWfRec (wf_x,wf_rel)} } as fixpoint_expr] -> - let { Vernacexpr.fname; univs; binders; rtype; body_def } as fixpoint_expr = + | [ ( { Vernacexpr.rec_order = + Some {CAst.v = Constrexpr.CWfRec (wf_x, wf_rel)} } as + fixpoint_expr ) ] -> + let ( {Vernacexpr.fname; univs = _; binders; rtype; body_def} as + fixpoint_expr ) = match recompute_binder_list [fixpoint_expr] with | [e] -> e | _ -> assert false in let fixpoint_exprl = [fixpoint_expr] in - let body = match body_def with | Some body -> body | None -> - CErrors.user_err ~hdr:"Function" (Pp.str "Body of Function must be given") in - let recdefs,rec_impls = build_newrecursive fixpoint_exprl in + let body = + match body_def with + | Some body -> body + | None -> + CErrors.user_err ~hdr:"Function" + (Pp.str "Body of Function must be given") + in + let recdefs, rec_impls = build_newrecursive fixpoint_exprl in let using_lemmas = [] in let pre_hook pconstants = generate_principle (ref (Evd.from_env (Global.env ()))) - pconstants - on_error - true - register_built - fixpoint_exprl - recdefs - true + pconstants on_error true register_built fixpoint_exprl recdefs in - if register_built - then register_wf interactive_proof fname.CAst.v rec_impls wf_rel wf_x.CAst.v using_lemmas binders rtype body pre_hook, false - else None, false - | [{ Vernacexpr.rec_order = Some {CAst.v = Constrexpr.CMeasureRec(wf_x,wf_mes,wf_rel_opt)} } as fixpoint_expr] -> - let { Vernacexpr.fname; univs; binders; rtype; body_def} as fixpoint_expr = + if register_built then + ( register_wf interactive_proof fname.CAst.v rec_impls wf_rel + wf_x.CAst.v using_lemmas binders rtype body pre_hook + , false ) + else (None, false) + | [ ( { Vernacexpr.rec_order = + Some {CAst.v = Constrexpr.CMeasureRec (wf_x, wf_mes, wf_rel_opt)} + } as fixpoint_expr ) ] -> + let ( {Vernacexpr.fname; univs = _; binders; rtype; body_def} as + fixpoint_expr ) = match recompute_binder_list [fixpoint_expr] with | [e] -> e | _ -> assert false in let fixpoint_exprl = [fixpoint_expr] in - let recdefs,rec_impls = build_newrecursive fixpoint_exprl in + let recdefs, rec_impls = build_newrecursive fixpoint_exprl in let using_lemmas = [] in - let body = match body_def with + let body = + match body_def with | Some body -> body | None -> - CErrors.user_err ~hdr:"Function" Pp.(str "Body of Function must be given") in + CErrors.user_err ~hdr:"Function" + Pp.(str "Body of Function must be given") + in let pre_hook pconstants = generate_principle (ref (Evd.from_env (Global.env ()))) - pconstants - on_error - true - register_built - fixpoint_exprl - recdefs - true + pconstants on_error true register_built fixpoint_exprl recdefs in - if register_built - then register_mes interactive_proof fname.CAst.v rec_impls wf_mes wf_rel_opt - (Option.map (fun x -> x.CAst.v) wf_x) using_lemmas binders rtype body pre_hook, true - else None, true + if register_built then + ( register_mes interactive_proof fname.CAst.v rec_impls wf_mes wf_rel_opt + (Option.map (fun x -> x.CAst.v) wf_x) + using_lemmas binders rtype body pre_hook + , true ) + else (None, true) | _ -> - List.iter (function { Vernacexpr.rec_order } -> - match rec_order with - | Some { CAst.v = (Constrexpr.CMeasureRec _ | Constrexpr.CWfRec _) } -> - CErrors.user_err - (Pp.str "Cannot use mutual definition with well-founded recursion or measure") - | _ -> () - ) + List.iter + (function + | {Vernacexpr.rec_order} -> ( + match rec_order with + | Some {CAst.v = Constrexpr.CMeasureRec _ | Constrexpr.CWfRec _} -> + CErrors.user_err + (Pp.str + "Cannot use mutual definition with well-founded recursion \ + or measure") + | _ -> () )) fixpoint_exprl; let fixpoint_exprl = recompute_binder_list fixpoint_exprl in - let fix_names = List.map (function { Vernacexpr.fname } -> fname.CAst.v) fixpoint_exprl in + let fix_names = + List.map (function {Vernacexpr.fname} -> fname.CAst.v) fixpoint_exprl + in (* ok all the expressions are structural *) - let recdefs,rec_impls = build_newrecursive fixpoint_exprl in + let recdefs, _rec_impls = build_newrecursive fixpoint_exprl in let is_rec = List.exists (is_rec fix_names) recdefs in - let lemma,evd,pconstants = - if register_built - then register_struct is_rec fixpoint_exprl - else None, Evd.from_env (Global.env ()), pconstants + let lemma, evd, pconstants = + if register_built then register_struct is_rec fixpoint_exprl + else (None, Evd.from_env (Global.env ()), pconstants) in let evd = ref evd in - generate_principle - (ref !evd) - pconstants - on_error - false - register_built - fixpoint_exprl - recdefs - interactive_proof - (Functional_principles_proofs.prove_princ_for_struct evd interactive_proof); - if register_built then - begin derive_inversion fix_names; end; - lemma, true + generate_principle (ref !evd) pconstants on_error false register_built + fixpoint_exprl recdefs + (Functional_principles_proofs.prove_princ_for_struct evd + interactive_proof); + if register_built then derive_inversion fix_names; + (lemma, true) in lemma let warn_cannot_define_graph = CWarnings.create ~name:"funind-cannot-define-graph" ~category:"funind" - (fun (names,error) -> - Pp.(strbrk "Cannot define graph(s) for " ++ - h 1 names ++ error)) + (fun (names, error) -> + Pp.(strbrk "Cannot define graph(s) for " ++ h 1 names ++ error)) let warn_cannot_define_principle = CWarnings.create ~name:"funind-cannot-define-principle" ~category:"funind" - (fun (names,error) -> - Pp.(strbrk "Cannot define induction principle(s) for "++ - h 1 names ++ error)) + (fun (names, error) -> + Pp.( + strbrk "Cannot define induction principle(s) for " ++ h 1 names ++ error)) let warning_error names e = let e_explain e = match e with - | ToShow e -> - Pp.(spc () ++ CErrors.print e) - | _ -> - if do_observe () - then Pp.(spc () ++ CErrors.print e) - else Pp.mt () + | ToShow e -> Pp.(spc () ++ CErrors.print e) + | _ -> if do_observe () then Pp.(spc () ++ CErrors.print e) else Pp.mt () in match e with | Building_graph e -> - let names = Pp.(prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) in - warn_cannot_define_graph (names,e_explain e) + let names = + Pp.(prlist_with_sep (fun _ -> str "," ++ spc ()) Ppconstr.pr_id names) + in + warn_cannot_define_graph (names, e_explain e) | Defining_principle e -> - let names = Pp.(prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) in - warn_cannot_define_principle (names,e_explain e) + let names = + Pp.(prlist_with_sep (fun _ -> str "," ++ spc ()) Ppconstr.pr_id names) + in + warn_cannot_define_principle (names, e_explain e) | _ -> raise e let error_error names e = @@ -1754,9 +1936,11 @@ let error_error names e = match e with | Building_graph e -> CErrors.user_err - Pp.(str "Cannot define graph(s) for " ++ - h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ - e_explain e) + Pp.( + str "Cannot define graph(s) for " + ++ h 1 + (prlist_with_sep (fun _ -> str "," ++ spc ()) Ppconstr.pr_id names) + ++ e_explain e) | _ -> raise e (* [chop_n_arrow n t] chops the [n] first arrows in [t] @@ -1765,272 +1949,307 @@ let error_error names e = let rec chop_n_arrow n t = let exception Stop of Constrexpr.constr_expr in let open Constrexpr in - if n <= 0 - then t (* If we have already removed all the arrows then return the type *) - else (* If not we check the form of [t] *) + if n <= 0 then t + (* If we have already removed all the arrows then return the type *) + else + (* If not we check the form of [t] *) match t.CAst.v with - | Constrexpr.CProdN(nal_ta',t') -> (* If we have a forall, two results are possible : - either we need to discard more than the number of arrows contained - in this product declaration then we just recall [chop_n_arrow] on - the remaining number of arrow to chop and [t'] we discard it and - recall [chop_n_arrow], either this product contains more arrows - than the number we need to chop and then we return the new type - *) - begin - try - let new_n = - let rec aux (n:int) = function - [] -> n - | CLocalAssum(nal,k,t'')::nal_ta' -> - let nal_l = List.length nal in - if n >= nal_l - then - aux (n - nal_l) nal_ta' - else - let new_t' = CAst.make @@ - Constrexpr.CProdN( - CLocalAssum((snd (List.chop n nal)),k,t'')::nal_ta',t') - in - raise (Stop new_t') - | _ -> CErrors.anomaly (Pp.str "Not enough products.") - in - aux n nal_ta' + | Constrexpr.CProdN (nal_ta', t') -> ( + try + (* If we have a forall, two results are possible : + either we need to discard more than the number of arrows contained + in this product declaration then we just recall [chop_n_arrow] on + the remaining number of arrow to chop and [t'] we discard it and + recall [chop_n_arrow], either this product contains more arrows + than the number we need to chop and then we return the new type + *) + let new_n = + let rec aux (n : int) = function + | [] -> n + | CLocalAssum (nal, k, t'') :: nal_ta' -> + let nal_l = List.length nal in + if n >= nal_l then aux (n - nal_l) nal_ta' + else + let new_t' = + CAst.make + @@ Constrexpr.CProdN + ( CLocalAssum (snd (List.chop n nal), k, t'') :: nal_ta' + , t' ) + in + raise (Stop new_t') + | _ -> CErrors.anomaly (Pp.str "Not enough products.") in - chop_n_arrow new_n t' - with Stop t -> t - end + aux n nal_ta' + in + chop_n_arrow new_n t' + with Stop t -> t ) | _ -> CErrors.anomaly (Pp.str "Not enough products.") let rec add_args id new_args = let open Libnames in let open Constrexpr in CAst.map (function - | CRef (qid,_) as b -> - if qualid_is_ident qid && Id.equal (qualid_basename qid) id then - CAppExpl((None,qid,None),new_args) - else b - | CFix _ | CCoFix _ -> - CErrors.anomaly ~label:"add_args " (Pp.str "todo.") - | CProdN(nal,b1) -> - CProdN(List.map (function CLocalAssum (nal,k,b2) -> CLocalAssum (nal,k,add_args id new_args b2) - | CLocalDef (na,b1,t) -> CLocalDef (na,add_args id new_args b1,Option.map (add_args id new_args) t) - | CLocalPattern _ -> - CErrors.user_err (Pp.str "pattern with quote not allowed here.")) nal, - add_args id new_args b1) - | CLambdaN(nal,b1) -> - CLambdaN(List.map (function CLocalAssum (nal,k,b2) -> CLocalAssum (nal,k,add_args id new_args b2) - | CLocalDef (na,b1,t) -> CLocalDef (na,add_args id new_args b1,Option.map (add_args id new_args) t) - | CLocalPattern _ -> - CErrors.user_err (Pp.str "pattern with quote not allowed here.")) nal, - add_args id new_args b1) - | CLetIn(na,b1,t,b2) -> - CLetIn(na,add_args id new_args b1,Option.map (add_args id new_args) t,add_args id new_args b2) - | CAppExpl((pf,qid,us),exprl) -> - if qualid_is_ident qid && Id.equal (qualid_basename qid) id then - CAppExpl((pf,qid,us),new_args@(List.map (add_args id new_args) exprl)) - else CAppExpl((pf,qid,us),List.map (add_args id new_args) exprl) - | CApp((pf,b),bl) -> - CApp((pf,add_args id new_args b), - List.map (fun (e,o) -> add_args id new_args e,o) bl) - | CCases(sty,b_option,cel,cal) -> - CCases(sty,Option.map (add_args id new_args) b_option, - List.map (fun (b,na,b_option) -> - add_args id new_args b, - na, b_option) cel, - List.map CAst.(map (fun (cpl,e) -> (cpl,add_args id new_args e))) cal - ) - | CLetTuple(nal,(na,b_option),b1,b2) -> - CLetTuple(nal,(na,Option.map (add_args id new_args) b_option), - add_args id new_args b1, - add_args id new_args b2 - ) - - | CIf(b1,(na,b_option),b2,b3) -> - CIf(add_args id new_args b1, - (na,Option.map (add_args id new_args) b_option), - add_args id new_args b2, - add_args id new_args b3 - ) - | CHole _ - | CPatVar _ - | CEvar _ - | CPrim _ - | CSort _ as b -> b - | CCast(b1,b2) -> - CCast(add_args id new_args b1, - Glob_ops.map_cast_type (add_args id new_args) b2) - | CRecord pars -> - CRecord (List.map (fun (e,o) -> e, add_args id new_args o) pars) - | CNotation _ -> - CErrors.anomaly ~label:"add_args " (Pp.str "CNotation.") - | CGeneralization _ -> - CErrors.anomaly ~label:"add_args " (Pp.str "CGeneralization.") - | CDelimiters _ -> - CErrors.anomaly ~label:"add_args " (Pp.str "CDelimiters.") - ) - -let rec get_args b t : Constrexpr.local_binder_expr list * Constrexpr.constr_expr * Constrexpr.constr_expr = + | CRef (qid, _) as b -> + if qualid_is_ident qid && Id.equal (qualid_basename qid) id then + CAppExpl ((None, qid, None), new_args) + else b + | CFix _ | CCoFix _ -> CErrors.anomaly ~label:"add_args " (Pp.str "todo.") + | CProdN (nal, b1) -> + CProdN + ( List.map + (function + | CLocalAssum (nal, k, b2) -> + CLocalAssum (nal, k, add_args id new_args b2) + | CLocalDef (na, b1, t) -> + CLocalDef + ( na + , add_args id new_args b1 + , Option.map (add_args id new_args) t ) + | CLocalPattern _ -> + CErrors.user_err (Pp.str "pattern with quote not allowed here.")) + nal + , add_args id new_args b1 ) + | CLambdaN (nal, b1) -> + CLambdaN + ( List.map + (function + | CLocalAssum (nal, k, b2) -> + CLocalAssum (nal, k, add_args id new_args b2) + | CLocalDef (na, b1, t) -> + CLocalDef + ( na + , add_args id new_args b1 + , Option.map (add_args id new_args) t ) + | CLocalPattern _ -> + CErrors.user_err (Pp.str "pattern with quote not allowed here.")) + nal + , add_args id new_args b1 ) + | CLetIn (na, b1, t, b2) -> + CLetIn + ( na + , add_args id new_args b1 + , Option.map (add_args id new_args) t + , add_args id new_args b2 ) + | CAppExpl ((pf, qid, us), exprl) -> + if qualid_is_ident qid && Id.equal (qualid_basename qid) id then + CAppExpl + ((pf, qid, us), new_args @ List.map (add_args id new_args) exprl) + else CAppExpl ((pf, qid, us), List.map (add_args id new_args) exprl) + | CApp ((pf, b), bl) -> + CApp + ( (pf, add_args id new_args b) + , List.map (fun (e, o) -> (add_args id new_args e, o)) bl ) + | CCases (sty, b_option, cel, cal) -> + CCases + ( sty + , Option.map (add_args id new_args) b_option + , List.map + (fun (b, na, b_option) -> (add_args id new_args b, na, b_option)) + cel + , List.map + CAst.(map (fun (cpl, e) -> (cpl, add_args id new_args e))) + cal ) + | CLetTuple (nal, (na, b_option), b1, b2) -> + CLetTuple + ( nal + , (na, Option.map (add_args id new_args) b_option) + , add_args id new_args b1 + , add_args id new_args b2 ) + | CIf (b1, (na, b_option), b2, b3) -> + CIf + ( add_args id new_args b1 + , (na, Option.map (add_args id new_args) b_option) + , add_args id new_args b2 + , add_args id new_args b3 ) + | (CHole _ | CPatVar _ | CEvar _ | CPrim _ | CSort _) as b -> b + | CCast (b1, b2) -> + CCast + ( add_args id new_args b1 + , Glob_ops.map_cast_type (add_args id new_args) b2 ) + | CRecord pars -> + CRecord (List.map (fun (e, o) -> (e, add_args id new_args o)) pars) + | CNotation _ -> CErrors.anomaly ~label:"add_args " (Pp.str "CNotation.") + | CGeneralization _ -> + CErrors.anomaly ~label:"add_args " (Pp.str "CGeneralization.") + | CDelimiters _ -> + CErrors.anomaly ~label:"add_args " (Pp.str "CDelimiters.")) + +let rec get_args b t : + Constrexpr.local_binder_expr list + * Constrexpr.constr_expr + * Constrexpr.constr_expr = let open Constrexpr in match b.CAst.v with - | Constrexpr.CLambdaN (CLocalAssum(nal,k,ta) as d::rest, b') -> - begin - let n = List.length nal in - let nal_tas,b'',t'' = get_args (CAst.make ?loc:b.CAst.loc @@ Constrexpr.CLambdaN (rest,b')) (chop_n_arrow n t) in - d :: nal_tas, b'',t'' - end - | Constrexpr.CLambdaN ([], b) -> [],b,t - | _ -> [],b,t + | Constrexpr.CLambdaN ((CLocalAssum (nal, k, ta) as d) :: rest, b') -> + let n = List.length nal in + let nal_tas, b'', t'' = + get_args + (CAst.make ?loc:b.CAst.loc @@ Constrexpr.CLambdaN (rest, b')) + (chop_n_arrow n t) + in + (d :: nal_tas, b'', t'') + | Constrexpr.CLambdaN ([], b) -> ([], b, t) + | _ -> ([], b, t) let make_graph (f_ref : GlobRef.t) = let open Constrexpr in - let env = Global.env() in + let env = Global.env () in let sigma = Evd.from_env env in - let c,c_body = + let c, c_body = match f_ref with - | GlobRef.ConstRef c -> - begin - try c,Global.lookup_constant c - with Not_found -> - CErrors.user_err Pp.(str "Cannot find " ++ Printer.pr_leconstr_env env sigma (EConstr.mkConst c)) - end - | _ -> - CErrors.user_err Pp.(str "Not a function reference") + | GlobRef.ConstRef c -> ( + try (c, Global.lookup_constant c) + with Not_found -> + CErrors.user_err + Pp.( + str "Cannot find " + ++ Printer.pr_leconstr_env env sigma (EConstr.mkConst c)) ) + | _ -> CErrors.user_err Pp.(str "Not a function reference") in - (match Global.body_of_constant_body Library.indirect_accessor c_body with - | None -> - CErrors.user_err (Pp.str "Cannot build a graph over an axiom!") - | Some (body, _, _) -> - let env = Global.env () in - let extern_body,extern_type = - with_full_print (fun () -> - (Constrextern.extern_constr env sigma (EConstr.of_constr body), - Constrextern.extern_type env sigma - (EConstr.of_constr (*FIXME*) c_body.Declarations.const_type) - ) - ) - () - in - let (nal_tas,b,t) = get_args extern_body extern_type in - let expr_list = - match b.CAst.v with - | Constrexpr.CFix(l_id,fixexprl) -> - let l = - List.map - (fun (id,recexp,bl,t,b) -> - let { CAst.loc; v=rec_id } = match Option.get recexp with - | { CAst.v = CStructRec id } -> id - | { CAst.v = CWfRec (id,_) } -> id - | { CAst.v = CMeasureRec (oid,_,_) } -> Option.get oid - in - let new_args = - List.flatten - (List.map - (function - | Constrexpr.CLocalDef (na,_,_)-> [] - | Constrexpr.CLocalAssum (nal,_,_) -> - List.map - (fun {CAst.loc;v=n} -> CAst.make ?loc @@ - CRef(Libnames.qualid_of_ident ?loc @@ Nameops.Name.get_id n,None)) - nal - | Constrexpr.CLocalPattern _ -> assert false - ) - nal_tas - ) - in - let b' = add_args id.CAst.v new_args b in - { Vernacexpr.fname=id; univs=None - ; rec_order = Some (CAst.make (CStructRec (CAst.make rec_id))) - ; binders = nal_tas@bl; rtype=t; body_def=Some b'; notations = []} - ) - fixexprl - in - l - | _ -> - let fname = CAst.make (Label.to_id (Constant.label c)) in - [{ Vernacexpr.fname; univs=None; rec_order = None; binders=nal_tas; rtype=t; body_def=Some b; notations=[]}] - in - let mp = Constant.modpath c in - let pstate = do_generate_principle_aux [c,Univ.Instance.empty] error_error false false expr_list in - assert (Option.is_empty pstate); - (* We register the infos *) - List.iter - (fun { Vernacexpr.fname= {CAst.v=id} } -> - add_Function false (Constant.make2 mp (Label.of_id id))) - expr_list) + match Global.body_of_constant_body Library.indirect_accessor c_body with + | None -> CErrors.user_err (Pp.str "Cannot build a graph over an axiom!") + | Some (body, _, _) -> + let env = Global.env () in + let extern_body, extern_type = + with_full_print + (fun () -> + ( Constrextern.extern_constr env sigma (EConstr.of_constr body) + , Constrextern.extern_type env sigma + (EConstr.of_constr (*FIXME*) c_body.Declarations.const_type) )) + () + in + let nal_tas, b, t = get_args extern_body extern_type in + let expr_list = + match b.CAst.v with + | Constrexpr.CFix (l_id, fixexprl) -> + let l = + List.map + (fun (id, recexp, bl, t, b) -> + let {CAst.loc; v = rec_id} = + match Option.get recexp with + | {CAst.v = CStructRec id} -> id + | {CAst.v = CWfRec (id, _)} -> id + | {CAst.v = CMeasureRec (oid, _, _)} -> Option.get oid + in + let new_args = + List.flatten + (List.map + (function + | Constrexpr.CLocalDef (na, _, _) -> [] + | Constrexpr.CLocalAssum (nal, _, _) -> + List.map + (fun {CAst.loc; v = n} -> + CAst.make ?loc + @@ CRef + ( Libnames.qualid_of_ident ?loc + @@ Nameops.Name.get_id n + , None )) + nal + | Constrexpr.CLocalPattern _ -> assert false) + nal_tas) + in + let b' = add_args id.CAst.v new_args b in + { Vernacexpr.fname = id + ; univs = None + ; rec_order = Some (CAst.make (CStructRec (CAst.make rec_id))) + ; binders = nal_tas @ bl + ; rtype = t + ; body_def = Some b' + ; notations = [] }) + fixexprl + in + l + | _ -> + let fname = CAst.make (Label.to_id (Constant.label c)) in + [ { Vernacexpr.fname + ; univs = None + ; rec_order = None + ; binders = nal_tas + ; rtype = t + ; body_def = Some b + ; notations = [] } ] + in + let mp = Constant.modpath c in + let pstate = + do_generate_principle_aux [(c, Univ.Instance.empty)] error_error false + false expr_list + in + assert (Option.is_empty pstate); + (* We register the infos *) + List.iter + (fun {Vernacexpr.fname = {CAst.v = id}} -> + add_Function false (Constant.make2 mp (Label.of_id id))) + expr_list (* *************** statically typed entrypoints ************************* *) let do_generate_principle_interactive fixl : Lemmas.t = - match - do_generate_principle_aux [] warning_error true true fixl - with + match do_generate_principle_aux [] warning_error true true fixl with | Some lemma -> lemma | None -> - CErrors.anomaly - (Pp.str"indfun: leaving no open proof in interactive mode") + CErrors.anomaly (Pp.str "indfun: leaving no open proof in interactive mode") let do_generate_principle fixl : unit = - match do_generate_principle_aux [] warning_error true false fixl with + match do_generate_principle_aux [] warning_error true false fixl with | Some _lemma -> CErrors.anomaly - (Pp.str"indfun: leaving a goal open in non-interactive mode") + (Pp.str "indfun: leaving a goal open in non-interactive mode") | None -> () - let build_scheme fas = - let evd = (ref (Evd.from_env (Global.env ()))) in - let pconstants = (List.map - (fun (_,f,sort) -> - let f_as_constant = - try - Smartlocate.global_with_alias f - with Not_found -> - CErrors.user_err ~hdr:"FunInd.build_scheme" - Pp.(str "Cannot find " ++ Libnames.pr_qualid f) - in - let evd',f = Evd.fresh_global (Global.env ()) !evd f_as_constant in - let _ = evd := evd' in - let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd f in - evd := sigma; - let c, u = - try EConstr.destConst !evd f - with Constr.DestKO -> - CErrors.user_err Pp.(Printer.pr_econstr_env (Global.env ()) !evd f ++spc () ++ str "should be the named of a globally defined function") - in - (c, EConstr.EInstance.kind !evd u), sort - ) - fas - ) in + let evd = ref (Evd.from_env (Global.env ())) in + let pconstants = + List.map + (fun (_, f, sort) -> + let f_as_constant = + try Smartlocate.global_with_alias f + with Not_found -> + CErrors.user_err ~hdr:"FunInd.build_scheme" + Pp.(str "Cannot find " ++ Libnames.pr_qualid f) + in + let evd', f = Evd.fresh_global (Global.env ()) !evd f_as_constant in + let _ = evd := evd' in + let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd f in + evd := sigma; + let c, u = + try EConstr.destConst !evd f + with Constr.DestKO -> + CErrors.user_err + Pp.( + Printer.pr_econstr_env (Global.env ()) !evd f + ++ spc () + ++ str "should be the named of a globally defined function") + in + ((c, EConstr.EInstance.kind !evd u), sort)) + fas + in let bodies_types = make_scheme evd pconstants in - List.iter2 - (fun (princ_id,_,_) def_entry -> - ignore - (Declare.declare_constant - ~name:princ_id - ~kind:Decls.(IsProof Theorem) - (Declare.DefinitionEntry def_entry)); - Declare.definition_message princ_id - ) - fas - bodies_types + (fun (princ_id, _, _) def_entry -> + ignore + (Declare.declare_constant ~name:princ_id + ~kind:Decls.(IsProof Theorem) + (Declare.DefinitionEntry def_entry)); + Declare.definition_message princ_id) + fas bodies_types let build_case_scheme fa = - let env = Global.env () - and sigma = (Evd.from_env (Global.env ())) in -(* let id_to_constr id = *) -(* Constrintern.global_reference id *) -(* in *) + let env = Global.env () and sigma = Evd.from_env (Global.env ()) in + (* let id_to_constr id = *) + (* Constrintern.global_reference id *) + (* in *) let funs = - let (_,f,_) = fa in - try (let open GlobRef in - match Smartlocate.global_with_alias f with - | ConstRef c -> c - | IndRef _ | ConstructRef _ | VarRef _ -> assert false) + let _, f, _ = fa in + try + let open GlobRef in + match Smartlocate.global_with_alias f with + | ConstRef c -> c + | IndRef _ | ConstructRef _ | VarRef _ -> assert false with Not_found -> CErrors.user_err ~hdr:"FunInd.build_case_scheme" - Pp.(str "Cannot find " ++ Libnames.pr_qualid f) in - let sigma, (_,u) = Evd.fresh_constant_instance env sigma funs in + Pp.(str "Cannot find " ++ Libnames.pr_qualid f) + in + let sigma, (_, u) = Evd.fresh_constant_instance env sigma funs in let first_fun = funs in let funs_mp = Constant.modpath first_fun in let first_fun_kn = @@ -2039,40 +2258,39 @@ let build_case_scheme fa = | Some finfos -> fst finfos.graph_ind in let this_block_funs_indexes = get_funs_constant funs_mp first_fun in - let this_block_funs = Array.map (fun (c,_) -> (c,u)) this_block_funs_indexes in + let this_block_funs = + Array.map (fun (c, _) -> (c, u)) this_block_funs_indexes + in let prop_sort = Sorts.InProp in let funs_indexes = let this_block_funs_indexes = Array.to_list this_block_funs_indexes in List.assoc_f Constant.equal funs this_block_funs_indexes in - let (ind, sf) = - let ind = first_fun_kn,funs_indexes in - (ind,Univ.Instance.empty)(*FIXME*),prop_sort + let ind, sf = + let ind = (first_fun_kn, funs_indexes) in + ((ind, Univ.Instance.empty) (*FIXME*), prop_sort) in - let (sigma, scheme) = - Indrec.build_case_analysis_scheme_default env sigma ind sf + let sigma, scheme = + Indrec.build_case_analysis_scheme_default env sigma ind sf in - let scheme_type = EConstr.Unsafe.to_constr ((Retyping.get_type_of env sigma) (EConstr.of_constr scheme)) in - let sorts = - (fun (_,_,x) -> - fst @@ UnivGen.fresh_sort_in_family x - ) - fa + let scheme_type = + EConstr.Unsafe.to_constr + ((Retyping.get_type_of env sigma) (EConstr.of_constr scheme)) in - let princ_name = (fun (x,_,_) -> x) fa in - let _ : unit = - (* Pp.msgnl (str "Generating " ++ Ppconstr.pr_id princ_name ++str " with " ++ - pr_lconstr scheme_type ++ str " and " ++ (fun a -> prlist_with_sep spc (fun c -> pr_lconstr (mkConst c)) (Array.to_list a)) this_block_funs - ); - *) + let sorts = (fun (_, _, x) -> fst @@ UnivGen.fresh_sort_in_family x) fa in + let princ_name = (fun (x, _, _) -> x) fa in + let (_ : unit) = + (* Pp.msgnl (str "Generating " ++ Ppconstr.pr_id princ_name ++str " with " ++ + pr_lconstr scheme_type ++ str " and " ++ (fun a -> prlist_with_sep spc (fun c -> pr_lconstr (mkConst c)) (Array.to_list a)) this_block_funs + ); + *) generate_functional_principle (ref (Evd.from_env (Global.env ()))) - false scheme_type - (Some ([|sorts|])) - (Some princ_name) - this_block_funs - 0 - (Functional_principles_proofs.prove_princ_for_struct (ref (Evd.from_env (Global.env ()))) false 0 [|funs|]) + (Some [|sorts|]) + (Some princ_name) this_block_funs 0 + (Functional_principles_proofs.prove_princ_for_struct + (ref (Evd.from_env (Global.env ()))) + false 0 [|funs|]) in () diff --git a/plugins/funind/gen_principle.mli b/plugins/funind/gen_principle.mli index 6313a2b16e..3c04d6cb7d 100644 --- a/plugins/funind/gen_principle.mli +++ b/plugins/funind/gen_principle.mli @@ -11,13 +11,14 @@ val warn_cannot_define_graph : ?loc:Loc.t -> Pp.t * Pp.t -> unit val warn_cannot_define_principle : ?loc:Loc.t -> Pp.t * Pp.t -> unit -val do_generate_principle_interactive : Vernacexpr.fixpoint_expr list -> Lemmas.t -val do_generate_principle : Vernacexpr.fixpoint_expr list -> unit +val do_generate_principle_interactive : + Vernacexpr.fixpoint_expr list -> Lemmas.t +val do_generate_principle : Vernacexpr.fixpoint_expr list -> unit val make_graph : Names.GlobRef.t -> unit (* Can be thrown by build_{,case}_scheme *) exception No_graph_found val build_scheme : (Names.Id.t * Libnames.qualid * Sorts.family) list -> unit -val build_case_scheme : (Names.Id.t * Libnames.qualid * Sorts.family) -> unit +val build_case_scheme : Names.Id.t * Libnames.qualid * Sorts.family -> unit diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index e08ad9af3a..11e4fa0ac7 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -10,34 +10,27 @@ open Indfun_common open CErrors open Util open Glob_termops - module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration -let observe strm = - if do_observe () - then Feedback.msg_debug strm - else () +let observe strm = if do_observe () then Feedback.msg_debug strm else () + (*let observennl strm = if do_observe () then Pp.msg strm else ()*) - -type binder_type = - | Lambda of Name.t - | Prod of Name.t - | LetIn of Name.t - -type glob_context = (binder_type*glob_constr) list - +type binder_type = Lambda of Name.t | Prod of Name.t | LetIn of Name.t +type glob_context = (binder_type * glob_constr) list let rec solve_trivial_holes pat_as_term e = - match DAst.get pat_as_term, DAst.get e with - | GHole _,_ -> e - | GApp(fp,argsp),GApp(fe,argse) when glob_constr_eq fp fe -> - DAst.make (GApp((solve_trivial_holes fp fe),List.map2 solve_trivial_holes argsp argse)) - | _,_ -> pat_as_term + match (DAst.get pat_as_term, DAst.get e) with + | GHole _, _ -> e + | GApp (fp, argsp), GApp (fe, argse) when glob_constr_eq fp fe -> + DAst.make + (GApp + (solve_trivial_holes fp fe, List.map2 solve_trivial_holes argsp argse)) + | _, _ -> pat_as_term (* compose_glob_context [(bt_1,n_1,t_1);......] rt returns @@ -45,31 +38,26 @@ let rec solve_trivial_holes pat_as_term e = binders corresponding to the bt_i's *) let compose_glob_context = - let compose_binder (bt,t) acc = + let compose_binder (bt, t) acc = match bt with - | Lambda n -> mkGLambda(n,t,acc) - | Prod n -> mkGProd(n,t,acc) - | LetIn n -> mkGLetIn(n,t,None,acc) + | Lambda n -> mkGLambda (n, t, acc) + | Prod n -> mkGProd (n, t, acc) + | LetIn n -> mkGLetIn (n, t, None, acc) in List.fold_right compose_binder - (* The main part deals with building a list of globalized constructor expressions from the rhs of a fixpoint equation. *) type 'a build_entry_pre_return = - { - context : glob_context; (* the binding context of the result *) - value : 'a; (* The value *) - } + { context : glob_context + ; (* the binding context of the result *) + value : 'a (* The value *) } type 'a build_entry_return = - { - result : 'a build_entry_pre_return list; - to_avoid : Id.t list - } + {result : 'a build_entry_pre_return list; to_avoid : Id.t list} (* [combine_results combine_fun res1 res2] combine two results [res1] and [res2] @@ -81,64 +69,55 @@ type 'a build_entry_return = *) let combine_results - (combine_fun : 'a build_entry_pre_return -> 'b build_entry_pre_return -> - 'c build_entry_pre_return - ) - (res1: 'a build_entry_return) - (res2 : 'b build_entry_return) - : 'c build_entry_return - = - let pre_result = List.map - ( fun res1 -> (* for each result in arg_res *) - List.map (* we add it in each args_res *) - (fun res2 -> - combine_fun res1 res2 - ) - res2.result - ) + (combine_fun : + 'a build_entry_pre_return + -> 'b build_entry_pre_return + -> 'c build_entry_pre_return) (res1 : 'a build_entry_return) + (res2 : 'b build_entry_return) : 'c build_entry_return = + let pre_result = + List.map + (fun res1 -> + (* for each result in arg_res *) + List.map (* we add it in each args_res *) + (fun res2 -> combine_fun res1 res2) + res2.result) res1.result - in (* and then we flatten the map *) - { - result = List.concat pre_result; - to_avoid = List.union Id.equal res1.to_avoid res2.to_avoid - } - + in + (* and then we flatten the map *) + { result = List.concat pre_result + ; to_avoid = List.union Id.equal res1.to_avoid res2.to_avoid } (* The combination function for an argument with a list of argument *) let combine_args arg args = - { - context = arg.context@args.context; - (* Note that the binding context of [arg] MUST be placed before the one of + { context = arg.context @ args.context + ; (* Note that the binding context of [arg] MUST be placed before the one of [args] in order to preserve possible type dependencies *) - value = arg.value::args.value; - } + value = arg.value :: args.value } - -let ids_of_binder = function +let ids_of_binder = function | LetIn Anonymous | Prod Anonymous | Lambda Anonymous -> Id.Set.empty - | LetIn (Name id) | Prod (Name id) | Lambda (Name id) -> Id.Set.singleton id + | LetIn (Name id) | Prod (Name id) | Lambda (Name id) -> Id.Set.singleton id let rec change_vars_in_binder mapping = function - [] -> [] - | (bt,t)::l -> - let new_mapping = Id.Set.fold Id.Map.remove (ids_of_binder bt) mapping in - (bt,change_vars mapping t):: - (if Id.Map.is_empty new_mapping - then l - else change_vars_in_binder new_mapping l - ) + | [] -> [] + | (bt, t) :: l -> + let new_mapping = Id.Set.fold Id.Map.remove (ids_of_binder bt) mapping in + (bt, change_vars mapping t) + :: + ( if Id.Map.is_empty new_mapping then l + else change_vars_in_binder new_mapping l ) let rec replace_var_by_term_in_binder x_id term = function | [] -> [] - | (bt,t)::l -> - (bt,replace_var_by_term x_id term t):: - if Id.Set.mem x_id (ids_of_binder bt) - then l - else replace_var_by_term_in_binder x_id term l + | (bt, t) :: l -> + (bt, replace_var_by_term x_id term t) + :: + ( if Id.Set.mem x_id (ids_of_binder bt) then l + else replace_var_by_term_in_binder x_id term l ) let add_bt_names bt = Id.Set.union (ids_of_binder bt) @@ -146,128 +125,116 @@ let apply_args ctxt body args = let need_convert_id avoid id = List.exists (is_free_in id) args || Id.Set.mem id avoid in - let need_convert avoid bt = + let need_convert avoid bt = Id.Set.exists (need_convert_id avoid) (ids_of_binder bt) in - let next_name_away (na:Name.t) (mapping: Id.t Id.Map.t) (avoid: Id.Set.t) = + let next_name_away (na : Name.t) (mapping : Id.t Id.Map.t) (avoid : Id.Set.t) + = match na with - | Name id when Id.Set.mem id avoid -> - let new_id = Namegen.next_ident_away id avoid in - Name new_id,Id.Map.add id new_id mapping,Id.Set.add new_id avoid - | _ -> na,mapping,avoid + | Name id when Id.Set.mem id avoid -> + let new_id = Namegen.next_ident_away id avoid in + (Name new_id, Id.Map.add id new_id mapping, Id.Set.add new_id avoid) + | _ -> (na, mapping, avoid) in - let next_bt_away bt (avoid:Id.Set.t) = + let next_bt_away bt (avoid : Id.Set.t) = match bt with - | LetIn na -> - let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid in - LetIn new_na,mapping,new_avoid - | Prod na -> - let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid in - Prod new_na,mapping,new_avoid - | Lambda na -> - let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid in - Lambda new_na,mapping,new_avoid + | LetIn na -> + let new_na, mapping, new_avoid = next_name_away na Id.Map.empty avoid in + (LetIn new_na, mapping, new_avoid) + | Prod na -> + let new_na, mapping, new_avoid = next_name_away na Id.Map.empty avoid in + (Prod new_na, mapping, new_avoid) + | Lambda na -> + let new_na, mapping, new_avoid = next_name_away na Id.Map.empty avoid in + (Lambda new_na, mapping, new_avoid) in let rec do_apply avoid ctxt body args = - match ctxt,args with - | _,[] -> (* No more args *) - (ctxt,body) - | [],_ -> (* no more fun *) - let f,args' = glob_decompose_app body in - (ctxt,mkGApp(f,args'@args)) - | (Lambda Anonymous,t)::ctxt',arg::args' -> - do_apply avoid ctxt' body args' - | (Lambda (Name id),t)::ctxt',arg::args' -> - let new_avoid,new_ctxt',new_body,new_id = - if need_convert_id avoid id - then - let new_avoid = Id.Set.add id avoid in - let new_id = Namegen.next_ident_away id new_avoid in - let new_avoid' = Id.Set.add new_id new_avoid in - let mapping = Id.Map.add id new_id Id.Map.empty in - let new_ctxt' = change_vars_in_binder mapping ctxt' in - let new_body = change_vars mapping body in - new_avoid',new_ctxt',new_body,new_id - else - Id.Set.add id avoid,ctxt',body,id - in - let new_body = replace_var_by_term new_id arg new_body in - let new_ctxt' = replace_var_by_term_in_binder new_id arg new_ctxt' in - do_apply avoid new_ctxt' new_body args' - | (bt,t)::ctxt',_ -> - let new_avoid,new_ctxt',new_body,new_bt = - let new_avoid = add_bt_names bt avoid in - if need_convert avoid bt - then - let new_bt,mapping,new_avoid = next_bt_away bt new_avoid in - ( - new_avoid, - change_vars_in_binder mapping ctxt', - change_vars mapping body, - new_bt - ) - else new_avoid,ctxt',body,bt - in - let new_ctxt',new_body = - do_apply new_avoid new_ctxt' new_body args - in - (new_bt,t)::new_ctxt',new_body + match (ctxt, args) with + | _, [] -> + (* No more args *) + (ctxt, body) + | [], _ -> + (* no more fun *) + let f, args' = glob_decompose_app body in + (ctxt, mkGApp (f, args' @ args)) + | (Lambda Anonymous, t) :: ctxt', arg :: args' -> + do_apply avoid ctxt' body args' + | (Lambda (Name id), t) :: ctxt', arg :: args' -> + let new_avoid, new_ctxt', new_body, new_id = + if need_convert_id avoid id then + let new_avoid = Id.Set.add id avoid in + let new_id = Namegen.next_ident_away id new_avoid in + let new_avoid' = Id.Set.add new_id new_avoid in + let mapping = Id.Map.add id new_id Id.Map.empty in + let new_ctxt' = change_vars_in_binder mapping ctxt' in + let new_body = change_vars mapping body in + (new_avoid', new_ctxt', new_body, new_id) + else (Id.Set.add id avoid, ctxt', body, id) + in + let new_body = replace_var_by_term new_id arg new_body in + let new_ctxt' = replace_var_by_term_in_binder new_id arg new_ctxt' in + do_apply avoid new_ctxt' new_body args' + | (bt, t) :: ctxt', _ -> + let new_avoid, new_ctxt', new_body, new_bt = + let new_avoid = add_bt_names bt avoid in + if need_convert avoid bt then + let new_bt, mapping, new_avoid = next_bt_away bt new_avoid in + ( new_avoid + , change_vars_in_binder mapping ctxt' + , change_vars mapping body + , new_bt ) + else (new_avoid, ctxt', body, bt) + in + let new_ctxt', new_body = do_apply new_avoid new_ctxt' new_body args in + ((new_bt, t) :: new_ctxt', new_body) in do_apply Id.Set.empty ctxt body args - let combine_app f args = - let new_ctxt,new_value = apply_args f.context f.value args.value in - { - (* Note that the binding context of [args] MUST be placed before the one of + let new_ctxt, new_value = apply_args f.context f.value args.value in + { (* Note that the binding context of [args] MUST be placed before the one of the applied value in order to preserve possible type dependencies *) - context = args.context@new_ctxt; - value = new_value; - } + context = args.context @ new_ctxt + ; value = new_value } let combine_lam n t b = - { - context = []; - value = mkGLambda(n, compose_glob_context t.context t.value, - compose_glob_context b.context b.value ) - } + { context = [] + ; value = + mkGLambda + ( n + , compose_glob_context t.context t.value + , compose_glob_context b.context b.value ) } let combine_prod2 n t b = - { - context = []; - value = mkGProd(n, compose_glob_context t.context t.value, - compose_glob_context b.context b.value ) - } + { context = [] + ; value = + mkGProd + ( n + , compose_glob_context t.context t.value + , compose_glob_context b.context b.value ) } let combine_prod n t b = - { context = t.context@((Prod n,t.value)::b.context); value = b.value} + {context = t.context @ ((Prod n, t.value) :: b.context); value = b.value} let combine_letin n t b = - { context = t.context@((LetIn n,t.value)::b.context); value = b.value} - + {context = t.context @ ((LetIn n, t.value) :: b.context); value = b.value} let mk_result ctxt value avoid = - { - result = - [{context = ctxt; - value = value}] - ; - to_avoid = avoid - } + {result = [{context = ctxt; value}]; to_avoid = avoid} + (************************************************* Some functions to deal with overlapping patterns **************************************************) -let coq_True_ref = lazy (Coqlib.lib_ref "core.True.type") +let coq_True_ref = lazy (Coqlib.lib_ref "core.True.type") let coq_False_ref = lazy (Coqlib.lib_ref "core.False.type") (* [make_discr_match_el \[e1,...en\]] builds match e1,...,en with (the list of expressions on which we will do the matching) *) -let make_discr_match_el = - List.map (fun e -> (e,(Anonymous,None))) +let make_discr_match_el = List.map (fun e -> (e, (Anonymous, None))) (* [make_discr_match_brl i \[pat_1,...,pat_n\]] constructs a discrimination pattern matching on the ith expression. @@ -283,23 +250,21 @@ let make_discr_match_el = *) let make_discr_match_brl i = List.map_i - (fun j {CAst.v=(idl,patl,_)} -> CAst.make @@ - if Int.equal j i - then (idl,patl, mkGRef (Lazy.force coq_True_ref)) - else (idl,patl, mkGRef (Lazy.force coq_False_ref)) - ) + (fun j {CAst.v = idl, patl, _} -> + CAst.make + @@ + if Int.equal j i then (idl, patl, mkGRef (Lazy.force coq_True_ref)) + else (idl, patl, mkGRef (Lazy.force coq_False_ref))) 0 + (* [make_discr_match brl el i] generates an hypothesis such that it reduce to true iff brl_{i} is the first branch matched by [el] Used when we want to simulate the coq pattern matching algorithm *) -let make_discr_match brl = - fun el i -> - mkGCases(None, - make_discr_match_el el, - make_discr_match_brl i brl) +let make_discr_match brl el i = + mkGCases (None, make_discr_match_el el, make_discr_match_brl i brl) (**********************************************************************) (* functions used to build case expression from lettuple and if ones *) @@ -307,140 +272,159 @@ let make_discr_match brl = (* [build_constructors_of_type] construct the array of pattern of its inductive argument*) let build_constructors_of_type ind' argl = - let (mib,ind) = Inductive.lookup_mind_specif (Global.env()) ind' in + let mib, ind = Inductive.lookup_mind_specif (Global.env ()) ind' in let npar = mib.Declarations.mind_nparams in - Array.mapi (fun i _ -> - let construct = ind',i+1 in - let constructref = GlobRef.ConstructRef(construct) in - let _implicit_positions_of_cst = - Impargs.implicits_of_global constructref - in - let cst_narg = - Inductiveops.constructor_nallargs - (Global.env ()) - construct - in - let argl = - if List.is_empty argl then - List.make cst_narg (mkGHole ()) - else - List.make npar (mkGHole ()) @ argl - in - let pat_as_term = - mkGApp(mkGRef (GlobRef.ConstructRef(ind',i+1)),argl) - in - cases_pattern_of_glob_constr (Global.env()) Anonymous pat_as_term - ) + Array.mapi + (fun i _ -> + let construct = (ind', i + 1) in + let constructref = GlobRef.ConstructRef construct in + let _implicit_positions_of_cst = + Impargs.implicits_of_global constructref + in + let cst_narg = + Inductiveops.constructor_nallargs (Global.env ()) construct + in + let argl = + if List.is_empty argl then List.make cst_narg (mkGHole ()) + else List.make npar (mkGHole ()) @ argl + in + let pat_as_term = + mkGApp (mkGRef (GlobRef.ConstructRef (ind', i + 1)), argl) + in + cases_pattern_of_glob_constr (Global.env ()) Anonymous pat_as_term) ind.Declarations.mind_consnames (******************) (* Main functions *) (******************) - - -let raw_push_named (na,raw_value,raw_typ) env = +let raw_push_named (na, raw_value, raw_typ) env = match na with - | Anonymous -> env - | Name id -> - let typ,_ = Pretyping.understand env (Evd.from_env env) ~expected_type:Pretyping.IsType raw_typ in - let na = make_annot id Sorts.Relevant in (* TODO relevance *) - (match raw_value with - | None -> - EConstr.push_named (NamedDecl.LocalAssum (na,typ)) env - | Some value -> - EConstr.push_named (NamedDecl.LocalDef (na, value, typ)) env) - + | Anonymous -> env + | Name id -> ( + let typ, _ = + Pretyping.understand env (Evd.from_env env) + ~expected_type:Pretyping.IsType raw_typ + in + let na = make_annot id Sorts.Relevant in + (* TODO relevance *) + match raw_value with + | None -> EConstr.push_named (NamedDecl.LocalAssum (na, typ)) env + | Some value -> EConstr.push_named (NamedDecl.LocalDef (na, value, typ)) env + ) let add_pat_variables sigma pat typ env : Environ.env = - let rec add_pat_variables env pat typ : Environ.env = - observe (str "new rel env := " ++ Printer.pr_rel_context_of env (Evd.from_env env)); - + let rec add_pat_variables env pat typ : Environ.env = + observe + (str "new rel env := " ++ Printer.pr_rel_context_of env (Evd.from_env env)); match DAst.get pat with - | PatVar na -> Environ.push_rel (RelDecl.LocalAssum (make_annot na Sorts.Relevant,typ)) env - | PatCstr(c,patl,na) -> - let Inductiveops.IndType(indf,indargs) = - try Inductiveops.find_rectype env (Evd.from_env env) (EConstr.of_constr typ) - with Not_found -> assert false - in - let constructors = Inductiveops.get_constructors env indf in - let constructor : Inductiveops.constructor_summary = List.find (fun cs -> eq_constructor c (fst cs.Inductiveops.cs_cstr)) (Array.to_list constructors) in - let cs_args_types :types list = List.map RelDecl.get_type constructor.Inductiveops.cs_args in - List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) + | PatVar na -> + Environ.push_rel + (RelDecl.LocalAssum (make_annot na Sorts.Relevant, typ)) + env + | PatCstr (c, patl, na) -> + let (Inductiveops.IndType (indf, indargs)) = + try + Inductiveops.find_rectype env (Evd.from_env env) + (EConstr.of_constr typ) + with Not_found -> assert false + in + let constructors = Inductiveops.get_constructors env indf in + let constructor : Inductiveops.constructor_summary = + List.find + (fun cs -> eq_constructor c (fst cs.Inductiveops.cs_cstr)) + (Array.to_list constructors) + in + let cs_args_types : types list = + List.map RelDecl.get_type constructor.Inductiveops.cs_args + in + List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) in let new_env = add_pat_variables env pat typ in let res = - fst ( - Context.Rel.fold_outside - (fun decl (env,ctxt) -> + fst + (Context.Rel.fold_outside + (fun decl (env, ctxt) -> let open Context.Rel.Declaration in match decl with - | LocalAssum ({binder_name=Anonymous},_) | LocalDef ({binder_name=Anonymous},_,_) -> assert false - | LocalAssum ({binder_name=Name id} as na, t) -> - let na = {na with binder_name=id} in - let new_t = substl ctxt t in - observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++ - str "old type := " ++ Printer.pr_lconstr_env env sigma t ++ fnl () ++ - str "new type := " ++ Printer.pr_lconstr_env env sigma new_t ++ fnl () - ); + | LocalAssum ({binder_name = Anonymous}, _) + |LocalDef ({binder_name = Anonymous}, _, _) -> + assert false + | LocalAssum (({binder_name = Name id} as na), t) -> + let na = {na with binder_name = id} in + let new_t = substl ctxt t in + observe + ( str "for variable " ++ Ppconstr.pr_id id ++ fnl () + ++ str "old type := " + ++ Printer.pr_lconstr_env env sigma t + ++ fnl () ++ str "new type := " + ++ Printer.pr_lconstr_env env sigma new_t + ++ fnl () ); let open Context.Named.Declaration in - (Environ.push_named (LocalAssum (na,new_t)) env,mkVar id::ctxt) - | LocalDef ({binder_name=Name id} as na, v, t) -> - let na = {na with binder_name=id} in - let new_t = substl ctxt t in + (Environ.push_named (LocalAssum (na, new_t)) env, mkVar id :: ctxt) + | LocalDef (({binder_name = Name id} as na), v, t) -> + let na = {na with binder_name = id} in + let new_t = substl ctxt t in let new_v = substl ctxt v in - observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++ - str "old type := " ++ Printer.pr_lconstr_env env sigma t ++ fnl () ++ - str "new type := " ++ Printer.pr_lconstr_env env sigma new_t ++ fnl () ++ - str "old value := " ++ Printer.pr_lconstr_env env sigma v ++ fnl () ++ - str "new value := " ++ Printer.pr_lconstr_env env sigma new_v ++ fnl () - ); + observe + ( str "for variable " ++ Ppconstr.pr_id id ++ fnl () + ++ str "old type := " + ++ Printer.pr_lconstr_env env sigma t + ++ fnl () ++ str "new type := " + ++ Printer.pr_lconstr_env env sigma new_t + ++ fnl () ++ str "old value := " + ++ Printer.pr_lconstr_env env sigma v + ++ fnl () ++ str "new value := " + ++ Printer.pr_lconstr_env env sigma new_v + ++ fnl () ); let open Context.Named.Declaration in - (Environ.push_named (LocalDef (na,new_v,new_t)) env,mkVar id::ctxt) - ) - (Environ.rel_context new_env) - ~init:(env,[]) - ) + ( Environ.push_named (LocalDef (na, new_v, new_t)) env + , mkVar id :: ctxt )) + (Environ.rel_context new_env) + ~init:(env, [])) in - observe (str "new var env := " ++ Printer.pr_named_context_of res (Evd.from_env env)); + observe + (str "new var env := " ++ Printer.pr_named_context_of res (Evd.from_env env)); res - - - -let rec pattern_to_term_and_type env typ = DAst.with_val (function - | PatVar Anonymous -> assert false - | PatVar (Name id) -> - mkGVar id - | PatCstr(constr,patternl,_) -> - let cst_narg = - Inductiveops.constructor_nallargs - (Global.env ()) - constr - in - let Inductiveops.IndType(indf,indargs) = - try Inductiveops.find_rectype env (Evd.from_env env) (EConstr.of_constr typ) +let rec pattern_to_term_and_type env typ = + DAst.with_val (function + | PatVar Anonymous -> assert false + | PatVar (Name id) -> mkGVar id + | PatCstr (constr, patternl, _) -> + let cst_narg = Inductiveops.constructor_nallargs (Global.env ()) constr in + let (Inductiveops.IndType (indf, indargs)) = + try + Inductiveops.find_rectype env (Evd.from_env env) + (EConstr.of_constr typ) with Not_found -> assert false in let constructors = Inductiveops.get_constructors env indf in - let constructor = List.find (fun cs -> eq_constructor (fst cs.Inductiveops.cs_cstr) constr) (Array.to_list constructors) in - let cs_args_types :types list = List.map RelDecl.get_type constructor.Inductiveops.cs_args in - let _,cstl = Inductiveops.dest_ind_family indf in + let constructor = + List.find + (fun cs -> eq_constructor (fst cs.Inductiveops.cs_cstr) constr) + (Array.to_list constructors) + in + let cs_args_types : types list = + List.map RelDecl.get_type constructor.Inductiveops.cs_args + in + let _, cstl = Inductiveops.dest_ind_family indf in let csta = Array.of_list cstl in let implicit_args = Array.to_list (Array.init (cst_narg - List.length patternl) - (fun i -> Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_env env) (EConstr.of_constr csta.(i))) - ) + (fun i -> + Detyping.detype Detyping.Now false Id.Set.empty env + (Evd.from_env env) + (EConstr.of_constr csta.(i)))) in let patl_as_term = - List.map2 (pattern_to_term_and_type env) (List.rev cs_args_types) patternl + List.map2 + (pattern_to_term_and_type env) + (List.rev cs_args_types) patternl in - mkGApp(mkGRef(GlobRef.ConstructRef constr), - implicit_args@patl_as_term - ) - ) + mkGApp (mkGRef (GlobRef.ConstructRef constr), implicit_args @ patl_as_term)) (* [build_entry_lc funnames avoid rt] construct the list (in fact a build_entry_return) of constructors corresponding to [rt] when replacing calls to [funnames] by calls to the @@ -473,448 +457,427 @@ let rec pattern_to_term_and_type env typ = DAst.with_val (function but only the value of the function *) - -let rec build_entry_lc env sigma funnames avoid rt : glob_constr build_entry_return = +let rec build_entry_lc env sigma funnames avoid rt : + glob_constr build_entry_return = observe (str " Entering : " ++ Printer.pr_glob_constr_env env rt); let open CAst in match DAst.get rt with - | GRef _ | GVar _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ | GFloat _ -> - (* do nothing (except changing type of course) *) - mk_result [] rt avoid - | GApp(_,_) -> - let f,args = glob_decompose_app rt in - let args_res : (glob_constr list) build_entry_return = - List.fold_right (* create the arguments lists of constructors and combine them *) - (fun arg ctxt_argsl -> - let arg_res = build_entry_lc env sigma funnames ctxt_argsl.to_avoid arg in - combine_results combine_args arg_res ctxt_argsl - ) - args - (mk_result [] [] avoid) - in - begin - match DAst.get f with - | GLambda _ -> - let rec aux t l = - match l with - | [] -> t - | u::l -> DAst.make @@ - match DAst.get t with - | GLambda(na,_,nat,b) -> - GLetIn(na,u,None,aux b l) - | _ -> - GApp(t,l) - in - build_entry_lc env sigma funnames avoid (aux f args) - | GVar id when Id.Set.mem id funnames -> - (* if we have [f t1 ... tn] with [f]$\in$[fnames] - then we create a fresh variable [res], - add [res] and its "value" (i.e. [res v1 ... vn]) to each - pseudo constructor build for the arguments (i.e. a pseudo context [ctxt] and - a pseudo value "v1 ... vn". - The "value" of this branch is then simply [res] - *) - (* XXX here and other [understand] calls drop the ctx *) - let rt_as_constr,ctx = Pretyping.understand env (Evd.from_env env) rt in - let rt_typ = Retyping.get_type_of env (Evd.from_env env) rt_as_constr in - let res_raw_type = Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_env env) rt_typ in - let res = fresh_id args_res.to_avoid "_res" in - let new_avoid = res::args_res.to_avoid in - let res_rt = mkGVar res in - let new_result = - List.map - (fun arg_res -> - let new_hyps = - [Prod (Name res),res_raw_type; - Prod Anonymous,mkGApp(res_rt,(mkGVar id)::arg_res.value)] - in - {context = arg_res.context@new_hyps; value = res_rt } - ) - args_res.result - in - { result = new_result; to_avoid = new_avoid } - | GVar _ | GEvar _ | GPatVar _ | GHole _ | GSort _ | GRef _ -> - (* if have [g t1 ... tn] with [g] not appearing in [funnames] - then - foreach [ctxt,v1 ... vn] in [args_res] we return - [ctxt, g v1 .... vn] - *) - { - args_res with - result = - List.map - (fun args_res -> - {args_res with value = mkGApp(f,args_res.value)}) - args_res.result - } - | GApp _ -> assert false (* we have collected all the app in [glob_decompose_app] *) - | GLetIn(n,v,t,b) -> - (* if we have [(let x := v in b) t1 ... tn] , - we discard our work and compute the list of constructor for - [let x = v in (b t1 ... tn)] up to alpha conversion - *) - let new_n,new_b,new_avoid = - match n with - | Name id when List.exists (is_free_in id) args -> - (* need to alpha-convert the name *) - let new_id = Namegen.next_ident_away id (Id.Set.of_list avoid) in - let new_avoid = id:: avoid in - let new_b = - replace_var_by_term - id - (DAst.make @@ GVar id) - b - in - (Name new_id,new_b,new_avoid) - | _ -> n,b,avoid - in - build_entry_lc - env - sigma - funnames - avoid - (mkGLetIn(new_n,v,t,mkGApp(new_b,args))) - | GCases _ | GIf _ | GLetTuple _ -> - (* we have [(match e1, ...., en with ..... end) t1 tn] - we first compute the result from the case and - then combine each of them with each of args one - *) - let f_res = build_entry_lc env sigma funnames args_res.to_avoid f in - combine_results combine_app f_res args_res - | GCast(b,_) -> - (* for an applied cast we just trash the cast part - and restart the work. - - WARNING: We need to restart since [b] itself should be an application term - *) - build_entry_lc env sigma funnames avoid (mkGApp(b,args)) - | GRec _ -> user_err Pp.(str "Not handled GRec") - | GProd _ -> user_err Pp.(str "Cannot apply a type") - | GInt _ -> user_err Pp.(str "Cannot apply an integer") - | GFloat _ -> user_err Pp.(str "Cannot apply a float") - end (* end of the application treatement *) - - | GLambda(n,_,t,b) -> - (* we first compute the list of constructor - corresponding to the body of the function, - then the one corresponding to the type - and combine the two result - *) - let t_res = build_entry_lc env sigma funnames avoid t in - let new_n = - match n with - | Name _ -> n - | Anonymous -> Name (Indfun_common.fresh_id [] "_x") - in - let new_env = raw_push_named (new_n,None,t) env in - let b_res = build_entry_lc new_env sigma funnames avoid b in - combine_results (combine_lam new_n) t_res b_res - | GProd(n,_,t,b) -> - (* we first compute the list of constructor - corresponding to the body of the function, - then the one corresponding to the type - and combine the two result - *) - let t_res = build_entry_lc env sigma funnames avoid t in - let new_env = raw_push_named (n,None,t) env in - let b_res = build_entry_lc new_env sigma funnames avoid b in - if List.length t_res.result = 1 && List.length b_res.result = 1 - then combine_results (combine_prod2 n) t_res b_res - else combine_results (combine_prod n) t_res b_res - | GLetIn(n,v,typ,b) -> - (* we first compute the list of constructor - corresponding to the body of the function, - then the one corresponding to the value [t] - and combine the two result - *) - let v = match typ with None -> v | Some t -> DAst.make ?loc:rt.loc @@ GCast (v,CastConv t) in - let v_res = build_entry_lc env sigma funnames avoid v in - let v_as_constr,ctx = Pretyping.understand env (Evd.from_env env) v in - let v_type = Retyping.get_type_of env (Evd.from_env env) v_as_constr in - let v_r = Sorts.Relevant in (* TODO relevance *) - let new_env = - match n with - Anonymous -> env - | Name id -> EConstr.push_named (NamedDecl.LocalDef (make_annot id v_r,v_as_constr,v_type)) env - in - let b_res = build_entry_lc new_env sigma funnames avoid b in - combine_results (combine_letin n) v_res b_res - | GCases(_,_,el,brl) -> - (* we create the discrimination function - and treat the case itself - *) - let make_discr = make_discr_match brl in - build_entry_lc_from_case env sigma funnames make_discr el brl avoid - | GIf(b,(na,e_option),lhs,rhs) -> - let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in - let b_typ = Retyping.get_type_of env (Evd.from_env env) b_as_constr in - let (ind,_) = - try Inductiveops.find_inductive env (Evd.from_env env) b_typ - with Not_found -> - user_err (str "Cannot find the inductive associated to " ++ - Printer.pr_glob_constr_env env b ++ str " in " ++ - Printer.pr_glob_constr_env env rt ++ str ". try again with a cast") - in - let case_pats = build_constructors_of_type (fst ind) [] in - assert (Int.equal (Array.length case_pats) 2); - let brl = - List.map_i - (fun i x -> CAst.make ([],[case_pats.(i)],x)) - 0 - [lhs;rhs] - in - let match_expr = - mkGCases(None,[(b,(Anonymous,None))],brl) - in - (* Pp.msgnl (str "new case := " ++ Printer.pr_glob_constr match_expr); *) - build_entry_lc env sigma funnames avoid match_expr - | GLetTuple(nal,_,b,e) -> - begin - let nal_as_glob_constr = - List.map - (function - Name id -> mkGVar id - | Anonymous -> mkGHole () - ) - nal - in - let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in - let b_typ = Retyping.get_type_of env (Evd.from_env env) b_as_constr in - let (ind,_) = - try Inductiveops.find_inductive env (Evd.from_env env) b_typ - with Not_found -> - user_err (str "Cannot find the inductive associated to " ++ - Printer.pr_glob_constr_env env b ++ str " in " ++ - Printer.pr_glob_constr_env env rt ++ str ". try again with a cast") + | GRef _ | GVar _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ + |GFloat _ -> + (* do nothing (except changing type of course) *) + mk_result [] rt avoid + | GApp (_, _) -> ( + let f, args = glob_decompose_app rt in + let args_res : glob_constr list build_entry_return = + List.fold_right + (* create the arguments lists of constructors and combine them *) + (fun arg ctxt_argsl -> + let arg_res = + build_entry_lc env sigma funnames ctxt_argsl.to_avoid arg in - let case_pats = build_constructors_of_type (fst ind) nal_as_glob_constr in - assert (Int.equal (Array.length case_pats) 1); - let br = CAst.make ([],[case_pats.(0)],e) in - let match_expr = mkGCases(None,[b,(Anonymous,None)],[br]) in - build_entry_lc env sigma funnames avoid match_expr - - end + combine_results combine_args arg_res ctxt_argsl) + args (mk_result [] [] avoid) + in + match DAst.get f with + | GLambda _ -> + let rec aux t l = + match l with + | [] -> t + | u :: l -> ( + DAst.make + @@ + match DAst.get t with + | GLambda (na, _, nat, b) -> GLetIn (na, u, None, aux b l) + | _ -> GApp (t, l) ) + in + build_entry_lc env sigma funnames avoid (aux f args) + | GVar id when Id.Set.mem id funnames -> + (* if we have [f t1 ... tn] with [f]$\in$[fnames] + then we create a fresh variable [res], + add [res] and its "value" (i.e. [res v1 ... vn]) to each + pseudo constructor build for the arguments (i.e. a pseudo context [ctxt] and + a pseudo value "v1 ... vn". + The "value" of this branch is then simply [res] + *) + (* XXX here and other [understand] calls drop the ctx *) + let rt_as_constr, ctx = Pretyping.understand env (Evd.from_env env) rt in + let rt_typ = Retyping.get_type_of env (Evd.from_env env) rt_as_constr in + let res_raw_type = + Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_env env) + rt_typ + in + let res = fresh_id args_res.to_avoid "_res" in + let new_avoid = res :: args_res.to_avoid in + let res_rt = mkGVar res in + let new_result = + List.map + (fun arg_res -> + let new_hyps = + [ (Prod (Name res), res_raw_type) + ; (Prod Anonymous, mkGApp (res_rt, mkGVar id :: arg_res.value)) ] + in + {context = arg_res.context @ new_hyps; value = res_rt}) + args_res.result + in + {result = new_result; to_avoid = new_avoid} + | GVar _ | GEvar _ | GPatVar _ | GHole _ | GSort _ | GRef _ -> + (* if have [g t1 ... tn] with [g] not appearing in [funnames] + then + foreach [ctxt,v1 ... vn] in [args_res] we return + [ctxt, g v1 .... vn] + *) + { args_res with + result = + List.map + (fun args_res -> {args_res with value = mkGApp (f, args_res.value)}) + args_res.result } + | GApp _ -> + assert false (* we have collected all the app in [glob_decompose_app] *) + | GLetIn (n, v, t, b) -> + (* if we have [(let x := v in b) t1 ... tn] , + we discard our work and compute the list of constructor for + [let x = v in (b t1 ... tn)] up to alpha conversion + *) + let new_n, new_b, new_avoid = + match n with + | Name id when List.exists (is_free_in id) args -> + (* need to alpha-convert the name *) + let new_id = Namegen.next_ident_away id (Id.Set.of_list avoid) in + let new_avoid = id :: avoid in + let new_b = replace_var_by_term id (DAst.make @@ GVar id) b in + (Name new_id, new_b, new_avoid) + | _ -> (n, b, avoid) + in + build_entry_lc env sigma funnames avoid + (mkGLetIn (new_n, v, t, mkGApp (new_b, args))) + | GCases _ | GIf _ | GLetTuple _ -> + (* we have [(match e1, ...., en with ..... end) t1 tn] + we first compute the result from the case and + then combine each of them with each of args one + *) + let f_res = build_entry_lc env sigma funnames args_res.to_avoid f in + combine_results combine_app f_res args_res + | GCast (b, _) -> + (* for an applied cast we just trash the cast part + and restart the work. + + WARNING: We need to restart since [b] itself should be an application term + *) + build_entry_lc env sigma funnames avoid (mkGApp (b, args)) | GRec _ -> user_err Pp.(str "Not handled GRec") - | GCast(b,_) -> - build_entry_lc env sigma funnames avoid b -and build_entry_lc_from_case env sigma funname make_discr - (el:tomatch_tuples) - (brl:Glob_term.cases_clauses) avoid : - glob_constr build_entry_return = + | GProd _ -> user_err Pp.(str "Cannot apply a type") + | GInt _ -> user_err Pp.(str "Cannot apply an integer") + | GFloat _ -> user_err Pp.(str "Cannot apply a float") + (* end of the application treatement *) ) + | GLambda (n, _, t, b) -> + (* we first compute the list of constructor + corresponding to the body of the function, + then the one corresponding to the type + and combine the two result + *) + let t_res = build_entry_lc env sigma funnames avoid t in + let new_n = + match n with + | Name _ -> n + | Anonymous -> Name (Indfun_common.fresh_id [] "_x") + in + let new_env = raw_push_named (new_n, None, t) env in + let b_res = build_entry_lc new_env sigma funnames avoid b in + combine_results (combine_lam new_n) t_res b_res + | GProd (n, _, t, b) -> + (* we first compute the list of constructor + corresponding to the body of the function, + then the one corresponding to the type + and combine the two result + *) + let t_res = build_entry_lc env sigma funnames avoid t in + let new_env = raw_push_named (n, None, t) env in + let b_res = build_entry_lc new_env sigma funnames avoid b in + if List.length t_res.result = 1 && List.length b_res.result = 1 then + combine_results (combine_prod2 n) t_res b_res + else combine_results (combine_prod n) t_res b_res + | GLetIn (n, v, typ, b) -> + (* we first compute the list of constructor + corresponding to the body of the function, + then the one corresponding to the value [t] + and combine the two result + *) + let v = + match typ with + | None -> v + | Some t -> DAst.make ?loc:rt.loc @@ GCast (v, CastConv t) + in + let v_res = build_entry_lc env sigma funnames avoid v in + let v_as_constr, ctx = Pretyping.understand env (Evd.from_env env) v in + let v_type = Retyping.get_type_of env (Evd.from_env env) v_as_constr in + let v_r = Sorts.Relevant in + (* TODO relevance *) + let new_env = + match n with + | Anonymous -> env + | Name id -> + EConstr.push_named + (NamedDecl.LocalDef (make_annot id v_r, v_as_constr, v_type)) + env + in + let b_res = build_entry_lc new_env sigma funnames avoid b in + combine_results (combine_letin n) v_res b_res + | GCases (_, _, el, brl) -> + (* we create the discrimination function + and treat the case itself + *) + let make_discr = make_discr_match brl in + build_entry_lc_from_case env sigma funnames make_discr el brl avoid + | GIf (b, (na, e_option), lhs, rhs) -> + let b_as_constr, ctx = Pretyping.understand env (Evd.from_env env) b in + let b_typ = Retyping.get_type_of env (Evd.from_env env) b_as_constr in + let ind, _ = + try Inductiveops.find_inductive env (Evd.from_env env) b_typ + with Not_found -> + user_err + ( str "Cannot find the inductive associated to " + ++ Printer.pr_glob_constr_env env b + ++ str " in " + ++ Printer.pr_glob_constr_env env rt + ++ str ". try again with a cast" ) + in + let case_pats = build_constructors_of_type (fst ind) [] in + assert (Int.equal (Array.length case_pats) 2); + let brl = + List.map_i (fun i x -> CAst.make ([], [case_pats.(i)], x)) 0 [lhs; rhs] + in + let match_expr = mkGCases (None, [(b, (Anonymous, None))], brl) in + (* Pp.msgnl (str "new case := " ++ Printer.pr_glob_constr match_expr); *) + build_entry_lc env sigma funnames avoid match_expr + | GLetTuple (nal, _, b, e) -> + let nal_as_glob_constr = + List.map (function Name id -> mkGVar id | Anonymous -> mkGHole ()) nal + in + let b_as_constr, ctx = Pretyping.understand env (Evd.from_env env) b in + let b_typ = Retyping.get_type_of env (Evd.from_env env) b_as_constr in + let ind, _ = + try Inductiveops.find_inductive env (Evd.from_env env) b_typ + with Not_found -> + user_err + ( str "Cannot find the inductive associated to " + ++ Printer.pr_glob_constr_env env b + ++ str " in " + ++ Printer.pr_glob_constr_env env rt + ++ str ". try again with a cast" ) + in + let case_pats = build_constructors_of_type (fst ind) nal_as_glob_constr in + assert (Int.equal (Array.length case_pats) 1); + let br = CAst.make ([], [case_pats.(0)], e) in + let match_expr = mkGCases (None, [(b, (Anonymous, None))], [br]) in + build_entry_lc env sigma funnames avoid match_expr + | GRec _ -> user_err Pp.(str "Not handled GRec") + | GCast (b, _) -> build_entry_lc env sigma funnames avoid b + +and build_entry_lc_from_case env sigma funname make_discr (el : tomatch_tuples) + (brl : Glob_term.cases_clauses) avoid : glob_constr build_entry_return = match el with - | [] -> assert false (* this case correspond to match <nothing> with .... !*) - | el -> - (* this case correspond to - match el with brl end - we first compute the list of lists corresponding to [el] and - combine them . - Then for each element of the combinations, - we compute the result we compute one list per branch in [brl] and - finally we just concatenate those list - *) - let case_resl = - List.fold_right - (fun (case_arg,_) ctxt_argsl -> - let arg_res = build_entry_lc env sigma funname ctxt_argsl.to_avoid case_arg in - combine_results combine_args arg_res ctxt_argsl - ) - el - (mk_result [] [] avoid) - in - let types = - List.map (fun (case_arg,_) -> - let case_arg_as_constr,ctx = Pretyping.understand env (Evd.from_env env) case_arg in - EConstr.Unsafe.to_constr (Retyping.get_type_of env (Evd.from_env env) case_arg_as_constr) - ) el - in - (****** The next works only if the match is not dependent ****) - let results = - List.map - (fun ca -> - let res = build_entry_lc_from_case_term - env sigma types - funname (make_discr) - [] brl - case_resl.to_avoid - ca - in - res - ) - case_resl.result - in - { - result = List.concat (List.map (fun r -> r.result) results); - to_avoid = - List.fold_left (fun acc r -> List.union Id.equal acc r.to_avoid) - [] results - } - -and build_entry_lc_from_case_term env sigma types funname make_discr patterns_to_prevent brl avoid - matched_expr = + | [] -> assert false (* this case correspond to match <nothing> with .... !*) + | el -> + (* this case correspond to + match el with brl end + we first compute the list of lists corresponding to [el] and + combine them . + Then for each element of the combinations, + we compute the result we compute one list per branch in [brl] and + finally we just concatenate those list + *) + let case_resl = + List.fold_right + (fun (case_arg, _) ctxt_argsl -> + let arg_res = + build_entry_lc env sigma funname ctxt_argsl.to_avoid case_arg + in + combine_results combine_args arg_res ctxt_argsl) + el (mk_result [] [] avoid) + in + let types = + List.map + (fun (case_arg, _) -> + let case_arg_as_constr, ctx = + Pretyping.understand env (Evd.from_env env) case_arg + in + EConstr.Unsafe.to_constr + (Retyping.get_type_of env (Evd.from_env env) case_arg_as_constr)) + el + in + (****** The next works only if the match is not dependent ****) + let results = + List.map + (fun ca -> + let res = + build_entry_lc_from_case_term env sigma types funname make_discr [] + brl case_resl.to_avoid ca + in + res) + case_resl.result + in + { result = List.concat (List.map (fun r -> r.result) results) + ; to_avoid = + List.fold_left + (fun acc r -> List.union Id.equal acc r.to_avoid) + [] results } + +and build_entry_lc_from_case_term env sigma types funname make_discr + patterns_to_prevent brl avoid matched_expr = match brl with - | [] -> (* computed_branches *) {result = [];to_avoid = avoid} - | br::brl' -> - (* alpha conversion to prevent name clashes *) - let {CAst.v=(idl,patl,return)} = alpha_br avoid br in - let new_avoid = idl@avoid in (* for now we can no more use idl as an identifier *) - (* building a list of precondition stating that we are not in this branch - (will be used in the following recursive calls) - *) - let new_env = List.fold_right2 (add_pat_variables sigma) patl types env in - let not_those_patterns : (Id.t list -> glob_constr -> glob_constr) list = - List.map2 - (fun pat typ -> - fun avoid pat'_as_term -> - let renamed_pat,_,_ = alpha_pat avoid pat in - let pat_ids = get_pattern_id renamed_pat in - let env_with_pat_ids = add_pat_variables sigma pat typ new_env in - List.fold_right - (fun id acc -> - let typ_of_id = Typing.type_of_variable env_with_pat_ids id in - let raw_typ_of_id = - Detyping.detype Detyping.Now false Id.Set.empty - env_with_pat_ids (Evd.from_env env) typ_of_id - in - mkGProd (Name id,raw_typ_of_id,acc)) - pat_ids - (glob_make_neq pat'_as_term (pattern_to_term renamed_pat)) - ) - patl - types - in - (* Checking if we can be in this branch - (will be used in the following recursive calls) - *) - let unify_with_those_patterns : (cases_pattern -> bool*bool) list = - List.map - (fun pat pat' -> are_unifiable pat pat',eq_cases_pattern pat pat') - patl - in - (* + | [] -> (* computed_branches *) {result = []; to_avoid = avoid} + | br :: brl' -> + (* alpha conversion to prevent name clashes *) + let {CAst.v = idl, patl, return} = alpha_br avoid br in + let new_avoid = idl @ avoid in + (* for now we can no more use idl as an identifier *) + (* building a list of precondition stating that we are not in this branch + (will be used in the following recursive calls) + *) + let new_env = List.fold_right2 (add_pat_variables sigma) patl types env in + let not_those_patterns : (Id.t list -> glob_constr -> glob_constr) list = + List.map2 + (fun pat typ avoid pat'_as_term -> + let renamed_pat, _, _ = alpha_pat avoid pat in + let pat_ids = get_pattern_id renamed_pat in + let env_with_pat_ids = add_pat_variables sigma pat typ new_env in + List.fold_right + (fun id acc -> + let typ_of_id = Typing.type_of_variable env_with_pat_ids id in + let raw_typ_of_id = + Detyping.detype Detyping.Now false Id.Set.empty env_with_pat_ids + (Evd.from_env env) typ_of_id + in + mkGProd (Name id, raw_typ_of_id, acc)) + pat_ids + (glob_make_neq pat'_as_term (pattern_to_term renamed_pat))) + patl types + in + (* Checking if we can be in this branch + (will be used in the following recursive calls) + *) + let unify_with_those_patterns : (cases_pattern -> bool * bool) list = + List.map + (fun pat pat' -> (are_unifiable pat pat', eq_cases_pattern pat pat')) + patl + in + (* we first compute the other branch result (in ordrer to keep the order of the matching as much as possible) *) - let brl'_res = - build_entry_lc_from_case_term - env - sigma - types - funname - make_discr - ((unify_with_those_patterns,not_those_patterns)::patterns_to_prevent) - brl' - avoid - matched_expr - in - (* We now create the precondition of this branch i.e. - 1- the list of variable appearing in the different patterns of this branch and - the list of equation stating than el = patl (List.flatten ...) - 2- If there exists a previous branch which pattern unify with the one of this branch - then a discrimination precond stating that we are not in a previous branch (if List.exists ...) - *) - let those_pattern_preconds = - (List.flatten - ( - List.map3 - (fun pat e typ_as_constr -> - let this_pat_ids = ids_of_pat pat in - let typ_as_constr = EConstr.of_constr typ_as_constr in - let typ = Detyping.detype Detyping.Now false Id.Set.empty new_env (Evd.from_env env) typ_as_constr in - let pat_as_term = pattern_to_term pat in - (* removing trivial holes *) - let pat_as_term = solve_trivial_holes pat_as_term e in - (* observe (str "those_pattern_preconds" ++ spc () ++ *) - (* str "pat" ++ spc () ++ pr_glob_constr pat_as_term ++ spc ()++ *) - (* str "e" ++ spc () ++ pr_glob_constr e ++spc ()++ *) - (* str "typ_as_constr" ++ spc () ++ pr_lconstr typ_as_constr); *) - List.fold_right - (fun id acc -> - if Id.Set.mem id this_pat_ids - then (Prod (Name id), - let typ_of_id = Typing.type_of_variable new_env id in - let raw_typ_of_id = - Detyping.detype Detyping.Now false Id.Set.empty new_env (Evd.from_env env) typ_of_id - in - raw_typ_of_id - )::acc - else acc - ) - idl - [(Prod Anonymous,glob_make_eq ~typ pat_as_term e)] - ) - patl - matched_expr.value - types - ) - ) - @ - (if List.exists (function (unifl,_) -> - let (unif,_) = - List.split (List.map2 (fun x y -> x y) unifl patl) - in - List.for_all (fun x -> x) unif) patterns_to_prevent - then - let i = List.length patterns_to_prevent in - let pats_as_constr = List.map2 (pattern_to_term_and_type new_env) types patl in - [(Prod Anonymous,make_discr pats_as_constr i )] - else - [] - ) - in - (* We compute the result of the value returned by the branch*) - let return_res = build_entry_lc new_env sigma funname new_avoid return in - (* and combine it with the preconds computed for this branch *) - let this_branch_res = - List.map - (fun res -> - { context = matched_expr.context@those_pattern_preconds@res.context ; - value = res.value} - ) - return_res.result + let brl'_res = + build_entry_lc_from_case_term env sigma types funname make_discr + ((unify_with_those_patterns, not_those_patterns) :: patterns_to_prevent) + brl' avoid matched_expr + in + (* We now create the precondition of this branch i.e. + 1- the list of variable appearing in the different patterns of this branch and + the list of equation stating than el = patl (List.flatten ...) + 2- If there exists a previous branch which pattern unify with the one of this branch + then a discrimination precond stating that we are not in a previous branch (if List.exists ...) + *) + let those_pattern_preconds = + List.flatten + (List.map3 + (fun pat e typ_as_constr -> + let this_pat_ids = ids_of_pat pat in + let typ_as_constr = EConstr.of_constr typ_as_constr in + let typ = + Detyping.detype Detyping.Now false Id.Set.empty new_env + (Evd.from_env env) typ_as_constr + in + let pat_as_term = pattern_to_term pat in + (* removing trivial holes *) + let pat_as_term = solve_trivial_holes pat_as_term e in + (* observe (str "those_pattern_preconds" ++ spc () ++ *) + (* str "pat" ++ spc () ++ pr_glob_constr pat_as_term ++ spc ()++ *) + (* str "e" ++ spc () ++ pr_glob_constr e ++spc ()++ *) + (* str "typ_as_constr" ++ spc () ++ pr_lconstr typ_as_constr); *) + List.fold_right + (fun id acc -> + if Id.Set.mem id this_pat_ids then + ( Prod (Name id) + , let typ_of_id = Typing.type_of_variable new_env id in + let raw_typ_of_id = + Detyping.detype Detyping.Now false Id.Set.empty new_env + (Evd.from_env env) typ_of_id + in + raw_typ_of_id ) + :: acc + else acc) + idl + [(Prod Anonymous, glob_make_eq ~typ pat_as_term e)]) + patl matched_expr.value types) + @ + if + List.exists + (function + | unifl, _ -> + let unif, _ = + List.split (List.map2 (fun x y -> x y) unifl patl) + in + List.for_all (fun x -> x) unif) + patterns_to_prevent + then + let i = List.length patterns_to_prevent in + let pats_as_constr = + List.map2 (pattern_to_term_and_type new_env) types patl in - { brl'_res with result = this_branch_res@brl'_res.result } - + [(Prod Anonymous, make_discr pats_as_constr i)] + else [] + in + (* We compute the result of the value returned by the branch*) + let return_res = build_entry_lc new_env sigma funname new_avoid return in + (* and combine it with the preconds computed for this branch *) + let this_branch_res = + List.map + (fun res -> + { context = matched_expr.context @ those_pattern_preconds @ res.context + ; value = res.value }) + return_res.result + in + {brl'_res with result = this_branch_res @ brl'_res.result} -let is_res r = match DAst.get r with -| GVar id -> - begin try - String.equal (String.sub (Id.to_string id) 0 4) "_res" - with Invalid_argument _ -> false end -| _ -> false +let is_res r = + match DAst.get r with + | GVar id -> ( + try String.equal (String.sub (Id.to_string id) 0 4) "_res" + with Invalid_argument _ -> false ) + | _ -> false -let is_gr c gr = match DAst.get c with -| GRef (r, _) -> GlobRef.equal r gr -| _ -> false +let is_gr c gr = + match DAst.get c with GRef (r, _) -> GlobRef.equal r gr | _ -> false -let is_gvar c = match DAst.get c with -| GVar id -> true -| _ -> false +let is_gvar c = match DAst.get c with GVar id -> true | _ -> false let same_raw_term rt1 rt2 = - match DAst.get rt1, DAst.get rt2 with - | GRef(r1,_), GRef (r2,_) -> GlobRef.equal r1 r2 - | GHole _, GHole _ -> true - | _ -> false + match (DAst.get rt1, DAst.get rt2) with + | GRef (r1, _), GRef (r2, _) -> GlobRef.equal r1 r2 + | GHole _, GHole _ -> true + | _ -> false + let decompose_raw_eq env lhs rhs = let rec decompose_raw_eq lhs rhs acc = - observe (str "decomposing eq for " ++ pr_glob_constr_env env lhs ++ str " " ++ pr_glob_constr_env env rhs); - let (rhd,lrhs) = glob_decompose_app rhs in - let (lhd,llhs) = glob_decompose_app lhs in + observe + ( str "decomposing eq for " ++ pr_glob_constr_env env lhs ++ str " " + ++ pr_glob_constr_env env rhs ); + let rhd, lrhs = glob_decompose_app rhs in + let lhd, llhs = glob_decompose_app lhs in observe (str "lhd := " ++ pr_glob_constr_env env lhd); observe (str "rhd := " ++ pr_glob_constr_env env rhd); observe (str "llhs := " ++ int (List.length llhs)); observe (str "lrhs := " ++ int (List.length lrhs)); let sllhs = List.length llhs in let slrhs = List.length lrhs in - if same_raw_term lhd rhd && Int.equal sllhs slrhs - then + if same_raw_term lhd rhd && Int.equal sllhs slrhs then (* let _ = assert false in *) - List.fold_right2 decompose_raw_eq llhs lrhs acc - else (lhs,rhs)::acc + List.fold_right2 decompose_raw_eq llhs lrhs acc + else (lhs, rhs) :: acc in decompose_raw_eq lhs rhs [] exception Continue + (* The second phase which reconstruct the real type of the constructor. rebuild the globalized constructors expression. @@ -925,304 +888,283 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let open Context.Rel.Declaration in let open CAst in match DAst.get rt with - | GProd(n,k,t,b) -> - let not_free_in_t id = not (is_free_in id t) in - let new_crossed_types = t::crossed_types in - begin - match DAst.get t with - | GApp(res_rt ,args') when is_res res_rt -> - begin - let arg = List.hd args' in - match DAst.get arg with - | GVar this_relname -> - (*i The next call to mk_rel_id is - valid since we are constructing the graph - Ensures by: obvious - i*) - - let new_t = - mkGApp(mkGVar(mk_rel_id this_relname),List.tl args'@[res_rt]) - in - let t',ctx = Pretyping.understand env (Evd.from_env env) new_t in - let r = Sorts.Relevant in (* TODO relevance *) - let new_env = EConstr.push_rel (LocalAssum (make_annot n r,t')) env in - let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - args new_crossed_types - (depth + 1) b - in - mkGProd(n,new_t,new_b), - Id.Set.filter not_free_in_t id_to_exclude - | _ -> (* the first args is the name of the function! *) - assert false - end - | GApp(eq_as_ref,[ty; id ;rt]) - when is_gvar id && is_gr eq_as_ref Coqlib.(lib_ref "core.eq.type") && n == Anonymous - -> - let loc1 = rt.CAst.loc in - let loc2 = eq_as_ref.CAst.loc in - let loc3 = id.CAst.loc in - let id = match DAst.get id with GVar id -> id | _ -> assert false in - begin - try - observe (str "computing new type for eq : " ++ pr_glob_constr_env env rt); - let t' = - try fst (Pretyping.understand env (Evd.from_env env) t)(*FIXME*) - with e when CErrors.noncritical e -> raise Continue - in - let is_in_b = is_free_in id b in - let _keep_eq = - not (List.exists (is_free_in id) args) || is_in_b || - List.exists (is_free_in id) crossed_types - in - let new_args = List.map (replace_var_by_term id rt) args in - let subst_b = - if is_in_b then b else replace_var_by_term id rt b - in - let r = Sorts.Relevant in (* TODO relevance *) - let new_env = EConstr.push_rel (LocalAssum (make_annot n r,t')) env in - let new_b,id_to_exclude = - rebuild_cons - new_env - nb_args relname - new_args new_crossed_types - (depth + 1) subst_b - in - mkGProd(n,t,new_b),id_to_exclude - with Continue -> - let jmeq = GlobRef.IndRef (fst (EConstr.destInd Evd.empty (jmeq ()))) in - let ty',ctx = Pretyping.understand env (Evd.from_env env) ty in - let ind,args' = Inductiveops.find_inductive env Evd.(from_env env) ty' in - let mib,_ = Global.lookup_inductive (fst ind) in - let nparam = mib.Declarations.mind_nparams in - let params,arg' = - ((Util.List.chop nparam args')) - in - let rt_typ = DAst.make @@ - GApp(DAst.make @@ GRef (GlobRef.IndRef (fst ind),None), - (List.map - (fun p -> Detyping.detype Detyping.Now false Id.Set.empty - env (Evd.from_env env) - (EConstr.of_constr p)) params)@(Array.to_list - (Array.make - (List.length args' - nparam) - (mkGHole ())))) - in - let eq' = - DAst.make ?loc:loc1 @@ GApp(DAst.make ?loc:loc2 @@GRef(jmeq,None),[ty;DAst.make ?loc:loc3 @@ GVar id;rt_typ;rt]) - in - observe (str "computing new type for jmeq : " ++ pr_glob_constr_env env eq'); - let eq'_as_constr,ctx = Pretyping.understand env (Evd.from_env env) eq' in - observe (str " computing new type for jmeq : done") ; - let sigma = Evd.(from_env env) in - let new_args = - match EConstr.kind sigma eq'_as_constr with - | App(_,[|_;_;ty;_|]) -> - let ty = Array.to_list (snd (EConstr.destApp sigma ty)) in - let ty' = snd (Util.List.chop nparam ty) in - List.fold_left2 - (fun acc var_as_constr arg -> - if isRel var_as_constr - then - let na = RelDecl.get_name (Environ.lookup_rel (destRel var_as_constr) env) in - match na with - | Anonymous -> acc - | Name id' -> - (id',Detyping.detype Detyping.Now false Id.Set.empty - env - (Evd.from_env env) - arg)::acc - else if isVar var_as_constr - then (destVar var_as_constr,Detyping.detype Detyping.Now false Id.Set.empty - env - (Evd.from_env env) - arg)::acc - else acc - ) - [] - arg' - ty' - | _ -> assert false - in - let is_in_b = is_free_in id b in - let _keep_eq = - not (List.exists (is_free_in id) args) || is_in_b || - List.exists (is_free_in id) crossed_types - in - let new_args = - List.fold_left - (fun args (id,rt) -> - List.map (replace_var_by_term id rt) args - ) - args - ((id,rt)::new_args) - in - let subst_b = - if is_in_b then b else replace_var_by_term id rt b - in - let new_env = - let t',ctx = Pretyping.understand env (Evd.from_env env) eq' in - let r = Sorts.Relevant in (* TODO relevance *) - EConstr.push_rel (LocalAssum (make_annot n r,t')) env - in - let new_b,id_to_exclude = - rebuild_cons - new_env - nb_args relname - new_args new_crossed_types - (depth + 1) subst_b - in - mkGProd(n,eq',new_b),id_to_exclude - end - (* J.F:. keep this comment it explain how to remove some meaningless equalities - if keep_eq then - mkGProd(n,t,new_b),id_to_exclude - else new_b, Id.Set.add id id_to_exclude - *) - | GApp(eq_as_ref,[ty;rt1;rt2]) - when is_gr eq_as_ref Coqlib.(lib_ref "core.eq.type") && n == Anonymous - -> - begin - try - let l = decompose_raw_eq env rt1 rt2 in - if List.length l > 1 - then - let new_rt = - List.fold_left - (fun acc (lhs,rhs) -> - mkGProd(Anonymous, - mkGApp(mkGRef Coqlib.(lib_ref "core.eq.type"),[mkGHole ();lhs;rhs]),acc) - ) - b - l - in - rebuild_cons env nb_args relname args crossed_types depth new_rt - else raise Continue - with Continue -> - observe (str "computing new type for prod : " ++ pr_glob_constr_env env rt); - let t',ctx = Pretyping.understand env (Evd.from_env env) t in - let r = Sorts.Relevant in (* TODO relevance *) - let new_env = EConstr.push_rel (LocalAssum (make_annot n r,t')) env in - let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - args new_crossed_types - (depth + 1) b - in - match n with - | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> - new_b,Id.Set.remove id - (Id.Set.filter not_free_in_t id_to_exclude) - | _ -> mkGProd(n,t,new_b),Id.Set.filter not_free_in_t id_to_exclude - end - | _ -> - observe (str "computing new type for prod : " ++ pr_glob_constr_env env rt); - let t',ctx = Pretyping.understand env (Evd.from_env env) t in - let r = Sorts.Relevant in (* TODO relevance *) - let new_env = EConstr.push_rel (LocalAssum (make_annot n r,t')) env in - let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - args new_crossed_types - (depth + 1) b - in - match n with - | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> - new_b,Id.Set.remove id - (Id.Set.filter not_free_in_t id_to_exclude) - | _ -> mkGProd(n,t,new_b),Id.Set.filter not_free_in_t id_to_exclude - end - | GLambda(n,k,t,b) -> - begin - let not_free_in_t id = not (is_free_in id t) in - let new_crossed_types = t :: crossed_types in - observe (str "computing new type for lambda : " ++ pr_glob_constr_env env rt); - let t',ctx = Pretyping.understand env (Evd.from_env env) t in - match n with - | Name id -> - let r = Sorts.Relevant in (* TODO relevance *) - let new_env = EConstr.push_rel (LocalAssum (make_annot n r,t')) env in - let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - (args@[mkGVar id])new_crossed_types - (depth + 1 ) b - in - if Id.Set.mem id id_to_exclude && depth >= nb_args - then - new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) - else - DAst.make @@ GProd(n,k,t,new_b),Id.Set.filter not_free_in_t id_to_exclude - | _ -> anomaly (Pp.str "Should not have an anonymous function here.") - (* We have renamed all the anonymous functions during alpha_renaming phase *) - - end - | GLetIn(n,v,t,b) -> - begin - let t = match t with None -> v | Some t -> DAst.make ?loc:rt.loc @@ GCast (v,CastConv t) in - let not_free_in_t id = not (is_free_in id t) in - let evd = (Evd.from_env env) in - let t',ctx = Pretyping.understand env evd t in - let evd = Evd.from_ctx ctx in - let type_t' = Retyping.get_type_of env evd t' in - let t' = EConstr.Unsafe.to_constr t' in - let type_t' = EConstr.Unsafe.to_constr type_t' in - let new_env = Environ.push_rel (LocalDef (make_annot n Sorts.Relevant,t',type_t')) env in - let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - args (t::crossed_types) - (depth + 1 ) b in - match n with - | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> - new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) - | _ -> DAst.make @@ GLetIn(n,t,None,new_b), (* HOPING IT WOULD WORK *) - Id.Set.filter not_free_in_t id_to_exclude - end - | GLetTuple(nal,(na,rto),t,b) -> - assert (Option.is_empty rto); - begin - let not_free_in_t id = not (is_free_in id t) in - let new_t,id_to_exclude' = - rebuild_cons env - nb_args - relname - args (crossed_types) - depth t - in - let t',ctx = Pretyping.understand env (Evd.from_env env) new_t in - let r = Sorts.Relevant in (* TODO relevance *) - let new_env = EConstr.push_rel (LocalAssum (make_annot na r,t')) env in - let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - args (t::crossed_types) - (depth + 1) b + | GProd (n, k, t, b) -> ( + let not_free_in_t id = not (is_free_in id t) in + let new_crossed_types = t :: crossed_types in + match DAst.get t with + | GApp (res_rt, args') when is_res res_rt -> ( + let arg = List.hd args' in + match DAst.get arg with + | GVar this_relname -> + (*i The next call to mk_rel_id is + valid since we are constructing the graph + Ensures by: obvious + i*) + let new_t = + mkGApp (mkGVar (mk_rel_id this_relname), List.tl args' @ [res_rt]) + in + let t', ctx = Pretyping.understand env (Evd.from_env env) new_t in + let r = Sorts.Relevant in + (* TODO relevance *) + let new_env = EConstr.push_rel (LocalAssum (make_annot n r, t')) env in + let new_b, id_to_exclude = + rebuild_cons new_env nb_args relname args new_crossed_types + (depth + 1) b + in + (mkGProd (n, new_t, new_b), Id.Set.filter not_free_in_t id_to_exclude) + | _ -> + (* the first args is the name of the function! *) + assert false ) + | GApp (eq_as_ref, [ty; id; rt]) + when is_gvar id + && is_gr eq_as_ref Coqlib.(lib_ref "core.eq.type") + && n == Anonymous -> ( + let loc1 = rt.CAst.loc in + let loc2 = eq_as_ref.CAst.loc in + let loc3 = id.CAst.loc in + let id = match DAst.get id with GVar id -> id | _ -> assert false in + try + observe (str "computing new type for eq : " ++ pr_glob_constr_env env rt); + let t' = + try fst (Pretyping.understand env (Evd.from_env env) t) (*FIXME*) + with e when CErrors.noncritical e -> raise Continue + in + let is_in_b = is_free_in id b in + let _keep_eq = + (not (List.exists (is_free_in id) args)) + || is_in_b + || List.exists (is_free_in id) crossed_types + in + let new_args = List.map (replace_var_by_term id rt) args in + let subst_b = if is_in_b then b else replace_var_by_term id rt b in + let r = Sorts.Relevant in + (* TODO relevance *) + let new_env = EConstr.push_rel (LocalAssum (make_annot n r, t')) env in + let new_b, id_to_exclude = + rebuild_cons new_env nb_args relname new_args new_crossed_types + (depth + 1) subst_b + in + (mkGProd (n, t, new_b), id_to_exclude) + with Continue -> + let jmeq = GlobRef.IndRef (fst (EConstr.destInd Evd.empty (jmeq ()))) in + let ty', ctx = Pretyping.understand env (Evd.from_env env) ty in + let ind, args' = + Inductiveops.find_inductive env Evd.(from_env env) ty' + in + let mib, _ = Global.lookup_inductive (fst ind) in + let nparam = mib.Declarations.mind_nparams in + let params, arg' = Util.List.chop nparam args' in + let rt_typ = + DAst.make + @@ GApp + ( DAst.make @@ GRef (GlobRef.IndRef (fst ind), None) + , List.map + (fun p -> + Detyping.detype Detyping.Now false Id.Set.empty env + (Evd.from_env env) (EConstr.of_constr p)) + params + @ Array.to_list + (Array.make (List.length args' - nparam) (mkGHole ())) ) + in + let eq' = + DAst.make ?loc:loc1 + @@ GApp + ( DAst.make ?loc:loc2 @@ GRef (jmeq, None) + , [ty; DAst.make ?loc:loc3 @@ GVar id; rt_typ; rt] ) + in + observe + (str "computing new type for jmeq : " ++ pr_glob_constr_env env eq'); + let eq'_as_constr, ctx = + Pretyping.understand env (Evd.from_env env) eq' + in + observe (str " computing new type for jmeq : done"); + let sigma = Evd.(from_env env) in + let new_args = + match EConstr.kind sigma eq'_as_constr with + | App (_, [|_; _; ty; _|]) -> + let ty = Array.to_list (snd (EConstr.destApp sigma ty)) in + let ty' = snd (Util.List.chop nparam ty) in + List.fold_left2 + (fun acc var_as_constr arg -> + if isRel var_as_constr then + let na = + RelDecl.get_name + (Environ.lookup_rel (destRel var_as_constr) env) + in + match na with + | Anonymous -> acc + | Name id' -> + ( id' + , Detyping.detype Detyping.Now false Id.Set.empty env + (Evd.from_env env) arg ) + :: acc + else if isVar var_as_constr then + ( destVar var_as_constr + , Detyping.detype Detyping.Now false Id.Set.empty env + (Evd.from_env env) arg ) + :: acc + else acc) + [] arg' ty' + | _ -> assert false + in + let is_in_b = is_free_in id b in + let _keep_eq = + (not (List.exists (is_free_in id) args)) + || is_in_b + || List.exists (is_free_in id) crossed_types + in + let new_args = + List.fold_left + (fun args (id, rt) -> List.map (replace_var_by_term id rt) args) + args ((id, rt) :: new_args) + in + let subst_b = if is_in_b then b else replace_var_by_term id rt b in + let new_env = + let t', ctx = Pretyping.understand env (Evd.from_env env) eq' in + let r = Sorts.Relevant in + (* TODO relevance *) + EConstr.push_rel (LocalAssum (make_annot n r, t')) env + in + let new_b, id_to_exclude = + rebuild_cons new_env nb_args relname new_args new_crossed_types + (depth + 1) subst_b + in + (mkGProd (n, eq', new_b), id_to_exclude) + (* J.F:. keep this comment it explain how to remove some meaningless equalities + if keep_eq then + mkGProd(n,t,new_b),id_to_exclude + else new_b, Id.Set.add id id_to_exclude + *) ) + | GApp (eq_as_ref, [ty; rt1; rt2]) + when is_gr eq_as_ref Coqlib.(lib_ref "core.eq.type") && n == Anonymous + -> ( + try + let l = decompose_raw_eq env rt1 rt2 in + if List.length l > 1 then + let new_rt = + List.fold_left + (fun acc (lhs, rhs) -> + mkGProd + ( Anonymous + , mkGApp + ( mkGRef Coqlib.(lib_ref "core.eq.type") + , [mkGHole (); lhs; rhs] ) + , acc )) + b l in -(* match n with *) -(* | Name id when Id.Set.mem id id_to_exclude -> *) -(* new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) *) -(* | _ -> *) - DAst.make @@ GLetTuple(nal,(na,None),t,new_b), - Id.Set.filter not_free_in_t (Id.Set.union id_to_exclude id_to_exclude') - - end - - | _ -> mkGApp(mkGVar relname,args@[rt]),Id.Set.empty - + rebuild_cons env nb_args relname args crossed_types depth new_rt + else raise Continue + with Continue -> ( + observe + (str "computing new type for prod : " ++ pr_glob_constr_env env rt); + let t', ctx = Pretyping.understand env (Evd.from_env env) t in + let r = Sorts.Relevant in + (* TODO relevance *) + let new_env = EConstr.push_rel (LocalAssum (make_annot n r, t')) env in + let new_b, id_to_exclude = + rebuild_cons new_env nb_args relname args new_crossed_types + (depth + 1) b + in + match n with + | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> + (new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude)) + | _ -> (mkGProd (n, t, new_b), Id.Set.filter not_free_in_t id_to_exclude) ) + ) + | _ -> ( + observe (str "computing new type for prod : " ++ pr_glob_constr_env env rt); + let t', ctx = Pretyping.understand env (Evd.from_env env) t in + let r = Sorts.Relevant in + (* TODO relevance *) + let new_env = EConstr.push_rel (LocalAssum (make_annot n r, t')) env in + let new_b, id_to_exclude = + rebuild_cons new_env nb_args relname args new_crossed_types (depth + 1) + b + in + match n with + | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> + (new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude)) + | _ -> (mkGProd (n, t, new_b), Id.Set.filter not_free_in_t id_to_exclude) + ) ) + | GLambda (n, k, t, b) -> ( + let not_free_in_t id = not (is_free_in id t) in + let new_crossed_types = t :: crossed_types in + observe (str "computing new type for lambda : " ++ pr_glob_constr_env env rt); + let t', ctx = Pretyping.understand env (Evd.from_env env) t in + match n with + | Name id -> + let r = Sorts.Relevant in + (* TODO relevance *) + let new_env = EConstr.push_rel (LocalAssum (make_annot n r, t')) env in + let new_b, id_to_exclude = + rebuild_cons new_env nb_args relname + (args @ [mkGVar id]) + new_crossed_types (depth + 1) b + in + if Id.Set.mem id id_to_exclude && depth >= nb_args then + (new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude)) + else + ( DAst.make @@ GProd (n, k, t, new_b) + , Id.Set.filter not_free_in_t id_to_exclude ) + | _ -> anomaly (Pp.str "Should not have an anonymous function here.") + (* We have renamed all the anonymous functions during alpha_renaming phase *) + ) + | GLetIn (n, v, t, b) -> ( + let t = + match t with + | None -> v + | Some t -> DAst.make ?loc:rt.loc @@ GCast (v, CastConv t) + in + let not_free_in_t id = not (is_free_in id t) in + let evd = Evd.from_env env in + let t', ctx = Pretyping.understand env evd t in + let evd = Evd.from_ctx ctx in + let type_t' = Retyping.get_type_of env evd t' in + let t' = EConstr.Unsafe.to_constr t' in + let type_t' = EConstr.Unsafe.to_constr type_t' in + let new_env = + Environ.push_rel (LocalDef (make_annot n Sorts.Relevant, t', type_t')) env + in + let new_b, id_to_exclude = + rebuild_cons new_env nb_args relname args (t :: crossed_types) (depth + 1) + b + in + match n with + | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> + (new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude)) + | _ -> + ( DAst.make @@ GLetIn (n, t, None, new_b) + , (* HOPING IT WOULD WORK *) + Id.Set.filter not_free_in_t id_to_exclude ) ) + | GLetTuple (nal, (na, rto), t, b) -> + assert (Option.is_empty rto); + let not_free_in_t id = not (is_free_in id t) in + let new_t, id_to_exclude' = + rebuild_cons env nb_args relname args crossed_types depth t + in + let t', ctx = Pretyping.understand env (Evd.from_env env) new_t in + let r = Sorts.Relevant in + (* TODO relevance *) + let new_env = EConstr.push_rel (LocalAssum (make_annot na r, t')) env in + let new_b, id_to_exclude = + rebuild_cons new_env nb_args relname args (t :: crossed_types) (depth + 1) + b + in + (* match n with *) + (* | Name id when Id.Set.mem id id_to_exclude -> *) + (* new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) *) + (* | _ -> *) + ( DAst.make @@ GLetTuple (nal, (na, None), t, new_b) + , Id.Set.filter not_free_in_t (Id.Set.union id_to_exclude id_to_exclude') ) + | _ -> (mkGApp (mkGVar relname, args @ [rt]), Id.Set.empty) (* debugging wrapper *) let rebuild_cons env nb_args relname args crossed_types rt = -(* observennl (str "rebuild_cons : rt := "++ pr_glob_constr rt ++ *) -(* str "nb_args := " ++ str (string_of_int nb_args)); *) - let res = - rebuild_cons env nb_args relname args crossed_types 0 rt - in -(* observe (str " leads to "++ pr_glob_constr (fst res)); *) + (* observennl (str "rebuild_cons : rt := "++ pr_glob_constr rt ++ *) + (* str "nb_args := " ++ str (string_of_int nb_args)); *) + let res = rebuild_cons env nb_args relname args crossed_types 0 rt in + (* observe (str " leads to "++ pr_glob_constr (fst res)); *) res - (* naive implementation of parameter detection. A parameter is an argument which is only preceded by parameters and whose @@ -1230,92 +1172,103 @@ let rebuild_cons env nb_args relname args crossed_types rt = TODO: Find a valid way to deal with implicit arguments here! *) -let rec compute_cst_params relnames params gt = DAst.with_val (function - | GRef _ | GVar _ | GEvar _ | GPatVar _ | GInt _ | GFloat _ -> params - | GApp(f,args) -> - begin match DAst.get f with - | GVar relname' when Id.Set.mem relname' relnames -> - compute_cst_params_from_app [] (params,args) - | _ -> - List.fold_left (compute_cst_params relnames) params (f::args) - end - | GLambda(_,_,t,b) | GProd(_,_,t,b) | GLetTuple(_,_,t,b) -> - let t_params = compute_cst_params relnames params t in - compute_cst_params relnames t_params b - | GLetIn(_,v,t,b) -> - let v_params = compute_cst_params relnames params v in - let t_params = Option.fold_left (compute_cst_params relnames) v_params t in - compute_cst_params relnames t_params b - | GCases _ -> - params (* If there is still cases at this point they can only be - discrimination ones *) - | GSort _ -> params - | GHole _ -> params - | GIf _ | GRec _ | GCast _ -> - CErrors.user_err ~hdr:"compute_cst_params" (str "Not handled case") - ) gt -and compute_cst_params_from_app acc (params,rtl) = - let is_gid id c = match DAst.get c with GVar id' -> Id.equal id id' | _ -> false in - match params,rtl with - | _::_,[] -> assert false (* the rel has at least nargs + 1 arguments ! *) - | ((Name id,_,None) as param)::params', c::rtl' when is_gid id c -> - compute_cst_params_from_app (param::acc) (params',rtl') - | _ -> List.rev acc - -let compute_params_name relnames (args : (Name.t * Glob_term.glob_constr * glob_constr option) list array) csts = +let rec compute_cst_params relnames params gt = + DAst.with_val + (function + | GRef _ | GVar _ | GEvar _ | GPatVar _ | GInt _ | GFloat _ -> params + | GApp (f, args) -> ( + match DAst.get f with + | GVar relname' when Id.Set.mem relname' relnames -> + compute_cst_params_from_app [] (params, args) + | _ -> List.fold_left (compute_cst_params relnames) params (f :: args) ) + | GLambda (_, _, t, b) | GProd (_, _, t, b) | GLetTuple (_, _, t, b) -> + let t_params = compute_cst_params relnames params t in + compute_cst_params relnames t_params b + | GLetIn (_, v, t, b) -> + let v_params = compute_cst_params relnames params v in + let t_params = + Option.fold_left (compute_cst_params relnames) v_params t + in + compute_cst_params relnames t_params b + | GCases _ -> + params + (* If there is still cases at this point they can only be + discrimination ones *) + | GSort _ -> params + | GHole _ -> params + | GIf _ | GRec _ | GCast _ -> + CErrors.user_err ~hdr:"compute_cst_params" (str "Not handled case")) + gt + +and compute_cst_params_from_app acc (params, rtl) = + let is_gid id c = + match DAst.get c with GVar id' -> Id.equal id id' | _ -> false + in + match (params, rtl) with + | _ :: _, [] -> assert false (* the rel has at least nargs + 1 arguments ! *) + | ((Name id, _, None) as param) :: params', c :: rtl' when is_gid id c -> + compute_cst_params_from_app (param :: acc) (params', rtl') + | _ -> List.rev acc + +let compute_params_name relnames + (args : (Name.t * Glob_term.glob_constr * glob_constr option) list array) + csts = let rels_params = Array.mapi (fun i args -> - List.fold_left - (fun params (_,cst) -> compute_cst_params relnames params cst) - args - csts.(i) - ) + List.fold_left + (fun params (_, cst) -> compute_cst_params relnames params cst) + args csts.(i)) args in let l = ref [] in let _ = try List.iteri - (fun i ((n,nt,typ) as param) -> - if Array.for_all - (fun l -> - let (n',nt',typ') = List.nth l i in - Name.equal n n' && glob_constr_eq nt nt' && Option.equal glob_constr_eq typ typ') - rels_params - then - l := param::!l - ) + (fun i ((n, nt, typ) as param) -> + if + Array.for_all + (fun l -> + let n', nt', typ' = List.nth l i in + Name.equal n n' && glob_constr_eq nt nt' + && Option.equal glob_constr_eq typ typ') + rels_params + then l := param :: !l) rels_params.(0) - with e when CErrors.noncritical e -> - () + with e when CErrors.noncritical e -> () in List.rev !l let rec rebuild_return_type rt = let loc = rt.CAst.loc in match rt.CAst.v with - | Constrexpr.CProdN(n,t') -> - CAst.make ?loc @@ Constrexpr.CProdN(n,rebuild_return_type t') - | Constrexpr.CLetIn(na,v,t,t') -> - CAst.make ?loc @@ Constrexpr.CLetIn(na,v,t,rebuild_return_type t') - | _ -> CAst.make ?loc @@ Constrexpr.CProdN([Constrexpr.CLocalAssum ([CAst.make Anonymous], - Constrexpr.Default Explicit, rt)], - CAst.make @@ Constrexpr.CSort(UAnonymous {rigid=true})) - -let do_build_inductive - evd (funconstants: pconstant list) (funsargs: (Name.t * glob_constr * glob_constr option) list list) - returned_types - (rtl:glob_constr list) = + | Constrexpr.CProdN (n, t') -> + CAst.make ?loc @@ Constrexpr.CProdN (n, rebuild_return_type t') + | Constrexpr.CLetIn (na, v, t, t') -> + CAst.make ?loc @@ Constrexpr.CLetIn (na, v, t, rebuild_return_type t') + | _ -> + CAst.make ?loc + @@ Constrexpr.CProdN + ( [ Constrexpr.CLocalAssum + ([CAst.make Anonymous], Constrexpr.Default Explicit, rt) ] + , CAst.make @@ Constrexpr.CSort (UAnonymous {rigid = true}) ) + +let do_build_inductive evd (funconstants : pconstant list) + (funsargs : (Name.t * glob_constr * glob_constr option) list list) + returned_types (rtl : glob_constr list) = let _time1 = System.get_time () in - let funnames = List.map (fun c -> Label.to_id (KerName.label (Constant.canonical (fst c)))) funconstants in + let funnames = + List.map + (fun c -> Label.to_id (KerName.label (Constant.canonical (fst c)))) + funconstants + in (* Pp.msgnl (prlist_with_sep fnl Printer.pr_glob_constr rtl); *) let funnames_as_set = List.fold_right Id.Set.add funnames Id.Set.empty in let funnames = Array.of_list funnames in let funsargs = Array.of_list funsargs in let returned_types = Array.of_list returned_types in (* alpha_renaming of the body to prevent variable capture during manipulation *) - let rtl_alpha = List.map (function rt -> expand_as (alpha_rt [] rt)) rtl in + let rtl_alpha = List.map (function rt -> expand_as (alpha_rt [] rt)) rtl in let rta = Array.of_list rtl_alpha in (*i The next call to mk_rel_id is valid since we are constructing the graph Ensures by: obvious @@ -1324,46 +1277,64 @@ let do_build_inductive let relnames_as_set = Array.fold_right Id.Set.add relnames Id.Set.empty in (* Construction of the pseudo constructors *) let open Context.Named.Declaration in - let evd,env = + let evd, env = Array.fold_right2 - (fun id (c, u) (evd,env) -> - let u = EConstr.EInstance.make u in - let evd,t = Typing.type_of env evd (EConstr.mkConstU (c, u)) in - let t = EConstr.Unsafe.to_constr t in - evd, - Environ.push_named (LocalAssum (make_annot id Sorts.Relevant,t)) - env - ) + (fun id (c, u) (evd, env) -> + let u = EConstr.EInstance.make u in + let evd, t = Typing.type_of env evd (EConstr.mkConstU (c, u)) in + let t = EConstr.Unsafe.to_constr t in + ( evd + , Environ.push_named (LocalAssum (make_annot id Sorts.Relevant, t)) env + )) funnames (Array.of_list funconstants) - (evd,Global.env ()) + (evd, Global.env ()) in (* we solve and replace the implicits *) let rta = - Array.mapi (fun i rt -> - let _,t = Typing.type_of env evd (EConstr.of_constr (mkConstU ((Array.of_list funconstants).(i)))) in - resolve_and_replace_implicits ~expected_type:(Pretyping.OfType t) env evd rt - ) rta + Array.mapi + (fun i rt -> + let _, t = + Typing.type_of env evd + (EConstr.of_constr (mkConstU (Array.of_list funconstants).(i))) + in + resolve_and_replace_implicits ~expected_type:(Pretyping.OfType t) env + evd rt) + rta in let resa = Array.map (build_entry_lc env evd funnames_as_set []) rta in let env_with_graphs = - let rel_arity i funargs = (* Rebuilding arities (with parameters) *) - let rel_first_args :(Name.t * Glob_term.glob_constr * Glob_term.glob_constr option ) list = + let rel_arity i funargs = + (* Rebuilding arities (with parameters) *) + let rel_first_args : + (Name.t * Glob_term.glob_constr * Glob_term.glob_constr option) list = funargs in List.fold_right - (fun (n,t,typ) acc -> + (fun (n, t, typ) acc -> match typ with | Some typ -> - CAst.make @@ Constrexpr.CLetIn((CAst.make n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t, - Some (with_full_print (Constrextern.extern_glob_constr Id.Set.empty) typ), - acc) + CAst.make + @@ Constrexpr.CLetIn + ( CAst.make n + , with_full_print + (Constrextern.extern_glob_constr Id.Set.empty) + t + , Some + (with_full_print + (Constrextern.extern_glob_constr Id.Set.empty) + typ) + , acc ) | None -> - CAst.make @@ Constrexpr.CProdN - ([Constrexpr.CLocalAssum([CAst.make n],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t)], - acc - ) - ) + CAst.make + @@ Constrexpr.CProdN + ( [ Constrexpr.CLocalAssum + ( [CAst.make n] + , Constrexpr_ops.default_binder_kind + , with_full_print + (Constrextern.extern_glob_constr Id.Set.empty) + t ) ] + , acc )) rel_first_args (rebuild_return_type returned_types.(i)) in @@ -1372,67 +1343,87 @@ let do_build_inductive Then save the graphs and reset Printing options to their primitive values *) let rel_arities = Array.mapi rel_arity funsargs in - Util.Array.fold_left2 (fun env rel_name rel_ar -> - let rex = fst (with_full_print (Constrintern.interp_constr env evd) rel_ar) in + Util.Array.fold_left2 + (fun env rel_name rel_ar -> + let rex = + fst (with_full_print (Constrintern.interp_constr env evd) rel_ar) + in let rex = EConstr.Unsafe.to_constr rex in - let r = Sorts.Relevant in (* TODO relevance *) - Environ.push_named (LocalAssum (make_annot rel_name r,rex)) env) env relnames rel_arities + let r = Sorts.Relevant in + (* TODO relevance *) + Environ.push_named (LocalAssum (make_annot rel_name r, rex)) env) + env relnames rel_arities in (* and of the real constructors*) let constr i res = List.map - (function result (* (args',concl') *) -> - let rt = compose_glob_context result.context result.value in - let nb_args = List.length funsargs.(i) in - (* with_full_print (fun rt -> Pp.msgnl (str "glob constr " ++ pr_glob_constr rt)) rt; *) - fst ( - rebuild_cons env_with_graphs nb_args relnames.(i) - [] - [] - rt - ) - ) + (function + | result (* (args',concl') *) -> + let rt = compose_glob_context result.context result.value in + let nb_args = List.length funsargs.(i) in + (* with_full_print (fun rt -> Pp.msgnl (str "glob constr " ++ pr_glob_constr rt)) rt; *) + fst (rebuild_cons env_with_graphs nb_args relnames.(i) [] [] rt)) res.result in (* adding names to constructors *) - let next_constructor_id = ref (-1) in + let next_constructor_id = ref (-1) in let mk_constructor_id i = incr next_constructor_id; (*i The next call to mk_rel_id is valid since we are constructing the graph Ensures by: obvious i*) - Id.of_string ((Id.to_string (mk_rel_id funnames.(i)))^"_"^(string_of_int !next_constructor_id)) + Id.of_string + ( Id.to_string (mk_rel_id funnames.(i)) + ^ "_" + ^ string_of_int !next_constructor_id ) in - let rel_constructors i rt : (Id.t*glob_constr) list = - next_constructor_id := (-1); - List.map (fun constr -> (mk_constructor_id i),constr) (constr i rt) + let rel_constructors i rt : (Id.t * glob_constr) list = + next_constructor_id := -1; + List.map (fun constr -> (mk_constructor_id i, constr)) (constr i rt) in let rel_constructors = Array.mapi rel_constructors resa in (* Computing the set of parameters if asked *) - let rels_params = compute_params_name relnames_as_set funsargs rel_constructors in + let rels_params = + compute_params_name relnames_as_set funsargs rel_constructors + in let nrel_params = List.length rels_params in - let rel_constructors = (* Taking into account the parameters in constructors *) - Array.map (List.map - (fun (id,rt) -> (id,snd (chop_rprod_n nrel_params rt)))) - rel_constructors + let rel_constructors = + (* Taking into account the parameters in constructors *) + Array.map + (List.map (fun (id, rt) -> (id, snd (chop_rprod_n nrel_params rt)))) + rel_constructors in - let rel_arity i funargs = (* Reduilding arities (with parameters) *) - let rel_first_args :(Name.t * Glob_term.glob_constr * Glob_term.glob_constr option ) list = - (snd (List.chop nrel_params funargs)) + let rel_arity i funargs = + (* Reduilding arities (with parameters) *) + let rel_first_args : + (Name.t * Glob_term.glob_constr * Glob_term.glob_constr option) list = + snd (List.chop nrel_params funargs) in List.fold_right - (fun (n,t,typ) acc -> - match typ with - | Some typ -> - CAst.make @@ Constrexpr.CLetIn((CAst.make n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t, - Some (with_full_print (Constrextern.extern_glob_constr Id.Set.empty) typ), - acc) - | None -> - CAst.make @@ Constrexpr.CProdN - ([Constrexpr.CLocalAssum([CAst.make n],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t)], - acc - ) - ) + (fun (n, t, typ) acc -> + match typ with + | Some typ -> + CAst.make + @@ Constrexpr.CLetIn + ( CAst.make n + , with_full_print + (Constrextern.extern_glob_constr Id.Set.empty) + t + , Some + (with_full_print + (Constrextern.extern_glob_constr Id.Set.empty) + typ) + , acc ) + | None -> + CAst.make + @@ Constrexpr.CProdN + ( [ Constrexpr.CLocalAssum + ( [CAst.make n] + , Constrexpr_ops.default_binder_kind + , with_full_print + (Constrextern.extern_glob_constr Id.Set.empty) + t ) ] + , acc )) rel_first_args (rebuild_return_type returned_types.(i)) in @@ -1443,103 +1434,123 @@ let do_build_inductive let rel_arities = Array.mapi rel_arity funsargs in let rel_params_ids = List.fold_left - (fun acc (na,_,_) -> - match na with - Anonymous -> acc - | Name id -> id::acc - ) - [] - rels_params + (fun acc (na, _, _) -> + match na with Anonymous -> acc | Name id -> id :: acc) + [] rels_params in let rel_params = List.map - (fun (n,t,typ) -> - match typ with - | Some typ -> - Constrexpr.CLocalDef((CAst.make n), Constrextern.extern_glob_constr Id.Set.empty t, - Some (with_full_print (Constrextern.extern_glob_constr Id.Set.empty) typ)) - | None -> - Constrexpr.CLocalAssum - ([(CAst.make n)], Constrexpr_ops.default_binder_kind, Constrextern.extern_glob_constr Id.Set.empty t) - ) + (fun (n, t, typ) -> + match typ with + | Some typ -> + Constrexpr.CLocalDef + ( CAst.make n + , Constrextern.extern_glob_constr Id.Set.empty t + , Some + (with_full_print + (Constrextern.extern_glob_constr Id.Set.empty) + typ) ) + | None -> + Constrexpr.CLocalAssum + ( [CAst.make n] + , Constrexpr_ops.default_binder_kind + , Constrextern.extern_glob_constr Id.Set.empty t )) rels_params in let ext_rels_constructors = - Array.map (List.map - (fun (id,t) -> - false,((CAst.make id), - with_full_print - (Constrextern.extern_glob_type Id.Set.empty) ((* zeta_normalize *) (alpha_rt rel_params_ids t)) - ) - )) - (rel_constructors) + Array.map + (List.map (fun (id, t) -> + ( false + , ( CAst.make id + , with_full_print + (Constrextern.extern_glob_type Id.Set.empty) + ((* zeta_normalize *) alpha_rt rel_params_ids t) ) ))) + rel_constructors in let rel_ind i ext_rel_constructors = - ((CAst.make @@ relnames.(i)), - (rel_params,None), - Some rel_arities.(i), - ext_rel_constructors),[] + ( ( CAst.make @@ relnames.(i) + , (rel_params, None) + , Some rel_arities.(i) + , ext_rel_constructors ) + , [] ) in - let ext_rel_constructors = (Array.mapi rel_ind ext_rels_constructors) in + let ext_rel_constructors = Array.mapi rel_ind ext_rels_constructors in let rel_inds = Array.to_list ext_rel_constructors in -(* let _ = *) -(* Pp.msgnl (\* observe *\) ( *) -(* str "Inductive" ++ spc () ++ *) -(* prlist_with_sep *) -(* (fun () -> fnl ()++spc () ++ str "with" ++ spc ()) *) -(* (function ((_,id),_,params,ar,constr) -> *) -(* Ppconstr.pr_id id ++ spc () ++ *) -(* Ppconstr.pr_binders params ++ spc () ++ *) -(* str ":" ++ spc () ++ *) -(* Ppconstr.pr_lconstr_expr ar ++ spc () ++ str ":=" ++ *) -(* prlist_with_sep *) -(* (fun _ -> fnl () ++ spc () ++ str "|" ++ spc ()) *) -(* (function (_,((_,id),t)) -> *) -(* Ppconstr.pr_id id ++ spc () ++ str ":" ++ spc () ++ *) -(* Ppconstr.pr_lconstr_expr t) *) -(* constr *) -(* ) *) -(* rel_inds *) -(* ) *) -(* in *) + (* let _ = *) + (* Pp.msgnl (\* observe *\) ( *) + (* str "Inductive" ++ spc () ++ *) + (* prlist_with_sep *) + (* (fun () -> fnl ()++spc () ++ str "with" ++ spc ()) *) + (* (function ((_,id),_,params,ar,constr) -> *) + (* Ppconstr.pr_id id ++ spc () ++ *) + (* Ppconstr.pr_binders params ++ spc () ++ *) + (* str ":" ++ spc () ++ *) + (* Ppconstr.pr_lconstr_expr ar ++ spc () ++ str ":=" ++ *) + (* prlist_with_sep *) + (* (fun _ -> fnl () ++ spc () ++ str "|" ++ spc ()) *) + (* (function (_,((_,id),t)) -> *) + (* Ppconstr.pr_id id ++ spc () ++ str ":" ++ spc () ++ *) + (* Ppconstr.pr_lconstr_expr t) *) + (* constr *) + (* ) *) + (* rel_inds *) + (* ) *) + (* in *) let _time2 = System.get_time () in try with_full_print - (Flags.silently (ComInductive.do_mutual_inductive ~template:(Some false) None rel_inds ~cumulative:false ~poly:false ~private_ind:false ~uniform:ComInductive.NonUniformParameters)) + (Flags.silently + (ComInductive.do_mutual_inductive ~template:(Some false) None rel_inds + ~cumulative:false ~poly:false ~private_ind:false + ~uniform:ComInductive.NonUniformParameters)) Declarations.Finite with - | UserError(s,msg) as e -> - let _time3 = System.get_time () in -(* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) - let repacked_rel_inds = - List.map (fun ((a , b , c , l),ntn) -> ((false,(a,None)) , b, c, Vernacexpr.Constructors l),ntn ) - rel_inds - in - let msg = - str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (CAst.make Vernacexpr.{ control = []; attrs = []; expr = VernacInductive(Vernacexpr.Inductive_kw,repacked_rel_inds)}) - ++ fnl () ++ - msg - in - observe (msg); - raise e - | reraise -> - let _time3 = System.get_time () in -(* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) - let repacked_rel_inds = - List.map (fun ((a , b , c , l),ntn) -> ((false,(a,None)) , b, c, Vernacexpr.Constructors l),ntn ) - rel_inds - in - let msg = - str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (CAst.make @@ Vernacexpr.{ control = []; attrs = []; expr = VernacInductive(Vernacexpr.Inductive_kw,repacked_rel_inds)}) - ++ fnl () ++ - CErrors.print reraise - in - observe msg; - raise reraise - - + | UserError (s, msg) as e -> + let _time3 = System.get_time () in + (* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) + let repacked_rel_inds = + List.map + (fun ((a, b, c, l), ntn) -> + (((false, (a, None)), b, c, Vernacexpr.Constructors l), ntn)) + rel_inds + in + let msg = + str "while trying to define" + ++ spc () + ++ Ppvernac.pr_vernac + (CAst.make + Vernacexpr. + { control = [] + ; attrs = [] + ; expr = + VernacInductive (Vernacexpr.Inductive_kw, repacked_rel_inds) + }) + ++ fnl () ++ msg + in + observe msg; raise e + | reraise -> + let _time3 = System.get_time () in + (* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) + let repacked_rel_inds = + List.map + (fun ((a, b, c, l), ntn) -> + (((false, (a, None)), b, c, Vernacexpr.Constructors l), ntn)) + rel_inds + in + let msg = + str "while trying to define" + ++ spc () + ++ Ppvernac.pr_vernac + ( CAst.make + @@ Vernacexpr. + { control = [] + ; attrs = [] + ; expr = + VernacInductive (Vernacexpr.Inductive_kw, repacked_rel_inds) + } ) + ++ fnl () ++ CErrors.print reraise + in + observe msg; raise reraise let build_inductive evd funconstants funsargs returned_types rtl = let pu = !Detyping.print_universes in diff --git a/plugins/funind/glob_term_to_relation.mli b/plugins/funind/glob_term_to_relation.mli index a29e5dff23..8dfeafe7c9 100644 --- a/plugins/funind/glob_term_to_relation.mli +++ b/plugins/funind/glob_term_to_relation.mli @@ -7,13 +7,15 @@ open Names *) val build_inductive : -(* (ModPath.t * DirPath.t) option -> - Id.t list -> (* The list of function name *) - *) - Evd.evar_map -> - Constr.pconstant list -> - (Name.t*Glob_term.glob_constr*Glob_term.glob_constr option) list list -> (* The list of function args *) - Constrexpr.constr_expr list -> (* The list of function returned type *) - Glob_term.glob_constr list -> (* the list of body *) - unit - + (* (ModPath.t * DirPath.t) option -> + Id.t list -> (* The list of function name *) + *) + Evd.evar_map + -> Constr.pconstant list + -> (Name.t * Glob_term.glob_constr * Glob_term.glob_constr option) list list + -> (* The list of function args *) + Constrexpr.constr_expr list + -> (* The list of function returned type *) + Glob_term.glob_constr list + -> (* the list of body *) + unit diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 9fa72919ce..5026120849 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -18,14 +18,17 @@ open Names Some basic functions to rebuild glob_constr In each of them the location is Loc.ghost *) -let mkGRef ref = DAst.make @@ GRef(ref,None) -let mkGVar id = DAst.make @@ GVar(id) -let mkGApp(rt,rtl) = DAst.make @@ GApp(rt,rtl) -let mkGLambda(n,t,b) = DAst.make @@ GLambda(n,Explicit,t,b) -let mkGProd(n,t,b) = DAst.make @@ GProd(n,Explicit,t,b) -let mkGLetIn(n,b,t,c) = DAst.make @@ GLetIn(n,b,t,c) -let mkGCases(rto,l,brl) = DAst.make @@ GCases(RegularStyle,rto,l,brl) -let mkGHole () = DAst.make @@ GHole(Evar_kinds.BinderType Anonymous,Namegen.IntroAnonymous,None) +let mkGRef ref = DAst.make @@ GRef (ref, None) +let mkGVar id = DAst.make @@ GVar id +let mkGApp (rt, rtl) = DAst.make @@ GApp (rt, rtl) +let mkGLambda (n, t, b) = DAst.make @@ GLambda (n, Explicit, t, b) +let mkGProd (n, t, b) = DAst.make @@ GProd (n, Explicit, t, b) +let mkGLetIn (n, b, t, c) = DAst.make @@ GLetIn (n, b, t, c) +let mkGCases (rto, l, brl) = DAst.make @@ GCases (RegularStyle, rto, l, brl) + +let mkGHole () = + DAst.make + @@ GHole (Evar_kinds.BinderType Anonymous, Namegen.IntroAnonymous, None) (* Some basic functions to decompose glob_constrs @@ -33,532 +36,483 @@ let mkGHole () = DAst.make @@ GHole(Evar_kinds.BinderType Anonymous,Nam *) let glob_decompose_app = let rec decompose_rapp acc rt = -(* msgnl (str "glob_decompose_app on : "++ Printer.pr_glob_constr rt); *) + (* msgnl (str "glob_decompose_app on : "++ Printer.pr_glob_constr rt); *) match DAst.get rt with - | GApp(rt,rtl) -> - decompose_rapp (List.fold_left (fun y x -> x::y) acc rtl) rt - | _ -> rt,List.rev acc + | GApp (rt, rtl) -> + decompose_rapp (List.fold_left (fun y x -> x :: y) acc rtl) rt + | _ -> (rt, List.rev acc) in decompose_rapp [] - - - (* [glob_make_eq t1 t2] build the glob_constr corresponding to [t2 = t1] *) -let glob_make_eq ?(typ= mkGHole ()) t1 t2 = - mkGApp(mkGRef (Coqlib.lib_ref "core.eq.type"),[typ;t2;t1]) +let glob_make_eq ?(typ = mkGHole ()) t1 t2 = + mkGApp (mkGRef (Coqlib.lib_ref "core.eq.type"), [typ; t2; t1]) (* [glob_make_neq t1 t2] build the glob_constr corresponding to [t1 <> t2] *) let glob_make_neq t1 t2 = - mkGApp(mkGRef (Coqlib.lib_ref "core.not.type"),[glob_make_eq t1 t2]) + mkGApp (mkGRef (Coqlib.lib_ref "core.not.type"), [glob_make_eq t1 t2]) let remove_name_from_mapping mapping na = - match na with - | Anonymous -> mapping - | Name id -> Id.Map.remove id mapping + match na with Anonymous -> mapping | Name id -> Id.Map.remove id mapping let change_vars = let rec change_vars mapping rt = - DAst.map_with_loc (fun ?loc -> function - | GRef _ as x -> x - | GVar id -> - let new_id = - try - Id.Map.find id mapping - with Not_found -> id + DAst.map_with_loc + (fun ?loc -> function GRef _ as x -> x + | GVar id -> + let new_id = try Id.Map.find id mapping with Not_found -> id in + GVar new_id | GEvar _ as x -> x | GPatVar _ as x -> x + | GApp (rt', rtl) -> + GApp (change_vars mapping rt', List.map (change_vars mapping) rtl) + | GLambda (name, k, t, b) -> + GLambda + ( name + , k + , change_vars mapping t + , change_vars (remove_name_from_mapping mapping name) b ) + | GProd (name, k, t, b) -> + GProd + ( name + , k + , change_vars mapping t + , change_vars (remove_name_from_mapping mapping name) b ) + | GLetIn (name, def, typ, b) -> + GLetIn + ( name + , change_vars mapping def + , Option.map (change_vars mapping) typ + , change_vars (remove_name_from_mapping mapping name) b ) + | GLetTuple (nal, (na, rto), b, e) -> + let new_mapping = + List.fold_left remove_name_from_mapping mapping nal in - GVar(new_id) - | GEvar _ as x -> x - | GPatVar _ as x -> x - | GApp(rt',rtl) -> - GApp(change_vars mapping rt', - List.map (change_vars mapping) rtl - ) - | GLambda(name,k,t,b) -> - GLambda(name, - k, - change_vars mapping t, - change_vars (remove_name_from_mapping mapping name) b - ) - | GProd(name,k,t,b) -> - GProd( name, - k, - change_vars mapping t, - change_vars (remove_name_from_mapping mapping name) b - ) - | GLetIn(name,def,typ,b) -> - GLetIn(name, - change_vars mapping def, - Option.map (change_vars mapping) typ, - change_vars (remove_name_from_mapping mapping name) b - ) - | GLetTuple(nal,(na,rto),b,e) -> - let new_mapping = List.fold_left remove_name_from_mapping mapping nal in - GLetTuple(nal, - (na, Option.map (change_vars mapping) rto), - change_vars mapping b, - change_vars new_mapping e - ) - | GCases(sty,infos,el,brl) -> - GCases(sty, - infos, - List.map (fun (e,x) -> (change_vars mapping e,x)) el, - List.map (change_vars_br mapping) brl - ) - | GIf(b,(na,e_option),lhs,rhs) -> - GIf(change_vars mapping b, - (na,Option.map (change_vars mapping) e_option), - change_vars mapping lhs, - change_vars mapping rhs - ) - | GRec _ -> user_err ?loc Pp.(str "Local (co)fixes are not supported") - | GSort _ as x -> x - | GHole _ as x -> x - | GInt _ as x -> x - | GFloat _ as x -> x - | GCast(b,c) -> - GCast(change_vars mapping b, - Glob_ops.map_cast_type (change_vars mapping) c) - ) rt - and change_vars_br mapping ({CAst.loc;v=(idl,patl,res)} as br) = + GLetTuple + ( nal + , (na, Option.map (change_vars mapping) rto) + , change_vars mapping b + , change_vars new_mapping e ) + | GCases (sty, infos, el, brl) -> + GCases + ( sty + , infos + , List.map (fun (e, x) -> (change_vars mapping e, x)) el + , List.map (change_vars_br mapping) brl ) + | GIf (b, (na, e_option), lhs, rhs) -> + GIf + ( change_vars mapping b + , (na, Option.map (change_vars mapping) e_option) + , change_vars mapping lhs + , change_vars mapping rhs ) + | GRec _ -> user_err ?loc Pp.(str "Local (co)fixes are not supported") + | GSort _ as x -> x | GHole _ as x -> x | GInt _ as x -> x + | GFloat _ as x -> x + | GCast (b, c) -> + GCast + ( change_vars mapping b + , Glob_ops.map_cast_type (change_vars mapping) c )) + rt + and change_vars_br mapping ({CAst.loc; v = idl, patl, res} as br) = let new_mapping = List.fold_right Id.Map.remove idl mapping in - if Id.Map.is_empty new_mapping - then br - else CAst.make ?loc (idl,patl,change_vars new_mapping res) + if Id.Map.is_empty new_mapping then br + else CAst.make ?loc (idl, patl, change_vars new_mapping res) in change_vars - - let rec alpha_pat excluded pat = let loc = pat.CAst.loc in match DAst.get pat with - | PatVar Anonymous -> - let new_id = Indfun_common.fresh_id excluded "_x" in - (DAst.make ?loc @@ PatVar(Name new_id)),(new_id::excluded),Id.Map.empty - | PatVar(Name id) -> - if Id.List.mem id excluded - then - let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in - (DAst.make ?loc @@ PatVar(Name new_id)),(new_id::excluded), - (Id.Map.add id new_id Id.Map.empty) - else pat, excluded,Id.Map.empty - | PatCstr(constr,patl,na) -> - let new_na,new_excluded,map = - match na with - | Name id when Id.List.mem id excluded -> - let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in - Name new_id,new_id::excluded, Id.Map.add id new_id Id.Map.empty - | _ -> na,excluded,Id.Map.empty - in - let new_patl,new_excluded,new_map = - List.fold_left - (fun (patl,excluded,map) pat -> - let new_pat,new_excluded,new_map = alpha_pat excluded pat in - (new_pat::patl,new_excluded,Id.Map.fold Id.Map.add new_map map) - ) - ([],new_excluded,map) - patl - in - (DAst.make ?loc @@ PatCstr(constr,List.rev new_patl,new_na)),new_excluded,new_map - -let alpha_patl excluded patl = - let patl,new_excluded,map = + | PatVar Anonymous -> + let new_id = Indfun_common.fresh_id excluded "_x" in + (DAst.make ?loc @@ PatVar (Name new_id), new_id :: excluded, Id.Map.empty) + | PatVar (Name id) -> + if Id.List.mem id excluded then + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in + ( DAst.make ?loc @@ PatVar (Name new_id) + , new_id :: excluded + , Id.Map.add id new_id Id.Map.empty ) + else (pat, excluded, Id.Map.empty) + | PatCstr (constr, patl, na) -> + let new_na, new_excluded, map = + match na with + | Name id when Id.List.mem id excluded -> + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in + (Name new_id, new_id :: excluded, Id.Map.add id new_id Id.Map.empty) + | _ -> (na, excluded, Id.Map.empty) + in + let new_patl, new_excluded, new_map = + List.fold_left + (fun (patl, excluded, map) pat -> + let new_pat, new_excluded, new_map = alpha_pat excluded pat in + (new_pat :: patl, new_excluded, Id.Map.fold Id.Map.add new_map map)) + ([], new_excluded, map) patl + in + ( DAst.make ?loc @@ PatCstr (constr, List.rev new_patl, new_na) + , new_excluded + , new_map ) + +let alpha_patl excluded patl = + let patl, new_excluded, map = List.fold_left - (fun (patl,excluded,map) pat -> - let new_pat,new_excluded,new_map = alpha_pat excluded pat in - new_pat::patl,new_excluded,(Id.Map.fold Id.Map.add new_map map) - ) - ([],excluded,Id.Map.empty) + (fun (patl, excluded, map) pat -> + let new_pat, new_excluded, new_map = alpha_pat excluded pat in + (new_pat :: patl, new_excluded, Id.Map.fold Id.Map.add new_map map)) + ([], excluded, Id.Map.empty) patl in - (List.rev patl,new_excluded,map) - - - + (List.rev patl, new_excluded, map) let raw_get_pattern_id pat acc = let rec get_pattern_id pat = match DAst.get pat with - | PatVar(Anonymous) -> assert false - | PatVar(Name id) -> - [id] - | PatCstr(constr,patternl,_) -> - List.fold_right - (fun pat idl -> - let idl' = get_pattern_id pat in - idl'@idl - ) - patternl - [] + | PatVar Anonymous -> assert false + | PatVar (Name id) -> [id] + | PatCstr (constr, patternl, _) -> + List.fold_right + (fun pat idl -> + let idl' = get_pattern_id pat in + idl' @ idl) + patternl [] in - (get_pattern_id pat)@acc + get_pattern_id pat @ acc let get_pattern_id pat = raw_get_pattern_id pat [] let rec alpha_rt excluded rt = let loc = rt.CAst.loc in - let new_rt = DAst.make ?loc @@ + let new_rt = + DAst.make ?loc + @@ match DAst.get rt with - | GRef _ | GVar _ | GEvar _ | GPatVar _ as rt -> rt - | GLambda(Anonymous,k,t,b) -> - let new_id = Namegen.next_ident_away (Id.of_string "_x") (Id.Set.of_list excluded) in - let new_excluded = new_id :: excluded in - let new_t = alpha_rt new_excluded t in - let new_b = alpha_rt new_excluded b in - GLambda(Name new_id,k,new_t,new_b) - | GProd(Anonymous,k,t,b) -> - let new_t = alpha_rt excluded t in - let new_b = alpha_rt excluded b in - GProd(Anonymous,k,new_t,new_b) - | GLetIn(Anonymous,b,t,c) -> - let new_b = alpha_rt excluded b in - let new_t = Option.map (alpha_rt excluded) t in - let new_c = alpha_rt excluded c in - GLetIn(Anonymous,new_b,new_t,new_c) - | GLambda(Name id,k,t,b) -> - let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in - let t,b = - if Id.equal new_id id - then t, b - else - let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in - (t,replace b) - in - let new_excluded = new_id::excluded in - let new_t = alpha_rt new_excluded t in - let new_b = alpha_rt new_excluded b in - GLambda(Name new_id,k,new_t,new_b) - | GProd(Name id,k,t,b) -> - let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in - let new_excluded = new_id::excluded in - let t,b = - if Id.equal new_id id - then t,b - else - let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in - (t,replace b) - in - let new_t = alpha_rt new_excluded t in - let new_b = alpha_rt new_excluded b in - GProd(Name new_id,k,new_t,new_b) - | GLetIn(Name id,b,t,c) -> - let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in - let c = - if Id.equal new_id id then c - else change_vars (Id.Map.add id new_id Id.Map.empty) c - in - let new_excluded = new_id::excluded in - let new_b = alpha_rt new_excluded b in - let new_t = Option.map (alpha_rt new_excluded) t in - let new_c = alpha_rt new_excluded c in - GLetIn(Name new_id,new_b,new_t,new_c) - - | GLetTuple(nal,(na,rto),t,b) -> - let rev_new_nal,new_excluded,mapping = - List.fold_left - (fun (nal,excluded,mapping) na -> - match na with - | Anonymous -> (na::nal,excluded,mapping) - | Name id -> - let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in - if Id.equal new_id id - then - na::nal,id::excluded,mapping - else - (Name new_id)::nal,id::excluded,(Id.Map.add id new_id mapping) - ) - ([],excluded,Id.Map.empty) - nal - in - let new_nal = List.rev rev_new_nal in - let new_rto,new_t,new_b = - if Id.Map.is_empty mapping - then rto,t,b - else let replace = change_vars mapping in - (Option.map replace rto, t,replace b) - in - let new_t = alpha_rt new_excluded new_t in - let new_b = alpha_rt new_excluded new_b in - let new_rto = Option.map (alpha_rt new_excluded) new_rto in - GLetTuple(new_nal,(na,new_rto),new_t,new_b) - | GCases(sty,infos,el,brl) -> - let new_el = - List.map (function (rt,i) -> alpha_rt excluded rt, i) el - in - GCases(sty,infos,new_el,List.map (alpha_br excluded) brl) - | GIf(b,(na,e_o),lhs,rhs) -> - GIf(alpha_rt excluded b, - (na,Option.map (alpha_rt excluded) e_o), - alpha_rt excluded lhs, - alpha_rt excluded rhs - ) + | (GRef _ | GVar _ | GEvar _ | GPatVar _) as rt -> rt + | GLambda (Anonymous, k, t, b) -> + let new_id = + Namegen.next_ident_away (Id.of_string "_x") (Id.Set.of_list excluded) + in + let new_excluded = new_id :: excluded in + let new_t = alpha_rt new_excluded t in + let new_b = alpha_rt new_excluded b in + GLambda (Name new_id, k, new_t, new_b) + | GProd (Anonymous, k, t, b) -> + let new_t = alpha_rt excluded t in + let new_b = alpha_rt excluded b in + GProd (Anonymous, k, new_t, new_b) + | GLetIn (Anonymous, b, t, c) -> + let new_b = alpha_rt excluded b in + let new_t = Option.map (alpha_rt excluded) t in + let new_c = alpha_rt excluded c in + GLetIn (Anonymous, new_b, new_t, new_c) + | GLambda (Name id, k, t, b) -> + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in + let t, b = + if Id.equal new_id id then (t, b) + else + let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in + (t, replace b) + in + let new_excluded = new_id :: excluded in + let new_t = alpha_rt new_excluded t in + let new_b = alpha_rt new_excluded b in + GLambda (Name new_id, k, new_t, new_b) + | GProd (Name id, k, t, b) -> + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in + let new_excluded = new_id :: excluded in + let t, b = + if Id.equal new_id id then (t, b) + else + let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in + (t, replace b) + in + let new_t = alpha_rt new_excluded t in + let new_b = alpha_rt new_excluded b in + GProd (Name new_id, k, new_t, new_b) + | GLetIn (Name id, b, t, c) -> + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in + let c = + if Id.equal new_id id then c + else change_vars (Id.Map.add id new_id Id.Map.empty) c + in + let new_excluded = new_id :: excluded in + let new_b = alpha_rt new_excluded b in + let new_t = Option.map (alpha_rt new_excluded) t in + let new_c = alpha_rt new_excluded c in + GLetIn (Name new_id, new_b, new_t, new_c) + | GLetTuple (nal, (na, rto), t, b) -> + let rev_new_nal, new_excluded, mapping = + List.fold_left + (fun (nal, excluded, mapping) na -> + match na with + | Anonymous -> (na :: nal, excluded, mapping) + | Name id -> + let new_id = + Namegen.next_ident_away id (Id.Set.of_list excluded) + in + if Id.equal new_id id then (na :: nal, id :: excluded, mapping) + else + ( Name new_id :: nal + , id :: excluded + , Id.Map.add id new_id mapping )) + ([], excluded, Id.Map.empty) + nal + in + let new_nal = List.rev rev_new_nal in + let new_rto, new_t, new_b = + if Id.Map.is_empty mapping then (rto, t, b) + else + let replace = change_vars mapping in + (Option.map replace rto, t, replace b) + in + let new_t = alpha_rt new_excluded new_t in + let new_b = alpha_rt new_excluded new_b in + let new_rto = Option.map (alpha_rt new_excluded) new_rto in + GLetTuple (new_nal, (na, new_rto), new_t, new_b) + | GCases (sty, infos, el, brl) -> + let new_el = + List.map (function rt, i -> (alpha_rt excluded rt, i)) el + in + GCases (sty, infos, new_el, List.map (alpha_br excluded) brl) + | GIf (b, (na, e_o), lhs, rhs) -> + GIf + ( alpha_rt excluded b + , (na, Option.map (alpha_rt excluded) e_o) + , alpha_rt excluded lhs + , alpha_rt excluded rhs ) | GRec _ -> user_err Pp.(str "Not handled GRec") - | GSort _ - | GInt _ - | GFloat _ - | GHole _ as rt -> rt - | GCast (b,c) -> - GCast(alpha_rt excluded b, - Glob_ops.map_cast_type (alpha_rt excluded) c) - | GApp(f,args) -> - GApp(alpha_rt excluded f, - List.map (alpha_rt excluded) args - ) + | (GSort _ | GInt _ | GFloat _ | GHole _) as rt -> rt + | GCast (b, c) -> + GCast (alpha_rt excluded b, Glob_ops.map_cast_type (alpha_rt excluded) c) + | GApp (f, args) -> + GApp (alpha_rt excluded f, List.map (alpha_rt excluded) args) in new_rt -and alpha_br excluded {CAst.loc;v=(ids,patl,res)} = - let new_patl,new_excluded,mapping = alpha_patl excluded patl in +and alpha_br excluded {CAst.loc; v = ids, patl, res} = + let new_patl, new_excluded, mapping = alpha_patl excluded patl in let new_ids = List.fold_right raw_get_pattern_id new_patl [] in - let new_excluded = new_ids@excluded in + let new_excluded = new_ids @ excluded in let renamed_res = change_vars mapping res in let new_res = alpha_rt new_excluded renamed_res in - CAst.make ?loc (new_ids,new_patl,new_res) + CAst.make ?loc (new_ids, new_patl, new_res) (* [is_free_in id rt] checks if [id] is a free variable in [rt] *) let is_free_in id = - let rec is_free_in x = DAst.with_loc_val (fun ?loc -> function - | GRef _ -> false - | GVar id' -> Id.compare id' id == 0 - | GEvar _ -> false - | GPatVar _ -> false - | GApp(rt,rtl) -> List.exists is_free_in (rt::rtl) - | GLambda(n,_,t,b) | GProd(n,_,t,b) -> - let check_in_b = - match n with - | Name id' -> not (Id.equal id' id) - | _ -> true - in - is_free_in t || (check_in_b && is_free_in b) - | GLetIn(n,b,t,c) -> - let check_in_c = - match n with - | Name id' -> not (Id.equal id' id) - | _ -> true - in - is_free_in b || Option.cata is_free_in true t || (check_in_c && is_free_in c) - | GCases(_,_,el,brl) -> - (List.exists (fun (e,_) -> is_free_in e) el) || - List.exists is_free_in_br brl - | GLetTuple(nal,_,b,t) -> - let check_in_nal = - not (List.exists (function Name id' -> Id.equal id' id | _ -> false) nal) - in - is_free_in t || (check_in_nal && is_free_in b) - - | GIf(cond,_,br1,br2) -> - is_free_in cond || is_free_in br1 || is_free_in br2 - | GRec _ -> user_err Pp.(str "Not handled GRec") - | GSort _ -> false - | GHole _ -> false - | GCast (b,(CastConv t|CastVM t|CastNative t)) -> is_free_in b || is_free_in t - | GCast (b,CastCoerce) -> is_free_in b - | GInt _ | GFloat _ -> false - ) x - and is_free_in_br {CAst.v=(ids,_,rt)} = + let rec is_free_in x = + DAst.with_loc_val + (fun ?loc -> function GRef _ -> false | GVar id' -> Id.compare id' id == 0 + | GEvar _ -> false | GPatVar _ -> false + | GApp (rt, rtl) -> List.exists is_free_in (rt :: rtl) + | GLambda (n, _, t, b) | GProd (n, _, t, b) -> + let check_in_b = + match n with Name id' -> not (Id.equal id' id) | _ -> true + in + is_free_in t || (check_in_b && is_free_in b) + | GLetIn (n, b, t, c) -> + let check_in_c = + match n with Name id' -> not (Id.equal id' id) | _ -> true + in + is_free_in b + || Option.cata is_free_in true t + || (check_in_c && is_free_in c) + | GCases (_, _, el, brl) -> + List.exists (fun (e, _) -> is_free_in e) el + || List.exists is_free_in_br brl + | GLetTuple (nal, _, b, t) -> + let check_in_nal = + not + (List.exists + (function Name id' -> Id.equal id' id | _ -> false) + nal) + in + is_free_in t || (check_in_nal && is_free_in b) + | GIf (cond, _, br1, br2) -> + is_free_in cond || is_free_in br1 || is_free_in br2 + | GRec _ -> user_err Pp.(str "Not handled GRec") | GSort _ -> false + | GHole _ -> false + | GCast (b, (CastConv t | CastVM t | CastNative t)) -> + is_free_in b || is_free_in t | GCast (b, CastCoerce) -> is_free_in b + | GInt _ | GFloat _ -> false) + x + and is_free_in_br {CAst.v = ids, _, rt} = (not (Id.List.mem id ids)) && is_free_in rt in is_free_in - - -let rec pattern_to_term pt = DAst.with_val (function - | PatVar Anonymous -> assert false - | PatVar(Name id) -> - mkGVar id - | PatCstr(constr,patternl,_) -> - let cst_narg = - Inductiveops.constructor_nallargs - (Global.env ()) - constr - in - let implicit_args = - Array.to_list - (Array.init - (cst_narg - List.length patternl) - (fun _ -> mkGHole ()) - ) - in - let patl_as_term = - List.map pattern_to_term patternl - in - mkGApp(mkGRef(GlobRef.ConstructRef constr), - implicit_args@patl_as_term - ) - ) pt - +let rec pattern_to_term pt = + DAst.with_val + (function + | PatVar Anonymous -> assert false + | PatVar (Name id) -> mkGVar id + | PatCstr (constr, patternl, _) -> + let cst_narg = + Inductiveops.constructor_nallargs (Global.env ()) constr + in + let implicit_args = + Array.to_list + (Array.init (cst_narg - List.length patternl) (fun _ -> mkGHole ())) + in + let patl_as_term = List.map pattern_to_term patternl in + mkGApp + (mkGRef (GlobRef.ConstructRef constr), implicit_args @ patl_as_term)) + pt let replace_var_by_term x_id term = - let rec replace_var_by_pattern x = DAst.map (function - | GVar id when Id.compare id x_id == 0 -> DAst.get term - | GRef _ - | GVar _ - | GEvar _ - | GPatVar _ as rt -> rt - | GApp(rt',rtl) -> - GApp(replace_var_by_pattern rt', - List.map replace_var_by_pattern rtl - ) - | GLambda(Name id,_,_,_) as rt when Id.compare id x_id == 0 -> rt - | GLambda(name,k,t,b) -> - GLambda(name, - k, - replace_var_by_pattern t, - replace_var_by_pattern b - ) - | GProd(Name id,_,_,_) as rt when Id.compare id x_id == 0 -> rt - | GProd(name,k,t,b) -> - GProd( name, - k, - replace_var_by_pattern t, - replace_var_by_pattern b - ) - | GLetIn(Name id,_,_,_) as rt when Id.compare id x_id == 0 -> rt - | GLetIn(name,def,typ,b) -> - GLetIn(name, - replace_var_by_pattern def, - Option.map (replace_var_by_pattern) typ, - replace_var_by_pattern b - ) - | GLetTuple(nal,_,_,_) as rt - when List.exists (function Name id -> Id.equal id x_id | _ -> false) nal -> + let rec replace_var_by_pattern x = + DAst.map + (function + | GVar id when Id.compare id x_id == 0 -> DAst.get term + | (GRef _ | GVar _ | GEvar _ | GPatVar _) as rt -> rt + | GApp (rt', rtl) -> + GApp (replace_var_by_pattern rt', List.map replace_var_by_pattern rtl) + | GLambda (Name id, _, _, _) as rt when Id.compare id x_id == 0 -> rt + | GLambda (name, k, t, b) -> + GLambda (name, k, replace_var_by_pattern t, replace_var_by_pattern b) + | GProd (Name id, _, _, _) as rt when Id.compare id x_id == 0 -> rt + | GProd (name, k, t, b) -> + GProd (name, k, replace_var_by_pattern t, replace_var_by_pattern b) + | GLetIn (Name id, _, _, _) as rt when Id.compare id x_id == 0 -> rt + | GLetIn (name, def, typ, b) -> + GLetIn + ( name + , replace_var_by_pattern def + , Option.map replace_var_by_pattern typ + , replace_var_by_pattern b ) + | GLetTuple (nal, _, _, _) as rt + when List.exists + (function Name id -> Id.equal id x_id | _ -> false) + nal -> rt - | GLetTuple(nal,(na,rto),def,b) -> - GLetTuple(nal, - (na,Option.map replace_var_by_pattern rto), - replace_var_by_pattern def, - replace_var_by_pattern b - ) - | GCases(sty,infos,el,brl) -> - GCases(sty, - infos, - List.map (fun (e,x) -> (replace_var_by_pattern e,x)) el, - List.map replace_var_by_pattern_br brl - ) - | GIf(b,(na,e_option),lhs,rhs) -> - GIf(replace_var_by_pattern b, - (na,Option.map replace_var_by_pattern e_option), - replace_var_by_pattern lhs, - replace_var_by_pattern rhs - ) - | GRec _ -> - CErrors.user_err (Pp.str "Not handled GRec") - | GSort _ - | GHole _ as rt -> rt - | GInt _ as rt -> rt - | GFloat _ as rt -> rt - | GCast(b,c) -> - GCast(replace_var_by_pattern b, - Glob_ops.map_cast_type replace_var_by_pattern c) - ) x - and replace_var_by_pattern_br ({CAst.loc;v=(idl,patl,res)} as br) = - if List.exists (fun id -> Id.compare id x_id == 0) idl - then br - else CAst.make ?loc (idl,patl,replace_var_by_pattern res) + | GLetTuple (nal, (na, rto), def, b) -> + GLetTuple + ( nal + , (na, Option.map replace_var_by_pattern rto) + , replace_var_by_pattern def + , replace_var_by_pattern b ) + | GCases (sty, infos, el, brl) -> + GCases + ( sty + , infos + , List.map (fun (e, x) -> (replace_var_by_pattern e, x)) el + , List.map replace_var_by_pattern_br brl ) + | GIf (b, (na, e_option), lhs, rhs) -> + GIf + ( replace_var_by_pattern b + , (na, Option.map replace_var_by_pattern e_option) + , replace_var_by_pattern lhs + , replace_var_by_pattern rhs ) + | GRec _ -> CErrors.user_err (Pp.str "Not handled GRec") + | (GSort _ | GHole _) as rt -> rt + | GInt _ as rt -> rt + | GFloat _ as rt -> rt + | GCast (b, c) -> + GCast + ( replace_var_by_pattern b + , Glob_ops.map_cast_type replace_var_by_pattern c )) + x + and replace_var_by_pattern_br ({CAst.loc; v = idl, patl, res} as br) = + if List.exists (fun id -> Id.compare id x_id == 0) idl then br + else CAst.make ?loc (idl, patl, replace_var_by_pattern res) in replace_var_by_pattern - - - (* checking unifiability of patterns *) exception NotUnifiable -let rec are_unifiable_aux = function +let rec are_unifiable_aux = function | [] -> () - | (l, r) ::eqs -> - match DAst.get l, DAst.get r with - | PatVar _ ,_ | _, PatVar _-> are_unifiable_aux eqs - | PatCstr(constructor1,cpl1,_), PatCstr(constructor2,cpl2,_) -> - if not (eq_constructor constructor2 constructor1) - then raise NotUnifiable - else - let eqs' = - try (List.combine cpl1 cpl2) @ eqs - with Invalid_argument _ -> anomaly (Pp.str "are_unifiable_aux.") - in - are_unifiable_aux eqs' + | (l, r) :: eqs -> ( + match (DAst.get l, DAst.get r) with + | PatVar _, _ | _, PatVar _ -> are_unifiable_aux eqs + | PatCstr (constructor1, cpl1, _), PatCstr (constructor2, cpl2, _) -> + if not (eq_constructor constructor2 constructor1) then raise NotUnifiable + else + let eqs' = + try List.combine cpl1 cpl2 @ eqs + with Invalid_argument _ -> anomaly (Pp.str "are_unifiable_aux.") + in + are_unifiable_aux eqs' ) let are_unifiable pat1 pat2 = try - are_unifiable_aux [pat1,pat2]; + are_unifiable_aux [(pat1, pat2)]; true with NotUnifiable -> false - -let rec eq_cases_pattern_aux = function +let rec eq_cases_pattern_aux = function | [] -> () - | (l, r) ::eqs -> - match DAst.get l, DAst.get r with - | PatVar _, PatVar _ -> eq_cases_pattern_aux eqs - | PatCstr(constructor1,cpl1,_), PatCstr(constructor2,cpl2,_) -> - if not (eq_constructor constructor2 constructor1) - then raise NotUnifiable - else - let eqs' = - try (List.combine cpl1 cpl2) @ eqs - with Invalid_argument _ -> anomaly (Pp.str "eq_cases_pattern_aux.") - in - eq_cases_pattern_aux eqs' - | _ -> raise NotUnifiable + | (l, r) :: eqs -> ( + match (DAst.get l, DAst.get r) with + | PatVar _, PatVar _ -> eq_cases_pattern_aux eqs + | PatCstr (constructor1, cpl1, _), PatCstr (constructor2, cpl2, _) -> + if not (eq_constructor constructor2 constructor1) then raise NotUnifiable + else + let eqs' = + try List.combine cpl1 cpl2 @ eqs + with Invalid_argument _ -> anomaly (Pp.str "eq_cases_pattern_aux.") + in + eq_cases_pattern_aux eqs' + | _ -> raise NotUnifiable ) let eq_cases_pattern pat1 pat2 = try - eq_cases_pattern_aux [pat1,pat2]; + eq_cases_pattern_aux [(pat1, pat2)]; true with NotUnifiable -> false - - let ids_of_pat = - let rec ids_of_pat ids = DAst.with_val (function - | PatVar Anonymous -> ids - | PatVar(Name id) -> Id.Set.add id ids - | PatCstr(_,patl,_) -> List.fold_left ids_of_pat ids patl - ) + let rec ids_of_pat ids = + DAst.with_val (function + | PatVar Anonymous -> ids + | PatVar (Name id) -> Id.Set.add id ids + | PatCstr (_, patl, _) -> List.fold_left ids_of_pat ids patl) in ids_of_pat Id.Set.empty let expand_as = - let rec add_as map rt = match DAst.get rt with - | PatVar _ -> map - | PatCstr(_,patl,Name id) -> - Id.Map.add id (pattern_to_term rt) (List.fold_left add_as map patl) - | PatCstr(_,patl,_) -> List.fold_left add_as map patl + | PatVar _ -> map + | PatCstr (_, patl, Name id) -> + Id.Map.add id (pattern_to_term rt) (List.fold_left add_as map patl) + | PatCstr (_, patl, _) -> List.fold_left add_as map patl in - let rec expand_as map = DAst.map (function - | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ | GFloat _ as rt -> rt - | GVar id as rt -> - begin - try - DAst.get (Id.Map.find id map) - with Not_found -> rt - end - | GApp(f,args) -> GApp(expand_as map f,List.map (expand_as map) args) - | GLambda(na,k,t,b) -> GLambda(na,k,expand_as map t, expand_as map b) - | GProd(na,k,t,b) -> GProd(na,k,expand_as map t, expand_as map b) - | GLetIn(na,v,typ,b) -> GLetIn(na, expand_as map v,Option.map (expand_as map) typ,expand_as map b) - | GLetTuple(nal,(na,po),v,b) -> - GLetTuple(nal,(na,Option.map (expand_as map) po), - expand_as map v, expand_as map b) - | GIf(e,(na,po),br1,br2) -> - GIf(expand_as map e,(na,Option.map (expand_as map) po), - expand_as map br1, expand_as map br2) - | GRec _ -> user_err Pp.(str "Not handled GRec") - | GCast(b,c) -> - GCast(expand_as map b, - Glob_ops.map_cast_type (expand_as map) c) - | GCases(sty,po,el,brl) -> - GCases(sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el, - List.map (expand_as_br map) brl) - ) - and expand_as_br map {CAst.loc; v=(idl,cpl,rt)} = - CAst.make ?loc (idl,cpl, expand_as (List.fold_left add_as map cpl) rt) + let rec expand_as map = + DAst.map (function + | (GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ | GFloat _) + as rt -> + rt + | GVar id as rt -> ( + try DAst.get (Id.Map.find id map) with Not_found -> rt ) + | GApp (f, args) -> GApp (expand_as map f, List.map (expand_as map) args) + | GLambda (na, k, t, b) -> + GLambda (na, k, expand_as map t, expand_as map b) + | GProd (na, k, t, b) -> GProd (na, k, expand_as map t, expand_as map b) + | GLetIn (na, v, typ, b) -> + GLetIn + (na, expand_as map v, Option.map (expand_as map) typ, expand_as map b) + | GLetTuple (nal, (na, po), v, b) -> + GLetTuple + ( nal + , (na, Option.map (expand_as map) po) + , expand_as map v + , expand_as map b ) + | GIf (e, (na, po), br1, br2) -> + GIf + ( expand_as map e + , (na, Option.map (expand_as map) po) + , expand_as map br1 + , expand_as map br2 ) + | GRec _ -> user_err Pp.(str "Not handled GRec") + | GCast (b, c) -> + GCast (expand_as map b, Glob_ops.map_cast_type (expand_as map) c) + | GCases (sty, po, el, brl) -> + GCases + ( sty + , Option.map (expand_as map) po + , List.map (fun (rt, t) -> (expand_as map rt, t)) el + , List.map (expand_as_br map) brl )) + and expand_as_br map {CAst.loc; v = idl, cpl, rt} = + CAst.make ?loc (idl, cpl, expand_as (List.fold_left add_as map cpl) rt) in expand_as Id.Map.empty @@ -566,65 +520,75 @@ let expand_as = *) exception Found of Evd.evar_info -let resolve_and_replace_implicits ?(flags=Pretyping.all_and_fail_flags) ?(expected_type=Pretyping.WithoutTypeConstraint) env sigma rt = + +let resolve_and_replace_implicits ?(flags = Pretyping.all_and_fail_flags) + ?(expected_type = Pretyping.WithoutTypeConstraint) env sigma rt = let open Evd in let open Evar_kinds in (* we first (pseudo) understand [rt] and get back the computed evar_map *) (* FIXME : JF (30/03/2017) I'm not completely sure to have split understand as needed. -If someone knows how to prevent solved existantial removal in understand, please do not hesitate to change the computation of [ctx] here *) - let ctx,_,_ = Pretyping.ise_pretype_gen flags env sigma Glob_ops.empty_lvar expected_type rt in + If someone knows how to prevent solved existantial removal in understand, please do not hesitate to change the computation of [ctx] here *) + let ctx, _, _ = + Pretyping.ise_pretype_gen flags env sigma Glob_ops.empty_lvar expected_type + rt + in let ctx = Evd.minimize_universes ctx in - let f c = EConstr.of_constr (Evarutil.nf_evars_universes ctx (EConstr.Unsafe.to_constr c)) in - + let f c = + EConstr.of_constr + (Evarutil.nf_evars_universes ctx (EConstr.Unsafe.to_constr c)) + in (* then we map [rt] to replace the implicit holes by their values *) let rec change rt = match DAst.get rt with - | GHole(ImplicitArg(grk,pk,bk),_,_) -> (* we only want to deal with implicit arguments *) - ( - try (* we scan the new evar map to find the evar corresponding to this hole (by looking the source *) - Evd.fold (* to simulate an iter *) - (fun _ evi _ -> - match evi.evar_source with - | (loc_evi,ImplicitArg(gr_evi,p_evi,b_evi)) -> - if GlobRef.equal grk gr_evi && pk=p_evi && bk=b_evi && rt.CAst.loc = loc_evi - then raise (Found evi) - | _ -> () - ) - ctx - (); - (* the hole was not solved : we do nothing *) - rt - with Found evi -> (* we found the evar corresponding to this hole *) - match evi.evar_body with - | Evar_defined c -> - (* we just have to lift the solution in glob_term *) - Detyping.detype Detyping.Now false Id.Set.empty env ctx (f c) - | Evar_empty -> rt (* the hole was not solved : we do nothing *) - ) - | (GHole(BinderType na,_,_)) -> (* we only want to deal with implicit arguments *) - ( - let res = - try (* we scan the new evar map to find the evar corresponding to this hole (by looking the source *) - Evd.fold (* to simulate an iter *) - (fun _ evi _ -> - match evi.evar_source with - | (loc_evi,BinderType na') -> - if Name.equal na na' && rt.CAst.loc = loc_evi then raise (Found evi) - | _ -> () - ) - ctx - (); - (* the hole was not solved : we do nothing *) - rt - with Found evi -> (* we found the evar corresponding to this hole *) - match evi.evar_body with - | Evar_defined c -> - (* we just have to lift the solution in glob_term *) - Detyping.detype Detyping.Now false Id.Set.empty env ctx (f c) - | Evar_empty -> rt (* the hole was not solved : we d when falseo nothing *) - in - res - ) + | GHole (ImplicitArg (grk, pk, bk), _, _) -> ( + try + (* we only want to deal with implicit arguments *) + + (* we scan the new evar map to find the evar corresponding to this hole (by looking the source *) + Evd.fold (* to simulate an iter *) + (fun _ evi _ -> + match evi.evar_source with + | loc_evi, ImplicitArg (gr_evi, p_evi, b_evi) -> + if + GlobRef.equal grk gr_evi && pk = p_evi && bk = b_evi + && rt.CAst.loc = loc_evi + then raise (Found evi) + | _ -> ()) + ctx (); + (* the hole was not solved : we do nothing *) + rt + with Found evi -> ( + (* we found the evar corresponding to this hole *) + match evi.evar_body with + | Evar_defined c -> + (* we just have to lift the solution in glob_term *) + Detyping.detype Detyping.Now false Id.Set.empty env ctx (f c) + | Evar_empty -> rt (* the hole was not solved : we do nothing *) ) ) + | GHole (BinderType na, _, _) -> + (* we only want to deal with implicit arguments *) + let res = + try + (* we scan the new evar map to find the evar corresponding to this hole (by looking the source *) + Evd.fold (* to simulate an iter *) + (fun _ evi _ -> + match evi.evar_source with + | loc_evi, BinderType na' -> + if Name.equal na na' && rt.CAst.loc = loc_evi then + raise (Found evi) + | _ -> ()) + ctx (); + (* the hole was not solved : we do nothing *) + rt + with Found evi -> ( + (* we found the evar corresponding to this hole *) + match evi.evar_body with + | Evar_defined c -> + (* we just have to lift the solution in glob_term *) + Detyping.detype Detyping.Now false Id.Set.empty env ctx (f c) + | Evar_empty -> rt ) + (* the hole was not solved : we d when falseo nothing *) + in + res | _ -> Glob_ops.map_glob_constr change rt in change rt diff --git a/plugins/funind/glob_termops.mli b/plugins/funind/glob_termops.mli index c55fdc017c..8eff7926da 100644 --- a/plugins/funind/glob_termops.mli +++ b/plugins/funind/glob_termops.mli @@ -25,33 +25,37 @@ val pattern_to_term : cases_pattern -> glob_constr *) val mkGRef : GlobRef.t -> glob_constr val mkGVar : Id.t -> glob_constr -val mkGApp : glob_constr*(glob_constr list) -> glob_constr +val mkGApp : glob_constr * glob_constr list -> glob_constr val mkGLambda : Name.t * glob_constr * glob_constr -> glob_constr val mkGProd : Name.t * glob_constr * glob_constr -> glob_constr -val mkGLetIn : Name.t * glob_constr * glob_constr option * glob_constr -> glob_constr -val mkGCases : glob_constr option * tomatch_tuples * cases_clauses -> glob_constr -val mkGHole : unit -> glob_constr (* we only build Evd.BinderType Anonymous holes *) + +val mkGLetIn : + Name.t * glob_constr * glob_constr option * glob_constr -> glob_constr + +val mkGCases : + glob_constr option * tomatch_tuples * cases_clauses -> glob_constr + +val mkGHole : unit -> glob_constr + +(* we only build Evd.BinderType Anonymous holes *) + (* Some basic functions to decompose glob_constrs These are analogous to the ones constrs *) -val glob_decompose_app : glob_constr -> glob_constr*(glob_constr list) - +val glob_decompose_app : glob_constr -> glob_constr * glob_constr list (* [glob_make_eq t1 t2] build the glob_constr corresponding to [t2 = t1] *) -val glob_make_eq : ?typ:glob_constr -> glob_constr -> glob_constr -> glob_constr +val glob_make_eq : ?typ:glob_constr -> glob_constr -> glob_constr -> glob_constr + (* [glob_make_neq t1 t2] build the glob_constr corresponding to [t1 <> t2] *) -val glob_make_neq : glob_constr -> glob_constr -> glob_constr +val glob_make_neq : glob_constr -> glob_constr -> glob_constr (* alpha_conversion functions *) - - (* Replace the var mapped in the glob_constr/context *) val change_vars : Id.t Id.Map.t -> glob_constr -> glob_constr - - (* [alpha_pat avoid pat] rename all the variables present in [pat] s.t. the result does not share variables with [avoid]. This function create a fresh variable for each occurrence of the anonymous pattern. @@ -59,11 +63,10 @@ val change_vars : Id.t Id.Map.t -> glob_constr -> glob_constr Also returns a mapping from old variables to new ones and the concatenation of [avoid] with the variables appearing in the result. *) - val alpha_pat : - Id.Map.key list -> - Glob_term.cases_pattern -> - Glob_term.cases_pattern * Id.Map.key list * - Id.t Id.Map.t +val alpha_pat : + Id.Map.key list + -> Glob_term.cases_pattern + -> Glob_term.cases_pattern * Id.Map.key list * Id.t Id.Map.t (* [alpha_rt avoid rt] alpha convert [rt] s.t. the result respects barendregt conventions and does not share bound variables with avoid @@ -71,38 +74,35 @@ val change_vars : Id.t Id.Map.t -> glob_constr -> glob_constr val alpha_rt : Id.t list -> glob_constr -> glob_constr (* same as alpha_rt but for case branches *) -val alpha_br : Id.t list -> - Glob_term.cases_clause -> - Glob_term.cases_clause +val alpha_br : Id.t list -> Glob_term.cases_clause -> Glob_term.cases_clause (* Reduction function *) -val replace_var_by_term : - Id.t -> - Glob_term.glob_constr -> Glob_term.glob_constr -> Glob_term.glob_constr - - +val replace_var_by_term : + Id.t + -> Glob_term.glob_constr + -> Glob_term.glob_constr + -> Glob_term.glob_constr (* [is_free_in id rt] checks if [id] is a free variable in [rt] *) val is_free_in : Id.t -> glob_constr -> bool - - val are_unifiable : cases_pattern -> cases_pattern -> bool val eq_cases_pattern : cases_pattern -> cases_pattern -> bool - - (* ids_of_pat : cases_pattern -> Id.Set.t returns the set of variables appearing in a pattern *) -val ids_of_pat : cases_pattern -> Id.Set.t - +val ids_of_pat : cases_pattern -> Id.Set.t val expand_as : glob_constr -> glob_constr (* [resolve_and_replace_implicits ?expected_type env sigma rt] solves implicits of [rt] w.r.t. [env] and [sigma] and then replace them by their solution *) val resolve_and_replace_implicits : - ?flags:Pretyping.inference_flags -> - ?expected_type:Pretyping.typing_constraint -> Environ.env -> Evd.evar_map -> glob_constr -> glob_constr + ?flags:Pretyping.inference_flags + -> ?expected_type:Pretyping.typing_constraint + -> Environ.env + -> Evd.evar_map + -> glob_constr + -> glob_constr diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 1f2f56ec34..4e0e2dc501 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -15,48 +15,49 @@ open Names open Sorts open Constr open EConstr - open Tacmach.New open Tacticals.New open Tactics - open Indfun_common - module RelDecl = Context.Rel.Declaration let is_rec_info sigma scheme_info = let test_branche min acc decl = - acc || ( - let new_branche = - it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum sigma (RelDecl.get_type decl))) in - let free_rels_in_br = Termops.free_rels sigma new_branche in - let max = min + scheme_info.Tactics.npredicates in - Int.Set.exists (fun i -> i >= min && i< max) free_rels_in_br - ) + acc + || + let new_branche = + it_mkProd_or_LetIn mkProp + (fst (decompose_prod_assum sigma (RelDecl.get_type decl))) + in + let free_rels_in_br = Termops.free_rels sigma new_branche in + let max = min + scheme_info.Tactics.npredicates in + Int.Set.exists (fun i -> i >= min && i < max) free_rels_in_br in List.fold_left_i test_branche 1 false (List.rev scheme_info.Tactics.branches) let choose_dest_or_ind scheme_info args = Proofview.tclBIND Proofview.tclEVARMAP (fun sigma -> - Tactics.induction_destruct (is_rec_info sigma scheme_info) false args) + Tactics.induction_destruct (is_rec_info sigma scheme_info) false args) let functional_induction with_clean c princl pat = let open Proofview.Notations in Proofview.Goal.enter_one (fun gl -> - let sigma = project gl in - let f,args = decompose_app sigma c in - match princl with - | None -> (* No principle is given let's find the good one *) - begin + let sigma = project gl in + let f, args = decompose_app sigma c in + match princl with + | None -> ( + (* No principle is given let's find the good one *) match EConstr.kind sigma f with - | Const (c',u) -> + | Const (c', u) -> let princ_option = - let finfo = (* we first try to find out a graph on f *) + let finfo = + (* we first try to find out a graph on f *) match find_Function_infos c' with | Some finfo -> finfo | None -> - user_err (str "Cannot find induction information on "++ - Printer.pr_leconstr_env (pf_env gl) sigma (mkConst c') ) + user_err + ( str "Cannot find induction information on " + ++ Printer.pr_leconstr_env (pf_env gl) sigma (mkConst c') ) in match elimination_sort_of_goal gl with | InSProp -> finfo.sprop_lemma @@ -64,7 +65,8 @@ let functional_induction with_clean c princl pat = | InSet -> finfo.rec_lemma | InType -> finfo.rect_lemma in - let sigma, princ = (* then we get the principle *) + let sigma, princ = + (* then we get the principle *) match princ_option with | Some princ -> Evd.fresh_global (pf_env gl) (project gl) (GlobRef.ConstRef princ) @@ -79,66 +81,74 @@ let functional_induction with_clean c princl pat = in let princ_ref = try - Constrintern.locate_reference (Libnames.qualid_of_ident princ_name) - with - | Not_found -> - user_err (str "Cannot find induction principle for " - ++ Printer.pr_leconstr_env (pf_env gl) sigma (mkConst c') ) + Constrintern.locate_reference + (Libnames.qualid_of_ident princ_name) + with Not_found -> + user_err + ( str "Cannot find induction principle for " + ++ Printer.pr_leconstr_env (pf_env gl) sigma (mkConst c') ) in Evd.fresh_global (pf_env gl) (project gl) princ_ref in let princt = Retyping.get_type_of (pf_env gl) sigma princ in - Proofview.Unsafe.tclEVARS sigma <*> - Proofview.tclUNIT (princ, Tactypes.NoBindings, princt, args) + Proofview.Unsafe.tclEVARS sigma + <*> Proofview.tclUNIT (princ, Tactypes.NoBindings, princt, args) | _ -> - CErrors.user_err (str "functional induction must be used with a function" ) - end - | Some ((princ,binding)) -> - let sigma, princt = pf_type_of gl princ in - Proofview.Unsafe.tclEVARS sigma <*> - Proofview.tclUNIT (princ, binding, princt, args) - ) >>= fun (princ, bindings, princ_type, args) -> + CErrors.user_err + (str "functional induction must be used with a function") ) + | Some (princ, binding) -> + let sigma, princt = pf_type_of gl princ in + Proofview.Unsafe.tclEVARS sigma + <*> Proofview.tclUNIT (princ, binding, princt, args)) + >>= fun (princ, bindings, princ_type, args) -> Proofview.Goal.enter (fun gl -> - let sigma = project gl in - let princ_infos = compute_elim_sig (project gl) princ_type in - let args_as_induction_constr = - let c_list = - if princ_infos.Tactics.farg_in_concl - then [c] else [] - in - if List.length args + List.length c_list = 0 - then user_err Pp.(str "Cannot recognize a valid functional scheme" ); - let encoded_pat_as_patlist = - List.make (List.length args + List.length c_list - 1) None @ [pat] - in - List.map2 - (fun c pat -> - ((None, ElimOnConstr (fun env sigma -> (sigma,(c,Tactypes.NoBindings)))), - (None,pat), None)) - (args@c_list) - encoded_pat_as_patlist - in - let princ' = Some (princ,bindings) in - let princ_vars = - List.fold_right - (fun a acc -> try Id.Set.add (destVar sigma a) acc with DestKO -> acc) - args - Id.Set.empty - in - let old_idl = List.fold_right Id.Set.add (pf_ids_of_hyps gl) Id.Set.empty in - let old_idl = Id.Set.diff old_idl princ_vars in - let subst_and_reduce gl = - if with_clean - then - let idl = List.filter (fun id -> not (Id.Set.mem id old_idl))(pf_ids_of_hyps gl) in - let flag = Genredexpr.Cbv { Redops.all_flags with Genredexpr.rDelta = false } in + let sigma = project gl in + let princ_infos = compute_elim_sig (project gl) princ_type in + let args_as_induction_constr = + let c_list = if princ_infos.Tactics.farg_in_concl then [c] else [] in + if List.length args + List.length c_list = 0 then + user_err Pp.(str "Cannot recognize a valid functional scheme"); + let encoded_pat_as_patlist = + List.make (List.length args + List.length c_list - 1) None @ [pat] + in + List.map2 + (fun c pat -> + ( ( None + , ElimOnConstr + (fun env sigma -> (sigma, (c, Tactypes.NoBindings))) ) + , (None, pat) + , None )) + (args @ c_list) encoded_pat_as_patlist + in + let princ' = Some (princ, bindings) in + let princ_vars = + List.fold_right + (fun a acc -> + try Id.Set.add (destVar sigma a) acc with DestKO -> acc) + args Id.Set.empty + in + let old_idl = + List.fold_right Id.Set.add (pf_ids_of_hyps gl) Id.Set.empty + in + let old_idl = Id.Set.diff old_idl princ_vars in + let subst_and_reduce gl = + if with_clean then + let idl = + List.filter + (fun id -> not (Id.Set.mem id old_idl)) + (pf_ids_of_hyps gl) + in + let flag = + Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false} + in + tclTHEN + (tclMAP + (fun id -> + tclTRY (Equality.subst_gen (do_rewrite_dependent ()) [id])) + idl) + (reduce flag Locusops.allHypsAndConcl) + else tclIDTAC + in tclTHEN - (tclMAP (fun id -> tclTRY (Equality.subst_gen (do_rewrite_dependent ()) [id])) idl) - (reduce flag Locusops.allHypsAndConcl) - else tclIDTAC - in - tclTHEN - (choose_dest_or_ind - princ_infos - (args_as_induction_constr,princ')) - (Proofview.Goal.enter subst_and_reduce)) + (choose_dest_or_ind princ_infos (args_as_induction_constr, princ')) + (Proofview.Goal.enter subst_and_reduce)) diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli index 4f3d4a1587..daabc4e7c6 100644 --- a/plugins/funind/indfun.mli +++ b/plugins/funind/indfun.mli @@ -8,8 +8,8 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -val functional_induction - : bool +val functional_induction : + bool -> EConstr.constr -> (EConstr.constr * EConstr.constr Tactypes.bindings) option -> Ltac_plugin.Tacexpr.or_and_intro_pattern option diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 7d87fc0220..e83fe56cc9 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -4,112 +4,96 @@ open Constr open Libnames open Refiner -let mk_prefix pre id = Id.of_string (pre^(Id.to_string id)) +let mk_prefix pre id = Id.of_string (pre ^ Id.to_string id) let mk_rel_id = mk_prefix "R_" let mk_correct_id id = Nameops.add_suffix (mk_rel_id id) "_correct" let mk_complete_id id = Nameops.add_suffix (mk_rel_id id) "_complete" let mk_equation_id id = Nameops.add_suffix id "_equation" -let fresh_id avoid s = Namegen.next_ident_away_in_goal (Id.of_string s) (Id.Set.of_list avoid) +let fresh_id avoid s = + Namegen.next_ident_away_in_goal (Id.of_string s) (Id.Set.of_list avoid) let fresh_name avoid s = Name (fresh_id avoid s) -let get_name avoid ?(default="H") = function +let get_name avoid ?(default = "H") = function | Anonymous -> fresh_name avoid default | Name n -> Name n -let array_get_start a = - Array.init - (Array.length a - 1) - (fun i -> a.(i)) - +let array_get_start a = Array.init (Array.length a - 1) (fun i -> a.(i)) let locate qid = Nametab.locate qid let locate_ind ref = - match locate ref with - | GlobRef.IndRef x -> x - | _ -> raise Not_found + match locate ref with GlobRef.IndRef x -> x | _ -> raise Not_found let locate_constant ref = - match locate ref with - | GlobRef.ConstRef x -> x - | _ -> raise Not_found - - -let locate_with_msg msg f x = - try f x - with - | Not_found -> - CErrors.user_err msg + match locate ref with GlobRef.ConstRef x -> x | _ -> raise Not_found +let locate_with_msg msg f x = try f x with Not_found -> CErrors.user_err msg let filter_map filter f = let rec it = function | [] -> [] - | e::l -> - if filter e - then - (f e) :: it l - else it l + | e :: l -> if filter e then f e :: it l else it l in it - -let chop_rlambda_n = +let chop_rlambda_n = let rec chop_lambda_n acc n rt = - if n == 0 - then List.rev acc,rt - else - match DAst.get rt with - | Glob_term.GLambda(name,k,t,b) -> chop_lambda_n ((name,t,None)::acc) (n-1) b - | Glob_term.GLetIn(name,v,t,b) -> chop_lambda_n ((name,v,t)::acc) (n-1) b - | _ -> - CErrors.user_err ~hdr:"chop_rlambda_n" (str "chop_rlambda_n: Not enough Lambdas") + if n == 0 then (List.rev acc, rt) + else + match DAst.get rt with + | Glob_term.GLambda (name, k, t, b) -> + chop_lambda_n ((name, t, None) :: acc) (n - 1) b + | Glob_term.GLetIn (name, v, t, b) -> + chop_lambda_n ((name, v, t) :: acc) (n - 1) b + | _ -> + CErrors.user_err ~hdr:"chop_rlambda_n" + (str "chop_rlambda_n: Not enough Lambdas") in chop_lambda_n [] -let chop_rprod_n = +let chop_rprod_n = let rec chop_prod_n acc n rt = - if n == 0 - then List.rev acc,rt - else - match DAst.get rt with - | Glob_term.GProd(name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b - | _ -> - CErrors.user_err ~hdr:"chop_rprod_n" (str "chop_rprod_n: Not enough products") + if n == 0 then (List.rev acc, rt) + else + match DAst.get rt with + | Glob_term.GProd (name, k, t, b) -> + chop_prod_n ((name, t) :: acc) (n - 1) b + | _ -> + CErrors.user_err ~hdr:"chop_rprod_n" + (str "chop_rprod_n: Not enough products") in chop_prod_n [] - - let list_union_eq eq_fun l1 l2 = let rec urec = function | [] -> l2 - | a::l -> if List.exists (eq_fun a) l2 then urec l else a::urec l + | a :: l -> if List.exists (eq_fun a) l2 then urec l else a :: urec l in urec l1 -let list_add_set_eq eq_fun x l = - if List.exists (eq_fun x) l then l else x::l - -let coq_constant s = UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref s;; +let list_add_set_eq eq_fun x l = if List.exists (eq_fun x) l then l else x :: l +let coq_constant s = UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref s let find_reference sl s = let dp = Names.DirPath.make (List.rev_map Id.of_string sl) in Nametab.locate (make_qualid dp (Id.of_string s)) -let eq = lazy(EConstr.of_constr (coq_constant "core.eq.type")) -let refl_equal = lazy(EConstr.of_constr (coq_constant "core.eq.refl")) +let eq = lazy (EConstr.of_constr (coq_constant "core.eq.type")) +let refl_equal = lazy (EConstr.of_constr (coq_constant "core.eq.refl")) let with_full_print f a = let old_implicit_args = Impargs.is_implicit_args () - and old_strict_implicit_args = Impargs.is_strict_implicit_args () + and old_strict_implicit_args = Impargs.is_strict_implicit_args () and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in let old_rawprint = !Flags.raw_print in let old_printuniverses = !Constrextern.print_universes in - let old_printallowmatchdefaultclause = !Detyping.print_allow_match_default_clause in + let old_printallowmatchdefaultclause = + Detyping.print_allow_match_default_clause () + in Constrextern.print_universes := true; - Detyping.print_allow_match_default_clause := false; + Goptions.set_bool_option_value Detyping.print_allow_match_default_opt_name + false; Flags.raw_print := true; Impargs.make_implicit_args false; Impargs.make_strict_implicit_args false; @@ -122,47 +106,41 @@ let with_full_print f a = Impargs.make_contextual_implicit_args old_contextual_implicit_args; Flags.raw_print := old_rawprint; Constrextern.print_universes := old_printuniverses; - Detyping.print_allow_match_default_clause := old_printallowmatchdefaultclause; + Goptions.set_bool_option_value Detyping.print_allow_match_default_opt_name + old_printallowmatchdefaultclause; Dumpglob.continue (); res - with - | reraise -> - Impargs.make_implicit_args old_implicit_args; - Impargs.make_strict_implicit_args old_strict_implicit_args; - Impargs.make_contextual_implicit_args old_contextual_implicit_args; - Flags.raw_print := old_rawprint; - Constrextern.print_universes := old_printuniverses; - Detyping.print_allow_match_default_clause := old_printallowmatchdefaultclause; - Dumpglob.continue (); - raise reraise - - - - - + with reraise -> + Impargs.make_implicit_args old_implicit_args; + Impargs.make_strict_implicit_args old_strict_implicit_args; + Impargs.make_contextual_implicit_args old_contextual_implicit_args; + Flags.raw_print := old_rawprint; + Constrextern.print_universes := old_printuniverses; + Goptions.set_bool_option_value Detyping.print_allow_match_default_opt_name + old_printallowmatchdefaultclause; + Dumpglob.continue (); + raise reraise (**********************) type function_info = - { - function_constant : Constant.t; - graph_ind : inductive; - equation_lemma : Constant.t option; - correctness_lemma : Constant.t option; - completeness_lemma : Constant.t option; - rect_lemma : Constant.t option; - rec_lemma : Constant.t option; - prop_lemma : Constant.t option; - sprop_lemma : Constant.t option; - is_general : bool; (* Has this function been defined using general recursive definition *) - } - + { function_constant : Constant.t + ; graph_ind : inductive + ; equation_lemma : Constant.t option + ; correctness_lemma : Constant.t option + ; completeness_lemma : Constant.t option + ; rect_lemma : Constant.t option + ; rec_lemma : Constant.t option + ; prop_lemma : Constant.t option + ; sprop_lemma : Constant.t option + ; is_general : bool + (* Has this function been defined using general recursive definition *) + } (* type function_db = function_info list *) (* let function_table = ref ([] : function_db) *) - let from_function = Summary.ref Cmap_env.empty ~name:"functions_db_fn" let from_graph = Summary.ref Indmap.empty ~name:"functions_db_gr" @@ -187,91 +165,105 @@ let cache_Function (_,(finfos)) = then function_table := new_tbl *) -let cache_Function (_,finfos) = +let cache_Function (_, finfos) = from_function := Cmap_env.add finfos.function_constant finfos !from_function; from_graph := Indmap.add finfos.graph_ind finfos !from_graph - -let subst_Function (subst,finfos) = +let subst_Function (subst, finfos) = let do_subst_con c = Mod_subst.subst_constant subst c - and do_subst_ind i = Mod_subst.subst_ind subst i - in + and do_subst_ind i = Mod_subst.subst_ind subst i in let function_constant' = do_subst_con finfos.function_constant in let graph_ind' = do_subst_ind finfos.graph_ind in let equation_lemma' = Option.Smart.map do_subst_con finfos.equation_lemma in - let correctness_lemma' = Option.Smart.map do_subst_con finfos.correctness_lemma in - let completeness_lemma' = Option.Smart.map do_subst_con finfos.completeness_lemma in + let correctness_lemma' = + Option.Smart.map do_subst_con finfos.correctness_lemma + in + let completeness_lemma' = + Option.Smart.map do_subst_con finfos.completeness_lemma + in let rect_lemma' = Option.Smart.map do_subst_con finfos.rect_lemma in let rec_lemma' = Option.Smart.map do_subst_con finfos.rec_lemma in - let prop_lemma' = Option.Smart.map do_subst_con finfos.prop_lemma in + let prop_lemma' = Option.Smart.map do_subst_con finfos.prop_lemma in let sprop_lemma' = Option.Smart.map do_subst_con finfos.sprop_lemma in - if function_constant' == finfos.function_constant && - graph_ind' == finfos.graph_ind && - equation_lemma' == finfos.equation_lemma && - correctness_lemma' == finfos.correctness_lemma && - completeness_lemma' == finfos.completeness_lemma && - rect_lemma' == finfos.rect_lemma && - rec_lemma' == finfos.rec_lemma && - prop_lemma' == finfos.prop_lemma && - sprop_lemma' == finfos.sprop_lemma + if + function_constant' == finfos.function_constant + && graph_ind' == finfos.graph_ind + && equation_lemma' == finfos.equation_lemma + && correctness_lemma' == finfos.correctness_lemma + && completeness_lemma' == finfos.completeness_lemma + && rect_lemma' == finfos.rect_lemma + && rec_lemma' == finfos.rec_lemma + && prop_lemma' == finfos.prop_lemma + && sprop_lemma' == finfos.sprop_lemma then finfos else - { function_constant = function_constant'; - graph_ind = graph_ind'; - equation_lemma = equation_lemma' ; - correctness_lemma = correctness_lemma' ; - completeness_lemma = completeness_lemma' ; - rect_lemma = rect_lemma' ; - rec_lemma = rec_lemma'; - prop_lemma = prop_lemma'; - sprop_lemma = sprop_lemma'; - is_general = finfos.is_general - } - -let discharge_Function (_,finfos) = Some finfos + { function_constant = function_constant' + ; graph_ind = graph_ind' + ; equation_lemma = equation_lemma' + ; correctness_lemma = correctness_lemma' + ; completeness_lemma = completeness_lemma' + ; rect_lemma = rect_lemma' + ; rec_lemma = rec_lemma' + ; prop_lemma = prop_lemma' + ; sprop_lemma = sprop_lemma' + ; is_general = finfos.is_general } + +let discharge_Function (_, finfos) = Some finfos let pr_ocst env sigma c = - Option.fold_right (fun v acc -> Printer.pr_lconstr_env env sigma (mkConst v)) c (mt ()) + Option.fold_right + (fun v acc -> Printer.pr_lconstr_env env sigma (mkConst v)) + c (mt ()) let pr_info env sigma f_info = - str "function_constant := " ++ - Printer.pr_lconstr_env env sigma (mkConst f_info.function_constant)++ fnl () ++ - str "function_constant_type := " ++ - (try - Printer.pr_lconstr_env env sigma - (fst (Typeops.type_of_global_in_context env (GlobRef.ConstRef f_info.function_constant))) - with e when CErrors.noncritical e -> mt ()) ++ fnl () ++ - str "equation_lemma := " ++ pr_ocst env sigma f_info.equation_lemma ++ fnl () ++ - str "completeness_lemma :=" ++ pr_ocst env sigma f_info.completeness_lemma ++ fnl () ++ - str "correctness_lemma := " ++ pr_ocst env sigma f_info.correctness_lemma ++ fnl () ++ - str "rect_lemma := " ++ pr_ocst env sigma f_info.rect_lemma ++ fnl () ++ - str "rec_lemma := " ++ pr_ocst env sigma f_info.rec_lemma ++ fnl () ++ - str "prop_lemma := " ++ pr_ocst env sigma f_info.prop_lemma ++ fnl () ++ - str "graph_ind := " ++ Printer.pr_lconstr_env env sigma (mkInd f_info.graph_ind) ++ fnl () + str "function_constant := " + ++ Printer.pr_lconstr_env env sigma (mkConst f_info.function_constant) + ++ fnl () + ++ str "function_constant_type := " + ++ ( try + Printer.pr_lconstr_env env sigma + (fst + (Typeops.type_of_global_in_context env + (GlobRef.ConstRef f_info.function_constant))) + with e when CErrors.noncritical e -> mt () ) + ++ fnl () ++ str "equation_lemma := " + ++ pr_ocst env sigma f_info.equation_lemma + ++ fnl () + ++ str "completeness_lemma :=" + ++ pr_ocst env sigma f_info.completeness_lemma + ++ fnl () + ++ str "correctness_lemma := " + ++ pr_ocst env sigma f_info.correctness_lemma + ++ fnl () ++ str "rect_lemma := " + ++ pr_ocst env sigma f_info.rect_lemma + ++ fnl () ++ str "rec_lemma := " + ++ pr_ocst env sigma f_info.rec_lemma + ++ fnl () ++ str "prop_lemma := " + ++ pr_ocst env sigma f_info.prop_lemma + ++ fnl () ++ str "graph_ind := " + ++ Printer.pr_lconstr_env env sigma (mkInd f_info.graph_ind) + ++ fnl () let pr_table env sigma tb = - let l = Cmap_env.fold (fun k v acc -> v::acc) tb [] in + let l = Cmap_env.fold (fun k v acc -> v :: acc) tb [] in Pp.prlist_with_sep fnl (pr_info env sigma) l let in_Function : function_info -> Libobject.obj = let open Libobject in - declare_object @@ superglobal_object "FUNCTIONS_DB" - ~cache:cache_Function - ~subst:(Some subst_Function) - ~discharge:discharge_Function - + declare_object + @@ superglobal_object "FUNCTIONS_DB" ~cache:cache_Function + ~subst:(Some subst_Function) ~discharge:discharge_Function let find_or_none id = - try Some - (match Nametab.locate (qualid_of_ident id) with GlobRef.ConstRef c -> c | _ -> CErrors.anomaly (Pp.str "Not a constant.") - ) + try + Some + ( match Nametab.locate (qualid_of_ident id) with + | GlobRef.ConstRef c -> c + | _ -> CErrors.anomaly (Pp.str "Not a constant.") ) with Not_found -> None -let find_Function_infos f = - Cmap_env.find_opt f !from_function - -let find_Function_of_graph ind = - Indmap.find_opt ind !from_graph +let find_Function_infos f = Cmap_env.find_opt f !from_function +let find_Function_of_graph ind = Indmap.find_opt ind !from_graph let update_Function finfo = (* Pp.msgnl (pr_info finfo); *) @@ -287,136 +279,102 @@ let add_Function is_general f = and prop_lemma = find_or_none (Nameops.add_suffix f_id "_ind") and sprop_lemma = find_or_none (Nameops.add_suffix f_id "_sind") and graph_ind = - match Nametab.locate (qualid_of_ident (mk_rel_id f_id)) - with | GlobRef.IndRef ind -> ind | _ -> CErrors.anomaly (Pp.str "Not an inductive.") + match Nametab.locate (qualid_of_ident (mk_rel_id f_id)) with + | GlobRef.IndRef ind -> ind + | _ -> CErrors.anomaly (Pp.str "Not an inductive.") in let finfos = - { function_constant = f; - equation_lemma = equation_lemma; - completeness_lemma = completeness_lemma; - correctness_lemma = correctness_lemma; - rect_lemma = rect_lemma; - rec_lemma = rec_lemma; - prop_lemma = prop_lemma; - sprop_lemma = sprop_lemma; - graph_ind = graph_ind; - is_general = is_general - - } + { function_constant = f + ; equation_lemma + ; completeness_lemma + ; correctness_lemma + ; rect_lemma + ; rec_lemma + ; prop_lemma + ; sprop_lemma + ; graph_ind + ; is_general } in update_Function finfos let pr_table env sigma = pr_table env sigma !from_function + (*********************************) (* Debugging *) -let functional_induction_rewrite_dependent_proofs = ref true -let function_debug = ref false -open Goptions - -let functional_induction_rewrite_dependent_proofs_sig = - { - optdepr = false; - optkey = ["Functional";"Induction";"Rewrite";"Dependent"]; - optread = (fun () -> !functional_induction_rewrite_dependent_proofs); - optwrite = (fun b -> functional_induction_rewrite_dependent_proofs := b) - } -let () = declare_bool_option functional_induction_rewrite_dependent_proofs_sig - -let do_rewrite_dependent () = !functional_induction_rewrite_dependent_proofs = true - -let function_debug_sig = - { - optdepr = false; - optkey = ["Function_debug"]; - optread = (fun () -> !function_debug); - optwrite = (fun b -> function_debug := b) - } - -let () = declare_bool_option function_debug_sig - -let do_observe () = !function_debug +let do_rewrite_dependent = + Goptions.declare_bool_option_and_ref ~depr:false + ~key:["Functional"; "Induction"; "Rewrite"; "Dependent"] + ~value:true -let observe strm = - if do_observe () - then Feedback.msg_debug strm - else () +let do_observe = + Goptions.declare_bool_option_and_ref ~depr:false ~key:["Function_debug"] + ~value:false +let observe strm = if do_observe () then Feedback.msg_debug strm else () let debug_queue = Stack.create () let print_debug_queue b e = - if not (Stack.is_empty debug_queue) - then - let lmsg,goal = Stack.pop debug_queue in - (if b then - Feedback.msg_debug (hov 1 (lmsg ++ (str " raised exception " ++ CErrors.print e) ++ str " on goal" ++ fnl() ++ goal)) - else - Feedback.msg_debug (hov 1 (str " from " ++ lmsg ++ str " on goal"++fnl() ++ goal)) - (* print_debug_queue false e; *) - ) + if not (Stack.is_empty debug_queue) then + let lmsg, goal = Stack.pop debug_queue in + if b then + Feedback.msg_debug + (hov 1 + ( lmsg + ++ (str " raised exception " ++ CErrors.print e) + ++ str " on goal" ++ fnl () ++ goal )) + else + Feedback.msg_debug + (hov 1 (str " from " ++ lmsg ++ str " on goal" ++ fnl () ++ goal)) + +(* print_debug_queue false e; *) let do_observe_tac s tac g = let goal = Printer.pr_goal g in let s = s (pf_env g) (project g) in - let lmsg = (str "observation : ") ++ s in - Stack.push (lmsg,goal) debug_queue; + let lmsg = str "observation : " ++ s in + Stack.push (lmsg, goal) debug_queue; try let v = tac g in - ignore(Stack.pop debug_queue); + ignore (Stack.pop debug_queue); v with reraise -> let reraise = Exninfo.capture reraise in - if not (Stack.is_empty debug_queue) - then print_debug_queue true (fst reraise); + if not (Stack.is_empty debug_queue) then + print_debug_queue true (fst reraise); Exninfo.iraise reraise let observe_tac s tac g = - if do_observe () - then do_observe_tac s tac g - else tac g + if do_observe () then do_observe_tac s tac g else tac g module New = struct - -let do_observe_tac ~header s tac = - let open Proofview.Notations in - let open Proofview in - Goal.enter begin fun gl -> - let goal = Printer.pr_goal (Goal.print gl) in - let env, sigma = Goal.env gl, Goal.sigma gl in - let s = s env sigma in - let lmsg = seq [header; str " : " ++ s] in - tclLIFT (NonLogical.make (fun () -> - Feedback.msg_debug (s++fnl()))) >>= fun () -> - tclOR ( - Stack.push (lmsg, goal) debug_queue; - tac >>= fun v -> - ignore(Stack.pop debug_queue); - Proofview.tclUNIT v) - (fun (exn, info) -> - if not (Stack.is_empty debug_queue) - then print_debug_queue true exn; - tclZERO ~info exn) - end - -let observe_tac ~header s tac = - if do_observe () - then do_observe_tac ~header s tac - else tac - + let do_observe_tac ~header s tac = + let open Proofview.Notations in + let open Proofview in + Goal.enter (fun gl -> + let goal = Printer.pr_goal (Goal.print gl) in + let env, sigma = (Goal.env gl, Goal.sigma gl) in + let s = s env sigma in + let lmsg = seq [header; str " : " ++ s] in + tclLIFT (NonLogical.make (fun () -> Feedback.msg_debug (s ++ fnl ()))) + >>= fun () -> + tclOR + ( Stack.push (lmsg, goal) debug_queue; + tac + >>= fun v -> + ignore (Stack.pop debug_queue); + Proofview.tclUNIT v ) + (fun (exn, info) -> + if not (Stack.is_empty debug_queue) then print_debug_queue true exn; + tclZERO ~info exn)) + + let observe_tac ~header s tac = + if do_observe () then do_observe_tac ~header s tac else tac end -let strict_tcc = ref false -let is_strict_tcc () = !strict_tcc -let strict_tcc_sig = - { - optdepr = false; - optkey = ["Function_raw_tcc"]; - optread = (fun () -> !strict_tcc); - optwrite = (fun b -> strict_tcc := b) - } - -let () = declare_bool_option strict_tcc_sig - +let is_strict_tcc = + Goptions.declare_bool_option_and_ref ~depr:false ~key:["Function_raw_tcc"] + ~value:false exception Building_graph of exn exception Defining_principle of exn @@ -425,17 +383,15 @@ exception ToShow of exn let jmeq () = try Coqlib.check_required_library Coqlib.jmeq_module_name; - EConstr.of_constr @@ - UnivGen.constr_of_monomorphic_global @@ - Coqlib.lib_ref "core.JMeq.type" + EConstr.of_constr @@ UnivGen.constr_of_monomorphic_global + @@ Coqlib.lib_ref "core.JMeq.type" with e when CErrors.noncritical e -> raise (ToShow e) let jmeq_refl () = try Coqlib.check_required_library Coqlib.jmeq_module_name; - EConstr.of_constr @@ - UnivGen.constr_of_monomorphic_global @@ - Coqlib.lib_ref "core.JMeq.refl" + EConstr.of_constr @@ UnivGen.constr_of_monomorphic_global + @@ Coqlib.lib_ref "core.JMeq.refl" with e when CErrors.noncritical e -> raise (ToShow e) let h_intros l = @@ -443,49 +399,67 @@ let h_intros l = let h_id = Id.of_string "h" let hrec_id = Id.of_string "hrec" -let well_founded = function () -> EConstr.of_constr (coq_constant "core.wf.well_founded") + +let well_founded = function + | () -> EConstr.of_constr (coq_constant "core.wf.well_founded") + let acc_rel = function () -> EConstr.of_constr (coq_constant "core.wf.acc") -let acc_inv_id = function () -> EConstr.of_constr (coq_constant "core.wf.acc_inv") -let well_founded_ltof () = EConstr.of_constr (coq_constant "num.nat.well_founded_ltof") +let acc_inv_id = function + | () -> EConstr.of_constr (coq_constant "core.wf.acc_inv") + +let well_founded_ltof () = + EConstr.of_constr (coq_constant "num.nat.well_founded_ltof") -let ltof_ref = function () -> (find_reference ["Coq";"Arith";"Wf_nat"] "ltof") +let ltof_ref = function () -> find_reference ["Coq"; "Arith"; "Wf_nat"] "ltof" let make_eq () = - try EConstr.of_constr (UnivGen.constr_of_monomorphic_global (Coqlib.lib_ref "core.eq.type")) + try + EConstr.of_constr + (UnivGen.constr_of_monomorphic_global (Coqlib.lib_ref "core.eq.type")) with _ -> assert false -let evaluable_of_global_reference r = (* Tacred.evaluable_of_global_reference (Global.env ()) *) +let evaluable_of_global_reference r = + (* Tacred.evaluable_of_global_reference (Global.env ()) *) match r with - GlobRef.ConstRef sp -> EvalConstRef sp - | GlobRef.VarRef id -> EvalVarRef id - | _ -> assert false;; + | GlobRef.ConstRef sp -> EvalConstRef sp + | GlobRef.VarRef id -> EvalVarRef id + | _ -> assert false -let list_rewrite (rev:bool) (eqs: (EConstr.constr*bool) list) = +let list_rewrite (rev : bool) (eqs : (EConstr.constr * bool) list) = tclREPEAT (List.fold_right - (fun (eq,b) i -> tclORELSE (Proofview.V82.of_tactic ((if b then Equality.rewriteLR else Equality.rewriteRL) eq)) i) - (if rev then (List.rev eqs) else eqs) (tclFAIL 0 (mt())));; + (fun (eq, b) i -> + tclORELSE + (Proofview.V82.of_tactic + ((if b then Equality.rewriteLR else Equality.rewriteRL) eq)) + i) + (if rev then List.rev eqs else eqs) + (tclFAIL 0 (mt ()))) let decompose_lam_n sigma n = - if n < 0 then CErrors.user_err Pp.(str "decompose_lam_n: integer parameter must be positive"); + if n < 0 then + CErrors.user_err + Pp.(str "decompose_lam_n: integer parameter must be positive"); let rec lamdec_rec l n c = - if Int.equal n 0 then l,c - else match EConstr.kind sigma c with - | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) (n-1) c - | Cast (c,_,_) -> lamdec_rec l n c - | _ -> CErrors.user_err Pp.(str "decompose_lam_n: not enough abstractions") + if Int.equal n 0 then (l, c) + else + match EConstr.kind sigma c with + | Lambda (x, t, c) -> lamdec_rec ((x, t) :: l) (n - 1) c + | Cast (c, _, _) -> lamdec_rec l n c + | _ -> + CErrors.user_err Pp.(str "decompose_lam_n: not enough abstractions") in lamdec_rec [] n let lamn n env b = let open EConstr in let rec lamrec = function - | (0, env, b) -> b - | (n, ((v,t)::l), b) -> lamrec (n-1, l, mkLambda (v,t,b)) + | 0, env, b -> b + | n, (v, t) :: l, b -> lamrec (n - 1, l, mkLambda (v, t, b)) | _ -> assert false in - lamrec (n,env,b) + lamrec (n, env, b) (* compose_lam [xn:Tn;..;x1:T1] b = [x1:T1]..[xn:Tn]b *) let compose_lam l b = lamn (List.length l) l b @@ -494,19 +468,16 @@ let compose_lam l b = lamn (List.length l) l b let prodn n env b = let open EConstr in let rec prodrec = function - | (0, env, b) -> b - | (n, ((v,t)::l), b) -> prodrec (n-1, l, mkProd (v,t,b)) + | 0, env, b -> b + | n, (v, t) :: l, b -> prodrec (n - 1, l, mkProd (v, t, b)) | _ -> assert false in - prodrec (n,env,b) + prodrec (n, env, b) (* compose_prod [xn:Tn;..;x1:T1] b = (x1:T1)..(xn:Tn)b *) let compose_prod l b = prodn (List.length l) l b -type tcc_lemma_value = - | Undefined - | Value of constr - | Not_needed +type tcc_lemma_value = Undefined | Value of constr | Not_needed (* We only "purify" on exceptions. XXX: What is this doing here? *) let funind_purify f x = @@ -519,4 +490,4 @@ let funind_purify f x = let tac_type_of g c = let sigma, t = Tacmach.pf_type_of g c in - {g with Evd.sigma}, t + ({g with Evd.sigma}, t) diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index bd8b34088b..396db55458 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -8,30 +8,27 @@ val mk_rel_id : Id.t -> Id.t val mk_correct_id : Id.t -> Id.t val mk_complete_id : Id.t -> Id.t val mk_equation_id : Id.t -> Id.t - val fresh_id : Id.t list -> string -> Id.t val fresh_name : Id.t list -> string -> Name.t val get_name : Id.t list -> ?default:string -> Name.t -> Name.t - val array_get_start : 'a array -> 'a array - val locate_ind : Libnames.qualid -> inductive val locate_constant : Libnames.qualid -> Constant.t -val locate_with_msg : - Pp.t -> (Libnames.qualid -> 'a) -> - Libnames.qualid -> 'a - +val locate_with_msg : Pp.t -> (Libnames.qualid -> 'a) -> Libnames.qualid -> 'a val filter_map : ('a -> bool) -> ('a -> 'b) -> 'a list -> 'b list -val list_union_eq : - ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list -val list_add_set_eq : - ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list +val list_union_eq : ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list +val list_add_set_eq : ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list -val chop_rlambda_n : int -> Glob_term.glob_constr -> - (Name.t*Glob_term.glob_constr*Glob_term.glob_constr option) list * Glob_term.glob_constr +val chop_rlambda_n : + int + -> Glob_term.glob_constr + -> (Name.t * Glob_term.glob_constr * Glob_term.glob_constr option) list + * Glob_term.glob_constr -val chop_rprod_n : int -> Glob_term.glob_constr -> - (Name.t*Glob_term.glob_constr) list * Glob_term.glob_constr +val chop_rprod_n : + int + -> Glob_term.glob_constr + -> (Name.t * Glob_term.glob_constr) list * Glob_term.glob_constr val eq : EConstr.constr Lazy.t val refl_equal : EConstr.constr Lazy.t @@ -45,44 +42,41 @@ val make_eq : unit -> EConstr.constr *) val with_full_print : ('a -> 'b) -> 'a -> 'b - (*****************) type function_info = - { - function_constant : Constant.t; - graph_ind : inductive; - equation_lemma : Constant.t option; - correctness_lemma : Constant.t option; - completeness_lemma : Constant.t option; - rect_lemma : Constant.t option; - rec_lemma : Constant.t option; - prop_lemma : Constant.t option; - sprop_lemma : Constant.t option; - is_general : bool; - } + { function_constant : Constant.t + ; graph_ind : inductive + ; equation_lemma : Constant.t option + ; correctness_lemma : Constant.t option + ; completeness_lemma : Constant.t option + ; rect_lemma : Constant.t option + ; rec_lemma : Constant.t option + ; prop_lemma : Constant.t option + ; sprop_lemma : Constant.t option + ; is_general : bool } val find_Function_infos : Constant.t -> function_info option val find_Function_of_graph : inductive -> function_info option + (* WARNING: To be used just after the graph definition !!! *) val add_Function : bool -> Constant.t -> unit val update_Function : function_info -> unit (** debugging *) val pr_info : Environ.env -> Evd.evar_map -> function_info -> Pp.t + val pr_table : Environ.env -> Evd.evar_map -> Pp.t -val observe_tac - : (Environ.env -> Evd.evar_map -> Pp.t) - -> Tacmach.tactic -> Tacmach.tactic +val observe_tac : + (Environ.env -> Evd.evar_map -> Pp.t) -> Tacmach.tactic -> Tacmach.tactic module New : sig - - val observe_tac - : header:Pp.t + val observe_tac : + header:Pp.t -> (Environ.env -> Evd.evar_map -> Pp.t) - -> unit Proofview.tactic -> unit Proofview.tactic - + -> unit Proofview.tactic + -> unit Proofview.tactic end (* val function_debug : bool ref *) @@ -96,28 +90,35 @@ exception Defining_principle of exn exception ToShow of exn val is_strict_tcc : unit -> bool - -val h_intros: Names.Id.t list -> Tacmach.tactic -val h_id : Names.Id.t -val hrec_id : Names.Id.t -val acc_inv_id : EConstr.constr Util.delayed +val h_intros : Names.Id.t list -> Tacmach.tactic +val h_id : Names.Id.t +val hrec_id : Names.Id.t +val acc_inv_id : EConstr.constr Util.delayed val ltof_ref : GlobRef.t Util.delayed val well_founded_ltof : EConstr.constr Util.delayed val acc_rel : EConstr.constr Util.delayed val well_founded : EConstr.constr Util.delayed -val evaluable_of_global_reference : GlobRef.t -> Names.evaluable_global_reference -val list_rewrite : bool -> (EConstr.constr*bool) list -> Tacmach.tactic -val decompose_lam_n : Evd.evar_map -> int -> EConstr.t -> - (Names.Name.t Context.binder_annot * EConstr.t) list * EConstr.t -val compose_lam : (Names.Name.t Context.binder_annot * EConstr.t) list -> EConstr.t -> EConstr.t -val compose_prod : (Names.Name.t Context.binder_annot * EConstr.t) list -> EConstr.t -> EConstr.t +val evaluable_of_global_reference : + GlobRef.t -> Names.evaluable_global_reference + +val list_rewrite : bool -> (EConstr.constr * bool) list -> Tacmach.tactic + +val decompose_lam_n : + Evd.evar_map + -> int + -> EConstr.t + -> (Names.Name.t Context.binder_annot * EConstr.t) list * EConstr.t + +val compose_lam : + (Names.Name.t Context.binder_annot * EConstr.t) list -> EConstr.t -> EConstr.t + +val compose_prod : + (Names.Name.t Context.binder_annot * EConstr.t) list -> EConstr.t -> EConstr.t -type tcc_lemma_value = - | Undefined - | Value of Constr.t - | Not_needed +type tcc_lemma_value = Undefined | Value of Constr.t | Not_needed -val funind_purify : ('a -> 'b) -> ('a -> 'b) +val funind_purify : ('a -> 'b) -> 'a -> 'b -val tac_type_of : Goal.goal Evd.sigma -> EConstr.constr -> Goal.goal Evd.sigma * EConstr.types +val tac_type_of : + Goal.goal Evd.sigma -> EConstr.constr -> Goal.goal Evd.sigma * EConstr.types diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 44d2cb4a3d..5d631aac84 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -15,7 +15,6 @@ open EConstr open Tacmach.New open Tactics open Tacticals.New - open Indfun_common (***********************************************) @@ -26,36 +25,40 @@ open Indfun_common if the type of hypothesis has not this form or if we cannot find the completeness lemma then we do nothing *) -let revert_graph kn post_tac hid = Proofview.Goal.enter (fun gl -> - let sigma = project gl in - let typ = pf_get_hyp_typ hid gl in - match EConstr.kind sigma typ with - | App(i,args) when isInd sigma i -> - let ((kn',num) as ind'),u = destInd sigma i in - if MutInd.equal kn kn' - then (* We have generated a graph hypothesis so that we must change it if we can *) - let info = match find_Function_of_graph ind' with - | Some info -> info - | None -> - (* The graphs are mutually recursive but we cannot find one of them !*) - CErrors.anomaly (Pp.str "Cannot retrieve infos about a mutual block.") - in - (* if we can find a completeness lemma for this function - then we can come back to the functional form. If not, we do nothing - *) - match info.completeness_lemma with - | None -> tclIDTAC - | Some f_complete -> - let f_args,res = Array.chop (Array.length args - 1) args in - tclTHENLIST - [ generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])] - ; clear [hid] - ; Simple.intro hid - ; post_tac hid - ] - else tclIDTAC - | _ -> tclIDTAC - ) +let revert_graph kn post_tac hid = + Proofview.Goal.enter (fun gl -> + let sigma = project gl in + let typ = pf_get_hyp_typ hid gl in + match EConstr.kind sigma typ with + | App (i, args) when isInd sigma i -> + let ((kn', num) as ind'), u = destInd sigma i in + if MutInd.equal kn kn' then + (* We have generated a graph hypothesis so that we must change it if we can *) + let info = + match find_Function_of_graph ind' with + | Some info -> info + | None -> + (* The graphs are mutually recursive but we cannot find one of them !*) + CErrors.anomaly + (Pp.str "Cannot retrieve infos about a mutual block.") + in + (* if we can find a completeness lemma for this function + then we can come back to the functional form. If not, we do nothing + *) + match info.completeness_lemma with + | None -> tclIDTAC + | Some f_complete -> + let f_args, res = Array.chop (Array.length args - 1) args in + tclTHENLIST + [ generalize + [ applist + ( mkConst f_complete + , Array.to_list f_args @ [res.(0); mkVar hid] ) ] + ; clear [hid] + ; Simple.intro hid + ; post_tac hid ] + else tclIDTAC + | _ -> tclIDTAC) (* [functional_inversion hid fconst f_correct ] is the functional version of [inversion] @@ -74,52 +77,55 @@ let revert_graph kn post_tac hid = Proofview.Goal.enter (fun gl -> \end{enumerate} *) -let functional_inversion kn hid fconst f_correct = Proofview.Goal.enter (fun gl -> - let old_ids = List.fold_right Id.Set.add (pf_ids_of_hyps gl) Id.Set.empty in - let sigma = project gl in - let type_of_h = pf_get_hyp_typ hid gl in - match EConstr.kind sigma type_of_h with - | App(eq,args) when EConstr.eq_constr sigma eq (make_eq ()) -> - let pre_tac,f_args,res = - match EConstr.kind sigma args.(1),EConstr.kind sigma args.(2) with - | App(f,f_args),_ when EConstr.eq_constr sigma f fconst -> - ((fun hid -> intros_symmetry (Locusops.onHyp hid))),f_args,args.(2) - |_,App(f,f_args) when EConstr.eq_constr sigma f fconst -> - ((fun hid -> tclIDTAC),f_args,args.(1)) - | _ -> (fun hid -> tclFAIL 1 Pp.(mt ())),[||],args.(2) - in - tclTHENLIST - [ pre_tac hid - ; generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])] - ; clear [hid] - ; Simple.intro hid - ; Inv.inv Inv.FullInversion None (Tactypes.NamedHyp hid) - ; Proofview.Goal.enter (fun gl -> - let new_ids = List.filter (fun id -> not (Id.Set.mem id old_ids)) (pf_ids_of_hyps gl) in - tclMAP (revert_graph kn pre_tac) (hid::new_ids) - ) - ] - | _ -> tclFAIL 1 Pp.(mt ()) - ) +let functional_inversion kn hid fconst f_correct = + Proofview.Goal.enter (fun gl -> + let old_ids = + List.fold_right Id.Set.add (pf_ids_of_hyps gl) Id.Set.empty + in + let sigma = project gl in + let type_of_h = pf_get_hyp_typ hid gl in + match EConstr.kind sigma type_of_h with + | App (eq, args) when EConstr.eq_constr sigma eq (make_eq ()) -> + let pre_tac, f_args, res = + match (EConstr.kind sigma args.(1), EConstr.kind sigma args.(2)) with + | App (f, f_args), _ when EConstr.eq_constr sigma f fconst -> + ((fun hid -> intros_symmetry (Locusops.onHyp hid)), f_args, args.(2)) + | _, App (f, f_args) when EConstr.eq_constr sigma f fconst -> + ((fun hid -> tclIDTAC), f_args, args.(1)) + | _ -> ((fun hid -> tclFAIL 1 Pp.(mt ())), [||], args.(2)) + in + tclTHENLIST + [ pre_tac hid + ; generalize + [applist (f_correct, Array.to_list f_args @ [res; mkVar hid])] + ; clear [hid] + ; Simple.intro hid + ; Inv.inv Inv.FullInversion None (Tactypes.NamedHyp hid) + ; Proofview.Goal.enter (fun gl -> + let new_ids = + List.filter + (fun id -> not (Id.Set.mem id old_ids)) + (pf_ids_of_hyps gl) + in + tclMAP (revert_graph kn pre_tac) (hid :: new_ids)) ] + | _ -> tclFAIL 1 Pp.(mt ())) -let invfun qhyp f = +let invfun qhyp f = let f = match f with | GlobRef.ConstRef f -> f - | _ -> - CErrors.user_err Pp.(str "Not a function") + | _ -> CErrors.user_err Pp.(str "Not a function") in match find_Function_infos f with - | None -> - CErrors.user_err (Pp.str "No graph found") - | Some finfos -> + | None -> CErrors.user_err (Pp.str "No graph found") + | Some finfos -> ( match finfos.correctness_lemma with - | None -> - CErrors.user_err (Pp.str "Cannot use equivalence with graph!") + | None -> CErrors.user_err (Pp.str "Cannot use equivalence with graph!") | Some f_correct -> - let f_correct = mkConst f_correct - and kn = fst finfos.graph_ind in - Tactics.try_intros_until (fun hid -> functional_inversion kn hid (mkConst f) f_correct) qhyp + let f_correct = mkConst f_correct and kn = fst finfos.graph_ind in + Tactics.try_intros_until + (fun hid -> functional_inversion kn hid (mkConst f) f_correct) + qhyp ) let invfun qhyp f = let exception NoFunction in @@ -128,41 +134,55 @@ let invfun qhyp f = | None -> let tac_action hid gl = let sigma = project gl in - let hyp_typ = pf_get_hyp_typ hid gl in + let hyp_typ = pf_get_hyp_typ hid gl in match EConstr.kind sigma hyp_typ with - | App(eq,args) when EConstr.eq_constr sigma eq (make_eq ()) -> - begin - let f1,_ = decompose_app sigma args.(1) in - try - if not (isConst sigma f1) then raise NoFunction; - let finfos = Option.get (find_Function_infos (fst (destConst sigma f1))) in - let f_correct = mkConst(Option.get finfos.correctness_lemma) - and kn = fst finfos.graph_ind - in - functional_inversion kn hid f1 f_correct - with - | NoFunction | Option.IsNone -> - let f2,_ = decompose_app sigma args.(2) in - if isConst sigma f2 then - match find_Function_infos (fst (destConst sigma f2)) with + | App (eq, args) when EConstr.eq_constr sigma eq (make_eq ()) -> ( + let f1, _ = decompose_app sigma args.(1) in + try + if not (isConst sigma f1) then raise NoFunction; + let finfos = + Option.get (find_Function_infos (fst (destConst sigma f1))) + in + let f_correct = mkConst (Option.get finfos.correctness_lemma) + and kn = fst finfos.graph_ind in + functional_inversion kn hid f1 f_correct + with NoFunction | Option.IsNone -> + let f2, _ = decompose_app sigma args.(2) in + if isConst sigma f2 then + match find_Function_infos (fst (destConst sigma f2)) with + | None -> + if do_observe () then + CErrors.user_err + (Pp.str "No graph found for any side of equality") + else + CErrors.user_err + Pp.( + str "Cannot find inversion information for hypothesis " + ++ Ppconstr.pr_id hid) + | Some finfos -> ( + match finfos.correctness_lemma with | None -> - if do_observe () - then CErrors.user_err (Pp.str "No graph found for any side of equality") - else CErrors.user_err Pp.(str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) - | Some finfos -> - match finfos.correctness_lemma with - | None -> - if do_observe () - then CErrors.user_err (Pp.str "Cannot use equivalence with graph for any side of the equality") - else CErrors.user_err Pp.(str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) - | Some f_correct -> - let f_correct = mkConst f_correct - and kn = fst finfos.graph_ind - in - functional_inversion kn hid f2 f_correct - else (* NoFunction *) - CErrors.user_err Pp.(str "Hypothesis " ++ Ppconstr.pr_id hid ++ str " must contain at least one Function") - end - | _ -> CErrors.user_err Pp.(Ppconstr.pr_id hid ++ str " must be an equality ") + if do_observe () then + CErrors.user_err + (Pp.str + "Cannot use equivalence with graph for any side of the \ + equality") + else + CErrors.user_err + Pp.( + str "Cannot find inversion information for hypothesis " + ++ Ppconstr.pr_id hid) + | Some f_correct -> + let f_correct = mkConst f_correct + and kn = fst finfos.graph_ind in + functional_inversion kn hid f2 f_correct ) + else + (* NoFunction *) + CErrors.user_err + Pp.( + str "Hypothesis " ++ Ppconstr.pr_id hid + ++ str " must contain at least one Function") ) + | _ -> + CErrors.user_err Pp.(Ppconstr.pr_id hid ++ str " must be an equality ") in try_intros_until (tac_action %> Proofview.Goal.enter) qhyp diff --git a/plugins/funind/invfun.mli b/plugins/funind/invfun.mli index 41dbe1437c..a117df32df 100644 --- a/plugins/funind/invfun.mli +++ b/plugins/funind/invfun.mli @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -val invfun - : Tactypes.quantified_hypothesis +val invfun : + Tactypes.quantified_hypothesis -> Names.GlobRef.t option -> unit Proofview.tactic diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 19a762d33d..ffb9a7e69b 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -8,9 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) - module CVars = Vars - open Constr open Context open EConstr @@ -29,7 +27,6 @@ open Tacticals open Tacmach open Tactics open Nametab -open Declare open Tacred open Glob_term open Pretyping @@ -37,58 +34,58 @@ open Termops open Constrintern open Tactypes open Genredexpr - open Equality open Auto open Eauto - open Indfun_common open Context.Rel.Declaration (* Ugly things which should not be here *) -let coq_constant s = EConstr.of_constr @@ UnivGen.constr_of_monomorphic_global @@ - Coqlib.lib_ref s +let coq_constant s = + EConstr.of_constr @@ UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref s let coq_init_constant s = - EConstr.of_constr(UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref s) -;; + EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref s) let find_reference sl s = let dp = Names.DirPath.make (List.rev_map Id.of_string sl) in locate (make_qualid dp (Id.of_string s)) let declare_fun name kind ?univs value = - let ce = definition_entry ?univs value (*FIXME *) in - GlobRef.ConstRef(declare_constant ~name ~kind (DefinitionEntry ce)) + let ce = Declare.definition_entry ?univs value (*FIXME *) in + GlobRef.ConstRef + (Declare.declare_constant ~name ~kind (Declare.DefinitionEntry ce)) let defined lemma = - Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Transparent ~idopt:None + Lemmas.save_lemma_proved ~lemma ~opaque:Declare.Transparent ~idopt:None let def_of_const t = - match (Constr.kind t) with - Const sp -> - (try (match constant_opt_value_in (Global.env ()) sp with - | Some c -> c - | _ -> raise Not_found) - with Not_found -> - anomaly (str "Cannot find definition of constant " ++ - (Id.print (Label.to_id (Constant.label (fst sp)))) ++ str ".") - ) - |_ -> assert false + match Constr.kind t with + | Const sp -> ( + try + match constant_opt_value_in (Global.env ()) sp with + | Some c -> c + | _ -> raise Not_found + with Not_found -> + anomaly + ( str "Cannot find definition of constant " + ++ Id.print (Label.to_id (Constant.label (fst sp))) + ++ str "." ) ) + | _ -> assert false let type_of_const sigma t = - match (EConstr.kind sigma t) with - | Const (sp, u) -> - let u = EInstance.kind sigma u in - (* FIXME discarding universe constraints *) - Typeops.type_of_constant_in (Global.env()) (sp, u) - |_ -> assert false + match EConstr.kind sigma t with + | Const (sp, u) -> + let u = EInstance.kind sigma u in + (* FIXME discarding universe constraints *) + Typeops.type_of_constant_in (Global.env ()) (sp, u) + | _ -> assert false let constant sl s = UnivGen.constr_of_monomorphic_global (find_reference sl s) let const_of_ref = function - GlobRef.ConstRef kn -> kn + | GlobRef.ConstRef kn -> kn | _ -> anomaly (Pp.str "ConstRef expected.") (* Generic values *) @@ -96,16 +93,16 @@ let pf_get_new_ids idl g = let ids = pf_ids_of_hyps g in let ids = Id.Set.of_list ids in List.fold_right - (fun id acc -> next_global_ident_away id (Id.Set.union (Id.Set.of_list acc) ids)::acc) - idl - [] + (fun id acc -> + next_global_ident_away id (Id.Set.union (Id.Set.of_list acc) ids) :: acc) + idl [] let next_ident_away_in_goal ids avoid = next_ident_away_in_goal ids (Id.Set.of_list avoid) let compute_renamed_type gls id = - rename_bound_vars_as_displayed (project gls) (*no avoid*) Id.Set.empty (*no rels*) [] - (pf_get_hyp_typ gls id) + rename_bound_vars_as_displayed (project gls) (*no avoid*) Id.Set.empty + (*no rels*) [] (pf_get_hyp_typ gls id) let h'_id = Id.of_string "h'" let teq_id = Id.of_string "teq" @@ -115,112 +112,140 @@ let k_id = Id.of_string "k" let v_id = Id.of_string "v" let def_id = Id.of_string "def" let p_id = Id.of_string "p" -let rec_res_id = Id.of_string "rec_res";; -let lt = function () -> (coq_init_constant "num.nat.lt") +let rec_res_id = Id.of_string "rec_res" +let lt = function () -> coq_init_constant "num.nat.lt" let le = function () -> Coqlib.lib_ref "num.nat.le" +let ex = function () -> coq_init_constant "core.ex.type" +let nat = function () -> coq_init_constant "num.nat.type" -let ex = function () -> (coq_init_constant "core.ex.type") -let nat = function () -> (coq_init_constant "num.nat.type") let iter_ref () = try find_reference ["Recdef"] "iter" with Not_found -> user_err Pp.(str "module Recdef not loaded") -let iter_rd = function () -> (constr_of_monomorphic_global (delayed_force iter_ref)) -let eq = function () -> (coq_init_constant "core.eq.type") -let le_lt_SS = function () -> (constant ["Recdef"] "le_lt_SS") -let le_lt_n_Sm = function () -> (coq_constant "num.nat.le_lt_n_Sm") -let le_trans = function () -> (coq_constant "num.nat.le_trans") -let le_lt_trans = function () -> (coq_constant "num.nat.le_lt_trans") -let lt_S_n = function () -> (coq_constant "num.nat.lt_S_n") -let le_n = function () -> (coq_init_constant "num.nat.le_n") -let coq_sig_ref = function () -> (find_reference ["Coq";"Init";"Specif"] "sig") -let coq_O = function () -> (coq_init_constant "num.nat.O") -let coq_S = function () -> (coq_init_constant"num.nat.S") -let lt_n_O = function () -> (coq_constant "num.nat.nlt_0_r") -let max_ref = function () -> (find_reference ["Recdef"] "max") -let max_constr = function () -> EConstr.of_constr (constr_of_monomorphic_global (delayed_force max_ref)) - -let f_S t = mkApp(delayed_force coq_S, [|t|]);; + +let iter_rd = function + | () -> constr_of_monomorphic_global (delayed_force iter_ref) + +let eq = function () -> coq_init_constant "core.eq.type" +let le_lt_SS = function () -> constant ["Recdef"] "le_lt_SS" +let le_lt_n_Sm = function () -> coq_constant "num.nat.le_lt_n_Sm" +let le_trans = function () -> coq_constant "num.nat.le_trans" +let le_lt_trans = function () -> coq_constant "num.nat.le_lt_trans" +let lt_S_n = function () -> coq_constant "num.nat.lt_S_n" +let le_n = function () -> coq_init_constant "num.nat.le_n" + +let coq_sig_ref = function + | () -> find_reference ["Coq"; "Init"; "Specif"] "sig" + +let coq_O = function () -> coq_init_constant "num.nat.O" +let coq_S = function () -> coq_init_constant "num.nat.S" +let lt_n_O = function () -> coq_constant "num.nat.nlt_0_r" +let max_ref = function () -> find_reference ["Recdef"] "max" + +let max_constr = function + | () -> + EConstr.of_constr (constr_of_monomorphic_global (delayed_force max_ref)) + +let f_S t = mkApp (delayed_force coq_S, [|t|]) let rec n_x_id ids n = if Int.equal n 0 then [] - else let x = next_ident_away_in_goal x_id ids in - x::n_x_id (x::ids) (n-1);; - + else + let x = next_ident_away_in_goal x_id ids in + x :: n_x_id (x :: ids) (n - 1) let simpl_iter clause = reduce (Lazy - {rBeta=true;rMatch=true;rFix=true;rCofix=true;rZeta=true;rDelta=false; - rConst = [ EvalConstRef (const_of_ref (delayed_force iter_ref))]}) + { rBeta = true + ; rMatch = true + ; rFix = true + ; rCofix = true + ; rZeta = true + ; rDelta = false + ; rConst = [EvalConstRef (const_of_ref (delayed_force iter_ref))] }) clause (* Others ugly things ... *) -let (value_f: Constr.t list -> GlobRef.t -> Constr.t) = +let (value_f : Constr.t list -> GlobRef.t -> Constr.t) = let open Term in let open Constr in fun al fterm -> let rev_x_id_l = - ( - List.fold_left - (fun x_id_l _ -> - let x_id = next_ident_away_in_goal x_id x_id_l in - x_id::x_id_l - ) - [] - al - ) + List.fold_left + (fun x_id_l _ -> + let x_id = next_ident_away_in_goal x_id x_id_l in + x_id :: x_id_l) + [] al in - let context = List.map - (fun (x, c) -> LocalAssum (make_annot (Name x) Sorts.Relevant, c)) (List.combine rev_x_id_l (List.rev al)) + let context = + List.map + (fun (x, c) -> LocalAssum (make_annot (Name x) Sorts.Relevant, c)) + (List.combine rev_x_id_l (List.rev al)) in let env = Environ.push_rel_context context (Global.env ()) in let glob_body = - DAst.make @@ - GCases - (RegularStyle,None, - [DAst.make @@ GApp(DAst.make @@ GRef(fterm,None), List.rev_map (fun x_id -> DAst.make @@ GVar x_id) rev_x_id_l), - (Anonymous,None)], - [CAst.make ([v_id], [DAst.make @@ PatCstr ((destIndRef (delayed_force coq_sig_ref),1), - [DAst.make @@ PatVar(Name v_id); DAst.make @@ PatVar Anonymous], - Anonymous)], - DAst.make @@ GVar v_id)]) + DAst.make + @@ GCases + ( RegularStyle + , None + , [ ( DAst.make + @@ GApp + ( DAst.make @@ GRef (fterm, None) + , List.rev_map + (fun x_id -> DAst.make @@ GVar x_id) + rev_x_id_l ) + , (Anonymous, None) ) ] + , [ CAst.make + ( [v_id] + , [ DAst.make + @@ PatCstr + ( (destIndRef (delayed_force coq_sig_ref), 1) + , [ DAst.make @@ PatVar (Name v_id) + ; DAst.make @@ PatVar Anonymous ] + , Anonymous ) ] + , DAst.make @@ GVar v_id ) ] ) in - let body = fst (understand env (Evd.from_env env) glob_body)(*FIXME*) in + let body = fst (understand env (Evd.from_env env) glob_body) (*FIXME*) in let body = EConstr.Unsafe.to_constr body in it_mkLambda_or_LetIn body context -let (declare_f : Id.t -> Decls.logical_kind -> Constr.t list -> GlobRef.t -> GlobRef.t) = - fun f_id kind input_type fterm_ref -> - declare_fun f_id kind (value_f input_type fterm_ref);; +let (declare_f : + Id.t -> Decls.logical_kind -> Constr.t list -> GlobRef.t -> GlobRef.t) = + fun f_id kind input_type fterm_ref -> + declare_fun f_id kind (value_f input_type fterm_ref) let observe_tclTHENLIST s tacl = - if do_observe () - then + if do_observe () then let rec aux n = function | [] -> tclIDTAC - | [tac] -> observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) tac - | tac::tacl -> observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) (tclTHEN tac (aux (succ n) tacl)) + | [tac] -> + observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) tac + | tac :: tacl -> + observe_tac + (fun env sigma -> s env sigma ++ spc () ++ int n) + (tclTHEN tac (aux (succ n) tacl)) in aux 0 tacl else tclTHENLIST tacl module New = struct - open Tacticals.New - let observe_tac = New.observe_tac ~header:(Pp.mt()) + let observe_tac = New.observe_tac ~header:(Pp.mt ()) let observe_tclTHENLIST s tacl = - if do_observe () - then - let rec aux n = function - | [] -> tclIDTAC - | [tac] -> observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) tac - | tac::tacl -> observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) (tclTHEN tac (aux (succ n) tacl)) - in - aux 0 tacl - else tclTHENLIST tacl - + if do_observe () then + let rec aux n = function + | [] -> tclIDTAC + | [tac] -> + observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) tac + | tac :: tacl -> + observe_tac + (fun env sigma -> s env sigma ++ spc () ++ int n) + (tclTHEN tac (aux (succ n) tacl)) + in + aux 0 tacl + else tclTHENLIST tacl end (* Conclusion tactics *) @@ -234,23 +259,25 @@ let tclUSER tac is_mes l = | None -> tclIDTAC | Some l -> tclMAP (fun id -> tclTRY (clear [id])) (List.rev l) in - New.observe_tclTHENLIST (fun _ _ -> str "tclUSER1") - [ clear_tac; - if is_mes - then - New.observe_tclTHENLIST (fun _ _ -> str "tclUSER2") - [ unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference - (delayed_force Indfun_common.ltof_ref))] - ; tac - ] - else tac - ] + New.observe_tclTHENLIST + (fun _ _ -> str "tclUSER1") + [ clear_tac + ; ( if is_mes then + New.observe_tclTHENLIST + (fun _ _ -> str "tclUSER2") + [ unfold_in_concl + [ ( Locus.AllOccurrences + , evaluable_of_global_reference + (delayed_force Indfun_common.ltof_ref) ) ] + ; tac ] + else tac ) ] let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = - if is_mes - then Tacticals.New.tclCOMPLETE (Simple.apply (delayed_force well_founded_ltof)) - else (* tclTHEN (Simple.apply (delayed_force acc_intro_generator_function) ) *) - (tclUSER concl_tac is_mes names_to_suppress) + if is_mes then + Tacticals.New.tclCOMPLETE (Simple.apply (delayed_force well_founded_ltof)) + else + (* tclTHEN (Simple.apply (delayed_force acc_intro_generator_function) ) *) + tclUSER concl_tac is_mes names_to_suppress (* Traveling term. Both definitions of [f_terminate] and [f_equation] use the same generic @@ -263,210 +290,243 @@ let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = let check_not_nested env sigma forbidden e = let rec check_not_nested e = match EConstr.kind sigma e with - | Rel _ -> () - | Int _ | Float _ -> () - | Var x -> - if Id.List.mem x forbidden - then user_err ~hdr:"Recdef.check_not_nested" - (str "check_not_nested: failure " ++ Id.print x) - | Meta _ | Evar _ | Sort _ -> () - | Cast(e,_,t) -> check_not_nested e;check_not_nested t - | Prod(_,t,b) -> check_not_nested t;check_not_nested b - | Lambda(_,t,b) -> check_not_nested t;check_not_nested b - | LetIn(_,v,t,b) -> check_not_nested t;check_not_nested b;check_not_nested v - | App(f,l) -> check_not_nested f;Array.iter check_not_nested l - | Proj (p,c) -> check_not_nested c - | Const _ -> () - | Ind _ -> () - | Construct _ -> () - | Case(_,t,e,a) -> - check_not_nested t;check_not_nested e;Array.iter check_not_nested a - | Fix _ -> user_err Pp.(str "check_not_nested : Fix") - | CoFix _ -> user_err Pp.(str "check_not_nested : Fix") + | Rel _ -> () + | Int _ | Float _ -> () + | Var x -> + if Id.List.mem x forbidden then + user_err ~hdr:"Recdef.check_not_nested" + (str "check_not_nested: failure " ++ Id.print x) + | Meta _ | Evar _ | Sort _ -> () + | Cast (e, _, t) -> check_not_nested e; check_not_nested t + | Prod (_, t, b) -> check_not_nested t; check_not_nested b + | Lambda (_, t, b) -> check_not_nested t; check_not_nested b + | LetIn (_, v, t, b) -> + check_not_nested t; check_not_nested b; check_not_nested v + | App (f, l) -> + check_not_nested f; + Array.iter check_not_nested l + | Proj (p, c) -> check_not_nested c + | Const _ -> () + | Ind _ -> () + | Construct _ -> () + | Case (_, t, e, a) -> + check_not_nested t; + check_not_nested e; + Array.iter check_not_nested a + | Fix _ -> user_err Pp.(str "check_not_nested : Fix") + | CoFix _ -> user_err Pp.(str "check_not_nested : Fix") in - try - check_not_nested e - with UserError(_,p) -> - user_err ~hdr:"_" (str "on expr : " ++ Printer.pr_leconstr_env env sigma e ++ str " " ++ p) + try check_not_nested e + with UserError (_, p) -> + user_err ~hdr:"_" + (str "on expr : " ++ Printer.pr_leconstr_env env sigma e ++ str " " ++ p) (* ['a info] contains the local information for traveling *) type 'a infos = - { nb_arg : int; (* function number of arguments *) - concl_tac : unit Proofview.tactic; (* final tactic to finish proofs *) - rec_arg_id : Id.t; (*name of the declared recursive argument *) - is_mes : bool; (* type of recursion *) - ih : Id.t; (* induction hypothesis name *) - f_id : Id.t; (* function name *) - f_constr : constr; (* function term *) - f_terminate : constr; (* termination proof term *) - func : GlobRef.t; (* functional reference *) - info : 'a; - is_main_branch : bool; (* on the main branch or on a matched expression *) - is_final : bool; (* final first order term or not *) - values_and_bounds : (Id.t*Id.t) list; - eqs : Id.t list; - forbidden_ids : Id.t list; - acc_inv : constr lazy_t; - acc_id : Id.t; - args_assoc : ((constr list)*constr) list; - } - - -type ('a,'b) journey_info_tac = - 'a -> (* the arguments of the constructor *) - 'b infos -> (* infos of the caller *) - ('b infos -> tactic) -> (* the continuation tactic of the caller *) - 'b infos -> (* argument of the tactic *) - tactic + { nb_arg : int + ; (* function number of arguments *) + concl_tac : unit Proofview.tactic + ; (* final tactic to finish proofs *) + rec_arg_id : Id.t + ; (*name of the declared recursive argument *) + is_mes : bool + ; (* type of recursion *) + ih : Id.t + ; (* induction hypothesis name *) + f_id : Id.t + ; (* function name *) + f_constr : constr + ; (* function term *) + f_terminate : constr + ; (* termination proof term *) + func : GlobRef.t + ; (* functional reference *) + info : 'a + ; is_main_branch : bool + ; (* on the main branch or on a matched expression *) + is_final : bool + ; (* final first order term or not *) + values_and_bounds : (Id.t * Id.t) list + ; eqs : Id.t list + ; forbidden_ids : Id.t list + ; acc_inv : constr lazy_t + ; acc_id : Id.t + ; args_assoc : (constr list * constr) list } + +type ('a, 'b) journey_info_tac = + 'a + -> (* the arguments of the constructor *) + 'b infos + -> (* infos of the caller *) + ('b infos -> tactic) + -> (* the continuation tactic of the caller *) + 'b infos + -> (* argument of the tactic *) + tactic (* journey_info : specifies the actions to do on the different term constructors during the traveling of the term *) type journey_info = - { letiN : ((Name.t*constr*types*constr),constr) journey_info_tac; - lambdA : ((Name.t*types*constr),constr) journey_info_tac; - casE : ((constr infos -> tactic) -> constr infos -> tactic) -> - ((case_info * constr * constr * constr array),constr) journey_info_tac; - otherS : (unit,constr) journey_info_tac; - apP : (constr*(constr list),constr) journey_info_tac; - app_reC : (constr*(constr list),constr) journey_info_tac; - message : string - } - - + { letiN : (Name.t * constr * types * constr, constr) journey_info_tac + ; lambdA : (Name.t * types * constr, constr) journey_info_tac + ; casE : + ((constr infos -> tactic) -> constr infos -> tactic) + -> (case_info * constr * constr * constr array, constr) journey_info_tac + ; otherS : (unit, constr) journey_info_tac + ; apP : (constr * constr list, constr) journey_info_tac + ; app_reC : (constr * constr list, constr) journey_info_tac + ; message : string } let add_vars sigma forbidden e = let rec aux forbidden e = - match EConstr.kind sigma e with - | Var x -> x::forbidden + match EConstr.kind sigma e with + | Var x -> x :: forbidden | _ -> EConstr.fold sigma aux forbidden e in aux forbidden e let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = - fun g -> - let rev_context,b = decompose_lam_n (project g) nb_lam e in - let ids = List.fold_left (fun acc (na,_) -> - let pre_id = - match na.binder_name with - | Name x -> x - | Anonymous -> ano_id - in - pre_id::acc - ) [] rev_context in - let rev_ids = pf_get_new_ids (List.rev ids) g in - let new_b = substl (List.map mkVar rev_ids) b in - observe_tclTHENLIST (fun _ _ -> str "treat_case1") - [ - h_intros (List.rev rev_ids); - Proofview.V82.of_tactic (intro_using teq_id); - onLastHypId (fun heq -> - observe_tclTHENLIST (fun _ _ -> str "treat_case2")[ - Proofview.V82.of_tactic (clear to_intros); - h_intros to_intros; - (fun g' -> - let ty_teq = pf_get_hyp_typ g' heq in - let teq_lhs,teq_rhs = - let _,args = try destApp (project g') ty_teq with DestKO -> assert false in - args.(1),args.(2) - in - let new_b' = Termops.replace_term (project g') teq_lhs teq_rhs new_b in - let new_infos = { - infos with - info = new_b'; - eqs = heq::infos.eqs; - forbidden_ids = - if forbid_new_ids - then add_vars (project g') infos.forbidden_ids new_b' - else infos.forbidden_ids - } in - finalize_tac new_infos g' - ) - ] - ) - ] g - -let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g = + fun g -> + let rev_context, b = decompose_lam_n (project g) nb_lam e in + let ids = + List.fold_left + (fun acc (na, _) -> + let pre_id = + match na.binder_name with Name x -> x | Anonymous -> ano_id + in + pre_id :: acc) + [] rev_context + in + let rev_ids = pf_get_new_ids (List.rev ids) g in + let new_b = substl (List.map mkVar rev_ids) b in + observe_tclTHENLIST + (fun _ _ -> str "treat_case1") + [ h_intros (List.rev rev_ids) + ; Proofview.V82.of_tactic (intro_using teq_id) + ; onLastHypId (fun heq -> + observe_tclTHENLIST + (fun _ _ -> str "treat_case2") + [ Proofview.V82.of_tactic (clear to_intros) + ; h_intros to_intros + ; (fun g' -> + let ty_teq = pf_get_hyp_typ g' heq in + let teq_lhs, teq_rhs = + let _, args = + try destApp (project g') ty_teq + with DestKO -> assert false + in + (args.(1), args.(2)) + in + let new_b' = + Termops.replace_term (project g') teq_lhs teq_rhs new_b + in + let new_infos = + { infos with + info = new_b' + ; eqs = heq :: infos.eqs + ; forbidden_ids = + ( if forbid_new_ids then + add_vars (project g') infos.forbidden_ids new_b' + else infos.forbidden_ids ) } + in + finalize_tac new_infos g') ]) ] + g + +let rec travel_aux jinfo continuation_tac (expr_info : constr infos) g = let sigma = project g in let env = pf_env g in match EConstr.kind sigma expr_info.info with - | CoFix _ | Fix _ -> user_err Pp.(str "Function cannot treat local fixpoint or cofixpoint") - | Proj _ -> user_err Pp.(str "Function cannot treat projections") - | LetIn(na,b,t,e) -> - begin + | CoFix _ | Fix _ -> + user_err Pp.(str "Function cannot treat local fixpoint or cofixpoint") + | Proj _ -> user_err Pp.(str "Function cannot treat projections") + | LetIn (na, b, t, e) -> + let new_continuation_tac = + jinfo.letiN (na.binder_name, b, t, e) expr_info continuation_tac + in + travel jinfo new_continuation_tac + {expr_info with info = b; is_final = false} + g + | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") + | Prod _ -> ( + try + check_not_nested env sigma + (expr_info.f_id :: expr_info.forbidden_ids) + expr_info.info; + jinfo.otherS () expr_info continuation_tac expr_info g + with e when CErrors.noncritical e -> + user_err ~hdr:"Recdef.travel" + ( str "the term " + ++ Printer.pr_leconstr_env env sigma expr_info.info + ++ str " can not contain a recursive call to " + ++ Id.print expr_info.f_id ) ) + | Lambda (n, t, b) -> ( + try + check_not_nested env sigma + (expr_info.f_id :: expr_info.forbidden_ids) + expr_info.info; + jinfo.otherS () expr_info continuation_tac expr_info g + with e when CErrors.noncritical e -> + user_err ~hdr:"Recdef.travel" + ( str "the term " + ++ Printer.pr_leconstr_env env sigma expr_info.info + ++ str " can not contain a recursive call to " + ++ Id.print expr_info.f_id ) ) + | Case (ci, t, a, l) -> + let continuation_tac_a = + jinfo.casE (travel jinfo) (ci, t, a, l) expr_info continuation_tac + in + travel jinfo continuation_tac_a + {expr_info with info = a; is_main_branch = false; is_final = false} + g + | App _ -> ( + let f, args = decompose_app sigma expr_info.info in + if EConstr.eq_constr sigma f expr_info.f_constr then + jinfo.app_reC (f, args) expr_info continuation_tac expr_info g + else + match EConstr.kind sigma f with + | App _ -> assert false (* f is coming from a decompose_app *) + | Const _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ + |Prod _ | Var _ -> + let new_infos = {expr_info with info = (f, args)} in let new_continuation_tac = - jinfo.letiN (na.binder_name,b,t,e) expr_info continuation_tac + jinfo.apP (f, args) expr_info continuation_tac in - travel jinfo new_continuation_tac - {expr_info with info = b; is_final=false} g - end - | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") - | Prod _ -> - begin - try - check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; - jinfo.otherS () expr_info continuation_tac expr_info g - with e when CErrors.noncritical e -> - user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env env sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) - end - | Lambda(n,t,b) -> - begin - try - check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; - jinfo.otherS () expr_info continuation_tac expr_info g - with e when CErrors.noncritical e -> - user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env env sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) - end - | Case(ci,t,a,l) -> - begin - let continuation_tac_a = - jinfo.casE - (travel jinfo) (ci,t,a,l) - expr_info continuation_tac in - travel - jinfo continuation_tac_a - {expr_info with info = a; is_main_branch = false; - is_final = false} g - end - | App _ -> - let f,args = decompose_app sigma expr_info.info in - if EConstr.eq_constr sigma f (expr_info.f_constr) - then jinfo.app_reC (f,args) expr_info continuation_tac expr_info g - else - begin - match EConstr.kind sigma f with - | App _ -> assert false (* f is coming from a decompose_app *) - | Const _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ - | Sort _ | Prod _ | Var _ -> - let new_infos = {expr_info with info=(f,args)} in - let new_continuation_tac = - jinfo.apP (f,args) expr_info continuation_tac in - travel_args jinfo - expr_info.is_main_branch new_continuation_tac new_infos g - | Case _ -> user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env env sigma expr_info.info ++ str " can not contain an applied match (See Limitation in Section 2.3 of refman)") - | _ -> anomaly (Pp.str "travel_aux : unexpected "++ Printer.pr_leconstr_env env sigma expr_info.info ++ Pp.str ".") - end - | Cast(t,_,_) -> travel jinfo continuation_tac {expr_info with info=t} g - | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ | Float _ -> - let new_continuation_tac = - jinfo.otherS () expr_info continuation_tac in - new_continuation_tac expr_info g + travel_args jinfo expr_info.is_main_branch new_continuation_tac + new_infos g + | Case _ -> + user_err ~hdr:"Recdef.travel" + ( str "the term " + ++ Printer.pr_leconstr_env env sigma expr_info.info + ++ str + " can not contain an applied match (See Limitation in Section \ + 2.3 of refman)" ) + | _ -> + anomaly + ( Pp.str "travel_aux : unexpected " + ++ Printer.pr_leconstr_env env sigma expr_info.info + ++ Pp.str "." ) ) + | Cast (t, _, _) -> travel jinfo continuation_tac {expr_info with info = t} g + | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ + |Float _ -> + let new_continuation_tac = jinfo.otherS () expr_info continuation_tac in + new_continuation_tac expr_info g + and travel_args jinfo is_final continuation_tac infos = - let (f_args',args) = infos.info in + let f_args', args = infos.info in match args with - | [] -> - continuation_tac {infos with info = f_args'; is_final = is_final} - | arg::args' -> - let new_continuation_tac new_infos = - let new_arg = new_infos.info in - travel_args jinfo is_final - continuation_tac - {new_infos with info = (mkApp(f_args',[|new_arg|]),args')} - in - travel jinfo new_continuation_tac - {infos with info=arg;is_final=false} + | [] -> continuation_tac {infos with info = f_args'; is_final} + | arg :: args' -> + let new_continuation_tac new_infos = + let new_arg = new_infos.info in + travel_args jinfo is_final continuation_tac + {new_infos with info = (mkApp (f_args', [|new_arg|]), args')} + in + travel jinfo new_continuation_tac {infos with info = arg; is_final = false} + and travel jinfo continuation_tac expr_info = observe_tac - (fun env sigma -> str jinfo.message ++ Printer.pr_leconstr_env env sigma expr_info.info) + (fun env sigma -> + str jinfo.message ++ Printer.pr_leconstr_env env sigma expr_info.info) (travel_aux jinfo continuation_tac expr_info) (* Termination proof *) @@ -475,164 +535,185 @@ let rec prove_lt hyple g = let sigma = project g in begin try - let (varx,varz) = match decompose_app sigma (pf_concl g) with - | _, x::z::_ when isVar sigma x && isVar sigma z -> x, z + let varx, varz = + match decompose_app sigma (pf_concl g) with + | _, x :: z :: _ when isVar sigma x && isVar sigma z -> (x, z) | _ -> assert false in let h = - List.find (fun id -> - match decompose_app sigma (pf_get_hyp_typ g id) with - | _, t::_ -> EConstr.eq_constr sigma t varx - | _ -> false - ) hyple + List.find + (fun id -> + match decompose_app sigma (pf_get_hyp_typ g id) with + | _, t :: _ -> EConstr.eq_constr sigma t varx + | _ -> false) + hyple in let y = - List.hd (List.tl (snd (decompose_app sigma (pf_get_hyp_typ g h)))) in - observe_tclTHENLIST (fun _ _ -> str "prove_lt1")[ - Proofview.V82.of_tactic (apply (mkApp(le_lt_trans (),[|varx;y;varz;mkVar h|]))); - observe_tac (fun _ _ -> str "prove_lt") (prove_lt hyple) - ] + List.hd (List.tl (snd (decompose_app sigma (pf_get_hyp_typ g h)))) + in + observe_tclTHENLIST + (fun _ _ -> str "prove_lt1") + [ Proofview.V82.of_tactic + (apply (mkApp (le_lt_trans (), [|varx; y; varz; mkVar h|]))) + ; observe_tac (fun _ _ -> str "prove_lt") (prove_lt hyple) ] with Not_found -> - ( - ( - observe_tclTHENLIST (fun _ _ -> str "prove_lt2")[ - Proofview.V82.of_tactic (apply (delayed_force lt_S_n)); - (observe_tac (fun _ _ -> str "assumption: " ++ Printer.pr_goal g) (Proofview.V82.of_tactic assumption)) - ]) - ) + observe_tclTHENLIST + (fun _ _ -> str "prove_lt2") + [ Proofview.V82.of_tactic (apply (delayed_force lt_S_n)) + ; observe_tac + (fun _ _ -> str "assumption: " ++ Printer.pr_goal g) + (Proofview.V82.of_tactic assumption) ] end g -let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = +let rec destruct_bounds_aux infos (bound, hyple, rechyps) lbounds g = match lbounds with - | [] -> - let ids = pf_ids_of_hyps g in - let s_max = mkApp(delayed_force coq_S, [|bound|]) in - let k = next_ident_away_in_goal k_id ids in - let ids = k::ids in - let h' = next_ident_away_in_goal (h'_id) ids in - let ids = h'::ids in - let def = next_ident_away_in_goal def_id ids in - observe_tclTHENLIST (fun _ _ -> str "destruct_bounds_aux1")[ - Proofview.V82.of_tactic (split (ImplicitBindings [s_max])); - Proofview.V82.of_tactic (intro_then - (fun id -> - Proofview.V82.tactic begin - observe_tac (fun _ _ -> str "destruct_bounds_aux") - (tclTHENS (Proofview.V82.of_tactic (simplest_case (mkVar id))) - [ - observe_tclTHENLIST (fun _ _ -> str "")[Proofview.V82.of_tactic (intro_using h_id); - Proofview.V82.of_tactic (simplest_elim(mkApp(delayed_force lt_n_O,[|s_max|]))); - Proofview.V82.of_tactic default_full_auto]; - observe_tclTHENLIST (fun _ _ -> str "destruct_bounds_aux2")[ - observe_tac (fun _ _ -> str "clearing k ") (Proofview.V82.of_tactic (clear [id])); - h_intros [k;h';def]; - observe_tac (fun _ _ -> str "simple_iter") (Proofview.V82.of_tactic (simpl_iter Locusops.onConcl)); - observe_tac (fun _ _ -> str "unfold functional") - (Proofview.V82.of_tactic (unfold_in_concl[(Locus.OnlyOccurrences [1], - evaluable_of_global_reference infos.func)])); - ( - observe_tclTHENLIST (fun _ _ -> str "test")[ - list_rewrite true - (List.fold_right - (fun e acc -> (mkVar e,true)::acc) - infos.eqs - (List.map (fun e -> (e,true)) rechyps) - ); - (* list_rewrite true *) - (* (List.map (fun e -> (mkVar e,true)) infos.eqs) *) - (* ; *) - - (observe_tac (fun _ _ -> str "finishing") - (tclORELSE - (Proofview.V82.of_tactic intros_reflexivity) - (observe_tac (fun _ _ -> str "calling prove_lt") (prove_lt hyple))))]) - ] - ] - )end)) - ] g - | (_,v_bound)::l -> - observe_tclTHENLIST (fun _ _ -> str "destruct_bounds_aux3")[ - Proofview.V82.of_tactic (simplest_elim (mkVar v_bound)); - Proofview.V82.of_tactic (clear [v_bound]); - tclDO 2 (Proofview.V82.of_tactic intro); - onNthHypId 1 - (fun p_hyp -> - (onNthHypId 2 - (fun p -> - observe_tclTHENLIST (fun _ _ -> str "destruct_bounds_aux4")[ - Proofview.V82.of_tactic (simplest_elim - (mkApp(delayed_force max_constr, [| bound; mkVar p|]))); - tclDO 3 (Proofview.V82.of_tactic intro); - onNLastHypsId 3 (fun lids -> - match lids with - [hle2;hle1;pmax] -> - destruct_bounds_aux infos - ((mkVar pmax), - hle1::hle2::hyple,(mkVar p_hyp)::rechyps) - l - | _ -> assert false) ; - ] - ) - ) - ) - ] g + | [] -> + let ids = pf_ids_of_hyps g in + let s_max = mkApp (delayed_force coq_S, [|bound|]) in + let k = next_ident_away_in_goal k_id ids in + let ids = k :: ids in + let h' = next_ident_away_in_goal h'_id ids in + let ids = h' :: ids in + let def = next_ident_away_in_goal def_id ids in + observe_tclTHENLIST + (fun _ _ -> str "destruct_bounds_aux1") + [ Proofview.V82.of_tactic (split (ImplicitBindings [s_max])) + ; Proofview.V82.of_tactic + (intro_then (fun id -> + Proofview.V82.tactic + (observe_tac + (fun _ _ -> str "destruct_bounds_aux") + (tclTHENS + (Proofview.V82.of_tactic (simplest_case (mkVar id))) + [ observe_tclTHENLIST + (fun _ _ -> str "") + [ Proofview.V82.of_tactic (intro_using h_id) + ; Proofview.V82.of_tactic + (simplest_elim + (mkApp (delayed_force lt_n_O, [|s_max|]))) + ; Proofview.V82.of_tactic default_full_auto ] + ; observe_tclTHENLIST + (fun _ _ -> str "destruct_bounds_aux2") + [ observe_tac + (fun _ _ -> str "clearing k ") + (Proofview.V82.of_tactic (clear [id])) + ; h_intros [k; h'; def] + ; observe_tac + (fun _ _ -> str "simple_iter") + (Proofview.V82.of_tactic + (simpl_iter Locusops.onConcl)) + ; observe_tac + (fun _ _ -> str "unfold functional") + (Proofview.V82.of_tactic + (unfold_in_concl + [ ( Locus.OnlyOccurrences [1] + , evaluable_of_global_reference + infos.func ) ])) + ; observe_tclTHENLIST + (fun _ _ -> str "test") + [ list_rewrite true + (List.fold_right + (fun e acc -> (mkVar e, true) :: acc) + infos.eqs + (List.map (fun e -> (e, true)) rechyps)) + ; (* list_rewrite true *) + (* (List.map (fun e -> (mkVar e,true)) infos.eqs) *) + (* ; *) + observe_tac + (fun _ _ -> str "finishing") + (tclORELSE + (Proofview.V82.of_tactic + intros_reflexivity) + (observe_tac + (fun _ _ -> str "calling prove_lt") + (prove_lt hyple))) ] ] ])))) ] + g + | (_, v_bound) :: l -> + observe_tclTHENLIST + (fun _ _ -> str "destruct_bounds_aux3") + [ Proofview.V82.of_tactic (simplest_elim (mkVar v_bound)) + ; Proofview.V82.of_tactic (clear [v_bound]) + ; tclDO 2 (Proofview.V82.of_tactic intro) + ; onNthHypId 1 (fun p_hyp -> + onNthHypId 2 (fun p -> + observe_tclTHENLIST + (fun _ _ -> str "destruct_bounds_aux4") + [ Proofview.V82.of_tactic + (simplest_elim + (mkApp (delayed_force max_constr, [|bound; mkVar p|]))) + ; tclDO 3 (Proofview.V82.of_tactic intro) + ; onNLastHypsId 3 (fun lids -> + match lids with + | [hle2; hle1; pmax] -> + destruct_bounds_aux infos + ( mkVar pmax + , hle1 :: hle2 :: hyple + , mkVar p_hyp :: rechyps ) + l + | _ -> assert false) ])) ] + g let destruct_bounds infos = - destruct_bounds_aux infos (delayed_force coq_O,[],[]) infos.values_and_bounds + destruct_bounds_aux infos + (delayed_force coq_O, [], []) + infos.values_and_bounds let terminate_app f_and_args expr_info continuation_tac infos = - if expr_info.is_final && expr_info.is_main_branch - then - observe_tclTHENLIST (fun _ _ -> str "terminate_app1")[ - continuation_tac infos; - observe_tac (fun _ _ -> str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))); - observe_tac (fun _ _ -> str "destruct_bounds (1)") (destruct_bounds infos) - ] - else continuation_tac infos + if expr_info.is_final && expr_info.is_main_branch then + observe_tclTHENLIST + (fun _ _ -> str "terminate_app1") + [ continuation_tac infos + ; observe_tac + (fun _ _ -> str "first split") + (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))) + ; observe_tac + (fun _ _ -> str "destruct_bounds (1)") + (destruct_bounds infos) ] + else continuation_tac infos let terminate_others _ expr_info continuation_tac infos = - if expr_info.is_final && expr_info.is_main_branch - then - observe_tclTHENLIST (fun _ _ -> str "terminate_others")[ - continuation_tac infos; - observe_tac (fun _ _ -> str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))); - observe_tac (fun _ _ -> str "destruct_bounds") (destruct_bounds infos) - ] + if expr_info.is_final && expr_info.is_main_branch then + observe_tclTHENLIST + (fun _ _ -> str "terminate_others") + [ continuation_tac infos + ; observe_tac + (fun _ _ -> str "first split") + (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))) + ; observe_tac (fun _ _ -> str "destruct_bounds") (destruct_bounds infos) + ] else continuation_tac infos -let terminate_letin (na,b,t,e) expr_info continuation_tac info g = +let terminate_letin (na, b, t, e) expr_info continuation_tac info g = let sigma = project g in let env = pf_env g in let new_e = subst1 info.info e in let new_forbidden = let forbid = try - check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids) b; + check_not_nested env sigma (expr_info.f_id :: expr_info.forbidden_ids) b; true with e when CErrors.noncritical e -> false in - if forbid - then + if forbid then match na with - | Anonymous -> info.forbidden_ids - | Name id -> id::info.forbidden_ids + | Anonymous -> info.forbidden_ids + | Name id -> id :: info.forbidden_ids else info.forbidden_ids in continuation_tac {info with info = new_e; forbidden_ids = new_forbidden} g let pf_type c tac gl = let evars, ty = Typing.type_of (pf_env gl) (project gl) c in - tclTHEN (Refiner.tclEVARS evars) (tac ty) gl + tclTHEN (Refiner.tclEVARS evars) (tac ty) gl let pf_typel l tac = let rec aux tys l = match l with | [] -> tac (List.rev tys) - | hd :: tl -> pf_type hd (fun ty -> aux (ty::tys) tl) - in aux [] l + | hd :: tl -> pf_type hd (fun ty -> aux (ty :: tys) tl) + in + aux [] l (* This is like the previous one except that it also rewrite on all hypotheses except the ones given in the first argument. All the @@ -646,351 +727,431 @@ let mkDestructEq not_on_hyp expr g = (fun decl -> let open Context.Named.Declaration in let id = get_id decl in - if Id.List.mem id not_on_hyp || not (Termops.dependent (project g) expr (get_type decl)) - then None else Some id) hyps in + if + Id.List.mem id not_on_hyp + || not (Termops.dependent (project g) expr (get_type decl)) + then None + else Some id) + hyps + in let to_revert_constr = List.rev_map mkVar to_revert in let g, type_of_expr = tac_type_of g expr in - let new_hyps = mkApp(Lazy.force refl_equal, [|type_of_expr; expr|])::to_revert_constr in + let new_hyps = + mkApp (Lazy.force refl_equal, [|type_of_expr; expr|]) :: to_revert_constr + in let tac = pf_typel new_hyps (fun _ -> - observe_tclTHENLIST (fun _ _ -> str "mkDestructEq") - [Proofview.V82.of_tactic (generalize new_hyps); - (fun g2 -> - let changefun patvars env sigma = - pattern_occs [Locus.AllOccurrencesBut [1], expr] (pf_env g2) sigma (pf_concl g2) - in - Proofview.V82.of_tactic (change_in_concl ~check:true None changefun) g2); - Proofview.V82.of_tactic (simplest_case expr)]) + observe_tclTHENLIST + (fun _ _ -> str "mkDestructEq") + [ Proofview.V82.of_tactic (generalize new_hyps) + ; (fun g2 -> + let changefun patvars env sigma = + pattern_occs + [(Locus.AllOccurrencesBut [1], expr)] + (pf_env g2) sigma (pf_concl g2) + in + Proofview.V82.of_tactic + (change_in_concl ~check:true None changefun) + g2) + ; Proofview.V82.of_tactic (simplest_case expr) ]) in - g, tac, to_revert + (g, tac, to_revert) -let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = +let terminate_case next_step (ci, a, t, l) expr_info continuation_tac infos g = let sigma = project g in let env = pf_env g in let f_is_present = try - check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids) a; + check_not_nested env sigma (expr_info.f_id :: expr_info.forbidden_ids) a; false - with e when CErrors.noncritical e -> - true + with e when CErrors.noncritical e -> true in let a' = infos.info in let new_info = - {infos with - info = mkCase(ci,t,a',l); - is_main_branch = expr_info.is_main_branch; - is_final = expr_info.is_final} in - let g,destruct_tac,rev_to_thin_intro = - mkDestructEq [expr_info.rec_arg_id] a' g in + { infos with + info = mkCase (ci, t, a', l) + ; is_main_branch = expr_info.is_main_branch + ; is_final = expr_info.is_final } + in + let g, destruct_tac, rev_to_thin_intro = + mkDestructEq [expr_info.rec_arg_id] a' g + in let to_thin_intro = List.rev rev_to_thin_intro in - observe_tac (fun _ _ -> str "treating cases (" ++ int (Array.length l) ++ str")" ++ spc () ++ Printer.pr_leconstr_env (pf_env g) sigma a') - (try - (tclTHENS - destruct_tac - (List.map_i (fun i e -> observe_tac (fun _ _ -> str "do treat case") (treat_case f_is_present to_thin_intro (next_step continuation_tac) ci.ci_cstr_ndecls.(i) e new_info)) 0 (Array.to_list l) - )) - with - | UserError(Some "Refiner.thensn_tac3",_) - | UserError(Some "Refiner.tclFAIL_s",_) -> - (observe_tac (fun _ _ -> str "is computable " ++ Printer.pr_leconstr_env env sigma new_info.info) (next_step continuation_tac {new_info with info = Reductionops.nf_betaiotazeta (pf_env g) sigma new_info.info} ) - )) + observe_tac + (fun _ _ -> + str "treating cases (" + ++ int (Array.length l) + ++ str ")" ++ spc () + ++ Printer.pr_leconstr_env (pf_env g) sigma a') + ( try + tclTHENS destruct_tac + (List.map_i + (fun i e -> + observe_tac + (fun _ _ -> str "do treat case") + (treat_case f_is_present to_thin_intro + (next_step continuation_tac) + ci.ci_cstr_ndecls.(i) e new_info)) + 0 (Array.to_list l)) + with + | UserError (Some "Refiner.thensn_tac3", _) + |UserError (Some "Refiner.tclFAIL_s", _) + -> + observe_tac + (fun _ _ -> + str "is computable " + ++ Printer.pr_leconstr_env env sigma new_info.info) + (next_step continuation_tac + { new_info with + info = + Reductionops.nf_betaiotazeta (pf_env g) sigma new_info.info }) + ) g -let terminate_app_rec (f,args) expr_info continuation_tac _ g = +let terminate_app_rec (f, args) expr_info continuation_tac _ g = let sigma = project g in let env = pf_env g in - List.iter (check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids)) + List.iter + (check_not_nested env sigma (expr_info.f_id :: expr_info.forbidden_ids)) args; - begin - try - let v = List.assoc_f (List.equal (EConstr.eq_constr sigma)) args expr_info.args_assoc in - let new_infos = {expr_info with info = v} in - observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec")[ - continuation_tac new_infos; - if expr_info.is_final && expr_info.is_main_branch - then - observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec1")[ - observe_tac (fun _ _ -> str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info]))); - observe_tac (fun _ _ -> str "destruct_bounds (3)") - (destruct_bounds new_infos) - ] - else - tclIDTAC - ] g - with Not_found -> - observe_tac (fun _ _ -> str "terminate_app_rec not found") (tclTHENS - (Proofview.V82.of_tactic (simplest_elim (mkApp(mkVar expr_info.ih,Array.of_list args)))) - [ - observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec2")[ - Proofview.V82.of_tactic (intro_using rec_res_id); - Proofview.V82.of_tactic intro; - onNthHypId 1 - (fun v_bound -> - (onNthHypId 2 - (fun v -> - let new_infos = { expr_info with - info = (mkVar v); - values_and_bounds = - (v,v_bound)::expr_info.values_and_bounds; - args_assoc=(args,mkVar v)::expr_info.args_assoc - } in - observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec3")[ - continuation_tac new_infos; - if expr_info.is_final && expr_info.is_main_branch - then - observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec4")[ - observe_tac (fun _ _ -> str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info]))); - observe_tac (fun _ _ -> str "destruct_bounds (2)") - (destruct_bounds new_infos) - ] - else - tclIDTAC - ] - ) - ) - ) - ]; - observe_tac (fun _ _ -> str "proving decreasing") ( - tclTHENS (* proof of args < formal args *) - (Proofview.V82.of_tactic (apply (Lazy.force expr_info.acc_inv))) - [ - observe_tac (fun _ _ -> str "assumption") (Proofview.V82.of_tactic assumption); - observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec5") - [ - tclTRY(list_rewrite true - (List.map - (fun e -> mkVar e,true) - expr_info.eqs - ) - ); - Proofview.V82.of_tactic @@ - tclUSER expr_info.concl_tac true - (Some ( - expr_info.ih::expr_info.acc_id:: - (fun (x,y) -> y) - (List.split expr_info.values_and_bounds) - ) - ); - ] - ]) - ]) g - end + try + let v = + List.assoc_f + (List.equal (EConstr.eq_constr sigma)) + args expr_info.args_assoc + in + let new_infos = {expr_info with info = v} in + observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec") + [ continuation_tac new_infos + ; ( if expr_info.is_final && expr_info.is_main_branch then + observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec1") + [ observe_tac + (fun _ _ -> str "first split") + (Proofview.V82.of_tactic + (split (ImplicitBindings [new_infos.info]))) + ; observe_tac + (fun _ _ -> str "destruct_bounds (3)") + (destruct_bounds new_infos) ] + else tclIDTAC ) ] + g + with Not_found -> + observe_tac + (fun _ _ -> str "terminate_app_rec not found") + (tclTHENS + (Proofview.V82.of_tactic + (simplest_elim (mkApp (mkVar expr_info.ih, Array.of_list args)))) + [ observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec2") + [ Proofview.V82.of_tactic (intro_using rec_res_id) + ; Proofview.V82.of_tactic intro + ; onNthHypId 1 (fun v_bound -> + onNthHypId 2 (fun v -> + let new_infos = + { expr_info with + info = mkVar v + ; values_and_bounds = + (v, v_bound) :: expr_info.values_and_bounds + ; args_assoc = (args, mkVar v) :: expr_info.args_assoc + } + in + observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec3") + [ continuation_tac new_infos + ; ( if expr_info.is_final && expr_info.is_main_branch + then + observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec4") + [ observe_tac + (fun _ _ -> str "first split") + (Proofview.V82.of_tactic + (split + (ImplicitBindings [new_infos.info]))) + ; observe_tac + (fun _ _ -> str "destruct_bounds (2)") + (destruct_bounds new_infos) ] + else tclIDTAC ) ])) ] + ; observe_tac + (fun _ _ -> str "proving decreasing") + (tclTHENS (* proof of args < formal args *) + (Proofview.V82.of_tactic (apply (Lazy.force expr_info.acc_inv))) + [ observe_tac + (fun _ _ -> str "assumption") + (Proofview.V82.of_tactic assumption) + ; observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec5") + [ tclTRY + (list_rewrite true + (List.map (fun e -> (mkVar e, true)) expr_info.eqs)) + ; Proofview.V82.of_tactic + @@ tclUSER expr_info.concl_tac true + (Some + ( expr_info.ih :: expr_info.acc_id + :: (fun (x, y) -> y) + (List.split expr_info.values_and_bounds) )) + ] ]) ]) + g let terminate_info = - { message = "prove_terminate with term "; - letiN = terminate_letin; - lambdA = (fun _ _ _ _ -> assert false); - casE = terminate_case; - otherS = terminate_others; - apP = terminate_app; - app_reC = terminate_app_rec; - } + { message = "prove_terminate with term " + ; letiN = terminate_letin + ; lambdA = (fun _ _ _ _ -> assert false) + ; casE = terminate_case + ; otherS = terminate_others + ; apP = terminate_app + ; app_reC = terminate_app_rec } let prove_terminate = travel terminate_info - (* Equation proof *) -let equation_case next_step (ci,a,t,l) expr_info continuation_tac infos = - observe_tac (fun _ _ -> str "equation case") (terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos) +let equation_case next_step (ci, a, t, l) expr_info continuation_tac infos = + observe_tac + (fun _ _ -> str "equation case") + (terminate_case next_step (ci, a, t, l) expr_info continuation_tac infos) let rec prove_le g = let sigma = project g in - let x,z = - let _,args = decompose_app sigma (pf_concl g) in - (List.hd args,List.hd (List.tl args)) + let x, z = + let _, args = decompose_app sigma (pf_concl g) in + (List.hd args, List.hd (List.tl args)) in - tclFIRST[ - Proofview.V82.of_tactic assumption; - Proofview.V82.of_tactic (apply (delayed_force le_n)); - begin - try - let matching_fun c = match EConstr.kind sigma c with - | App (c, [| x0 ; _ |]) -> - EConstr.isVar sigma x0 && - Id.equal (destVar sigma x0) (destVar sigma x) && - EConstr.isRefX sigma (le ()) c - | _ -> false - in - let (h,t) = List.find (fun (_,t) -> matching_fun t) (pf_hyps_types g) in - let h = h.binder_name in - let y = - let _,args = decompose_app sigma t in - List.hd (List.tl args) - in - observe_tclTHENLIST (fun _ _ -> str "prove_le")[ - Proofview.V82.of_tactic (apply(mkApp(le_trans (),[|x;y;z;mkVar h|]))); - observe_tac (fun _ _ -> str "prove_le (rec)") (prove_le) - ] - with Not_found -> tclFAIL 0 (mt()) - end; - ] + tclFIRST + [ Proofview.V82.of_tactic assumption + ; Proofview.V82.of_tactic (apply (delayed_force le_n)) + ; begin + try + let matching_fun c = + match EConstr.kind sigma c with + | App (c, [|x0; _|]) -> + EConstr.isVar sigma x0 + && Id.equal (destVar sigma x0) (destVar sigma x) + && EConstr.isRefX sigma (le ()) c + | _ -> false + in + let h, t = + List.find (fun (_, t) -> matching_fun t) (pf_hyps_types g) + in + let h = h.binder_name in + let y = + let _, args = decompose_app sigma t in + List.hd (List.tl args) + in + observe_tclTHENLIST + (fun _ _ -> str "prove_le") + [ Proofview.V82.of_tactic + (apply (mkApp (le_trans (), [|x; y; z; mkVar h|]))) + ; observe_tac (fun _ _ -> str "prove_le (rec)") prove_le ] + with Not_found -> tclFAIL 0 (mt ()) + end ] g let rec make_rewrite_list expr_info max = function | [] -> tclIDTAC - | (_,p,hp)::l -> - observe_tac (fun _ _ -> str "make_rewrite_list") (tclTHENS - (observe_tac (fun _ _ -> str "rewrite heq on " ++ Id.print p ) ( - (fun g -> - let sigma = project g in - let t_eq = compute_renamed_type g hp in - let k,def = - let k_na,_,t = destProd sigma t_eq in - let _,_,t = destProd sigma t in - let def_na,_,_ = destProd sigma t in - Nameops.Name.get_id k_na.binder_name,Nameops.Name.get_id def_na.binder_name - in - Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences - true (* dep proofs also: *) true - (mkVar hp, - ExplicitBindings[CAst.make @@ (NamedHyp def, expr_info.f_constr); - CAst.make @@ (NamedHyp k, f_S max)]) false) g) ) - ) - [make_rewrite_list expr_info max l; - observe_tclTHENLIST (fun _ _ -> str "make_rewrite_list")[ (* x < S max proof *) - Proofview.V82.of_tactic (apply (delayed_force le_lt_n_Sm)); - observe_tac (fun _ _ -> str "prove_le(2)") prove_le - ] - ] ) + | (_, p, hp) :: l -> + observe_tac + (fun _ _ -> str "make_rewrite_list") + (tclTHENS + (observe_tac + (fun _ _ -> str "rewrite heq on " ++ Id.print p) + (fun g -> + let sigma = project g in + let t_eq = compute_renamed_type g hp in + let k, def = + let k_na, _, t = destProd sigma t_eq in + let _, _, t = destProd sigma t in + let def_na, _, _ = destProd sigma t in + ( Nameops.Name.get_id k_na.binder_name + , Nameops.Name.get_id def_na.binder_name ) + in + Proofview.V82.of_tactic + (general_rewrite_bindings false Locus.AllOccurrences true + (* dep proofs also: *) true + ( mkVar hp + , ExplicitBindings + [ CAst.make @@ (NamedHyp def, expr_info.f_constr) + ; CAst.make @@ (NamedHyp k, f_S max) ] ) + false) + g)) + [ make_rewrite_list expr_info max l + ; observe_tclTHENLIST + (fun _ _ -> str "make_rewrite_list") + [ (* x < S max proof *) + Proofview.V82.of_tactic (apply (delayed_force le_lt_n_Sm)) + ; observe_tac (fun _ _ -> str "prove_le(2)") prove_le ] ]) let make_rewrite expr_info l hp max = tclTHENFIRST - (observe_tac (fun _ _ -> str "make_rewrite") (make_rewrite_list expr_info max l)) - (observe_tac (fun _ _ -> str "make_rewrite") (tclTHENS - (fun g -> - let sigma = project g in - let t_eq = compute_renamed_type g hp in - let k,def = - let k_na,_,t = destProd sigma t_eq in - let _,_,t = destProd sigma t in - let def_na,_,_ = destProd sigma t in - Nameops.Name.get_id k_na.binder_name,Nameops.Name.get_id def_na.binder_name - in - observe_tac (fun _ _ -> str "general_rewrite_bindings") - (Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences - true (* dep proofs also: *) true - (mkVar hp, - ExplicitBindings[CAst.make @@ (NamedHyp def, expr_info.f_constr); - CAst.make @@ (NamedHyp k, f_S (f_S max))]) false)) g) - [observe_tac(fun _ _ -> str "make_rewrite finalize") ( - (* tclORELSE( h_reflexivity) *) - (observe_tclTHENLIST (fun _ _ -> str "make_rewrite")[ - Proofview.V82.of_tactic (simpl_iter Locusops.onConcl); - observe_tac (fun _ _ -> str "unfold functional") - (Proofview.V82.of_tactic (unfold_in_concl[(Locus.OnlyOccurrences [1], - evaluable_of_global_reference expr_info.func)])); - - (list_rewrite true - (List.map (fun e -> mkVar e,true) expr_info.eqs)); - (observe_tac (fun _ _ -> str "h_reflexivity") - (Proofview.V82.of_tactic intros_reflexivity) - ) - ])) - ; - observe_tclTHENLIST (fun _ _ -> str "make_rewrite1")[ (* x < S (S max) proof *) - Proofview.V82.of_tactic (apply (EConstr.of_constr (delayed_force le_lt_SS))); - observe_tac (fun _ _ -> str "prove_le (3)") prove_le - ] - ]) - ) + (observe_tac + (fun _ _ -> str "make_rewrite") + (make_rewrite_list expr_info max l)) + (observe_tac + (fun _ _ -> str "make_rewrite") + (tclTHENS + (fun g -> + let sigma = project g in + let t_eq = compute_renamed_type g hp in + let k, def = + let k_na, _, t = destProd sigma t_eq in + let _, _, t = destProd sigma t in + let def_na, _, _ = destProd sigma t in + ( Nameops.Name.get_id k_na.binder_name + , Nameops.Name.get_id def_na.binder_name ) + in + observe_tac + (fun _ _ -> str "general_rewrite_bindings") + (Proofview.V82.of_tactic + (general_rewrite_bindings false Locus.AllOccurrences true + (* dep proofs also: *) true + ( mkVar hp + , ExplicitBindings + [ CAst.make @@ (NamedHyp def, expr_info.f_constr) + ; CAst.make @@ (NamedHyp k, f_S (f_S max)) ] ) + false)) + g) + [ observe_tac + (fun _ _ -> str "make_rewrite finalize") + ((* tclORELSE( h_reflexivity) *) + observe_tclTHENLIST + (fun _ _ -> str "make_rewrite") + [ Proofview.V82.of_tactic (simpl_iter Locusops.onConcl) + ; observe_tac + (fun _ _ -> str "unfold functional") + (Proofview.V82.of_tactic + (unfold_in_concl + [ ( Locus.OnlyOccurrences [1] + , evaluable_of_global_reference expr_info.func ) ])) + ; list_rewrite true + (List.map (fun e -> (mkVar e, true)) expr_info.eqs) + ; observe_tac + (fun _ _ -> str "h_reflexivity") + (Proofview.V82.of_tactic intros_reflexivity) ]) + ; observe_tclTHENLIST + (fun _ _ -> str "make_rewrite1") + [ (* x < S (S max) proof *) + Proofview.V82.of_tactic + (apply (EConstr.of_constr (delayed_force le_lt_SS))) + ; observe_tac (fun _ _ -> str "prove_le (3)") prove_le ] ])) let rec compute_max rew_tac max l = match l with - | [] -> rew_tac max - | (_,p,_)::l -> - observe_tclTHENLIST (fun _ _ -> str "compute_max")[ - Proofview.V82.of_tactic (simplest_elim - (mkApp(delayed_force max_constr, [| max; mkVar p|]))); - tclDO 3 (Proofview.V82.of_tactic intro); - onNLastHypsId 3 (fun lids -> - match lids with - | [hle2;hle1;pmax] -> compute_max rew_tac (mkVar pmax) l - | _ -> assert false - )] + | [] -> rew_tac max + | (_, p, _) :: l -> + observe_tclTHENLIST + (fun _ _ -> str "compute_max") + [ Proofview.V82.of_tactic + (simplest_elim (mkApp (delayed_force max_constr, [|max; mkVar p|]))) + ; tclDO 3 (Proofview.V82.of_tactic intro) + ; onNLastHypsId 3 (fun lids -> + match lids with + | [hle2; hle1; pmax] -> compute_max rew_tac (mkVar pmax) l + | _ -> assert false) ] let rec destruct_hex expr_info acc l = match l with - | [] -> - begin - match List.rev acc with - | [] -> tclIDTAC - | (_,p,hp)::tl -> - observe_tac (fun _ _ -> str "compute max ") (compute_max (make_rewrite expr_info tl hp) (mkVar p) tl) - end - | (v,hex)::l -> - observe_tclTHENLIST (fun _ _ -> str "destruct_hex")[ - Proofview.V82.of_tactic (simplest_case (mkVar hex)); - Proofview.V82.of_tactic (clear [hex]); - tclDO 2 (Proofview.V82.of_tactic intro); - onNthHypId 1 (fun hp -> - onNthHypId 2 (fun p -> - observe_tac - (fun _ _ -> str "destruct_hex after " ++ Id.print hp ++ spc () ++ Id.print p) - (destruct_hex expr_info ((v,p,hp)::acc) l) - ) - ) - ] + | [] -> ( + match List.rev acc with + | [] -> tclIDTAC + | (_, p, hp) :: tl -> + observe_tac + (fun _ _ -> str "compute max ") + (compute_max (make_rewrite expr_info tl hp) (mkVar p) tl) ) + | (v, hex) :: l -> + observe_tclTHENLIST + (fun _ _ -> str "destruct_hex") + [ Proofview.V82.of_tactic (simplest_case (mkVar hex)) + ; Proofview.V82.of_tactic (clear [hex]) + ; tclDO 2 (Proofview.V82.of_tactic intro) + ; onNthHypId 1 (fun hp -> + onNthHypId 2 (fun p -> + observe_tac + (fun _ _ -> + str "destruct_hex after " ++ Id.print hp ++ spc () + ++ Id.print p) + (destruct_hex expr_info ((v, p, hp) :: acc) l))) ] let rec intros_values_eq expr_info acc = - tclORELSE( - observe_tclTHENLIST (fun _ _ -> str "intros_values_eq")[ - tclDO 2 (Proofview.V82.of_tactic intro); - onNthHypId 1 (fun hex -> - (onNthHypId 2 (fun v -> intros_values_eq expr_info ((v,hex)::acc))) - ) - ]) - (tclCOMPLETE ( - destruct_hex expr_info [] acc - )) + tclORELSE + (observe_tclTHENLIST + (fun _ _ -> str "intros_values_eq") + [ tclDO 2 (Proofview.V82.of_tactic intro) + ; onNthHypId 1 (fun hex -> + onNthHypId 2 (fun v -> + intros_values_eq expr_info ((v, hex) :: acc))) ]) + (tclCOMPLETE (destruct_hex expr_info [] acc)) let equation_others _ expr_info continuation_tac infos = - if expr_info.is_final && expr_info.is_main_branch - then - observe_tac (fun env sigma -> str "equation_others (cont_tac +intros) " ++ Printer.pr_leconstr_env env sigma expr_info.info) - (tclTHEN + if expr_info.is_final && expr_info.is_main_branch then + observe_tac + (fun env sigma -> + str "equation_others (cont_tac +intros) " + ++ Printer.pr_leconstr_env env sigma expr_info.info) + (tclTHEN (continuation_tac infos) + (observe_tac + (fun env sigma -> + str "intros_values_eq equation_others " + ++ Printer.pr_leconstr_env env sigma expr_info.info) + (intros_values_eq expr_info []))) + else + observe_tac + (fun env sigma -> + str "equation_others (cont_tac) " + ++ Printer.pr_leconstr_env env sigma expr_info.info) (continuation_tac infos) - (observe_tac (fun env sigma -> str "intros_values_eq equation_others " ++ Printer.pr_leconstr_env env sigma expr_info.info) (intros_values_eq expr_info []))) - else observe_tac (fun env sigma -> str "equation_others (cont_tac) " ++ Printer.pr_leconstr_env env sigma expr_info.info) (continuation_tac infos) let equation_app f_and_args expr_info continuation_tac infos = - if expr_info.is_final && expr_info.is_main_branch - then ((observe_tac (fun _ _ -> str "intros_values_eq equation_app") (intros_values_eq expr_info []))) - else continuation_tac infos + if expr_info.is_final && expr_info.is_main_branch then + observe_tac + (fun _ _ -> str "intros_values_eq equation_app") + (intros_values_eq expr_info []) + else continuation_tac infos -let equation_app_rec (f,args) expr_info continuation_tac info g = +let equation_app_rec (f, args) expr_info continuation_tac info g = let sigma = project g in - begin - try - let v = List.assoc_f (List.equal (EConstr.eq_constr sigma)) args expr_info.args_assoc in - let new_infos = {expr_info with info = v} in - observe_tac (fun _ _ -> str "app_rec found") (continuation_tac new_infos) g - with Not_found -> - if expr_info.is_final && expr_info.is_main_branch - then - observe_tclTHENLIST (fun _ _ -> str "equation_app_rec") - [ Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args))); - continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc}; - observe_tac (fun _ _ -> str "app_rec intros_values_eq") (intros_values_eq expr_info []) - ] g - else - observe_tclTHENLIST (fun _ _ -> str "equation_app_rec1")[ - Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args))); - observe_tac (fun _ _ -> str "app_rec not_found") (continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc}) - ] g - end + try + let v = + List.assoc_f + (List.equal (EConstr.eq_constr sigma)) + args expr_info.args_assoc + in + let new_infos = {expr_info with info = v} in + observe_tac (fun _ _ -> str "app_rec found") (continuation_tac new_infos) g + with Not_found -> + if expr_info.is_final && expr_info.is_main_branch then + observe_tclTHENLIST + (fun _ _ -> str "equation_app_rec") + [ Proofview.V82.of_tactic + (simplest_case (mkApp (expr_info.f_terminate, Array.of_list args))) + ; continuation_tac + { expr_info with + args_assoc = (args, delayed_force coq_O) :: expr_info.args_assoc + } + ; observe_tac + (fun _ _ -> str "app_rec intros_values_eq") + (intros_values_eq expr_info []) ] + g + else + observe_tclTHENLIST + (fun _ _ -> str "equation_app_rec1") + [ Proofview.V82.of_tactic + (simplest_case (mkApp (expr_info.f_terminate, Array.of_list args))) + ; observe_tac + (fun _ _ -> str "app_rec not_found") + (continuation_tac + { expr_info with + args_assoc = + (args, delayed_force coq_O) :: expr_info.args_assoc }) ] + g let equation_info = - {message = "prove_equation with term "; - letiN = (fun _ -> assert false); - lambdA = (fun _ _ _ _ -> assert false); - casE = equation_case; - otherS = equation_others; - apP = equation_app; - app_reC = equation_app_rec -} + { message = "prove_equation with term " + ; letiN = (fun _ -> assert false) + ; lambdA = (fun _ _ _ _ -> assert false) + ; casE = equation_case + ; otherS = equation_others + ; apP = equation_app + ; app_reC = equation_app_rec } let prove_eq = travel equation_info @@ -1001,271 +1162,268 @@ let compute_terminate_type nb_args func = let open Term in let open Constr in let open CVars in - let _,a_arrow_b,_ = destLambda(def_of_const (constr_of_monomorphic_global func)) in - let rev_args,b = decompose_prod_n nb_args a_arrow_b in + let _, a_arrow_b, _ = + destLambda (def_of_const (constr_of_monomorphic_global func)) + in + let rev_args, b = decompose_prod_n nb_args a_arrow_b in let left = - mkApp(delayed_force iter_rd, - Array.of_list - (lift 5 a_arrow_b:: mkRel 3:: - constr_of_monomorphic_global func::mkRel 1:: - List.rev (List.map_i (fun i _ -> mkRel (6+i)) 0 rev_args) - ) - ) + mkApp + ( delayed_force iter_rd + , Array.of_list + ( lift 5 a_arrow_b :: mkRel 3 + :: constr_of_monomorphic_global func + :: mkRel 1 + :: List.rev (List.map_i (fun i _ -> mkRel (6 + i)) 0 rev_args) ) ) in let right = mkRel 5 in let delayed_force c = EConstr.Unsafe.to_constr (delayed_force c) in - let equality = mkApp(delayed_force eq, [|lift 5 b; left; right|]) in - let result = (mkProd (make_annot (Name def_id) Sorts.Relevant, lift 4 a_arrow_b, equality)) in - let cond = mkApp(delayed_force lt, [|(mkRel 2); (mkRel 1)|]) in + let equality = mkApp (delayed_force eq, [|lift 5 b; left; right|]) in + let result = + mkProd (make_annot (Name def_id) Sorts.Relevant, lift 4 a_arrow_b, equality) + in + let cond = mkApp (delayed_force lt, [|mkRel 2; mkRel 1|]) in let nb_iter = - mkApp(delayed_force ex, - [|delayed_force nat; - (mkLambda - (make_annot (Name p_id) Sorts.Relevant, - delayed_force nat, - (mkProd (make_annot (Name k_id) Sorts.Relevant, delayed_force nat, - mkArrow cond Sorts.Relevant result))))|])in - let value = mkApp(constr_of_monomorphic_global (Util.delayed_force coq_sig_ref), - [|b; - (mkLambda (make_annot (Name v_id) Sorts.Relevant, b, nb_iter))|]) in + mkApp + ( delayed_force ex + , [| delayed_force nat + ; mkLambda + ( make_annot (Name p_id) Sorts.Relevant + , delayed_force nat + , mkProd + ( make_annot (Name k_id) Sorts.Relevant + , delayed_force nat + , mkArrow cond Sorts.Relevant result ) ) |] ) + in + let value = + mkApp + ( constr_of_monomorphic_global (Util.delayed_force coq_sig_ref) + , [|b; mkLambda (make_annot (Name v_id) Sorts.Relevant, b, nb_iter)|] ) + in compose_prod rev_args value - -let termination_proof_header is_mes input_type ids args_id relation - rec_arg_num rec_arg_id tac wf_tac : tactic = - begin - fun g -> - let nargs = List.length args_id in - let pre_rec_args = - List.rev_map - mkVar (fst (List.chop (rec_arg_num - 1) args_id)) - in - let relation = substl pre_rec_args relation in - let input_type = substl pre_rec_args input_type in - let wf_thm = next_ident_away_in_goal (Id.of_string ("wf_R")) ids in - let wf_rec_arg = - next_ident_away_in_goal - (Id.of_string ("Acc_"^(Id.to_string rec_arg_id))) - (wf_thm::ids) - in - let hrec = next_ident_away_in_goal hrec_id - (wf_rec_arg::wf_thm::ids) in - let acc_inv = - lazy ( - mkApp ( - delayed_force acc_inv_id, - [|input_type;relation;mkVar rec_arg_id|] - ) - ) - in - tclTHEN - (h_intros args_id) - (tclTHENS +let termination_proof_header is_mes input_type ids args_id relation rec_arg_num + rec_arg_id tac wf_tac : tactic = + fun g -> + let nargs = List.length args_id in + let pre_rec_args = + List.rev_map mkVar (fst (List.chop (rec_arg_num - 1) args_id)) + in + let relation = substl pre_rec_args relation in + let input_type = substl pre_rec_args input_type in + let wf_thm = next_ident_away_in_goal (Id.of_string "wf_R") ids in + let wf_rec_arg = + next_ident_away_in_goal + (Id.of_string ("Acc_" ^ Id.to_string rec_arg_id)) + (wf_thm :: ids) + in + let hrec = next_ident_away_in_goal hrec_id (wf_rec_arg :: wf_thm :: ids) in + let acc_inv = + lazy + (mkApp + (delayed_force acc_inv_id, [|input_type; relation; mkVar rec_arg_id|])) + in + tclTHEN (h_intros args_id) + (tclTHENS + (observe_tac + (fun _ _ -> str "first assert") + (Proofview.V82.of_tactic + (assert_before (Name wf_rec_arg) + (mkApp + ( delayed_force acc_rel + , [|input_type; relation; mkVar rec_arg_id|] ))))) + [ (* accesibility proof *) + tclTHENS (observe_tac - (fun _ _ -> str "first assert") - (Proofview.V82.of_tactic (assert_before - (Name wf_rec_arg) - (mkApp (delayed_force acc_rel, - [|input_type;relation;mkVar rec_arg_id|]) - ) - )) - ) - [ - (* accesibility proof *) - tclTHENS - (observe_tac - (fun _ _ -> str "second assert") - (Proofview.V82.of_tactic (assert_before - (Name wf_thm) - (mkApp (delayed_force well_founded,[|input_type;relation|])) - )) - ) - [ - (* interactive proof that the relation is well_founded *) - observe_tac (fun _ _ -> str "wf_tac") (wf_tac is_mes (Some args_id)); - (* this gives the accessibility argument *) - observe_tac - (fun _ _ -> str "apply wf_thm") - (Proofview.V82.of_tactic (Simple.apply (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|]))) - ) - ] - ; - (* rest of the proof *) - observe_tclTHENLIST (fun _ _ -> str "rest of proof") - [observe_tac (fun _ _ -> str "generalize") - (onNLastHypsId (nargs+1) - (tclMAP (fun id -> - tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (Proofview.V82.of_tactic (clear [id]))) - )) - ; - observe_tac (fun _ _ -> str "fix") (Proofview.V82.of_tactic (fix hrec (nargs+1))); - h_intros args_id; - Proofview.V82.of_tactic (Simple.intro wf_rec_arg); - observe_tac (fun _ _ -> str "tac") (tac wf_rec_arg hrec wf_rec_arg acc_inv) - ] + (fun _ _ -> str "second assert") + (Proofview.V82.of_tactic + (assert_before (Name wf_thm) + (mkApp + (delayed_force well_founded, [|input_type; relation|]))))) + [ (* interactive proof that the relation is well_founded *) + observe_tac + (fun _ _ -> str "wf_tac") + (wf_tac is_mes (Some args_id)) + ; (* this gives the accessibility argument *) + observe_tac + (fun _ _ -> str "apply wf_thm") + (Proofview.V82.of_tactic + (Simple.apply (mkApp (mkVar wf_thm, [|mkVar rec_arg_id|])))) ] - ) g - end - - + ; (* rest of the proof *) + observe_tclTHENLIST + (fun _ _ -> str "rest of proof") + [ observe_tac + (fun _ _ -> str "generalize") + (onNLastHypsId (nargs + 1) + (tclMAP (fun id -> + tclTHEN + (Proofview.V82.of_tactic + (Tactics.generalize [mkVar id])) + (Proofview.V82.of_tactic (clear [id]))))) + ; observe_tac + (fun _ _ -> str "fix") + (Proofview.V82.of_tactic (fix hrec (nargs + 1))) + ; h_intros args_id + ; Proofview.V82.of_tactic (Simple.intro wf_rec_arg) + ; observe_tac + (fun _ _ -> str "tac") + (tac wf_rec_arg hrec wf_rec_arg acc_inv) ] ]) + g let rec instantiate_lambda sigma t l = match l with | [] -> t - | a::l -> - let (_, _, body) = destLambda sigma t in - instantiate_lambda sigma (subst1 a body) l + | a :: l -> + let _, _, body = destLambda sigma t in + instantiate_lambda sigma (subst1 a body) l -let whole_start concl_tac nb_args is_mes func input_type relation rec_arg_num : tactic = - begin - fun g -> - let sigma = project g in - let ids = Termops.ids_of_named_context (pf_hyps g) in - let func_body = (def_of_const (constr_of_monomorphic_global func)) in - let func_body = EConstr.of_constr func_body in - let (f_name, _, body1) = destLambda sigma func_body in - let f_id = - match f_name.binder_name with - | Name f_id -> next_ident_away_in_goal f_id ids - | Anonymous -> anomaly (Pp.str "Anonymous function.") - in - let n_names_types,_ = decompose_lam_n sigma nb_args body1 in - let n_ids,ids = - List.fold_left - (fun (n_ids,ids) (n_name,_) -> - match n_name.binder_name with - | Name id -> - let n_id = next_ident_away_in_goal id ids in - n_id::n_ids,n_id::ids - | _ -> anomaly (Pp.str "anonymous argument.") - ) - ([],(f_id::ids)) - n_names_types - in - let rec_arg_id = List.nth n_ids (rec_arg_num - 1) in - let expr = instantiate_lambda sigma func_body (mkVar f_id::(List.map mkVar n_ids)) in - termination_proof_header - is_mes - input_type - ids - n_ids - relation - rec_arg_num - rec_arg_id - (fun rec_arg_id hrec acc_id acc_inv g -> - (prove_terminate (fun infos -> tclIDTAC) - { is_main_branch = true; (* we are on the main branche (i.e. still on a match ... with .... end *) - is_final = true; (* and on leaf (more or less) *) - f_terminate = delayed_force coq_O; - nb_arg = nb_args; - concl_tac; - rec_arg_id = rec_arg_id; - is_mes = is_mes; - ih = hrec; - f_id = f_id; - f_constr = mkVar f_id; - func = func; - info = expr; - acc_inv = acc_inv; - acc_id = acc_id; - values_and_bounds = []; - eqs = []; - forbidden_ids = []; - args_assoc = [] - } - ) - g - ) - (fun b ids -> Proofview.V82.of_tactic (tclUSER_if_not_mes concl_tac b ids)) - g - end +let whole_start concl_tac nb_args is_mes func input_type relation rec_arg_num : + tactic = + fun g -> + let sigma = project g in + let ids = Termops.ids_of_named_context (pf_hyps g) in + let func_body = def_of_const (constr_of_monomorphic_global func) in + let func_body = EConstr.of_constr func_body in + let f_name, _, body1 = destLambda sigma func_body in + let f_id = + match f_name.binder_name with + | Name f_id -> next_ident_away_in_goal f_id ids + | Anonymous -> anomaly (Pp.str "Anonymous function.") + in + let n_names_types, _ = decompose_lam_n sigma nb_args body1 in + let n_ids, ids = + List.fold_left + (fun (n_ids, ids) (n_name, _) -> + match n_name.binder_name with + | Name id -> + let n_id = next_ident_away_in_goal id ids in + (n_id :: n_ids, n_id :: ids) + | _ -> anomaly (Pp.str "anonymous argument.")) + ([], f_id :: ids) + n_names_types + in + let rec_arg_id = List.nth n_ids (rec_arg_num - 1) in + let expr = + instantiate_lambda sigma func_body (mkVar f_id :: List.map mkVar n_ids) + in + termination_proof_header is_mes input_type ids n_ids relation rec_arg_num + rec_arg_id + (fun rec_arg_id hrec acc_id acc_inv g -> + (prove_terminate + (fun infos -> tclIDTAC) + { is_main_branch = true + ; (* we are on the main branche (i.e. still on a match ... with .... end *) + is_final = true + ; (* and on leaf (more or less) *) + f_terminate = delayed_force coq_O + ; nb_arg = nb_args + ; concl_tac + ; rec_arg_id + ; is_mes + ; ih = hrec + ; f_id + ; f_constr = mkVar f_id + ; func + ; info = expr + ; acc_inv + ; acc_id + ; values_and_bounds = [] + ; eqs = [] + ; forbidden_ids = [] + ; args_assoc = [] }) + g) + (fun b ids -> Proofview.V82.of_tactic (tclUSER_if_not_mes concl_tac b ids)) + g let get_current_subgoals_types pstate = - let p = Proof_global.get_proof pstate in - let Proof.{ goals=sgs; sigma; _ } = Proof.data p in - sigma, List.map (Goal.V82.abstract_type sigma) sgs + let p = Declare.Proof.get_proof pstate in + let Proof.{goals = sgs; sigma; _} = Proof.data p in + (sigma, List.map (Goal.V82.abstract_type sigma) sgs) exception EmptySubgoals + let build_and_l sigma l = - let and_constr = UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.and.type" in + let and_constr = + UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.and.type" + in let conj_constr = Coqlib.lib_ref "core.and.conj" in - let mk_and p1 p2 = - mkApp(EConstr.of_constr and_constr,[|p1;p2|]) in + let mk_and p1 p2 = mkApp (EConstr.of_constr and_constr, [|p1; p2|]) in let rec is_well_founded t = match EConstr.kind sigma t with - | Prod(_,_,t') -> is_well_founded t' - | App(_,_) -> - let (f,_) = decompose_app sigma t in - EConstr.eq_constr sigma f (well_founded ()) - | _ -> - false + | Prod (_, _, t') -> is_well_founded t' + | App (_, _) -> + let f, _ = decompose_app sigma t in + EConstr.eq_constr sigma f (well_founded ()) + | _ -> false in let compare t1 t2 = - let b1,b2= is_well_founded t1,is_well_founded t2 in - if (b1&&b2) || not (b1 || b2) then 0 - else if b1 && not b2 then 1 else -1 + let b1, b2 = (is_well_founded t1, is_well_founded t2) in + if (b1 && b2) || not (b1 || b2) then 0 else if b1 && not b2 then 1 else -1 in let l = List.sort compare l in - let rec f = function + let rec f = function | [] -> raise EmptySubgoals - | [p] -> p,tclIDTAC,1 - | p1::pl -> - let c,tac,nb = f pl in - mk_and p1 c, - tclTHENS - (Proofview.V82.of_tactic (apply (EConstr.of_constr (constr_of_monomorphic_global conj_constr)))) - [tclIDTAC; - tac - ],nb+1 - in f l - + | [p] -> (p, tclIDTAC, 1) + | p1 :: pl -> + let c, tac, nb = f pl in + ( mk_and p1 c + , tclTHENS + (Proofview.V82.of_tactic + (apply + (EConstr.of_constr (constr_of_monomorphic_global conj_constr)))) + [tclIDTAC; tac] + , nb + 1 ) + in + f l let is_rec_res id = - let rec_res_name = Id.to_string rec_res_id in + let rec_res_name = Id.to_string rec_res_id in let id_name = Id.to_string id in try - String.equal (String.sub id_name 0 (String.length rec_res_name)) rec_res_name + String.equal + (String.sub id_name 0 (String.length rec_res_name)) + rec_res_name with Invalid_argument _ -> false let clear_goals sigma = let rec clear_goal t = match EConstr.kind sigma t with - | Prod({binder_name=Name id} as na,t',b) -> - let b' = clear_goal b in - if noccurn sigma 1 b' && (is_rec_res id) - then Vars.lift (-1) b' - else if b' == b then t - else mkProd(na,t',b') - | _ -> EConstr.map sigma clear_goal t + | Prod (({binder_name = Name id} as na), t', b) -> + let b' = clear_goal b in + if noccurn sigma 1 b' && is_rec_res id then Vars.lift (-1) b' + else if b' == b then t + else mkProd (na, t', b') + | _ -> EConstr.map sigma clear_goal t in List.map clear_goal - let build_new_goal_type lemma = let sigma, sub_gls_types = Lemmas.pf_fold get_current_subgoals_types lemma in (* Pp.msgnl (str "sub_gls_types1 := " ++ Util.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) let sub_gls_types = clear_goals sigma sub_gls_types in (* Pp.msgnl (str "sub_gls_types2 := " ++ Pp.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) let res = build_and_l sigma sub_gls_types in - sigma, res + (sigma, res) let is_opaque_constant c = let cb = Global.lookup_constant c in match cb.Declarations.const_body with - | Declarations.OpaqueDef _ -> Proof_global.Opaque - | Declarations.Undef _ -> Proof_global.Opaque - | Declarations.Def _ -> Proof_global.Transparent - | Declarations.Primitive _ -> Proof_global.Opaque + | Declarations.OpaqueDef _ -> Declare.Opaque + | Declarations.Undef _ -> Declare.Opaque + | Declarations.Def _ -> Declare.Transparent + | Declarations.Primitive _ -> Declare.Opaque -let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = +let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name + (gls_type, decompose_and_tac, nb_goal) = (* Pp.msgnl (str "gls_type := " ++ Printer.pr_lconstr gls_type); *) - let current_proof_name = Lemmas.pf_fold Proof_global.get_proof_name lemma in - let name = match goal_name with + let current_proof_name = Lemmas.pf_fold Declare.Proof.get_proof_name lemma in + let name = + match goal_name with | Some s -> s - | None -> - try add_suffix current_proof_name "_subproof" - with e when CErrors.noncritical e -> - anomaly (Pp.str "open_new_goal with an unnamed theorem.") + | None -> ( + try add_suffix current_proof_name "_subproof" + with e when CErrors.noncritical e -> + anomaly (Pp.str "open_new_goal with an unnamed theorem.") ) in let na = next_global_ident_away name Id.Set.empty in if Termops.occur_existential sigma gls_type then @@ -1275,8 +1433,8 @@ let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name (gls_type let na_ref = qualid_of_ident na in let na_global = Smartlocate.global_with_alias na_ref in match na_global with - GlobRef.ConstRef c -> is_opaque_constant c - | _ -> anomaly ~label:"equation_lemma" (Pp.str "not a constant.") + | GlobRef.ConstRef c -> is_opaque_constant c + | _ -> anomaly ~label:"equation_lemma" (Pp.str "not a constant.") in let lemma = mkConst (Names.Constant.make1 (Lib.make_kn na)) in ref_ := Value (EConstr.Unsafe.to_constr lemma); @@ -1288,7 +1446,8 @@ let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name (gls_type let open Tacticals.New in Proofview.Goal.enter (fun gl -> let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gl) in - New.observe_tclTHENLIST (fun _ _ -> mt ()) + New.observe_tclTHENLIST + (fun _ _ -> mt ()) [ generalize [lemma] ; Simple.intro hid ; Proofview.Goal.enter (fun gl -> @@ -1299,195 +1458,252 @@ let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name (gls_type let ids' = pf_ids_of_hyps gl in lid := List.rev (List.subtract Id.equal ids' ids); if List.is_empty !lid then lid := [hid]; - tclIDTAC))) - ]) in + tclIDTAC))) ]) + in let end_tac = let open Tacmach.New in let open Tacticals.New in Proofview.Goal.enter (fun gl -> let sigma = project gl in match EConstr.kind sigma (pf_concl gl) with - | App(f,_) when EConstr.eq_constr sigma f (well_founded ()) -> + | App (f, _) when EConstr.eq_constr sigma f (well_founded ()) -> Auto.h_auto None [] (Some []) | _ -> incr h_num; - tclCOMPLETE( - tclFIRST - [ tclTHEN - (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings)) - e_assumption - ; Eauto.eauto_with_bases - (true,5) - [(fun _ sigma -> (sigma, (Lazy.force refl_equal)))] - [Hints.Hint_db.empty TransparentState.empty false - ] - ] - )) in + tclCOMPLETE + (tclFIRST + [ tclTHEN + (eapply_with_bindings + (mkVar (List.nth !lid !h_num), NoBindings)) + e_assumption + ; Eauto.eauto_with_bases (true, 5) + [(fun _ sigma -> (sigma, Lazy.force refl_equal))] + [Hints.Hint_db.empty TransparentState.empty false] ])) + in let lemma = build_proof env (Evd.from_env env) start_tac end_tac in Lemmas.save_lemma_proved ~lemma ~opaque:opacity ~idopt:None in let info = Lemmas.Info.make ~hook:(DeclareDef.Hook.make hook) () in - let lemma = Lemmas.start_lemma - ~name:na - ~poly:false (* FIXME *) ~info - sigma gls_type in - let lemma = if Indfun_common.is_strict_tcc () - then - fst @@ Lemmas.by (Proofview.V82.tactic (tclIDTAC)) lemma - else - fst @@ Lemmas.by (Proofview.V82.tactic begin - fun g -> - tclTHEN - (decompose_and_tac) - (tclORELSE - (tclFIRST - (List.map - (fun c -> - Proofview.V82.of_tactic (Tacticals.New.tclTHENLIST - [intros; - Simple.apply (fst (interp_constr (Global.env()) Evd.empty c)) (*FIXME*); - Tacticals.New.tclCOMPLETE Auto.default_auto - ]) - ) - using_lemmas) - ) tclIDTAC) - g end) lemma + let lemma = + Lemmas.start_lemma ~name:na ~poly:false (* FIXME *) ~info sigma gls_type + in + let lemma = + if Indfun_common.is_strict_tcc () then + fst @@ Lemmas.by (Proofview.V82.tactic tclIDTAC) lemma + else + fst + @@ Lemmas.by + (Proofview.V82.tactic (fun g -> + tclTHEN decompose_and_tac + (tclORELSE + (tclFIRST + (List.map + (fun c -> + Proofview.V82.of_tactic + (Tacticals.New.tclTHENLIST + [ intros + ; Simple.apply + (fst + (interp_constr (Global.env ()) + Evd.empty c)) + (*FIXME*) + ; Tacticals.New.tclCOMPLETE Auto.default_auto + ])) + using_lemmas)) + tclIDTAC) + g)) + lemma in - if Lemmas.(pf_fold Proof_global.get_open_goals) lemma = 0 then (defined lemma; None) else Some lemma - -let com_terminate - interactive_proof - tcc_lemma_name - tcc_lemma_ref - is_mes - fonctional_ref - input_type - relation - rec_arg_num - thm_name using_lemmas - nb_args ctx - hook = + if Lemmas.(pf_fold Declare.Proof.get_open_goals) lemma = 0 then ( + defined lemma; None ) + else Some lemma + +let com_terminate interactive_proof tcc_lemma_name tcc_lemma_ref is_mes + fonctional_ref input_type relation rec_arg_num thm_name using_lemmas nb_args + ctx hook = let start_proof env ctx tac_start tac_end = let info = Lemmas.Info.make ~hook () in - let lemma = Lemmas.start_lemma ~name:thm_name - ~poly:false (*FIXME*) - ~info - ctx - (EConstr.of_constr (compute_terminate_type nb_args fonctional_ref)) in - let lemma = fst @@ Lemmas.by (New.observe_tac (fun _ _ -> str "starting_tac") tac_start) lemma in - fst @@ Lemmas.by (Proofview.V82.tactic (observe_tac (fun _ _ -> str "whole_start") (whole_start tac_end nb_args is_mes fonctional_ref - input_type relation rec_arg_num ))) lemma + let lemma = + Lemmas.start_lemma ~name:thm_name ~poly:false (*FIXME*) ~info ctx + (EConstr.of_constr (compute_terminate_type nb_args fonctional_ref)) + in + let lemma = + fst + @@ Lemmas.by + (New.observe_tac (fun _ _ -> str "starting_tac") tac_start) + lemma + in + fst + @@ Lemmas.by + (Proofview.V82.tactic + (observe_tac + (fun _ _ -> str "whole_start") + (whole_start tac_end nb_args is_mes fonctional_ref input_type + relation rec_arg_num))) + lemma + in + let lemma = + start_proof + Global.(env ()) + ctx Tacticals.New.tclIDTAC Tacticals.New.tclIDTAC in - let lemma = start_proof Global.(env ()) ctx Tacticals.New.tclIDTAC Tacticals.New.tclIDTAC in try let sigma, new_goal_type = build_new_goal_type lemma in let sigma = Evd.from_ctx (Evd.evar_universe_context sigma) in - open_new_goal ~lemma start_proof sigma - using_lemmas tcc_lemma_ref - (Some tcc_lemma_name) - (new_goal_type) + open_new_goal ~lemma start_proof sigma using_lemmas tcc_lemma_ref + (Some tcc_lemma_name) new_goal_type with EmptySubgoals -> (* a non recursive function declared with measure ! *) tcc_lemma_ref := Not_needed; - if interactive_proof then Some lemma - else (defined lemma; None) + if interactive_proof then Some lemma else (defined lemma; None) -let start_equation (f:GlobRef.t) (term_f:GlobRef.t) - (cont_tactic:Id.t list -> tactic) g = +let start_equation (f : GlobRef.t) (term_f : GlobRef.t) + (cont_tactic : Id.t list -> tactic) g = let sigma = project g in let ids = pf_ids_of_hyps g in let terminate_constr = constr_of_monomorphic_global term_f in let terminate_constr = EConstr.of_constr terminate_constr in - let nargs = nb_prod (project g) (EConstr.of_constr (type_of_const sigma terminate_constr)) in + let nargs = + nb_prod (project g) + (EConstr.of_constr (type_of_const sigma terminate_constr)) + in let x = n_x_id ids nargs in - observe_tac (fun _ _ -> str "start_equation") (observe_tclTHENLIST (fun _ _ -> str "start_equation") [ - h_intros x; - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference f)]); - observe_tac (fun _ _ -> str "simplest_case") - (Proofview.V82.of_tactic (simplest_case (mkApp (terminate_constr, - Array.of_list (List.map mkVar x))))); - observe_tac (fun _ _ -> str "prove_eq") (cont_tactic x)]) g;; - -let com_eqn uctx nb_arg eq_name functional_ref f_ref terminate_ref equation_lemma_type = - let open CVars in - let opacity = - match terminate_ref with - | GlobRef.ConstRef c -> is_opaque_constant c - | _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant.") - in - let evd = Evd.from_ctx uctx in - let f_constr = constr_of_monomorphic_global f_ref in - let equation_lemma_type = subst1 f_constr equation_lemma_type in - let lemma = Lemmas.start_lemma ~name:eq_name ~poly:false evd - (EConstr.of_constr equation_lemma_type) in - let lemma = fst @@ Lemmas.by - (Proofview.V82.tactic (start_equation f_ref terminate_ref - (fun x -> - prove_eq (fun _ -> tclIDTAC) - {nb_arg=nb_arg; - f_terminate = EConstr.of_constr (constr_of_monomorphic_global terminate_ref); - f_constr = EConstr.of_constr f_constr; - concl_tac = Tacticals.New.tclIDTAC; - func=functional_ref; - info=(instantiate_lambda Evd.empty - (EConstr.of_constr (def_of_const (constr_of_monomorphic_global functional_ref))) - (EConstr.of_constr f_constr::List.map mkVar x) - ); - is_main_branch = true; - is_final = true; - values_and_bounds = []; - eqs = []; - forbidden_ids = []; - acc_inv = lazy (assert false); - acc_id = Id.of_string "____"; - args_assoc = []; - f_id = Id.of_string "______"; - rec_arg_id = Id.of_string "______"; - is_mes = false; - ih = Id.of_string "______"; - } - ) - )) lemma in - let _ = Flags.silently (fun () -> Lemmas.save_lemma_proved ~lemma ~opaque:opacity ~idopt:None) () in - () -(* Pp.msgnl (fun _ _ -> str "eqn finished"); *) + observe_tac + (fun _ _ -> str "start_equation") + (observe_tclTHENLIST + (fun _ _ -> str "start_equation") + [ h_intros x + ; Proofview.V82.of_tactic + (unfold_in_concl + [(Locus.AllOccurrences, evaluable_of_global_reference f)]) + ; observe_tac + (fun _ _ -> str "simplest_case") + (Proofview.V82.of_tactic + (simplest_case + (mkApp (terminate_constr, Array.of_list (List.map mkVar x))))) + ; observe_tac (fun _ _ -> str "prove_eq") (cont_tactic x) ]) + g +let com_eqn uctx nb_arg eq_name functional_ref f_ref terminate_ref + equation_lemma_type = + let open CVars in + let opacity = + match terminate_ref with + | GlobRef.ConstRef c -> is_opaque_constant c + | _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant.") + in + let evd = Evd.from_ctx uctx in + let f_constr = constr_of_monomorphic_global f_ref in + let equation_lemma_type = subst1 f_constr equation_lemma_type in + let lemma = + Lemmas.start_lemma ~name:eq_name ~poly:false evd + (EConstr.of_constr equation_lemma_type) + in + let lemma = + fst + @@ Lemmas.by + (Proofview.V82.tactic + (start_equation f_ref terminate_ref (fun x -> + prove_eq + (fun _ -> tclIDTAC) + { nb_arg + ; f_terminate = + EConstr.of_constr + (constr_of_monomorphic_global terminate_ref) + ; f_constr = EConstr.of_constr f_constr + ; concl_tac = Tacticals.New.tclIDTAC + ; func = functional_ref + ; info = + instantiate_lambda Evd.empty + (EConstr.of_constr + (def_of_const + (constr_of_monomorphic_global functional_ref))) + (EConstr.of_constr f_constr :: List.map mkVar x) + ; is_main_branch = true + ; is_final = true + ; values_and_bounds = [] + ; eqs = [] + ; forbidden_ids = [] + ; acc_inv = lazy (assert false) + ; acc_id = Id.of_string "____" + ; args_assoc = [] + ; f_id = Id.of_string "______" + ; rec_arg_id = Id.of_string "______" + ; is_mes = false + ; ih = Id.of_string "______" }))) + lemma + in + let _ = + Flags.silently + (fun () -> Lemmas.save_lemma_proved ~lemma ~opaque:opacity ~idopt:None) + () + in + () -let recursive_definition ~interactive_proof ~is_mes function_name rec_impls type_of_f r rec_arg_num eq - generate_induction_principle using_lemmas : Lemmas.t option = +(* Pp.msgnl (fun _ _ -> str "eqn finished"); *) + +let recursive_definition ~interactive_proof ~is_mes function_name rec_impls + type_of_f r rec_arg_num eq generate_induction_principle using_lemmas : + Lemmas.t option = let open Term in let open Constr in let open CVars in - let env = Global.env() in + let env = Global.env () in let evd = Evd.from_env env in - let evd, function_type = interp_type_evars ~program_mode:false env evd type_of_f in - let function_r = Sorts.Relevant in (* TODO relevance *) - let env = EConstr.push_named (Context.Named.Declaration.LocalAssum (make_annot function_name function_r,function_type)) env in + let evd, function_type = + interp_type_evars ~program_mode:false env evd type_of_f + in + let function_r = Sorts.Relevant in + (* TODO relevance *) + let env = + EConstr.push_named + (Context.Named.Declaration.LocalAssum + (make_annot function_name function_r, function_type)) + env + in (* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *) - let evd, ty = interp_type_evars ~program_mode:false env evd ~impls:rec_impls eq in + let evd, ty = + interp_type_evars ~program_mode:false env evd ~impls:rec_impls eq + in let evd = Evd.minimize_universes evd in - let equation_lemma_type = Reductionops.nf_betaiotazeta env evd (Evarutil.nf_evar evd ty) in - let function_type = EConstr.to_constr ~abort_on_undefined_evars:false evd function_type in + let equation_lemma_type = + Reductionops.nf_betaiotazeta env evd (Evarutil.nf_evar evd ty) + in + let function_type = + EConstr.to_constr ~abort_on_undefined_evars:false evd function_type + in let equation_lemma_type = EConstr.Unsafe.to_constr equation_lemma_type in - (* Pp.msgnl (fun _ _ -> str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *) - let res_vars,eq' = decompose_prod equation_lemma_type in - let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> LocalAssum (x,y)) res_vars) env in + (* Pp.msgnl (fun _ _ -> str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *) + let res_vars, eq' = decompose_prod equation_lemma_type in + let env_eq' = + Environ.push_rel_context + (List.map (fun (x, y) -> LocalAssum (x, y)) res_vars) + env + in let eq' = Reductionops.nf_zeta env_eq' evd (EConstr.of_constr eq') in let eq' = EConstr.Unsafe.to_constr eq' in let res = -(* Pp.msgnl (fun _ _ -> str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *) -(* Pp.msgnl (fun _ _ -> str "rec_arg_num := " ++ str (fun _ _ -> string_of_int rec_arg_num)); *) -(* Pp.msgnl (fun _ _ -> str "eq' := " ++ str (fun _ _ -> string_of_int rec_arg_num)); *) + (* Pp.msgnl (fun _ _ -> str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *) + (* Pp.msgnl (fun _ _ -> str "rec_arg_num := " ++ str (fun _ _ -> string_of_int rec_arg_num)); *) + (* Pp.msgnl (fun _ _ -> str "eq' := " ++ str (fun _ _ -> string_of_int rec_arg_num)); *) match Constr.kind eq' with - | App(e,[|_;_;eq_fix|]) -> - mkLambda (make_annot (Name function_name) Sorts.Relevant,function_type,subst_var function_name (compose_lam res_vars eq_fix)) - | _ -> failwith "Recursive Definition (res not eq)" + | App (e, [|_; _; eq_fix|]) -> + mkLambda + ( make_annot (Name function_name) Sorts.Relevant + , function_type + , subst_var function_name (compose_lam res_vars eq_fix) ) + | _ -> failwith "Recursive Definition (res not eq)" + in + let pre_rec_args, function_type_before_rec_arg = + decompose_prod_n (rec_arg_num - 1) function_type + in + let _, rec_arg_type, _ = destProd function_type_before_rec_arg in + let arg_types = + List.rev_map snd + (fst (decompose_prod_n (List.length res_vars) function_type)) in - let pre_rec_args,function_type_before_rec_arg = decompose_prod_n (rec_arg_num - 1) function_type in - let (_, rec_arg_type, _) = destProd function_type_before_rec_arg in - let arg_types = List.rev_map snd (fst (decompose_prod_n (List.length res_vars) function_type)) in let equation_id = add_suffix function_name "_equation" in - let functional_id = add_suffix function_name "_F" in + let functional_id = add_suffix function_name "_F" in let term_id = add_suffix function_name "_terminate" in let functional_ref = let univs = Evd.univ_entry ~poly:false evd in @@ -1495,57 +1711,61 @@ let recursive_definition ~interactive_proof ~is_mes function_name rec_impls type in (* Refresh the global universes, now including those of _F *) let evd = Evd.from_env (Global.env ()) in - let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> LocalAssum (x,t)) pre_rec_args) env in - let relation, evuctx = - interp_constr env_with_pre_rec_args evd r + let env_with_pre_rec_args = + push_rel_context + (List.map (function x, t -> LocalAssum (x, t)) pre_rec_args) + env in + let relation, evuctx = interp_constr env_with_pre_rec_args evd r in let evd = Evd.from_ctx evuctx in let tcc_lemma_name = add_suffix function_name "_tcc" in let tcc_lemma_constr = ref Undefined in (* let _ = Pp.msgnl (fun _ _ -> str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *) - let hook { DeclareDef.Hook.S.uctx ; _ } = + let hook {DeclareDef.Hook.S.uctx; _} = let term_ref = Nametab.locate (qualid_of_ident term_id) in - let f_ref = declare_f function_name Decls.(IsProof Lemma) arg_types term_ref in - let _ = Extraction_plugin.Table.extraction_inline true [qualid_of_ident term_id] in + let f_ref = + declare_f function_name Decls.(IsProof Lemma) arg_types term_ref + in + let _ = + Extraction_plugin.Table.extraction_inline true [qualid_of_ident term_id] + in (* message "start second proof"; *) let stop = (* XXX: What is the correct way to get sign at hook time *) try - com_eqn uctx (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type); + com_eqn uctx (List.length res_vars) equation_id functional_ref f_ref + term_ref + (subst_var function_name equation_lemma_type); false with e when CErrors.noncritical e -> - begin - if do_observe () - then Feedback.msg_debug (str "Cannot create equation Lemma " ++ CErrors.print e) - else CErrors.user_err ~hdr:"Cannot create equation Lemma" - (str "Cannot create equation lemma." ++ spc () ++ - str "This may be because the function is nested-recursive.") - ; - true - end + if do_observe () then + Feedback.msg_debug + (str "Cannot create equation Lemma " ++ CErrors.print e) + else + CErrors.user_err ~hdr:"Cannot create equation Lemma" + ( str "Cannot create equation lemma." + ++ spc () + ++ str "This may be because the function is nested-recursive." ); + true in - if not stop - then - let eq_ref = Nametab.locate (qualid_of_ident equation_id ) in + if not stop then + let eq_ref = Nametab.locate (qualid_of_ident equation_id) in let f_ref = destConst (constr_of_monomorphic_global f_ref) - and functional_ref = destConst (constr_of_monomorphic_global functional_ref) + and functional_ref = + destConst (constr_of_monomorphic_global functional_ref) and eq_ref = destConst (constr_of_monomorphic_global eq_ref) in - generate_induction_principle f_ref tcc_lemma_constr - functional_ref eq_ref rec_arg_num + generate_induction_principle f_ref tcc_lemma_constr functional_ref eq_ref + rec_arg_num (EConstr.of_constr rec_arg_type) - (nb_prod evd (EConstr.of_constr res)) relation + (nb_prod evd (EConstr.of_constr res)) + relation in (* XXX STATE Why do we need this... why is the toplevel protection not enough *) - funind_purify (fun () -> - com_terminate - interactive_proof - tcc_lemma_name - tcc_lemma_constr - is_mes functional_ref + funind_purify + (fun () -> + com_terminate interactive_proof tcc_lemma_name tcc_lemma_constr is_mes + functional_ref (EConstr.of_constr rec_arg_type) - relation rec_arg_num - term_id - using_lemmas - (List.length res_vars) - evd (DeclareDef.Hook.make hook)) + relation rec_arg_num term_id using_lemmas (List.length res_vars) evd + (DeclareDef.Hook.make hook)) () diff --git a/plugins/funind/recdef.mli b/plugins/funind/recdef.mli index 3225411c85..4e5146e37c 100644 --- a/plugins/funind/recdef.mli +++ b/plugins/funind/recdef.mli @@ -1,13 +1,13 @@ open Constr -val tclUSER_if_not_mes - : unit Proofview.tactic +val tclUSER_if_not_mes : + unit Proofview.tactic -> bool -> Names.Id.t list option -> unit Proofview.tactic -val recursive_definition - : interactive_proof:bool +val recursive_definition : + interactive_proof:bool -> is_mes:bool -> Names.Id.t -> Constrintern.internalization_env @@ -15,7 +15,14 @@ val recursive_definition -> Constrexpr.constr_expr -> int -> Constrexpr.constr_expr - -> (pconstant -> Indfun_common.tcc_lemma_value ref -> pconstant -> - pconstant -> int -> EConstr.types -> int -> EConstr.constr -> unit) + -> ( pconstant + -> Indfun_common.tcc_lemma_value ref + -> pconstant + -> pconstant + -> int + -> EConstr.types + -> int + -> EConstr.constr + -> unit) -> Constrexpr.constr_expr list -> Lemmas.t option diff --git a/plugins/ltac/plugin_base.dune b/plugins/ltac/dune index 5611f5ba16..6558ecbfe8 100644 --- a/plugins/ltac/plugin_base.dune +++ b/plugins/ltac/dune @@ -11,3 +11,5 @@ (synopsis "Coq's tauto tactic") (modules tauto) (libraries coq.plugins.ltac)) + +(coq.pp (modules extratactics g_tactic g_rewrite g_eqdecide g_auto g_obligations g_ltac profile_ltac_tactics coretactics g_class extraargs)) diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 9b80cbd803..0bad3cbe5b 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -47,7 +47,7 @@ DECLARE PLUGIN "ltac_plugin" let with_delayed_uconstr ist c tac = let flags = { - Pretyping.use_typeclasses = false; + Pretyping.use_typeclasses = Pretyping.NoUseTC; solve_unification_constraints = true; fail_evar = false; expand_evars = true; @@ -312,7 +312,7 @@ let add_rewrite_hint ~poly bases ort t lcsr = if poly then ctx else (* This is a global universe context that shouldn't be refreshed at every use of the hint, declare it globally. *) - (Declare.declare_universe_context ~poly:false ctx; + (DeclareUctx.declare_universe_context ~poly:false ctx; Univ.ContextSet.empty) in CAst.make ?loc:(Constrexpr_ops.constr_loc ce) ((c, ctx), ort, Option.map (in_gen (rawwit wit_ltac)) t) in @@ -345,8 +345,8 @@ open EConstr open Vars let constr_flags () = { - Pretyping.use_typeclasses = true; - Pretyping.solve_unification_constraints = Pfedit.use_unification_heuristics (); + Pretyping.use_typeclasses = Pretyping.UseTC; + Pretyping.solve_unification_constraints = Proof.use_unification_heuristics (); Pretyping.fail_evar = false; Pretyping.expand_evars = true; Pretyping.program_mode = false; @@ -375,22 +375,22 @@ let refine_tac ist simple with_classes c = TACTIC EXTEND refine | [ "refine" uconstr(c) ] -> - { refine_tac ist false true c } + { refine_tac ist false Pretyping.UseTC c } END TACTIC EXTEND simple_refine | [ "simple" "refine" uconstr(c) ] -> - { refine_tac ist true true c } + { refine_tac ist true Pretyping.UseTC c } END TACTIC EXTEND notcs_refine | [ "notypeclasses" "refine" uconstr(c) ] -> - { refine_tac ist false false c } + { refine_tac ist false Pretyping.NoUseTC c } END TACTIC EXTEND notcs_simple_refine | [ "simple" "notypeclasses" "refine" uconstr(c) ] -> - { refine_tac ist true false c } + { refine_tac ist true Pretyping.NoUseTC c } END (* Solve unification constraints using heuristics or fail if any remain *) @@ -918,7 +918,7 @@ END VERNAC COMMAND EXTEND GrabEvars STATE proof | [ "Grab" "Existential" "Variables" ] => { classify_as_proofstep } - -> { fun ~pstate -> Proof_global.map_proof (fun p -> Proof.V82.grab_evars p) pstate } + -> { fun ~pstate -> Declare.Proof.map_proof (fun p -> Proof.V82.grab_evars p) pstate } END (* Shelves all the goals under focus. *) @@ -950,7 +950,7 @@ END VERNAC COMMAND EXTEND Unshelve STATE proof | [ "Unshelve" ] => { classify_as_proofstep } - -> { fun ~pstate -> Proof_global.map_proof (fun p -> Proof.unshelve p) pstate } + -> { fun ~pstate -> Declare.Proof.map_proof (fun p -> Proof.unshelve p) pstate } END (* Gives up on the goals under focus: the goals are considered solved, @@ -1102,7 +1102,7 @@ END VERNAC COMMAND EXTEND OptimizeProof | ![ proof ] [ "Optimize" "Proof" ] => { classify_as_proofstep } -> - { fun ~pstate -> Proof_global.compact_the_proof pstate } + { fun ~pstate -> Declare.Proof.compact pstate } | [ "Optimize" "Heap" ] => { classify_as_proofstep } -> { Gc.compact () } END diff --git a/plugins/ltac/g_auto.mlg b/plugins/ltac/g_auto.mlg index 3c30c881fb..b4527694ae 100644 --- a/plugins/ltac/g_auto.mlg +++ b/plugins/ltac/g_auto.mlg @@ -53,7 +53,7 @@ END let eval_uconstrs ist cs = let flags = { - Pretyping.use_typeclasses = false; + Pretyping.use_typeclasses = Pretyping.NoUseTC; solve_unification_constraints = true; fail_evar = false; expand_evars = true; diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index 50c3ed1248..5baa23b3e9 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -342,7 +342,7 @@ GRAMMAR EXTEND Gram hint: [ [ IDENT "Extern"; n = natural; c = OPT Constr.constr_pattern ; "=>"; tac = Pltac.tactic -> - { Hints.HintsExtern (n,c, in_tac tac) } ] ] + { ComHints.HintsExtern (n,c, in_tac tac) } ] ] ; operconstr: LEVEL "0" [ [ IDENT "ltac"; ":"; "("; tac = Pltac.tactic_expr; ")" -> @@ -359,23 +359,17 @@ open Vernacextend open Goptions open Libnames -let print_info_trace = ref None - -let () = declare_int_option { - optdepr = false; - optkey = ["Info" ; "Level"]; - optread = (fun () -> !print_info_trace); - optwrite = fun n -> print_info_trace := n; -} +let print_info_trace = + declare_intopt_option_and_ref ~depr:false ~key:["Info" ; "Level"] let vernac_solve ~pstate n info tcom b = let open Goal_select in - let pstate, status = Proof_global.map_fold_proof_endline (fun etac p -> + let pstate, status = Declare.Proof.map_fold_proof_endline (fun etac p -> let with_end_tac = if b then Some etac else None in let global = match n with SelectAll | SelectList _ -> true | _ -> false in - let info = Option.append info !print_info_trace in + let info = Option.append info (print_info_trace ()) in let (p,status) = - Pfedit.solve n info (Tacinterp.hide_interp global tcom None) ?with_end_tac p + Proof.solve n info (Tacinterp.hide_interp global tcom None) ?with_end_tac p in (* in case a strict subtree was completed, go back to the top of the prooftree *) diff --git a/tactics/leminv.ml b/plugins/ltac/leminv.ml index 5a8ec404ee..5a8ec404ee 100644 --- a/tactics/leminv.ml +++ b/plugins/ltac/leminv.ml diff --git a/tactics/leminv.mli b/plugins/ltac/leminv.mli index 5a5de7b58f..5a5de7b58f 100644 --- a/tactics/leminv.mli +++ b/plugins/ltac/leminv.mli diff --git a/plugins/ltac/ltac_plugin.mlpack b/plugins/ltac/ltac_plugin.mlpack index e83eab20dc..f31361279c 100644 --- a/plugins/ltac/ltac_plugin.mlpack +++ b/plugins/ltac/ltac_plugin.mlpack @@ -9,6 +9,7 @@ Tactic_debug Tacintern Profile_ltac Tactic_matching +Leminv Tacinterp Tacentries Evar_tactics diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 321b05b97c..3834b21a14 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -639,7 +639,7 @@ let solve_remaining_by env sigma holes by = let env = Environ.reset_with_named_context evi.evar_hyps env in let ty = evi.evar_concl in let name, poly = Id.of_string "rewrite", false in - let c, sigma = Pfedit.refine_by_tactic ~name ~poly env sigma ty solve_tac in + let c, sigma = Proof.refine_by_tactic ~name ~poly env sigma ty solve_tac in Evd.define evk (EConstr.of_constr c) sigma in List.fold_left solve sigma indep @@ -952,10 +952,11 @@ let fold_match env sigma c = then case_dep_scheme_kind_from_type else case_scheme_kind_from_type) in - let exists = Ind_tables.check_scheme sk ci.ci_ind in - if exists then - dep, pred, exists, Ind_tables.lookup_scheme sk ci.ci_ind - else raise Not_found + match Ind_tables.lookup_scheme sk ci.ci_ind with + | Some cst -> + dep, pred, true, cst + | None -> + raise Not_found in let app = let ind, args = Inductiveops.find_mrectype env sigma cty in @@ -1559,7 +1560,7 @@ let assert_replacing id newt tac = if Id.equal n id then ev' else mkVar n in let (e, _) = destEvar sigma ev in - (sigma, mkEvar (e, Array.map_of_list map nc)) + (sigma, mkEvar (e, List.map map nc)) end end in Proofview.tclTHEN prf (Proofview.tclFOCUS 2 2 tac) @@ -1864,14 +1865,14 @@ let proper_projection env sigma r ty = Array.append args [| instarg |]) in it_mkLambda_or_LetIn app ctx -let declare_projection n instance_id r = +let declare_projection name instance_id r = let poly = Global.is_polymorphic r in let env = Global.env () in let sigma = Evd.from_env env in let sigma,c = Evd.fresh_global env sigma r in let ty = Retyping.get_type_of env sigma c in - let term = proper_projection env sigma c ty in - let sigma, typ = Typing.type_of env sigma term in + let body = proper_projection env sigma c ty in + let sigma, typ = Typing.type_of env sigma body in let ctx, typ = decompose_prod_assum sigma typ in let typ = let n = @@ -1892,14 +1893,11 @@ let declare_projection n instance_id r = let ctx,ccl = Reductionops.splay_prod_n env sigma (3 * n) typ in it_mkProd_or_LetIn ccl ctx in - let typ = it_mkProd_or_LetIn typ ctx in - let univs = Evd.univ_entry ~poly sigma in - let typ = EConstr.to_constr sigma typ in - let term = EConstr.to_constr sigma term in - let cst = Declare.definition_entry ~types:typ ~univs term in - let _ : Constant.t = - Declare.declare_constant ~name:n ~kind:Decls.(IsDefinition Definition) - (Declare.DefinitionEntry cst) + let types = Some (it_mkProd_or_LetIn typ ctx) in + let kind, opaque, scope = Decls.(IsDefinition Definition), false, DeclareDef.Global Declare.ImportDefaultBehavior in + let impargs, udecl = [], UState.default_univ_decl in + let _r : GlobRef.t = + DeclareDef.declare_definition ~name ~scope ~kind ~opaque ~impargs ~udecl ~poly ~types ~body sigma in () let build_morphism_signature env sigma m = @@ -1927,10 +1925,7 @@ let build_morphism_signature env sigma m = in let morph = e_app_poly env evd (PropGlobal.proper_type env) [| t; sig_; m |] in let evd = solve_constraints env !evd in - let evd = Evd.minimize_universes evd in - let m = Evarutil.nf_evars_universes evd (EConstr.Unsafe.to_constr morph) in - Pretyping.check_evars env evd (EConstr.of_constr m); - Evd.evar_universe_context evd, m + evd, morph let default_morphism sign m = let env = Global.env () in @@ -1965,22 +1960,24 @@ let add_morphism_as_parameter atts m n : unit = let instance_id = add_suffix n "_Proper" in let env = Global.env () in let evd = Evd.from_env env in - let uctx, instance = build_morphism_signature env evd m in - let uctx = UState.univ_entry ~poly:atts.polymorphic uctx in - let cst = Declare.declare_constant ~name:instance_id - ~kind:Decls.(IsAssumption Logical) - (Declare.ParameterEntry (None,(instance,uctx),None)) - in - Classes.add_instance (Classes.mk_instance - (PropGlobal.proper_class env evd) Hints.empty_hint_info atts.global (GlobRef.ConstRef cst)); - declare_projection n instance_id (GlobRef.ConstRef cst) + let poly = atts.polymorphic in + let kind, opaque, scope = Decls.(IsAssumption Logical), false, DeclareDef.Global Declare.ImportDefaultBehavior in + let impargs, udecl = [], UState.default_univ_decl in + let evd, types = build_morphism_signature env evd m in + let evd, pe = DeclareDef.prepare_parameter ~poly ~udecl ~types evd in + let cst = Declare.declare_constant ~name:instance_id ~kind (Declare.ParameterEntry pe) in + let cst = GlobRef.ConstRef cst in + Classes.add_instance + (Classes.mk_instance + (PropGlobal.proper_class env evd) Hints.empty_hint_info atts.global cst); + declare_projection n instance_id cst let add_morphism_interactive atts m n : Lemmas.t = init_setoid (); let instance_id = add_suffix n "_Proper" in let env = Global.env () in let evd = Evd.from_env env in - let uctx, instance = build_morphism_signature env evd m in + let evd, morph = build_morphism_signature env evd m in let poly = atts.polymorphic in let kind = Decls.(IsDefinition Instance) in let tac = make_tactic "Coq.Classes.SetoidTactics.add_morphism_tactic" in @@ -1996,7 +1993,7 @@ let add_morphism_interactive atts m n : Lemmas.t = let info = Lemmas.Info.make ~hook ~kind () in Flags.silently (fun () -> - let lemma = Lemmas.start_lemma ~name:instance_id ~poly ~info (Evd.from_ctx uctx) (EConstr.of_constr instance) in + let lemma = Lemmas.start_lemma ~name:instance_id ~poly ~info evd morph in fst (Lemmas.by (Tacinterp.interp tac) lemma)) () let add_morphism atts binders m s n = diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index 4127d28bae..9910796d9c 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -299,7 +299,7 @@ let classify_tactic_notation tacobj = Substitute tacobj let inTacticGrammar : tactic_grammar_obj -> obj = declare_object {(default_object "TacticGrammar") with - open_function = open_tactic_notation; + open_function = simple_open open_tactic_notation; load_function = load_tactic_notation; cache_function = cache_tactic_notation; subst_function = subst_tactic_notation; diff --git a/plugins/ltac/tacenv.ml b/plugins/ltac/tacenv.ml index ce9189792e..76d47f5482 100644 --- a/plugins/ltac/tacenv.ml +++ b/plugins/ltac/tacenv.ml @@ -182,7 +182,7 @@ let inMD : bool * ltac_constant option * bool * glob_tactic_expr * declare_object {(default_object "TAC-DEFINITION") with cache_function = cache_md; load_function = load_md; - open_function = open_md; + open_function = simple_open open_md; subst_function = subst_md; classify_function = classify_md} diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 9e0b9d3254..dda7f0742c 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -546,7 +546,7 @@ let interp_gen kind ist pattern_mode flags env sigma c = (evd,c) let constr_flags () = { - use_typeclasses = true; + use_typeclasses = UseTC; solve_unification_constraints = true; fail_evar = true; expand_evars = true; @@ -564,7 +564,7 @@ let interp_constr = interp_constr_gen WithoutTypeConstraint let interp_type = interp_constr_gen IsType let open_constr_use_classes_flags () = { - use_typeclasses = true; + use_typeclasses = UseTC; solve_unification_constraints = true; fail_evar = false; expand_evars = true; @@ -573,7 +573,7 @@ let open_constr_use_classes_flags () = { } let open_constr_no_classes_flags () = { - use_typeclasses = false; + use_typeclasses = NoUseTC; solve_unification_constraints = true; fail_evar = false; expand_evars = true; @@ -582,7 +582,7 @@ let open_constr_no_classes_flags () = { } let pure_open_constr_flags = { - use_typeclasses = false; + use_typeclasses = NoUseTC; solve_unification_constraints = true; fail_evar = false; expand_evars = false; @@ -2070,7 +2070,7 @@ let _ = *) let name, poly = Id.of_string "ltac_gen", poly in let name, poly = Id.of_string "ltac_gen", poly in - let (c, sigma) = Pfedit.refine_by_tactic ~name ~poly env sigma ty tac in + let (c, sigma) = Proof.refine_by_tactic ~name ~poly env sigma ty tac in (EConstr.of_constr c, sigma) in GlobEnv.register_constr_interp0 wit_tactic eval diff --git a/plugins/ltac/tactic_option.ml b/plugins/ltac/tactic_option.ml index c72a527537..922d2f7792 100644 --- a/plugins/ltac/tactic_option.ml +++ b/plugins/ltac/tactic_option.ml @@ -13,15 +13,11 @@ open Pp let declare_tactic_option ?(default=Tacexpr.TacId []) name = let locality = Summary.ref false ~name:(name^"-locality") in - let default_tactic_expr : Tacexpr.glob_tactic_expr ref = - Summary.ref default ~name:(name^"-default-tacexpr") - in let default_tactic : Tacexpr.glob_tactic_expr ref = - Summary.ref !default_tactic_expr ~name:(name^"-default-tactic") + Summary.ref default ~name:(name^"-default-tactic") in let set_default_tactic local t = locality := local; - default_tactic_expr := t; default_tactic := t in let cache (_, (local, tac)) = set_default_tactic local tac in @@ -36,18 +32,17 @@ let declare_tactic_option ?(default=Tacexpr.TacId []) name = { (default_object name) with cache_function = cache; load_function = (fun _ -> load); - open_function = (fun _ -> load); + open_function = simple_open (fun _ -> load); classify_function = (fun (local, tac) -> if local then Dispose else Substitute (local, tac)); subst_function = subst} in let put local tac = - set_default_tactic local tac; Lib.add_anonymous_leaf (input (local, tac)) in let get () = !locality, Tacinterp.eval_tactic !default_tactic in let print () = - Pptactic.pr_glob_tactic (Global.env ()) !default_tactic_expr ++ + Pptactic.pr_glob_tactic (Global.env ()) !default_tactic ++ (if !locality then str" (locally defined)" else str" (globally defined)") in put, get, print diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index 1958fff4cc..9eeba614c7 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -27,7 +27,13 @@ open NumCompat open Q.Notations open Mutils -let use_simplex = ref true +let use_simplex = + Goptions.declare_bool_option_and_ref ~depr:false ~key:["Simplex"] ~value:true + +(* If set to some [file], arithmetic goals are dumped in [file].v *) + +let dump_file = + Goptions.declare_stringopt_option_and_ref ~depr:false ~key:["Dump"; "Arith"] type ('prf, 'model) res = Prf of 'prf | Model of 'model | Unknown type zres = (Mc.zArithProof, int * Mc.z list) res @@ -203,19 +209,19 @@ let fourier_linear_prover l = | Inl _ -> None let direct_linear_prover l = - if !use_simplex then Simplex.find_unsat_certificate l + if use_simplex () then Simplex.find_unsat_certificate l else fourier_linear_prover l let find_point l = let open Util in - if !use_simplex then Simplex.find_point l + if use_simplex () then Simplex.find_point l else match Mfourier.Fourier.find_point l with | Inr _ -> None | Inl cert -> Some cert let optimise v l = - if !use_simplex then Simplex.optimise v l else Mfourier.Fourier.optimise v l + if use_simplex () then Simplex.optimise v l else Mfourier.Fourier.optimise v l let dual_raw_certificate l = if debug then begin @@ -981,13 +987,11 @@ let xlia_simplex env red sys = with FoundProof prf -> compile_prf sys (Step (0, prf, Done)) let xlia env0 en red sys = - if !use_simplex then xlia_simplex env0 red sys else xlia en red sys - -let dump_file = ref None + if use_simplex () then xlia_simplex env0 red sys else xlia en red sys let gen_bench (tac, prover) can_enum prfdepth sys = let res = prover can_enum prfdepth sys in - ( match !dump_file with + ( match dump_file () with | None -> () | Some file -> let o = open_out (Filename.temp_file ~temp_dir:(Sys.getcwd ()) file ".v") in diff --git a/plugins/micromega/certificate.mli b/plugins/micromega/certificate.mli index cabd36ebb7..5b215549b0 100644 --- a/plugins/micromega/certificate.mli +++ b/plugins/micromega/certificate.mli @@ -12,16 +12,12 @@ module Mc = Micromega (** [use_simplex] is bound to the Coq option Simplex. If set, use the Simplex method, otherwise use Fourier *) -val use_simplex : bool ref +val use_simplex : unit -> bool type ('prf, 'model) res = Prf of 'prf | Model of 'model | Unknown type zres = (Mc.zArithProof, int * Mc.z list) res type qres = (Mc.q Mc.psatz, int * Mc.q list) res -(** [dump_file] is bound to the Coq option Dump Arith. - If set to some [file], arithmetic goals are dumped in filexxx.v *) -val dump_file : string option ref - (** [q_cert_of_pos prf] converts a Sos proof into a rational Coq proof *) val q_cert_of_pos : Sos_types.positivstellensatz -> Mc.q Mc.psatz diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 43f6f5a35e..7e4c4ce5c6 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -37,74 +37,31 @@ let debug = false let max_depth = max_int (* Search limit for provers over Q R *) -let lra_proof_depth = ref max_depth +let lra_proof_depth = + declare_int_option_and_ref ~depr:false ~key:["Lra"; "Depth"] ~value:max_depth (* Search limit for provers over Z *) -let lia_enum = ref true -let lia_proof_depth = ref max_depth -let get_lia_option () = (!Certificate.use_simplex, !lia_enum, !lia_proof_depth) -let get_lra_option () = !lra_proof_depth +let lia_enum = + declare_bool_option_and_ref ~depr:false ~key:["Lia"; "Enum"] ~value:true + +let lia_proof_depth = + declare_int_option_and_ref ~depr:false ~key:["Lia"; "Depth"] ~value:max_depth + +let get_lia_option () = + (Certificate.use_simplex (), lia_enum (), lia_proof_depth ()) (* Enable/disable caches *) -let use_lia_cache = ref true -let use_nia_cache = ref true -let use_nra_cache = ref true -let use_csdp_cache = ref true - -let () = - let int_opt l vref = - { optdepr = false - ; optkey = l - ; optread = (fun () -> Some !vref) - ; optwrite = - (fun x -> vref := match x with None -> max_depth | Some v -> v) } - in - let lia_enum_opt = - { optdepr = false - ; optkey = ["Lia"; "Enum"] - ; optread = (fun () -> !lia_enum) - ; optwrite = (fun x -> lia_enum := x) } - in - let solver_opt = - { optdepr = false - ; optkey = ["Simplex"] - ; optread = (fun () -> !Certificate.use_simplex) - ; optwrite = (fun x -> Certificate.use_simplex := x) } - in - let dump_file_opt = - { optdepr = false - ; optkey = ["Dump"; "Arith"] - ; optread = (fun () -> !Certificate.dump_file) - ; optwrite = (fun x -> Certificate.dump_file := x) } - in - let lia_cache_opt = - { optdepr = false - ; optkey = ["Lia"; "Cache"] - ; optread = (fun () -> !use_lia_cache) - ; optwrite = (fun x -> use_lia_cache := x) } - in - let nia_cache_opt = - { optdepr = false - ; optkey = ["Nia"; "Cache"] - ; optread = (fun () -> !use_nia_cache) - ; optwrite = (fun x -> use_nia_cache := x) } - in - let nra_cache_opt = - { optdepr = false - ; optkey = ["Nra"; "Cache"] - ; optread = (fun () -> !use_nra_cache) - ; optwrite = (fun x -> use_nra_cache := x) } - in - let () = declare_bool_option solver_opt in - let () = declare_bool_option lia_cache_opt in - let () = declare_bool_option nia_cache_opt in - let () = declare_bool_option nra_cache_opt in - let () = declare_stringopt_option dump_file_opt in - let () = declare_int_option (int_opt ["Lra"; "Depth"] lra_proof_depth) in - let () = declare_int_option (int_opt ["Lia"; "Depth"] lia_proof_depth) in - let () = declare_bool_option lia_enum_opt in - () +let use_lia_cache = + declare_bool_option_and_ref ~depr:false ~key:["Lia"; "Cache"] ~value:true + +let use_nia_cache = + declare_bool_option_and_ref ~depr:false ~key:["Nia"; "Cache"] ~value:true + +let use_nra_cache = + declare_bool_option_and_ref ~depr:false ~key:["Nra"; "Cache"] ~value:true + +let use_csdp_cache () = true (** * Initialize a tag type to the Tag module declaration (see Mutils). @@ -2101,7 +2058,7 @@ struct let memo_opt use_cache cache_file f = let memof = memo cache_file f in - fun x -> if !use_cache then memof x else f x + fun x -> if use_cache () then memof x else f x end module CacheCsdp = MakeCache (struct @@ -2281,7 +2238,7 @@ let memo_nra = let linear_prover_Q = { name = "linear prover" - ; get_option = get_lra_option + ; get_option = lra_proof_depth ; prover = (fun (o, l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o) l) @@ -2292,7 +2249,7 @@ let linear_prover_Q = let linear_prover_R = { name = "linear prover" - ; get_option = get_lra_option + ; get_option = lra_proof_depth ; prover = (fun (o, l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o) l) @@ -2303,7 +2260,7 @@ let linear_prover_R = let nlinear_prover_R = { name = "nra" - ; get_option = get_lra_option + ; get_option = lra_proof_depth ; prover = memo_nra ; hyps = hyps_of_cone ; compact = compact_cone diff --git a/plugins/micromega/plugin_base.dune b/plugins/micromega/dune index 4153d06161..33ad3a0138 100644 --- a/plugins/micromega/plugin_base.dune +++ b/plugins/micromega/dune @@ -20,3 +20,5 @@ (modules g_zify zify) (synopsis "Coq's zify plugin") (libraries coq.plugins.ltac)) + +(coq.pp (modules g_micromega g_zify)) diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml index f157a807ad..9051bbb5ca 100644 --- a/plugins/micromega/persistent_cache.ml +++ b/plugins/micromega/persistent_cache.ml @@ -41,13 +41,21 @@ module PHashtable (Key : HashedType) : PHashtable with type key = Key.t = struct type mode = Closed | Open type 'a t = {outch : out_channel; mutable status : mode; htbl : 'a Table.t} - let finally f rst = - try - let res = f () in - rst (); res - with reraise -> - (try rst () with any -> raise reraise); - raise reraise + (* XXX: Move to Fun.protect once in Ocaml 4.08 *) + let fun_protect ~(finally : unit -> unit) work = + let finally_no_exn () = + let exception Finally_raised of exn in + try finally () + with e -> + let bt = Printexc.get_raw_backtrace () in + Printexc.raise_with_backtrace (Finally_raised e) bt + in + match work () with + | result -> finally_no_exn (); result + | exception work_exn -> + let work_bt = Printexc.get_raw_backtrace () in + finally_no_exn (); + Printexc.raise_with_backtrace work_exn work_bt let read_key_elem inch = try Some (Marshal.from_channel inch) with @@ -76,21 +84,23 @@ module PHashtable (Key : HashedType) : PHashtable with type key = Key.t = struct let unlock fd = let pos = lseek fd 0 SEEK_CUR in - try - ignore (lseek fd 0 SEEK_SET); - lockf fd F_ULOCK 1 - with Unix.Unix_error (_, _, _) -> - () - (* Here, this is really bad news -- - there is a pending lock which could cause a deadlock. - Should it be an anomaly or produce a warning ? - *); - ignore (lseek fd pos SEEK_SET) + let () = + try + ignore (lseek fd 0 SEEK_SET); + lockf fd F_ULOCK 1 + with Unix.Unix_error (_, _, _) -> + (* Here, this is really bad news -- + there is a pending lock which could cause a deadlock. + Should it be an anomaly or produce a warning ? + *) + () + in + ignore (lseek fd pos SEEK_SET) (* We make the assumption that an acquired lock can always be released *) let do_under_lock kd fd f = - if lock kd fd then finally f (fun () -> unlock fd) else f () + if lock kd fd then fun_protect f ~finally:(fun () -> unlock fd) else f () let open_in f = let flags = [O_RDONLY; O_CREAT] in diff --git a/plugins/nsatz/plugin_base.dune b/plugins/nsatz/dune index 9da5b39972..b921c9c408 100644 --- a/plugins/nsatz/plugin_base.dune +++ b/plugins/nsatz/dune @@ -3,3 +3,5 @@ (public_name coq.plugins.nsatz) (synopsis "Coq's nsatz solver plugin") (libraries num coq.plugins.ltac)) + +(coq.pp (modules g_nsatz)) diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 2eef459217..79d6c05e1d 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -1899,8 +1899,15 @@ let destructure_goal = let destructure_goal = destructure_goal +let warn_omega_is_deprecated = + let name = "omega-is-deprecated" in + let category = "deprecated" in + CWarnings.create ~name ~category (fun () -> + Pp.str "omega is deprecated since 8.12; use “lia” instead.") + let omega_solver = Proofview.tclUNIT () >>= fun () -> (* delay for [check_required_library] *) + warn_omega_is_deprecated (); Coqlib.check_required_library ["Coq";"omega";"Omega"]; reset_all (); destructure_goal diff --git a/plugins/omega/plugin_base.dune b/plugins/omega/dune index f512501c78..0db71ed6fb 100644 --- a/plugins/omega/plugin_base.dune +++ b/plugins/omega/dune @@ -3,3 +3,5 @@ (public_name coq.plugins.omega) (synopsis "Coq's omega plugin") (libraries coq.plugins.ltac)) + +(coq.pp (modules g_omega)) diff --git a/plugins/rtauto/plugin_base.dune b/plugins/rtauto/dune index 233845ae0f..43efa0eca5 100644 --- a/plugins/rtauto/plugin_base.dune +++ b/plugins/rtauto/dune @@ -3,3 +3,5 @@ (public_name coq.plugins.rtauto) (synopsis "Coq's rtauto plugin") (libraries coq.plugins.ltac)) + +(coq.pp (modules g_rtauto)) diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml index 537c37810e..1371c671a2 100644 --- a/plugins/rtauto/proof_search.ml +++ b/plugins/rtauto/proof_search.ml @@ -45,15 +45,11 @@ let reset_info () = s_info.branch_successes <- 0; s_info.nd_branching <- 0 -let pruning = ref true - -let opt_pruning= - {optdepr=false; - optkey=["Rtauto";"Pruning"]; - optread=(fun () -> !pruning); - optwrite=(fun b -> pruning:=b)} - -let () = declare_bool_option opt_pruning +let pruning = + declare_bool_option_and_ref + ~depr:false + ~key:["Rtauto";"Pruning"] + ~value:true type form= Atom of int @@ -182,7 +178,7 @@ let rec fill stack proof = [] -> Complete proof.dep_it | slice::super -> if - !pruning && + pruning () && List.is_empty slice.proofs_done && not (slice.changes_goal && proof.dep_goal) && not (Int.Set.exists @@ -529,7 +525,7 @@ let pp = let pp_info () = let count_info = - if !pruning then + if pruning () then str "Proof steps : " ++ int s_info.created_steps ++ str " created / " ++ int s_info.pruned_steps ++ str " pruned" ++ fnl () ++ diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index 63dae1417e..d464ec4c06 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -221,27 +221,17 @@ let build_env gamma= mkApp(force node_count l_push,[|mkProp;p;e|])) gamma.env (mkApp (force node_count l_empty,[|mkProp|])) -open Goptions - -let verbose = ref false - -let opt_verbose= - {optdepr=false; - optkey=["Rtauto";"Verbose"]; - optread=(fun () -> !verbose); - optwrite=(fun b -> verbose:=b)} - -let () = declare_bool_option opt_verbose - -let check = ref false - -let opt_check= - {optdepr=false; - optkey=["Rtauto";"Check"]; - optread=(fun () -> !check); - optwrite=(fun b -> check:=b)} - -let () = declare_bool_option opt_check +let verbose = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["Rtauto";"Verbose"] + ~value:false + +let check = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["Rtauto";"Check"] + ~value:false open Pp @@ -267,7 +257,7 @@ let rtauto_tac = let () = begin reset_info (); - if !verbose then + if verbose () then Feedback.msg_info (str "Starting proof-search ..."); end in let search_start_time = System.get_time () in @@ -276,7 +266,7 @@ let rtauto_tac = with Not_found -> user_err ~hdr:"rtauto" (Pp.str "rtauto couldn't find any proof") in let search_end_time = System.get_time () in - let () = if !verbose then + let () = if verbose () then begin Feedback.msg_info (str "Proof tree found in " ++ System.fmt_time_difference search_start_time search_end_time); @@ -292,7 +282,7 @@ let rtauto_tac = let term= applistc main (List.rev_map (fun (id,_) -> mkVar id.binder_name) hyps) in let build_end_time=System.get_time () in - let () = if !verbose then + let () = if verbose () then begin Feedback.msg_info (str "Proof term built in " ++ System.fmt_time_difference build_start_time build_end_time ++ @@ -306,14 +296,14 @@ let rtauto_tac = let tac_start_time = System.get_time () in let term = EConstr.of_constr term in let result= - if !check then + if check () then Tactics.exact_check term else Tactics.exact_no_check term in let tac_end_time = System.get_time () in let () = - if !check then Feedback.msg_info (str "Proof term type-checking is on"); - if !verbose then + if check () then Feedback.msg_info (str "Proof term type-checking is on"); + if verbose () then Feedback.msg_info (str "Internal tactic executed in " ++ System.fmt_time_difference tac_start_time tac_end_time) in result diff --git a/plugins/setoid_ring/plugin_base.dune b/plugins/setoid_ring/dune index d83857edad..60522cd3f5 100644 --- a/plugins/setoid_ring/plugin_base.dune +++ b/plugins/setoid_ring/dune @@ -3,3 +3,5 @@ (public_name coq.plugins.setoid_ring) (synopsis "Coq's setoid ring plugin") (libraries coq.plugins.ltac)) + +(coq.pp (modules g_newring)) diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 0646af3552..633cdbd735 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -150,7 +150,7 @@ let decl_constant na univs c = let open Constr in let vars = CVars.universes_of_constr c in let univs = UState.restrict_universe_context ~lbound:(Global.universes_lbound ()) univs vars in - let () = Declare.declare_universe_context ~poly:false univs in + let () = DeclareUctx.declare_universe_context ~poly:false univs in let types = (Typeops.infer (Global.env ()) c).uj_type in let univs = Monomorphic_entry Univ.ContextSet.empty in mkConst(declare_constant ~name:(Id.of_string na) diff --git a/plugins/ssr/plugin_base.dune b/plugins/ssr/dune index a13524bb52..a117d09a16 100644 --- a/plugins/ssr/plugin_base.dune +++ b/plugins/ssr/dune @@ -5,3 +5,5 @@ (modules_without_implementation ssrast) (flags :standard -open Gramlib) (libraries coq.plugins.ssrmatching)) + +(coq.pp (modules ssrvernac ssrparser)) diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 01b12474dd..134a9e4b36 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -239,7 +239,7 @@ let interp_refine ist gl rc = } in let kind = Pretyping.OfType (pf_concl gl) in let flags = { - Pretyping.use_typeclasses = true; + Pretyping.use_typeclasses = Pretyping.UseTC; solve_unification_constraints = true; fail_evar = false; expand_evars = true; @@ -537,7 +537,7 @@ let pf_abs_evars2 gl rigid (sigma, c0) = let rec put evlist c = match Constr.kind c with | Evar (k, a) -> if List.mem_assoc k evlist || Evd.mem sigma0 k || List.mem k rigid then evlist else - let n = max 0 (Array.length a - nenv) in + let n = max 0 (List.length a - nenv) in let t = abs_evar n k in (k, (n, t)) :: put evlist t | _ -> Constr.fold put evlist c in let evlist = put [] c0 in @@ -549,6 +549,7 @@ let pf_abs_evars2 gl rigid (sigma, c0) = | Evar (ev, a) -> let j, n = lookup ev i evlist in if j = 0 then Constr.map (get i) c else if n = 0 then mkRel j else + let a = Array.of_list a in mkApp (mkRel j, Array.init n (fun k -> get i a.(n - 1 - k))) | _ -> Constr.map_with_binders ((+) 1) get i c in let rec loop c i = function @@ -598,7 +599,7 @@ let pf_abs_evars_pirrel gl (sigma, c0) = let rec put evlist c = match Constr.kind c with | Evar (k, a) -> if List.mem_assoc k evlist || Evd.mem sigma0 k then evlist else - let n = max 0 (Array.length a - nenv) in + let n = max 0 (List.length a - nenv) in let k_ty = Retyping.get_sort_family_of (pf_env gl) sigma (Evd.evar_concl (Evd.find sigma k)) in @@ -636,6 +637,7 @@ let pf_abs_evars_pirrel gl (sigma, c0) = | Evar (ev, a) -> let j, n = lookup ev i evlist in if j = 0 then Constr.map (get evlist i) c else if n = 0 then mkRel j else + let a = Array.of_list a in mkApp (mkRel j, Array.init n (fun k -> get evlist i a.(n - 1 - k))) | _ -> Constr.map_with_binders ((+) 1) (get evlist) i c in let rec app extra_args i c = match decompose_app c with diff --git a/plugins/ssrmatching/plugin_base.dune b/plugins/ssrmatching/dune index 06f67c3774..629d723816 100644 --- a/plugins/ssrmatching/plugin_base.dune +++ b/plugins/ssrmatching/dune @@ -3,3 +3,5 @@ (public_name coq.plugins.ssrmatching) (synopsis "Coq ssrmatching plugin") (libraries coq.plugins.ltac)) + +(coq.pp (modules g_ssrmatching)) diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index 1c776398e7..d5a781e472 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -263,7 +263,7 @@ let nf_open_term sigma0 ise c = let rec nf c' = match kind c' with | Evar ex -> begin try nf (existential_value0 s ex) with _ -> - let k, a = ex in let a' = Array.map nf a in + let k, a = ex in let a' = List.map nf a in if not (Evd.mem !s' k) then s' := Evd.add !s' k (Evarutil.nf_evar_info s (Evd.find s k)); mkEvar (k, a') @@ -307,7 +307,7 @@ let pf_unify_HO gl t1 t2 = (* This is what the definition of iter_constr should be... *) let iter_constr_LR f c = match kind c with - | Evar (k, a) -> Array.iter f a + | Evar (k, a) -> List.iter f a | Cast (cc, _, t) -> f cc; f t | Prod (_, t, b) | Lambda (_, t, b) -> f t; f b | LetIn (_, v, t, b) -> f v; f t; f b @@ -387,7 +387,7 @@ let evars_for_FO ~hack env sigma0 (ise0:evar_map) c0 = with NotInstantiatedEvar -> if Evd.mem sigma0 k then map put c else let evi = Evd.find !sigma k in - let dc = List.firstn (max 0 (Array.length a - nenv)) (evar_filtered_context evi) in + let dc = List.firstn (max 0 (List.length a - nenv)) (evar_filtered_context evi) in let abs_dc (d, c) = function | Context.Named.Declaration.LocalDef (x, b, t) -> d, mkNamedLetIn x (put b) (put t) c @@ -601,7 +601,8 @@ let match_upats_HO ~on_instance upats env sigma0 ise c = | KpatFixed | KpatConst -> ise | KpatEvar _ -> let _, pka = destEvar u.up_f and _, ka = destEvar f in - unif_HO_args env ise pka 0 ka + let fold ise pk k = unif_HO env ise (EConstr.of_constr pk) (EConstr.of_constr k) in + List.fold_left2 fold ise pka ka | KpatLet -> let x, v, t, b = destLetIn f in let _, pv, _, pb = destLetIn u.up_f in diff --git a/plugins/syntax/plugin_base.dune b/plugins/syntax/dune index 512752135d..b395695c8a 100644 --- a/plugins/syntax/plugin_base.dune +++ b/plugins/syntax/dune @@ -32,3 +32,5 @@ (synopsis "Coq syntax plugin: float") (modules float_syntax) (libraries coq.vernac)) + +(coq.pp (modules g_numeral g_string)) diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index f816599a17..b39ec37cd1 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -446,7 +446,7 @@ let rec norm_head info env t stack = Some c -> norm_head info env c stack | None -> let e, xs = ev in - let xs' = Array.map (apply_env env) xs in + let xs' = List.map (apply_env env) xs in (VAL(0, mkEvar (e,xs')), stack)) (* non-neutral cases *) diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index f85635528d..25aa8915ba 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -404,7 +404,7 @@ let matches_core env sigma allow_bound_rels Array.fold_left2 (fun subst na1 na2 -> add_binders na1 na2 binding_vars subst) subst lna1 lna2 | PEvar (c1,args1), Evar (c2,args2) when Evar.equal c1 c2 -> - Array.fold_left2 (sorec ctx env) subst args1 args2 + List.fold_left2 (sorec ctx env) subst args1 args2 | PInt i1, Int i2 when Uint63.equal i1 i2 -> subst | PFloat f1, Float f2 when Float64.equal f1 f2 -> subst | (PRef _ | PVar _ | PRel _ | PApp _ | PProj _ | PLambda _ diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 73be36d031..ff278baf9f 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -221,53 +221,35 @@ module PrintingLet = Goptions.MakeRefTable(PrintingCasesLet) (* Flags.for printing or not wildcard and synthetisable types *) -open Goptions - -let wildcard_value = ref true -let force_wildcard () = !wildcard_value - -let () = declare_bool_option - { optdepr = false; - optkey = ["Printing";"Wildcard"]; - optread = force_wildcard; - optwrite = (:=) wildcard_value } - -let fast_name_generation = ref false - -let () = declare_bool_option { - optdepr = false; - optkey = ["Fast";"Name";"Printing"]; - optread = (fun () -> !fast_name_generation); - optwrite = (:=) fast_name_generation; -} - -let synth_type_value = ref true -let synthetize_type () = !synth_type_value - -let () = declare_bool_option - { optdepr = false; - optkey = ["Printing";"Synth"]; - optread = synthetize_type; - optwrite = (:=) synth_type_value } - -let reverse_matching_value = ref true -let reverse_matching () = !reverse_matching_value - -let () = declare_bool_option - { optdepr = false; - optkey = ["Printing";"Matching"]; - optread = reverse_matching; - optwrite = (:=) reverse_matching_value } - -let print_primproj_params_value = ref false -let print_primproj_params () = !print_primproj_params_value - -let () = declare_bool_option - { optdepr = false; - optkey = ["Printing";"Primitive";"Projection";"Parameters"]; - optread = print_primproj_params; - optwrite = (:=) print_primproj_params_value } - +let force_wildcard = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["Printing";"Wildcard"] + ~value:true + +let fast_name_generation = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["Fast";"Name";"Printing"] + ~value:false + +let synthetize_type = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["Printing";"Synth"] + ~value:true + +let reverse_matching = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["Printing";"Matching"] + ~value:true + +let print_primproj_params = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["Printing";"Primitive";"Projection";"Parameters"] + ~value:false (* Auxiliary function for MutCase printing *) (* [computable] tries to tell if the predicate typing the result is inferable*) @@ -338,27 +320,23 @@ let lookup_index_as_renamed env sigma t n = (**********************************************************************) (* Factorization of match patterns *) -let print_factorize_match_patterns = ref true - -let () = - declare_bool_option - { optdepr = false; - optkey = ["Printing";"Factorizable";"Match";"Patterns"]; - optread = (fun () -> !print_factorize_match_patterns); - optwrite = (fun b -> print_factorize_match_patterns := b) } - -let print_allow_match_default_clause = ref true +let print_factorize_match_patterns = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["Printing";"Factorizable";"Match";"Patterns"] + ~value:true -let () = - declare_bool_option - { optdepr = false; - optkey = ["Printing";"Allow";"Match";"Default";"Clause"]; - optread = (fun () -> !print_allow_match_default_clause); - optwrite = (fun b -> print_allow_match_default_clause := b) } +let print_allow_match_default_opt_name = + ["Printing";"Allow";"Match";"Default";"Clause"] +let print_allow_match_default_clause = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:print_allow_match_default_opt_name + ~value:true let rec join_eqns (ids,rhs as x) patll = function | ({CAst.loc; v=(ids',patl',rhs')} as eqn')::rest -> - if not !Flags.raw_print && !print_factorize_match_patterns && + if not !Flags.raw_print && print_factorize_match_patterns () && List.eq_set Id.equal ids ids' && glob_constr_eq rhs rhs' then join_eqns x (patl'::patll) rest @@ -404,7 +382,7 @@ let factorize_eqns eqns = let eqns = aux [] (List.rev eqns) in let mk_anon patl = List.map (fun _ -> DAst.make @@ PatVar Anonymous) patl in let open CAst in - if not !Flags.raw_print && !print_allow_match_default_clause && eqns <> [] then + if not !Flags.raw_print && print_allow_match_default_clause () && eqns <> [] then match select_default_clause eqns with (* At least two clauses and the last one is disjunctive with no variables *) | Some {loc=gloc;v=([],patl::_::_,rhs)}, (_::_ as eqns) -> @@ -812,7 +790,7 @@ and detype_r d flags avoid env sigma t = id,l with Not_found -> Id.of_string ("X" ^ string_of_int (Evar.repr evk)), - (Array.map_to_list (fun c -> (Id.of_string "__",c)) cl) + (List.map (fun c -> (Id.of_string "__",c)) cl) in GEvar (id, List.map (on_snd (detype d flags avoid env sigma)) l) @@ -925,16 +903,16 @@ let detype_rel_context d flags where avoid env sigma sign = let detype_names isgoal avoid nenv env sigma t = let flags = { flg_isgoal = isgoal; flg_lax = false } in - let avoid = Avoid.make ~fast:!fast_name_generation avoid in + let avoid = Avoid.make ~fast:(fast_name_generation ()) avoid in detype Now flags avoid (nenv,env) sigma t let detype d ?(lax=false) isgoal avoid env sigma t = let flags = { flg_isgoal = isgoal; flg_lax = lax } in - let avoid = Avoid.make ~fast:!fast_name_generation avoid in + let avoid = Avoid.make ~fast:(fast_name_generation ()) avoid in detype d flags avoid (names_of_rel_context env, env) sigma t let detype_rel_context d ?(lax = false) where avoid env sigma sign = let flags = { flg_isgoal = false; flg_lax = lax } in - let avoid = Avoid.make ~fast:!fast_name_generation avoid in + let avoid = Avoid.make ~fast:(fast_name_generation ()) avoid in detype_rel_context d flags where avoid env sigma sign let detype_closed_glob ?lax isgoal avoid env sigma t = diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli index 5723b47715..254f772ff8 100644 --- a/pretyping/detyping.mli +++ b/pretyping/detyping.mli @@ -29,11 +29,12 @@ val print_evar_arguments : bool ref (** If true, contract branches with same r.h.s. and same matching variables in a disjunctive pattern *) -val print_factorize_match_patterns : bool ref +val print_factorize_match_patterns : unit -> bool -(** If true and the last non unique clause of a "match" is a +(** If this flag is true and the last non unique clause of a "match" is a variable-free disjunctive pattern, turn it into a catch-call case *) -val print_allow_match_default_clause : bool ref +val print_allow_match_default_clause : unit -> bool +val print_allow_match_default_opt_name : string list val subst_cases_pattern : substitution -> cases_pattern -> cases_pattern diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 26bf02aa25..f1506f5f59 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -47,21 +47,17 @@ let default_flags env = let ts = default_transparent_state env in default_flags_of ts -let debug_unification = ref (false) -let () = Goptions.(declare_bool_option { - optdepr = false; - optkey = ["Debug";"Unification"]; - optread = (fun () -> !debug_unification); - optwrite = (fun a -> debug_unification:=a); -}) - -let debug_ho_unification = ref (false) -let () = Goptions.(declare_bool_option { - optdepr = false; - optkey = ["Debug";"HO";"Unification"]; - optread = (fun () -> !debug_ho_unification); - optwrite = (fun a -> debug_ho_unification:=a); -}) +let debug_unification = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["Debug";"Unification"] + ~value:false + +let debug_ho_unification = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["Debug";"HO";"Unification"] + ~value:false (*******************************************) (* Functions to deal with impossible cases *) @@ -199,7 +195,7 @@ let occur_rigidly flags env evd (evk,_) t = | Evar (evk',l as ev) -> if Evar.equal evk evk' then Rigid true else if is_frozen flags ev then - Rigid (Array.exists (fun x -> rigid_normal_occ (aux x)) l) + Rigid (List.exists (fun x -> rigid_normal_occ (aux x)) l) else Reducible | Cast (p, _, _) -> aux p | Lambda (na, t, b) -> aux b @@ -355,6 +351,14 @@ let ise_array2 evd f v1 v2 = if Int.equal lv1 (Array.length v2) then allrec evd (pred lv1) else UnifFailure (evd,NotSameArgSize) +let rec ise_inst2 evd f l1 l2 = match l1, l2 with +| [], [] -> Success evd +| [], (_ :: _) | (_ :: _), [] -> assert false +| c1 :: l1, c2 :: l2 -> + match ise_inst2 evd f l1 l2 with + | Success evd' -> f evd' c1 c2 + | UnifFailure _ as x -> x + (* Applicative node of stack are read from the outermost to the innermost but are unified the other way. *) let rec ise_app_stack2 env f evd sk1 sk2 = @@ -767,7 +771,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty in let app_empty = match sk1, sk2 with [], [] -> true | _ -> false in (* Evar must be undefined since we have flushed evars *) - let () = if !debug_unification then + let () = if debug_unification () then let open Pp in Feedback.msg_debug (v 0 (pr_state env evd appr1 ++ cut () ++ pr_state env evd appr2 ++ cut ())) in match (flex_kind_of_term flags env evd term1 sk1, @@ -1023,7 +1027,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty if Evar.equal sp1 sp2 then match ise_stack2 false env evd (evar_conv_x flags) sk1 sk2 with |None, Success i' -> - ise_array2 i' (fun i' -> evar_conv_x flags env i' CONV) al1 al2 + ise_inst2 i' (fun i' -> evar_conv_x flags env i' CONV) al1 al2 |_, (UnifFailure _ as x) -> x |Some _, _ -> UnifFailure (evd,NotSameArgSize) else UnifFailure (evd,NotSameHead) @@ -1224,16 +1228,16 @@ let apply_on_subterm env evd fixedref f test c t = (fun d (env,(k,c)) -> (push_rel d env, (k+1,lift 1 c))) applyrec acc t else - (if !debug_ho_unification then + (if debug_ho_unification () then Feedback.msg_debug Pp.(str"Testing " ++ prc env !evdref c ++ str" against " ++ prc env !evdref t); let b, evd = try test env !evdref k c t with e when CErrors.noncritical e -> assert false in - if b then (if !debug_ho_unification then Feedback.msg_debug (Pp.str "succeeded"); + if b then (if debug_ho_unification () then Feedback.msg_debug (Pp.str "succeeded"); let evd', t' = f !evdref k t in evdref := evd'; t') else ( - if !debug_ho_unification then Feedback.msg_debug (Pp.str "failed"); + if debug_ho_unification () then Feedback.msg_debug (Pp.str "failed"); map_constr_with_binders_left_to_right !evdref (fun d (env,(k,c)) -> (push_rel d env, (k+1,lift 1 c))) applyrec acc t)) @@ -1245,6 +1249,7 @@ let filter_possible_projections evd c ty ctxt args = (* Since args in the types will be replaced by holes, we count the fv of args to have a well-typed filter; don't know how necessary it is however to have a well-typed filter here *) + let args = Array.of_list args in let fv1 = free_rels evd (mkApp (c,args)) (* Hack: locally untyped *) in let fv2 = collect_vars evd (mkApp (c,args)) in let len = Array.length args in @@ -1313,8 +1318,8 @@ let thin_evars env sigma sign c = match kind !sigma t with | Evar (ev, args) -> let evi = Evd.find_undefined !sigma ev in - let filter = Array.map (fun c -> Id.Set.subset (collect_vars !sigma c) ctx) args in - let filter = Filter.make (Array.to_list filter) in + let filter = List.map (fun c -> Id.Set.subset (collect_vars !sigma c) ctx) args in + let filter = Filter.make filter in let candidates = Option.map (List.map EConstr.of_constr) (evar_candidates evi) in let evd, ev = restrict_evar !sigma ev filter candidates in sigma := evd; whd_evar !sigma t @@ -1337,12 +1342,12 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = let env_evar = evar_filtered_env env_rhs evi in let sign = named_context_val env_evar in let ctxt = evar_filtered_context evi in - if !debug_ho_unification then + if debug_ho_unification () then (Feedback.msg_debug Pp.(str"env rhs: " ++ Termops.Internal.print_env env_rhs); Feedback.msg_debug Pp.(str"env evars: " ++ Termops.Internal.print_env env_evar)); - let args = Array.map (nf_evar evd) args in + let args = List.map (nf_evar evd) args in let vars = List.map NamedDecl.get_id ctxt in - let argsubst = List.map2 (fun id c -> (id, c)) vars (Array.to_list args) in + let argsubst = List.map2 (fun id c -> (id, c)) vars args in let instance = List.map mkVar vars in let rhs = nf_evar evd rhs in if not (noccur_evar env_rhs evd evk rhs) then raise (TypingFailed evd); @@ -1374,7 +1379,7 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = let rec set_holes env_rhs evd rhs = function | (id,idty,c,cty,evsref,filter,occs)::subst -> let c = nf_evar evd c in - if !debug_ho_unification then + if debug_ho_unification () then Feedback.msg_debug Pp.(str"set holes for: " ++ prc env_rhs evd (mkVar id.binder_name) ++ spc () ++ prc env_rhs evd c ++ str" in " ++ @@ -1382,7 +1387,7 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = let occ = ref 1 in let set_var evd k inst = let oc = !occ in - if !debug_ho_unification then + if debug_ho_unification () then (Feedback.msg_debug Pp.(str"Found one occurrence"); Feedback.msg_debug Pp.(str"cty: " ++ prc env_rhs evd c)); incr occ; @@ -1393,7 +1398,7 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = | Unspecified prefer_abstraction -> let evd, evty = set_holes env_rhs evd cty subst in let evty = nf_evar evd evty in - if !debug_ho_unification then + if debug_ho_unification () then Feedback.msg_debug Pp.(str"abstracting one occurrence " ++ prc env_rhs evd inst ++ str" of type: " ++ prc env_evar evd evty ++ str " for " ++ prc env_rhs evd c); @@ -1413,21 +1418,21 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = evd, ev in let evd, rhs' = apply_on_subterm env_rhs evd fixed set_var test c rhs in - if !debug_ho_unification then + if debug_ho_unification () then Feedback.msg_debug Pp.(str"abstracted: " ++ prc env_rhs evd rhs'); let () = check_selected_occs env_rhs evd c !occ occs in let env_rhs' = push_named (NamedDecl.LocalAssum (id,idty)) env_rhs in set_holes env_rhs' evd rhs' subst | [] -> evd, rhs in - let subst = make_subst (ctxt,Array.to_list args,argoccs) in + let subst = make_subst (ctxt,args,argoccs) in let evd, rhs' = set_holes env_rhs evd rhs subst in let rhs' = nf_evar evd rhs' in (* Thin evars making the term typable in env_evar *) let evd, rhs' = thin_evars env_evar evd ctxt rhs' in (* We instantiate the evars of which the value is forced by typing *) - if !debug_ho_unification then + if debug_ho_unification () then (Feedback.msg_debug Pp.(str"solve_evars on: " ++ prc env_evar evd rhs'); Feedback.msg_debug Pp.(str"evars: " ++ pr_evar_map (Some 0) env_evar evd)); let evd,rhs' = @@ -1437,7 +1442,7 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = raise (TypingFailed evd) in let rhs' = nf_evar evd rhs' in (* We instantiate the evars of which the value is forced by typing *) - if !debug_ho_unification then + if debug_ho_unification () then (Feedback.msg_debug Pp.(str"after solve_evars: " ++ prc env_evar evd rhs'); Feedback.msg_debug Pp.(str"evars: " ++ pr_evar_map (Some 0) env_evar evd)); @@ -1445,7 +1450,7 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = | (id,idty,c,cty,evsref,_,_)::l -> let id = id.binder_name in let c = nf_evar evd c in - if !debug_ho_unification then + if debug_ho_unification () then Feedback.msg_debug Pp.(str"abstracting: " ++ prc env_rhs evd (mkVar id) ++ spc () ++ prc env_rhs evd c); @@ -1476,7 +1481,7 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = | _ -> evd) with e -> user_err (Pp.str "Cannot find an instance") else - ((if !debug_ho_unification then + ((if debug_ho_unification () then let evi = Evd.find evd evk in let env = Evd.evar_env env_rhs evi in Feedback.msg_debug Pp.(str"evar is defined: " ++ @@ -1491,7 +1496,7 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = if Evd.is_defined evd evk then (* Can happen due to dependencies: instantiating evars in the arguments of evk might instantiate evk itself. *) - (if !debug_ho_unification then + (if debug_ho_unification () then begin let evi = Evd.find evd evk in let evenv = evar_env env_rhs evi in @@ -1504,13 +1509,13 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = let evi = Evd.find_undefined evd evk in let evenv = evar_env env_rhs evi in let rhs' = nf_evar evd rhs' in - if !debug_ho_unification then + if debug_ho_unification () then Feedback.msg_debug Pp.(str"abstracted type before second solve_evars: " ++ prc evenv evd rhs'); (* solve_evars is not commuting with nf_evar, because restricting an evar might provide a more specific type. *) let evd, _ = !solve_evars evenv evd rhs' in - if !debug_ho_unification then + if debug_ho_unification () then Feedback.msg_debug Pp.(str"abstracted type: " ++ prc evenv evd (nf_evar evd rhs')); let flags = default_flags_of TransparentState.full in Evarsolve.instantiate_evar evar_unify flags env_rhs evd evk rhs' @@ -1537,7 +1542,7 @@ let default_evar_selection flags evd (ev,args) = in spec :: aux args abs | l, [] -> List.map (fun _ -> default_occurrence_selection) l | [], _ :: _ -> assert false - in aux (Array.to_list args) evi.evar_abstract_arguments + in aux args evi.evar_abstract_arguments let second_order_matching_with_args flags env evd with_ho pbty ev l t = if with_ho then @@ -1564,7 +1569,7 @@ let apply_conversion_problem_heuristic flags env evd with_ho pbty t1 t2 = let t2 = apprec_nohdbeta flags env evd (whd_head_evar evd t2) in let (term1,l1 as appr1) = try destApp evd t1 with DestKO -> (t1, [||]) in let (term2,l2 as appr2) = try destApp evd t2 with DestKO -> (t2, [||]) in - let () = if !debug_unification then + let () = if debug_unification () then let open Pp in Feedback.msg_debug (v 0 (str "Heuristic:" ++ spc () ++ Termops.Internal.print_constr_env env evd t1 ++ cut () ++ diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index 50187d82cc..71edcaa231 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -113,7 +113,7 @@ let define_evar_as_product env evd (evk,args) = (* Quick way to compute the instantiation of evk with args *) let na,dom,rng = destProd evd prod in let evdom = mkEvar (fst (destEvar evd dom), args) in - let evrngargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in + let evrngargs = mkRel 1 :: List.map (lift 1) args in let evrng = mkEvar (fst (destEvar evd rng), evrngargs) in evd, mkProd (na, evdom, evrng) @@ -152,7 +152,7 @@ let define_evar_as_lambda env evd (evk,args) = let evd,lam = define_pure_evar_as_lambda env evd evk in (* Quick way to compute the instantiation of evk with args *) let na,dom,body = destLambda evd lam in - let evbodyargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in + let evbodyargs = mkRel 1 :: List.map (lift 1) args in let evbody = mkEvar (fst (destEvar evd body), evbodyargs) in evd, mkLambda (na, dom, evbody) @@ -163,7 +163,7 @@ let rec evar_absorb_arguments env evd (evk,args as ev) = function let evd,lam = define_pure_evar_as_lambda env evd evk in let _,_,body = destLambda evd lam in let evk = fst (destEvar evd body) in - evar_absorb_arguments env evd (evk, Array.cons a args) l + evar_absorb_arguments env evd (evk, a :: args) l (* Refining an evar to a sort *) diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 4eae0cf86c..34684e4a34 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -217,7 +217,7 @@ type 'a update = | NoUpdate open Context.Named.Declaration -let inst_of_vars sign = Array.map_of_list (get_id %> mkVar) sign +let inst_of_vars sign = List.map (get_id %> mkVar) sign let restrict_evar_key evd evk filter candidates = match filter, candidates with @@ -247,7 +247,7 @@ let restrict_applied_evar evd (evk,argsv) filter candidates = | Some filter -> let evi = Evd.find evd evk in let subfilter = Filter.compose (evar_filter evi) filter in - Filter.filter_array subfilter argsv in + Filter.filter_list subfilter argsv in evd,(newevk,newargsv) (* Restrict an evar in the current evar_map *) @@ -258,7 +258,7 @@ let restrict_evar evd evk filter candidates = let restrict_instance evd evk filter argsv = match filter with None -> argsv | Some filter -> let evi = Evd.find evd evk in - Filter.filter_array (Filter.compose (evar_filter evi) filter) argsv + Filter.filter_list (Filter.compose (evar_filter evi) filter) argsv open Context.Rel.Declaration let noccur_evar env evd evk c = @@ -269,7 +269,7 @@ let noccur_evar env evd evk c = if Evar.equal evk evk' then raise Occur else (if check_types then occur_rec false acc (existential_type evd ev'); - Array.iter (occur_rec check_types acc) args') + List.iter (occur_rec check_types acc) args') | Rel i when i > k -> if not (Int.Set.mem (i-k) !cache) then let decl = Environ.lookup_rel i env in @@ -416,19 +416,10 @@ let get_alias_chain_of sigma aliases x = match x with | RelAlias n -> (try Int.Map.find n aliases.rel_aliases with Not_found -> empty_aliasing) | VarAlias id -> (try cast_aliasing (Id.Map.find id aliases.var_aliases) with Not_found -> empty_aliasing) -let normalize_alias_opt_alias sigma aliases x = - match get_alias_chain_of sigma aliases x with - | _, [] -> None - | _, a :: _ -> Some a - -let normalize_alias_opt sigma aliases x = match to_alias sigma x with -| None -> None -| Some a -> normalize_alias_opt_alias sigma aliases a - let normalize_alias sigma aliases x = - match normalize_alias_opt_alias sigma aliases x with - | Some a -> a - | None -> x + match get_alias_chain_of sigma aliases x with + | _, [] -> x + | _, a :: _ -> a let normalize_alias_var sigma var_aliases id = let aliases = { var_aliases; rel_aliases = Int.Map.empty } in @@ -561,17 +552,13 @@ let get_actual_deps env evd aliases l t = open Context.Named.Declaration let remove_instance_local_defs evd evk args = let evi = Evd.find evd evk in - let len = Array.length args in - let rec aux sign i = match sign with - | [] -> - let () = assert (i = len) in [] - | LocalAssum _ :: sign -> - let () = assert (i < len) in - (Array.unsafe_get args i) :: aux sign (succ i) - | LocalDef _ :: sign -> - aux sign (succ i) + let rec aux sign args = match sign, args with + | [], [] -> [] + | LocalAssum _ :: sign, c :: args -> c :: aux sign args + | LocalDef _ :: sign, _ :: args -> aux sign args + | _ -> assert false in - aux (evar_filtered_context evi) 0 + aux (evar_filtered_context evi) args (* Check if an applied evar "?X[args] l" is a Miller's pattern *) @@ -678,7 +665,7 @@ let make_projectable_subst aliases sigma evi args = let l = try Constrmap.find (fst cstr) cstrs with Not_found -> [] in Constrmap.add (fst cstr) ((args,id)::l) cstrs | _ -> cstrs in - let all = Int.Map.add i [a,normalize_alias_opt sigma aliases a,id] all in + let all = Int.Map.add i [a, id] all in (rest,all,cstrs,revmap) | LocalDef ({binder_name=id},c,_), a::rest -> let revmap = Id.Map.add id i revmap in @@ -688,16 +675,16 @@ let make_projectable_subst aliases sigma evi args = let ic, sub = try let ic = Id.Map.find idc revmap in ic, Int.Map.find ic all with Not_found -> i, [] (* e.g. [idc] is a filtered variable: treat [id] as an assumption *) in - if List.exists (fun (c,_,_) -> EConstr.eq_constr sigma a c) sub then + if List.exists (fun (c, _) -> EConstr.eq_constr sigma a c) sub then (rest,all,cstrs,revmap) else - let all = Int.Map.add ic ((a,normalize_alias_opt sigma aliases a,id)::sub) all in + let all = Int.Map.add ic ((a, id)::sub) all in (rest,all,cstrs,revmap) | _ -> - let all = Int.Map.add i [a,normalize_alias_opt sigma aliases a,id] all in + let all = Int.Map.add i [a, id] all in (rest,all,cstrs,revmap)) | _ -> anomaly (Pp.str "Instance does not match its signature.")) 0 - sign (Array.rev_to_list args,Int.Map.empty,Constrmap.empty,Id.Map.empty) in + sign (List.rev args,Int.Map.empty,Constrmap.empty,Id.Map.empty) in (full_subst,cstr_subst) (*------------------------------------* @@ -774,7 +761,7 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = (mkRel 1)::(List.map (lift 1) inst_in_sign), push_rel d env,evd,Id.Set.add id.binder_name avoid)) rel_sign - (sign1,filter1,Array.to_list args1,inst_in_sign,env1,evd,avoid) + (sign1,filter1,args1,inst_in_sign,env1,evd,avoid) in let evd,ev2ty_in_sign = let s = Retyping.get_sort_of env evd ty_in_env in @@ -784,11 +771,12 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = ty_t_in_sign sign2 filter2 inst2_in_env in let (evd, ev2_in_sign) = new_evar_instance sign2 evd ev2ty_in_sign ~filter:filter2 ~src inst2_in_sign in - let ev2_in_env = (fst (destEvar evd ev2_in_sign), Array.of_list inst2_in_env) in + let ev2_in_env = (fst (destEvar evd ev2_in_sign), inst2_in_env) in (evd, ev2_in_sign, ev2_in_env) let restrict_upon_filter evd evk p args = let oldfullfilter = evar_filter (Evd.find_undefined evd evk) in + let args = Array.of_list args in let len = Array.length args in Filter.restrict_upon oldfullfilter len (fun i -> p (Array.unsafe_get args i)) @@ -862,47 +850,47 @@ type evar_projection = exception NotUnique exception NotUniqueInType of (Id.t * evar_projection) list -let rec assoc_up_to_alias sigma aliases y yc = function +let rec assoc_up_to_alias sigma aliases y = function | [] -> raise Not_found - | (c,cc,id)::l -> - if is_alias sigma c y then id + | (c, id)::l -> + match to_alias sigma c with + | None -> assoc_up_to_alias sigma aliases y l + | Some c -> + if eq_alias c y then id else match l with - | _ :: _ -> assoc_up_to_alias sigma aliases y yc l + | _ :: _ -> assoc_up_to_alias sigma aliases y l | [] -> (* Last chance, we reason up to alias conversion *) - match (normalize_alias_opt sigma aliases c) with - | Some cc when eq_alias yc cc -> id - | _ -> if is_alias sigma c yc then id else raise Not_found + let cc = normalize_alias sigma aliases c in + let yc = normalize_alias sigma aliases y in + if eq_alias cc yc then id else raise Not_found -let rec find_projectable_vars with_evars aliases sigma y subst = - let yc = normalize_alias sigma aliases y in - let is_projectable idc idcl (subst1,subst2 as subst') = +let rec find_projectable_vars aliases sigma y subst = + let is_projectable _ idcl (subst1,subst2 as subst') = (* First test if some [id] aliased to [idc] is bound to [y] in [subst] *) try - let id = assoc_up_to_alias sigma aliases y yc idcl in + let id = assoc_up_to_alias sigma aliases y idcl in (id,ProjectVar)::subst1,subst2 with Not_found -> (* Then test if [idc] is (indirectly) bound in [subst] to some evar *) (* projectable on [y] *) - if with_evars then - let f (c,_,id) = isEvar sigma c in - let idcl' = List.filter f idcl in - match idcl' with - | [c,_,id] -> - begin - let (evk,argsv as t) = destEvar sigma c in - let evi = Evd.find sigma evk in - let subst,_ = make_projectable_subst aliases sigma evi argsv in - let l = find_projectable_vars with_evars aliases sigma y subst in - match l with - | [id',p] -> (subst1,(id,ProjectEvar (t,evi,id',p))::subst2) - | _ -> subst' - end - | [] -> subst' - | _ -> anomaly (Pp.str "More than one non var in aliases class of evar instance.") - else - subst' in + let f (c, id) = isEvar sigma c in + let idcl' = List.filter f idcl in + match idcl' with + | [c, id] -> + begin + let (evk,argsv as t) = destEvar sigma c in + let evi = Evd.find sigma evk in + let subst,_ = make_projectable_subst aliases sigma evi argsv in + let l = find_projectable_vars aliases sigma y subst in + match l with + | [id',p] -> (subst1,(id,ProjectEvar (t,evi,id',p))::subst2) + | _ -> subst' + end + | [] -> subst' + | _ -> anomaly (Pp.str "More than one non var in aliases class of evar instance.") + in let subst1,subst2 = Int.Map.fold is_projectable subst ([],[]) in (* We return the substitution with ProjectVar first (from most recent to oldest var), followed by ProjectEvar (from most recent @@ -914,14 +902,15 @@ let rec find_projectable_vars with_evars aliases sigma y subst = let filter_solution = function | [] -> raise Not_found - | (id,p)::_::_ -> raise NotUnique - | [id,p] -> (mkVar id, p) + | _ :: _ :: _ -> raise NotUnique + | [id] -> mkVar id -let project_with_effects aliases sigma effects t subst = - let c, p = - filter_solution (find_projectable_vars false aliases sigma t subst) in - effects := p :: !effects; - c +let project_with_effects aliases sigma t subst = + let is_projectable _ idcl accu = + try assoc_up_to_alias sigma aliases t idcl :: accu + with Not_found -> accu + in + filter_solution (Int.Map.fold is_projectable subst []) open Context.Named.Declaration let rec find_solution_type evarenv = function @@ -981,28 +970,27 @@ let rec do_projection_effects unify flags define_fun env ty evd = function type projectibility_kind = | NoUniqueProjection - | UniqueProjection of EConstr.constr * evar_projection list + | UniqueProjection of EConstr.constr type projectibility_status = | CannotInvert | Invertible of projectibility_kind let invert_arg_from_subst evd aliases k0 subst_in_env_extended_with_k_binders c_in_env_extended_with_k_binders = - let effects = ref [] in let rec aux k t = match EConstr.kind evd t with | Rel i when i>k0+k -> aux' k (RelAlias (i-k)) | Var id -> aux' k (VarAlias id) | _ -> map_with_binders evd succ aux k t and aux' k t = - try project_with_effects aliases evd effects t subst_in_env_extended_with_k_binders + try project_with_effects aliases evd t subst_in_env_extended_with_k_binders with Not_found -> match expand_alias_once evd aliases t with | None -> raise Not_found | Some c -> aux k (Alias.eval (Alias.lift k c)) in try let c = aux 0 c_in_env_extended_with_k_binders in - Invertible (UniqueProjection (c,!effects)) + Invertible (UniqueProjection c) with | Not_found -> CannotInvert | NotUnique -> Invertible NoUniqueProjection @@ -1010,7 +998,7 @@ let invert_arg_from_subst evd aliases k0 subst_in_env_extended_with_k_binders c_ let invert_arg fullenv evd aliases k evk subst_in_env_extended_with_k_binders c_in_env_extended_with_k_binders = let res = invert_arg_from_subst evd aliases k subst_in_env_extended_with_k_binders c_in_env_extended_with_k_binders in match res with - | Invertible (UniqueProjection (c,_)) when not (noccur_evar fullenv evd evk c) + | Invertible (UniqueProjection c) when not (noccur_evar fullenv evd evk c) -> CannotInvert | _ -> @@ -1019,7 +1007,7 @@ let invert_arg fullenv evd aliases k evk subst_in_env_extended_with_k_binders c_ exception NotEnoughInformationToInvert let extract_unique_projection = function -| Invertible (UniqueProjection (c,_)) -> c +| Invertible (UniqueProjection c) -> c | _ -> (* For instance, there are evars with non-invertible arguments and *) (* we cannot arbitrarily restrict these evars before knowing if there *) @@ -1043,7 +1031,7 @@ let invert_invertible_arg fullenv evd aliases k (evk,argsv) args' = let p = invert_arg fullenv evd aliases k evk subst arg in extract_unique_projection p in - Array.map invert args' + List.map invert args' (* Redefines an evar with a smaller context (i.e. it may depend on less * variables) such that c becomes closed. @@ -1399,9 +1387,9 @@ let solve_refl ?(can_drop=false) unify flags env evd pbty evk argsv1 argsv2 = try evdref := Evd.add_universe_constraints !evdref cstr; true with UniversesDiffer -> false in - if Array.equal eq_constr argsv1 argsv2 then !evdref else + if List.equal eq_constr argsv1 argsv2 then !evdref else (* Filter and restrict if needed *) - let args = Array.map2 (fun a1 a2 -> (a1, a2)) argsv1 argsv2 in + let args = List.map2 (fun a1 a2 -> (a1, a2)) argsv1 argsv2 in let untypedfilter = restrict_upon_filter evd evk (fun (a1,a2) -> unify flags TermUnification env evd Reduction.CONV a1 a2) args in @@ -1461,7 +1449,7 @@ let occur_evar_upto_types sigma n c = | Evar (sp,_) when Evar.equal sp n -> raise Occur | Evar (sp,args as e) -> if Evar.Set.mem sp !seen then - Array.iter occur_rec args + List.iter occur_rec args else ( seen := Evar.Set.add sp !seen; Option.iter occur_rec (existential_opt_value0 sigma e); @@ -1518,7 +1506,7 @@ let rec invert_definition unify flags choose imitate_defs let project_variable t = (* Evar/Var problem: unifiable iff variable projectable from ev subst *) try - let sols = find_projectable_vars true aliases !evdref t subst in + let sols = find_projectable_vars aliases !evdref t subst in let c, p = match sols with | [] -> raise Not_found | [id,p] -> (mkVar id, p) @@ -1579,7 +1567,7 @@ let rec invert_definition unify flags choose imitate_defs (* Evar/Evar problem (but left evar is virtual) *) let aliases = lift_aliases k aliases in (try - let ev = (evk,Array.map (lift k) argsv) in + let ev = (evk,List.map (lift k) argsv) in let evd,body = project_evar_on_evar false unify flags env' !evdref aliases k None ev' ev in evdref := evd; body @@ -1657,7 +1645,7 @@ let rec invert_definition unify flags choose imitate_defs | [], [] -> true | _ -> false in - is_id_subst filter_ctxt (Array.to_list argsv) && + is_id_subst filter_ctxt argsv && closed0 evd rhs && Id.Set.subset (collect_vars evd rhs) !names in diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli index 0a1b731e6b..3fb80432ad 100644 --- a/pretyping/evarsolve.mli +++ b/pretyping/evarsolve.mli @@ -99,7 +99,7 @@ val refresh_universes : env -> evar_map -> types -> evar_map * types val solve_refl : ?can_drop:bool -> conversion_check -> unify_flags -> env -> evar_map -> - bool option -> Evar.t -> constr array -> constr array -> evar_map + bool option -> Evar.t -> constr list -> constr list -> evar_map val solve_evar_evar : ?force:bool -> (env -> evar_map -> bool option -> existential -> constr -> evar_map) -> @@ -128,7 +128,7 @@ val check_evar_instance : unifier -> unify_flags -> env -> evar_map -> Evar.t -> constr -> evar_map val remove_instance_local_defs : - evar_map -> Evar.t -> 'a array -> 'a list + evar_map -> Evar.t -> 'a list -> 'a list val get_type_of_refresh : ?polyprop:bool -> ?lax:bool -> env -> evar_map -> constr -> evar_map * types diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index a006c82993..cb868e0480 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -60,12 +60,20 @@ let glob_sort_family = let open Sorts in function | UNamed [GSet,0] -> InSet | _ -> raise ComplexSort -let glob_sort_eq u1 u2 = match u1, u2 with +let glob_sort_expr_eq f u1 u2 = + match u1, u2 with | UAnonymous {rigid=r1}, UAnonymous {rigid=r2} -> r1 = r2 - | UNamed l1, UNamed l2 -> - List.equal (fun (x,m) (y,n) -> glob_sort_name_eq x y && Int.equal m n) l1 l2 + | UNamed l1, UNamed l2 -> f l1 l2 | (UNamed _ | UAnonymous _), _ -> false +let glob_sort_eq u1 u2 = + glob_sort_expr_eq + (List.equal (fun (x,m) (y,n) -> glob_sort_name_eq x y && Int.equal m n)) + u1 u2 + +let glob_level_eq u1 u2 = + glob_sort_expr_eq glob_sort_name_eq u1 u2 + let binding_kind_eq bk1 bk2 = match bk1, bk2 with | Explicit, Explicit -> true | NonMaxImplicit, NonMaxImplicit -> true @@ -123,7 +131,9 @@ let instance_eq f (x1,c1) (x2,c2) = Id.equal x1 x2 && f c1 c2 let mk_glob_constr_eq f c1 c2 = match DAst.get c1, DAst.get c2 with - | GRef (gr1, _), GRef (gr2, _) -> GlobRef.equal gr1 gr2 + | GRef (gr1, u1), GRef (gr2, u2) -> + GlobRef.equal gr1 gr2 && + Option.equal (List.equal glob_level_eq) u1 u2 | GVar id1, GVar id2 -> Id.equal id1 id2 | GEvar (id1, arg1), GEvar (id2, arg2) -> Id.equal id1 id2 && List.equal (instance_eq f) arg1 arg2 diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli index 14bf2f6764..6da8173dce 100644 --- a/pretyping/glob_ops.mli +++ b/pretyping/glob_ops.mli @@ -15,6 +15,8 @@ open Glob_term val glob_sort_eq : Glob_term.glob_sort -> Glob_term.glob_sort -> bool +val glob_level_eq : Glob_term.glob_level -> Glob_term.glob_level -> bool + val cases_pattern_eq : 'a cases_pattern_g -> 'a cases_pattern_g -> bool (** Expect a Prop/SProp/Set/Type universe; raise [ComplexSort] if diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 7be34d4cf1..d672ddc906 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -28,16 +28,22 @@ exception Find_at of int (* timing *) -let timing_enabled = ref false +let get_timing_enabled = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["NativeCompute"; "Timing"] + ~value:false (* profiling *) -let profiling_enabled = ref false +let get_profiling_enabled = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["NativeCompute"; "Profiling"] + ~value:false (* for supported platforms, filename for profiler results *) -let profile_filename = ref "native_compute_profile.data" - let profiler_platform () = match [@warning "-8"] Sys.os_type with | "Unix" -> @@ -48,10 +54,11 @@ let profiler_platform () = | "Win32" -> "Windows (Win32)" | "Cygwin" -> "Windows (Cygwin)" -let get_profile_filename () = !profile_filename - -let set_profile_filename fn = - profile_filename := fn +let get_profile_filename = + Goptions.declare_string_option_and_ref + ~depr:false + ~key:["NativeCompute"; "Profile"; "Filename"] + ~value:"native_compute_profile.data" (* find unused profile filename *) let get_available_profile_filename () = @@ -77,18 +84,6 @@ let get_available_profile_filename () = let _ = Feedback.msg_info (Pp.str msg) in assert false -let get_profiling_enabled () = - !profiling_enabled - -let set_profiling_enabled b = - profiling_enabled := b - -let get_timing_enabled () = - !timing_enabled - -let set_timing_enabled b = - timing_enabled := b - let invert_tag cst tag reloc_tbl = try for j = 0 to Array.length reloc_tbl - 1 do @@ -428,8 +423,8 @@ and nf_evar env sigma evk args = let hyps = Environ.named_context_of_val (Evd.evar_filtered_hyps evi) in let ty = EConstr.to_constr ~abort_on_undefined_evars:false sigma @@ Evd.evar_concl evi in if List.is_empty hyps then begin - assert (Int.equal (Array.length args) 0); - mkEvar (evk, [||]), ty + assert (Array.is_empty args); + mkEvar (evk, []), ty end else (* Let-bound arguments are present in the evar arguments but not @@ -441,7 +436,7 @@ and nf_evar env sigma evk args = (* nf_args takes arguments in the reverse order but produces them in the correct one, so we have to reverse them again for the evar node *) - mkEvar (evk, Array.rev_of_list args), ty + mkEvar (evk, List.rev args), ty let evars_of_evar_map sigma = { Nativelambda.evars_val = Evd.existential_opt_value0 sigma; @@ -496,32 +491,36 @@ let stop_profiler m_pid = let native_norm env sigma c ty = let c = EConstr.Unsafe.to_constr c in let ty = EConstr.Unsafe.to_constr ty in - if not Coq_config.native_compiler then - user_err Pp.(str "Native_compute reduction has been disabled at configure time.") + if not (Flags.get_native_compiler ()) then + user_err Pp.(str "Native_compute reduction has been disabled.") else (* Format.eprintf "Numbers of free variables (named): %i\n" (List.length vl1); Format.eprintf "Numbers of free variables (rel): %i\n" (List.length vl2); *) - let ml_filename, prefix = Nativelib.get_ml_filename () in - let code, upd = mk_norm_code env (evars_of_evar_map sigma) prefix c in let profile = get_profiling_enabled () in let print_timing = get_timing_enabled () in - let tc0 = Sys.time () in + let ml_filename, prefix = Nativelib.get_ml_filename () in + let tnc0 = Unix.gettimeofday () in + let code, upd = mk_norm_code env (evars_of_evar_map sigma) prefix c in + let tnc1 = Unix.gettimeofday () in + let time_info = Format.sprintf "native_compute: Conversion to native code done in %.5f" (tnc1 -. tnc0) in + if print_timing then Feedback.msg_info (Pp.str time_info); + let tc0 = Unix.gettimeofday () in let fn = Nativelib.compile ml_filename code ~profile:profile in - let tc1 = Sys.time () in - let time_info = Format.sprintf "native_compute: Compilation done in %.5f@." (tc1 -. tc0) in + let tc1 = Unix.gettimeofday () in + let time_info = Format.sprintf "native_compute: Compilation done in %.5f" (tc1 -. tc0) in if print_timing then Feedback.msg_info (Pp.str time_info); let profiler_pid = if profile then start_profiler () else None in - let t0 = Sys.time () in + let t0 = Unix.gettimeofday () in Nativelib.call_linker ~fatal:true env ~prefix fn (Some upd); - let t1 = Sys.time () in + let t1 = Unix.gettimeofday () in if profile then stop_profiler profiler_pid; - let time_info = Format.sprintf "native_compute: Evaluation done in %.5f@." (t1 -. t0) in + let time_info = Format.sprintf "native_compute: Evaluation done in %.5f" (t1 -. t0) in if print_timing then Feedback.msg_info (Pp.str time_info); let res = nf_val env sigma !Nativelib.rt1 ty in - let t2 = Sys.time () in - let time_info = Format.sprintf "native_compute: Reification done in %.5f@." (t2 -. t1) in + let t2 = Unix.gettimeofday () in + let time_info = Format.sprintf "native_compute: Reification done in %.5f" (t2 -. t1) in if print_timing then Feedback.msg_info (Pp.str time_info); EConstr.of_constr res diff --git a/pretyping/nativenorm.mli b/pretyping/nativenorm.mli index 4f18174261..73a8add6ec 100644 --- a/pretyping/nativenorm.mli +++ b/pretyping/nativenorm.mli @@ -14,16 +14,6 @@ open Evd (** This module implements normalization by evaluation to OCaml code *) -val get_profile_filename : unit -> string -val set_profile_filename : string -> unit - -val get_profiling_enabled : unit -> bool -val set_profiling_enabled : bool -> unit - -val get_timing_enabled : unit -> bool -val set_timing_enabled : bool -> unit - - val native_norm : env -> evar_map -> constr -> types -> constr (** Conversion with inference of universe constraints *) diff --git a/pretyping/pattern.ml b/pretyping/pattern.ml index 3f2e690da5..1dfb8b2cd1 100644 --- a/pretyping/pattern.ml +++ b/pretyping/pattern.ml @@ -24,7 +24,7 @@ type case_info_pattern = type constr_pattern = | PRef of GlobRef.t | PVar of Id.t - | PEvar of Evar.t * constr_pattern array + | PEvar of constr_pattern Constr.pexistential | PRel of int | PApp of constr_pattern * constr_pattern array | PSoApp of patvar * constr_pattern list diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index b8635d03b7..6d30e0338e 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -31,7 +31,7 @@ let rec constr_pattern_eq p1 p2 = match p1, p2 with | PRef r1, PRef r2 -> GlobRef.equal r1 r2 | PVar v1, PVar v2 -> Id.equal v1 v2 | PEvar (ev1, ctx1), PEvar (ev2, ctx2) -> - Evar.equal ev1 ev2 && Array.equal constr_pattern_eq ctx1 ctx2 + Evar.equal ev1 ev2 && List.equal constr_pattern_eq ctx1 ctx2 | PRel i1, PRel i2 -> Int.equal i1 i2 | PApp (t1, arg1), PApp (t2, arg2) -> @@ -115,7 +115,7 @@ let rec occurn_pattern n = function (occurn_pattern n c) || (List.exists (fun (_,_,p) -> occurn_pattern n p) br) | PMeta _ | PSoApp _ -> true - | PEvar (_,args) -> Array.exists (occurn_pattern n) args + | PEvar (_,args) -> List.exists (occurn_pattern n) args | PVar _ | PRef _ | PSort _ | PInt _ | PFloat _ -> false | PFix (_,(_,tl,bl)) -> Array.exists (occurn_pattern n) tl || Array.exists (occurn_pattern (n+Array.length tl)) bl @@ -190,7 +190,7 @@ let pattern_of_constr env sigma t = (* These are the two evar kinds used for existing goals *) (* see Proofview.mark_in_evm *) if Evd.is_defined sigma evk then pattern_of_constr env (Evd.existential_value0 sigma ev) - else PEvar (evk,Array.map (pattern_of_constr env) ctxt) + else PEvar (evk,List.map (pattern_of_constr env) ctxt) | Evar_kinds.MatchingVar (Evar_kinds.SecondOrderPatVar ido) -> assert false | _ -> PMeta None) diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index ded159e484..f7e3d651ff 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -189,8 +189,10 @@ let interp_sort_info ?loc evd l = type inference_hook = env -> evar_map -> Evar.t -> (evar_map * constr) option +type use_typeclasses = NoUseTC | UseTCForConv | UseTC + type inference_flags = { - use_typeclasses : bool; + use_typeclasses : use_typeclasses; solve_unification_constraints : bool; fail_evar : bool; expand_evars : bool; @@ -231,7 +233,7 @@ let frozen_and_pending_holes (sigma, sigma') = end in FrozenProgress data -let apply_typeclasses ~program_mode env sigma frozen fail_evar = +let apply_typeclasses ~program_mode ~fail_evar env sigma frozen = let filter_frozen = match frozen with | FrozenId map -> fun evk -> Evar.Map.mem evk map | FrozenProgress (lazy (frozen, _)) -> fun evk -> Evar.Set.mem evk frozen @@ -270,7 +272,7 @@ let apply_heuristics env sigma fail_evar = let check_typeclasses_instances_are_solved ~program_mode env current_sigma frozen = (* Naive way, call resolution again with failure flag *) - apply_typeclasses ~program_mode env current_sigma frozen true + apply_typeclasses ~program_mode ~fail_evar:true env current_sigma frozen let check_extra_evars_are_solved env current_sigma frozen = match frozen with | FrozenId _ -> () @@ -312,9 +314,9 @@ let solve_remaining_evars ?hook flags env ?initial sigma = let program_mode = flags.program_mode in let frozen = frozen_and_pending_holes (initial, sigma) in let sigma = - if flags.use_typeclasses - then apply_typeclasses ~program_mode env sigma frozen false - else sigma + match flags.use_typeclasses with + | UseTC -> apply_typeclasses ~program_mode ~fail_evar:false env sigma frozen + | NoUseTC | UseTCForConv -> sigma in let sigma = match hook with | None -> sigma @@ -436,7 +438,15 @@ let pretype_ref ?loc sigma env ref us = match ref with | GlobRef.VarRef id -> (* Section variable *) - (try sigma, make_judge (mkVar id) (NamedDecl.get_type (lookup_named id !!env)) + (try + let ty = NamedDecl.get_type (lookup_named id !!env) in + (match us with + | None | Some [] -> () + | Some (_ :: _) -> + CErrors.user_err ?loc + Pp.(str "Section variables are not polymorphic:" ++ spc () + ++ str "universe instance should have length 0.")); + sigma, make_judge (mkVar id) ty with Not_found -> (* This may happen if env is a goal env and section variables have been cleared - section variables should be different from goal @@ -597,7 +607,7 @@ let pretype_instance self ~program_mode ~poly resolve_tc env sigma loc hyps evk ((id,c)::subst, update, sigma) in let subst,inst,sigma = List.fold_right f hyps ([],update,sigma) in check_instance loc subst inst; - sigma, Array.map_of_list snd subst + sigma, List.map snd subst module Default = struct @@ -1287,21 +1297,25 @@ let ise_pretype_gen flags env sigma lvar kind c = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in let env = GlobEnv.make ~hypnaming env sigma lvar in + let use_tc = match flags.use_typeclasses with + | NoUseTC -> false + | UseTC | UseTCForConv -> true + in let sigma', c', c'_ty = match kind with | WithoutTypeConstraint | UnknownIfTermOrType -> - let sigma, j = pretype ~program_mode ~poly flags.use_typeclasses empty_tycon env sigma c in + let sigma, j = pretype ~program_mode ~poly use_tc empty_tycon env sigma c in sigma, j.uj_val, j.uj_type | OfType exptyp -> - let sigma, j = pretype ~program_mode ~poly flags.use_typeclasses (mk_tycon exptyp) env sigma c in + let sigma, j = pretype ~program_mode ~poly use_tc (mk_tycon exptyp) env sigma c in sigma, j.uj_val, j.uj_type | IsType -> - let sigma, tj = pretype_type ~program_mode ~poly flags.use_typeclasses empty_valcon env sigma c in + let sigma, tj = pretype_type ~program_mode ~poly use_tc empty_valcon env sigma c in sigma, tj.utj_val, mkSort tj.utj_type in process_inference_flags flags !!env sigma (sigma',c',c'_ty) let default_inference_flags fail = { - use_typeclasses = true; + use_typeclasses = UseTC; solve_unification_constraints = true; fail_evar = fail; expand_evars = true; @@ -1310,7 +1324,7 @@ let default_inference_flags fail = { } let no_classes_no_fail_inference_flags = { - use_typeclasses = false; + use_typeclasses = NoUseTC; solve_unification_constraints = true; fail_evar = false; expand_evars = true; diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index abbb745161..8be7b1477b 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -44,8 +44,17 @@ type typing_constraint = | OfType of types (** A term of the expected type *) | WithoutTypeConstraint (** A term of unknown expected type *) +type use_typeclasses = NoUseTC | UseTCForConv | UseTC +(** Typeclasses are used in 2 ways: + +- through the "Typeclass Resolution For Conversion" option, if a + conversion problem fails we try again after resolving typeclasses + (UseTCForConv and UseTC) +- after pretyping we resolve typeclasses (UseTC) (in [solve_remaining_evars]) +*) + type inference_flags = { - use_typeclasses : bool; + use_typeclasses : use_typeclasses; solve_unification_constraints : bool; fail_evar : bool; expand_evars : bool; diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 8822cc2338..f7456ef35e 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -30,14 +30,6 @@ exception Elimconst their parameters in its stack. *) -let () = Goptions.(declare_bool_option { - optdepr = false; - optkey = ["Cumulativity";"Weak";"Constraints"]; - optread = (fun () -> not !UState.drop_weak_constraints); - optwrite = (fun a -> UState.drop_weak_constraints:=not a); -}) - - (** Support for reduction effects *) open Mod_subst @@ -715,7 +707,7 @@ let reducible_mind_case sigma c = match EConstr.kind sigma c with f x := t. End M. Definition f := u. and say goodbye to any hope of refolding M.f this way ... *) -let magicaly_constant_of_fixbody env sigma reference bd = function +let magically_constant_of_fixbody env sigma reference bd = function | Name.Anonymous -> bd | Name.Name id -> let open UnivProblem in @@ -757,7 +749,7 @@ let contract_cofix ?env sigma ?reference (bodynum,(names,types,bodies as typedbo | Some e -> match reference with | None -> bd - | Some r -> magicaly_constant_of_fixbody e sigma r bd names.(ind).binder_name in + | Some r -> magically_constant_of_fixbody e sigma r bd names.(ind).binder_name in let closure = List.init nbodies make_Fi in substl closure bodies.(bodynum) @@ -799,7 +791,7 @@ let contract_fix ?env sigma ?reference ((recindices,bodynum),(names,types,bodies | Some e -> match reference with | None -> bd - | Some r -> magicaly_constant_of_fixbody e sigma r bd names.(ind).binder_name in + | Some r -> magically_constant_of_fixbody e sigma r bd names.(ind).binder_name in let closure = List.init nbodies make_Fi in substl closure bodies.(bodynum) @@ -966,13 +958,11 @@ module CredNative = RedNative(CNativeEntries) contract_* in any case . *) -let debug_RAKAM = ref (false) -let () = Goptions.(declare_bool_option { - optdepr = false; - optkey = ["Debug";"RAKAM"]; - optread = (fun () -> !debug_RAKAM); - optwrite = (fun a -> debug_RAKAM:=a); -}) +let debug_RAKAM = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["Debug";"RAKAM"] + ~value:false let equal_stacks sigma (x, l) (y, l') = let f_equal x y = eq_constr sigma x y in @@ -983,7 +973,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = let open Context.Named.Declaration in let open ReductionBehaviour in let rec whrec cst_l (x, stack) = - let () = if !debug_RAKAM then + let () = if debug_RAKAM () then let open Pp in let pr c = Termops.Internal.print_constr_env env sigma c in Feedback.msg_debug @@ -994,7 +984,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = in let c0 = EConstr.kind sigma x in let fold () = - let () = if !debug_RAKAM then + let () = if debug_RAKAM () then let open Pp in Feedback.msg_debug (str "<><><><><>") in ((EConstr.of_kind c0, stack),cst_l) in @@ -1746,26 +1736,46 @@ let is_sort env sigma t = let whd_betaiota_deltazeta_for_iota_state ts env sigma s = let refold = false in let tactic_mode = false in - let rec whrec csts s = - let (t, stack as s),csts' = whd_state_gen ~csts ~refold ~tactic_mode CClosure.betaiota env sigma s in + let all' = CClosure.RedFlags.red_add_transparent CClosure.all ts in + (* Unset the sharing flag to get a call-by-name reduction. This matters for + the shape of the generated term. *) + let env' = Environ.set_typing_flags { (Environ.typing_flags env) with Declarations.share_reduction = false } env in + let whd_opt c = + let open CClosure in + let evars ev = safe_evar_value sigma ev in + let infos = create_clos_infos ~evars all' env' in + let tab = create_tab () in + let c = inject (EConstr.Unsafe.to_constr (Stack.zip sigma c)) in + let (c, stk) = whd_stack infos tab c [] in + match fterm_of c with + | (FConstruct _ | FCoFix _) -> + (* Non-neutral normal, can trigger reduction below *) + let c = EConstr.of_constr (term_of_process c stk) in + Some (decompose_app_vect sigma c) + | _ -> None + in + let rec whrec s = + let (t, stack as s), _ = whd_state_gen ~refold ~tactic_mode CClosure.betaiota env sigma s in match Stack.strip_app stack with |args, (Stack.Case _ :: _ as stack') -> - let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' ~refold ~tactic_mode - (CClosure.RedFlags.red_add_transparent CClosure.all ts) env sigma (t,args) in - if reducible_mind_case sigma t_o then whrec csts_o (t_o, stack_o@stack') else s,csts' + begin match whd_opt (t, args) with + | Some (t_o, args) when reducible_mind_case sigma t_o -> whrec (t_o, Stack.append_app args stack') + | (Some _ | None) -> s + end |args, (Stack.Fix _ :: _ as stack') -> - let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' ~refold ~tactic_mode - (CClosure.RedFlags.red_add_transparent CClosure.all ts) env sigma (t,args) in - if isConstruct sigma t_o then whrec csts_o (t_o, stack_o@stack') else s,csts' + begin match whd_opt (t, args) with + | Some (t_o, args) when isConstruct sigma t_o -> whrec (t_o, Stack.append_app args stack') + | (Some _ | None) -> s + end |args, (Stack.Proj (p,_) :: stack'') -> - let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' ~refold ~tactic_mode - (CClosure.RedFlags.red_add_transparent CClosure.all ts) env sigma (t,args) in - if isConstruct sigma t_o then - whrec Cst_stack.empty (Stack.nth stack_o (Projection.npars p + Projection.arg p), stack'') - else s,csts' - |_, ((Stack.App _|Stack.Cst _|Stack.Primitive _) :: _|[]) -> s,csts' + begin match whd_opt (t, args) with + | Some (t_o, args) when isConstruct sigma t_o -> + whrec (args.(Projection.npars p + Projection.arg p), stack'') + | (Some _ | None) -> s + end + |_, ((Stack.App _|Stack.Cst _|Stack.Primitive _) :: _|[]) -> s in - fst (whrec Cst_stack.empty s) + whrec s let find_conclusion env sigma = let rec decrec env c = diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 70605d58ab..2c717b8774 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -86,7 +86,7 @@ let evaluable_reference_eq sigma r1 r2 = match r1, r2 with | EvalVar id1, EvalVar id2 -> Id.equal id1 id2 | EvalRel i1, EvalRel i2 -> Int.equal i1 i2 | EvalEvar (e1, ctx1), EvalEvar (e2, ctx2) -> - Evar.equal e1 e2 && Array.equal (EConstr.eq_constr sigma) ctx1 ctx2 + Evar.equal e1 e2 && List.equal (EConstr.eq_constr sigma) ctx1 ctx2 | _ -> false let mkEvalRef ref u = @@ -408,7 +408,7 @@ let substl_with_function subst sigma constr = let (sigma, evk) = Evarutil.new_pure_evar venv sigma dummy in evd := sigma; minargs := Evar.Map.add evk min !minargs; - Vars.lift k (mkEvar (evk, [|fx;ref|])) + Vars.lift k (mkEvar (evk, [fx; ref])) | (fx, None) -> Vars.lift k fx else mkRel (i - Array.length v) | _ -> @@ -455,7 +455,7 @@ let substl_checking_arity env subst sigma c = (* we propagate the constraints: solved problems are substituted; the other ones are replaced by the function symbol *) let rec nf_fix c = match EConstr.kind sigma c with - | Evar (i,[|fx;f|]) when Evar.Map.mem i minargs -> + | Evar (i,[fx;f]) when Evar.Map.mem i minargs -> (* FIXME: find a less hackish way of doing this *) begin match EConstr.kind sigma' c with | Evar _ -> f diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 90dde01915..f5aaac315a 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -43,23 +43,17 @@ type subst0 = module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration -let keyed_unification = ref (false) -let () = Goptions.(declare_bool_option { - optdepr = false; - optkey = ["Keyed";"Unification"]; - optread = (fun () -> !keyed_unification); - optwrite = (fun a -> keyed_unification:=a); -}) - -let is_keyed_unification () = !keyed_unification - -let debug_unification = ref (false) -let () = Goptions.(declare_bool_option { - optdepr = false; - optkey = ["Debug";"Tactic";"Unification"]; - optread = (fun () -> !debug_unification); - optwrite = (fun a -> debug_unification:=a); -}) +let is_keyed_unification = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["Keyed";"Unification"] + ~value:false + +let debug_unification = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["Debug";"Tactic";"Unification"] + ~value:false (** Making this unification algorithm correct w.r.t. the evar-map abstraction breaks too much stuff. So we redefine incorrect functions here. *) @@ -82,7 +76,7 @@ let occur_meta_or_undefined_evar evd c = | Evar (ev,args) -> (match evar_body (Evd.find evd ev) with | Evar_defined c -> - occrec (EConstr.Unsafe.to_constr c); Array.iter occrec args + occrec (EConstr.Unsafe.to_constr c); List.iter occrec args | Evar_empty -> raise Occur) | _ -> Constr.iter occrec c in try occrec c; false with Occur | Not_found -> true @@ -144,9 +138,9 @@ let abstract_list_all env evd typ c l = error_cannot_find_well_typed_abstraction env evd p l (Some (env',x)) in evd,(p,typp) -let set_occurrences_of_last_arg args = +let set_occurrences_of_last_arg n = Evarconv.AtOccurrences AllOccurrences :: - List.tl (Array.map_to_list (fun _ -> Evarconv.Unspecified Abstraction.Abstract) args) + List.tl (List.init n (fun _ -> Evarconv.Unspecified Abstraction.Abstract)) let occurrence_test _ _ _ env sigma _ c1 c2 = match EConstr.eq_constr_universes env sigma c1 c2 with @@ -159,7 +153,8 @@ let abstract_list_all_with_dependencies env evd typ c l = let (evd, ev) = new_evar env evd typ in let evd,ev' = evar_absorb_arguments env evd (destEvar evd ev) l in let n = List.length l in - let argoccs = set_occurrences_of_last_arg (Array.sub (snd ev') 0 n) in + let () = assert (n <= List.length (snd ev')) in + let argoccs = set_occurrences_of_last_arg n in let evd,b = Evarconv.second_order_matching (Evarconv.default_flags_of TransparentState.empty) @@ -629,7 +624,7 @@ let subst_defined_metas_evars sigma (bl,el) c = substrec (EConstr.Unsafe.to_constr (pi2 (List.find select bl))) | Evar (evk,args) -> let eq c1 c2 = Constr.equal c1 (EConstr.Unsafe.to_constr c2) in - let select (_,(evk',args'),_) = Evar.equal evk evk' && Array.for_all2 eq args args' in + let select (_,(evk',args'),_) = Evar.equal evk evk' && List.for_all2 eq args args' in (try substrec (EConstr.Unsafe.to_constr (pi3 (List.find select el))) with Not_found -> Constr.map substrec c) | _ -> Constr.map substrec c @@ -702,7 +697,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e let cM = Evarutil.whd_head_evar sigma curm and cN = Evarutil.whd_head_evar sigma curn in let () = - if !debug_unification then + if debug_unification () then Feedback.msg_debug ( Termops.Internal.print_constr_env curenv sigma cM ++ str" ~= " ++ Termops.Internal.print_constr_env curenv sigma cN) @@ -1127,7 +1122,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e else error_cannot_unify (fst curenvnb) sigma (cM,cN) in - if !debug_unification then Feedback.msg_debug (str "Starting unification"); + if debug_unification () then Feedback.msg_debug (str "Starting unification"); let opt = { at_top = conv_at_top; with_types = false; with_cs = true } in try let res = @@ -1152,11 +1147,11 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e let a = match res with | Some sigma -> sigma, ms, es | None -> unirec_rec (env,0) cv_pb opt subst m n in - if !debug_unification then Feedback.msg_debug (str "Leaving unification with success"); + if debug_unification () then Feedback.msg_debug (str "Leaving unification with success"); a with e -> let e = Exninfo.capture e in - if !debug_unification then Feedback.msg_debug (str "Leaving unification with failure"); + if debug_unification () then Feedback.msg_debug (str "Leaving unification with failure"); Exninfo.iraise e let unify_0 env sigma = unify_0_with_initial_metas (sigma,[],[]) true env @@ -1745,7 +1740,7 @@ let make_abstraction env evd ccl abs = env evd c ty occs check_occs ccl let keyed_unify env evd kop = - if not !keyed_unification then fun cl -> true + if not (is_keyed_unification ()) then fun cl -> true else match kop with | None -> fun _ -> true @@ -1767,7 +1762,7 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = (try if closed0 evd cl && not (isEvar evd cl) && keyed_unify env evd kop cl then (try - if !keyed_unification then + if is_keyed_unification () then let f1, l1 = decompose_app_vect evd op in let f2, l2 = decompose_app_vect evd cl in w_typed_unify_array env evd flags f1 l1 f2 l2,cl @@ -1913,7 +1908,7 @@ let w_unify_to_subterm_list env evd flags hdmeta oplist t = else let allow_K = flags.allow_K_in_toplevel_higher_order_unification in let flags = - if unsafe_occur_meta_or_existential op || !keyed_unification then + if unsafe_occur_meta_or_existential op || is_keyed_unification () then (* This is up to delta for subterms w/o metas ... *) flags else diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index d4da93cc5b..37c34d55cf 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -205,7 +205,7 @@ and nf_evar env sigma evk stk = let hyps = Environ.named_context_of_val (Evd.evar_filtered_hyps evi) in let concl = EConstr.to_constr ~abort_on_undefined_evars:false sigma @@ Evd.evar_concl evi in if List.is_empty hyps then - nf_stk env sigma (mkEvar (evk, [||])) concl stk + nf_stk env sigma (mkEvar (evk, [])) concl stk else match stk with | Zapp args :: stk -> (* We assume that there is no consecutive Zapp nodes in a VM stack. Is that @@ -217,6 +217,7 @@ and nf_evar env sigma evk stk = let t = List.fold_left fold concl hyps in let t, args = nf_args env sigma args t in let inst, args = Array.chop (List.length hyps) args in + let inst = Array.to_list inst in let c = mkApp (mkEvar (evk, inst), args) in nf_stk env sigma c t stk | _ -> diff --git a/printing/printer.ml b/printing/printer.ml index 32dc4bb0f0..c2f73715f0 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -25,42 +25,26 @@ module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration module CompactedDecl = Context.Compacted.Declaration -let enable_unfocused_goal_printing = ref false -let enable_goal_tags_printing = ref false -let enable_goal_names_printing = ref false - -let should_tag() = !enable_goal_tags_printing -let should_unfoc() = !enable_unfocused_goal_printing -let should_gname() = !enable_goal_names_printing - - -let () = - let open Goptions in - declare_bool_option - { optdepr = false; - optkey = ["Printing";"Unfocused"]; - optread = (fun () -> !enable_unfocused_goal_printing); - optwrite = (fun b -> enable_unfocused_goal_printing:=b) } - (* This is set on by proofgeneral proof-tree mode. But may be used for other purposes *) -let () = - let open Goptions in - declare_bool_option - { optdepr = false; - optkey = ["Printing";"Goal";"Tags"]; - optread = (fun () -> !enable_goal_tags_printing); - optwrite = (fun b -> enable_goal_tags_printing:=b) } - - -let () = - let open Goptions in - declare_bool_option - { optdepr = false; - optkey = ["Printing";"Goal";"Names"]; - optread = (fun () -> !enable_goal_names_printing); - optwrite = (fun b -> enable_goal_names_printing:=b) } - +let print_goal_tag_opt_name = ["Printing";"Goal";"Tags"] +let should_tag = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:print_goal_tag_opt_name + ~value:false + +let should_unfoc = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["Printing";"Unfocused"] + ~value:false + +let should_gname = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["Printing";"Goal";"Names"] + ~value:false (**********************************************************************) (** Terms *) @@ -407,17 +391,10 @@ let pr_context_limit_compact ?n env sigma = (* The number of printed hypothesis in a goal *) (* If [None], no limit *) -let print_hyps_limit = ref (None : int option) +let print_hyps_limit = + Goptions.declare_intopt_option_and_ref ~depr:false ~key:["Hyps";"Limit"] -let () = - let open Goptions in - declare_int_option - { optdepr = false; - optkey = ["Hyps";"Limit"]; - optread = (fun () -> !print_hyps_limit); - optwrite = (fun x -> print_hyps_limit := x) } - -let pr_context_of env sigma = match !print_hyps_limit with +let pr_context_of env sigma = match print_hyps_limit () with | None -> hv 0 (pr_context_limit_compact env sigma) | Some n -> hv 0 (pr_context_limit_compact ~n env sigma) @@ -615,18 +592,14 @@ let print_evar_constraints gl sigma = str" with candidates:" ++ fnl () ++ hov 0 ppcandidates else mt () -let should_print_dependent_evars = ref false - -let () = - let open Goptions in - declare_bool_option - { optdepr = false; - optkey = ["Printing";"Dependent";"Evars";"Line"]; - optread = (fun () -> !should_print_dependent_evars); - optwrite = (fun v -> should_print_dependent_evars := v) } +let should_print_dependent_evars = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["Printing";"Dependent";"Evars";"Line"] + ~value:false let print_dependent_evars gl sigma seeds = - if !should_print_dependent_evars then + if should_print_dependent_evars () then let mt_pp = mt () in let evars = Evarutil.gather_dependent_evars sigma seeds in let evars_pp = Evar.Map.fold (fun e i s -> @@ -1016,4 +989,5 @@ let print_and_diff oldp newp = let pr_typing_flags flags = str "check_guarded: " ++ bool flags.check_guarded ++ fnl () ++ str "check_positive: " ++ bool flags.check_positive ++ fnl () - ++ str "check_universes: " ++ bool flags.check_universes + ++ str "check_universes: " ++ bool flags.check_universes ++ fnl () + ++ str "cumulative sprop: " ++ bool flags.cumulative_sprop diff --git a/printing/printer.mli b/printing/printer.mli index 936426949c..8c633b5e79 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -19,9 +19,7 @@ open Notation_term (** These are the entry points for printing terms, context, tac, ... *) -val enable_unfocused_goal_printing: bool ref -val enable_goal_tags_printing : bool ref -val enable_goal_names_printing : bool ref +val print_goal_tag_opt_name : string list (** Terms *) diff --git a/printing/proof_diffs.ml b/printing/proof_diffs.ml index 3a6424ba9f..c78cc96a83 100644 --- a/printing/proof_diffs.ml +++ b/printing/proof_diffs.ml @@ -46,36 +46,37 @@ let write_color_enabled enabled = let color_enabled () = !term_color -let diff_option = ref `OFF +type diffOpt = DiffOff | DiffOn | DiffRemoved -let read_diffs_option () = match !diff_option with -| `OFF -> "off" -| `ON -> "on" -| `REMOVED -> "removed" +let diffs_to_string = function + | DiffOff -> "off" + | DiffOn -> "on" + | DiffRemoved -> "removed" -let write_diffs_option opt = - let enable opt = - if not (color_enabled ()) then - CErrors.user_err Pp.(str "Enabling Diffs requires setting the \"-color\" command line argument to \"on\" or \"auto\".") - else - diff_option := opt - in - match opt with - | "off" -> diff_option := `OFF - | "on" -> enable `ON - | "removed" -> enable `REMOVED + +let assert_color_enabled () = + if not (color_enabled ()) then + CErrors.user_err + Pp.(str "Enabling Diffs requires setting the \"-color\" command line argument to \"on\" or \"auto\".") + +let string_to_diffs = function + | "off" -> DiffOff + | "on" -> assert_color_enabled (); DiffOn + | "removed" -> assert_color_enabled (); DiffRemoved | _ -> CErrors.user_err Pp.(str "Diffs option only accepts the following values: \"off\", \"on\", \"removed\".") -let () = - Goptions.(declare_string_option { - optdepr = false; - optkey = ["Diffs"]; - optread = read_diffs_option; - optwrite = write_diffs_option - }) +let opt_name = ["Diffs"] + +let diff_option = + Goptions.declare_interpreted_string_option_and_ref + ~depr:false + ~key:opt_name + ~value:DiffOff + string_to_diffs + diffs_to_string -let show_diffs () = !diff_option <> `OFF;; -let show_removed () = !diff_option = `REMOVED;; +let show_diffs () = match diff_option () with DiffOff -> false | _ -> true +let show_removed () = match diff_option () with DiffRemoved -> true | _ -> false (* DEBUG/UNIT TEST *) diff --git a/printing/proof_diffs.mli b/printing/proof_diffs.mli index 24b171770a..ea64439456 100644 --- a/printing/proof_diffs.mli +++ b/printing/proof_diffs.mli @@ -10,8 +10,8 @@ (* diff options *) -(** Controls whether to show diffs. Takes values "on", "off", "removed" *) -val write_diffs_option : string -> unit +(** Name of Diffs option *) +val opt_name : string list (** Returns true if the diffs option is "on" or "removed" *) val show_diffs : unit -> bool diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index 000b34ed0a..53254e9511 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -50,7 +50,7 @@ let w_refine (evk,evi) (ltac_var,rawc) env sigma = let env = Evd.evar_filtered_env env evi in let sigma',typed_c = let flags = { - Pretyping.use_typeclasses = true; + Pretyping.use_typeclasses = Pretyping.UseTC; Pretyping.solve_unification_constraints = true; Pretyping.fail_evar = false; Pretyping.expand_evars = true; diff --git a/proofs/goal.ml b/proofs/goal.ml index b1f8fd3e97..53d3047bc7 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -69,7 +69,7 @@ module V82 = struct let (evars, evk) = Evarutil.new_pure_evar_full evars ~typeclass_candidate:false evi in let evars = Evd.restore_future_goals evars prev_future_goals in let ctxt = Environ.named_context_of_val hyps in - let inst = Array.map_of_list (NamedDecl.get_id %> EConstr.mkVar) ctxt in + let inst = List.map (NamedDecl.get_id %> EConstr.mkVar) ctxt in let ev = EConstr.mkEvar (evk,inst) in (evk, ev, evars) diff --git a/proofs/goal_select.ml b/proofs/goal_select.ml index 29e19778e4..e847535aaf 100644 --- a/proofs/goal_select.ml +++ b/proofs/goal_select.ml @@ -22,11 +22,6 @@ type t = | SelectId of Id.t | SelectAll -(* Default goal selector: selector chosen when a tactic is applied - without an explicit selector. *) -let default_goal_selector = ref (SelectNth 1) -let get_default_goal_selector () = !default_goal_selector - let pr_range_selector (i, j) = if i = j then Pp.int i else Pp.(int i ++ str "-" ++ int j) @@ -53,15 +48,12 @@ let parse_goal_selector = function with Failure _ -> CErrors.user_err Pp.(str err_msg) end -let () = let open Goptions in - declare_string_option - { optdepr = false; - optkey = ["Default";"Goal";"Selector"] ; - optread = begin fun () -> - Pp.string_of_ppcmds - (pr_goal_selector !default_goal_selector) - end; - optwrite = begin fun n -> - default_goal_selector := parse_goal_selector n - end - } +(* Default goal selector: selector chosen when a tactic is applied + without an explicit selector. *) +let get_default_goal_selector = + Goptions.declare_interpreted_string_option_and_ref + ~depr:false + ~key:["Default";"Goal";"Selector"] + ~value:(SelectNth 1) + parse_goal_selector + (fun v -> Pp.string_of_ppcmds @@ pr_goal_selector v) diff --git a/proofs/proof.ml b/proofs/proof.ml index 21006349d2..75aca7e7ff 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -63,7 +63,7 @@ exception CannotUnfocusThisWay (* Cannot focus on non-existing subgoals *) exception NoSuchGoals of int * int -exception NoSuchGoal of Names.Id.t +exception NoSuchGoal of Names.Id.t option exception FullyUnfocused @@ -74,8 +74,10 @@ let _ = CErrors.register_handler begin function Some Pp.(str "[Focus] No such goal (" ++ int i ++ str").") | NoSuchGoals (i,j) -> Some Pp.(str "[Focus] Not every goal in range ["++ int i ++ str","++int j++str"] exist.") - | NoSuchGoal id -> + | NoSuchGoal (Some id) -> Some Pp.(str "[Focus] No such goal: " ++ str (Names.Id.to_string id) ++ str ".") + | NoSuchGoal None -> + Some Pp.(str "[Focus] No such goal.") | FullyUnfocused -> Some (Pp.str "The proof is not focused") | _ -> None @@ -233,7 +235,7 @@ let focus_id cond inf id pr = raise CannotUnfocusThisWay end | None -> - raise (NoSuchGoal id) + raise (NoSuchGoal (Some id)) end let rec unfocus kind pr () = @@ -506,3 +508,124 @@ let pr_proof p = str "given up: " ++ pr_goal_list given_up ++ str "]" ) + +let use_unification_heuristics = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["Solve";"Unification";"Constraints"] + ~value:true + +exception SuggestNoSuchGoals of int * t + +let solve ?with_end_tac gi info_lvl tac pr = + let tac = match with_end_tac with + | None -> tac + | Some etac -> Proofview.tclTHEN tac etac in + let tac = match info_lvl with + | None -> tac + | Some _ -> Proofview.Trace.record_info_trace tac + in + let nosuchgoal = Proofview.tclZERO (SuggestNoSuchGoals (1,pr)) in + let tac = let open Goal_select in match gi with + | SelectAlreadyFocused -> + let open Proofview.Notations in + Proofview.numgoals >>= fun n -> + if n == 1 then tac + else + let e = CErrors.UserError + (None, + Pp.(str "Expected a single focused goal but " ++ + int n ++ str " goals are focused.")) + in + Proofview.tclZERO e + + | SelectNth i -> Proofview.tclFOCUS ~nosuchgoal i i tac + | SelectList l -> Proofview.tclFOCUSLIST ~nosuchgoal l tac + | SelectId id -> Proofview.tclFOCUSID ~nosuchgoal id tac + | SelectAll -> tac + in + let tac = + if use_unification_heuristics () then + Proofview.tclTHEN tac Refine.solve_constraints + else tac + in + let env = Global.env () in + let (p,(status,info),()) = 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 (Pp.hov 0 (Proofview.Trace.pr_info env sigma ~lvl:i info)) + in + (p,status) + +(**********************************************************************) +(* Shortcut to build a term using tactics *) + +let refine_by_tactic ~name ~poly env sigma ty tac = + (* Save the initial side-effects to restore them afterwards. We set the + current set of side-effects to be empty so that we can retrieve the + ones created during the tactic invocation easily. *) + let eff = Evd.eval_side_effects sigma in + let sigma = Evd.drop_side_effects sigma in + (* Save the existing goals *) + let prev_future_goals = Evd.save_future_goals sigma in + (* Start a proof *) + let prf = start ~name ~poly sigma [env, ty] in + let (prf, _, ()) = + try run_tactic env tac prf + with Logic_monad.TacticFailure e as src -> + (* Catch the inner error of the monad tactic *) + let (_, info) = Exninfo.capture src in + Exninfo.iraise (e, info) + in + (* Plug back the retrieved sigma *) + let { goals; stack; shelf; given_up; sigma; entry } = data prf in + assert (stack = []); + let ans = match Proofview.initial_goals entry with + | [c, _] -> c + | _ -> assert false + in + let ans = EConstr.to_constr ~abort_on_undefined_evars:false sigma ans in + (* [neff] contains the freshly generated side-effects *) + let neff = Evd.eval_side_effects sigma in + (* Reset the old side-effects *) + let sigma = Evd.drop_side_effects sigma in + let sigma = Evd.emit_side_effects eff sigma in + (* Restore former goals *) + let sigma = Evd.restore_future_goals sigma prev_future_goals in + (* Push remaining goals as future_goals which is the only way we + have to inform the caller that there are goals to collect while + not being encapsulated in the monad *) + (* Goals produced by tactic "shelve" *) + let sigma = List.fold_right (Evd.declare_future_goal ~tag:Evd.ToShelve) shelf sigma in + (* Goals produced by tactic "give_up" *) + let sigma = List.fold_right (Evd.declare_future_goal ~tag:Evd.ToGiveUp) given_up sigma in + (* Other goals *) + let sigma = List.fold_right Evd.declare_future_goal goals sigma in + (* Get rid of the fresh side-effects by internalizing them in the term + itself. Note that this is unsound, because the tactic may have solved + other goals that were already present during its invocation, so that + those goals rely on effects that are not present anymore. Hopefully, + this hack will work in most cases. *) + let neff = neff.Evd.seff_private in + let (ans, _) = Safe_typing.inline_private_constants env ((ans, Univ.ContextSet.empty), neff) in + ans, sigma + +let get_nth_V82_goal p i = + let { sigma; goals } = data p in + try { Evd.it = List.nth goals (i-1) ; sigma } + with Failure _ -> raise (NoSuchGoal None) + +let get_goal_context_gen pf i = + let { Evd.it=goal ; sigma=sigma; } = get_nth_V82_goal pf i in + (sigma, Global.env_of_context (Goal.V82.hyps sigma goal)) + +let get_proof_context p = + try get_goal_context_gen p 1 + with + | NoSuchGoal _ -> + (* No more focused goals *) + let { sigma } = data p in + sigma, Global.env () diff --git a/proofs/proof.mli b/proofs/proof.mli index 1a0b105723..0e5bdaf07d 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -143,6 +143,8 @@ exception CannotUnfocusThisWay Bullet.push. *) exception NoSuchGoals of int * int +exception NoSuchGoal of Names.Id.t option + (* Unfocusing command. Raises [FullyUnfocused] if the proof is not focused. Raises [CannotUnfocusThisWay] if the proof the unfocusing condition @@ -207,3 +209,41 @@ end (* returns the set of all goals in the proof *) val all_goals : t -> Goal.Set.t + +(** [solve (SelectNth n) tac] applies tactic [tac] to the [n]th + subgoal of the current focused proof. [solve SelectAll + tac] applies [tac] to all subgoals. *) + +val solve : + ?with_end_tac:unit Proofview.tactic + -> Goal_select.t + -> int option + -> unit Proofview.tactic + -> t + -> t * bool + +(** Option telling if unification heuristics should be used. *) +val use_unification_heuristics : unit -> bool + +val refine_by_tactic + : name:Names.Id.t + -> poly:bool + -> Environ.env + -> Evd.evar_map + -> EConstr.types + -> unit Proofview.tactic + -> Constr.constr * Evd.evar_map +(** A variant of the above function that handles open terms as well. + Caveat: all effects are purged in the returned term at the end, but other + evars solved by side-effects are NOT purged, so that unexpected failures may + occur. Ideally all code using this function should be rewritten in the + monad. *) + +exception SuggestNoSuchGoals of int * t + +(** {6 Helpers to obtain proof state when in an interactive proof } *) +val get_goal_context_gen : t -> int -> Evd.evar_map * Environ.env + +(** [get_proof_context ()] gets the goal context for the first subgoal + of the proof *) +val get_proof_context : t -> Evd.evar_map * Environ.env diff --git a/proofs/proof_bullet.ml b/proofs/proof_bullet.ml index f1f7361317..41cb7399da 100644 --- a/proofs/proof_bullet.ml +++ b/proofs/proof_bullet.ml @@ -174,34 +174,25 @@ module Strict = struct end (* Current bullet behavior, controlled by the option *) -let current_behavior = ref Strict.strict - -let () = - Goptions.(declare_string_option { - optdepr = false; - optkey = ["Bullet";"Behavior"]; - optread = begin fun () -> - (!current_behavior).name - end; - optwrite = begin fun n -> - current_behavior := - try Hashtbl.find behaviors n - with Not_found -> - CErrors.user_err Pp.(str ("Unknown bullet behavior: \"" ^ n ^ "\".")) - end - }) +let current_behavior = + Goptions.declare_interpreted_string_option_and_ref + ~depr:false + ~key:["Bullet";"Behavior"] + ~value:Strict.strict + (fun n -> + try Hashtbl.find behaviors n + with Not_found -> + CErrors.user_err Pp.(str ("Unknown bullet behavior: \"" ^ n ^ "\"."))) + (fun v -> v.name) let put p b = - (!current_behavior).put p b + (current_behavior ()).put p b let suggest p = - (!current_behavior).suggest p - -(* Better printing for bullet exceptions *) -exception SuggestNoSuchGoals of int * Proof.t + (current_behavior ()).suggest p let _ = CErrors.register_handler begin function - | SuggestNoSuchGoals(n,proof) -> + | Proof.SuggestNoSuchGoals(n,proof) -> let suffix = suggest proof in Some (Pp.(str "No such " ++ str (CString.plural n "goal") ++ str "." ++ pr_non_empty_arg (fun x -> x) suffix)) diff --git a/proofs/proof_bullet.mli b/proofs/proof_bullet.mli index 687781361c..f15b7824ff 100644 --- a/proofs/proof_bullet.mli +++ b/proofs/proof_bullet.mli @@ -44,5 +44,3 @@ val register_behavior : behavior -> unit *) val put : Proof.t -> t -> Proof.t val suggest : Proof.t -> Pp.t - -exception SuggestNoSuchGoals of int * Proof.t diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index c8eb7b08f1..87d844edb3 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -138,7 +138,9 @@ module Make(T : Task) () = struct set_slave_opt tl (* We need to pass some options with one argument *) | ( "-I" | "-include" | "-top" | "-topfile" | "-coqlib" | "-exclude-dir" | "-compat" - | "-require" | "-w" | "-color" | "-init-file" + | "-require-import" | "-require-export" | "-require-import-from" | "-require-export-from" + | "-ri" | "-re" | "-rifrom" | "-refrom" | "-load-vernac-object" + | "-w" | "-color" | "-init-file" | "-profile-ltac-cutoff" | "-main-channel" | "-control-channel" | "-mangle-names" | "-set" | "-unset" | "-diffs" | "-mangle-name" | "-dump-glob" | "-bytecode-compiler" | "-native-compiler" as x) :: a :: tl -> x :: a :: set_slave_opt tl diff --git a/stm/proofBlockDelimiter.ml b/stm/proofBlockDelimiter.ml index 6a78dd5529..2ff76e69f8 100644 --- a/stm/proofBlockDelimiter.ml +++ b/stm/proofBlockDelimiter.ml @@ -50,7 +50,7 @@ let is_focused_goal_simple ~doc id = | `Expired | `Error _ | `Valid None -> `Not | `Valid (Some { Vernacstate.lemmas }) -> Option.cata (Vernacstate.LemmaStack.with_top_pstate ~f:(fun proof -> - let proof = Proof_global.get_proof proof in + let proof = Declare.Proof.get_proof proof in let Proof.{ goals=focused; stack=r1; shelf=r2; given_up=r3; sigma } = Proof.data proof in let rest = List.(flatten (map (fun (x,y) -> x @ y) r1)) @ r2 @ r3 in if List.for_all (fun x -> simple_goal sigma x rest) focused diff --git a/stm/stm.ml b/stm/stm.ml index 62556d38ff..f3768e9b99 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -27,7 +27,7 @@ open Feedback open Vernacexpr open Vernacextend -module PG_compat = Vernacstate.Proof_global [@@ocaml.warning "-3"] +module PG_compat = Vernacstate.Declare [@@ocaml.warning "-3"] let is_vtkeep = function VtKeep _ -> true | _ -> false let get_vtkeep = function VtKeep x -> x | _ -> assert false @@ -147,7 +147,7 @@ let update_global_env () = PG_compat.update_global_env () module Vcs_ = Vcs.Make(Stateid.Self) -type future_proof = Proof_global.closed_proof_output Future.computation +type future_proof = Declare.closed_proof_output Future.computation type depth = int type branch_type = @@ -1164,7 +1164,7 @@ end = struct (* {{{ *) let get_proof ~doc id = match state_of_id ~doc id with - | `Valid (Some vstate) -> Option.map (Vernacstate.LemmaStack.with_top_pstate ~f:Proof_global.get_proof) vstate.Vernacstate.lemmas + | `Valid (Some vstate) -> Option.map (Vernacstate.LemmaStack.with_top_pstate ~f:Declare.Proof.get_proof) vstate.Vernacstate.lemmas | _ -> None let undo_vernac_classifier v ~doc = @@ -1358,7 +1358,7 @@ module rec ProofTask : sig t_stop : Stateid.t; t_drop : bool; t_states : competence; - t_assign : Proof_global.closed_proof_output Future.assignment -> unit; + t_assign : Declare.closed_proof_output Future.assignment -> unit; t_loc : Loc.t option; t_uuid : Future.UUID.t; t_name : string } @@ -1381,7 +1381,7 @@ module rec ProofTask : sig ?loc:Loc.t -> drop_pt:bool -> Stateid.t * Stateid.t -> Stateid.t -> - Proof_global.closed_proof_output Future.computation + Declare.closed_proof_output Future.computation (* If set, only tasks overlapping with this list are processed *) val set_perspective : Stateid.t list -> unit @@ -1397,7 +1397,7 @@ end = struct (* {{{ *) t_stop : Stateid.t; t_drop : bool; t_states : competence; - t_assign : Proof_global.closed_proof_output Future.assignment -> unit; + t_assign : Declare.closed_proof_output Future.assignment -> unit; t_loc : Loc.t option; t_uuid : Future.UUID.t; t_name : string } @@ -1419,7 +1419,7 @@ end = struct (* {{{ *) e_safe_states : Stateid.t list } type response = - | RespBuiltProof of Proof_global.closed_proof_output * float + | RespBuiltProof of Declare.closed_proof_output * float | RespError of error | RespStates of (Stateid.t * State.partial_state) list @@ -1501,7 +1501,7 @@ end = struct (* {{{ *) let wall_clock2 = Unix.gettimeofday () in Aux_file.record_in_aux_at ?loc "proof_build_time" (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1)); - let p = PG_compat.return_proof ~allow_partial:drop_pt () in + let p = if drop_pt then PG_compat.return_partial_proof () else PG_compat.return_proof () in if drop_pt then feedback ~id Complete; p) @@ -1522,15 +1522,15 @@ end = struct (* {{{ *) let st = State.freeze () in if not drop then begin let checked_proof = Future.chain future_proof (fun p -> - let opaque = Proof_global.Opaque in (* Unfortunately close_future_proof and friends are not pure so we need to set the state manually here *) State.unfreeze st; let pobject, _info = - PG_compat.close_future_proof ~opaque ~feedback_id:stop (Future.from_val ~fix_exn p) in + PG_compat.close_future_proof ~feedback_id:stop (Future.from_val ~fix_exn p) in let st = Vernacstate.freeze_interp_state ~marshallable:false in + let opaque = Declare.Opaque in stm_qed_delay_proof ~st ~id:stop ~proof:pobject ~info:(Lemmas.Info.make ()) ~loc ~control:[] (Proved (opaque,None))) in ignore(Future.join checked_proof); @@ -1661,14 +1661,14 @@ end = struct (* {{{ *) try Reach.known_state ~doc:dummy_doc (* XXX should be document *) ~cache:false stop; if drop then - let _proof = PG_compat.return_proof ~allow_partial:true () in + let _proof = PG_compat.return_partial_proof () in `OK_ADMITTED else begin - let opaque = Proof_global.Opaque in + let opaque = Declare.Opaque in (* The original terminator, a hook, has not been saved in the .vio*) let proof, _info = - PG_compat.close_proof ~opaque ~keep_body_ucst_separate:true (fun x -> x) in + PG_compat.close_proof ~opaque ~keep_body_ucst_separate:true in let info = Lemmas.Info.make () in @@ -1723,7 +1723,7 @@ end = struct (* {{{ *) | `ERROR -> exit 1 | `ERROR_ADMITTED -> cst, false | `OK_ADMITTED -> cst, false - | `OK { Proof_global.name } -> + | `OK { Declare.name } -> let con = Nametab.locate_constant (Libnames.qualid_of_ident name) in let c = Global.lookup_constant con in let o = match c.Declarations.const_body with @@ -2149,7 +2149,7 @@ let collect_proof keep cur hd brkind id = | id :: _ -> Names.Id.to_string id in let loc = (snd cur).expr.CAst.loc in let is_defined_expr = function - | VernacEndProof (Proved (Proof_global.Transparent,_)) -> true + | VernacEndProof (Proved (Declare.Transparent,_)) -> true | _ -> false in let is_defined = function | _, { expr = e } -> is_defined_expr e.CAst.v.expr @@ -2310,7 +2310,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = Option.iter PG_compat.unfreeze lemmas; PG_compat.with_current_proof (fun _ p -> feedback ~id:id Feedback.AddedAxiom; - fst (Pfedit.solve Goal_select.SelectAll None tac p), ()); + fst (Proof.solve Goal_select.SelectAll None tac p), ()); (* STATE SPEC: * - start: Modifies the input state adding a proof. * - end : maybe after recovery command. @@ -2479,13 +2479,13 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = ~drop_pt exn_info block_stop, ref false in qed.fproof <- Some (Some fp, cancel); - let opaque = match keep' with - | VtKeepAxiom | VtKeepOpaque -> - Proof_global.Opaque (* Admitted -> Opaque should be OK. *) - | VtKeepDefined -> Proof_global.Transparent + let () = match keep' with + | VtKeepAxiom | VtKeepOpaque -> () + | VtKeepDefined -> + CErrors.anomaly (Pp.str "Cannot delegate transparent proofs, this is a bug in the STM.") in let proof, info = - PG_compat.close_future_proof ~opaque ~feedback_id:id fp in + PG_compat.close_future_proof ~feedback_id:id fp in if not delegate then ignore(Future.compute fp); reach view.next; let st = Vernacstate.freeze_interp_state ~marshallable:false in @@ -2514,13 +2514,15 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = | VtKeep VtKeepAxiom -> qed.fproof <- Some (None, ref false); None | VtKeep opaque -> - let opaque = let open Proof_global in match opaque with + let opaque = let open Declare in match opaque with | VtKeepOpaque -> Opaque | VtKeepDefined -> Transparent | VtKeepAxiom -> assert false in - Some(PG_compat.close_proof ~opaque - ~keep_body_ucst_separate:false - (State.exn_on id ~valid:eop)) in + try Some (PG_compat.close_proof ~opaque ~keep_body_ucst_separate:false) + with exn -> + let iexn = Exninfo.capture exn in + Exninfo.iraise (State.exn_on id ~valid:eop iexn) + in if keep <> VtKeep VtKeepAxiom then reach view.next; let wall_clock2 = Unix.gettimeofday () in diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 567acb1c73..cf127648b4 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -37,7 +37,7 @@ let string_of_vernac_classification = function | VtMeta -> "Meta " | VtProofMode _ -> "Proof Mode" -let vtkeep_of_opaque = let open Proof_global in function +let vtkeep_of_opaque = let open Declare in function | Opaque -> VtKeepOpaque | Transparent -> VtKeepDefined diff --git a/tactics/abstract.ml b/tactics/abstract.ml index e85d94cd72..6b575d0807 100644 --- a/tactics/abstract.ml +++ b/tactics/abstract.ml @@ -11,7 +11,6 @@ open Util open Termops open EConstr -open Evarutil module NamedDecl = Context.Named.Declaration @@ -41,6 +40,9 @@ let name_op_to_name ~name_op ~name suffix = | Some s -> s | None -> Nameops.add_suffix name suffix +let declare_abstract = ref (fun ~name ~poly ~kind ~sign ~secsign ~opaque ~solve_tac sigma concl -> + CErrors.anomaly (Pp.str "Abstract declaration hook not registered")) + let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = let open Tacticals.New in let open Tacmach.New in @@ -76,61 +78,9 @@ let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = | None -> Proofview.Goal.concl gl | Some ty -> ty in let concl = it_mkNamedProd_or_LetIn concl sign in - let concl = - try flush_and_check_evars sigma concl - with Uninstantiated_evar _ -> - CErrors.user_err Pp.(str "\"abstract\" cannot handle existentials.") in - - let sigma, ctx, concl = - (* FIXME: should be done only if the tactic succeeds *) - let sigma = Evd.minimize_universes sigma in - let ctx = Evd.universe_context_set sigma in - sigma, ctx, Evarutil.nf_evars_universes sigma concl - in - let concl = EConstr.of_constr concl in let solve_tac = tclCOMPLETE (tclTHEN (tclDO (List.length sign) Tactics.intro) tac) in - let ectx = Evd.evar_universe_context sigma in - let (const, safe, ectx) = - try Pfedit.build_constant_by_tactic ~name ~opaque:Proof_global.Transparent ~poly ~uctx:ectx ~sign:secsign concl solve_tac - with Logic_monad.TacticFailure e as src -> - (* if the tactic [tac] fails, it reports a [TacticFailure e], - which is an error irrelevant to the proof system (in fact it - means that [e] comes from [tac] failing to yield enough - success). Hence it reraises [e]. *) - let (_, info) = Exninfo.capture src in - Exninfo.iraise (e, info) - in - let body, effs = Future.force const.Declare.proof_entry_body in - (* We drop the side-effects from the entry, they already exist in the ambient environment *) - let const = Declare.Internal.map_entry_body const ~f:(fun _ -> body, ()) in - (* EJGA: Hack related to the above call to - `build_constant_by_tactic` with `~opaque:Transparent`. Even if - the abstracted term is destined to be opaque, if we trigger the - `if poly && opaque && private_poly_univs ()` in `Proof_global` - kernel will boom. This deserves more investigation. *) - let const = Declare.Internal.set_opacity ~opaque const in - let const, args = Declare.Internal.shrink_entry sign const in - let args = List.map EConstr.of_constr args in - let cst () = - (* do not compute the implicit arguments, it may be costly *) - let () = Impargs.make_implicit_args false in - (* ppedrot: seems legit to have abstracted subproofs as local*) - Declare.declare_private_constant ~local:Declare.ImportNeedQualified ~name ~kind const - in - let cst, eff = Impargs.with_implicit_protection cst () in - let inst = match const.Declare.proof_entry_universes with - | Entries.Monomorphic_entry _ -> EInstance.empty - | Entries.Polymorphic_entry (_, ctx) -> - (* We mimic what the kernel does, that is ensuring that no additional - constraints appear in the body of polymorphic constants. Ideally this - should be enforced statically. *) - let (_, body_uctx), _ = Future.force const.Declare.proof_entry_body in - let () = assert (Univ.ContextSet.is_empty body_uctx) in - EInstance.make (Univ.UContext.instance ctx) - in - let lem = mkConstU (cst, inst) in - let sigma = Evd.set_universe_context sigma ectx in - let effs = Evd.concat_side_effects eff effs in + let effs, sigma, lem, args, safe = + !declare_abstract ~name ~poly ~sign ~secsign ~kind ~opaque ~solve_tac sigma concl in let solve = Proofview.tclEFFECTS effs <*> tacK lem args diff --git a/tactics/abstract.mli b/tactics/abstract.mli index 5c936ff9d6..a138a457b3 100644 --- a/tactics/abstract.mli +++ b/tactics/abstract.mli @@ -20,3 +20,15 @@ val cache_term_by_tactic_then -> unit Proofview.tactic val tclABSTRACT : ?opaque:bool -> Id.t option -> unit Proofview.tactic -> unit Proofview.tactic + +val declare_abstract : + ( name:Names.Id.t + -> poly:bool + -> kind:Decls.logical_kind + -> sign:EConstr.named_context + -> secsign:Environ.named_context_val + -> opaque:bool + -> solve_tac:unit Proofview.tactic + -> Evd.evar_map + -> EConstr.t + -> Evd.side_effects * Evd.evar_map * EConstr.t * EConstr.t list * bool) ref diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 92d56d2904..a51fc8b347 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -38,33 +38,48 @@ let typeclasses_db = "typeclass_instances" (** Options handling *) let typeclasses_debug = ref 0 -let typeclasses_depth = ref None + +let typeclasses_depth_opt_name = ["Typeclasses";"Depth"] +let get_typeclasses_depth = + Goptions.declare_intopt_option_and_ref + ~depr:false + ~key:typeclasses_depth_opt_name + +let set_typeclasses_depth = + Goptions.set_int_option_value typeclasses_depth_opt_name (** When this flag is enabled, the resolution of type classes tries to avoid useless introductions. This is no longer useful since we have eta, but is here for compatibility purposes. Another compatibility issues is that the cost (in terms of search depth) can differ. *) -let typeclasses_limit_intros = ref true -let set_typeclasses_limit_intros d = (:=) typeclasses_limit_intros d -let get_typeclasses_limit_intros () = !typeclasses_limit_intros - -let typeclasses_dependency_order = ref false -let set_typeclasses_dependency_order d = (:=) typeclasses_dependency_order d -let get_typeclasses_dependency_order () = !typeclasses_dependency_order - -let typeclasses_iterative_deepening = ref false -let set_typeclasses_iterative_deepening d = (:=) typeclasses_iterative_deepening d -let get_typeclasses_iterative_deepening () = !typeclasses_iterative_deepening +let get_typeclasses_limit_intros = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["Typeclasses";"Limit";"Intros"] + ~value:true + +let get_typeclasses_dependency_order = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["Typeclasses";"Dependency";"Order"] + ~value:false + +let iterative_deepening_opt_name = ["Typeclasses";"Iterative";"Deepening"] +let get_typeclasses_iterative_deepening = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:iterative_deepening_opt_name + ~value:false (** [typeclasses_filtered_unif] governs the unification algorithm used by type classes. If enabled, a new algorithm based on pattern filtering and refine will be used. When disabled, the previous algorithm based on apply will be used. *) -let typeclasses_filtered_unification = ref false -let set_typeclasses_filtered_unification d = - (:=) typeclasses_filtered_unification d -let get_typeclasses_filtered_unification () = - !typeclasses_filtered_unification +let get_typeclasses_filtered_unification = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["Typeclasses";"Filtered";"Unification"] + ~value:false let set_typeclasses_debug d = (:=) typeclasses_debug (if d then 1 else 0) let get_typeclasses_debug () = if !typeclasses_debug > 0 then true else false @@ -75,40 +90,8 @@ let set_typeclasses_verbose = let get_typeclasses_verbose () = if !typeclasses_debug = 0 then None else Some !typeclasses_debug -let set_typeclasses_depth d = (:=) typeclasses_depth d -let get_typeclasses_depth () = !typeclasses_depth - -open Goptions - -let () = - declare_bool_option - { optdepr = false; - optkey = ["Typeclasses";"Limit";"Intros"]; - optread = get_typeclasses_limit_intros; - optwrite = set_typeclasses_limit_intros; } - -let () = - declare_bool_option - { optdepr = false; - optkey = ["Typeclasses";"Dependency";"Order"]; - optread = get_typeclasses_dependency_order; - optwrite = set_typeclasses_dependency_order; } - -let () = - declare_bool_option - { optdepr = false; - optkey = ["Typeclasses";"Iterative";"Deepening"]; - optread = get_typeclasses_iterative_deepening; - optwrite = set_typeclasses_iterative_deepening; } - -let () = - declare_bool_option - { optdepr = false; - optkey = ["Typeclasses";"Filtered";"Unification"]; - optread = get_typeclasses_filtered_unification; - optwrite = set_typeclasses_filtered_unification; } - let () = + let open Goptions in declare_bool_option { optdepr = false; optkey = ["Typeclasses";"Debug"]; @@ -116,24 +99,18 @@ let () = optwrite = set_typeclasses_debug; } let _ = + let open Goptions in declare_int_option { optdepr = false; optkey = ["Typeclasses";"Debug";"Verbosity"]; optread = get_typeclasses_verbose; optwrite = set_typeclasses_verbose; } -let () = - declare_int_option - { optdepr = false; - optkey = ["Typeclasses";"Depth"]; - optread = get_typeclasses_depth; - optwrite = set_typeclasses_depth; } - type search_strategy = Dfs | Bfs let set_typeclasses_strategy = function - | Dfs -> set_typeclasses_iterative_deepening false - | Bfs -> set_typeclasses_iterative_deepening true + | Dfs -> Goptions.set_bool_option_value iterative_deepening_opt_name false + | Bfs -> Goptions.set_bool_option_value iterative_deepening_opt_name true let pr_ev evs ev = Printer.pr_econstr_env (Goal.V82.env evs ev) evs (Goal.V82.concl evs ev) @@ -977,7 +954,7 @@ module Search = struct | None -> None (* This happens only because there's no evar having p *) | Some (goals, nongoals) -> let goalsl = - if !typeclasses_dependency_order then + if get_typeclasses_dependency_order () then top_sort evm goals else Evar.Set.elements goals in @@ -1211,7 +1188,7 @@ let resolve_one_typeclass env ?(sigma=Evd.from_env env) gl unique = with Refiner.FailError _ -> raise Not_found in let evd = sig_sig gls' in - let t' = mkEvar (ev, Array.of_list subst) in + let t' = mkEvar (ev, subst) in let term = Evarutil.nf_evar evd t' in term, evd end in diff --git a/tactics/class_tactics.mli b/tactics/class_tactics.mli index e26338436d..b97b90d777 100644 --- a/tactics/class_tactics.mli +++ b/tactics/class_tactics.mli @@ -19,10 +19,8 @@ val catchable : exn -> bool [@@ocaml.deprecated "Use instead CErrors.noncritical, or the exact name of the exception that matters in the corresponding case."] val set_typeclasses_debug : bool -> unit -val get_typeclasses_debug : unit -> bool val set_typeclasses_depth : int option -> unit -val get_typeclasses_depth : unit -> int option type search_strategy = Dfs | Bfs diff --git a/tactics/declare.ml b/tactics/declare.ml deleted file mode 100644 index 5e6f78be6f..0000000000 --- a/tactics/declare.ml +++ /dev/null @@ -1,512 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \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) *) -(************************************************************************) - -(** This module is about the low-level declaration of logical objects *) - -open Pp -open Util -open Names -open Declarations -open Entries -open Safe_typing -open Libobject -open Lib - -(* object_kind , id *) -exception AlreadyDeclared of (string option * Id.t) - -let _ = CErrors.register_handler (function - | AlreadyDeclared (kind, id) -> - Some - (seq [ Pp.pr_opt_no_spc (fun s -> str s ++ spc ()) kind - ; Id.print id; str " already exists."]) - | _ -> - None) - -module NamedDecl = Context.Named.Declaration - -type import_status = ImportDefaultBehavior | ImportNeedQualified - -(** Monomorphic universes need to survive sections. *) - -let name_instance inst = - let map lvl = match Univ.Level.name lvl with - | None -> (* Having Prop/Set/Var as section universes makes no sense *) - assert false - | Some na -> - try - let qid = Nametab.shortest_qualid_of_universe na in - Name (Libnames.qualid_basename qid) - with Not_found -> - (* Best-effort naming from the string representation of the level. - See univNames.ml for a similar hack. *) - Name (Id.of_string_soft (Univ.Level.to_string lvl)) - in - Array.map map (Univ.Instance.to_array inst) - -let declare_universe_context ~poly ctx = - if poly then - let uctx = Univ.ContextSet.to_context ctx in - let nas = name_instance (Univ.UContext.instance uctx) in - Global.push_section_context (nas, uctx) - else - Global.push_context_set ~strict:true ctx - -(** Declaration of constants and parameters *) - -type constant_obj = { - cst_kind : Decls.logical_kind; - cst_locl : import_status; -} - -type 'a proof_entry = { - proof_entry_body : 'a Entries.const_entry_body; - (* List of section variables *) - proof_entry_secctx : Id.Set.t option; - (* State id on which the completion of type checking is reported *) - proof_entry_feedback : Stateid.t option; - proof_entry_type : Constr.types option; - proof_entry_universes : Entries.universes_entry; - proof_entry_opaque : bool; - proof_entry_inline_code : bool; -} - -type 'a constant_entry = - | DefinitionEntry of 'a proof_entry - | ParameterEntry of parameter_entry - | PrimitiveEntry of primitive_entry - -(* At load-time, the segment starting from the module name to the discharge *) -(* section (if Remark or Fact) is needed to access a construction *) -let load_constant i ((sp,kn), obj) = - if Nametab.exists_cci sp then - raise (AlreadyDeclared (None, Libnames.basename sp)); - let con = Global.constant_of_delta_kn kn in - Nametab.push (Nametab.Until i) sp (GlobRef.ConstRef con); - Dumpglob.add_constant_kind con obj.cst_kind - -(* Opening means making the name without its module qualification available *) -let open_constant i ((sp,kn), obj) = - (* Never open a local definition *) - match obj.cst_locl with - | ImportNeedQualified -> () - | ImportDefaultBehavior -> - let con = Global.constant_of_delta_kn kn in - Nametab.push (Nametab.Exactly i) sp (GlobRef.ConstRef con) - -let exists_name id = - Decls.variable_exists id || Global.exists_objlabel (Label.of_id id) - -let check_exists id = - if exists_name id then - raise (AlreadyDeclared (None, id)) - -let cache_constant ((sp,kn), obj) = - (* Invariant: the constant must exist in the logical environment, except when - redefining it when exiting a section. See [discharge_constant]. *) - let kn' = - if Global.exists_objlabel (Label.of_id (Libnames.basename sp)) - then Constant.make1 kn - else CErrors.anomaly Pp.(str"Missing constant " ++ Id.print(Libnames.basename sp) ++ str".") - in - assert (Constant.equal kn' (Constant.make1 kn)); - Nametab.push (Nametab.Until 1) sp (GlobRef.ConstRef (Constant.make1 kn)); - Dumpglob.add_constant_kind (Constant.make1 kn) obj.cst_kind - -let discharge_constant ((sp, kn), obj) = - Some obj - -(* Hack to reduce the size of .vo: we keep only what load/open needs *) -let dummy_constant cst = { - cst_kind = cst.cst_kind; - cst_locl = cst.cst_locl; -} - -let classify_constant cst = Substitute (dummy_constant cst) - -let (objConstant : constant_obj Libobject.Dyn.tag) = - declare_object_full { (default_object "CONSTANT") with - cache_function = cache_constant; - load_function = load_constant; - open_function = open_constant; - classify_function = classify_constant; - subst_function = ident_subst_function; - discharge_function = discharge_constant } - -let inConstant v = Libobject.Dyn.Easy.inj v objConstant - -let update_tables c = - Impargs.declare_constant_implicits c; - Notation.declare_ref_arguments_scope Evd.empty (GlobRef.ConstRef c) - -let register_constant kn kind local = - let o = inConstant { - cst_kind = kind; - cst_locl = local; - } in - let id = Label.to_id (Constant.label kn) in - let _ = add_leaf id o in - update_tables kn - -let register_side_effect (c, role) = - let () = register_constant c Decls.(IsProof Theorem) ImportDefaultBehavior in - match role with - | None -> () - | Some (Evd.Schema (ind, kind)) -> DeclareScheme.declare_scheme kind [|ind,c|] - -let get_roles export eff = - let map c = - let role = try Some (Cmap.find c eff.Evd.seff_roles) with Not_found -> None in - (c, role) - in - List.map map export - -let export_side_effects eff = - let export = Global.export_private_constants eff.Evd.seff_private in - let export = get_roles export eff in - List.iter register_side_effect export - -let record_aux env s_ty s_bo = - let open Environ in - let in_ty = keep_hyps env s_ty in - let v = - String.concat " " - (CList.map_filter (fun decl -> - let id = NamedDecl.get_id decl in - if List.exists (NamedDecl.get_id %> Id.equal id) in_ty then None - else Some (Id.to_string id)) - (keep_hyps env s_bo)) in - Aux_file.record_in_aux "context_used" v - -let default_univ_entry = Monomorphic_entry Univ.ContextSet.empty - -let definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?types - ?(univs=default_univ_entry) ?(eff=Evd.empty_side_effects) body = - { proof_entry_body = Future.from_val ?fix_exn ((body,Univ.ContextSet.empty), eff); - proof_entry_secctx = None; - proof_entry_type = types; - proof_entry_universes = univs; - proof_entry_opaque = opaque; - proof_entry_feedback = None; - proof_entry_inline_code = inline} - -let pure_definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?types - ?(univs=default_univ_entry) body = - { proof_entry_body = Future.from_val ?fix_exn ((body,Univ.ContextSet.empty), ()); - proof_entry_secctx = None; - proof_entry_type = types; - proof_entry_universes = univs; - proof_entry_opaque = opaque; - proof_entry_feedback = None; - proof_entry_inline_code = inline} - -let delayed_definition_entry ?(opaque=false) ?(inline=false) ?feedback_id ?section_vars ?(univs=default_univ_entry) ?types body = - { proof_entry_body = body - ; proof_entry_secctx = section_vars - ; proof_entry_type = types - ; proof_entry_universes = univs - ; proof_entry_opaque = opaque - ; proof_entry_feedback = feedback_id - ; proof_entry_inline_code = inline - } - -let cast_proof_entry e = - let (body, ctx), () = Future.force e.proof_entry_body in - let univs = - if Univ.ContextSet.is_empty ctx then e.proof_entry_universes - else match e.proof_entry_universes with - | Monomorphic_entry ctx' -> - (* This can actually happen, try compiling EqdepFacts for instance *) - Monomorphic_entry (Univ.ContextSet.union ctx' ctx) - | Polymorphic_entry _ -> - CErrors.anomaly Pp.(str "Local universes in non-opaque polymorphic definition."); - in - { - const_entry_body = body; - const_entry_secctx = e.proof_entry_secctx; - const_entry_feedback = e.proof_entry_feedback; - const_entry_type = e.proof_entry_type; - const_entry_universes = univs; - const_entry_inline_code = e.proof_entry_inline_code; - } - -type ('a, 'b) effect_entry = -| EffectEntry : (private_constants, private_constants Entries.const_entry_body) effect_entry -| PureEntry : (unit, Constr.constr) effect_entry - -let cast_opaque_proof_entry (type a b) (entry : (a, b) effect_entry) (e : a proof_entry) : b opaque_entry = - let typ = match e.proof_entry_type with - | None -> assert false - | Some typ -> typ - in - let secctx = match e.proof_entry_secctx with - | None -> - let open Environ in - let env = Global.env () in - let hyp_typ, hyp_def = - if List.is_empty (Environ.named_context env) then - Id.Set.empty, Id.Set.empty - else - let ids_typ = global_vars_set env typ in - let pf, env = match entry with - | PureEntry -> - let (pf, _), () = Future.force e.proof_entry_body in - pf, env - | EffectEntry -> - let (pf, _), eff = Future.force e.proof_entry_body in - let env = Safe_typing.push_private_constants env eff in - pf, env - in - let vars = global_vars_set env pf in - ids_typ, vars - in - let () = if Aux_file.recording () then record_aux env hyp_typ hyp_def in - Environ.really_needed env (Id.Set.union hyp_typ hyp_def) - | Some hyps -> hyps - in - let (body, univs : b * _) = match entry with - | PureEntry -> - let (body, uctx), () = Future.force e.proof_entry_body in - let univs = match e.proof_entry_universes with - | Monomorphic_entry uctx' -> Monomorphic_entry (Univ.ContextSet.union uctx uctx') - | Polymorphic_entry _ -> - assert (Univ.ContextSet.is_empty uctx); - e.proof_entry_universes - in - body, univs - | EffectEntry -> e.proof_entry_body, e.proof_entry_universes - in - { - opaque_entry_body = body; - opaque_entry_secctx = secctx; - opaque_entry_feedback = e.proof_entry_feedback; - opaque_entry_type = typ; - opaque_entry_universes = univs; - } - -let feedback_axiom () = Feedback.(feedback AddedAxiom) - -let is_unsafe_typing_flags () = - let flags = Environ.typing_flags (Global.env()) in - not (flags.check_universes && flags.check_guarded && flags.check_positive) - -let define_constant ~name cd = - (* Logically define the constant and its subproofs, no libobject tampering *) - let decl, unsafe = match cd with - | DefinitionEntry de -> - (* We deal with side effects *) - if not de.proof_entry_opaque then - let body, eff = Future.force de.proof_entry_body in - (* This globally defines the side-effects in the environment - and registers their libobjects. *) - let () = export_side_effects eff in - let de = { de with proof_entry_body = Future.from_val (body, ()) } in - let cd = Entries.DefinitionEntry (cast_proof_entry de) in - ConstantEntry cd, false - else - let map (body, eff) = body, eff.Evd.seff_private in - let body = Future.chain de.proof_entry_body map in - let de = { de with proof_entry_body = body } in - let de = cast_opaque_proof_entry EffectEntry de in - OpaqueEntry de, false - | ParameterEntry e -> - ConstantEntry (Entries.ParameterEntry e), not (Lib.is_modtype_strict()) - | PrimitiveEntry e -> - ConstantEntry (Entries.PrimitiveEntry e), false - in - let kn = Global.add_constant name decl in - if unsafe || is_unsafe_typing_flags() then feedback_axiom(); - kn - -let declare_constant ?(local = ImportDefaultBehavior) ~name ~kind cd = - let () = check_exists name in - let kn = define_constant ~name cd in - (* Register the libobjects attached to the constants *) - let () = register_constant kn kind local in - kn - -let declare_private_constant ?role ?(local = ImportDefaultBehavior) ~name ~kind de = - let kn, eff = - let de = - if not de.proof_entry_opaque then - DefinitionEff (cast_proof_entry de) - else - let de = cast_opaque_proof_entry PureEntry de in - OpaqueEff de - in - Global.add_private_constant name de - in - let () = register_constant kn kind local in - let seff_roles = match role with - | None -> Cmap.empty - | Some r -> Cmap.singleton kn r - in - let eff = { Evd.seff_private = eff; Evd.seff_roles; } in - kn, eff - -let inline_private_constants ~uctx env ce = - let body, eff = Future.force ce.proof_entry_body in - let cb, ctx = Safe_typing.inline_private_constants env (body, eff.Evd.seff_private) in - let uctx = UState.merge ~sideff:true Evd.univ_rigid uctx ctx in - cb, uctx - -(** Declaration of section variables and local definitions *) -type variable_declaration = - | SectionLocalDef of Evd.side_effects proof_entry - | SectionLocalAssum of { typ:Constr.types; impl:Glob_term.binding_kind; } - -(* This object is only for things which iterate over objects to find - variables (only Prettyp.print_context AFAICT) *) -let objVariable : unit Libobject.Dyn.tag = - declare_object_full { (default_object "VARIABLE") with - classify_function = (fun () -> Dispose)} - -let inVariable v = Libobject.Dyn.Easy.inj v objVariable - -let declare_variable ~name ~kind d = - (* Variables are distinguished by only short names *) - if Decls.variable_exists name then - raise (AlreadyDeclared (None, name)); - - let impl,opaque = match d with (* Fails if not well-typed *) - | SectionLocalAssum {typ;impl} -> - let () = Global.push_named_assum (name,typ) in - impl, true - | SectionLocalDef (de) -> - (* The body should already have been forced upstream because it is a - section-local definition, but it's not enforced by typing *) - let ((body, body_ui), eff) = Future.force de.proof_entry_body in - let () = export_side_effects eff in - let poly, entry_ui = match de.proof_entry_universes with - | Monomorphic_entry uctx -> false, uctx - | Polymorphic_entry (_, uctx) -> true, Univ.ContextSet.of_context uctx - in - let univs = Univ.ContextSet.union body_ui entry_ui in - (* We must declare the universe constraints before type-checking the - term. *) - let () = declare_universe_context ~poly univs in - let se = { - secdef_body = body; - secdef_secctx = de.proof_entry_secctx; - secdef_feedback = de.proof_entry_feedback; - secdef_type = de.proof_entry_type; - } in - let () = Global.push_named_def (name, se) in - Glob_term.Explicit, de.proof_entry_opaque - in - Nametab.push (Nametab.Until 1) (Libnames.make_path DirPath.empty name) (GlobRef.VarRef name); - Decls.(add_variable_data name {opaque;kind}); - ignore(add_leaf name (inVariable ()) : Libobject.object_name); - Impargs.declare_var_implicits ~impl name; - Notation.declare_ref_arguments_scope Evd.empty (GlobRef.VarRef name) - -(* Declaration messages *) - -let pr_rank i = pr_nth (i+1) - -let fixpoint_message indexes l = - Flags.if_verbose Feedback.msg_info (match l with - | [] -> CErrors.anomaly (Pp.str "no recursive definition.") - | [id] -> Id.print id ++ str " is recursively defined" ++ - (match indexes with - | Some [|i|] -> str " (decreasing on "++pr_rank i++str " argument)" - | _ -> mt ()) - | l -> hov 0 (prlist_with_sep pr_comma Id.print l ++ - spc () ++ str "are recursively defined" ++ - match indexes with - | Some a -> spc () ++ str "(decreasing respectively on " ++ - prvect_with_sep pr_comma pr_rank a ++ - str " arguments)" - | None -> mt ())) - -let cofixpoint_message l = - Flags.if_verbose Feedback.msg_info (match l with - | [] -> CErrors.anomaly (Pp.str "No corecursive definition.") - | [id] -> Id.print id ++ str " is corecursively defined" - | l -> hov 0 (prlist_with_sep pr_comma Id.print l ++ - spc () ++ str "are corecursively defined")) - -let recursive_message isfix i l = - (if isfix then fixpoint_message i else cofixpoint_message) l - -let definition_message id = - Flags.if_verbose Feedback.msg_info (Id.print id ++ str " is defined") - -let assumption_message id = - (* Changing "assumed" to "declared", "assuming" referring more to - the type of the object than to the name of the object (see - discussion on coqdev: "Chapter 4 of the Reference Manual", 8/10/2015) *) - Flags.if_verbose Feedback.msg_info (Id.print id ++ str " is declared") - -module Internal = struct - - let map_entry_body ~f entry = - { entry with proof_entry_body = Future.chain entry.proof_entry_body f } - - let map_entry_type ~f entry = - { entry with proof_entry_type = f entry.proof_entry_type } - - let set_opacity ~opaque entry = - { entry with proof_entry_opaque = opaque } - - let get_fix_exn entry = Future.fix_exn_of entry.proof_entry_body - - let rec decompose len c t accu = - let open Constr in - let open Context.Rel.Declaration in - if len = 0 then (c, t, accu) - else match kind c, kind t with - | Lambda (na, u, c), Prod (_, _, t) -> - decompose (pred len) c t (LocalAssum (na, u) :: accu) - | LetIn (na, b, u, c), LetIn (_, _, _, t) -> - decompose (pred len) c t (LocalDef (na, b, u) :: accu) - | _ -> assert false - - let rec shrink ctx sign c t accu = - let open Constr in - let open Vars in - match ctx, sign with - | [], [] -> (c, t, accu) - | p :: ctx, decl :: sign -> - if noccurn 1 c && noccurn 1 t then - let c = subst1 mkProp c in - let t = subst1 mkProp t in - shrink ctx sign c t accu - else - let c = Term.mkLambda_or_LetIn p c in - let t = Term.mkProd_or_LetIn p t in - let accu = if Context.Rel.Declaration.is_local_assum p - then mkVar (NamedDecl.get_id decl) :: accu - else accu - in - shrink ctx sign c t accu - | _ -> assert false - - let shrink_entry sign const = - let typ = match const.proof_entry_type with - | None -> assert false - | Some t -> t - in - (* The body has been forced by the call to [build_constant_by_tactic] *) - let () = assert (Future.is_over const.proof_entry_body) in - let ((body, uctx), eff) = Future.force const.proof_entry_body in - let (body, typ, ctx) = decompose (List.length sign) body typ [] in - let (body, typ, args) = shrink ctx sign body typ [] in - { const with - proof_entry_body = Future.from_val ((body, uctx), eff) - ; proof_entry_type = Some typ - }, args - - type nonrec constant_obj = constant_obj - - let objVariable = objVariable - let objConstant = objConstant - -end diff --git a/tactics/declare.mli b/tactics/declare.mli deleted file mode 100644 index 0068b9842a..0000000000 --- a/tactics/declare.mli +++ /dev/null @@ -1,154 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \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 Names -open Constr -open Entries - -(** This module provides the official functions to declare new variables, - parameters, constants and inductive types. Using the following functions - will add the entries in the global environment (module [Global]), will - register the declarations in the library (module [Lib]) --- so that the - reset works properly --- and will fill some global tables such as - [Nametab] and [Impargs]. *) - -(** Proof entries *) -type 'a proof_entry = private { - proof_entry_body : 'a Entries.const_entry_body; - (* List of section variables *) - proof_entry_secctx : Id.Set.t option; - (* State id on which the completion of type checking is reported *) - proof_entry_feedback : Stateid.t option; - proof_entry_type : Constr.types option; - proof_entry_universes : Entries.universes_entry; - proof_entry_opaque : bool; - proof_entry_inline_code : bool; -} - -(** Declaration of local constructions (Variable/Hypothesis/Local) *) - -type variable_declaration = - | SectionLocalDef of Evd.side_effects proof_entry - | SectionLocalAssum of { typ:types; impl:Glob_term.binding_kind; } - -type 'a constant_entry = - | DefinitionEntry of 'a proof_entry - | ParameterEntry of parameter_entry - | PrimitiveEntry of primitive_entry - -val declare_universe_context : poly:bool -> Univ.ContextSet.t -> unit - -val declare_variable - : name:variable - -> kind:Decls.logical_kind - -> variable_declaration - -> unit - -(** Declaration of global constructions - i.e. Definition/Theorem/Axiom/Parameter/... *) - -(* Default definition entries, transparent with no secctx or proj information *) -val definition_entry - : ?fix_exn:Future.fix_exn - -> ?opaque:bool - -> ?inline:bool - -> ?types:types - -> ?univs:Entries.universes_entry - -> ?eff:Evd.side_effects - -> constr - -> Evd.side_effects proof_entry - -val pure_definition_entry - : ?fix_exn:Future.fix_exn - -> ?opaque:bool - -> ?inline:bool - -> ?types:types - -> ?univs:Entries.universes_entry - -> constr - -> unit proof_entry - -(* Delayed definition entries *) -val delayed_definition_entry - : ?opaque:bool - -> ?inline:bool - -> ?feedback_id:Stateid.t - -> ?section_vars:Id.Set.t - -> ?univs:Entries.universes_entry - -> ?types:types - -> 'a Entries.const_entry_body - -> 'a proof_entry - -type import_status = ImportDefaultBehavior | ImportNeedQualified - -(** [declare_constant id cd] declares a global declaration - (constant/parameter) with name [id] in the current section; it returns - the full path of the declaration - - internal specify if the constant has been created by the kernel or by the - user, and in the former case, if its errors should be silent *) -val declare_constant - : ?local:import_status - -> name:Id.t - -> kind:Decls.logical_kind - -> Evd.side_effects constant_entry - -> Constant.t - -val declare_private_constant - : ?role:Evd.side_effect_role - -> ?local:import_status - -> name:Id.t - -> kind:Decls.logical_kind - -> unit proof_entry - -> Constant.t * Evd.side_effects - -(** [inline_private_constants ~sideff ~uctx env ce] will inline the - constants in [ce]'s body and return the body plus the updated - [UState.t]. *) -val inline_private_constants - : uctx:UState.t - -> Environ.env - -> Evd.side_effects proof_entry - -> Constr.t * UState.t - -(** Declaration messages *) - -val definition_message : Id.t -> unit -val assumption_message : Id.t -> unit -val fixpoint_message : int array option -> Id.t list -> unit -val cofixpoint_message : Id.t list -> unit -val recursive_message : bool (** true = fixpoint *) -> - int array option -> Id.t list -> unit - -val check_exists : Id.t -> unit - -(* Used outside this module only in indschemes *) -exception AlreadyDeclared of (string option * Id.t) - -(** {6 For legacy support, do not use} *) - -module Internal : sig - - val map_entry_body : f:('a Entries.proof_output -> 'b Entries.proof_output) -> 'a proof_entry -> 'b proof_entry - val map_entry_type : f:(Constr.t option -> Constr.t option) -> 'a proof_entry -> 'a proof_entry - (* Overriding opacity is indeed really hacky *) - val set_opacity : opaque:bool -> 'a proof_entry -> 'a proof_entry - - (* TODO: This is only used in DeclareDef to forward the fix to - hooks, should eventually go away *) - val get_fix_exn : 'a proof_entry -> Future.fix_exn - - val shrink_entry : EConstr.named_context -> 'a proof_entry -> 'a proof_entry * Constr.constr list - - type constant_obj - - val objConstant : constant_obj Libobject.Dyn.tag - val objVariable : unit Libobject.Dyn.tag - -end diff --git a/tactics/declareUctx.ml b/tactics/declareUctx.ml new file mode 100644 index 0000000000..3f67ff20a4 --- /dev/null +++ b/tactics/declareUctx.ml @@ -0,0 +1,34 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \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) *) +(************************************************************************) + +(** Monomorphic universes need to survive sections. *) + +let name_instance inst = + let map lvl = match Univ.Level.name lvl with + | None -> (* Having Prop/Set/Var as section universes makes no sense *) + assert false + | Some na -> + try + let qid = Nametab.shortest_qualid_of_universe na in + Names.Name (Libnames.qualid_basename qid) + with Not_found -> + (* Best-effort naming from the string representation of the level. + See univNames.ml for a similar hack. *) + Names.Name (Names.Id.of_string_soft (Univ.Level.to_string lvl)) + in + Array.map map (Univ.Instance.to_array inst) + +let declare_universe_context ~poly ctx = + if poly then + let uctx = Univ.ContextSet.to_context ctx in + let nas = name_instance (Univ.UContext.instance uctx) in + Global.push_section_context (nas, uctx) + else + Global.push_context_set ~strict:true ctx diff --git a/tactics/declareUctx.mli b/tactics/declareUctx.mli new file mode 100644 index 0000000000..7ecfab04f2 --- /dev/null +++ b/tactics/declareUctx.mli @@ -0,0 +1,11 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \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) *) +(************************************************************************) + +val declare_universe_context : poly:bool -> Univ.ContextSet.t -> unit diff --git a/tactics/eauto.ml b/tactics/eauto.ml index a89e5ef19a..28b5ed5811 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -430,29 +430,39 @@ let make_dimension n = function | None -> (true,make_depth n) | Some d -> (false,d) +let autounfolds ids csts gl cls = + let hyps = Tacmach.New.pf_ids_of_hyps gl in + let env = Tacmach.New.pf_env gl in + let ids = List.filter (fun id -> List.mem id hyps && Tacred.is_evaluable env (EvalVarRef id)) ids in + let csts = List.filter (fun cst -> Tacred.is_evaluable env (EvalConstRef cst)) csts in + let flags = + List.fold_left (fun flags cst -> CClosure.RedFlags.(red_add flags (fCONST cst))) + (List.fold_left (fun flags id -> CClosure.RedFlags.(red_add flags (fVAR id))) + CClosure.betaiotazeta ids) csts + in reduct_option ~check:false (Reductionops.clos_norm_flags flags, DEFAULTcast) cls + let cons a l = a :: l -let autounfolds db occs cls gl = - let unfolds = List.concat (List.map (fun dbname -> - let db = try searchtable_map dbname - with Not_found -> user_err ~hdr:"autounfold" (str "Unknown database " ++ str dbname) - in - let (ids, csts) = Hint_db.unfolds db in - let hyps = pf_ids_of_hyps gl in - let ids = Id.Set.filter (fun id -> List.mem id hyps) ids in - Cset.fold (fun cst -> cons (AllOccurrences, EvalConstRef cst)) csts - (Id.Set.fold (fun id -> cons (AllOccurrences, EvalVarRef id)) ids [])) db) - in Proofview.V82.of_tactic (unfold_option unfolds cls) gl +exception UnknownDatabase of string let autounfold db cls = - Proofview.V82.tactic begin fun gl -> - let cls = concrete_clause_of (fun () -> pf_ids_of_hyps gl) cls in - let tac = autounfolds db in - tclMAP (function - | OnHyp (id,occs,where) -> tac occs (Some (id,where)) - | OnConcl occs -> tac occs None) - cls gl - end + if not (Locusops.clause_with_generic_occurrences cls) then + user_err ~hdr:"autounfold" (str "\"at\" clause not supported"); + match List.fold_left (fun (ids, csts) dbname -> + let db = try searchtable_map dbname + with Not_found -> raise (UnknownDatabase dbname) + in + let (db_ids, db_csts) = Hint_db.unfolds db in + (Id.Set.fold cons db_ids ids, Cset.fold cons db_csts csts)) ([], []) db + with + | (ids, csts) -> Proofview.Goal.enter begin fun gl -> + let cls = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cls in + let tac = autounfolds ids csts gl in + Tacticals.New.tclMAP (function + | OnHyp (id, _, where) -> tac (Some (id, where)) + | OnConcl _ -> tac None) cls + end + | exception UnknownDatabase dbname -> Tacticals.New.tclZEROMSG (str "Unknown database " ++ str dbname) let autounfold_tac db cls = Proofview.tclUNIT () >>= fun () -> diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml index 910e042e7a..9a517652a7 100644 --- a/tactics/elimschemes.ml +++ b/tactics/elimschemes.ml @@ -27,11 +27,11 @@ open Ind_tables let optimize_non_type_induction_scheme kind dep sort ind = let env = Global.env () in let sigma = Evd.from_env env in - if check_scheme kind ind then + match lookup_scheme kind ind with + | Some cte -> (* in case the inductive has a type elimination, generates only one induction scheme, the other ones share the same code with the appropriate type *) - let cte = lookup_scheme kind ind in let sigma, cte = Evd.fresh_constant_instance env sigma cte in let c = mkConstU cte in let t = type_of_constant_in (Global.env()) cte in @@ -48,7 +48,7 @@ let optimize_non_type_induction_scheme kind dep sort ind = let sigma, t', c' = weaken_sort_scheme env sigma false sort npars c t in let sigma = Evd.minimize_universes sigma in (Evarutil.nf_evars_universes sigma c', Evd.evar_universe_context sigma) - else + | None -> let sigma, pind = Evd.fresh_inductive_instance ~rigid:UState.univ_rigid env sigma ind in let sigma, c = build_induction_scheme env sigma pind dep sort in (c, Evd.evar_universe_context sigma) @@ -62,7 +62,7 @@ let build_induction_scheme_in_type dep sort ind = let declare_individual_scheme_object name ?aux f = let f : individual_scheme_object_function = - fun _ ind -> f ind, Evd.empty_side_effects + fun _ ind -> f ind in declare_individual_scheme_object name ?aux f diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index 98da61781e..7c702eab3a 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -229,7 +229,7 @@ let sym_scheme_kind = declare_individual_scheme_object "_sym_internal" (fun _ ind -> let c, ctx = build_sym_scheme (Global.env() (* side-effect! *)) ind in - (c, ctx), Evd.empty_side_effects) + (c, ctx)) (**********************************************************************) (* Build the involutivity of symmetry for an inductive type *) @@ -248,17 +248,17 @@ let sym_scheme_kind = (**********************************************************************) let const_of_scheme kind env ind ctx = - let sym_scheme, eff = (find_scheme kind ind) in + let sym_scheme = match lookup_scheme kind ind with Some cst -> cst | None -> assert false in let sym, ctx = with_context_set ctx (UnivGen.fresh_constant_instance (Global.env()) sym_scheme) in - mkConstU sym, ctx, eff + mkConstU sym, ctx let build_sym_involutive_scheme env ind = let (ind,u as indu), ctx = UnivGen.fresh_inductive_instance env ind in let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 = get_sym_eq_data env indu in let eq,eqrefl,ctx = get_coq_eq ctx in - let sym, ctx, eff = const_of_scheme sym_scheme_kind env ind ctx in + let sym, ctx = const_of_scheme sym_scheme_kind env ind ctx in let cstr n = mkApp (mkConstructUi (indu,1),Context.Rel.to_extended_vect mkRel n paramsctxt) in let inds = snd (mind_arity mip) in let indr = Sorts.relevance_of_sort_family inds in @@ -297,10 +297,11 @@ let build_sym_involutive_scheme env ind = mkRel 1|])), mkRel 1 (* varH *), [|mkApp(eqrefl,[|applied_ind_C;cstr (nrealargs+1)|])|])))) - in (c, UState.of_context_set ctx), eff + in (c, UState.of_context_set ctx) let sym_involutive_scheme_kind = declare_individual_scheme_object "_sym_involutive" + ~deps:(fun ind -> [SchemeIndividualDep (ind, sym_scheme_kind)]) (fun _ ind -> build_sym_involutive_scheme (Global.env() (* side-effect! *)) ind) @@ -368,8 +369,8 @@ let build_l2r_rew_scheme dep env ind kind = let (ind,u as indu), ctx = UnivGen.fresh_inductive_instance env ind in let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 = get_sym_eq_data env indu in - let sym, ctx, eff = const_of_scheme sym_scheme_kind env ind ctx in - let sym_involutive, ctx, eff' = const_of_scheme sym_involutive_scheme_kind env ind ctx in + let sym, ctx = const_of_scheme sym_scheme_kind env ind ctx in + let sym_involutive, ctx = const_of_scheme sym_involutive_scheme_kind env ind ctx in let eq,eqrefl,ctx = get_coq_eq ctx in let cstr n p = mkApp (mkConstructUi(indu,1), @@ -454,8 +455,7 @@ let build_l2r_rew_scheme dep env ind kind = [|main_body|]) else main_body)))))) - in (c, UState.of_context_set ctx), - Evd.concat_side_effects eff' eff + in (c, UState.of_context_set ctx) (**********************************************************************) (* Build the left-to-right rewriting lemma for hypotheses associated *) @@ -698,6 +698,10 @@ let build_r2l_rew_scheme dep env ind k = (**********************************************************************) let rew_l2r_dep_scheme_kind = declare_individual_scheme_object "_rew_r_dep" + ~deps:(fun ind -> [ + SchemeIndividualDep (ind, sym_scheme_kind); + SchemeIndividualDep (ind, sym_involutive_scheme_kind); + ]) (fun _ ind -> build_l2r_rew_scheme true (Global.env()) ind InType) (**********************************************************************) @@ -708,7 +712,7 @@ let rew_l2r_dep_scheme_kind = (**********************************************************************) let rew_r2l_dep_scheme_kind = declare_individual_scheme_object "_rew_dep" - (fun _ ind -> build_r2l_rew_scheme true (Global.env()) ind InType,Evd.empty_side_effects) + (fun _ ind -> build_r2l_rew_scheme true (Global.env()) ind InType) (**********************************************************************) (* Dependent rewrite from right-to-left in hypotheses *) @@ -718,7 +722,7 @@ let rew_r2l_dep_scheme_kind = (**********************************************************************) let rew_r2l_forward_dep_scheme_kind = declare_individual_scheme_object "_rew_fwd_dep" - (fun _ ind -> build_r2l_forward_rew_scheme true (Global.env()) ind InType,Evd.empty_side_effects) + (fun _ ind -> build_r2l_forward_rew_scheme true (Global.env()) ind InType) (**********************************************************************) (* Dependent rewrite from left-to-right in hypotheses *) @@ -728,7 +732,7 @@ let rew_r2l_forward_dep_scheme_kind = (**********************************************************************) let rew_l2r_forward_dep_scheme_kind = declare_individual_scheme_object "_rew_fwd_r_dep" - (fun _ ind -> build_l2r_forward_rew_scheme true (Global.env()) ind InType,Evd.empty_side_effects) + (fun _ ind -> build_l2r_forward_rew_scheme true (Global.env()) ind InType) (**********************************************************************) (* Non-dependent rewrite from either left-to-right in conclusion or *) @@ -742,7 +746,7 @@ let rew_l2r_forward_dep_scheme_kind = let rew_l2r_scheme_kind = declare_individual_scheme_object "_rew_r" (fun _ ind -> fix_r2l_forward_rew_scheme - (build_r2l_forward_rew_scheme false (Global.env()) ind InType), Evd.empty_side_effects) + (build_r2l_forward_rew_scheme false (Global.env()) ind InType)) (**********************************************************************) (* Non-dependent rewrite from either right-to-left in conclusion or *) @@ -752,7 +756,7 @@ let rew_l2r_scheme_kind = (**********************************************************************) let rew_r2l_scheme_kind = declare_individual_scheme_object "_rew" - (fun _ ind -> build_r2l_rew_scheme false (Global.env()) ind InType, Evd.empty_side_effects) + (fun _ ind -> build_r2l_rew_scheme false (Global.env()) ind InType) (* End of rewriting schemes *) @@ -835,5 +839,4 @@ let build_congr env (eq,refl,ctx) ind = let congr_scheme_kind = declare_individual_scheme_object "_congr" (fun _ ind -> (* May fail if equality is not defined *) - build_congr (Global.env()) (get_coq_eq Univ.ContextSet.empty) ind, - Evd.empty_side_effects) + build_congr (Global.env()) (get_coq_eq Univ.ContextSet.empty) ind) diff --git a/tactics/eqschemes.mli b/tactics/eqschemes.mli index d1038f2655..6447708ace 100644 --- a/tactics/eqschemes.mli +++ b/tactics/eqschemes.mli @@ -27,7 +27,7 @@ val rew_r2l_scheme_kind : individual scheme_kind val build_r2l_rew_scheme : bool -> env -> inductive -> Sorts.family -> constr Evd.in_evar_universe_context val build_l2r_rew_scheme : bool -> env -> inductive -> Sorts.family -> - constr Evd.in_evar_universe_context * Evd.side_effects + constr Evd.in_evar_universe_context val build_r2l_forward_rew_scheme : bool -> env -> inductive -> Sorts.family -> constr Evd.in_evar_universe_context val build_l2r_forward_rew_scheme : @@ -39,7 +39,7 @@ val build_sym_scheme : env -> inductive -> constr Evd.in_evar_universe_context val sym_scheme_kind : individual scheme_kind val build_sym_involutive_scheme : env -> inductive -> - constr Evd.in_evar_universe_context * Evd.side_effects + constr Evd.in_evar_universe_context val sym_involutive_scheme_kind : individual scheme_kind (** Builds a congruence scheme for an equality type *) diff --git a/tactics/equality.ml b/tactics/equality.ml index 49645d82a4..f3073acb0a 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -411,8 +411,7 @@ let find_elim hdcncl lft2rgt dep cls ot = match EConstr.kind sigma hdcncl with | Ind (ind,u) -> - let c, eff = find_scheme scheme_name ind in - Proofview.tclEFFECTS eff <*> + find_scheme scheme_name ind >>= fun c -> pf_constr_of_global (GlobRef.ConstRef c) | _ -> assert false end @@ -1001,14 +1000,13 @@ let ind_scheme_of_eq lbeq to_kind = let from_kind = inductive_sort_family mip in (* use ind rather than case by compatibility *) let kind = Elimschemes.nondep_elim_scheme from_kind to_kind in - let c, eff = find_scheme kind (destIndRef lbeq.eq) in - GlobRef.ConstRef c, eff + find_scheme kind (destIndRef lbeq.eq) >>= fun c -> + Proofview.tclUNIT (GlobRef.ConstRef c) let discrimination_pf e (t,t1,t2) discriminator lbeq to_kind = build_coq_I () >>= fun i -> - let eq_elim, eff = ind_scheme_of_eq lbeq to_kind in - Proofview.tclEFFECTS eff <*> + ind_scheme_of_eq lbeq to_kind >>= fun eq_elim -> pf_constr_of_global eq_elim >>= fun eq_elim -> Proofview.tclUNIT (applist (eq_elim, [t;t1;mkNamedLambda (make_annot e Sorts.Relevant) t discriminator;i;t2])) @@ -1347,15 +1345,15 @@ let inject_if_homogenous_dependent_pair ty = (* and compare the fst arguments of the dep pair *) (* Note: should work even if not an inductive type, but the table only *) (* knows inductive types *) - if not (Ind_tables.check_scheme (!eq_dec_scheme_kind_name()) ind && + if not (Option.has_some (Ind_tables.lookup_scheme (!eq_dec_scheme_kind_name()) ind) && pf_apply is_conv gl ar1.(2) ar2.(2)) then raise Exit; check_required_library ["Coq";"Logic";"Eqdep_dec"]; let new_eq_args = [|pf_get_type_of gl ar1.(3);ar1.(3);ar2.(3)|] in let inj2 = lib_ref "core.eqdep_dec.inj_pair2" in - let c, eff = find_scheme (!eq_dec_scheme_kind_name()) ind in + find_scheme (!eq_dec_scheme_kind_name()) ind >>= fun c -> (* cut with the good equality and prove the requested goal *) tclTHENLIST - [Proofview.tclEFFECTS eff; + [ intro; onLastHyp (fun hyp -> Tacticals.New.pf_constr_of_global Coqlib.(lib_ref "core.eq.type") >>= fun ceq -> diff --git a/tactics/hints.ml b/tactics/hints.ml index a907b9e783..5fb519cc4f 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -23,7 +23,6 @@ open Globnames open Libobject open Namegen open Libnames -open Smartlocate open Termops open Inductiveops open Typeclasses @@ -100,8 +99,6 @@ let empty_hint_info = (* The Type of Constructions Autotactic Hints *) (************************************************************************) -type hint_info_expr = Constrexpr.constr_pattern_expr hint_info_gen - type 'a hint_ast = | Res_pf of 'a (* Hint Apply *) | ERes_pf of 'a (* Hint EApply *) @@ -164,10 +161,6 @@ type full_hint = hint with_metadata type hint_entry = GlobRef.t option * raw_hint hint_ast with_uid with_metadata -type reference_or_constr = - | HintsReference of qualid - | HintsConstr of Constrexpr.constr_expr - type hint_mode = | ModeInput (* No evars *) | ModeNoHeadEvar (* No evar at the head *) @@ -178,37 +171,26 @@ type 'a hints_transparency_target = | HintsConstants | HintsReferences of 'a list -type hints_expr = - | HintsResolve of (hint_info_expr * bool * reference_or_constr) list - | HintsResolveIFF of bool * qualid list * int option - | HintsImmediate of reference_or_constr list - | HintsUnfold of qualid list - | HintsTransparency of qualid hints_transparency_target * bool - | HintsMode of qualid * hint_mode list - | HintsConstructors of qualid list - | HintsExtern of int * Constrexpr.constr_expr option * Genarg.raw_generic_argument - -type import_level = [ `LAX | `WARN | `STRICT ] - -let warn_hint : import_level ref = ref `LAX -let read_warn_hint () = match !warn_hint with -| `LAX -> "Lax" -| `WARN -> "Warn" -| `STRICT -> "Strict" - -let write_warn_hint = function -| "Lax" -> warn_hint := `LAX -| "Warn" -> warn_hint := `WARN -| "Strict" -> warn_hint := `STRICT -| _ -> user_err Pp.(str "Only the following flags are accepted: Lax, Warn, Strict.") - -let () = - Goptions.(declare_string_option - { optdepr = false; - optkey = ["Loose"; "Hint"; "Behavior"]; - optread = read_warn_hint; - optwrite = write_warn_hint; - }) +type import_level = HintLax | HintWarn | HintStrict + +let warn_hint_to_string = function +| HintLax -> "Lax" +| HintWarn -> "Warn" +| HintStrict -> "Strict" + +let string_to_warn_hint = function +| "Lax" -> HintLax +| "Warn" -> HintWarn +| "Strict" -> HintStrict +| _ -> user_err Pp.(str "Only the following values are accepted: Lax, Warn, Strict.") + +let warn_hint = + Goptions.declare_interpreted_string_option_and_ref + ~depr:false + ~key:["Loose"; "Hint"; "Behavior"] + ~value:HintLax + string_to_warn_hint + warn_hint_to_string let fresh_key = let id = Summary.ref ~name:"HINT-COUNTER" 0 in @@ -896,7 +878,7 @@ let fresh_global_or_constr env sigma poly cr = else begin if isgr then warn_polymorphic_hint (pr_hint_term env sigma ctx cr); - Declare.declare_universe_context ~poly:false ctx; + DeclareUctx.declare_universe_context ~poly:false ctx; (c, Univ.ContextSet.empty) end @@ -1164,7 +1146,7 @@ let inAutoHint : hint_obj -> obj = declare_object {(default_object "AUTOHINT") with cache_function = cache_autohint; load_function = load_autohint; - open_function = open_autohint; + open_function = simple_open open_autohint; subst_function = subst_autohint; classify_function = classify_autohint; } @@ -1311,114 +1293,6 @@ let prepare_hint check env init (sigma,c) = let diff = Univ.ContextSet.diff (Evd.universe_context_set sigma) (Evd.universe_context_set init) in (c', diff) -let project_hint ~poly pri l2r r = - let open EConstr in - let open Coqlib in - let gr = Smartlocate.global_with_alias r in - let env = Global.env() in - let sigma = Evd.from_env env in - let sigma, c = Evd.fresh_global env sigma gr in - let t = Retyping.get_type_of env sigma c in - let t = - Tacred.reduce_to_quantified_ref env sigma (lib_ref "core.iff.type") t in - let sign,ccl = decompose_prod_assum sigma t in - let (a,b) = match snd (decompose_app sigma ccl) with - | [a;b] -> (a,b) - | _ -> assert false in - let p = - if l2r then lib_ref "core.iff.proj1" else lib_ref "core.iff.proj2" in - let sigma, p = Evd.fresh_global env sigma p in - let c = Reductionops.whd_beta sigma (mkApp (c, Context.Rel.to_extended_vect mkRel 0 sign)) in - let c = it_mkLambda_or_LetIn - (mkApp (p,[|mkArrow a Sorts.Relevant (lift 1 b);mkArrow b Sorts.Relevant (lift 1 a);c|])) sign in - let name = - Nameops.add_suffix (Nametab.basename_of_global gr) ("_proj_" ^ (if l2r then "l2r" else "r2l")) - in - let ctx = Evd.univ_entry ~poly sigma in - let c = EConstr.to_constr sigma c in - let cb = Declare.(DefinitionEntry (definition_entry ~univs:ctx ~opaque:false c)) in - let c = Declare.declare_constant - ~local:Declare.ImportDefaultBehavior - ~name ~kind:Decls.(IsDefinition Definition) cb - in - let info = {Typeclasses.hint_priority = pri; hint_pattern = None} in - (info,false,true,PathAny, IsGlobRef (GlobRef.ConstRef c)) - -let warn_deprecated_hint_constr = - CWarnings.create ~name:"deprecated-hint-constr" ~category:"deprecated" - (fun () -> - Pp.strbrk - "Declaring arbitrary terms as hints is deprecated; declare a global reference instead" - ) - -let interp_hints ~poly = - fun h -> - let env = Global.env () in - let sigma = Evd.from_env env in - let f poly c = - let evd,c = Constrintern.interp_open_constr env sigma c in - let env = Global.env () in - let sigma = Evd.from_env env in - let (c, diff) = prepare_hint true env sigma (evd,c) in - if poly then IsConstr (c, diff) - else - let () = Declare.declare_universe_context ~poly:false diff in - IsConstr (c, Univ.ContextSet.empty) - in - let fref r = - let gr = global_with_alias r in - Dumpglob.add_glob ?loc:r.CAst.loc gr; - gr in - let fr r = evaluable_of_global_reference env (fref r) in - let fi c = - match c with - | HintsReference c -> - let gr = global_with_alias c in - (PathHints [gr], poly, IsGlobRef gr) - | HintsConstr c -> - let () = warn_deprecated_hint_constr () in - (PathAny, poly, f poly c) - in - let fp = Constrintern.intern_constr_pattern env sigma in - let fres (info, b, r) = - let path, poly, gr = fi r in - let info = { info with hint_pattern = Option.map fp info.hint_pattern } in - (info, poly, b, path, gr) - in - let ft = function - | HintsVariables -> HintsVariables - | HintsConstants -> HintsConstants - | HintsReferences lhints -> HintsReferences (List.map fr lhints) - in - let fp = Constrintern.intern_constr_pattern (Global.env()) in - match h with - | HintsResolve lhints -> HintsResolveEntry (List.map fres lhints) - | HintsResolveIFF (l2r, lc, n) -> - HintsResolveEntry (List.map (project_hint ~poly n l2r) lc) - | HintsImmediate lhints -> HintsImmediateEntry (List.map fi lhints) - | HintsUnfold lhints -> HintsUnfoldEntry (List.map fr lhints) - | HintsTransparency (t, b) -> HintsTransparencyEntry (ft t, b) - | HintsMode (r, l) -> HintsModeEntry (fref r, l) - | HintsConstructors lqid -> - let constr_hints_of_ind qid = - let ind = global_inductive_with_alias qid in - let mib,_ = Global.lookup_inductive ind in - Dumpglob.dump_reference ?loc:qid.CAst.loc "<>" (string_of_qualid qid) "ind"; - List.init (nconstructors env ind) - (fun i -> let c = (ind,i+1) in - let gr = GlobRef.ConstructRef c in - empty_hint_info, - (Declareops.inductive_is_polymorphic mib), true, - PathHints [gr], IsGlobRef gr) - in HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid)) - | HintsExtern (pri, patcom, tacexp) -> - let pat = Option.map (fp sigma) patcom in - let l = match pat with None -> [] | Some (l, _) -> l in - let ltacvars = List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty l in - let env = Genintern.({ (empty_glob_sign env) with ltacvars }) in - let _, tacexp = Genintern.generic_intern env tacexp in - HintsExternEntry ({ hint_priority = Some pri; hint_pattern = pat }, tacexp) - let add_hints ~locality dbnames h = let local, superglobal = match locality with | Goptions.OptDefault | Goptions.OptGlobal -> false, true @@ -1563,8 +1437,7 @@ let pr_hint_term env sigma cl = (* print all hints that apply to the concl of the current goal *) let pr_applicable_hint pf = let env = Global.env () in - let pts = Proof_global.get_proof pf in - let Proof.{goals;sigma} = Proof.data pts in + let Proof.{goals;sigma} = Proof.data pf in match goals with | [] -> CErrors.user_err Pp.(str "No focused goal.") | g::_ -> @@ -1690,12 +1563,12 @@ let wrap_hint_warning_fun env sigma t = in (ans, set_extra_data store sigma) -let run_hint tac k = match !warn_hint with -| `LAX -> k tac.obj -| `WARN -> +let run_hint tac k = match warn_hint () with +| HintLax -> k tac.obj +| HintWarn -> if is_imported tac then k tac.obj else Proofview.tclTHEN (log_hint tac) (k tac.obj) -| `STRICT -> +| HintStrict -> if is_imported tac then k tac.obj else Proofview.tclZERO (UserError (None, (str "Tactic failure."))) diff --git a/tactics/hints.mli b/tactics/hints.mli index 9e11931247..f5fd3348e4 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -32,8 +32,6 @@ val empty_hint_info : 'a Typeclasses.hint_info_gen (** Pre-created hint databases *) -type hint_info_expr = Constrexpr.constr_pattern_expr hint_info_gen - type 'a hint_ast = | Res_pf of 'a (* Hint Apply *) | ERes_pf of 'a (* Hint EApply *) @@ -78,10 +76,6 @@ type search_entry type hint_entry -type reference_or_constr = - | HintsReference of Libnames.qualid - | HintsConstr of Constrexpr.constr_expr - type hint_mode = | ModeInput (* No evars *) | ModeNoHeadEvar (* No evar at the head *) @@ -92,16 +86,6 @@ type 'a hints_transparency_target = | HintsConstants | HintsReferences of 'a list -type hints_expr = - | HintsResolve of (hint_info_expr * bool * reference_or_constr) list - | HintsResolveIFF of bool * Libnames.qualid list * int option - | HintsImmediate of reference_or_constr list - | HintsUnfold of Libnames.qualid list - | HintsTransparency of Libnames.qualid hints_transparency_target * bool - | HintsMode of Libnames.qualid * hint_mode list - | HintsConstructors of Libnames.qualid list - | HintsExtern of int * Constrexpr.constr_expr option * Genarg.raw_generic_argument - type 'a hints_path_gen = | PathAtom of 'a hints_path_atom_gen | PathStar of 'a hints_path_gen @@ -217,8 +201,6 @@ val current_db_names : unit -> String.Set.t val current_pure_db : unit -> hint_db list -val interp_hints : poly:bool -> hints_expr -> hints_entry - val add_hints : locality:Goptions.option_locality -> hint_db_name list -> hints_entry -> unit val prepare_hint : bool (* Check no remaining evars *) -> @@ -306,7 +288,7 @@ val wrap_hint_warning_fun : env -> evar_map -> (** Printing hints *) val pr_searchtable : env -> evar_map -> Pp.t -val pr_applicable_hint : Proof_global.t -> Pp.t +val pr_applicable_hint : Proof.t -> Pp.t val pr_hint_ref : env -> evar_map -> GlobRef.t -> Pp.t val pr_hint_db_by_name : env -> evar_map -> hint_db_name -> Pp.t val pr_hint_db_env : env -> evar_map -> Hint_db.t -> Pp.t diff --git a/tactics/ind_tables.ml b/tactics/ind_tables.ml index 8336fae02f..9164a4ff26 100644 --- a/tactics/ind_tables.ml +++ b/tactics/ind_tables.ml @@ -32,9 +32,9 @@ type internal_flag = | UserIndividualRequest (* user action, a message is displayed *) type mutual_scheme_object_function = - internal_flag -> MutInd.t -> constr array Evd.in_evar_universe_context * Evd.side_effects + internal_flag -> MutInd.t -> constr array Evd.in_evar_universe_context type individual_scheme_object_function = - internal_flag -> inductive -> constr Evd.in_evar_universe_context * Evd.side_effects + internal_flag -> inductive -> constr Evd.in_evar_universe_context type 'a scheme_kind = string @@ -46,9 +46,13 @@ let pr_scheme_kind = Pp.str type individual type mutual +type scheme_dependency = +| SchemeMutualDep of MutInd.t * mutual scheme_kind +| SchemeIndividualDep of inductive * individual scheme_kind + type scheme_object_function = - | MutualSchemeFunction of mutual_scheme_object_function - | IndividualSchemeFunction of individual_scheme_object_function + | MutualSchemeFunction of mutual_scheme_object_function * (MutInd.t -> scheme_dependency list) option + | IndividualSchemeFunction of individual_scheme_object_function * (inductive -> scheme_dependency list) option let scheme_object_table = (Hashtbl.create 17 : (string, string * scheme_object_function) Hashtbl.t) @@ -68,11 +72,11 @@ let declare_scheme_object s aux f = Hashtbl.add scheme_object_table key (s,f); key -let declare_mutual_scheme_object s ?(aux="") f = - declare_scheme_object s aux (MutualSchemeFunction f) +let declare_mutual_scheme_object s ?deps ?(aux="") f = + declare_scheme_object s aux (MutualSchemeFunction (f, deps)) -let declare_individual_scheme_object s ?(aux="") f = - declare_scheme_object s aux (IndividualSchemeFunction f) +let declare_individual_scheme_object s ?deps ?(aux="") f = + declare_scheme_object s aux (IndividualSchemeFunction (f, deps)) (**********************************************************************) (* Defining/retrieving schemes *) @@ -86,18 +90,24 @@ let compute_name internal id = Namegen.next_ident_away_from (add_prefix "internal_" id) is_visible_name else id +let declare_definition_scheme = ref (fun ~internal ~univs ~role ~name c -> + CErrors.anomaly (Pp.str "scheme declaration not registered")) + +let lookup_scheme kind ind = + try Some (DeclareScheme.lookup_scheme kind ind) with Not_found -> None + +let check_scheme kind ind = Option.has_some (lookup_scheme kind ind) + let define internal role id c poly univs = let id = compute_name internal id in let ctx = UState.minimize univs in let c = UnivSubst.nf_evars_and_universes_opt_subst (fun _ -> None) (UState.subst ctx) c in let univs = UState.univ_entry ~poly ctx in - let entry = Declare.pure_definition_entry ~univs c in - let kn, eff = Declare.declare_private_constant ~role ~kind:Decls.(IsDefinition Scheme) ~name:id entry in - let () = if internal then () else Declare.definition_message id in - kn, eff + !declare_definition_scheme ~internal ~univs ~role ~name:id c -let define_individual_scheme_base kind suff f mode idopt (mind,i as ind) = - let (c, ctx), eff = f mode ind in +(* Assumes that dependencies are already defined *) +let rec define_individual_scheme_base kind suff f mode idopt (mind,i as ind) eff = + let (c, ctx) = f mode ind in let mib = Global.lookup_mind mind in let id = match idopt with | Some id -> id @@ -105,17 +115,21 @@ let define_individual_scheme_base kind suff f mode idopt (mind,i as ind) = let role = Evd.Schema (ind, kind) in let internal = mode == InternalTacticRequest in let const, neff = define internal role id c (Declareops.inductive_is_polymorphic mib) ctx in + let eff = Evd.concat_side_effects neff eff in DeclareScheme.declare_scheme kind [|ind,const|]; - const, Evd.concat_side_effects neff eff + const, eff -let define_individual_scheme kind mode names (mind,i as ind) = +and define_individual_scheme kind mode names (mind,i as ind) = match Hashtbl.find scheme_object_table kind with - | _,MutualSchemeFunction f -> assert false - | s,IndividualSchemeFunction f -> - define_individual_scheme_base kind s f mode names ind - -let define_mutual_scheme_base kind suff f mode names mind = - let (cl, ctx), eff = f mode mind in + | _,MutualSchemeFunction _ -> assert false + | s,IndividualSchemeFunction (f, deps) -> + let deps = match deps with None -> [] | Some deps -> deps ind in + let eff = List.fold_left (fun eff dep -> declare_scheme_dependence mode eff dep) Evd.empty_side_effects deps in + define_individual_scheme_base kind s f mode names ind eff + +(* Assumes that dependencies are already defined *) +and define_mutual_scheme_base kind suff f mode names mind eff = + let (cl, ctx) = f mode mind in let mib = Global.lookup_mind mind in let ids = Array.init (Array.length mib.mind_packets) (fun i -> try Int.List.assoc i names @@ -131,34 +145,49 @@ let define_mutual_scheme_base kind suff f mode names mind = DeclareScheme.declare_scheme kind schemes; consts, eff -let define_mutual_scheme kind mode names mind = +and define_mutual_scheme kind mode names mind = match Hashtbl.find scheme_object_table kind with | _,IndividualSchemeFunction _ -> assert false - | s,MutualSchemeFunction f -> - define_mutual_scheme_base kind s f mode names mind - -let find_scheme_on_env_too kind ind = - let s = DeclareScheme.lookup_scheme kind ind in - s, Evd.empty_side_effects + | s,MutualSchemeFunction (f, deps) -> + let deps = match deps with None -> [] | Some deps -> deps mind in + let eff = List.fold_left (fun eff dep -> declare_scheme_dependence mode eff dep) Evd.empty_side_effects deps in + define_mutual_scheme_base kind s f mode names mind eff + +and declare_scheme_dependence mode eff = function +| SchemeIndividualDep (ind, kind) -> + if check_scheme kind ind then eff + else + let _, eff' = define_individual_scheme kind mode None ind in + Evd.concat_side_effects eff' eff +| SchemeMutualDep (mind, kind) -> + if check_scheme kind (mind, 0) then eff + else + let _, eff' = define_mutual_scheme kind mode [] mind in + Evd.concat_side_effects eff' eff let find_scheme ?(mode=InternalTacticRequest) kind (mind,i as ind) = - try find_scheme_on_env_too kind ind - with Not_found -> + let open Proofview.Notations in + match lookup_scheme kind ind with + | Some s -> + (* FIXME: we need to perform this call to reset the environment, since the + imperative scheme table is desynchronized from the monadic interface. *) + Proofview.tclEFFECTS Evd.empty_side_effects <*> + Proofview.tclUNIT s + | None -> match Hashtbl.find scheme_object_table kind with - | s,IndividualSchemeFunction f -> - define_individual_scheme_base kind s f mode None ind - | s,MutualSchemeFunction f -> - let ca, eff = define_mutual_scheme_base kind s f mode [] mind in - ca.(i), eff + | s,IndividualSchemeFunction (f, deps) -> + let deps = match deps with None -> [] | Some deps -> deps ind in + let eff = List.fold_left (fun eff dep -> declare_scheme_dependence mode eff dep) Evd.empty_side_effects deps in + let c, eff = define_individual_scheme_base kind s f mode None ind eff in + Proofview.tclEFFECTS eff <*> Proofview.tclUNIT c + | s,MutualSchemeFunction (f, deps) -> + let deps = match deps with None -> [] | Some deps -> deps mind in + let eff = List.fold_left (fun eff dep -> declare_scheme_dependence mode eff dep) Evd.empty_side_effects deps in + let ca, eff = define_mutual_scheme_base kind s f mode [] mind eff in + Proofview.tclEFFECTS eff <*> Proofview.tclUNIT ca.(i) let define_individual_scheme kind mode names ind = ignore (define_individual_scheme kind mode names ind) let define_mutual_scheme kind mode names mind = ignore (define_mutual_scheme kind mode names mind) - -let check_scheme kind ind = - try let _ = find_scheme_on_env_too kind ind in true - with Not_found -> false - -let lookup_scheme = DeclareScheme.lookup_scheme diff --git a/tactics/ind_tables.mli b/tactics/ind_tables.mli index dad2036c64..09fb051194 100644 --- a/tactics/ind_tables.mli +++ b/tactics/ind_tables.mli @@ -25,19 +25,27 @@ type internal_flag = | InternalTacticRequest | UserIndividualRequest +type scheme_dependency = +| SchemeMutualDep of MutInd.t * mutual scheme_kind +| SchemeIndividualDep of inductive * individual scheme_kind + type mutual_scheme_object_function = - internal_flag -> MutInd.t -> constr array Evd.in_evar_universe_context * Evd.side_effects + internal_flag -> MutInd.t -> constr array Evd.in_evar_universe_context type individual_scheme_object_function = - internal_flag -> inductive -> constr Evd.in_evar_universe_context * Evd.side_effects + internal_flag -> inductive -> constr Evd.in_evar_universe_context (** Main functions to register a scheme builder. Note these functions are not safe to be used by plugins as their effects won't be undone on backtracking *) -val declare_mutual_scheme_object : string -> ?aux:string -> +val declare_mutual_scheme_object : string -> + ?deps:(MutInd.t -> scheme_dependency list) -> + ?aux:string -> mutual_scheme_object_function -> mutual scheme_kind -val declare_individual_scheme_object : string -> ?aux:string -> +val declare_individual_scheme_object : string -> + ?deps:(inductive -> scheme_dependency list) -> + ?aux:string -> individual_scheme_object_function -> individual scheme_kind @@ -51,11 +59,17 @@ val define_mutual_scheme : mutual scheme_kind -> internal_flag (** internal *) - (int * Id.t) list -> MutInd.t -> unit (** Main function to retrieve a scheme in the cache or to generate it *) -val find_scheme : ?mode:internal_flag -> 'a scheme_kind -> inductive -> Constant.t * Evd.side_effects - -val check_scheme : 'a scheme_kind -> inductive -> bool +val find_scheme : ?mode:internal_flag -> 'a scheme_kind -> inductive -> Constant.t Proofview.tactic -(** Like [find_scheme] but fails when the scheme is not already in the cache *) -val lookup_scheme : 'a scheme_kind -> inductive -> Constant.t +(** Like [find_scheme] but does not generate a constant on the fly *) +val lookup_scheme : 'a scheme_kind -> inductive -> Constant.t option val pr_scheme_kind : 'a scheme_kind -> Pp.t + +val declare_definition_scheme : + (internal : bool + -> univs:Entries.universes_entry + -> role:Evd.side_effect_role + -> name:Id.t + -> Constr.t + -> Constant.t * Evd.side_effects) ref diff --git a/tactics/pfedit.ml b/tactics/pfedit.ml deleted file mode 100644 index b228a04298..0000000000 --- a/tactics/pfedit.ml +++ /dev/null @@ -1,193 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \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 Pp -open Util -open Names -open Environ -open Evd - -let use_unification_heuristics_ref = ref true -let () = Goptions.(declare_bool_option { - optdepr = false; - optkey = ["Solve";"Unification";"Constraints"]; - optread = (fun () -> !use_unification_heuristics_ref); - optwrite = (fun a -> use_unification_heuristics_ref:=a); -}) - -let use_unification_heuristics () = !use_unification_heuristics_ref - -exception NoSuchGoal -let () = CErrors.register_handler begin function - | NoSuchGoal -> Some Pp.(str "No such goal.") - | _ -> None -end - -let get_nth_V82_goal p i = - let Proof.{ sigma; goals } = Proof.data p in - try { it = List.nth goals (i-1) ; sigma } - with Failure _ -> raise NoSuchGoal - -let get_goal_context_gen pf i = - let { it=goal ; sigma=sigma; } = get_nth_V82_goal pf i in - (sigma, Refiner.pf_env { it=goal ; sigma=sigma; }) - -let get_goal_context pf i = - let p = Proof_global.get_proof pf in - get_goal_context_gen p i - -let get_current_goal_context pf = - let p = Proof_global.get_proof pf in - try get_goal_context_gen p 1 - with - | NoSuchGoal -> - (* spiwack: returning empty evar_map, since if there is no goal, - under focus, there is no accessible evar either. EJGA: this - seems strange, as we have pf *) - let env = Global.env () in - Evd.from_env env, env - -let get_proof_context p = - try get_goal_context_gen p 1 - with - | NoSuchGoal -> - (* No more focused goals *) - let { Proof.sigma } = Proof.data p in - sigma, Global.env () - -let get_current_context pf = - let p = Proof_global.get_proof pf in - get_proof_context p - -let solve ?with_end_tac gi info_lvl tac pr = - let tac = match with_end_tac with - | None -> tac - | Some etac -> Proofview.tclTHEN tac etac in - let tac = match info_lvl with - | None -> tac - | Some _ -> Proofview.Trace.record_info_trace tac - in - let nosuchgoal = Proofview.tclZERO (Proof_bullet.SuggestNoSuchGoals (1,pr)) in - let tac = let open Goal_select in match gi with - | SelectAlreadyFocused -> - let open Proofview.Notations in - Proofview.numgoals >>= fun n -> - if n == 1 then tac - else - let e = CErrors.UserError - (None, - Pp.(str "Expected a single focused goal but " ++ - int n ++ str " goals are focused.")) - in - Proofview.tclZERO e - - | SelectNth i -> Proofview.tclFOCUS ~nosuchgoal i i tac - | SelectList l -> Proofview.tclFOCUSLIST ~nosuchgoal l tac - | SelectId id -> Proofview.tclFOCUSID ~nosuchgoal id tac - | SelectAll -> tac - in - let tac = - if use_unification_heuristics () then - Proofview.tclTHEN tac Refine.solve_constraints - else tac - 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 env sigma ~lvl:i info)) - in - (p,status) - -let by tac = Proof_global.map_fold_proof (solve (Goal_select.SelectNth 1) None tac) - -(**********************************************************************) -(* Shortcut to build a term using tactics *) - -let next = let n = ref 0 in fun () -> incr n; !n - -let build_constant_by_tactic ~name ?(opaque=Proof_global.Transparent) ~uctx ~sign ~poly typ tac = - let evd = Evd.from_ctx uctx in - let goals = [ (Global.env_of_context sign , typ) ] in - let pf = Proof_global.start_proof ~name ~poly ~udecl:UState.default_univ_decl evd goals in - let pf, status = by tac pf in - let open Proof_global in - let { entries; uctx } = close_proof ~opaque ~keep_body_ucst_separate:false (fun x -> x) pf in - match entries with - | [entry] -> - entry, status, uctx - | _ -> - CErrors.anomaly Pp.(str "[build_constant_by_tactic] close_proof returned more than one proof term") - -let build_by_tactic ?(side_eff=true) env ~uctx ~poly ~typ tac = - let name = Id.of_string ("temporary_proof"^string_of_int (next())) in - let sign = val_of_named_context (named_context env) in - let ce, status, univs = build_constant_by_tactic ~name ~uctx ~sign ~poly typ tac in - let cb, uctx = - if side_eff then Declare.inline_private_constants ~uctx env ce - else - (* GG: side effects won't get reset: no need to treat their universes specially *) - let (cb, ctx), _eff = Future.force ce.Declare.proof_entry_body in - cb, UState.merge ~sideff:false Evd.univ_rigid uctx ctx - in - cb, ce.Declare.proof_entry_type, status, univs - -let refine_by_tactic ~name ~poly env sigma ty tac = - (* Save the initial side-effects to restore them afterwards. We set the - current set of side-effects to be empty so that we can retrieve the - ones created during the tactic invocation easily. *) - let eff = Evd.eval_side_effects sigma in - let sigma = Evd.drop_side_effects sigma in - (* Save the existing goals *) - let prev_future_goals = save_future_goals sigma in - (* Start a proof *) - let prf = Proof.start ~name ~poly sigma [env, ty] in - let (prf, _, ()) = - try Proof.run_tactic env tac prf - with Logic_monad.TacticFailure e as src -> - (* Catch the inner error of the monad tactic *) - let (_, info) = Exninfo.capture src in - Exninfo.iraise (e, info) - in - (* Plug back the retrieved sigma *) - let Proof.{ goals; stack; shelf; given_up; sigma; entry } = Proof.data prf in - assert (stack = []); - let ans = match Proofview.initial_goals entry with - | [c, _] -> c - | _ -> assert false - in - let ans = EConstr.to_constr ~abort_on_undefined_evars:false sigma ans in - (* [neff] contains the freshly generated side-effects *) - let neff = Evd.eval_side_effects sigma in - (* Reset the old side-effects *) - let sigma = Evd.drop_side_effects sigma in - let sigma = Evd.emit_side_effects eff sigma in - (* Restore former goals *) - let sigma = restore_future_goals sigma prev_future_goals in - (* Push remaining goals as future_goals which is the only way we - have to inform the caller that there are goals to collect while - not being encapsulated in the monad *) - (* Goals produced by tactic "shelve" *) - let sigma = List.fold_right (Evd.declare_future_goal ~tag:Evd.ToShelve) shelf sigma in - (* Goals produced by tactic "give_up" *) - let sigma = List.fold_right (Evd.declare_future_goal ~tag:Evd.ToGiveUp) given_up sigma in - (* Other goals *) - let sigma = List.fold_right Evd.declare_future_goal goals sigma in - (* Get rid of the fresh side-effects by internalizing them in the term - itself. Note that this is unsound, because the tactic may have solved - other goals that were already present during its invocation, so that - those goals rely on effects that are not present anymore. Hopefully, - this hack will work in most cases. *) - let neff = neff.Evd.seff_private in - let (ans, _) = Safe_typing.inline_private_constants env ((ans, Univ.ContextSet.empty), neff) in - ans, sigma diff --git a/tactics/pfedit.mli b/tactics/pfedit.mli deleted file mode 100644 index c49e997757..0000000000 --- a/tactics/pfedit.mli +++ /dev/null @@ -1,94 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \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) *) -(************************************************************************) - -(** Global proof state. A quite redundant wrapper on {!Proof_global}. *) - -open Names -open Constr -open Environ - -(** {6 ... } *) - -exception NoSuchGoal - -(** [get_goal_context n] returns the context of the [n]th subgoal of - the current focused proof or raises a [UserError] if there is no - focused proof or if there is no more subgoals *) - -val get_goal_context : Proof_global.t -> int -> Evd.evar_map * env - -(** [get_current_goal_context ()] works as [get_goal_context 1] *) -val get_current_goal_context : Proof_global.t -> Evd.evar_map * env - -(** [get_proof_context ()] gets the goal context for the first subgoal - of the proof *) -val get_proof_context : Proof.t -> Evd.evar_map * env - -(** [get_current_context ()] returns the context of the - current focused goal. If there is no focused goal but there - is a proof in progress, it returns the corresponding evar_map. - If there is no pending proof then it returns the current global - environment and empty evar_map. *) -val get_current_context : Proof_global.t -> Evd.evar_map * env - -(** {6 ... } *) - -(** [solve (SelectNth n) tac] applies tactic [tac] to the [n]th - subgoal of the current focused proof. [solve SelectAll - tac] applies [tac] to all subgoals. *) - -val solve : ?with_end_tac:unit Proofview.tactic -> - Goal_select.t -> int option -> unit Proofview.tactic -> - Proof.t -> Proof.t * bool - -(** [by tac] applies tactic [tac] to the 1st subgoal of the current - focused proof. - Returns [false] if an unsafe tactic has been used. *) - -val by : unit Proofview.tactic -> Proof_global.t -> Proof_global.t * bool - -(** Option telling if unification heuristics should be used. *) -val use_unification_heuristics : unit -> bool - -(** [build_by_tactic typ tac] returns a term of type [typ] by calling - [tac]. The return boolean, if [false] indicates the use of an unsafe - tactic. *) - -val build_constant_by_tactic - : name:Id.t - -> ?opaque:Proof_global.opacity_flag - -> uctx:UState.t - -> sign:named_context_val - -> poly:bool - -> EConstr.types - -> unit Proofview.tactic - -> Evd.side_effects Declare.proof_entry * bool * UState.t - -val build_by_tactic - : ?side_eff:bool - -> env - -> uctx:UState.t - -> poly:bool - -> typ:EConstr.types - -> unit Proofview.tactic - -> constr * types option * bool * UState.t - -val refine_by_tactic - : name:Id.t - -> poly:bool - -> env -> Evd.evar_map - -> EConstr.types - -> unit Proofview.tactic - -> constr * Evd.evar_map -(** A variant of the above function that handles open terms as well. - Caveat: all effects are purged in the returned term at the end, but other - evars solved by side-effects are NOT purged, so that unexpected failures may - occur. Ideally all code using this function should be rewritten in the - monad. *) diff --git a/tactics/proof_global.ml b/tactics/proof_global.ml deleted file mode 100644 index 623e6b8a42..0000000000 --- a/tactics/proof_global.ml +++ /dev/null @@ -1,285 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \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 Context - -module NamedDecl = Context.Named.Declaration - -(*** Proof Global Environment ***) - -type proof_object = - { name : Names.Id.t - ; entries : Evd.side_effects Declare.proof_entry list - ; uctx: UState.t - ; udecl : UState.universe_decl - } - -type opacity_flag = Opaque | Transparent - -type t = - { endline_tactic : Genarg.glob_generic_argument option - ; section_vars : Id.Set.t option - ; proof : Proof.t - ; udecl: UState.universe_decl - (** Initial universe declarations *) - ; initial_euctx : UState.t - (** The initial universe context (for the statement) *) - } - -(*** Proof Global manipulation ***) - -let get_proof ps = ps.proof -let get_proof_name ps = (Proof.data ps.proof).Proof.name - -let get_initial_euctx ps = ps.initial_euctx - -let map_proof f p = { p with proof = f p.proof } -let map_fold_proof f p = let proof, res = f p.proof in { p with proof }, res - -let map_fold_proof_endline f ps = - let et = - match ps.endline_tactic with - | None -> Proofview.tclUNIT () - | Some tac -> - let open Geninterp in - let {Proof.poly} = Proof.data ps.proof in - let ist = { lfun = Id.Map.empty; poly; extra = TacStore.empty } in - let Genarg.GenArg (Genarg.Glbwit tag, tac) = tac in - let tac = Geninterp.interp tag ist tac in - Ftactic.run tac (fun _ -> Proofview.tclUNIT ()) - in - let (newpr,ret) = f et ps.proof in - let ps = { ps with proof = newpr } in - ps, ret - -let compact_the_proof pf = map_proof Proof.compact pf - -(* Sets the tactic to be used when a tactic line is closed with [...] *) -let set_endline_tactic tac ps = - { ps with endline_tactic = Some tac } - -(** [start_proof ~name ~udecl ~poly sigma goals] starts a proof of - name [name] with goals [goals] (a list of pairs of environment and - conclusion). The proof is started in the evar map [sigma] (which - can typically contain universe constraints), and with universe - bindings [udecl]. *) -let start_proof ~name ~udecl ~poly sigma goals = - let proof = Proof.start ~name ~poly sigma goals in - let initial_euctx = Evd.evar_universe_context Proof.((data proof).sigma) in - { proof - ; endline_tactic = None - ; section_vars = None - ; udecl - ; initial_euctx - } - -let start_dependent_proof ~name ~udecl ~poly goals = - let proof = Proof.dependent_start ~name ~poly goals in - let initial_euctx = Evd.evar_universe_context Proof.((data proof).sigma) in - { proof - ; endline_tactic = None - ; section_vars = None - ; udecl - ; initial_euctx - } - -let get_used_variables pf = pf.section_vars -let get_universe_decl pf = pf.udecl - -let set_used_variables ps l = - let open Context.Named.Declaration in - let env = Global.env () in - let ids = List.fold_right Id.Set.add l Id.Set.empty in - let ctx = Environ.keep_hyps env ids in - let ctx_set = - List.fold_right Id.Set.add (List.map NamedDecl.get_id ctx) Id.Set.empty in - let vars_of = Environ.global_vars_set in - let aux env entry (ctx, all_safe as orig) = - match entry with - | LocalAssum ({binder_name=x},_) -> - if Id.Set.mem x all_safe then orig - else (ctx, all_safe) - | LocalDef ({binder_name=x},bo, ty) as decl -> - if Id.Set.mem x all_safe then orig else - let vars = Id.Set.union (vars_of env bo) (vars_of env ty) in - if Id.Set.subset vars all_safe - then (decl :: ctx, Id.Set.add x all_safe) - else (ctx, all_safe) in - let ctx, _ = - Environ.fold_named_context aux env ~init:(ctx,ctx_set) in - if not (Option.is_empty ps.section_vars) then - CErrors.user_err Pp.(str "Used section variables can be declared only once"); - (* EJGA: This is always empty thus we should modify the type *) - (ctx, []), { ps with section_vars = Some (Context.Named.to_vars ctx) } - -let get_open_goals ps = - let Proof.{ goals; stack; shelf } = Proof.data ps.proof in - List.length goals + - List.fold_left (+) 0 - (List.map (fun (l1,l2) -> List.length l1 + List.length l2) stack) + - List.length shelf - -type closed_proof_output = (Constr.t * Evd.side_effects) list * UState.t - -let private_poly_univs = - let b = ref true in - let _ = Goptions.(declare_bool_option { - optdepr = false; - optkey = ["Private";"Polymorphic";"Universes"]; - optread = (fun () -> !b); - optwrite = ((:=) b); - }) - in - fun () -> !b - -let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now - (fpl : closed_proof_output Future.computation) ps = - let { section_vars; proof; udecl; initial_euctx } = ps in - let Proof.{ name; poly; entry } = Proof.data proof in - let opaque = match opaque with Opaque -> true | Transparent -> false in - let constrain_variables ctx = - UState.constrain_variables (fst (UState.context_set initial_euctx)) ctx - in - let fpl, univs = Future.split2 fpl in - let uctx = if poly || now then Future.force univs else initial_euctx in - (* Because of dependent subgoals at the beginning of proofs, we could - have existential variables in the initial types of goals, we need to - normalise them for the kernel. *) - let subst_evar k = - let { Proof.sigma } = Proof.data proof in - Evd.existential_opt_value0 sigma k in - let nf = UnivSubst.nf_evars_and_universes_opt_subst subst_evar - (UState.subst uctx) in - - let make_body = - if poly || now then - let make_body t (c, eff) = - let body = c in - let allow_deferred = - not poly && (keep_body_ucst_separate || - not (Safe_typing.empty_private_constants = eff.Evd.seff_private)) - in - let typ = if allow_deferred then t else nf t in - let used_univs_body = Vars.universes_of_constr body in - let used_univs_typ = Vars.universes_of_constr typ in - if allow_deferred then - let initunivs = UState.univ_entry ~poly initial_euctx in - let ctx = constrain_variables uctx in - (* For vi2vo compilation proofs are computed now but we need to - complement the univ constraints of the typ with the ones of - the body. So we keep the two sets distinct. *) - let used_univs = Univ.LSet.union used_univs_body used_univs_typ in - let ctx_body = UState.restrict ctx used_univs in - let univs = UState.check_mono_univ_decl ctx_body udecl in - (initunivs, typ), ((body, univs), eff) - else if poly && opaque && private_poly_univs () then - let used_univs = Univ.LSet.union used_univs_body used_univs_typ in - let universes = UState.restrict uctx used_univs in - let typus = UState.restrict universes used_univs_typ in - let udecl = UState.check_univ_decl ~poly typus udecl in - let ubody = Univ.ContextSet.diff - (UState.context_set universes) - (UState.context_set typus) - in - (udecl, typ), ((body, ubody), eff) - else - (* Since the proof is computed now, we can simply have 1 set of - constraints in which we merge the ones for the body and the ones - for the typ. We recheck the declaration after restricting with - the actually used universes. - TODO: check if restrict is really necessary now. *) - let used_univs = Univ.LSet.union used_univs_body used_univs_typ in - let ctx = UState.restrict uctx used_univs in - let univs = UState.check_univ_decl ~poly ctx udecl in - (univs, typ), ((body, Univ.ContextSet.empty), eff) - in - fun t p -> Future.split2 (Future.chain p (make_body t)) - else - fun t p -> - (* Already checked the univ_decl for the type universes when starting the proof. *) - let univctx = UState.univ_entry ~poly:false uctx in - let t = nf t in - Future.from_val (univctx, t), - Future.chain p (fun (pt,eff) -> - (* Deferred proof, we already checked the universe declaration with - the initial universes, ensure that the final universes respect - the declaration as well. If the declaration is non-extensible, - this will prevent the body from adding universes and constraints. *) - let univs = Future.force univs in - let univs = constrain_variables univs in - let used_univs = Univ.LSet.union - (Vars.universes_of_constr t) - (Vars.universes_of_constr pt) - in - let univs = UState.restrict univs used_univs in - let univs = UState.check_mono_univ_decl univs udecl in - (pt,univs),eff) - in - let entry_fn p (_, t) = - let t = EConstr.Unsafe.to_constr t in - let univstyp, body = make_body t p in - let univs, typ = Future.force univstyp in - Declare.delayed_definition_entry ~opaque ?feedback_id ?section_vars ~univs ~types:typ body - in - let entries = Future.map2 entry_fn fpl (Proofview.initial_goals entry) in - { name; entries; uctx; udecl } - -let return_proof ?(allow_partial=false) ps = - let { proof } = ps in - if allow_partial then begin - let proofs = Proof.partial_proof proof in - let Proof.{sigma=evd} = Proof.data proof in - let eff = Evd.eval_side_effects evd in - (* 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 proofs = List.map (fun c -> EConstr.Unsafe.to_constr c, eff) proofs in - proofs, Evd.evar_universe_context evd - end else - let Proof.{name=pid;entry} = Proof.data proof in - let initial_goals = Proofview.initial_goals entry in - let evd = Proof.return ~pid proof in - let eff = Evd.eval_side_effects evd in - let evd = Evd.minimize_universes evd in - 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 - (* 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... *) - (* EJGA: actually side-effects de-duplication and this codepath is - unrelated. Duplicated side-effects arise from incorrect scheme - generation code, the main bulk of it was mostly fixed by #9836 - but duplication can still happen because of rewriting schemes I - think; however the code below is mostly untested, the only - code-paths that generate several proof entries are derive and - equations and so far there is no code in the CI that will - actually call those and do a side-effect, TTBOMK *) - let proofs = - List.map (fun (c, _) -> (proof_opt c, eff)) initial_goals in - proofs, Evd.evar_universe_context evd - -let close_future_proof ~opaque ~feedback_id ps proof = - close_proof ~opaque ~keep_body_ucst_separate:true ~feedback_id ~now:false proof ps - -let close_proof ~opaque ~keep_body_ucst_separate fix_exn ps = - close_proof ~opaque ~keep_body_ucst_separate ~now:true - (Future.from_val ~fix_exn (return_proof ps)) ps - -let update_global_env = - map_proof (fun p -> - let { Proof.sigma } = Proof.data p in - let tac = Proofview.Unsafe.tclEVARS (Evd.update_sigma_env sigma (Global.env ())) in - let p, (status,info), _ = Proof.run_tactic (Global.env ()) tac p in - p) diff --git a/tactics/proof_global.mli b/tactics/proof_global.mli deleted file mode 100644 index e1c75c0649..0000000000 --- a/tactics/proof_global.mli +++ /dev/null @@ -1,99 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \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) *) -(************************************************************************) - -(** State for interactive proofs. *) - -type t - -(* Should be moved into a proper view *) -val get_proof : t -> Proof.t -val get_proof_name : t -> Names.Id.t -val get_used_variables : t -> Names.Id.Set.t option - -(** Get the universe declaration associated to the current proof. *) -val get_universe_decl : t -> UState.universe_decl - -(** Get initial universe state *) -val get_initial_euctx : t -> UState.t - -val compact_the_proof : t -> t - -(** When a proof is closed, it is reified into a [proof_object] *) -type proof_object = - { name : Names.Id.t - (** name of the proof *) - ; entries : Evd.side_effects Declare.proof_entry list - (** list of the proof terms (in a form suitable for definitions). *) - ; uctx: UState.t - (** universe state *) - ; udecl : UState.universe_decl - (** universe declaration *) - } - -type opacity_flag = Opaque | Transparent - -(** [start_proof ~name ~udecl ~poly sigma goals] starts a proof of - name [name] with goals [goals] (a list of pairs of environment and - conclusion); [poly] determines if the proof is universe - polymorphic. The proof is started in the evar map [sigma] (which - can typically contain universe constraints), and with universe - bindings [udecl]. *) -val start_proof - : name:Names.Id.t - -> udecl:UState.universe_decl - -> poly:bool - -> Evd.evar_map - -> (Environ.env * EConstr.types) list - -> t - -(** Like [start_proof] except that there may be dependencies between - initial goals. *) -val start_dependent_proof - : name:Names.Id.t - -> udecl:UState.universe_decl - -> poly:bool - -> Proofview.telescope - -> t - -(** Update the proofs global environment after a side-effecting command - (e.g. a sublemma definition) has been run inside it. Assumes - there_are_pending_proofs. *) -val update_global_env : t -> t - -(* Takes a function to add to the exceptions data relative to the - state in which the proof was built *) -val close_proof : opaque:opacity_flag -> keep_body_ucst_separate:bool -> Future.fix_exn -> t -> proof_object - -(* Intermediate step necessary to delegate the future. - * Both access the current proof state. The former is supposed to be - * chained with a computation that completed the proof *) - -type closed_proof_output - -(* If allow_partial is set (default no) then an incomplete proof - * is allowed (no error), and a warn is given if the proof is complete. *) -val return_proof : ?allow_partial:bool -> t -> closed_proof_output -val close_future_proof : opaque:opacity_flag -> feedback_id:Stateid.t -> t -> - closed_proof_output Future.computation -> proof_object - -val get_open_goals : t -> int - -val map_proof : (Proof.t -> Proof.t) -> t -> t -val map_fold_proof : (Proof.t -> Proof.t * 'a) -> t -> t * 'a -val map_fold_proof_endline : (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> t -> t * 'a - -(** Sets the tactic to be used when a tactic line is closed with [...] *) -val set_endline_tactic : Genarg.glob_generic_argument -> t -> t - -(** Sets the section variables assumed by the proof, returns its closure - * (w.r.t. type dependencies and let-ins covered by it) + a list of - * ids to be cleared *) -val set_used_variables : t -> - Names.Id.t list -> (Constr.named_context * Names.lident list) * t diff --git a/tactics/redexpr.ml b/tactics/redexpr.ml index 250c80d9a5..f681e4e99e 100644 --- a/tactics/redexpr.ml +++ b/tactics/redexpr.ml @@ -37,7 +37,7 @@ let warn_native_compute_disabled = strbrk "native_compute disabled at configure time; falling back to vm_compute.") let cbv_native env sigma c = - if Coq_config.native_compiler then + if Flags.get_native_compiler () then let ctyp = Retyping.get_type_of env sigma c in Nativenorm.native_norm env sigma c ctyp else @@ -53,13 +53,8 @@ let whd_cbn flags env sigma t = let strong_cbn flags = strong_with_flags whd_cbn flags -let simplIsCbn = ref (false) -let () = Goptions.(declare_bool_option { - optdepr = false; - optkey = ["SimplIsCbn"]; - optread = (fun () -> !simplIsCbn); - optwrite = (fun a -> simplIsCbn:=a); -}) +let simplIsCbn = + Goptions.declare_bool_option_and_ref ~depr:false ~key:["SimplIsCbn"] ~value:false let set_strategy_one ref l = let k = @@ -228,10 +223,10 @@ let reduction_of_red_expr env = else (e_red red_product,DEFAULTcast) | Hnf -> (e_red hnf_constr,DEFAULTcast) | Simpl (f,o) -> - let whd_am = if !simplIsCbn then whd_cbn (make_flag f) else whd_simpl in - let am = if !simplIsCbn then strong_cbn (make_flag f) else simpl in + let whd_am = if simplIsCbn () then whd_cbn (make_flag f) else whd_simpl in + let am = if simplIsCbn () then strong_cbn (make_flag f) else simpl in let () = - if not (!simplIsCbn || List.is_empty f.rConst) then + if not (simplIsCbn () || List.is_empty f.rConst) then warn_simpl_unfolding_modifiers () in (contextualize (if head_style then whd_am else am) am o,DEFAULTcast) | Cbv f -> (e_red (cbv_norm_flags (make_flag f)),DEFAULTcast) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 30ca024a2f..0df4f5b207 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1223,7 +1223,7 @@ let rec intros_move = function or a term with bindings *) let tactic_infer_flags with_evar = { - Pretyping.use_typeclasses = true; + Pretyping.use_typeclasses = Pretyping.UseTC; Pretyping.solve_unification_constraints = true; Pretyping.fail_evar = not with_evar; Pretyping.expand_evars = true; @@ -2763,8 +2763,8 @@ let pose_tac na c = let id = make_annot id Sorts.Relevant in let nhyps = EConstr.push_named_context_val (NamedDecl.LocalDef (id, c, t)) hyps in let (sigma, ev) = Evarutil.new_pure_evar nhyps sigma concl in - let inst = Array.map_of_list (fun d -> mkVar (get_id d)) (named_context env) in - let body = mkEvar (ev, Array.append [|mkRel 1|] inst) in + let inst = List.map (fun d -> mkVar (get_id d)) (named_context env) in + let body = mkEvar (ev, mkRel 1 :: inst) in (sigma, mkLetIn (map_annot Name.mk_name id, c, t, body)) end end @@ -4499,7 +4499,7 @@ let check_expected_type env sigma (elimc,bl) elimt = if n == 0 then error "Scheme cannot be applied."; let sigma,cl = make_evar_clause env sigma ~len:(n - 1) elimt in let sigma = solve_evar_clause env sigma true cl bl in - let (_,u,_) = destProd sigma cl.cl_concl in + let (_,u,_) = destProd sigma (whd_all env sigma cl.cl_concl) in fun t -> match Evarconv.unify_leq_delay env sigma t u with | _sigma -> true | exception Evarconv.UnableToUnify _ -> false diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib index 0c4e496650..36d61feed1 100644 --- a/tactics/tactics.mllib +++ b/tactics/tactics.mllib @@ -1,7 +1,4 @@ DeclareScheme -Declare -Proof_global -Pfedit Dnet Dn Btermdn @@ -20,7 +17,7 @@ Elim Equality Contradiction Inv -Leminv +DeclareUctx Hints Auto Eauto diff --git a/test-suite/Makefile b/test-suite/Makefile index 0d8a6ebed7..dece21885c 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -38,7 +38,8 @@ ROOT='$(shell cd ..; pwd)' ifneq ($(wildcard ../_build),) BIN:=$(ROOT)/_build/install/default/bin/ -COQLIB:=$(ROOT)/_build/install/default/lib/coq +# COQLIB is an env variable so no quotes +COQLIB:=$(shell cd ..; pwd)/_build/install/default/lib/coq else BIN := $(ROOT)/bin/ @@ -61,6 +62,10 @@ coqtopbyte := $(BIN)coqtop.byte -q coqc_interactive := $(coqc) -test-mode -async-proofs-cache force coqdep := $(BIN)coqdep +# This is the convention for coq_makefile +OPT=-$(BEST) +export OPT + VERBOSE?= SHOW := $(if $(VERBOSE),@true,@echo) HIDE := $(if $(VERBOSE),,@) @@ -353,8 +358,7 @@ $(addsuffix .log,$(wildcard ssr/*.v success/*.v micromega/*.v modules/*.v primit } > "$@" @if ! grep -q -F "Error!" $@; then echo "CHECK $<"; fi $(HIDE)if ! grep -q -F "Error!" $@; then { \ - opts="$(if $(findstring modules/,$<),-R modules Mods -norec Mods.$(shell basename $< .v),-I $(shell dirname $<) -norec $(shell basename $< .v))"; \ - $(coqchk) -silent $(call get_set_impredicativity,$<) $$opts 2>&1; R=$$?; \ + $(coqchk) -silent $(call get_set_impredicativity,$<) $(if $(findstring modules/,$<),-R modules Mods -norec Mods.$(shell basename $< .v),-Q $(shell dirname $<) "" -norec $(shell basename $< .v)) 2>&1; R=$$?; \ if [ $$R != 0 ]; then \ echo $(log_failure); \ echo " $<...could not be checked (Error!)" ; \ @@ -380,7 +384,7 @@ $(addsuffix .log,$(wildcard stm/*.v)): %.v.log: %.v } > "$@" @if ! grep -q -F "Error!" $@; then echo "CHECK $<"; fi $(HIDE)if ! grep -q -F "Error!" $@; then { \ - $(coqchk) -silent -I $(shell dirname $<) -norec $(shell basename $< .v) 2>&1; R=$$?; \ + $(coqchk) -silent -Q $(shell dirname $<) "" -norec $(shell basename $< .v) 2>&1; R=$$?; \ if [ $$R != 0 ]; then \ echo $(log_failure); \ echo " $<...could not be checked (Error!)" ; \ @@ -404,7 +408,7 @@ $(addsuffix .log,$(wildcard failure/*.v)): %.v.log: %.v $(PREREQUISITELOG) } > "$@" @if ! grep -q -F "Error!" $@; then echo "CHECK $<"; fi $(HIDE)if ! grep -q -F "Error!" $@; then { \ - $(coqchk) -silent -I $(shell dirname $<) -norec $(shell basename $< .v) 2>&1; R=$$?; \ + $(coqchk) -silent -Q $(shell dirname $<) "" -norec $(shell basename $< .v) 2>&1; R=$$?; \ if [ $$R != 0 ]; then \ echo $(log_failure); \ echo " $<...could not be checked (Error!)" ; \ diff --git a/test-suite/bugs/closed/HoTT_coq_107.v b/test-suite/bugs/closed/HoTT_coq_107.v index fa4072a8f6..91f5c423a5 100644 --- a/test-suite/bugs/closed/HoTT_coq_107.v +++ b/test-suite/bugs/closed/HoTT_coq_107.v @@ -2,6 +2,7 @@ (* File reduced by coq-bug-finder from 4897 lines to 2605 lines, then from 2297 lines to 236 lines, then from 239 lines to 137 lines, then from 118 lines to 67 lines, then from 520 lines to 76 lines. *) (** Note: The bug here is the same as the #113, that is, HoTT_coq_113.v *) Require Import Coq.Init.Logic. +Require Import Coq.Init.Ltac. Global Set Universe Polymorphism. Global Set Asymmetric Patterns. Set Implicit Arguments. diff --git a/test-suite/bugs/closed/bug_11585.v b/test-suite/bugs/closed/bug_11585.v new file mode 100644 index 0000000000..6294668323 --- /dev/null +++ b/test-suite/bugs/closed/bug_11585.v @@ -0,0 +1,3 @@ +Fail Inductive type {type : Type} : Type := T : type. + +Inductive type {type : Type} : Type := T . diff --git a/test-suite/bugs/closed/bug_11783.v b/test-suite/bugs/closed/bug_11783.v new file mode 100644 index 0000000000..a07391add5 --- /dev/null +++ b/test-suite/bugs/closed/bug_11783.v @@ -0,0 +1,5 @@ +Section S. + Variable A : Type. + Require Hurkens. + Definition foo := Hurkens.Generic.paradox A. +End S. diff --git a/test-suite/bugs/closed/bug_11935.v b/test-suite/bugs/closed/bug_11935.v new file mode 100644 index 0000000000..ad5ffc68b5 --- /dev/null +++ b/test-suite/bugs/closed/bug_11935.v @@ -0,0 +1,6 @@ +Section S. + Variable A : Prop. + + Fail Check A@{Type}. + Check A@{}. +End S. diff --git a/test-suite/bugs/closed/bug_11941.v b/test-suite/bugs/closed/bug_11941.v new file mode 100644 index 0000000000..87cb462991 --- /dev/null +++ b/test-suite/bugs/closed/bug_11941.v @@ -0,0 +1,5 @@ +Inductive Box A := box (_:A). +Inductive unit := tt. +Definition t := unit. +Record foo := { bar : Box t }. +Fail Scheme Equality for foo. diff --git a/test-suite/bugs/closed/bug_12045.v b/test-suite/bugs/closed/bug_12045.v new file mode 100644 index 0000000000..4e416778a9 --- /dev/null +++ b/test-suite/bugs/closed/bug_12045.v @@ -0,0 +1,19 @@ +(* Check enough reduction happens in the conclusion of an induction scheme *) + +Lemma foo : + forall (P : nat -> Prop), + (forall n, P (S n)) -> + forall n, + (fun e => + IsSucc e -> + P e) n. +Proof. +Admitted. + +Theorem bar : forall n, + IsSucc n -> + True. +Proof. + intros. + Fail induction n using foo. (* was an anomaly *) +Admitted. diff --git a/test-suite/bugs/closed/bug_1912.v b/test-suite/bugs/closed/bug_1912.v index 987a541778..0228abbb9b 100644 --- a/test-suite/bugs/closed/bug_1912.v +++ b/test-suite/bugs/closed/bug_1912.v @@ -1,4 +1,4 @@ -Require Import ZArith. +Require Import Omega. Goal forall x, Z.succ (Z.pred x) = x. intros x. diff --git a/test-suite/bugs/closed/bug_3881.v b/test-suite/bugs/closed/bug_3881.v index d7e097e326..50e9de60e5 100644 --- a/test-suite/bugs/closed/bug_3881.v +++ b/test-suite/bugs/closed/bug_3881.v @@ -4,6 +4,7 @@ coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (90ed6636dea41486ddf2cc0daead83f9f0788163) *) Generalizable All Variables. Require Import Coq.Init.Notations. +Require Import Coq.Init.Ltac. Reserved Notation "x -> y" (at level 99, right associativity, y at level 200). Notation "A -> B" := (forall (_ : A), B) : type_scope. Axiom admit : forall {T}, T. diff --git a/test-suite/bugs/closed/bug_4527.v b/test-suite/bugs/closed/bug_4527.v index dfb07520f1..cf802eb89b 100644 --- a/test-suite/bugs/closed/bug_4527.v +++ b/test-suite/bugs/closed/bug_4527.v @@ -5,7 +5,7 @@ then from 269 lines to 255 lines *) (* coqc version 8.5 (January 2016) compiled on Jan 23 2016 16:15:22 with OCaml 4.01.0 coqtop version 8.5 (January 2016) *) -Declare ML Module "ltac_plugin". +Require Import Coq.Init.Ltac. Inductive False := . Axiom proof_admitted : False. Tactic Notation "admit" := case proof_admitted. diff --git a/test-suite/bugs/closed/bug_4533.v b/test-suite/bugs/closed/bug_4533.v index d2f9fb9099..2d628f414d 100644 --- a/test-suite/bugs/closed/bug_4533.v +++ b/test-suite/bugs/closed/bug_4533.v @@ -5,7 +5,7 @@ then from 285 lines to 271 lines *) (* coqc version 8.5 (January 2016) compiled on Jan 23 2016 16:15:22 with OCaml 4.01.0 coqtop version 8.5 (January 2016) *) -Declare ML Module "ltac_plugin". +Require Import Coq.Init.Ltac. Inductive False := . Axiom proof_admitted : False. Tactic Notation "admit" := case proof_admitted. diff --git a/test-suite/bugs/closed/bug_4544.v b/test-suite/bugs/closed/bug_4544.v index 13c47edc8f..213c91bfa0 100644 --- a/test-suite/bugs/closed/bug_4544.v +++ b/test-suite/bugs/closed/bug_4544.v @@ -2,7 +2,7 @@ (* File reduced by coq-bug-finder from original input, then from 2553 lines to 1932 lines, then from 1946 lines to 1932 lines, then from 2467 lines to 1002 lines, then from 1016 lines to 1002 lines *) (* coqc version 8.5 (January 2016) compiled on Jan 23 2016 16:15:22 with OCaml 4.01.0 coqtop version 8.5 (January 2016) *) -Declare ML Module "ltac_plugin". +Require Import Coq.Init.Ltac. Inductive False := . Axiom proof_admitted : False. Tactic Notation "admit" := case proof_admitted. @@ -1003,7 +1003,8 @@ Proof. = loops_functor (group_loops_functor (pmap_compose psi phi)) g). rewrite <- p. - Fail Timeout 1 Time rewrite !loops_functor_group. + Timeout 1 Time rewrite !loops_functor_group. + Undo. (* 0.004 s in 8.5rc1, 8.677 s in 8.5 *) Timeout 1 do 3 rewrite loops_functor_group. Abort. diff --git a/test-suite/bugs/closed/bug_5233.v b/test-suite/bugs/closed/bug_5233.v index 06286c740d..63e33b63f7 100644 --- a/test-suite/bugs/closed/bug_5233.v +++ b/test-suite/bugs/closed/bug_5233.v @@ -1,2 +1,5 @@ (* Implicit arguments on type were missing for recursive records *) Inductive foo {A : Type} : Type := { Foo : foo }. + +(* Implicit arguments can be overidden *) +Inductive bar {A : Type} : Type := { Bar : @bar (A*A) }. diff --git a/test-suite/bugs/closed/bug_5359.v b/test-suite/bugs/closed/bug_5359.v index 1f202e4396..36f2ec5891 100644 --- a/test-suite/bugs/closed/bug_5359.v +++ b/test-suite/bugs/closed/bug_5359.v @@ -90,7 +90,7 @@ Goal False. (Ring_polynom.PEX Z 2))) (Ring_polynom.PEmul (Ring_polynom.PEX Z 3) (Ring_polynom.PEX Z 3)))) :: nil)%list ) in - Nsatz.nsatz_compute + NsatzTactic.nsatz_compute (@cons _ (@Ring_polynom.PEc _ sugar) (@cons _ (@Ring_polynom.PEc _ nparams) (@cons _ (@Ring_polynom.PEpow _ reified_goal power) reified_givens))). let sugar := constr:( 0%Z ) in @@ -214,6 +214,6 @@ Goal False. (Ring_polynom.PEX Z 2))) (Ring_polynom.PEmul (Ring_polynom.PEX Z 3) (Ring_polynom.PEX Z 3)))) :: nil)%list ) in - Nsatz.nsatz_compute + NsatzTactic.nsatz_compute (@cons _ (@Ring_polynom.PEc _ sugar) (@cons _ (@Ring_polynom.PEc _ nparams) (@cons _ (@Ring_polynom.PEpow _ reified_goal power) reified_givens))). Abort. diff --git a/test-suite/bugs/closed/bug_5445.v b/test-suite/bugs/closed/bug_5445.v new file mode 100644 index 0000000000..deaf174661 --- /dev/null +++ b/test-suite/bugs/closed/bug_5445.v @@ -0,0 +1,11 @@ +Require Import Coq.nsatz.NsatzTactic. +(** Ensure that loading the nsatz tactic doesn't load the reals *) +Fail Module M := Coq.Reals.Rdefinitions. +(** Ensure that loading the nsatz tactic doesn't load classic *) +Fail Check Coq.Logic.Classical_Prop.classic. +(** Ensure that this test-case hasn't messed up about the location of the reals / how to check for them *) +Require Coq.Reals.Rdefinitions. +Module M := Coq.Reals.Rdefinitions. +(** Ensure that this test-case hasn't messed up about the location of classic / how to check for it *) +Require Coq.Logic.Classical_Prop. +Check Coq.Logic.Classical_Prop.classic. diff --git a/test-suite/bugs/closed/bug_6661.v b/test-suite/bugs/closed/bug_6661.v index 28a9ffc7bd..0f4ae2b4c5 100644 --- a/test-suite/bugs/closed/bug_6661.v +++ b/test-suite/bugs/closed/bug_6661.v @@ -7,6 +7,7 @@ Require Export Coq.Init.Notations. +Require Export Coq.Init.Ltac. Notation "'∏' x .. y , P" := (forall x, .. (forall y, P) ..) (at level 200, x binder, y binder, right associativity) : type_scope. Notation "'λ' x .. y , t" := (fun x => .. (fun y => t) ..) diff --git a/test-suite/bugs/closed/bug_7812.v b/test-suite/bugs/closed/bug_7812.v new file mode 100644 index 0000000000..a714eea81d --- /dev/null +++ b/test-suite/bugs/closed/bug_7812.v @@ -0,0 +1,30 @@ +Module Foo. + Definition binary A := A -> A -> Prop. + + Definition inter A (R1 R2 : binary A): binary A := + fun (x y:A) => R1 x y /\ R2 x y. +End Foo. + +Module Simple_sparse_proof. + Parameter node : Type. + Parameter graph : Type. + Parameter has_edge : graph -> node -> node -> Prop. + Implicit Types x y z : node. + Implicit Types G : graph. + + Parameter mem : forall A, A -> list A -> Prop. + Hypothesis mem_nil : forall x, mem node x nil = False. + + Definition notin (l: list node): node -> node -> Prop := + fun x y => ~ mem node x l /\ ~ mem node y l. + + Definition edge_notin G l : node -> node -> Prop := + Foo.inter node (has_edge G) (notin l). + + Hint Unfold Foo.inter notin edge_notin : rel_crush. + + Lemma edge_notin_nil G : forall x y, edge_notin G nil x y <-> has_edge G x y. + Proof. + intros. autounfold with rel_crush. rewrite !mem_nil. tauto. + Qed. +End Simple_sparse_proof. diff --git a/test-suite/coq-makefile/native1/_CoqProject b/test-suite/coq-makefile/native1/_CoqProject index 3dfca7ffc0..85276fd9b9 100644 --- a/test-suite/coq-makefile/native1/_CoqProject +++ b/test-suite/coq-makefile/native1/_CoqProject @@ -1,6 +1,8 @@ -R src test -R theories test -I src +-arg -w +-arg +native-compiler-disabled -arg -native-compiler -arg yes diff --git a/test-suite/coq-makefile/native2/run.sh b/test-suite/coq-makefile/native2/run.sh index 857f70fdff..aaae81630f 100755 --- a/test-suite/coq-makefile/native2/run.sh +++ b/test-suite/coq-makefile/native2/run.sh @@ -7,7 +7,7 @@ if [[ $(which ocamlopt) && ! $NONATIVECOMP ]]; then coq_makefile -f _CoqProject -o Makefile cat Makefile.conf -COQEXTRAFLAGS="-native-compiler yes" make +COQEXTRAFLAGS="-w +native-compiler-disabled -native-compiler yes" make make html mlihtml make install DSTROOT="$PWD/tmp" #make debug diff --git a/test-suite/coq-makefile/timing/after/time-of-build-after.log.desired b/test-suite/coq-makefile/timing/after/time-of-build-after.log.desired index 7900c034da..ebe44f3548 100644 --- a/test-suite/coq-makefile/timing/after/time-of-build-after.log.desired +++ b/test-suite/coq-makefile/timing/after/time-of-build-after.log.desired @@ -1,15 +1,5 @@ -Makefile:69: warning: undefined variable '*' -Makefile:204: warning: undefined variable 'DSTROOT' COQDEP VFILES -Makefile:69: warning: undefined variable '*' -Makefile:204: warning: undefined variable 'DSTROOT' -Makefile:69: warning: undefined variable '*' -Makefile:204: warning: undefined variable 'DSTROOT' -Makefile:69: warning: undefined variable '*' -Makefile:204: warning: undefined variable 'DSTROOT' COQC Slow.v -Slow (real: 0.04, user: 0.02, sys: 0.01, mem: 45512 ko) +Slow.vo (real: 0.04, user: 0.02, sys: 0.01, mem: 45512 ko) COQC Fast.v -Fast (real: 0.41, user: 0.37, sys: 0.04, mem: 395200 ko) -Makefile:69: warning: undefined variable '*' -Makefile:204: warning: undefined variable 'DSTROOT' +Fast.vo (real: 0.41, user: 0.37, sys: 0.04, mem: 395200 ko) diff --git a/test-suite/coq-makefile/timing/after/time-of-build-before.log.desired b/test-suite/coq-makefile/timing/after/time-of-build-before.log.desired index 7ab0bc75d9..bf17a3e95c 100644 --- a/test-suite/coq-makefile/timing/after/time-of-build-before.log.desired +++ b/test-suite/coq-makefile/timing/after/time-of-build-before.log.desired @@ -1,15 +1,5 @@ -Makefile:69: warning: undefined variable '*' -Makefile:204: warning: undefined variable 'DSTROOT' COQDEP VFILES -Makefile:69: warning: undefined variable '*' -Makefile:204: warning: undefined variable 'DSTROOT' -Makefile:69: warning: undefined variable '*' -Makefile:204: warning: undefined variable 'DSTROOT' -Makefile:69: warning: undefined variable '*' -Makefile:204: warning: undefined variable 'DSTROOT' COQC Slow.v -Slow (real: 0.40, user: 0.35, sys: 0.04, mem: 394968 ko) +Slow.vo (real: 0.40, user: 0.35, sys: 0.04, mem: 394968 ko) COQC Fast.v -Fast (real: 0.04, user: 0.03, sys: 0.00, mem: 46564 ko) -Makefile:69: warning: undefined variable '*' -Makefile:204: warning: undefined variable 'DSTROOT' +Fast.vo (real: 0.04, user: 0.03, sys: 0.00, mem: 46564 ko) diff --git a/test-suite/coq-makefile/timing/after/time-of-build-both.log.desired b/test-suite/coq-makefile/timing/after/time-of-build-both.log.desired index 72c520218c..541b307b5e 100644 --- a/test-suite/coq-makefile/timing/after/time-of-build-both.log.desired +++ b/test-suite/coq-makefile/timing/after/time-of-build-both.log.desired @@ -1,6 +1,6 @@ -After | File Name | Before || Change | % Change --------------------------------------------------------- -0m00.34s | Total | 0m00.49s || -0m00.14s | -30.61% --------------------------------------------------------- -0m00.32s | Fast | 0m00.02s || +0m00.30s | +1500.00% -0m00.02s | Slow | 0m00.47s || -0m00.44s | -95.74%
\ No newline at end of file + After | Peak Mem | File Name | Before | Peak Mem || Change || Change (mem) | % Change | % Change (mem) +----------------------------------------------------------------------------------------------------------------------------- +0m00.47s | 394716 ko | Total Time / Peak Mem | 0m00.45s | 394392 ko || +0m00.01s || 324 ko | +4.44% | +0.08% +----------------------------------------------------------------------------------------------------------------------------- +0m00.42s | 394716 ko | Fast.vo | 0m00.02s | 57164 ko || +0m00.40s || 337552 ko | +1999.99% | +590.49% +0m00.05s | 57124 ko | Slow.vo | 0m00.43s | 394392 ko || -0m00.38s || -337268 ko | -88.37% | -85.51%
\ No newline at end of file diff --git a/test-suite/coq-makefile/timing/per-file-after/A.v.timing.diff.desired b/test-suite/coq-makefile/timing/per-file-after/A.v.timing.diff.desired index 74dad73332..71e4ee0b32 100644 --- a/test-suite/coq-makefile/timing/per-file-after/A.v.timing.diff.desired +++ b/test-suite/coq-makefile/timing/per-file-after/A.v.timing.diff.desired @@ -1,9 +1,9 @@ -After | Code | Before || Change | % Change + After | Code | Before || Change | % Change ---------------------------------------------------------------------------------------------------- -0m04.35s | Total | 0m00.58s || +0m03.77s | +649.05% + 0m14.06s | Total | 0m00.72s || +0m13.34s | +1854.02% ---------------------------------------------------------------------------------------------------- -0m03.87s | Chars 163 - 208 [Definition~foo1~:=~Eval~comp~i...] | 0m00.246s || +0m03.62s | +1473.17% -0m00.322s | Chars 069 - 162 [Definition~foo0~:=~Eval~comp~i...] | 0m00.189s || +0m00.13s | +70.37% -0m00.16s | Chars 000 - 026 [Require~Coq.ZArith.BinInt.] | 0m00.146s || +0m00.01s | +9.58% -0m00.s | Chars 027 - 068 [Declare~Reduction~comp~:=~nati...] | N/A || +0m00.00s | N/A - N/A | Chars 027 - 068 [Declare~Reduction~comp~:=~vm_c...] | 0m00.s || +0m00.00s | N/A
\ No newline at end of file +0m13.582s | Chars 163 - 208 [Definition~foo1~:=~Eval~comp~i...] | 0m00.353s || +0m13.22s | +3747.59% +0m00.335s | Chars 069 - 162 [Definition~foo0~:=~Eval~comp~i...] | 0m00.225s || +0m00.11s | +48.88% +0m00.152s | Chars 000 - 026 [Require~Coq.ZArith.BinInt.] | 0m00.142s || +0m00.01s | +7.04% + 0m00.s | Chars 027 - 068 [Declare~Reduction~comp~:=~nati...] | N/A || +0m00.00s | N/A + N/A | Chars 027 - 068 [Declare~Reduction~comp~:=~vm_c...] | 0m00.s || +0m00.00s | N/A
\ No newline at end of file diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/run.sh b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/run.sh index a6f35db17c..9078d21e3b 100755 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/run.sh +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/run.sh @@ -12,3 +12,13 @@ diff -u time-of-build-both-user.log.expected time-of-build-both-user.log || exit "$COQLIB"/tools/make-both-time-files.py --real time-of-build-after.log.in time-of-build-before.log.in time-of-build-both-real.log diff -u time-of-build-both-real.log.expected time-of-build-both-real.log || exit $? + +for sort_kind in auto absolute diff; do + "$COQLIB"/tools/make-both-time-files.py time-of-build-after.log.in time-of-build-before.log.in time-of-build-both-user-${sort_kind}.log --sort-by=${sort_kind} + + diff -u time-of-build-both-user-${sort_kind}.log.expected time-of-build-both-user-${sort_kind}.log || exit $? + + "$COQLIB"/tools/make-both-time-files.py --real time-of-build-after.log.in time-of-build-before.log.in time-of-build-both-real-${sort_kind}.log --sort-by=${sort_kind} + + diff -u time-of-build-both-real-${sort_kind}.log.expected time-of-build-both-real-${sort_kind}.log || exit $? +done diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-real-absolute.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-real-absolute.log.expected new file mode 100644 index 0000000000..e7d289858b --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-real-absolute.log.expected @@ -0,0 +1,26 @@ + After | Peak Mem | File Name | Before | Peak Mem || Change || Change (mem) | % Change | % Change (mem) +--------------------------------------------------------------------------------------------------------------------------------------------------------- +20m46.07s | 3302508 ko | Total Time / Peak Mem | 23m06.30s | 3307052 ko || -2m20.23s || -4544 ko | -10.11% | -0.13% +--------------------------------------------------------------------------------------------------------------------------------------------------------- + 4m16.77s | 1617000 ko | Specific/X25519/C64/ladderstep | 5m16.83s | 1621500 ko || -1m00.06s || -4500 ko | -18.95% | -0.27% + 3m22.96s | 3302508 ko | Specific/NISTP256/AMD64/femul | 3m37.80s | 3307052 ko || -0m14.84s || -4544 ko | -6.81% | -0.13% + 3m01.77s | 1589516 ko | Specific/solinas32_2e255m765_13limbs/femul | 3m27.94s | 1656912 ko || -0m26.16s || -67396 ko | -12.58% | -4.06% + 2m35.79s | 1454696 ko | Specific/solinas32_2e255m765_12limbs/femul | 2m59.21s | 1549104 ko || -0m23.42s || -94408 ko | -13.06% | -6.09% + 0m49.44s | 744240 ko | Specific/solinas32_2e255m765_13limbs/Synthesis | 0m49.50s | 744472 ko || -0m00.06s || -232 ko | -0.12% | -0.03% + 0m43.34s | 793376 ko | Specific/NISTP256/AMD64/fesub | 0m43.78s | 799668 ko || -0m00.43s || -6292 ko | -1.00% | -0.78% + 0m40.13s | 728464 ko | Specific/solinas32_2e255m765_12limbs/Synthesis | 0m39.53s | 729464 ko || +0m00.60s || -1000 ko | +1.51% | -0.13% + 0m39.72s | 825448 ko | Specific/X25519/C64/femul | 0m42.98s | 839624 ko || -0m03.25s || -14176 ko | -7.58% | -1.68% + 0m38.19s | 799216 ko | Specific/NISTP256/AMD64/feadd | 0m40.48s | 797944 ko || -0m02.28s || 1272 ko | -5.65% | +0.15% + 0m34.35s | 828104 ko | Specific/X25519/C64/freeze | 0m36.42s | 826476 ko || -0m02.07s || 1628 ko | -5.68% | +0.19% + 0m33.08s | 799620 ko | Specific/X25519/C64/fesquare | 0m35.23s | 802776 ko || -0m02.14s || -3156 ko | -6.10% | -0.39% + 0m31.00s | 765208 ko | Specific/NISTP256/AMD64/feopp | 0m32.08s | 765212 ko || -0m01.07s || -4 ko | -3.36% | -0.00% + 0m27.81s | 756080 ko | Specific/NISTP256/AMD64/fenz | 0m28.91s | 756216 ko || -0m01.10s || -136 ko | -3.80% | -0.01% + 0m27.11s | 786052 ko | Specific/X25519/C64/fecarry | 0m28.85s | 787148 ko || -0m01.74s || -1096 ko | -6.03% | -0.13% + 0m24.71s | 778792 ko | Specific/X25519/C64/fesub | 0m26.11s | 781808 ko || -0m01.39s || -3016 ko | -5.36% | -0.38% + 0m22.81s | 766300 ko | Specific/X25519/C64/feadd | 0m23.43s | 766168 ko || -0m00.62s || 132 ko | -2.64% | +0.01% + 0m13.45s | 668216 ko | Specific/NISTP256/AMD64/Synthesis | 0m13.74s | 667664 ko || -0m00.29s || 552 ko | -2.11% | +0.08% + 0m11.15s | 687760 ko | Specific/X25519/C64/Synthesis | 0m11.23s | 687812 ko || -0m00.08s || -52 ko | -0.71% | -0.00% + 0m07.33s | 574388 ko | Compilers/Z/Bounds/Pipeline/Definition | 0m07.40s | 578344 ko || -0m00.07s || -3956 ko | -0.94% | -0.68% + 0m01.93s | 544172 ko | Compilers/Z/Bounds/Pipeline/ReflectiveTactics | 0m01.73s | 546112 ko || +0m00.19s || -1940 ko | +11.56% | -0.35% + 0m01.85s | 646300 ko | Specific/Framework/SynthesisFramework | 0m01.95s | 648632 ko || -0m00.09s || -2332 ko | -5.12% | -0.35% + 0m01.38s | 539808 ko | Compilers/Z/Bounds/Pipeline | 0m01.18s | 539160 ko || +0m00.19s || 648 ko | +16.94% | +0.12%
\ No newline at end of file diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-real-auto.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-real-auto.log.expected new file mode 100644 index 0000000000..36f86e0e1e --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-real-auto.log.expected @@ -0,0 +1,26 @@ + After | Peak Mem | File Name | Before | Peak Mem || Change || Change (mem) | % Change | % Change (mem) +--------------------------------------------------------------------------------------------------------------------------------------------------------- +20m46.07s | 3302508 ko | Total Time / Peak Mem | 23m06.30s | 3307052 ko || -2m20.23s || -4544 ko | -10.11% | -0.13% +--------------------------------------------------------------------------------------------------------------------------------------------------------- + 4m16.77s | 1617000 ko | Specific/X25519/C64/ladderstep | 5m16.83s | 1621500 ko || -1m00.06s || -4500 ko | -18.95% | -0.27% + 3m01.77s | 1589516 ko | Specific/solinas32_2e255m765_13limbs/femul | 3m27.94s | 1656912 ko || -0m26.16s || -67396 ko | -12.58% | -4.06% + 2m35.79s | 1454696 ko | Specific/solinas32_2e255m765_12limbs/femul | 2m59.21s | 1549104 ko || -0m23.42s || -94408 ko | -13.06% | -6.09% + 3m22.96s | 3302508 ko | Specific/NISTP256/AMD64/femul | 3m37.80s | 3307052 ko || -0m14.84s || -4544 ko | -6.81% | -0.13% + 0m39.72s | 825448 ko | Specific/X25519/C64/femul | 0m42.98s | 839624 ko || -0m03.25s || -14176 ko | -7.58% | -1.68% + 0m38.19s | 799216 ko | Specific/NISTP256/AMD64/feadd | 0m40.48s | 797944 ko || -0m02.28s || 1272 ko | -5.65% | +0.15% + 0m34.35s | 828104 ko | Specific/X25519/C64/freeze | 0m36.42s | 826476 ko || -0m02.07s || 1628 ko | -5.68% | +0.19% + 0m33.08s | 799620 ko | Specific/X25519/C64/fesquare | 0m35.23s | 802776 ko || -0m02.14s || -3156 ko | -6.10% | -0.39% + 0m31.00s | 765208 ko | Specific/NISTP256/AMD64/feopp | 0m32.08s | 765212 ko || -0m01.07s || -4 ko | -3.36% | -0.00% + 0m27.81s | 756080 ko | Specific/NISTP256/AMD64/fenz | 0m28.91s | 756216 ko || -0m01.10s || -136 ko | -3.80% | -0.01% + 0m27.11s | 786052 ko | Specific/X25519/C64/fecarry | 0m28.85s | 787148 ko || -0m01.74s || -1096 ko | -6.03% | -0.13% + 0m24.71s | 778792 ko | Specific/X25519/C64/fesub | 0m26.11s | 781808 ko || -0m01.39s || -3016 ko | -5.36% | -0.38% + 0m49.44s | 744240 ko | Specific/solinas32_2e255m765_13limbs/Synthesis | 0m49.50s | 744472 ko || -0m00.06s || -232 ko | -0.12% | -0.03% + 0m43.34s | 793376 ko | Specific/NISTP256/AMD64/fesub | 0m43.78s | 799668 ko || -0m00.43s || -6292 ko | -1.00% | -0.78% + 0m40.13s | 728464 ko | Specific/solinas32_2e255m765_12limbs/Synthesis | 0m39.53s | 729464 ko || +0m00.60s || -1000 ko | +1.51% | -0.13% + 0m22.81s | 766300 ko | Specific/X25519/C64/feadd | 0m23.43s | 766168 ko || -0m00.62s || 132 ko | -2.64% | +0.01% + 0m13.45s | 668216 ko | Specific/NISTP256/AMD64/Synthesis | 0m13.74s | 667664 ko || -0m00.29s || 552 ko | -2.11% | +0.08% + 0m11.15s | 687760 ko | Specific/X25519/C64/Synthesis | 0m11.23s | 687812 ko || -0m00.08s || -52 ko | -0.71% | -0.00% + 0m07.33s | 574388 ko | Compilers/Z/Bounds/Pipeline/Definition | 0m07.40s | 578344 ko || -0m00.07s || -3956 ko | -0.94% | -0.68% + 0m01.93s | 544172 ko | Compilers/Z/Bounds/Pipeline/ReflectiveTactics | 0m01.73s | 546112 ko || +0m00.19s || -1940 ko | +11.56% | -0.35% + 0m01.85s | 646300 ko | Specific/Framework/SynthesisFramework | 0m01.95s | 648632 ko || -0m00.09s || -2332 ko | -5.12% | -0.35% + 0m01.38s | 539808 ko | Compilers/Z/Bounds/Pipeline | 0m01.18s | 539160 ko || +0m00.19s || 648 ko | +16.94% | +0.12%
\ No newline at end of file diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-real-diff.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-real-diff.log.expected new file mode 100644 index 0000000000..6415223693 --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-real-diff.log.expected @@ -0,0 +1,26 @@ + After | Peak Mem | File Name | Before | Peak Mem || Change || Change (mem) | % Change | % Change (mem) +--------------------------------------------------------------------------------------------------------------------------------------------------------- +20m46.07s | 3302508 ko | Total Time / Peak Mem | 23m06.30s | 3307052 ko || -2m20.23s || -4544 ko | -10.11% | -0.13% +--------------------------------------------------------------------------------------------------------------------------------------------------------- + 0m40.13s | 728464 ko | Specific/solinas32_2e255m765_12limbs/Synthesis | 0m39.53s | 729464 ko || +0m00.60s || -1000 ko | +1.51% | -0.13% + 0m01.38s | 539808 ko | Compilers/Z/Bounds/Pipeline | 0m01.18s | 539160 ko || +0m00.19s || 648 ko | +16.94% | +0.12% + 0m01.93s | 544172 ko | Compilers/Z/Bounds/Pipeline/ReflectiveTactics | 0m01.73s | 546112 ko || +0m00.19s || -1940 ko | +11.56% | -0.35% + 0m49.44s | 744240 ko | Specific/solinas32_2e255m765_13limbs/Synthesis | 0m49.50s | 744472 ko || -0m00.06s || -232 ko | -0.12% | -0.03% + 0m07.33s | 574388 ko | Compilers/Z/Bounds/Pipeline/Definition | 0m07.40s | 578344 ko || -0m00.07s || -3956 ko | -0.94% | -0.68% + 0m11.15s | 687760 ko | Specific/X25519/C64/Synthesis | 0m11.23s | 687812 ko || -0m00.08s || -52 ko | -0.71% | -0.00% + 0m01.85s | 646300 ko | Specific/Framework/SynthesisFramework | 0m01.95s | 648632 ko || -0m00.09s || -2332 ko | -5.12% | -0.35% + 0m13.45s | 668216 ko | Specific/NISTP256/AMD64/Synthesis | 0m13.74s | 667664 ko || -0m00.29s || 552 ko | -2.11% | +0.08% + 0m43.34s | 793376 ko | Specific/NISTP256/AMD64/fesub | 0m43.78s | 799668 ko || -0m00.43s || -6292 ko | -1.00% | -0.78% + 0m22.81s | 766300 ko | Specific/X25519/C64/feadd | 0m23.43s | 766168 ko || -0m00.62s || 132 ko | -2.64% | +0.01% + 0m31.00s | 765208 ko | Specific/NISTP256/AMD64/feopp | 0m32.08s | 765212 ko || -0m01.07s || -4 ko | -3.36% | -0.00% + 0m27.81s | 756080 ko | Specific/NISTP256/AMD64/fenz | 0m28.91s | 756216 ko || -0m01.10s || -136 ko | -3.80% | -0.01% + 0m24.71s | 778792 ko | Specific/X25519/C64/fesub | 0m26.11s | 781808 ko || -0m01.39s || -3016 ko | -5.36% | -0.38% + 0m27.11s | 786052 ko | Specific/X25519/C64/fecarry | 0m28.85s | 787148 ko || -0m01.74s || -1096 ko | -6.03% | -0.13% + 0m34.35s | 828104 ko | Specific/X25519/C64/freeze | 0m36.42s | 826476 ko || -0m02.07s || 1628 ko | -5.68% | +0.19% + 0m33.08s | 799620 ko | Specific/X25519/C64/fesquare | 0m35.23s | 802776 ko || -0m02.14s || -3156 ko | -6.10% | -0.39% + 0m38.19s | 799216 ko | Specific/NISTP256/AMD64/feadd | 0m40.48s | 797944 ko || -0m02.28s || 1272 ko | -5.65% | +0.15% + 0m39.72s | 825448 ko | Specific/X25519/C64/femul | 0m42.98s | 839624 ko || -0m03.25s || -14176 ko | -7.58% | -1.68% + 3m22.96s | 3302508 ko | Specific/NISTP256/AMD64/femul | 3m37.80s | 3307052 ko || -0m14.84s || -4544 ko | -6.81% | -0.13% + 2m35.79s | 1454696 ko | Specific/solinas32_2e255m765_12limbs/femul | 2m59.21s | 1549104 ko || -0m23.42s || -94408 ko | -13.06% | -6.09% + 3m01.77s | 1589516 ko | Specific/solinas32_2e255m765_13limbs/femul | 3m27.94s | 1656912 ko || -0m26.16s || -67396 ko | -12.58% | -4.06% + 4m16.77s | 1617000 ko | Specific/X25519/C64/ladderstep | 5m16.83s | 1621500 ko || -1m00.06s || -4500 ko | -18.95% | -0.27%
\ No newline at end of file diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-real.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-real.log.expected index ea600b000e..36f86e0e1e 100644 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-real.log.expected +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-real.log.expected @@ -1,26 +1,26 @@ -After | File Name | Before || Change | % Change ----------------------------------------------------------------------------------------------- -20m46.07s | Total | 23m06.30s || -2m20.23s | -10.11% ----------------------------------------------------------------------------------------------- -4m16.77s | Specific/X25519/C64/ladderstep | 5m16.83s || -1m00.06s | -18.95% -3m01.77s | Specific/solinas32_2e255m765_13limbs/femul | 3m27.94s || -0m26.16s | -12.58% -2m35.79s | Specific/solinas32_2e255m765_12limbs/femul | 2m59.21s || -0m23.42s | -13.06% -3m22.96s | Specific/NISTP256/AMD64/femul | 3m37.80s || -0m14.84s | -6.81% -0m39.72s | Specific/X25519/C64/femul | 0m42.98s || -0m03.25s | -7.58% -0m38.19s | Specific/NISTP256/AMD64/feadd | 0m40.48s || -0m02.28s | -5.65% -0m34.35s | Specific/X25519/C64/freeze | 0m36.42s || -0m02.07s | -5.68% -0m33.08s | Specific/X25519/C64/fesquare | 0m35.23s || -0m02.14s | -6.10% -0m31.00s | Specific/NISTP256/AMD64/feopp | 0m32.08s || -0m01.07s | -3.36% -0m27.81s | Specific/NISTP256/AMD64/fenz | 0m28.91s || -0m01.10s | -3.80% -0m27.11s | Specific/X25519/C64/fecarry | 0m28.85s || -0m01.74s | -6.03% -0m24.71s | Specific/X25519/C64/fesub | 0m26.11s || -0m01.39s | -5.36% -0m49.44s | Specific/solinas32_2e255m765_13limbs/Synthesis | 0m49.50s || -0m00.06s | -0.12% -0m43.34s | Specific/NISTP256/AMD64/fesub | 0m43.78s || -0m00.43s | -1.00% -0m40.13s | Specific/solinas32_2e255m765_12limbs/Synthesis | 0m39.53s || +0m00.60s | +1.51% -0m22.81s | Specific/X25519/C64/feadd | 0m23.43s || -0m00.62s | -2.64% -0m13.45s | Specific/NISTP256/AMD64/Synthesis | 0m13.74s || -0m00.29s | -2.11% -0m11.15s | Specific/X25519/C64/Synthesis | 0m11.23s || -0m00.08s | -0.71% -0m07.33s | Compilers/Z/Bounds/Pipeline/Definition | 0m07.40s || -0m00.07s | -0.94% -0m01.93s | Compilers/Z/Bounds/Pipeline/ReflectiveTactics | 0m01.73s || +0m00.19s | +11.56% -0m01.85s | Specific/Framework/SynthesisFramework | 0m01.95s || -0m00.09s | -5.12% -0m01.38s | Compilers/Z/Bounds/Pipeline | 0m01.18s || +0m00.19s | +16.94%
\ No newline at end of file + After | Peak Mem | File Name | Before | Peak Mem || Change || Change (mem) | % Change | % Change (mem) +--------------------------------------------------------------------------------------------------------------------------------------------------------- +20m46.07s | 3302508 ko | Total Time / Peak Mem | 23m06.30s | 3307052 ko || -2m20.23s || -4544 ko | -10.11% | -0.13% +--------------------------------------------------------------------------------------------------------------------------------------------------------- + 4m16.77s | 1617000 ko | Specific/X25519/C64/ladderstep | 5m16.83s | 1621500 ko || -1m00.06s || -4500 ko | -18.95% | -0.27% + 3m01.77s | 1589516 ko | Specific/solinas32_2e255m765_13limbs/femul | 3m27.94s | 1656912 ko || -0m26.16s || -67396 ko | -12.58% | -4.06% + 2m35.79s | 1454696 ko | Specific/solinas32_2e255m765_12limbs/femul | 2m59.21s | 1549104 ko || -0m23.42s || -94408 ko | -13.06% | -6.09% + 3m22.96s | 3302508 ko | Specific/NISTP256/AMD64/femul | 3m37.80s | 3307052 ko || -0m14.84s || -4544 ko | -6.81% | -0.13% + 0m39.72s | 825448 ko | Specific/X25519/C64/femul | 0m42.98s | 839624 ko || -0m03.25s || -14176 ko | -7.58% | -1.68% + 0m38.19s | 799216 ko | Specific/NISTP256/AMD64/feadd | 0m40.48s | 797944 ko || -0m02.28s || 1272 ko | -5.65% | +0.15% + 0m34.35s | 828104 ko | Specific/X25519/C64/freeze | 0m36.42s | 826476 ko || -0m02.07s || 1628 ko | -5.68% | +0.19% + 0m33.08s | 799620 ko | Specific/X25519/C64/fesquare | 0m35.23s | 802776 ko || -0m02.14s || -3156 ko | -6.10% | -0.39% + 0m31.00s | 765208 ko | Specific/NISTP256/AMD64/feopp | 0m32.08s | 765212 ko || -0m01.07s || -4 ko | -3.36% | -0.00% + 0m27.81s | 756080 ko | Specific/NISTP256/AMD64/fenz | 0m28.91s | 756216 ko || -0m01.10s || -136 ko | -3.80% | -0.01% + 0m27.11s | 786052 ko | Specific/X25519/C64/fecarry | 0m28.85s | 787148 ko || -0m01.74s || -1096 ko | -6.03% | -0.13% + 0m24.71s | 778792 ko | Specific/X25519/C64/fesub | 0m26.11s | 781808 ko || -0m01.39s || -3016 ko | -5.36% | -0.38% + 0m49.44s | 744240 ko | Specific/solinas32_2e255m765_13limbs/Synthesis | 0m49.50s | 744472 ko || -0m00.06s || -232 ko | -0.12% | -0.03% + 0m43.34s | 793376 ko | Specific/NISTP256/AMD64/fesub | 0m43.78s | 799668 ko || -0m00.43s || -6292 ko | -1.00% | -0.78% + 0m40.13s | 728464 ko | Specific/solinas32_2e255m765_12limbs/Synthesis | 0m39.53s | 729464 ko || +0m00.60s || -1000 ko | +1.51% | -0.13% + 0m22.81s | 766300 ko | Specific/X25519/C64/feadd | 0m23.43s | 766168 ko || -0m00.62s || 132 ko | -2.64% | +0.01% + 0m13.45s | 668216 ko | Specific/NISTP256/AMD64/Synthesis | 0m13.74s | 667664 ko || -0m00.29s || 552 ko | -2.11% | +0.08% + 0m11.15s | 687760 ko | Specific/X25519/C64/Synthesis | 0m11.23s | 687812 ko || -0m00.08s || -52 ko | -0.71% | -0.00% + 0m07.33s | 574388 ko | Compilers/Z/Bounds/Pipeline/Definition | 0m07.40s | 578344 ko || -0m00.07s || -3956 ko | -0.94% | -0.68% + 0m01.93s | 544172 ko | Compilers/Z/Bounds/Pipeline/ReflectiveTactics | 0m01.73s | 546112 ko || +0m00.19s || -1940 ko | +11.56% | -0.35% + 0m01.85s | 646300 ko | Specific/Framework/SynthesisFramework | 0m01.95s | 648632 ko || -0m00.09s || -2332 ko | -5.12% | -0.35% + 0m01.38s | 539808 ko | Compilers/Z/Bounds/Pipeline | 0m01.18s | 539160 ko || +0m00.19s || 648 ko | +16.94% | +0.12%
\ No newline at end of file diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-user-absolute.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-user-absolute.log.expected new file mode 100644 index 0000000000..84d20f484a --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-user-absolute.log.expected @@ -0,0 +1,26 @@ + After | Peak Mem | File Name | Before | Peak Mem || Change || Change (mem) | % Change | % Change (mem) +--------------------------------------------------------------------------------------------------------------------------------------------------------- +19m16.04s | 3302508 ko | Total Time / Peak Mem | 21m25.27s | 3307052 ko || -2m09.23s || -4544 ko | -10.05% | -0.13% +--------------------------------------------------------------------------------------------------------------------------------------------------------- + 4m01.34s | 1617000 ko | Specific/X25519/C64/ladderstep | 4m59.49s | 1621500 ko || -0m58.15s || -4500 ko | -19.41% | -0.27% + 3m09.62s | 3302508 ko | Specific/NISTP256/AMD64/femul | 3m22.52s | 3307052 ko || -0m12.90s || -4544 ko | -6.36% | -0.13% + 2m48.52s | 1589516 ko | Specific/solinas32_2e255m765_13limbs/femul | 3m12.95s | 1656912 ko || -0m24.42s || -67396 ko | -12.66% | -4.06% + 2m23.70s | 1454696 ko | Specific/solinas32_2e255m765_12limbs/femul | 2m44.11s | 1549104 ko || -0m20.41s || -94408 ko | -12.43% | -6.09% + 0m45.75s | 744240 ko | Specific/solinas32_2e255m765_13limbs/Synthesis | 0m45.58s | 744472 ko || +0m00.17s || -232 ko | +0.37% | -0.03% + 0m39.59s | 793376 ko | Specific/NISTP256/AMD64/fesub | 0m40.09s | 799668 ko || -0m00.50s || -6292 ko | -1.24% | -0.78% + 0m36.92s | 728464 ko | Specific/solinas32_2e255m765_12limbs/Synthesis | 0m36.64s | 729464 ko || +0m00.28s || -1000 ko | +0.76% | -0.13% + 0m36.32s | 825448 ko | Specific/X25519/C64/femul | 0m39.50s | 839624 ko || -0m03.17s || -14176 ko | -8.05% | -1.68% + 0m35.40s | 799216 ko | Specific/NISTP256/AMD64/feadd | 0m37.21s | 797944 ko || -0m01.81s || 1272 ko | -4.86% | +0.15% + 0m31.50s | 828104 ko | Specific/X25519/C64/freeze | 0m33.24s | 826476 ko || -0m01.74s || 1628 ko | -5.23% | +0.19% + 0m30.13s | 799620 ko | Specific/X25519/C64/fesquare | 0m32.24s | 802776 ko || -0m02.11s || -3156 ko | -6.54% | -0.39% + 0m28.51s | 765208 ko | Specific/NISTP256/AMD64/feopp | 0m29.46s | 765212 ko || -0m00.94s || -4 ko | -3.22% | -0.00% + 0m25.50s | 756080 ko | Specific/NISTP256/AMD64/fenz | 0m26.41s | 756216 ko || -0m00.91s || -136 ko | -3.44% | -0.01% + 0m24.99s | 786052 ko | Specific/X25519/C64/fecarry | 0m26.31s | 787148 ko || -0m01.32s || -1096 ko | -5.01% | -0.13% + 0m22.65s | 778792 ko | Specific/X25519/C64/fesub | 0m23.72s | 781808 ko || -0m01.07s || -3016 ko | -4.51% | -0.38% + 0m20.93s | 766300 ko | Specific/X25519/C64/feadd | 0m21.41s | 766168 ko || -0m00.48s || 132 ko | -2.24% | +0.01% + 0m12.55s | 668216 ko | Specific/NISTP256/AMD64/Synthesis | 0m12.54s | 667664 ko || +0m00.01s || 552 ko | +0.07% | +0.08% + 0m10.37s | 687760 ko | Specific/X25519/C64/Synthesis | 0m10.30s | 687812 ko || +0m00.06s || -52 ko | +0.67% | -0.00% + 0m07.18s | 574388 ko | Compilers/Z/Bounds/Pipeline/Definition | 0m07.22s | 578344 ko || -0m00.04s || -3956 ko | -0.55% | -0.68% + 0m01.72s | 544172 ko | Compilers/Z/Bounds/Pipeline/ReflectiveTactics | 0m01.58s | 546112 ko || +0m00.13s || -1940 ko | +8.86% | -0.35% + 0m01.67s | 646300 ko | Specific/Framework/SynthesisFramework | 0m01.72s | 648632 ko || -0m00.05s || -2332 ko | -2.90% | -0.35% + 0m01.19s | 539808 ko | Compilers/Z/Bounds/Pipeline | 0m01.04s | 539160 ko || +0m00.14s || 648 ko | +14.42% | +0.12%
\ No newline at end of file diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-user-auto.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-user-auto.log.expected new file mode 100644 index 0000000000..7576dca88b --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-user-auto.log.expected @@ -0,0 +1,26 @@ + After | Peak Mem | File Name | Before | Peak Mem || Change || Change (mem) | % Change | % Change (mem) +--------------------------------------------------------------------------------------------------------------------------------------------------------- +19m16.04s | 3302508 ko | Total Time / Peak Mem | 21m25.27s | 3307052 ko || -2m09.23s || -4544 ko | -10.05% | -0.13% +--------------------------------------------------------------------------------------------------------------------------------------------------------- + 4m01.34s | 1617000 ko | Specific/X25519/C64/ladderstep | 4m59.49s | 1621500 ko || -0m58.15s || -4500 ko | -19.41% | -0.27% + 2m48.52s | 1589516 ko | Specific/solinas32_2e255m765_13limbs/femul | 3m12.95s | 1656912 ko || -0m24.42s || -67396 ko | -12.66% | -4.06% + 2m23.70s | 1454696 ko | Specific/solinas32_2e255m765_12limbs/femul | 2m44.11s | 1549104 ko || -0m20.41s || -94408 ko | -12.43% | -6.09% + 3m09.62s | 3302508 ko | Specific/NISTP256/AMD64/femul | 3m22.52s | 3307052 ko || -0m12.90s || -4544 ko | -6.36% | -0.13% + 0m36.32s | 825448 ko | Specific/X25519/C64/femul | 0m39.50s | 839624 ko || -0m03.17s || -14176 ko | -8.05% | -1.68% + 0m30.13s | 799620 ko | Specific/X25519/C64/fesquare | 0m32.24s | 802776 ko || -0m02.11s || -3156 ko | -6.54% | -0.39% + 0m35.40s | 799216 ko | Specific/NISTP256/AMD64/feadd | 0m37.21s | 797944 ko || -0m01.81s || 1272 ko | -4.86% | +0.15% + 0m31.50s | 828104 ko | Specific/X25519/C64/freeze | 0m33.24s | 826476 ko || -0m01.74s || 1628 ko | -5.23% | +0.19% + 0m24.99s | 786052 ko | Specific/X25519/C64/fecarry | 0m26.31s | 787148 ko || -0m01.32s || -1096 ko | -5.01% | -0.13% + 0m22.65s | 778792 ko | Specific/X25519/C64/fesub | 0m23.72s | 781808 ko || -0m01.07s || -3016 ko | -4.51% | -0.38% + 0m45.75s | 744240 ko | Specific/solinas32_2e255m765_13limbs/Synthesis | 0m45.58s | 744472 ko || +0m00.17s || -232 ko | +0.37% | -0.03% + 0m39.59s | 793376 ko | Specific/NISTP256/AMD64/fesub | 0m40.09s | 799668 ko || -0m00.50s || -6292 ko | -1.24% | -0.78% + 0m36.92s | 728464 ko | Specific/solinas32_2e255m765_12limbs/Synthesis | 0m36.64s | 729464 ko || +0m00.28s || -1000 ko | +0.76% | -0.13% + 0m28.51s | 765208 ko | Specific/NISTP256/AMD64/feopp | 0m29.46s | 765212 ko || -0m00.94s || -4 ko | -3.22% | -0.00% + 0m25.50s | 756080 ko | Specific/NISTP256/AMD64/fenz | 0m26.41s | 756216 ko || -0m00.91s || -136 ko | -3.44% | -0.01% + 0m20.93s | 766300 ko | Specific/X25519/C64/feadd | 0m21.41s | 766168 ko || -0m00.48s || 132 ko | -2.24% | +0.01% + 0m12.55s | 668216 ko | Specific/NISTP256/AMD64/Synthesis | 0m12.54s | 667664 ko || +0m00.01s || 552 ko | +0.07% | +0.08% + 0m10.37s | 687760 ko | Specific/X25519/C64/Synthesis | 0m10.30s | 687812 ko || +0m00.06s || -52 ko | +0.67% | -0.00% + 0m07.18s | 574388 ko | Compilers/Z/Bounds/Pipeline/Definition | 0m07.22s | 578344 ko || -0m00.04s || -3956 ko | -0.55% | -0.68% + 0m01.72s | 544172 ko | Compilers/Z/Bounds/Pipeline/ReflectiveTactics | 0m01.58s | 546112 ko || +0m00.13s || -1940 ko | +8.86% | -0.35% + 0m01.67s | 646300 ko | Specific/Framework/SynthesisFramework | 0m01.72s | 648632 ko || -0m00.05s || -2332 ko | -2.90% | -0.35% + 0m01.19s | 539808 ko | Compilers/Z/Bounds/Pipeline | 0m01.04s | 539160 ko || +0m00.14s || 648 ko | +14.42% | +0.12%
\ No newline at end of file diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-user-diff.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-user-diff.log.expected new file mode 100644 index 0000000000..1173a6fe29 --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-user-diff.log.expected @@ -0,0 +1,26 @@ + After | Peak Mem | File Name | Before | Peak Mem || Change || Change (mem) | % Change | % Change (mem) +--------------------------------------------------------------------------------------------------------------------------------------------------------- +19m16.04s | 3302508 ko | Total Time / Peak Mem | 21m25.27s | 3307052 ko || -2m09.23s || -4544 ko | -10.05% | -0.13% +--------------------------------------------------------------------------------------------------------------------------------------------------------- + 0m36.92s | 728464 ko | Specific/solinas32_2e255m765_12limbs/Synthesis | 0m36.64s | 729464 ko || +0m00.28s || -1000 ko | +0.76% | -0.13% + 0m45.75s | 744240 ko | Specific/solinas32_2e255m765_13limbs/Synthesis | 0m45.58s | 744472 ko || +0m00.17s || -232 ko | +0.37% | -0.03% + 0m01.19s | 539808 ko | Compilers/Z/Bounds/Pipeline | 0m01.04s | 539160 ko || +0m00.14s || 648 ko | +14.42% | +0.12% + 0m01.72s | 544172 ko | Compilers/Z/Bounds/Pipeline/ReflectiveTactics | 0m01.58s | 546112 ko || +0m00.13s || -1940 ko | +8.86% | -0.35% + 0m10.37s | 687760 ko | Specific/X25519/C64/Synthesis | 0m10.30s | 687812 ko || +0m00.06s || -52 ko | +0.67% | -0.00% + 0m12.55s | 668216 ko | Specific/NISTP256/AMD64/Synthesis | 0m12.54s | 667664 ko || +0m00.01s || 552 ko | +0.07% | +0.08% + 0m07.18s | 574388 ko | Compilers/Z/Bounds/Pipeline/Definition | 0m07.22s | 578344 ko || -0m00.04s || -3956 ko | -0.55% | -0.68% + 0m01.67s | 646300 ko | Specific/Framework/SynthesisFramework | 0m01.72s | 648632 ko || -0m00.05s || -2332 ko | -2.90% | -0.35% + 0m20.93s | 766300 ko | Specific/X25519/C64/feadd | 0m21.41s | 766168 ko || -0m00.48s || 132 ko | -2.24% | +0.01% + 0m39.59s | 793376 ko | Specific/NISTP256/AMD64/fesub | 0m40.09s | 799668 ko || -0m00.50s || -6292 ko | -1.24% | -0.78% + 0m25.50s | 756080 ko | Specific/NISTP256/AMD64/fenz | 0m26.41s | 756216 ko || -0m00.91s || -136 ko | -3.44% | -0.01% + 0m28.51s | 765208 ko | Specific/NISTP256/AMD64/feopp | 0m29.46s | 765212 ko || -0m00.94s || -4 ko | -3.22% | -0.00% + 0m22.65s | 778792 ko | Specific/X25519/C64/fesub | 0m23.72s | 781808 ko || -0m01.07s || -3016 ko | -4.51% | -0.38% + 0m24.99s | 786052 ko | Specific/X25519/C64/fecarry | 0m26.31s | 787148 ko || -0m01.32s || -1096 ko | -5.01% | -0.13% + 0m31.50s | 828104 ko | Specific/X25519/C64/freeze | 0m33.24s | 826476 ko || -0m01.74s || 1628 ko | -5.23% | +0.19% + 0m35.40s | 799216 ko | Specific/NISTP256/AMD64/feadd | 0m37.21s | 797944 ko || -0m01.81s || 1272 ko | -4.86% | +0.15% + 0m30.13s | 799620 ko | Specific/X25519/C64/fesquare | 0m32.24s | 802776 ko || -0m02.11s || -3156 ko | -6.54% | -0.39% + 0m36.32s | 825448 ko | Specific/X25519/C64/femul | 0m39.50s | 839624 ko || -0m03.17s || -14176 ko | -8.05% | -1.68% + 3m09.62s | 3302508 ko | Specific/NISTP256/AMD64/femul | 3m22.52s | 3307052 ko || -0m12.90s || -4544 ko | -6.36% | -0.13% + 2m23.70s | 1454696 ko | Specific/solinas32_2e255m765_12limbs/femul | 2m44.11s | 1549104 ko || -0m20.41s || -94408 ko | -12.43% | -6.09% + 2m48.52s | 1589516 ko | Specific/solinas32_2e255m765_13limbs/femul | 3m12.95s | 1656912 ko || -0m24.42s || -67396 ko | -12.66% | -4.06% + 4m01.34s | 1617000 ko | Specific/X25519/C64/ladderstep | 4m59.49s | 1621500 ko || -0m58.15s || -4500 ko | -19.41% | -0.27%
\ No newline at end of file diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-user.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-user.log.expected index 159e645512..7576dca88b 100644 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-user.log.expected +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-user.log.expected @@ -1,26 +1,26 @@ -After | File Name | Before || Change | % Change ----------------------------------------------------------------------------------------------- -19m16.04s | Total | 21m25.27s || -2m09.23s | -10.05% ----------------------------------------------------------------------------------------------- -4m01.34s | Specific/X25519/C64/ladderstep | 4m59.49s || -0m58.15s | -19.41% -2m48.52s | Specific/solinas32_2e255m765_13limbs/femul | 3m12.95s || -0m24.42s | -12.66% -2m23.70s | Specific/solinas32_2e255m765_12limbs/femul | 2m44.11s || -0m20.41s | -12.43% -3m09.62s | Specific/NISTP256/AMD64/femul | 3m22.52s || -0m12.90s | -6.36% -0m36.32s | Specific/X25519/C64/femul | 0m39.50s || -0m03.17s | -8.05% -0m30.13s | Specific/X25519/C64/fesquare | 0m32.24s || -0m02.11s | -6.54% -0m35.40s | Specific/NISTP256/AMD64/feadd | 0m37.21s || -0m01.81s | -4.86% -0m31.50s | Specific/X25519/C64/freeze | 0m33.24s || -0m01.74s | -5.23% -0m24.99s | Specific/X25519/C64/fecarry | 0m26.31s || -0m01.32s | -5.01% -0m22.65s | Specific/X25519/C64/fesub | 0m23.72s || -0m01.07s | -4.51% -0m45.75s | Specific/solinas32_2e255m765_13limbs/Synthesis | 0m45.58s || +0m00.17s | +0.37% -0m39.59s | Specific/NISTP256/AMD64/fesub | 0m40.09s || -0m00.50s | -1.24% -0m36.92s | Specific/solinas32_2e255m765_12limbs/Synthesis | 0m36.64s || +0m00.28s | +0.76% -0m28.51s | Specific/NISTP256/AMD64/feopp | 0m29.46s || -0m00.94s | -3.22% -0m25.50s | Specific/NISTP256/AMD64/fenz | 0m26.41s || -0m00.91s | -3.44% -0m20.93s | Specific/X25519/C64/feadd | 0m21.41s || -0m00.48s | -2.24% -0m12.55s | Specific/NISTP256/AMD64/Synthesis | 0m12.54s || +0m00.01s | +0.07% -0m10.37s | Specific/X25519/C64/Synthesis | 0m10.30s || +0m00.06s | +0.67% -0m07.18s | Compilers/Z/Bounds/Pipeline/Definition | 0m07.22s || -0m00.04s | -0.55% -0m01.72s | Compilers/Z/Bounds/Pipeline/ReflectiveTactics | 0m01.58s || +0m00.13s | +8.86% -0m01.67s | Specific/Framework/SynthesisFramework | 0m01.72s || -0m00.05s | -2.90% -0m01.19s | Compilers/Z/Bounds/Pipeline | 0m01.04s || +0m00.14s | +14.42%
\ No newline at end of file + After | Peak Mem | File Name | Before | Peak Mem || Change || Change (mem) | % Change | % Change (mem) +--------------------------------------------------------------------------------------------------------------------------------------------------------- +19m16.04s | 3302508 ko | Total Time / Peak Mem | 21m25.27s | 3307052 ko || -2m09.23s || -4544 ko | -10.05% | -0.13% +--------------------------------------------------------------------------------------------------------------------------------------------------------- + 4m01.34s | 1617000 ko | Specific/X25519/C64/ladderstep | 4m59.49s | 1621500 ko || -0m58.15s || -4500 ko | -19.41% | -0.27% + 2m48.52s | 1589516 ko | Specific/solinas32_2e255m765_13limbs/femul | 3m12.95s | 1656912 ko || -0m24.42s || -67396 ko | -12.66% | -4.06% + 2m23.70s | 1454696 ko | Specific/solinas32_2e255m765_12limbs/femul | 2m44.11s | 1549104 ko || -0m20.41s || -94408 ko | -12.43% | -6.09% + 3m09.62s | 3302508 ko | Specific/NISTP256/AMD64/femul | 3m22.52s | 3307052 ko || -0m12.90s || -4544 ko | -6.36% | -0.13% + 0m36.32s | 825448 ko | Specific/X25519/C64/femul | 0m39.50s | 839624 ko || -0m03.17s || -14176 ko | -8.05% | -1.68% + 0m30.13s | 799620 ko | Specific/X25519/C64/fesquare | 0m32.24s | 802776 ko || -0m02.11s || -3156 ko | -6.54% | -0.39% + 0m35.40s | 799216 ko | Specific/NISTP256/AMD64/feadd | 0m37.21s | 797944 ko || -0m01.81s || 1272 ko | -4.86% | +0.15% + 0m31.50s | 828104 ko | Specific/X25519/C64/freeze | 0m33.24s | 826476 ko || -0m01.74s || 1628 ko | -5.23% | +0.19% + 0m24.99s | 786052 ko | Specific/X25519/C64/fecarry | 0m26.31s | 787148 ko || -0m01.32s || -1096 ko | -5.01% | -0.13% + 0m22.65s | 778792 ko | Specific/X25519/C64/fesub | 0m23.72s | 781808 ko || -0m01.07s || -3016 ko | -4.51% | -0.38% + 0m45.75s | 744240 ko | Specific/solinas32_2e255m765_13limbs/Synthesis | 0m45.58s | 744472 ko || +0m00.17s || -232 ko | +0.37% | -0.03% + 0m39.59s | 793376 ko | Specific/NISTP256/AMD64/fesub | 0m40.09s | 799668 ko || -0m00.50s || -6292 ko | -1.24% | -0.78% + 0m36.92s | 728464 ko | Specific/solinas32_2e255m765_12limbs/Synthesis | 0m36.64s | 729464 ko || +0m00.28s || -1000 ko | +0.76% | -0.13% + 0m28.51s | 765208 ko | Specific/NISTP256/AMD64/feopp | 0m29.46s | 765212 ko || -0m00.94s || -4 ko | -3.22% | -0.00% + 0m25.50s | 756080 ko | Specific/NISTP256/AMD64/fenz | 0m26.41s | 756216 ko || -0m00.91s || -136 ko | -3.44% | -0.01% + 0m20.93s | 766300 ko | Specific/X25519/C64/feadd | 0m21.41s | 766168 ko || -0m00.48s || 132 ko | -2.24% | +0.01% + 0m12.55s | 668216 ko | Specific/NISTP256/AMD64/Synthesis | 0m12.54s | 667664 ko || +0m00.01s || 552 ko | +0.07% | +0.08% + 0m10.37s | 687760 ko | Specific/X25519/C64/Synthesis | 0m10.30s | 687812 ko || +0m00.06s || -52 ko | +0.67% | -0.00% + 0m07.18s | 574388 ko | Compilers/Z/Bounds/Pipeline/Definition | 0m07.22s | 578344 ko || -0m00.04s || -3956 ko | -0.55% | -0.68% + 0m01.72s | 544172 ko | Compilers/Z/Bounds/Pipeline/ReflectiveTactics | 0m01.58s | 546112 ko || +0m00.13s || -1940 ko | +8.86% | -0.35% + 0m01.67s | 646300 ko | Specific/Framework/SynthesisFramework | 0m01.72s | 648632 ko || -0m00.05s || -2332 ko | -2.90% | -0.35% + 0m01.19s | 539808 ko | Compilers/Z/Bounds/Pipeline | 0m01.04s | 539160 ko || +0m00.14s || 648 ko | +14.42% | +0.12%
\ No newline at end of file diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/002-single-file-sorting/time-of-build-pretty-real.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/002-single-file-sorting/time-of-build-pretty-real.log.expected index b9739ddb1d..94122d8190 100644 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/002-single-file-sorting/time-of-build-pretty-real.log.expected +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/002-single-file-sorting/time-of-build-pretty-real.log.expected @@ -1,26 +1,26 @@ -Time | File Name ----------------------------------------------------------- -19m16.04s | Total ----------------------------------------------------------- -4m01.34s | Specific/X25519/C64/ladderstep -3m09.62s | Specific/NISTP256/AMD64/femul -2m48.52s | Specific/solinas32_2e255m765_13limbs/femul -2m23.70s | Specific/solinas32_2e255m765_12limbs/femul -0m45.75s | Specific/solinas32_2e255m765_13limbs/Synthesis -0m39.59s | Specific/NISTP256/AMD64/fesub -0m36.92s | Specific/solinas32_2e255m765_12limbs/Synthesis -0m36.32s | Specific/X25519/C64/femul -0m35.40s | Specific/NISTP256/AMD64/feadd -0m31.50s | Specific/X25519/C64/freeze -0m30.13s | Specific/X25519/C64/fesquare -0m28.51s | Specific/NISTP256/AMD64/feopp -0m25.50s | Specific/NISTP256/AMD64/fenz -0m24.99s | Specific/X25519/C64/fecarry -0m22.65s | Specific/X25519/C64/fesub -0m20.93s | Specific/X25519/C64/feadd -0m12.55s | Specific/NISTP256/AMD64/Synthesis -0m10.37s | Specific/X25519/C64/Synthesis -0m07.18s | Compilers/Z/Bounds/Pipeline/Definition -0m01.72s | Compilers/Z/Bounds/Pipeline/ReflectiveTactics -0m01.67s | Specific/Framework/SynthesisFramework -0m01.19s | Compilers/Z/Bounds/Pipeline
\ No newline at end of file + Time | Peak Mem | File Name +----------------------------------------------------------------------- +19m16.04s | 3302508 ko | Total Time / Peak Mem +----------------------------------------------------------------------- + 4m01.34s | 1617000 ko | Specific/X25519/C64/ladderstep + 3m09.62s | 3302508 ko | Specific/NISTP256/AMD64/femul + 2m48.52s | 1589516 ko | Specific/solinas32_2e255m765_13limbs/femul + 2m23.70s | 1454696 ko | Specific/solinas32_2e255m765_12limbs/femul + 0m45.75s | 744240 ko | Specific/solinas32_2e255m765_13limbs/Synthesis + 0m39.59s | 793376 ko | Specific/NISTP256/AMD64/fesub + 0m36.92s | 728464 ko | Specific/solinas32_2e255m765_12limbs/Synthesis + 0m36.32s | 825448 ko | Specific/X25519/C64/femul + 0m35.40s | 799216 ko | Specific/NISTP256/AMD64/feadd + 0m31.50s | 828104 ko | Specific/X25519/C64/freeze + 0m30.13s | 799620 ko | Specific/X25519/C64/fesquare + 0m28.51s | 765208 ko | Specific/NISTP256/AMD64/feopp + 0m25.50s | 756080 ko | Specific/NISTP256/AMD64/fenz + 0m24.99s | 786052 ko | Specific/X25519/C64/fecarry + 0m22.65s | 778792 ko | Specific/X25519/C64/fesub + 0m20.93s | 766300 ko | Specific/X25519/C64/feadd + 0m12.55s | 668216 ko | Specific/NISTP256/AMD64/Synthesis + 0m10.37s | 687760 ko | Specific/X25519/C64/Synthesis + 0m07.18s | 574388 ko | Compilers/Z/Bounds/Pipeline/Definition + 0m01.72s | 544172 ko | Compilers/Z/Bounds/Pipeline/ReflectiveTactics + 0m01.67s | 646300 ko | Specific/Framework/SynthesisFramework + 0m01.19s | 539808 ko | Compilers/Z/Bounds/Pipeline
\ No newline at end of file diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/002-single-file-sorting/time-of-build-pretty-user.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/002-single-file-sorting/time-of-build-pretty-user.log.expected index b9739ddb1d..94122d8190 100644 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/002-single-file-sorting/time-of-build-pretty-user.log.expected +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/002-single-file-sorting/time-of-build-pretty-user.log.expected @@ -1,26 +1,26 @@ -Time | File Name ----------------------------------------------------------- -19m16.04s | Total ----------------------------------------------------------- -4m01.34s | Specific/X25519/C64/ladderstep -3m09.62s | Specific/NISTP256/AMD64/femul -2m48.52s | Specific/solinas32_2e255m765_13limbs/femul -2m23.70s | Specific/solinas32_2e255m765_12limbs/femul -0m45.75s | Specific/solinas32_2e255m765_13limbs/Synthesis -0m39.59s | Specific/NISTP256/AMD64/fesub -0m36.92s | Specific/solinas32_2e255m765_12limbs/Synthesis -0m36.32s | Specific/X25519/C64/femul -0m35.40s | Specific/NISTP256/AMD64/feadd -0m31.50s | Specific/X25519/C64/freeze -0m30.13s | Specific/X25519/C64/fesquare -0m28.51s | Specific/NISTP256/AMD64/feopp -0m25.50s | Specific/NISTP256/AMD64/fenz -0m24.99s | Specific/X25519/C64/fecarry -0m22.65s | Specific/X25519/C64/fesub -0m20.93s | Specific/X25519/C64/feadd -0m12.55s | Specific/NISTP256/AMD64/Synthesis -0m10.37s | Specific/X25519/C64/Synthesis -0m07.18s | Compilers/Z/Bounds/Pipeline/Definition -0m01.72s | Compilers/Z/Bounds/Pipeline/ReflectiveTactics -0m01.67s | Specific/Framework/SynthesisFramework -0m01.19s | Compilers/Z/Bounds/Pipeline
\ No newline at end of file + Time | Peak Mem | File Name +----------------------------------------------------------------------- +19m16.04s | 3302508 ko | Total Time / Peak Mem +----------------------------------------------------------------------- + 4m01.34s | 1617000 ko | Specific/X25519/C64/ladderstep + 3m09.62s | 3302508 ko | Specific/NISTP256/AMD64/femul + 2m48.52s | 1589516 ko | Specific/solinas32_2e255m765_13limbs/femul + 2m23.70s | 1454696 ko | Specific/solinas32_2e255m765_12limbs/femul + 0m45.75s | 744240 ko | Specific/solinas32_2e255m765_13limbs/Synthesis + 0m39.59s | 793376 ko | Specific/NISTP256/AMD64/fesub + 0m36.92s | 728464 ko | Specific/solinas32_2e255m765_12limbs/Synthesis + 0m36.32s | 825448 ko | Specific/X25519/C64/femul + 0m35.40s | 799216 ko | Specific/NISTP256/AMD64/feadd + 0m31.50s | 828104 ko | Specific/X25519/C64/freeze + 0m30.13s | 799620 ko | Specific/X25519/C64/fesquare + 0m28.51s | 765208 ko | Specific/NISTP256/AMD64/feopp + 0m25.50s | 756080 ko | Specific/NISTP256/AMD64/fenz + 0m24.99s | 786052 ko | Specific/X25519/C64/fecarry + 0m22.65s | 778792 ko | Specific/X25519/C64/fesub + 0m20.93s | 766300 ko | Specific/X25519/C64/feadd + 0m12.55s | 668216 ko | Specific/NISTP256/AMD64/Synthesis + 0m10.37s | 687760 ko | Specific/X25519/C64/Synthesis + 0m07.18s | 574388 ko | Compilers/Z/Bounds/Pipeline/Definition + 0m01.72s | 544172 ko | Compilers/Z/Bounds/Pipeline/ReflectiveTactics + 0m01.67s | 646300 ko | Specific/Framework/SynthesisFramework + 0m01.19s | 539808 ko | Compilers/Z/Bounds/Pipeline
\ No newline at end of file diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/time-of-build-pretty.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/time-of-build-pretty.log.expected index 05c1687002..6104c78380 100644 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/time-of-build-pretty.log.expected +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/time-of-build-pretty.log.expected @@ -1,307 +1,307 @@ -Time | File Name ------------------------------------------------------------------------ -39m02.51s | Total ------------------------------------------------------------------------ -3m26.96s | Kami/Ex/Multiplier64 -3m22.44s | bedrock2/compiler/src/FlatToRiscv -2m19.56s | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeI -2m11.59s | Kami/Ex/Divider64 -1m44.22s | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeCSR -1m44.11s | Kami/Ex/Multiplier32 -1m41.50s | bedrock2/bedrock2/src/Examples/bsearch -1m08.57s | Kami/Ex/ProcFDInl -1m07.92s | bedrock2/deps/riscv-coq/src/Platform/MinimalMMIO -1m01.07s | Kami/Ex/FifoCorrect -1m00.73s | Kami/Ex/Divider32 -0m50.15s | bedrock2/deps/riscv-coq/src/Proofs/EncodeBound -0m40.64s | bedrock2/bedrock2/src/Examples/FE310CompilerDemo -0m40.29s | Kami/InlineFacts -0m39.12s | Kami/Renaming -0m37.44s | Kami/Ex/SimpleFifoCorrect -0m37.08s | Kami/SemFacts -0m36.08s | ─preprbedrock2/deps/coqutil/src/Map/TestGoals -0m32.76s | Kami/ModularFacts -0m28.68s | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeA -0m26.60s | Kami/Lib/Word -0m26.55s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_SB -0m26.45s | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeA64 -0m25.80s | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeI64 -0m25.47s | bedrock2/processor/src/KamiRiscv -0m23.66s | bedrock2/compiler/src/EmitsValid -0m22.68s | Kami/Ex/InDepthTutorial -0m22.60s | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeM -0m21.68s | Kami/Specialize -0m21.59s | bedrock2/bedrock2/src/Examples/lightbulb -0m19.20s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I_shift_66 -0m19.19s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_UJ -0m17.33s | Kami/Ex/ProcDecInl -0m15.63s | bedrock2/compiler/src/examples/MMIO -0m14.78s | Kami/ParametricSyntax -0m12.11s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_S -0m11.74s | bedrock2/deps/riscv-coq/src/Platform/MetricMinimal -0m09.95s | bedrock2/deps/coqutil/src/Word/Properties -0m09.77s | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeM64 -0m09.56s | Kami/Lib/FMap -0m09.35s | bedrock2/bedrock2/src/Examples/ipow -0m09.26s | Kami/StepDet -0m09.19s | bedrock2/bedrock2/src/WeakestPreconditionProperties -0m09.16s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_Fence -0m08.98s | Kami/RefinementFacts -0m08.68s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_R_atomic -0m08.26s | bedrock2/compiler/src/FlatToRiscv32 -0m07.55s | Kami/Ex/Fifo -0m07.54s | ─ensbedrock2/deps/coqutil/src/Map/SlowGoals -0m06.99s | bedrock2/deps/riscv-coq/src/Platform/Minimal -0m06.89s | bedrock2/compiler/src/GoFlatToRiscv -0m06.82s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I -0m06.72s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_FenceI -0m06.50s | Kami/Semantics -0m06.36s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I_shift_57 -0m06.32s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_R -0m06.24s | Kami/PartialInlineFacts -0m06.02s | bedrock2/deps/coqutil/src/Map/Properties -0m05.62s | Kami/Ex/ProcThreeStage -0m05.56s | Kami/Decomposition -0m05.12s | Kami/Amortization -0m05.07s | Kami/Ex/SCMMInl -0m04.71s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I_system -0m04.46s | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_U -0m04.19s | Kami/ParametricInline -0m04.13s | Kami/Ex/ProcDec -0m03.88s | bedrock2/bedrock2/src/Examples/swap -0m03.81s | Kami/Ex/SC -0m03.64s | bedrock2/bedrock2/src/FE310CSemantics -0m03.39s | Kami/Tutorial -0m03.30s | bedrock2/compiler/src/examples/Fibonacci -0m03.17s | Kami/Label -0m03.17s | Kami/ModuleBoundEx -0m03.10s | Kami/ParametricEquiv -0m03.06s | Kami/Wf -0m02.50s | bedrock2/compiler/src/Pipeline -0m02.42s | Kami/Ex/ProcFDInv -0m02.42s | Kami/ParamDup -0m02.39s | Kami/Duplicate -0m02.19s | Kami/ParametricWf -0m02.11s | Kami/Ex/ProcFetchDecode -0m02.06s | bedrock2/bedrock2/src/Examples/ARPResponder -0m01.94s | Kami/MapReifyEx -0m01.89s | Kami/Syntax -0m01.88s | Kami/Ex/IsaRv32/PgmGcd -0m01.87s | Kami/Ex/IsaRv32/PgmBankerWorker1 -0m01.87s | Kami/Ex/IsaRv32/PgmMatMulReport -0m01.85s | Kami/Ex/IsaRv32/PgmBankerWorker3 -0m01.83s | Kami/Ex/IsaRv32/PgmDekker2 -0m01.83s | Kami/Ex/IsaRv32/PgmFact -0m01.83s | Kami/Ex/IsaRv32/PgmMatMulNormal1 -0m01.81s | Kami/Ex/IsaRv32/PgmBankerInit -0m01.81s | Kami/Ex/IsaRv32/PgmMatMulInit -0m01.81s | Kami/Ex/IsaRv32/PgmMatMulNormal2 -0m01.81s | Kami/Ex/RegFile -0m01.80s | Kami/Ex/IsaRv32/PgmBankerWorker2 -0m01.80s | Kami/Ex/IsaRv32/PgmPeterson1 -0m01.80s | Kami/Ex/IsaRv32/PgmPeterson2 -0m01.80s | bedrock2/bedrock2/src/ptsto_bytes -0m01.78s | Kami/Ex/IsaRv32/PgmDekker1 -0m01.78s | Kami/Ex/ProcDecInv -0m01.76s | bedrock2/bedrock2/src/Map/SeparationLogic -0m01.75s | Kami/Ex/IsaRv32/PgmBsort -0m01.74s | Kami/Ex/IsaRv32/PgmHanoi -0m01.70s | Kami/Ex/NativeFifo -0m01.52s | Kami/Lib/NatLib -0m01.51s | bedrock2/processor/src/Test -0m01.48s | Kami/SymEval -0m01.47s | Kami/Ex/MemAtomic -0m01.44s | Kami/Ex/ProcThreeStInv -0m01.35s | bedrock2/bedrock2/src/Array -0m01.34s | bedrock2/bedrock2/src/TailRecursion -0m01.30s | Kami/Ex/IsaRv32 -0m01.29s | Kami/ModuleBound -0m01.29s | bedrock2/bedrock2/src/Byte -0m01.25s | bedrock2/bedrock2/src/Examples/chacha20 -0m01.19s | Kami/Ex/ProcThreeStDec -0m01.18s | bedrock2/bedrock2/src/Scalars -0m01.17s | bedrock2/deps/riscv-coq/src/Utility/ListLib -0m01.15s | Kami/Ex/OneEltFifo -0m01.14s | bedrock2/bedrock2/src/Examples/Trace -0m01.13s | bedrock2/bedrock2/src/TODO_absint -0m01.10s | bedrock2/compiler/lib/LibTactics -0m01.08s | Kami/Lib/StringAsList -0m01.00s | bedrock2/deps/coqutil/src/Z/ZLib -0m00.99s | Kami/Lib/Struct -0m00.98s | bedrock2/compiler/src/examples/toposort -0m00.95s | bedrock2/deps/riscv-coq/src/Utility/prove_Zeq_bitwise -0m00.94s | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeProver -0m00.94s | bedrock2/deps/riscv-coq/src/Spec/ExecuteI -0m00.93s | Kami/Ex/ProcDecSC -0m00.92s | Kami/Ex/IsaRv32PgmExt -0m00.90s | Kami/Lib/Indexer -0m00.89s | Kami/Tactics -0m00.88s | bedrock2/compiler/src/util/ListLib -0m00.87s | Kami/Notations -0m00.84s | bedrock2/bedrock2/src/Memory -0m00.83s | Kami/Ex/ProcFDCorrect -0m00.83s | bedrock2/deps/riscv-coq/src/Utility/ZBitOps -0m00.82s | Kami/Ex/IsaRv32Pgm -0m00.82s | Kami/Lib/ilist -0m00.81s | Kami/Ex/ProcDecSCN -0m00.81s | bedrock2/deps/coqutil/src/Z/BitOps -0m00.80s | Kami/Ex/ProcFourStDec -0m00.80s | bedrock2/compiler/src/examples/EditDistExample -0m00.79s | Kami/Ext/BSyntax -0m00.79s | Kami/Ext/Extraction -0m00.77s | Kami/ParametricInlineLtac -0m00.76s | bedrock2/deps/riscv-coq/src/Platform/Example64Literal -0m00.76s | bedrock2/deps/riscv-coq/src/Spec/MetricPrimitives -0m00.75s | Kami/Ex/ProcThreeStInl -0m00.74s | Kami/Kami -0m00.74s | bedrock2/compiler/src/examples/CompileExamples -0m00.74s | bedrock2/compiler/src/examples/swap_bytes_over_uart_hexdump -0m00.74s | bedrock2/deps/riscv-coq/src/Platform/MinimalLogging -0m00.72s | Kami/Substitute -0m00.72s | bedrock2/compiler/src/examples/TestExprImp -0m00.72s | bedrock2/deps/riscv-coq/src/Spec/Primitives -0m00.71s | Kami/Ex/MemTypes -0m00.71s | bedrock2/compiler/src/examples/InlineAssemblyMacro -0m00.71s | bedrock2/compiler/src/examples/TestFlatImp -0m00.71s | bedrock2/deps/riscv-coq/src/Platform/Memory -0m00.71s | bedrock2/deps/riscv-coq/src/Spec/Decode -0m00.70s | Kami/Inline -0m00.70s | Kami/Lib/StringAsOT -0m00.69s | bedrock2/compiler/src/FlatToRiscvDef -0m00.68s | bedrock2/compiler/src/Rem4 -0m00.67s | Kami/SymEvalTac -0m00.67s | bedrock2/compiler/src/SimplWordExpr -0m00.67s | bedrock2/deps/riscv-coq/src/Utility/Encode -0m00.66s | bedrock2/bedrock2/src/Semantics -0m00.63s | Kami/Lib/StringStringAsOT -0m00.63s | bedrock2/deps/coqutil/src/Datatypes/PropSet -0m00.61s | bedrock2/compiler/src/UnmappedMemForExtSpec -0m00.61s | bedrock2/deps/riscv-coq/src/Utility/Monads -0m00.60s | bedrock2/deps/coqutil/src/Map/SortedList -0m00.59s | Kami/Synthesize -0m00.59s | bedrock2/compiler/src/util/Common -0m00.59s | bedrock2/deps/coqutil/src/Map/SortedListWord -0m00.58s | bedrock2/deps/coqutil/src/Word/Naive -0m00.58s | bedrock2/deps/riscv-coq/src/Utility/runsToNonDet_Run -0m00.57s | bedrock2/bedrock2/src/BasicC64Semantics -0m00.57s | bedrock2/deps/riscv-coq/src/Utility/Utility -0m00.56s | Kami/Lib/WordSupport -0m00.56s | bedrock2/bedrock2/src/WeakestPrecondition -0m00.55s | Kami/Lib/StringEq -0m00.55s | bedrock2/bedrock2/src/BasicC32Semantics -0m00.55s | bedrock2/compiler/src/examples/highlevel/FuncMut -0m00.55s | bedrock2/deps/riscv-coq/src/Spec/ExecuteI64 -0m00.55s | bedrock2/deps/riscv-coq/src/Utility/DefaultMemImpl32 -0m00.54s | bedrock2/bedrock2/src/Examples/MultipleReturnValues -0m00.53s | bedrock2/compiler/src/RegAlloc2 -0m00.53s | bedrock2/deps/riscv-coq/src/Spec/ExecuteM -0m00.52s | bedrock2/bedrock2/src/ProgramLogic -0m00.52s | bedrock2/deps/riscv-coq/src/Platform/Run -0m00.52s | bedrock2/deps/riscv-coq/src/Spec/ExecuteM64 -0m00.52s | bedrock2/deps/riscv-coq/src/Utility/DefaultMemImpl64 -0m00.52s | bedrock2/deps/riscv-coq/src/Utility/Words32Naive -0m00.50s | bedrock2/bedrock2/src/BasicCSyntax -0m00.50s | bedrock2/compiler/src/Basic32Semantics -0m00.50s | bedrock2/compiler/src/RegAlloc3 -0m00.49s | bedrock2/bedrock2/src/BytedumpTest -0m00.49s | bedrock2/bedrock2/src/BytedumpTestα -0m00.49s | bedrock2/deps/coqutil/src/Map/Z_keyed_SortedListMap -0m00.49s | bedrock2/deps/riscv-coq/src/Spec/Machine -0m00.49s | bedrock2/deps/riscv-coq/src/Utility/MkMachineWidth -0m00.49s | bedrock2/deps/riscv-coq/src/Utility/Words64Naive -0m00.48s | bedrock2/bedrock2/src/ToCString -0m00.48s | bedrock2/compiler/src/SeparationLogic -0m00.48s | bedrock2/deps/coqutil/src/Decidable -0m00.48s | bedrock2/deps/riscv-coq/src/Platform/MetricRiscvMachine -0m00.48s | bedrock2/deps/riscv-coq/src/Platform/RiscvMachine -0m00.47s | bedrock2/bedrock2/src/BasicC64Syntax -0m00.47s | bedrock2/deps/riscv-coq/src/Spec/PseudoInstructions -0m00.46s | bedrock2/compiler/src/ZNameGen -0m00.46s | bedrock2/deps/riscv-coq/src/Platform/MetricLogging -0m00.45s | bedrock2/compiler/src/RegAllocAnnotatedNotations -0m00.45s | bedrock2/processor/src/KamiWord -0m00.44s | bedrock2/deps/coqutil/src/Map/SortedListString_test -0m00.44s | bedrock2/deps/coqutil/src/Tactics/Tactics -0m00.44s | bedrock2/deps/riscv-coq/src/Spec/Execute -0m00.44s | bedrock2/deps/riscv-coq/src/Utility/InstructionNotations -0m00.43s | bedrock2/bedrock2/src/Map/Separation -0m00.43s | bedrock2/compiler/src/RiscvWordProperties -0m00.43s | bedrock2/deps/riscv-coq/src/Spec/VirtualMemory -0m00.43s | bedrock2/deps/riscv-coq/src/Utility/InstructionCoercions -0m00.42s | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncode -0m00.40s | bedrock2/compiler/src/util/Tactics -0m00.40s | bedrock2/deps/coqutil/src/Map/Interface -0m00.39s | bedrock2/deps/coqutil/src/Z/HexNotation -0m00.38s | Kami/Lib/CommonTactics -0m00.38s | Kami/Lib/Nomega -0m00.38s | bedrock2/bedrock2/src/ZNamesSyntax -0m00.37s | bedrock2/deps/coqutil/src/Map/Funext -0m00.37s | bedrock2/deps/riscv-coq/src/Utility/div_mod_to_quot_rem -0m00.36s | Kami/Ex/Names -0m00.36s | Kami/Lib/Concat -0m00.36s | bedrock2/bedrock2/src/string2ident -0m00.36s | bedrock2/compiler/src/Simp -0m00.36s | bedrock2/deps/coqutil/src/Map/Solver -0m00.36s | bedrock2/deps/riscv-coq/src/Utility/nat_div_mod_to_quot_rem -0m00.35s | Kami/Lib/Misc -0m00.35s | bedrock2/bedrock2/src/Examples/StructAccess -0m00.35s | bedrock2/bedrock2/src/StructNotations -0m00.35s | bedrock2/deps/coqutil/src/Map/Empty_set_keyed_map -0m00.35s | bedrock2/deps/coqutil/src/Map/SortedListString -0m00.34s | Kami/Lib/Reflection -0m00.34s | bedrock2/bedrock2/src/Bytedump -0m00.34s | bedrock2/deps/riscv-coq/src/Utility/Tactics -0m00.33s | bedrock2/bedrock2/src/NotationsCustomEntry -0m00.33s | bedrock2/compiler/src/util/MyOmega -0m00.32s | bedrock2/bedrock2/src/Hexdump -0m00.32s | bedrock2/compiler/src/NameGen -0m00.31s | bedrock2/compiler/lib/LibTacticsMin -0m00.30s | bedrock2/bedrock2/src/StringNamesSyntax -0m00.30s | bedrock2/compiler/src/util/Set -0m00.30s | bedrock2/compiler/src/util/SetSolverTests -0m00.29s | bedrock2/deps/coqutil/src/Datatypes/String -0m00.27s | bedrock2/deps/coqutil/src/Word/LittleEndian -0m00.27s | bedrock2/deps/riscv-coq/src/Utility/MonadTests -0m00.26s | bedrock2/deps/coqutil/src/Z/div_mod_to_equations -0m00.23s | bedrock2/deps/riscv-coq/src/Utility/MonadT -0m00.19s | bedrock2/bedrock2/src/NotationsInConstr -0m00.19s | bedrock2/deps/coqutil/src/Datatypes/HList -0m00.17s | Kami/Lib/VectorFacts -0m00.17s | bedrock2/deps/riscv-coq/src/Utility/JMonad -0m00.14s | Kami/Lib/DepEq -0m00.13s | Kami/Lib/FinNotations -0m00.13s | bedrock2/bedrock2/src/ListPred -0m00.13s | bedrock2/bedrock2/src/Variables -0m00.13s | bedrock2/deps/coqutil/src/Datatypes/List -0m00.12s | bedrock2/deps/riscv-coq/src/Utility/MonadNotations -0m00.09s | bedrock2/bedrock2/src/Lift1Prop -0m00.09s | bedrock2/deps/coqutil/src/Datatypes/Option -0m00.09s | bedrock2/deps/coqutil/src/Datatypes/Prod -0m00.07s | Kami/Lib/BasicLogic -0m00.07s | bedrock2/bedrock2/src/Syntax -0m00.06s | Kami/Lib/DepEqNat -0m00.06s | bedrock2/deps/coqutil/src/Macros/symmetry -0m00.05s | bedrock2/compiler/lib/fiat_crypto_tactics/Not -0m00.05s | bedrock2/compiler/src/util/Misc -0m00.05s | bedrock2/deps/riscv-coq/src/Utility/PowerFunc -0m00.05s | bedrock2/deps/riscv-coq/src/Utility/runsToNonDet -0m00.04s | bedrock2/bedrock2/src/Markers -0m00.04s | bedrock2/bedrock2/src/Notations -0m00.04s | bedrock2/compiler/lib/fiat_crypto_tactics/Test -0m00.04s | bedrock2/compiler/lib/fiat_crypto_tactics/UniquePose -0m00.04s | bedrock2/compiler/src/NoActionSyntaxParams -0m00.04s | bedrock2/compiler/src/eqexact -0m00.04s | bedrock2/compiler/src/examples/highlevel/For -0m00.04s | bedrock2/compiler/src/on_hyp_containing -0m00.04s | bedrock2/compiler/src/util/Learning -0m00.04s | bedrock2/deps/coqutil/src/Datatypes/PrimitivePair -0m00.04s | bedrock2/deps/coqutil/src/Macros/subst -0m00.04s | bedrock2/deps/coqutil/src/Macros/unique -0m00.04s | bedrock2/deps/coqutil/src/Tactics/eabstract -0m00.04s | bedrock2/deps/coqutil/src/Tactics/letexists -0m00.04s | bedrock2/deps/coqutil/src/Tactics/rdelta -0m00.04s | bedrock2/deps/coqutil/src/Tactics/syntactic_unify -0m00.04s | bedrock2/deps/coqutil/src/dlet -0m00.04s | bedrock2/deps/coqutil/src/sanity -0m00.04s | bedrock2/deps/riscv-coq/src/Utility/MMIOTrace -0m00.03s | bedrock2/compiler/src/util/LogGoal
\ No newline at end of file + Time | Peak Mem | File Name +------------------------------------------------------------------------------------ +39m02.51s | 1980772 ko | Total Time / Peak Mem +------------------------------------------------------------------------------------ + 3m26.96s | 1980772 ko | Kami/Ex/Multiplier64 + 3m22.44s | 899104 ko | bedrock2/compiler/src/FlatToRiscv + 2m19.56s | 1730872 ko | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeI + 2m11.59s | 1411224 ko | Kami/Ex/Divider64 + 1m44.22s | 997556 ko | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeCSR + 1m44.11s | 1131272 ko | Kami/Ex/Multiplier32 + 1m41.50s | 564436 ko | bedrock2/bedrock2/src/Examples/bsearch + 1m08.57s | 1312068 ko | Kami/Ex/ProcFDInl + 1m07.92s | 590104 ko | bedrock2/deps/riscv-coq/src/Platform/MinimalMMIO + 1m01.07s | 798376 ko | Kami/Ex/FifoCorrect + 1m00.73s | 847228 ko | Kami/Ex/Divider32 + 0m50.15s | 573560 ko | bedrock2/deps/riscv-coq/src/Proofs/EncodeBound + 0m40.64s | 588832 ko | bedrock2/bedrock2/src/Examples/FE310CompilerDemo + 0m40.29s | 668564 ko | Kami/InlineFacts + 0m39.12s | 563328 ko | Kami/Renaming + 0m37.44s | 672092 ko | Kami/Ex/SimpleFifoCorrect + 0m37.08s | 601836 ko | Kami/SemFacts + 0m36.08s | 562540 ko | ─preprbedrock2/deps/coqutil/src/Map/TestGoals + 0m32.76s | 885880 ko | Kami/ModularFacts + 0m28.68s | 639092 ko | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeA + 0m26.60s | 741048 ko | Kami/Lib/Word + 0m26.55s | 632108 ko | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_SB + 0m26.45s | 605916 ko | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeA64 + 0m25.80s | 650288 ko | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeI64 + 0m25.47s | 729768 ko | bedrock2/processor/src/KamiRiscv + 0m23.66s | 610544 ko | bedrock2/compiler/src/EmitsValid + 0m22.68s | 653084 ko | Kami/Ex/InDepthTutorial + 0m22.60s | 589708 ko | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeM + 0m21.68s | 506640 ko | Kami/Specialize + 0m21.59s | 525428 ko | bedrock2/bedrock2/src/Examples/lightbulb + 0m19.20s | 526372 ko | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I_shift_66 + 0m19.19s | 580040 ko | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_UJ + 0m17.33s | 724164 ko | Kami/Ex/ProcDecInl + 0m15.63s | 555732 ko | bedrock2/compiler/src/examples/MMIO + 0m14.78s | 561068 ko | Kami/ParametricSyntax + 0m12.11s | 518652 ko | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_S + 0m11.74s | 501100 ko | bedrock2/deps/riscv-coq/src/Platform/MetricMinimal + 0m09.95s | 568468 ko | bedrock2/deps/coqutil/src/Word/Properties + 0m09.77s | 523092 ko | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeM64 + 0m09.56s | 537308 ko | Kami/Lib/FMap + 0m09.35s | 496100 ko | bedrock2/bedrock2/src/Examples/ipow + 0m09.26s | 504428 ko | Kami/StepDet + 0m09.19s | 663884 ko | bedrock2/bedrock2/src/WeakestPreconditionProperties + 0m09.16s | 495544 ko | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_Fence + 0m08.98s | 511956 ko | Kami/RefinementFacts + 0m08.68s | 494004 ko | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_R_atomic + 0m08.26s | 505664 ko | bedrock2/compiler/src/FlatToRiscv32 + 0m07.55s | 534616 ko | Kami/Ex/Fifo + 0m07.54s | 454624 ko | ─ensbedrock2/deps/coqutil/src/Map/SlowGoals + 0m06.99s | 482444 ko | bedrock2/deps/riscv-coq/src/Platform/Minimal + 0m06.89s | 480324 ko | bedrock2/compiler/src/GoFlatToRiscv + 0m06.82s | 485168 ko | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I + 0m06.72s | 485544 ko | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_FenceI + 0m06.50s | 501300 ko | Kami/Semantics + 0m06.36s | 478692 ko | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I_shift_57 + 0m06.32s | 478812 ko | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_R + 0m06.24s | 509232 ko | Kami/PartialInlineFacts + 0m06.02s | 486764 ko | bedrock2/deps/coqutil/src/Map/Properties + 0m05.62s | 535096 ko | Kami/Ex/ProcThreeStage + 0m05.56s | 507520 ko | Kami/Decomposition + 0m05.12s | 505436 ko | Kami/Amortization + 0m05.07s | 561800 ko | Kami/Ex/SCMMInl + 0m04.71s | 470712 ko | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_I_system + 0m04.46s | 468412 ko | bedrock2/deps/riscv-coq/src/Proofs/invert_encode_U + 0m04.19s | 509168 ko | Kami/ParametricInline + 0m04.13s | 512264 ko | Kami/Ex/ProcDec + 0m03.88s | 478956 ko | bedrock2/bedrock2/src/Examples/swap + 0m03.81s | 510132 ko | Kami/Ex/SC + 0m03.64s | 472892 ko | bedrock2/bedrock2/src/FE310CSemantics + 0m03.39s | 517872 ko | Kami/Tutorial + 0m03.30s | 510956 ko | bedrock2/compiler/src/examples/Fibonacci + 0m03.17s | 486656 ko | Kami/Label + 0m03.17s | 492768 ko | Kami/ModuleBoundEx + 0m03.10s | 492424 ko | Kami/ParametricEquiv + 0m03.06s | 499932 ko | Kami/Wf + 0m02.50s | 505076 ko | bedrock2/compiler/src/Pipeline + 0m02.42s | 526316 ko | Kami/Ex/ProcFDInv + 0m02.42s | 489812 ko | Kami/ParamDup + 0m02.39s | 487424 ko | Kami/Duplicate + 0m02.19s | 489072 ko | Kami/ParametricWf + 0m02.11s | 508168 ko | Kami/Ex/ProcFetchDecode + 0m02.06s | 465924 ko | bedrock2/bedrock2/src/Examples/ARPResponder + 0m01.94s | 494008 ko | Kami/MapReifyEx + 0m01.89s | 479116 ko | Kami/Syntax + 0m01.88s | 521816 ko | Kami/Ex/IsaRv32/PgmGcd + 0m01.87s | 522776 ko | Kami/Ex/IsaRv32/PgmBankerWorker1 + 0m01.87s | 519908 ko | Kami/Ex/IsaRv32/PgmMatMulReport + 0m01.85s | 520188 ko | Kami/Ex/IsaRv32/PgmBankerWorker3 + 0m01.83s | 524584 ko | Kami/Ex/IsaRv32/PgmDekker2 + 0m01.83s | 522312 ko | Kami/Ex/IsaRv32/PgmFact + 0m01.83s | 519240 ko | Kami/Ex/IsaRv32/PgmMatMulNormal1 + 0m01.81s | 522124 ko | Kami/Ex/IsaRv32/PgmBankerInit + 0m01.81s | 521416 ko | Kami/Ex/IsaRv32/PgmMatMulInit + 0m01.81s | 519724 ko | Kami/Ex/IsaRv32/PgmMatMulNormal2 + 0m01.81s | 495792 ko | Kami/Ex/RegFile + 0m01.80s | 520460 ko | Kami/Ex/IsaRv32/PgmBankerWorker2 + 0m01.80s | 519680 ko | Kami/Ex/IsaRv32/PgmPeterson1 + 0m01.80s | 519696 ko | Kami/Ex/IsaRv32/PgmPeterson2 + 0m01.80s | 461200 ko | bedrock2/bedrock2/src/ptsto_bytes + 0m01.78s | 520604 ko | Kami/Ex/IsaRv32/PgmDekker1 + 0m01.78s | 495196 ko | Kami/Ex/ProcDecInv + 0m01.76s | 433996 ko | bedrock2/bedrock2/src/Map/SeparationLogic + 0m01.75s | 521896 ko | Kami/Ex/IsaRv32/PgmBsort + 0m01.74s | 522080 ko | Kami/Ex/IsaRv32/PgmHanoi + 0m01.70s | 490720 ko | Kami/Ex/NativeFifo + 0m01.52s | 429812 ko | Kami/Lib/NatLib + 0m01.51s | 473632 ko | bedrock2/processor/src/Test + 0m01.48s | 476176 ko | Kami/SymEval + 0m01.47s | 497260 ko | Kami/Ex/MemAtomic + 0m01.44s | 498104 ko | Kami/Ex/ProcThreeStInv + 0m01.35s | 457132 ko | bedrock2/bedrock2/src/Array + 0m01.34s | 461368 ko | bedrock2/bedrock2/src/TailRecursion + 0m01.30s | 509008 ko | Kami/Ex/IsaRv32 + 0m01.29s | 485936 ko | Kami/ModuleBound + 0m01.29s | 418180 ko | bedrock2/bedrock2/src/Byte + 0m01.25s | 435736 ko | bedrock2/bedrock2/src/Examples/chacha20 + 0m01.19s | 495240 ko | Kami/Ex/ProcThreeStDec + 0m01.18s | 457564 ko | bedrock2/bedrock2/src/Scalars + 0m01.17s | 444076 ko | bedrock2/deps/riscv-coq/src/Utility/ListLib + 0m01.15s | 487776 ko | Kami/Ex/OneEltFifo + 0m01.14s | 449412 ko | bedrock2/bedrock2/src/Examples/Trace + 0m01.13s | 457912 ko | bedrock2/bedrock2/src/TODO_absint + 0m01.10s | 419492 ko | bedrock2/compiler/lib/LibTactics + 0m01.08s | 421756 ko | Kami/Lib/StringAsList + 0m01.00s | 442912 ko | bedrock2/deps/coqutil/src/Z/ZLib + 0m00.99s | 435576 ko | Kami/Lib/Struct + 0m00.98s | 426872 ko | bedrock2/compiler/src/examples/toposort + 0m00.95s | 441452 ko | bedrock2/deps/riscv-coq/src/Utility/prove_Zeq_bitwise + 0m00.94s | 450352 ko | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncodeProver + 0m00.94s | 454504 ko | bedrock2/deps/riscv-coq/src/Spec/ExecuteI + 0m00.93s | 493232 ko | Kami/Ex/ProcDecSC + 0m00.92s | 550756 ko | Kami/Ex/IsaRv32PgmExt + 0m00.90s | 421100 ko | Kami/Lib/Indexer + 0m00.89s | 484828 ko | Kami/Tactics + 0m00.88s | 427540 ko | bedrock2/compiler/src/util/ListLib + 0m00.87s | 460284 ko | Kami/Notations + 0m00.84s | 443020 ko | bedrock2/bedrock2/src/Memory + 0m00.83s | 526908 ko | Kami/Ex/ProcFDCorrect + 0m00.83s | 439724 ko | bedrock2/deps/riscv-coq/src/Utility/ZBitOps + 0m00.82s | 507796 ko | Kami/Ex/IsaRv32Pgm + 0m00.82s | 422368 ko | Kami/Lib/ilist + 0m00.81s | 488468 ko | Kami/Ex/ProcDecSCN + 0m00.81s | 439216 ko | bedrock2/deps/coqutil/src/Z/BitOps + 0m00.80s | 527136 ko | Kami/Ex/ProcFourStDec + 0m00.80s | 499980 ko | bedrock2/compiler/src/examples/EditDistExample + 0m00.79s | 477872 ko | Kami/Ext/BSyntax + 0m00.79s | 488532 ko | Kami/Ext/Extraction + 0m00.77s | 486708 ko | Kami/ParametricInlineLtac + 0m00.76s | 409784 ko | bedrock2/deps/riscv-coq/src/Platform/Example64Literal + 0m00.76s | 459200 ko | bedrock2/deps/riscv-coq/src/Spec/MetricPrimitives + 0m00.75s | 490144 ko | Kami/Ex/ProcThreeStInl + 0m00.74s | 485920 ko | Kami/Kami + 0m00.74s | 501084 ko | bedrock2/compiler/src/examples/CompileExamples + 0m00.74s | 505316 ko | bedrock2/compiler/src/examples/swap_bytes_over_uart_hexdump + 0m00.74s | 460380 ko | bedrock2/deps/riscv-coq/src/Platform/MinimalLogging + 0m00.72s | 473852 ko | Kami/Substitute + 0m00.72s | 458732 ko | bedrock2/compiler/src/examples/TestExprImp + 0m00.72s | 457772 ko | bedrock2/deps/riscv-coq/src/Spec/Primitives + 0m00.71s | 452980 ko | Kami/Ex/MemTypes + 0m00.71s | 483356 ko | bedrock2/compiler/src/examples/InlineAssemblyMacro + 0m00.71s | 459820 ko | bedrock2/compiler/src/examples/TestFlatImp + 0m00.71s | 449484 ko | bedrock2/deps/riscv-coq/src/Platform/Memory + 0m00.71s | 446048 ko | bedrock2/deps/riscv-coq/src/Spec/Decode + 0m00.70s | 469696 ko | Kami/Inline + 0m00.70s | 423260 ko | Kami/Lib/StringAsOT + 0m00.69s | 466532 ko | bedrock2/compiler/src/FlatToRiscvDef + 0m00.68s | 447424 ko | bedrock2/compiler/src/Rem4 + 0m00.67s | 474056 ko | Kami/SymEvalTac + 0m00.67s | 446424 ko | bedrock2/compiler/src/SimplWordExpr + 0m00.67s | 446648 ko | bedrock2/deps/riscv-coq/src/Utility/Encode + 0m00.66s | 441912 ko | bedrock2/bedrock2/src/Semantics + 0m00.63s | 420276 ko | Kami/Lib/StringStringAsOT + 0m00.63s | 426168 ko | bedrock2/deps/coqutil/src/Datatypes/PropSet + 0m00.61s | 446012 ko | bedrock2/compiler/src/UnmappedMemForExtSpec + 0m00.61s | 357880 ko | bedrock2/deps/riscv-coq/src/Utility/Monads + 0m00.60s | 426440 ko | bedrock2/deps/coqutil/src/Map/SortedList + 0m00.59s | 442252 ko | Kami/Synthesize + 0m00.59s | 371952 ko | bedrock2/compiler/src/util/Common + 0m00.59s | 440596 ko | bedrock2/deps/coqutil/src/Map/SortedListWord + 0m00.58s | 415316 ko | bedrock2/deps/coqutil/src/Word/Naive + 0m00.58s | 408744 ko | bedrock2/deps/riscv-coq/src/Utility/runsToNonDet_Run + 0m00.57s | 403188 ko | bedrock2/bedrock2/src/BasicC64Semantics + 0m00.57s | 358716 ko | bedrock2/deps/riscv-coq/src/Utility/Utility + 0m00.56s | 432120 ko | Kami/Lib/WordSupport + 0m00.56s | 410516 ko | bedrock2/bedrock2/src/WeakestPrecondition + 0m00.55s | 413664 ko | Kami/Lib/StringEq + 0m00.55s | 387552 ko | bedrock2/bedrock2/src/BasicC32Semantics + 0m00.55s | 420416 ko | bedrock2/compiler/src/examples/highlevel/FuncMut + 0m00.55s | 401008 ko | bedrock2/deps/riscv-coq/src/Spec/ExecuteI64 + 0m00.55s | 376020 ko | bedrock2/deps/riscv-coq/src/Utility/DefaultMemImpl32 + 0m00.54s | 310296 ko | bedrock2/bedrock2/src/Examples/MultipleReturnValues + 0m00.53s | 386872 ko | bedrock2/compiler/src/RegAlloc2 + 0m00.53s | 387416 ko | bedrock2/deps/riscv-coq/src/Spec/ExecuteM + 0m00.52s | 371960 ko | bedrock2/bedrock2/src/ProgramLogic + 0m00.52s | 374676 ko | bedrock2/deps/riscv-coq/src/Platform/Run + 0m00.52s | 375816 ko | bedrock2/deps/riscv-coq/src/Spec/ExecuteM64 + 0m00.52s | 375840 ko | bedrock2/deps/riscv-coq/src/Utility/DefaultMemImpl64 + 0m00.52s | 346660 ko | bedrock2/deps/riscv-coq/src/Utility/Words32Naive + 0m00.50s | 322924 ko | bedrock2/bedrock2/src/BasicCSyntax + 0m00.50s | 385968 ko | bedrock2/compiler/src/Basic32Semantics + 0m00.50s | 389304 ko | bedrock2/compiler/src/RegAlloc3 + 0m00.49s | 411496 ko | bedrock2/bedrock2/src/BytedumpTest + 0m00.49s | 411496 ko | bedrock2/bedrock2/src/BytedumpTestα + 0m00.49s | 365272 ko | bedrock2/deps/coqutil/src/Map/Z_keyed_SortedListMap + 0m00.49s | 375808 ko | bedrock2/deps/riscv-coq/src/Spec/Machine + 0m00.49s | 360632 ko | bedrock2/deps/riscv-coq/src/Utility/MkMachineWidth + 0m00.49s | 346980 ko | bedrock2/deps/riscv-coq/src/Utility/Words64Naive + 0m00.48s | 276676 ko | bedrock2/bedrock2/src/ToCString + 0m00.48s | 352200 ko | bedrock2/compiler/src/SeparationLogic + 0m00.48s | 375156 ko | bedrock2/deps/coqutil/src/Decidable + 0m00.48s | 362608 ko | bedrock2/deps/riscv-coq/src/Platform/MetricRiscvMachine + 0m00.48s | 370692 ko | bedrock2/deps/riscv-coq/src/Platform/RiscvMachine + 0m00.47s | 321560 ko | bedrock2/bedrock2/src/BasicC64Syntax + 0m00.47s | 338992 ko | bedrock2/deps/riscv-coq/src/Spec/PseudoInstructions + 0m00.46s | 351756 ko | bedrock2/compiler/src/ZNameGen + 0m00.46s | 344552 ko | bedrock2/deps/riscv-coq/src/Platform/MetricLogging + 0m00.45s | 350576 ko | bedrock2/compiler/src/RegAllocAnnotatedNotations + 0m00.45s | 358800 ko | bedrock2/processor/src/KamiWord + 0m00.44s | 305528 ko | bedrock2/deps/coqutil/src/Map/SortedListString_test + 0m00.44s | 321736 ko | bedrock2/deps/coqutil/src/Tactics/Tactics + 0m00.44s | 336624 ko | bedrock2/deps/riscv-coq/src/Spec/Execute + 0m00.44s | 340268 ko | bedrock2/deps/riscv-coq/src/Utility/InstructionNotations + 0m00.43s | 289244 ko | bedrock2/bedrock2/src/Map/Separation + 0m00.43s | 362292 ko | bedrock2/compiler/src/RiscvWordProperties + 0m00.43s | 321032 ko | bedrock2/deps/riscv-coq/src/Spec/VirtualMemory + 0m00.43s | 313976 ko | bedrock2/deps/riscv-coq/src/Utility/InstructionCoercions + 0m00.42s | 374624 ko | bedrock2/deps/riscv-coq/src/Proofs/DecodeEncode + 0m00.40s | 282384 ko | bedrock2/compiler/src/util/Tactics + 0m00.40s | 323944 ko | bedrock2/deps/coqutil/src/Map/Interface + 0m00.39s | 303504 ko | bedrock2/deps/coqutil/src/Z/HexNotation + 0m00.38s | 319992 ko | Kami/Lib/CommonTactics + 0m00.38s | 363832 ko | Kami/Lib/Nomega + 0m00.38s | 294268 ko | bedrock2/bedrock2/src/ZNamesSyntax + 0m00.37s | 316400 ko | bedrock2/deps/coqutil/src/Map/Funext + 0m00.37s | 295668 ko | bedrock2/deps/riscv-coq/src/Utility/div_mod_to_quot_rem + 0m00.36s | 271052 ko | Kami/Ex/Names + 0m00.36s | 338456 ko | Kami/Lib/Concat + 0m00.36s | 272052 ko | bedrock2/bedrock2/src/string2ident + 0m00.36s | 298624 ko | bedrock2/compiler/src/Simp + 0m00.36s | 312496 ko | bedrock2/deps/coqutil/src/Map/Solver + 0m00.36s | 298516 ko | bedrock2/deps/riscv-coq/src/Utility/nat_div_mod_to_quot_rem + 0m00.35s | 299684 ko | Kami/Lib/Misc + 0m00.35s | 272888 ko | bedrock2/bedrock2/src/Examples/StructAccess + 0m00.35s | 267768 ko | bedrock2/bedrock2/src/StructNotations + 0m00.35s | 295952 ko | bedrock2/deps/coqutil/src/Map/Empty_set_keyed_map + 0m00.35s | 289456 ko | bedrock2/deps/coqutil/src/Map/SortedListString + 0m00.34s | 328692 ko | Kami/Lib/Reflection + 0m00.34s | 272812 ko | bedrock2/bedrock2/src/Bytedump + 0m00.34s | 294376 ko | bedrock2/deps/riscv-coq/src/Utility/Tactics + 0m00.33s | 301112 ko | bedrock2/bedrock2/src/NotationsCustomEntry + 0m00.33s | 289700 ko | bedrock2/compiler/src/util/MyOmega + 0m00.32s | 274924 ko | bedrock2/bedrock2/src/Hexdump + 0m00.32s | 286108 ko | bedrock2/compiler/src/NameGen + 0m00.31s | 301996 ko | bedrock2/compiler/lib/LibTacticsMin + 0m00.30s | 252388 ko | bedrock2/bedrock2/src/StringNamesSyntax + 0m00.30s | 282580 ko | bedrock2/compiler/src/util/Set + 0m00.30s | 290132 ko | bedrock2/compiler/src/util/SetSolverTests + 0m00.29s | 252176 ko | bedrock2/deps/coqutil/src/Datatypes/String + 0m00.27s | 227732 ko | bedrock2/deps/coqutil/src/Word/LittleEndian + 0m00.27s | 255852 ko | bedrock2/deps/riscv-coq/src/Utility/MonadTests + 0m00.26s | 238732 ko | bedrock2/deps/coqutil/src/Z/div_mod_to_equations + 0m00.23s | 212520 ko | bedrock2/deps/riscv-coq/src/Utility/MonadT + 0m00.19s | 172428 ko | bedrock2/bedrock2/src/NotationsInConstr + 0m00.19s | 180476 ko | bedrock2/deps/coqutil/src/Datatypes/HList + 0m00.17s | 180940 ko | Kami/Lib/VectorFacts + 0m00.17s | 184664 ko | bedrock2/deps/riscv-coq/src/Utility/JMonad + 0m00.14s | 160816 ko | Kami/Lib/DepEq + 0m00.13s | 142092 ko | Kami/Lib/FinNotations + 0m00.13s | 144616 ko | bedrock2/bedrock2/src/ListPred + 0m00.13s | 149744 ko | bedrock2/bedrock2/src/Variables + 0m00.13s | 142420 ko | bedrock2/deps/coqutil/src/Datatypes/List + 0m00.12s | 146976 ko | bedrock2/deps/riscv-coq/src/Utility/MonadNotations + 0m00.09s | 116312 ko | bedrock2/bedrock2/src/Lift1Prop + 0m00.09s | 108600 ko | bedrock2/deps/coqutil/src/Datatypes/Option + 0m00.09s | 93184 ko | bedrock2/deps/coqutil/src/Datatypes/Prod + 0m00.07s | 87856 ko | Kami/Lib/BasicLogic + 0m00.07s | 93508 ko | bedrock2/bedrock2/src/Syntax + 0m00.06s | 76484 ko | Kami/Lib/DepEqNat + 0m00.06s | 67708 ko | bedrock2/deps/coqutil/src/Macros/symmetry + 0m00.05s | 56680 ko | bedrock2/compiler/lib/fiat_crypto_tactics/Not + 0m00.05s | 70976 ko | bedrock2/compiler/src/util/Misc + 0m00.05s | 65768 ko | bedrock2/deps/riscv-coq/src/Utility/PowerFunc + 0m00.05s | 65120 ko | bedrock2/deps/riscv-coq/src/Utility/runsToNonDet + 0m00.04s | 57444 ko | bedrock2/bedrock2/src/Markers + 0m00.04s | 56396 ko | bedrock2/bedrock2/src/Notations + 0m00.04s | 55660 ko | bedrock2/compiler/lib/fiat_crypto_tactics/Test + 0m00.04s | 57340 ko | bedrock2/compiler/lib/fiat_crypto_tactics/UniquePose + 0m00.04s | 57364 ko | bedrock2/compiler/src/NoActionSyntaxParams + 0m00.04s | 56364 ko | bedrock2/compiler/src/eqexact + 0m00.04s | 55764 ko | bedrock2/compiler/src/examples/highlevel/For + 0m00.04s | 56680 ko | bedrock2/compiler/src/on_hyp_containing + 0m00.04s | 58420 ko | bedrock2/compiler/src/util/Learning + 0m00.04s | 56232 ko | bedrock2/deps/coqutil/src/Datatypes/PrimitivePair + 0m00.04s | 54100 ko | bedrock2/deps/coqutil/src/Macros/subst + 0m00.04s | 54384 ko | bedrock2/deps/coqutil/src/Macros/unique + 0m00.04s | 55016 ko | bedrock2/deps/coqutil/src/Tactics/eabstract + 0m00.04s | 55296 ko | bedrock2/deps/coqutil/src/Tactics/letexists + 0m00.04s | 54916 ko | bedrock2/deps/coqutil/src/Tactics/rdelta + 0m00.04s | 56184 ko | bedrock2/deps/coqutil/src/Tactics/syntactic_unify + 0m00.04s | 54440 ko | bedrock2/deps/coqutil/src/dlet + 0m00.04s | 54804 ko | bedrock2/deps/coqutil/src/sanity + 0m00.04s | 56096 ko | bedrock2/deps/riscv-coq/src/Utility/MMIOTrace + 0m00.03s | 54716 ko | bedrock2/compiler/src/util/LogGoal
\ No newline at end of file diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/004-per-file-fuzz/foo-real.v.timing.diff.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/004-per-file-fuzz/foo-real.v.timing.diff.expected index 726c19a2e2..76b0a35cb2 100644 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/004-per-file-fuzz/foo-real.v.timing.diff.expected +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/004-per-file-fuzz/foo-real.v.timing.diff.expected @@ -1,29 +1,29 @@ -After | Code | Before || Change | % Change + After | Code | Before || Change | % Change ----------------------------------------------------------------------------------------------------------- -0m01.23s | Total | 0m01.28s || -0m00.04s | -3.50% + 0m01.23s | Total | 0m01.28s || -0m00.04s | -3.50% ----------------------------------------------------------------------------------------------------------- -0m00.53s | Chars 260-284 ~ 280-304 [(vm_compute;~reflexivity).] | 0m00.566s || -0m00.03s | -6.36% -0m00.4s | Chars 285-289 ~ 305-309 [Qed.] | 0m00.411s || -0m00.01s | -2.67% -0m00.194s | Chars 031-064 ~ 031-064 [Require~Import~Coq.ZArith.ZArith.] | 0m00.192s || +0m00.00s | +1.04% -0m00.114s | Chars 000-030 ~ 000-030 [Require~Import~Coq.Lists.List.] | 0m00.114s || +0m00.00s | +0.00% -0m00.s | Chars 065-075 ~ 065-075 [Goal~_~True.] | 0m00.s || +0m00.00s | N/A -0m00.s | Chars 078-086 ~ 078-086 [exact~I.] | N/A || +0m00.00s | N/A - N/A | Chars 078-090 ~ 078-090 [constructor.] | 0m00.s || +0m00.00s | N/A -0m00.s | Chars 087-091 ~ 091-095 [Qed.] | 0m00.s || +0m00.00s | N/A -0m00.s | Chars 092-102 ~ 096-106 [Goal~_~True.] | 0m00.s || +0m00.00s | N/A -0m00.s | Chars 105-113 ~ 109-117 [exact~I.] | N/A || +0m00.00s | N/A - N/A | Chars 105-117 ~ 109-121 [constructor.] | 0m00.s || +0m00.00s | N/A -0m00.s | Chars 114-118 ~ 122-126 [Qed.] | 0m00.s || +0m00.00s | N/A -0m00.s | Chars 119-129 ~ 127-137 [Goal~_~True.] | 0m00.s || +0m00.00s | N/A -0m00.s | Chars 132-140 ~ 140-148 [exact~I.] | N/A || +0m00.00s | N/A - N/A | Chars 132-144 ~ 140-152 [constructor.] | 0m00.s || +0m00.00s | N/A -0m00.s | Chars 141-145 ~ 153-157 [Qed.] | 0m00.s || +0m00.00s | N/A -0m00.s | Chars 146-156 ~ 158-168 [Goal~_~True.] | 0m00.s || +0m00.00s | N/A -0m00.s | Chars 159-167 ~ 171-179 [exact~I.] | N/A || +0m00.00s | N/A - N/A | Chars 159-171 ~ 171-183 [constructor.] | 0m00.s || +0m00.00s | N/A -0m00.s | Chars 168-172 ~ 184-188 [Qed.] | 0m00.s || +0m00.00s | N/A -0m00.s | Chars 173-183 ~ 189-199 [Goal~_~True.] | 0m00.s || +0m00.00s | N/A -0m00.s | Chars 186-194 ~ 202-210 [exact~I.] | N/A || +0m00.00s | N/A - N/A | Chars 186-198 ~ 202-214 [constructor.] | 0m00.s || +0m00.00s | N/A -0m00.s | Chars 195-199 ~ 215-219 [Qed.] | 0m00.s || +0m00.00s | N/A -0m00.s | Chars 200-257 ~ 220-277 [Goal~_~List.repeat~Z.div_eucl~...] | 0m00.s || +0m00.00s | N/A
\ No newline at end of file + 0m00.53s | Chars 260-284 ~ 280-304 [(vm_compute;~reflexivity).] | 0m00.566s || -0m00.03s | -6.36% + 0m00.4s | Chars 285-289 ~ 305-309 [Qed.] | 0m00.411s || -0m00.01s | -2.67% +0m00.194s | Chars 031-064 ~ 031-064 [Require~Import~Coq.ZArith.ZArith.] | 0m00.192s || +0m00.00s | +1.04% +0m00.114s | Chars 000-030 ~ 000-030 [Require~Import~Coq.Lists.List.] | 0m00.114s || +0m00.00s | +0.00% + 0m00.s | Chars 065-075 ~ 065-075 [Goal~_~True.] | 0m00.s || +0m00.00s | N/A + 0m00.s | Chars 078-086 ~ 078-086 [exact~I.] | N/A || +0m00.00s | N/A + N/A | Chars 078-090 ~ 078-090 [constructor.] | 0m00.s || +0m00.00s | N/A + 0m00.s | Chars 087-091 ~ 091-095 [Qed.] | 0m00.s || +0m00.00s | N/A + 0m00.s | Chars 092-102 ~ 096-106 [Goal~_~True.] | 0m00.s || +0m00.00s | N/A + 0m00.s | Chars 105-113 ~ 109-117 [exact~I.] | N/A || +0m00.00s | N/A + N/A | Chars 105-117 ~ 109-121 [constructor.] | 0m00.s || +0m00.00s | N/A + 0m00.s | Chars 114-118 ~ 122-126 [Qed.] | 0m00.s || +0m00.00s | N/A + 0m00.s | Chars 119-129 ~ 127-137 [Goal~_~True.] | 0m00.s || +0m00.00s | N/A + 0m00.s | Chars 132-140 ~ 140-148 [exact~I.] | N/A || +0m00.00s | N/A + N/A | Chars 132-144 ~ 140-152 [constructor.] | 0m00.s || +0m00.00s | N/A + 0m00.s | Chars 141-145 ~ 153-157 [Qed.] | 0m00.s || +0m00.00s | N/A + 0m00.s | Chars 146-156 ~ 158-168 [Goal~_~True.] | 0m00.s || +0m00.00s | N/A + 0m00.s | Chars 159-167 ~ 171-179 [exact~I.] | N/A || +0m00.00s | N/A + N/A | Chars 159-171 ~ 171-183 [constructor.] | 0m00.s || +0m00.00s | N/A + 0m00.s | Chars 168-172 ~ 184-188 [Qed.] | 0m00.s || +0m00.00s | N/A + 0m00.s | Chars 173-183 ~ 189-199 [Goal~_~True.] | 0m00.s || +0m00.00s | N/A + 0m00.s | Chars 186-194 ~ 202-210 [exact~I.] | N/A || +0m00.00s | N/A + N/A | Chars 186-198 ~ 202-214 [constructor.] | 0m00.s || +0m00.00s | N/A + 0m00.s | Chars 195-199 ~ 215-219 [Qed.] | 0m00.s || +0m00.00s | N/A + 0m00.s | Chars 200-257 ~ 220-277 [Goal~_~List.repeat~Z.div_eucl~...] | 0m00.s || +0m00.00s | N/A
\ No newline at end of file diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/004-per-file-fuzz/foo-user.v.timing.diff.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/004-per-file-fuzz/foo-user.v.timing.diff.expected index f6be1d936d..1e27d5d12b 100644 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/004-per-file-fuzz/foo-user.v.timing.diff.expected +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/004-per-file-fuzz/foo-user.v.timing.diff.expected @@ -1,29 +1,29 @@ -After | Code | Before || Change | % Change + After | Code | Before || Change | % Change ----------------------------------------------------------------------------------------------------------- -0m01.14s | Total | 0m01.15s || -0m00.00s | -0.77% + 0m01.14s | Total | 0m01.15s || -0m00.00s | -0.77% ----------------------------------------------------------------------------------------------------------- -0m00.504s | Chars 260-284 ~ 280-304 [(vm_compute;~reflexivity).] | 0m00.528s || -0m00.02s | -4.54% -0m00.384s | Chars 285-289 ~ 305-309 [Qed.] | 0m00.4s || -0m00.01s | -4.00% -0m00.172s | Chars 031-064 ~ 031-064 [Require~Import~Coq.ZArith.ZArith.] | 0m00.156s || +0m00.01s | +10.25% -0m00.083s | Chars 000-030 ~ 000-030 [Require~Import~Coq.Lists.List.] | 0m00.072s || +0m00.01s | +15.27% -0m00.004s | Chars 200-257 ~ 220-277 [Goal~_~List.repeat~Z.div_eucl~...] | 0m00.s || +0m00.00s | ∞ -0m00.s | Chars 065-075 ~ 065-075 [Goal~_~True.] | 0m00.s || +0m00.00s | N/A -0m00.s | Chars 078-086 ~ 078-086 [exact~I.] | N/A || +0m00.00s | N/A - N/A | Chars 078-090 ~ 078-090 [constructor.] | 0m00.s || +0m00.00s | N/A -0m00.s | Chars 087-091 ~ 091-095 [Qed.] | 0m00.s || +0m00.00s | N/A -0m00.s | Chars 092-102 ~ 096-106 [Goal~_~True.] | 0m00.s || +0m00.00s | N/A -0m00.s | Chars 105-113 ~ 109-117 [exact~I.] | N/A || +0m00.00s | N/A - N/A | Chars 105-117 ~ 109-121 [constructor.] | 0m00.s || +0m00.00s | N/A -0m00.s | Chars 114-118 ~ 122-126 [Qed.] | 0m00.s || +0m00.00s | N/A -0m00.s | Chars 119-129 ~ 127-137 [Goal~_~True.] | 0m00.s || +0m00.00s | N/A -0m00.s | Chars 132-140 ~ 140-148 [exact~I.] | N/A || +0m00.00s | N/A - N/A | Chars 132-144 ~ 140-152 [constructor.] | 0m00.s || +0m00.00s | N/A -0m00.s | Chars 141-145 ~ 153-157 [Qed.] | 0m00.s || +0m00.00s | N/A -0m00.s | Chars 146-156 ~ 158-168 [Goal~_~True.] | 0m00.s || +0m00.00s | N/A -0m00.s | Chars 159-167 ~ 171-179 [exact~I.] | N/A || +0m00.00s | N/A - N/A | Chars 159-171 ~ 171-183 [constructor.] | 0m00.s || +0m00.00s | N/A -0m00.s | Chars 168-172 ~ 184-188 [Qed.] | 0m00.s || +0m00.00s | N/A -0m00.s | Chars 173-183 ~ 189-199 [Goal~_~True.] | 0m00.s || +0m00.00s | N/A -0m00.s | Chars 186-194 ~ 202-210 [exact~I.] | N/A || +0m00.00s | N/A - N/A | Chars 186-198 ~ 202-214 [constructor.] | 0m00.s || +0m00.00s | N/A -0m00.s | Chars 195-199 ~ 215-219 [Qed.] | 0m00.s || +0m00.00s | N/A
\ No newline at end of file +0m00.504s | Chars 260-284 ~ 280-304 [(vm_compute;~reflexivity).] | 0m00.528s || -0m00.02s | -4.54% +0m00.384s | Chars 285-289 ~ 305-309 [Qed.] | 0m00.4s || -0m00.01s | -4.00% +0m00.172s | Chars 031-064 ~ 031-064 [Require~Import~Coq.ZArith.ZArith.] | 0m00.156s || +0m00.01s | +10.25% +0m00.083s | Chars 000-030 ~ 000-030 [Require~Import~Coq.Lists.List.] | 0m00.072s || +0m00.01s | +15.27% +0m00.004s | Chars 200-257 ~ 220-277 [Goal~_~List.repeat~Z.div_eucl~...] | 0m00.s || +0m00.00s | ∞ + 0m00.s | Chars 065-075 ~ 065-075 [Goal~_~True.] | 0m00.s || +0m00.00s | N/A + 0m00.s | Chars 078-086 ~ 078-086 [exact~I.] | N/A || +0m00.00s | N/A + N/A | Chars 078-090 ~ 078-090 [constructor.] | 0m00.s || +0m00.00s | N/A + 0m00.s | Chars 087-091 ~ 091-095 [Qed.] | 0m00.s || +0m00.00s | N/A + 0m00.s | Chars 092-102 ~ 096-106 [Goal~_~True.] | 0m00.s || +0m00.00s | N/A + 0m00.s | Chars 105-113 ~ 109-117 [exact~I.] | N/A || +0m00.00s | N/A + N/A | Chars 105-117 ~ 109-121 [constructor.] | 0m00.s || +0m00.00s | N/A + 0m00.s | Chars 114-118 ~ 122-126 [Qed.] | 0m00.s || +0m00.00s | N/A + 0m00.s | Chars 119-129 ~ 127-137 [Goal~_~True.] | 0m00.s || +0m00.00s | N/A + 0m00.s | Chars 132-140 ~ 140-148 [exact~I.] | N/A || +0m00.00s | N/A + N/A | Chars 132-144 ~ 140-152 [constructor.] | 0m00.s || +0m00.00s | N/A + 0m00.s | Chars 141-145 ~ 153-157 [Qed.] | 0m00.s || +0m00.00s | N/A + 0m00.s | Chars 146-156 ~ 158-168 [Goal~_~True.] | 0m00.s || +0m00.00s | N/A + 0m00.s | Chars 159-167 ~ 171-179 [exact~I.] | N/A || +0m00.00s | N/A + N/A | Chars 159-171 ~ 171-183 [constructor.] | 0m00.s || +0m00.00s | N/A + 0m00.s | Chars 168-172 ~ 184-188 [Qed.] | 0m00.s || +0m00.00s | N/A + 0m00.s | Chars 173-183 ~ 189-199 [Goal~_~True.] | 0m00.s || +0m00.00s | N/A + 0m00.s | Chars 186-194 ~ 202-210 [exact~I.] | N/A || +0m00.00s | N/A + N/A | Chars 186-198 ~ 202-214 [constructor.] | 0m00.s || +0m00.00s | N/A + 0m00.s | Chars 195-199 ~ 215-219 [Qed.] | 0m00.s || +0m00.00s | N/A
\ No newline at end of file diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/run.sh b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/run.sh new file mode 100755 index 0000000000..f2c5b56ebb --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/run.sh @@ -0,0 +1,24 @@ +#!/usr/bin/env bash + +set -x +set -e + +cd "$(dirname "${BASH_SOURCE[0]}")" + +"$COQLIB"/tools/make-both-time-files.py time-of-build-after.log.in time-of-build-before.log.in time-of-build-both-user.log --sort-by-mem + +diff -u time-of-build-both-user.log.expected time-of-build-both-user.log || exit $? + +"$COQLIB"/tools/make-both-time-files.py --real time-of-build-after.log.in time-of-build-before.log.in time-of-build-both-real.log --sort-by-mem + +diff -u time-of-build-both-real.log.expected time-of-build-both-real.log || exit $? + +for sort_kind in auto absolute diff; do + "$COQLIB"/tools/make-both-time-files.py time-of-build-after.log.in time-of-build-before.log.in time-of-build-both-user-${sort_kind}.log --sort-by-mem --sort-by=${sort_kind} + + diff -u time-of-build-both-user-${sort_kind}.log.expected time-of-build-both-user-${sort_kind}.log || exit $? + + "$COQLIB"/tools/make-both-time-files.py --real time-of-build-after.log.in time-of-build-before.log.in time-of-build-both-real-${sort_kind}.log --sort-by-mem --sort-by=${sort_kind} + + diff -u time-of-build-both-real-${sort_kind}.log.expected time-of-build-both-real-${sort_kind}.log || exit $? +done diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-after.log.in b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-after.log.in new file mode 100644 index 0000000000..5757018e9b --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-after.log.in @@ -0,0 +1,1760 @@ +COQDEP src/Compilers/Z/Bounds/Pipeline/ReflectiveTactics.v +COQDEP src/Compilers/Z/Bounds/Pipeline/Definition.v +/home/jgross/.local64/coq/coq-master/bin/coq_makefile -f _CoqProject INSTALLDEFAULTROOT = Crypto -o Makefile-old +COQ_MAKEFILE -f _CoqProject > Makefile.coq +make --no-print-directory -C coqprime +make[1]: Nothing to be done for 'all'. +ECHO > _CoqProject +COQC src/Compilers/Z/Bounds/Pipeline/Definition.v +src/Compilers/Z/Bounds/Pipeline/Definition (real: 7.33, user: 7.18, sys: 0.14, mem: 574388 ko) +COQC src/Compilers/Z/Bounds/Pipeline/ReflectiveTactics.v +src/Compilers/Z/Bounds/Pipeline/ReflectiveTactics (real: 1.93, user: 1.72, sys: 0.20, mem: 544172 ko) +COQC src/Compilers/Z/Bounds/Pipeline.v +src/Compilers/Z/Bounds/Pipeline (real: 1.38, user: 1.19, sys: 0.16, mem: 539808 ko) +COQC src/Specific/Framework/SynthesisFramework.v +src/Specific/Framework/SynthesisFramework (real: 1.85, user: 1.67, sys: 0.17, mem: 646300 ko) +COQC src/Specific/X25519/C64/Synthesis.v +src/Specific/X25519/C64/Synthesis (real: 11.15, user: 10.37, sys: 0.18, mem: 687760 ko) +COQC src/Specific/NISTP256/AMD64/Synthesis.v +src/Specific/NISTP256/AMD64/Synthesis (real: 13.45, user: 12.55, sys: 0.19, mem: 668216 ko) +COQC src/Specific/X25519/C64/feadd.v +Finished transaction in 2.814 secs (2.624u,0.s) (successful) +total time: 2.576s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.2% 97.4% 1 2.508s +─ReflectiveTactics.do_reflective_pipelin 0.0% 66.9% 1 1.724s +─ReflectiveTactics.solve_side_conditions 0.0% 65.5% 1 1.688s +─ReflectiveTactics.solve_post_reified_si 1.2% 37.0% 1 0.952s +─Glue.refine_to_reflective_glue' ------- 0.0% 30.3% 1 0.780s +─ReflectiveTactics.do_reify ------------ 0.0% 28.6% 1 0.736s +─Reify.Reify_rhs_gen ------------------- 2.2% 26.6% 1 0.684s +─UnifyAbstractReflexivity.unify_transfor 20.3% 24.1% 7 0.164s +─Glue.zrange_to_reflective ------------- 0.0% 20.3% 1 0.524s +─Glue.zrange_to_reflective_goal -------- 9.5% 15.2% 1 0.392s +─Reify.do_reify_abs_goal --------------- 13.7% 13.8% 2 0.356s +─Reify.do_reifyf_goal ------------------ 12.4% 12.6% 16 0.324s +─ReflectiveTactics.unify_abstract_cbv_in 8.4% 11.2% 1 0.288s +─unify (constr) (constr) --------------- 5.7% 5.7% 6 0.072s +─Glue.pattern_sig_sig_assoc ------------ 0.0% 5.4% 1 0.140s +─assert (H : is_bounded_by' bounds (map' 4.8% 5.1% 2 0.072s +─Glue.pattern_proj1_sig_in_sig --------- 1.7% 5.1% 1 0.132s +─pose proof (pf : Interpretation.Bo 3.7% 3.7% 1 0.096s +─Glue.split_BoundedWordToZ ------------- 0.3% 3.7% 1 0.096s +─destruct_sig -------------------------- 0.2% 3.3% 4 0.044s +─destruct x ---------------------------- 3.1% 3.1% 4 0.036s +─eexact -------------------------------- 3.0% 3.0% 18 0.008s +─clearbody (ne_var_list) --------------- 3.0% 3.0% 4 0.060s +─prove_interp_compile_correct ---------- 0.0% 2.8% 1 0.072s +─synthesize ---------------------------- 0.0% 2.6% 1 0.068s +─rewrite ?EtaInterp.InterpExprEta ------ 2.5% 2.5% 1 0.064s +─ClearbodyAll.clearbody_all ------------ 0.0% 2.3% 2 0.060s +─rewrite H ----------------------------- 2.2% 2.2% 1 0.056s +─reflexivity --------------------------- 2.2% 2.2% 7 0.032s +─Reify.transitivity_tt ----------------- 0.0% 2.2% 2 0.032s +─transitivity -------------------------- 2.0% 2.0% 5 0.024s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.2% 97.4% 1 2.508s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 66.9% 1 1.724s + │└ReflectiveTactics.solve_side_conditio 0.0% 65.5% 1 1.688s + │ ├─ReflectiveTactics.solve_post_reifie 1.2% 37.0% 1 0.952s + │ │ ├─UnifyAbstractReflexivity.unify_tr 20.3% 24.1% 7 0.164s + │ │ │└unify (constr) (constr) --------- 3.0% 3.0% 5 0.028s + │ │ └─ReflectiveTactics.unify_abstract_ 8.4% 11.2% 1 0.288s + │ │ └unify (constr) (constr) --------- 2.8% 2.8% 1 0.072s + │ └─ReflectiveTactics.do_reify -------- 0.0% 28.6% 1 0.736s + │ └Reify.Reify_rhs_gen --------------- 2.2% 26.6% 1 0.684s + │ ├─Reify.do_reify_abs_goal --------- 13.7% 13.8% 2 0.356s + │ │└Reify.do_reifyf_goal ------------ 12.4% 12.6% 16 0.324s + │ │└eexact -------------------------- 2.6% 2.6% 16 0.008s + │ ├─prove_interp_compile_correct ---- 0.0% 2.8% 1 0.072s + │ │└rewrite ?EtaInterp.InterpExprEta 2.5% 2.5% 1 0.064s + │ ├─rewrite H ----------------------- 2.2% 2.2% 1 0.056s + │ └─Reify.transitivity_tt ----------- 0.0% 2.2% 2 0.032s + └─Glue.refine_to_reflective_glue' ----- 0.0% 30.3% 1 0.780s + ├─Glue.zrange_to_reflective --------- 0.0% 20.3% 1 0.524s + │ ├─Glue.zrange_to_reflective_goal -- 9.5% 15.2% 1 0.392s + │ │└pose proof (pf : Interpretat 3.7% 3.7% 1 0.096s + │ └─assert (H : is_bounded_by' bounds 4.8% 5.1% 2 0.072s + ├─Glue.pattern_sig_sig_assoc -------- 0.0% 5.4% 1 0.140s + │└Glue.pattern_proj1_sig_in_sig ----- 1.7% 5.1% 1 0.132s + │└ClearbodyAll.clearbody_all -------- 0.0% 2.3% 2 0.060s + │└clearbody (ne_var_list) ----------- 2.3% 2.3% 1 0.060s + └─Glue.split_BoundedWordToZ --------- 0.3% 3.7% 1 0.096s + └destruct_sig ---------------------- 0.2% 3.3% 4 0.044s + └destruct x ------------------------ 2.5% 2.5% 2 0.036s +─synthesize ---------------------------- 0.0% 2.6% 1 0.068s + +Finished transaction in 5.021 secs (4.636u,0.s) (successful) +Closed under the global context +total time: 2.576s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.2% 97.4% 1 2.508s +─ReflectiveTactics.do_reflective_pipelin 0.0% 66.9% 1 1.724s +─ReflectiveTactics.solve_side_conditions 0.0% 65.5% 1 1.688s +─ReflectiveTactics.solve_post_reified_si 1.2% 37.0% 1 0.952s +─Glue.refine_to_reflective_glue' ------- 0.0% 30.3% 1 0.780s +─ReflectiveTactics.do_reify ------------ 0.0% 28.6% 1 0.736s +─Reify.Reify_rhs_gen ------------------- 2.2% 26.6% 1 0.684s +─UnifyAbstractReflexivity.unify_transfor 20.3% 24.1% 7 0.164s +─Glue.zrange_to_reflective ------------- 0.0% 20.3% 1 0.524s +─Glue.zrange_to_reflective_goal -------- 9.5% 15.2% 1 0.392s +─Reify.do_reify_abs_goal --------------- 13.7% 13.8% 2 0.356s +─Reify.do_reifyf_goal ------------------ 12.4% 12.6% 16 0.324s +─ReflectiveTactics.unify_abstract_cbv_in 8.4% 11.2% 1 0.288s +─unify (constr) (constr) --------------- 5.7% 5.7% 6 0.072s +─Glue.pattern_sig_sig_assoc ------------ 0.0% 5.4% 1 0.140s +─assert (H : is_bounded_by' bounds (map' 4.8% 5.1% 2 0.072s +─Glue.pattern_proj1_sig_in_sig --------- 1.7% 5.1% 1 0.132s +─pose proof (pf : Interpretation.Bo 3.7% 3.7% 1 0.096s +─Glue.split_BoundedWordToZ ------------- 0.3% 3.7% 1 0.096s +─destruct_sig -------------------------- 0.2% 3.3% 4 0.044s +─destruct x ---------------------------- 3.1% 3.1% 4 0.036s +─eexact -------------------------------- 3.0% 3.0% 18 0.008s +─clearbody (ne_var_list) --------------- 3.0% 3.0% 4 0.060s +─prove_interp_compile_correct ---------- 0.0% 2.8% 1 0.072s +─synthesize ---------------------------- 0.0% 2.6% 1 0.068s +─rewrite ?EtaInterp.InterpExprEta ------ 2.5% 2.5% 1 0.064s +─ClearbodyAll.clearbody_all ------------ 0.0% 2.3% 2 0.060s +─rewrite H ----------------------------- 2.2% 2.2% 1 0.056s +─reflexivity --------------------------- 2.2% 2.2% 7 0.032s +─Reify.transitivity_tt ----------------- 0.0% 2.2% 2 0.032s +─transitivity -------------------------- 2.0% 2.0% 5 0.024s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.2% 97.4% 1 2.508s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 66.9% 1 1.724s + │└ReflectiveTactics.solve_side_conditio 0.0% 65.5% 1 1.688s + │ ├─ReflectiveTactics.solve_post_reifie 1.2% 37.0% 1 0.952s + │ │ ├─UnifyAbstractReflexivity.unify_tr 20.3% 24.1% 7 0.164s + │ │ │└unify (constr) (constr) --------- 3.0% 3.0% 5 0.028s + │ │ └─ReflectiveTactics.unify_abstract_ 8.4% 11.2% 1 0.288s + │ │ └unify (constr) (constr) --------- 2.8% 2.8% 1 0.072s + │ └─ReflectiveTactics.do_reify -------- 0.0% 28.6% 1 0.736s + │ └Reify.Reify_rhs_gen --------------- 2.2% 26.6% 1 0.684s + │ ├─Reify.do_reify_abs_goal --------- 13.7% 13.8% 2 0.356s + │ │└Reify.do_reifyf_goal ------------ 12.4% 12.6% 16 0.324s + │ │└eexact -------------------------- 2.6% 2.6% 16 0.008s + │ ├─prove_interp_compile_correct ---- 0.0% 2.8% 1 0.072s + │ │└rewrite ?EtaInterp.InterpExprEta 2.5% 2.5% 1 0.064s + │ ├─rewrite H ----------------------- 2.2% 2.2% 1 0.056s + │ └─Reify.transitivity_tt ----------- 0.0% 2.2% 2 0.032s + └─Glue.refine_to_reflective_glue' ----- 0.0% 30.3% 1 0.780s + ├─Glue.zrange_to_reflective --------- 0.0% 20.3% 1 0.524s + │ ├─Glue.zrange_to_reflective_goal -- 9.5% 15.2% 1 0.392s + │ │└pose proof (pf : Interpretat 3.7% 3.7% 1 0.096s + │ └─assert (H : is_bounded_by' bounds 4.8% 5.1% 2 0.072s + ├─Glue.pattern_sig_sig_assoc -------- 0.0% 5.4% 1 0.140s + │└Glue.pattern_proj1_sig_in_sig ----- 1.7% 5.1% 1 0.132s + │└ClearbodyAll.clearbody_all -------- 0.0% 2.3% 2 0.060s + │└clearbody (ne_var_list) ----------- 2.3% 2.3% 1 0.060s + └─Glue.split_BoundedWordToZ --------- 0.3% 3.7% 1 0.096s + └destruct_sig ---------------------- 0.2% 3.3% 4 0.044s + └destruct x ------------------------ 2.5% 2.5% 2 0.036s +─synthesize ---------------------------- 0.0% 2.6% 1 0.068s + +src/Specific/X25519/C64/feadd (real: 22.81, user: 20.93, sys: 0.25, mem: 766300 ko) +COQC src/Specific/X25519/C64/fecarry.v +Finished transaction in 4.343 secs (4.016u,0.004s) (successful) +total time: 3.976s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 99.0% 1 3.936s +─ReflectiveTactics.do_reflective_pipelin 0.0% 87.9% 1 3.496s +─ReflectiveTactics.solve_side_conditions 0.0% 86.9% 1 3.456s +─ReflectiveTactics.do_reify ------------ 0.0% 56.9% 1 2.264s +─Reify.Reify_rhs_gen ------------------- 1.8% 56.2% 1 2.236s +─Reify.do_reify_abs_goal --------------- 36.1% 36.5% 2 1.452s +─Reify.do_reifyf_goal ------------------ 34.8% 35.1% 29 1.396s +─ReflectiveTactics.solve_post_reified_si 0.6% 30.0% 1 1.192s +─UnifyAbstractReflexivity.unify_transfor 17.7% 21.7% 7 0.240s +─Glue.refine_to_reflective_glue' ------- 0.0% 11.1% 1 0.440s +─eexact -------------------------------- 10.9% 10.9% 31 0.024s +─ReflectiveTactics.unify_abstract_cbv_in 5.2% 7.3% 1 0.292s +─Glue.zrange_to_reflective ------------- 0.0% 7.1% 1 0.284s +─prove_interp_compile_correct ---------- 0.0% 5.7% 1 0.228s +─Glue.zrange_to_reflective_goal -------- 4.3% 5.5% 1 0.220s +─unify (constr) (constr) --------------- 5.3% 5.3% 6 0.084s +─rewrite ?EtaInterp.InterpExprEta ------ 5.2% 5.2% 1 0.208s +─rewrite H ----------------------------- 3.5% 3.5% 1 0.140s +─tac ----------------------------------- 1.9% 2.6% 2 0.104s +─reflexivity --------------------------- 2.2% 2.2% 7 0.028s +─Reify.transitivity_tt ----------------- 0.0% 2.2% 2 0.056s +─transitivity -------------------------- 2.0% 2.0% 5 0.048s +─Glue.split_BoundedWordToZ ------------- 0.1% 2.0% 1 0.080s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 99.0% 1 3.936s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 87.9% 1 3.496s + │└ReflectiveTactics.solve_side_conditio 0.0% 86.9% 1 3.456s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 56.9% 1 2.264s + │ │└Reify.Reify_rhs_gen --------------- 1.8% 56.2% 1 2.236s + │ │ ├─Reify.do_reify_abs_goal --------- 36.1% 36.5% 2 1.452s + │ │ │└Reify.do_reifyf_goal ------------ 34.8% 35.1% 29 1.396s + │ │ │└eexact -------------------------- 10.1% 10.1% 29 0.024s + │ │ ├─prove_interp_compile_correct ---- 0.0% 5.7% 1 0.228s + │ │ │└rewrite ?EtaInterp.InterpExprEta 5.2% 5.2% 1 0.208s + │ │ ├─rewrite H ----------------------- 3.5% 3.5% 1 0.140s + │ │ ├─tac ----------------------------- 1.9% 2.6% 1 0.104s + │ │ └─Reify.transitivity_tt ----------- 0.0% 2.2% 2 0.056s + │ │ └transitivity -------------------- 2.0% 2.0% 4 0.048s + │ └─ReflectiveTactics.solve_post_reifie 0.6% 30.0% 1 1.192s + │ ├─UnifyAbstractReflexivity.unify_tr 17.7% 21.7% 7 0.240s + │ │└unify (constr) (constr) --------- 3.2% 3.2% 5 0.048s + │ └─ReflectiveTactics.unify_abstract_ 5.2% 7.3% 1 0.292s + │ └unify (constr) (constr) --------- 2.1% 2.1% 1 0.084s + └─Glue.refine_to_reflective_glue' ----- 0.0% 11.1% 1 0.440s + ├─Glue.zrange_to_reflective --------- 0.0% 7.1% 1 0.284s + │└Glue.zrange_to_reflective_goal ---- 4.3% 5.5% 1 0.220s + └─Glue.split_BoundedWordToZ --------- 0.1% 2.0% 1 0.080s + +Finished transaction in 7.078 secs (6.728u,0.s) (successful) +Closed under the global context +total time: 3.976s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 99.0% 1 3.936s +─ReflectiveTactics.do_reflective_pipelin 0.0% 87.9% 1 3.496s +─ReflectiveTactics.solve_side_conditions 0.0% 86.9% 1 3.456s +─ReflectiveTactics.do_reify ------------ 0.0% 56.9% 1 2.264s +─Reify.Reify_rhs_gen ------------------- 1.8% 56.2% 1 2.236s +─Reify.do_reify_abs_goal --------------- 36.1% 36.5% 2 1.452s +─Reify.do_reifyf_goal ------------------ 34.8% 35.1% 29 1.396s +─ReflectiveTactics.solve_post_reified_si 0.6% 30.0% 1 1.192s +─UnifyAbstractReflexivity.unify_transfor 17.7% 21.7% 7 0.240s +─Glue.refine_to_reflective_glue' ------- 0.0% 11.1% 1 0.440s +─eexact -------------------------------- 10.9% 10.9% 31 0.024s +─ReflectiveTactics.unify_abstract_cbv_in 5.2% 7.3% 1 0.292s +─Glue.zrange_to_reflective ------------- 0.0% 7.1% 1 0.284s +─prove_interp_compile_correct ---------- 0.0% 5.7% 1 0.228s +─Glue.zrange_to_reflective_goal -------- 4.3% 5.5% 1 0.220s +─unify (constr) (constr) --------------- 5.3% 5.3% 6 0.084s +─rewrite ?EtaInterp.InterpExprEta ------ 5.2% 5.2% 1 0.208s +─rewrite H ----------------------------- 3.5% 3.5% 1 0.140s +─tac ----------------------------------- 1.9% 2.6% 2 0.104s +─reflexivity --------------------------- 2.2% 2.2% 7 0.028s +─Reify.transitivity_tt ----------------- 0.0% 2.2% 2 0.056s +─transitivity -------------------------- 2.0% 2.0% 5 0.048s +─Glue.split_BoundedWordToZ ------------- 0.1% 2.0% 1 0.080s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 99.0% 1 3.936s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 87.9% 1 3.496s + │└ReflectiveTactics.solve_side_conditio 0.0% 86.9% 1 3.456s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 56.9% 1 2.264s + │ │└Reify.Reify_rhs_gen --------------- 1.8% 56.2% 1 2.236s + │ │ ├─Reify.do_reify_abs_goal --------- 36.1% 36.5% 2 1.452s + │ │ │└Reify.do_reifyf_goal ------------ 34.8% 35.1% 29 1.396s + │ │ │└eexact -------------------------- 10.1% 10.1% 29 0.024s + │ │ ├─prove_interp_compile_correct ---- 0.0% 5.7% 1 0.228s + │ │ │└rewrite ?EtaInterp.InterpExprEta 5.2% 5.2% 1 0.208s + │ │ ├─rewrite H ----------------------- 3.5% 3.5% 1 0.140s + │ │ ├─tac ----------------------------- 1.9% 2.6% 1 0.104s + │ │ └─Reify.transitivity_tt ----------- 0.0% 2.2% 2 0.056s + │ │ └transitivity -------------------- 2.0% 2.0% 4 0.048s + │ └─ReflectiveTactics.solve_post_reifie 0.6% 30.0% 1 1.192s + │ ├─UnifyAbstractReflexivity.unify_tr 17.7% 21.7% 7 0.240s + │ │└unify (constr) (constr) --------- 3.2% 3.2% 5 0.048s + │ └─ReflectiveTactics.unify_abstract_ 5.2% 7.3% 1 0.292s + │ └unify (constr) (constr) --------- 2.1% 2.1% 1 0.084s + └─Glue.refine_to_reflective_glue' ----- 0.0% 11.1% 1 0.440s + ├─Glue.zrange_to_reflective --------- 0.0% 7.1% 1 0.284s + │└Glue.zrange_to_reflective_goal ---- 4.3% 5.5% 1 0.220s + └─Glue.split_BoundedWordToZ --------- 0.1% 2.0% 1 0.080s + +src/Specific/X25519/C64/fecarry (real: 27.11, user: 24.99, sys: 0.21, mem: 786052 ko) +COQC src/Specific/solinas32_2e255m765_12limbs/Synthesis.v +src/Specific/solinas32_2e255m765_12limbs/Synthesis (real: 40.13, user: 36.92, sys: 0.26, mem: 728464 ko) +COQC src/Specific/solinas32_2e255m765_13limbs/Synthesis.v +src/Specific/solinas32_2e255m765_13limbs/Synthesis (real: 49.44, user: 45.75, sys: 0.18, mem: 744240 ko) +COQC src/Specific/X25519/C64/femul.v +Finished transaction in 8.415 secs (7.664u,0.015s) (successful) +total time: 7.616s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 94.8% 1 7.220s +─ReflectiveTactics.do_reflective_pipelin 0.0% 85.0% 1 6.476s +─ReflectiveTactics.solve_side_conditions 0.0% 84.2% 1 6.416s +─ReflectiveTactics.do_reify ------------ 0.0% 50.3% 1 3.832s +─Reify.Reify_rhs_gen ------------------- 1.8% 49.4% 1 3.760s +─ReflectiveTactics.solve_post_reified_si 0.5% 33.9% 1 2.584s +─Reify.do_reify_abs_goal --------------- 31.1% 31.4% 2 2.392s +─Reify.do_reifyf_goal ------------------ 30.0% 30.3% 58 1.528s +─UnifyAbstractReflexivity.unify_transfor 22.1% 27.3% 7 0.600s +─Glue.refine_to_reflective_glue' ------- 0.0% 9.8% 1 0.744s +─eexact -------------------------------- 8.2% 8.2% 60 0.024s +─Glue.zrange_to_reflective ------------- 0.1% 6.8% 1 0.516s +─unify (constr) (constr) --------------- 5.9% 5.9% 6 0.124s +─prove_interp_compile_correct ---------- 0.0% 5.8% 1 0.444s +─ReflectiveTactics.unify_abstract_cbv_in 3.9% 5.7% 1 0.432s +─rewrite ?EtaInterp.InterpExprEta ------ 5.4% 5.4% 1 0.408s +─synthesize ---------------------------- 0.0% 5.2% 1 0.396s +─Glue.zrange_to_reflective_goal -------- 3.0% 5.0% 1 0.384s +─IntegrationTestTemporaryMiscCommon.do_r 0.1% 4.8% 1 0.364s +─change G' ----------------------------- 3.9% 3.9% 1 0.300s +─rewrite H ----------------------------- 3.0% 3.0% 1 0.232s +─tac ----------------------------------- 1.5% 2.3% 2 0.176s +─Reify.transitivity_tt ----------------- 0.0% 2.1% 2 0.092s +─reflexivity --------------------------- 2.0% 2.0% 7 0.052s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 94.8% 1 7.220s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 85.0% 1 6.476s + │└ReflectiveTactics.solve_side_conditio 0.0% 84.2% 1 6.416s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 50.3% 1 3.832s + │ │└Reify.Reify_rhs_gen --------------- 1.8% 49.4% 1 3.760s + │ │ ├─Reify.do_reify_abs_goal --------- 31.1% 31.4% 2 2.392s + │ │ │└Reify.do_reifyf_goal ------------ 30.0% 30.3% 58 1.528s + │ │ │└eexact -------------------------- 7.6% 7.6% 58 0.020s + │ │ ├─prove_interp_compile_correct ---- 0.0% 5.8% 1 0.444s + │ │ │└rewrite ?EtaInterp.InterpExprEta 5.4% 5.4% 1 0.408s + │ │ ├─rewrite H ----------------------- 3.0% 3.0% 1 0.232s + │ │ ├─tac ----------------------------- 1.5% 2.3% 1 0.176s + │ │ └─Reify.transitivity_tt ----------- 0.0% 2.1% 2 0.092s + │ └─ReflectiveTactics.solve_post_reifie 0.5% 33.9% 1 2.584s + │ ├─UnifyAbstractReflexivity.unify_tr 22.1% 27.3% 7 0.600s + │ │└unify (constr) (constr) --------- 4.3% 4.3% 5 0.096s + │ └─ReflectiveTactics.unify_abstract_ 3.9% 5.7% 1 0.432s + └─Glue.refine_to_reflective_glue' ----- 0.0% 9.8% 1 0.744s + └Glue.zrange_to_reflective ----------- 0.1% 6.8% 1 0.516s + └Glue.zrange_to_reflective_goal ------ 3.0% 5.0% 1 0.384s +─synthesize ---------------------------- 0.0% 5.2% 1 0.396s +└IntegrationTestTemporaryMiscCommon.do_r 0.1% 4.8% 1 0.364s +└change G' ----------------------------- 3.9% 3.9% 1 0.300s + +Finished transaction in 14.616 secs (13.528u,0.008s) (successful) +Closed under the global context +total time: 7.616s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 94.8% 1 7.220s +─ReflectiveTactics.do_reflective_pipelin 0.0% 85.0% 1 6.476s +─ReflectiveTactics.solve_side_conditions 0.0% 84.2% 1 6.416s +─ReflectiveTactics.do_reify ------------ 0.0% 50.3% 1 3.832s +─Reify.Reify_rhs_gen ------------------- 1.8% 49.4% 1 3.760s +─ReflectiveTactics.solve_post_reified_si 0.5% 33.9% 1 2.584s +─Reify.do_reify_abs_goal --------------- 31.1% 31.4% 2 2.392s +─Reify.do_reifyf_goal ------------------ 30.0% 30.3% 58 1.528s +─UnifyAbstractReflexivity.unify_transfor 22.1% 27.3% 7 0.600s +─Glue.refine_to_reflective_glue' ------- 0.0% 9.8% 1 0.744s +─eexact -------------------------------- 8.2% 8.2% 60 0.024s +─Glue.zrange_to_reflective ------------- 0.1% 6.8% 1 0.516s +─unify (constr) (constr) --------------- 5.9% 5.9% 6 0.124s +─prove_interp_compile_correct ---------- 0.0% 5.8% 1 0.444s +─ReflectiveTactics.unify_abstract_cbv_in 3.9% 5.7% 1 0.432s +─rewrite ?EtaInterp.InterpExprEta ------ 5.4% 5.4% 1 0.408s +─synthesize ---------------------------- 0.0% 5.2% 1 0.396s +─Glue.zrange_to_reflective_goal -------- 3.0% 5.0% 1 0.384s +─IntegrationTestTemporaryMiscCommon.do_r 0.1% 4.8% 1 0.364s +─change G' ----------------------------- 3.9% 3.9% 1 0.300s +─rewrite H ----------------------------- 3.0% 3.0% 1 0.232s +─tac ----------------------------------- 1.5% 2.3% 2 0.176s +─Reify.transitivity_tt ----------------- 0.0% 2.1% 2 0.092s +─reflexivity --------------------------- 2.0% 2.0% 7 0.052s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 94.8% 1 7.220s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 85.0% 1 6.476s + │└ReflectiveTactics.solve_side_conditio 0.0% 84.2% 1 6.416s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 50.3% 1 3.832s + │ │└Reify.Reify_rhs_gen --------------- 1.8% 49.4% 1 3.760s + │ │ ├─Reify.do_reify_abs_goal --------- 31.1% 31.4% 2 2.392s + │ │ │└Reify.do_reifyf_goal ------------ 30.0% 30.3% 58 1.528s + │ │ │└eexact -------------------------- 7.6% 7.6% 58 0.020s + │ │ ├─prove_interp_compile_correct ---- 0.0% 5.8% 1 0.444s + │ │ │└rewrite ?EtaInterp.InterpExprEta 5.4% 5.4% 1 0.408s + │ │ ├─rewrite H ----------------------- 3.0% 3.0% 1 0.232s + │ │ ├─tac ----------------------------- 1.5% 2.3% 1 0.176s + │ │ └─Reify.transitivity_tt ----------- 0.0% 2.1% 2 0.092s + │ └─ReflectiveTactics.solve_post_reifie 0.5% 33.9% 1 2.584s + │ ├─UnifyAbstractReflexivity.unify_tr 22.1% 27.3% 7 0.600s + │ │└unify (constr) (constr) --------- 4.3% 4.3% 5 0.096s + │ └─ReflectiveTactics.unify_abstract_ 3.9% 5.7% 1 0.432s + └─Glue.refine_to_reflective_glue' ----- 0.0% 9.8% 1 0.744s + └Glue.zrange_to_reflective ----------- 0.1% 6.8% 1 0.516s + └Glue.zrange_to_reflective_goal ------ 3.0% 5.0% 1 0.384s +─synthesize ---------------------------- 0.0% 5.2% 1 0.396s +└IntegrationTestTemporaryMiscCommon.do_r 0.1% 4.8% 1 0.364s +└change G' ----------------------------- 3.9% 3.9% 1 0.300s + +src/Specific/X25519/C64/femul (real: 39.72, user: 36.32, sys: 0.26, mem: 825448 ko) +COQC src/Specific/X25519/C64/feaddDisplay > src/Specific/X25519/C64/feaddDisplay.log +COQC src/Specific/X25519/C64/fecarryDisplay > src/Specific/X25519/C64/fecarryDisplay.log +COQC src/Specific/X25519/C64/fesub.v +Finished transaction in 3.513 secs (3.211u,0.s) (successful) +total time: 3.164s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.6% 1 3.088s +─ReflectiveTactics.do_reflective_pipelin 0.0% 74.1% 1 2.344s +─ReflectiveTactics.solve_side_conditions 0.0% 72.9% 1 2.308s +─ReflectiveTactics.do_reify ------------ 0.0% 38.6% 1 1.220s +─Reify.Reify_rhs_gen ------------------- 1.5% 37.2% 1 1.176s +─ReflectiveTactics.solve_post_reified_si 0.9% 34.4% 1 1.088s +─UnifyAbstractReflexivity.unify_transfor 19.2% 23.9% 7 0.204s +─Glue.refine_to_reflective_glue' ------- 0.0% 23.5% 1 0.744s +─Reify.do_reify_abs_goal --------------- 19.2% 19.5% 2 0.616s +─Reify.do_reifyf_goal ------------------ 18.0% 18.3% 16 0.580s +─Glue.zrange_to_reflective ------------- 0.1% 15.4% 1 0.488s +─Glue.zrange_to_reflective_goal -------- 6.8% 11.5% 1 0.364s +─ReflectiveTactics.unify_abstract_cbv_in 6.2% 9.0% 1 0.284s +─unify (constr) (constr) --------------- 5.9% 5.9% 6 0.080s +─Glue.pattern_sig_sig_assoc ------------ 0.0% 4.6% 1 0.144s +─eexact -------------------------------- 4.4% 4.4% 18 0.012s +─Glue.pattern_proj1_sig_in_sig --------- 1.4% 4.3% 1 0.136s +─prove_interp_compile_correct ---------- 0.0% 3.9% 1 0.124s +─rewrite H ----------------------------- 3.8% 3.8% 1 0.120s +─assert (H : is_bounded_by' bounds (map' 3.8% 3.8% 2 0.064s +─rewrite ?EtaInterp.InterpExprEta ------ 3.5% 3.5% 1 0.112s +─pose proof (pf : Interpretation.Bo 2.9% 2.9% 1 0.092s +─Glue.split_BoundedWordToZ ------------- 0.1% 2.8% 1 0.088s +─tac ----------------------------------- 1.9% 2.5% 2 0.080s +─reflexivity --------------------------- 2.4% 2.4% 7 0.028s +─synthesize ---------------------------- 0.0% 2.4% 1 0.076s +─destruct_sig -------------------------- 0.0% 2.4% 4 0.040s +─destruct x ---------------------------- 2.4% 2.4% 4 0.032s +─clearbody (ne_var_list) --------------- 2.3% 2.3% 4 0.060s +─Reify.transitivity_tt ----------------- 0.1% 2.3% 2 0.036s +─transitivity -------------------------- 2.1% 2.1% 5 0.032s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.6% 1 3.088s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 74.1% 1 2.344s + │└ReflectiveTactics.solve_side_conditio 0.0% 72.9% 1 2.308s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 38.6% 1 1.220s + │ │└Reify.Reify_rhs_gen --------------- 1.5% 37.2% 1 1.176s + │ │ ├─Reify.do_reify_abs_goal --------- 19.2% 19.5% 2 0.616s + │ │ │└Reify.do_reifyf_goal ------------ 18.0% 18.3% 16 0.580s + │ │ │└eexact -------------------------- 3.9% 3.9% 16 0.012s + │ │ ├─prove_interp_compile_correct ---- 0.0% 3.9% 1 0.124s + │ │ │└rewrite ?EtaInterp.InterpExprEta 3.5% 3.5% 1 0.112s + │ │ ├─rewrite H ----------------------- 3.8% 3.8% 1 0.120s + │ │ ├─tac ----------------------------- 1.9% 2.5% 1 0.080s + │ │ └─Reify.transitivity_tt ----------- 0.1% 2.3% 2 0.036s + │ │ └transitivity -------------------- 2.0% 2.0% 4 0.032s + │ └─ReflectiveTactics.solve_post_reifie 0.9% 34.4% 1 1.088s + │ ├─UnifyAbstractReflexivity.unify_tr 19.2% 23.9% 7 0.204s + │ │└unify (constr) (constr) --------- 3.4% 3.4% 5 0.036s + │ └─ReflectiveTactics.unify_abstract_ 6.2% 9.0% 1 0.284s + │ └unify (constr) (constr) --------- 2.5% 2.5% 1 0.080s + └─Glue.refine_to_reflective_glue' ----- 0.0% 23.5% 1 0.744s + ├─Glue.zrange_to_reflective --------- 0.1% 15.4% 1 0.488s + │ ├─Glue.zrange_to_reflective_goal -- 6.8% 11.5% 1 0.364s + │ │└pose proof (pf : Interpretat 2.9% 2.9% 1 0.092s + │ └─assert (H : is_bounded_by' bounds 3.8% 3.8% 2 0.064s + ├─Glue.pattern_sig_sig_assoc -------- 0.0% 4.6% 1 0.144s + │└Glue.pattern_proj1_sig_in_sig ----- 1.4% 4.3% 1 0.136s + └─Glue.split_BoundedWordToZ --------- 0.1% 2.8% 1 0.088s + └destruct_sig ---------------------- 0.0% 2.4% 4 0.040s +─synthesize ---------------------------- 0.0% 2.4% 1 0.076s + +Finished transaction in 6.12 secs (5.64u,0.008s) (successful) +Closed under the global context +total time: 3.164s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.6% 1 3.088s +─ReflectiveTactics.do_reflective_pipelin 0.0% 74.1% 1 2.344s +─ReflectiveTactics.solve_side_conditions 0.0% 72.9% 1 2.308s +─ReflectiveTactics.do_reify ------------ 0.0% 38.6% 1 1.220s +─Reify.Reify_rhs_gen ------------------- 1.5% 37.2% 1 1.176s +─ReflectiveTactics.solve_post_reified_si 0.9% 34.4% 1 1.088s +─UnifyAbstractReflexivity.unify_transfor 19.2% 23.9% 7 0.204s +─Glue.refine_to_reflective_glue' ------- 0.0% 23.5% 1 0.744s +─Reify.do_reify_abs_goal --------------- 19.2% 19.5% 2 0.616s +─Reify.do_reifyf_goal ------------------ 18.0% 18.3% 16 0.580s +─Glue.zrange_to_reflective ------------- 0.1% 15.4% 1 0.488s +─Glue.zrange_to_reflective_goal -------- 6.8% 11.5% 1 0.364s +─ReflectiveTactics.unify_abstract_cbv_in 6.2% 9.0% 1 0.284s +─unify (constr) (constr) --------------- 5.9% 5.9% 6 0.080s +─Glue.pattern_sig_sig_assoc ------------ 0.0% 4.6% 1 0.144s +─eexact -------------------------------- 4.4% 4.4% 18 0.012s +─Glue.pattern_proj1_sig_in_sig --------- 1.4% 4.3% 1 0.136s +─prove_interp_compile_correct ---------- 0.0% 3.9% 1 0.124s +─rewrite H ----------------------------- 3.8% 3.8% 1 0.120s +─assert (H : is_bounded_by' bounds (map' 3.8% 3.8% 2 0.064s +─rewrite ?EtaInterp.InterpExprEta ------ 3.5% 3.5% 1 0.112s +─pose proof (pf : Interpretation.Bo 2.9% 2.9% 1 0.092s +─Glue.split_BoundedWordToZ ------------- 0.1% 2.8% 1 0.088s +─tac ----------------------------------- 1.9% 2.5% 2 0.080s +─reflexivity --------------------------- 2.4% 2.4% 7 0.028s +─synthesize ---------------------------- 0.0% 2.4% 1 0.076s +─destruct_sig -------------------------- 0.0% 2.4% 4 0.040s +─destruct x ---------------------------- 2.4% 2.4% 4 0.032s +─clearbody (ne_var_list) --------------- 2.3% 2.3% 4 0.060s +─Reify.transitivity_tt ----------------- 0.1% 2.3% 2 0.036s +─transitivity -------------------------- 2.1% 2.1% 5 0.032s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.6% 1 3.088s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 74.1% 1 2.344s + │└ReflectiveTactics.solve_side_conditio 0.0% 72.9% 1 2.308s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 38.6% 1 1.220s + │ │└Reify.Reify_rhs_gen --------------- 1.5% 37.2% 1 1.176s + │ │ ├─Reify.do_reify_abs_goal --------- 19.2% 19.5% 2 0.616s + │ │ │└Reify.do_reifyf_goal ------------ 18.0% 18.3% 16 0.580s + │ │ │└eexact -------------------------- 3.9% 3.9% 16 0.012s + │ │ ├─prove_interp_compile_correct ---- 0.0% 3.9% 1 0.124s + │ │ │└rewrite ?EtaInterp.InterpExprEta 3.5% 3.5% 1 0.112s + │ │ ├─rewrite H ----------------------- 3.8% 3.8% 1 0.120s + │ │ ├─tac ----------------------------- 1.9% 2.5% 1 0.080s + │ │ └─Reify.transitivity_tt ----------- 0.1% 2.3% 2 0.036s + │ │ └transitivity -------------------- 2.0% 2.0% 4 0.032s + │ └─ReflectiveTactics.solve_post_reifie 0.9% 34.4% 1 1.088s + │ ├─UnifyAbstractReflexivity.unify_tr 19.2% 23.9% 7 0.204s + │ │└unify (constr) (constr) --------- 3.4% 3.4% 5 0.036s + │ └─ReflectiveTactics.unify_abstract_ 6.2% 9.0% 1 0.284s + │ └unify (constr) (constr) --------- 2.5% 2.5% 1 0.080s + └─Glue.refine_to_reflective_glue' ----- 0.0% 23.5% 1 0.744s + ├─Glue.zrange_to_reflective --------- 0.1% 15.4% 1 0.488s + │ ├─Glue.zrange_to_reflective_goal -- 6.8% 11.5% 1 0.364s + │ │└pose proof (pf : Interpretat 2.9% 2.9% 1 0.092s + │ └─assert (H : is_bounded_by' bounds 3.8% 3.8% 2 0.064s + ├─Glue.pattern_sig_sig_assoc -------- 0.0% 4.6% 1 0.144s + │└Glue.pattern_proj1_sig_in_sig ----- 1.4% 4.3% 1 0.136s + └─Glue.split_BoundedWordToZ --------- 0.1% 2.8% 1 0.088s + └destruct_sig ---------------------- 0.0% 2.4% 4 0.040s +─synthesize ---------------------------- 0.0% 2.4% 1 0.076s + +src/Specific/X25519/C64/fesub (real: 24.71, user: 22.65, sys: 0.24, mem: 778792 ko) +COQC src/Specific/X25519/C64/fesquare.v +Finished transaction in 6.132 secs (5.516u,0.012s) (successful) +total time: 5.480s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize ---------------------------- -0.0% 100.0% 1 5.480s +─Pipeline.refine_reflectively_gen ------ 0.0% 95.7% 1 5.244s +─ReflectiveTactics.do_reflective_pipelin 0.0% 88.6% 1 4.856s +─ReflectiveTactics.solve_side_conditions 0.0% 87.7% 1 4.804s +─ReflectiveTactics.do_reify ------------ 0.0% 53.3% 1 2.920s +─Reify.Reify_rhs_gen ------------------- 2.0% 52.5% 1 2.876s +─ReflectiveTactics.solve_post_reified_si 0.6% 34.4% 1 1.884s +─Reify.do_reify_abs_goal --------------- 33.2% 33.6% 2 1.844s +─Reify.do_reifyf_goal ------------------ 31.5% 32.0% 47 1.392s +─UnifyAbstractReflexivity.unify_transfor 21.9% 26.6% 7 0.400s +─eexact -------------------------------- 10.0% 10.0% 49 0.028s +─Glue.refine_to_reflective_glue' ------- 0.0% 7.1% 1 0.388s +─ReflectiveTactics.unify_abstract_cbv_in 5.0% 6.9% 1 0.380s +─unify (constr) (constr) --------------- 5.8% 5.8% 6 0.104s +─prove_interp_compile_correct ---------- 0.0% 5.8% 1 0.316s +─rewrite ?EtaInterp.InterpExprEta ------ 5.3% 5.3% 1 0.288s +─Glue.zrange_to_reflective ------------- 0.1% 5.1% 1 0.280s +─IntegrationTestTemporaryMiscCommon.do_r 0.1% 4.0% 1 0.220s +─Glue.zrange_to_reflective_goal -------- 3.1% 3.9% 1 0.212s +─change G' ----------------------------- 3.4% 3.4% 1 0.184s +─tac ----------------------------------- 2.0% 2.8% 2 0.156s +─rewrite H ----------------------------- 2.8% 2.8% 1 0.156s +─reflexivity --------------------------- 2.8% 2.8% 7 0.064s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize ---------------------------- -0.0% 100.0% 1 5.480s + ├─Pipeline.refine_reflectively_gen ---- 0.0% 95.7% 1 5.244s + │ ├─ReflectiveTactics.do_reflective_pip 0.0% 88.6% 1 4.856s + │ │└ReflectiveTactics.solve_side_condit 0.0% 87.7% 1 4.804s + │ │ ├─ReflectiveTactics.do_reify ------ 0.0% 53.3% 1 2.920s + │ │ │└Reify.Reify_rhs_gen ------------- 2.0% 52.5% 1 2.876s + │ │ │ ├─Reify.do_reify_abs_goal ------- 33.2% 33.6% 2 1.844s + │ │ │ │└Reify.do_reifyf_goal ---------- 31.5% 32.0% 47 1.392s + │ │ │ │└eexact ------------------------ 9.1% 9.1% 47 0.024s + │ │ │ ├─prove_interp_compile_correct -- 0.0% 5.8% 1 0.316s + │ │ │ │└rewrite ?EtaInterp.InterpExprEt 5.3% 5.3% 1 0.288s + │ │ │ ├─tac --------------------------- 2.0% 2.8% 1 0.156s + │ │ │ └─rewrite H --------------------- 2.8% 2.8% 1 0.156s + │ │ └─ReflectiveTactics.solve_post_reif 0.6% 34.4% 1 1.884s + │ │ ├─UnifyAbstractReflexivity.unify_ 21.9% 26.6% 7 0.400s + │ │ │└unify (constr) (constr) ------- 3.9% 3.9% 5 0.072s + │ │ └─ReflectiveTactics.unify_abstrac 5.0% 6.9% 1 0.380s + │ └─Glue.refine_to_reflective_glue' --- 0.0% 7.1% 1 0.388s + │ └Glue.zrange_to_reflective --------- 0.1% 5.1% 1 0.280s + │ └Glue.zrange_to_reflective_goal ---- 3.1% 3.9% 1 0.212s + └─IntegrationTestTemporaryMiscCommon.do 0.1% 4.0% 1 0.220s + └change G' --------------------------- 3.4% 3.4% 1 0.184s + +Finished transaction in 10.475 secs (9.728u,0.007s) (successful) +Closed under the global context +total time: 5.480s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize ---------------------------- -0.0% 100.0% 1 5.480s +─Pipeline.refine_reflectively_gen ------ 0.0% 95.7% 1 5.244s +─ReflectiveTactics.do_reflective_pipelin 0.0% 88.6% 1 4.856s +─ReflectiveTactics.solve_side_conditions 0.0% 87.7% 1 4.804s +─ReflectiveTactics.do_reify ------------ 0.0% 53.3% 1 2.920s +─Reify.Reify_rhs_gen ------------------- 2.0% 52.5% 1 2.876s +─ReflectiveTactics.solve_post_reified_si 0.6% 34.4% 1 1.884s +─Reify.do_reify_abs_goal --------------- 33.2% 33.6% 2 1.844s +─Reify.do_reifyf_goal ------------------ 31.5% 32.0% 47 1.392s +─UnifyAbstractReflexivity.unify_transfor 21.9% 26.6% 7 0.400s +─eexact -------------------------------- 10.0% 10.0% 49 0.028s +─Glue.refine_to_reflective_glue' ------- 0.0% 7.1% 1 0.388s +─ReflectiveTactics.unify_abstract_cbv_in 5.0% 6.9% 1 0.380s +─unify (constr) (constr) --------------- 5.8% 5.8% 6 0.104s +─prove_interp_compile_correct ---------- 0.0% 5.8% 1 0.316s +─rewrite ?EtaInterp.InterpExprEta ------ 5.3% 5.3% 1 0.288s +─Glue.zrange_to_reflective ------------- 0.1% 5.1% 1 0.280s +─IntegrationTestTemporaryMiscCommon.do_r 0.1% 4.0% 1 0.220s +─Glue.zrange_to_reflective_goal -------- 3.1% 3.9% 1 0.212s +─change G' ----------------------------- 3.4% 3.4% 1 0.184s +─tac ----------------------------------- 2.0% 2.8% 2 0.156s +─rewrite H ----------------------------- 2.8% 2.8% 1 0.156s +─reflexivity --------------------------- 2.8% 2.8% 7 0.064s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize ---------------------------- -0.0% 100.0% 1 5.480s + ├─Pipeline.refine_reflectively_gen ---- 0.0% 95.7% 1 5.244s + │ ├─ReflectiveTactics.do_reflective_pip 0.0% 88.6% 1 4.856s + │ │└ReflectiveTactics.solve_side_condit 0.0% 87.7% 1 4.804s + │ │ ├─ReflectiveTactics.do_reify ------ 0.0% 53.3% 1 2.920s + │ │ │└Reify.Reify_rhs_gen ------------- 2.0% 52.5% 1 2.876s + │ │ │ ├─Reify.do_reify_abs_goal ------- 33.2% 33.6% 2 1.844s + │ │ │ │└Reify.do_reifyf_goal ---------- 31.5% 32.0% 47 1.392s + │ │ │ │└eexact ------------------------ 9.1% 9.1% 47 0.024s + │ │ │ ├─prove_interp_compile_correct -- 0.0% 5.8% 1 0.316s + │ │ │ │└rewrite ?EtaInterp.InterpExprEt 5.3% 5.3% 1 0.288s + │ │ │ ├─tac --------------------------- 2.0% 2.8% 1 0.156s + │ │ │ └─rewrite H --------------------- 2.8% 2.8% 1 0.156s + │ │ └─ReflectiveTactics.solve_post_reif 0.6% 34.4% 1 1.884s + │ │ ├─UnifyAbstractReflexivity.unify_ 21.9% 26.6% 7 0.400s + │ │ │└unify (constr) (constr) ------- 3.9% 3.9% 5 0.072s + │ │ └─ReflectiveTactics.unify_abstrac 5.0% 6.9% 1 0.380s + │ └─Glue.refine_to_reflective_glue' --- 0.0% 7.1% 1 0.388s + │ └Glue.zrange_to_reflective --------- 0.1% 5.1% 1 0.280s + │ └Glue.zrange_to_reflective_goal ---- 3.1% 3.9% 1 0.212s + └─IntegrationTestTemporaryMiscCommon.do 0.1% 4.0% 1 0.220s + └change G' --------------------------- 3.4% 3.4% 1 0.184s + +src/Specific/X25519/C64/fesquare (real: 33.08, user: 30.13, sys: 0.24, mem: 799620 ko) +COQC src/Specific/X25519/C64/femulDisplay > src/Specific/X25519/C64/femulDisplay.log +COQC src/Specific/X25519/C64/freeze.v +Finished transaction in 7.307 secs (6.763u,0.011s) (successful) +total time: 6.732s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_freeze --------------------- 0.0% 100.0% 1 6.732s +─Pipeline.refine_reflectively_gen ------ 0.0% 99.3% 1 6.684s +─ReflectiveTactics.do_reflective_pipelin 0.0% 92.8% 1 6.248s +─ReflectiveTactics.solve_side_conditions 0.0% 92.0% 1 6.192s +─ReflectiveTactics.do_reify ------------ -0.0% 60.3% 1 4.060s +─Reify.Reify_rhs_gen ------------------- 1.5% 59.6% 1 4.012s +─Reify.do_reify_abs_goal --------------- 42.4% 42.7% 2 2.876s +─Reify.do_reifyf_goal ------------------ 41.3% 41.7% 129 2.804s +─ReflectiveTactics.solve_post_reified_si 0.6% 31.7% 1 2.132s +─UnifyAbstractReflexivity.unify_transfor 21.7% 25.8% 7 0.424s +─eexact -------------------------------- 13.7% 13.7% 131 0.036s +─Glue.refine_to_reflective_glue' ------- 0.0% 6.5% 1 0.436s +─prove_interp_compile_correct ---------- 0.0% 5.1% 1 0.344s +─ReflectiveTactics.unify_abstract_cbv_in 3.4% 5.0% 1 0.336s +─rewrite ?EtaInterp.InterpExprEta ------ 4.7% 4.7% 1 0.316s +─unify (constr) (constr) --------------- 4.6% 4.6% 6 0.100s +─Glue.zrange_to_reflective ------------- 0.0% 4.2% 1 0.280s +─Glue.zrange_to_reflective_goal -------- 2.4% 3.3% 1 0.220s +─Reify.transitivity_tt ----------------- 0.1% 2.6% 2 0.116s +─rewrite H ----------------------------- 2.6% 2.6% 1 0.172s +─tac ----------------------------------- 1.5% 2.3% 2 0.156s +─reflexivity --------------------------- 2.3% 2.3% 7 0.052s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_freeze --------------------- 0.0% 100.0% 1 6.732s +└Pipeline.refine_reflectively_gen ------ 0.0% 99.3% 1 6.684s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 92.8% 1 6.248s + │└ReflectiveTactics.solve_side_conditio 0.0% 92.0% 1 6.192s + │ ├─ReflectiveTactics.do_reify -------- -0.0% 60.3% 1 4.060s + │ │└Reify.Reify_rhs_gen --------------- 1.5% 59.6% 1 4.012s + │ │ ├─Reify.do_reify_abs_goal --------- 42.4% 42.7% 2 2.876s + │ │ │└Reify.do_reifyf_goal ------------ 41.3% 41.7% 129 2.804s + │ │ │└eexact -------------------------- 13.0% 13.0% 129 0.036s + │ │ ├─prove_interp_compile_correct ---- 0.0% 5.1% 1 0.344s + │ │ │└rewrite ?EtaInterp.InterpExprEta 4.7% 4.7% 1 0.316s + │ │ ├─Reify.transitivity_tt ----------- 0.1% 2.6% 2 0.116s + │ │ ├─rewrite H ----------------------- 2.6% 2.6% 1 0.172s + │ │ └─tac ----------------------------- 1.5% 2.3% 1 0.156s + │ └─ReflectiveTactics.solve_post_reifie 0.6% 31.7% 1 2.132s + │ ├─UnifyAbstractReflexivity.unify_tr 21.7% 25.8% 7 0.424s + │ │└unify (constr) (constr) --------- 3.1% 3.1% 5 0.084s + │ └─ReflectiveTactics.unify_abstract_ 3.4% 5.0% 1 0.336s + └─Glue.refine_to_reflective_glue' ----- 0.0% 6.5% 1 0.436s + └Glue.zrange_to_reflective ----------- 0.0% 4.2% 1 0.280s + └Glue.zrange_to_reflective_goal ------ 2.4% 3.3% 1 0.220s + +Finished transaction in 10.495 secs (9.756u,0.s) (successful) +Closed under the global context +total time: 6.732s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_freeze --------------------- 0.0% 100.0% 1 6.732s +─Pipeline.refine_reflectively_gen ------ 0.0% 99.3% 1 6.684s +─ReflectiveTactics.do_reflective_pipelin 0.0% 92.8% 1 6.248s +─ReflectiveTactics.solve_side_conditions 0.0% 92.0% 1 6.192s +─ReflectiveTactics.do_reify ------------ -0.0% 60.3% 1 4.060s +─Reify.Reify_rhs_gen ------------------- 1.5% 59.6% 1 4.012s +─Reify.do_reify_abs_goal --------------- 42.4% 42.7% 2 2.876s +─Reify.do_reifyf_goal ------------------ 41.3% 41.7% 129 2.804s +─ReflectiveTactics.solve_post_reified_si 0.6% 31.7% 1 2.132s +─UnifyAbstractReflexivity.unify_transfor 21.7% 25.8% 7 0.424s +─eexact -------------------------------- 13.7% 13.7% 131 0.036s +─Glue.refine_to_reflective_glue' ------- 0.0% 6.5% 1 0.436s +─prove_interp_compile_correct ---------- 0.0% 5.1% 1 0.344s +─ReflectiveTactics.unify_abstract_cbv_in 3.4% 5.0% 1 0.336s +─rewrite ?EtaInterp.InterpExprEta ------ 4.7% 4.7% 1 0.316s +─unify (constr) (constr) --------------- 4.6% 4.6% 6 0.100s +─Glue.zrange_to_reflective ------------- 0.0% 4.2% 1 0.280s +─Glue.zrange_to_reflective_goal -------- 2.4% 3.3% 1 0.220s +─Reify.transitivity_tt ----------------- 0.1% 2.6% 2 0.116s +─rewrite H ----------------------------- 2.6% 2.6% 1 0.172s +─tac ----------------------------------- 1.5% 2.3% 2 0.156s +─reflexivity --------------------------- 2.3% 2.3% 7 0.052s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_freeze --------------------- 0.0% 100.0% 1 6.732s +└Pipeline.refine_reflectively_gen ------ 0.0% 99.3% 1 6.684s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 92.8% 1 6.248s + │└ReflectiveTactics.solve_side_conditio 0.0% 92.0% 1 6.192s + │ ├─ReflectiveTactics.do_reify -------- -0.0% 60.3% 1 4.060s + │ │└Reify.Reify_rhs_gen --------------- 1.5% 59.6% 1 4.012s + │ │ ├─Reify.do_reify_abs_goal --------- 42.4% 42.7% 2 2.876s + │ │ │└Reify.do_reifyf_goal ------------ 41.3% 41.7% 129 2.804s + │ │ │└eexact -------------------------- 13.0% 13.0% 129 0.036s + │ │ ├─prove_interp_compile_correct ---- 0.0% 5.1% 1 0.344s + │ │ │└rewrite ?EtaInterp.InterpExprEta 4.7% 4.7% 1 0.316s + │ │ ├─Reify.transitivity_tt ----------- 0.1% 2.6% 2 0.116s + │ │ ├─rewrite H ----------------------- 2.6% 2.6% 1 0.172s + │ │ └─tac ----------------------------- 1.5% 2.3% 1 0.156s + │ └─ReflectiveTactics.solve_post_reifie 0.6% 31.7% 1 2.132s + │ ├─UnifyAbstractReflexivity.unify_tr 21.7% 25.8% 7 0.424s + │ │└unify (constr) (constr) --------- 3.1% 3.1% 5 0.084s + │ └─ReflectiveTactics.unify_abstract_ 3.4% 5.0% 1 0.336s + └─Glue.refine_to_reflective_glue' ----- 0.0% 6.5% 1 0.436s + └Glue.zrange_to_reflective ----------- 0.0% 4.2% 1 0.280s + └Glue.zrange_to_reflective_goal ------ 2.4% 3.3% 1 0.220s + +src/Specific/X25519/C64/freeze (real: 34.35, user: 31.50, sys: 0.24, mem: 828104 ko) +COQC src/Specific/NISTP256/AMD64/feadd.v +Finished transaction in 8.784 secs (8.176u,0.011s) (successful) +total time: 8.140s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 52.4% 1 4.268s +─synthesize_montgomery ----------------- 0.0% 47.6% 1 3.872s +─ReflectiveTactics.do_reflective_pipelin 0.0% 43.8% 1 3.568s +─ReflectiveTactics.solve_side_conditions 0.0% 43.2% 1 3.520s +─IntegrationTestTemporaryMiscCommon.fact 1.4% 23.6% 1 1.924s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 22.1% 1 1.796s +─ReflectiveTactics.do_reify ------------ 0.1% 21.7% 1 1.768s +─ReflectiveTactics.solve_post_reified_si 0.6% 21.5% 1 1.752s +─Reify.Reify_rhs_gen ------------------- 1.0% 20.9% 1 1.704s +─op_sig_side_conditions_t -------------- 0.0% 20.0% 1 1.624s +─DestructHyps.do_all_matches_then ------ 0.0% 20.0% 8 0.244s +─DestructHyps.do_one_match_then -------- 0.7% 19.9% 44 0.052s +─do_tac -------------------------------- 0.0% 19.2% 36 0.052s +─destruct H ---------------------------- 19.2% 19.2% 36 0.052s +─rewrite <- (lem : lemT) by by_tac ltac: 0.2% 17.3% 1 1.408s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 17.3% 1 1.408s +─by_tac -------------------------------- 0.0% 17.1% 4 0.504s +─rewrite <- (ZRange.is_bounded_by_None_r 16.7% 16.7% 8 0.344s +─UnifyAbstractReflexivity.unify_transfor 13.3% 16.1% 7 0.360s +─Reify.do_reify_abs_goal --------------- 9.9% 10.1% 2 0.820s +─Reify.do_reifyf_goal ------------------ 9.1% 9.3% 93 0.748s +─Glue.refine_to_reflective_glue' ------- 0.0% 8.6% 1 0.700s +─Glue.zrange_to_reflective ------------- 0.0% 5.3% 1 0.432s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 4.8% 1 0.388s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.9% 4.6% 3 0.368s +─ReflectiveTactics.unify_abstract_cbv_in 3.3% 4.5% 1 0.368s +─Glue.zrange_to_reflective_goal -------- 2.6% 4.0% 1 0.324s +─k ------------------------------------- 3.5% 3.6% 1 0.296s +─unify (constr) (constr) --------------- 3.3% 3.3% 8 0.092s +─rewrite H ----------------------------- 2.6% 2.6% 2 0.196s +─eexact -------------------------------- 2.6% 2.6% 95 0.024s +─prove_interp_compile_correct ---------- 0.0% 2.5% 1 0.204s +─apply (fun f => MapProjections.proj2 2.4% 2.4% 2 0.120s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 52.4% 1 4.268s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 43.8% 1 3.568s + │└ReflectiveTactics.solve_side_conditio 0.0% 43.2% 1 3.520s + │ ├─ReflectiveTactics.do_reify -------- 0.1% 21.7% 1 1.768s + │ │└Reify.Reify_rhs_gen --------------- 1.0% 20.9% 1 1.704s + │ │ ├─Reify.do_reify_abs_goal --------- 9.9% 10.1% 2 0.820s + │ │ │└Reify.do_reifyf_goal ------------ 9.1% 9.3% 93 0.748s + │ │ │└eexact -------------------------- 2.3% 2.3% 93 0.024s + │ │ ├─prove_interp_compile_correct ---- 0.0% 2.5% 1 0.204s + │ │ └─rewrite H ----------------------- 2.4% 2.4% 1 0.196s + │ └─ReflectiveTactics.solve_post_reifie 0.6% 21.5% 1 1.752s + │ ├─UnifyAbstractReflexivity.unify_tr 13.3% 16.1% 7 0.360s + │ │└unify (constr) (constr) --------- 2.2% 2.2% 5 0.064s + │ └─ReflectiveTactics.unify_abstract_ 3.3% 4.5% 1 0.368s + └─Glue.refine_to_reflective_glue' ----- 0.0% 8.6% 1 0.700s + └Glue.zrange_to_reflective ----------- 0.0% 5.3% 1 0.432s + └Glue.zrange_to_reflective_goal ------ 2.6% 4.0% 1 0.324s +─synthesize_montgomery ----------------- 0.0% 47.6% 1 3.872s + ├─IntegrationTestTemporaryMiscCommon.fa 1.4% 23.6% 1 1.924s + │└op_sig_side_conditions_t ------------ 0.0% 20.0% 1 1.624s + │ ├─DestructHyps.do_all_matches_then -- 0.0% 11.4% 4 0.244s + │ │└DestructHyps.do_one_match_then ---- 0.3% 11.4% 24 0.052s + │ │└do_tac ---------------------------- 0.0% 11.1% 20 0.052s + │ │└destruct H ------------------------ 11.1% 11.1% 20 0.052s + │ └─rewrite <- (ZRange.is_bounded_by_No 8.4% 8.4% 4 0.328s + └─IntegrationTestTemporaryMiscCommon.do 0.0% 22.1% 1 1.796s + ├─IntegrationTestTemporaryMiscCommon. 0.0% 17.3% 1 1.408s + │└rewrite <- (lem : lemT) by by_tac l 0.2% 17.3% 1 1.408s + │└by_tac ---------------------------- 0.0% 17.1% 4 0.504s + │ ├─DestructHyps.do_all_matches_then 0.0% 8.6% 4 0.184s + │ │└DestructHyps.do_one_match_then -- 0.3% 8.5% 20 0.052s + │ │└do_tac -------------------------- 0.0% 8.2% 16 0.052s + │ │└destruct H ---------------------- 8.2% 8.2% 16 0.052s + │ └─rewrite <- (ZRange.is_bounded_by_ 8.3% 8.3% 4 0.344s + └─IntegrationTestTemporaryMiscCommon. 0.0% 4.8% 1 0.388s + └<Crypto.Util.Tactics.MoveLetIn.with 0.9% 4.6% 3 0.368s + └k --------------------------------- 3.5% 3.6% 1 0.296s + +Finished transaction in 13.363 secs (12.516u,0.008s) (successful) +Closed under the global context +total time: 8.140s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 52.4% 1 4.268s +─synthesize_montgomery ----------------- 0.0% 47.6% 1 3.872s +─ReflectiveTactics.do_reflective_pipelin 0.0% 43.8% 1 3.568s +─ReflectiveTactics.solve_side_conditions 0.0% 43.2% 1 3.520s +─IntegrationTestTemporaryMiscCommon.fact 1.4% 23.6% 1 1.924s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 22.1% 1 1.796s +─ReflectiveTactics.do_reify ------------ 0.1% 21.7% 1 1.768s +─ReflectiveTactics.solve_post_reified_si 0.6% 21.5% 1 1.752s +─Reify.Reify_rhs_gen ------------------- 1.0% 20.9% 1 1.704s +─op_sig_side_conditions_t -------------- 0.0% 20.0% 1 1.624s +─DestructHyps.do_all_matches_then ------ 0.0% 20.0% 8 0.244s +─DestructHyps.do_one_match_then -------- 0.7% 19.9% 44 0.052s +─do_tac -------------------------------- 0.0% 19.2% 36 0.052s +─destruct H ---------------------------- 19.2% 19.2% 36 0.052s +─rewrite <- (lem : lemT) by by_tac ltac: 0.2% 17.3% 1 1.408s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 17.3% 1 1.408s +─by_tac -------------------------------- 0.0% 17.1% 4 0.504s +─rewrite <- (ZRange.is_bounded_by_None_r 16.7% 16.7% 8 0.344s +─UnifyAbstractReflexivity.unify_transfor 13.3% 16.1% 7 0.360s +─Reify.do_reify_abs_goal --------------- 9.9% 10.1% 2 0.820s +─Reify.do_reifyf_goal ------------------ 9.1% 9.3% 93 0.748s +─Glue.refine_to_reflective_glue' ------- 0.0% 8.6% 1 0.700s +─Glue.zrange_to_reflective ------------- 0.0% 5.3% 1 0.432s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 4.8% 1 0.388s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.9% 4.6% 3 0.368s +─ReflectiveTactics.unify_abstract_cbv_in 3.3% 4.5% 1 0.368s +─Glue.zrange_to_reflective_goal -------- 2.6% 4.0% 1 0.324s +─k ------------------------------------- 3.5% 3.6% 1 0.296s +─unify (constr) (constr) --------------- 3.3% 3.3% 8 0.092s +─rewrite H ----------------------------- 2.6% 2.6% 2 0.196s +─eexact -------------------------------- 2.6% 2.6% 95 0.024s +─prove_interp_compile_correct ---------- 0.0% 2.5% 1 0.204s +─apply (fun f => MapProjections.proj2 2.4% 2.4% 2 0.120s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 52.4% 1 4.268s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 43.8% 1 3.568s + │└ReflectiveTactics.solve_side_conditio 0.0% 43.2% 1 3.520s + │ ├─ReflectiveTactics.do_reify -------- 0.1% 21.7% 1 1.768s + │ │└Reify.Reify_rhs_gen --------------- 1.0% 20.9% 1 1.704s + │ │ ├─Reify.do_reify_abs_goal --------- 9.9% 10.1% 2 0.820s + │ │ │└Reify.do_reifyf_goal ------------ 9.1% 9.3% 93 0.748s + │ │ │└eexact -------------------------- 2.3% 2.3% 93 0.024s + │ │ ├─prove_interp_compile_correct ---- 0.0% 2.5% 1 0.204s + │ │ └─rewrite H ----------------------- 2.4% 2.4% 1 0.196s + │ └─ReflectiveTactics.solve_post_reifie 0.6% 21.5% 1 1.752s + │ ├─UnifyAbstractReflexivity.unify_tr 13.3% 16.1% 7 0.360s + │ │└unify (constr) (constr) --------- 2.2% 2.2% 5 0.064s + │ └─ReflectiveTactics.unify_abstract_ 3.3% 4.5% 1 0.368s + └─Glue.refine_to_reflective_glue' ----- 0.0% 8.6% 1 0.700s + └Glue.zrange_to_reflective ----------- 0.0% 5.3% 1 0.432s + └Glue.zrange_to_reflective_goal ------ 2.6% 4.0% 1 0.324s +─synthesize_montgomery ----------------- 0.0% 47.6% 1 3.872s + ├─IntegrationTestTemporaryMiscCommon.fa 1.4% 23.6% 1 1.924s + │└op_sig_side_conditions_t ------------ 0.0% 20.0% 1 1.624s + │ ├─DestructHyps.do_all_matches_then -- 0.0% 11.4% 4 0.244s + │ │└DestructHyps.do_one_match_then ---- 0.3% 11.4% 24 0.052s + │ │└do_tac ---------------------------- 0.0% 11.1% 20 0.052s + │ │└destruct H ------------------------ 11.1% 11.1% 20 0.052s + │ └─rewrite <- (ZRange.is_bounded_by_No 8.4% 8.4% 4 0.328s + └─IntegrationTestTemporaryMiscCommon.do 0.0% 22.1% 1 1.796s + ├─IntegrationTestTemporaryMiscCommon. 0.0% 17.3% 1 1.408s + │└rewrite <- (lem : lemT) by by_tac l 0.2% 17.3% 1 1.408s + │└by_tac ---------------------------- 0.0% 17.1% 4 0.504s + │ ├─DestructHyps.do_all_matches_then 0.0% 8.6% 4 0.184s + │ │└DestructHyps.do_one_match_then -- 0.3% 8.5% 20 0.052s + │ │└do_tac -------------------------- 0.0% 8.2% 16 0.052s + │ │└destruct H ---------------------- 8.2% 8.2% 16 0.052s + │ └─rewrite <- (ZRange.is_bounded_by_ 8.3% 8.3% 4 0.344s + └─IntegrationTestTemporaryMiscCommon. 0.0% 4.8% 1 0.388s + └<Crypto.Util.Tactics.MoveLetIn.with 0.9% 4.6% 3 0.368s + └k --------------------------------- 3.5% 3.6% 1 0.296s + +src/Specific/NISTP256/AMD64/feadd (real: 38.19, user: 35.40, sys: 0.30, mem: 799216 ko) +COQC src/Specific/NISTP256/AMD64/fenz.v +Finished transaction in 6.356 secs (5.82u,0.004s) (successful) +total time: 5.800s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_nonzero -------------------- 0.0% 100.0% 1 5.800s +─IntegrationTestTemporaryMiscCommon.nonz 0.2% 85.5% 1 4.960s +─destruct (Decidable.dec x), (Decidable. 37.4% 37.4% 1 2.168s +─destruct (Decidable.dec x) as [H| H] -- 22.0% 22.0% 1 1.276s +─Pipeline.refine_reflectively_gen ------ 0.0% 14.5% 1 0.840s +─ReflectiveTactics.do_reflective_pipelin 0.0% 10.9% 1 0.632s +─ReflectiveTactics.solve_side_conditions 0.0% 10.6% 1 0.612s +─ReflectiveTactics.solve_post_reified_si 0.3% 8.5% 1 0.492s +─IntegrationTestTemporaryMiscCommon.op_s 0.1% 8.1% 2 0.368s +─rewrite <- (ZRange.is_bounded_by_None_r 5.2% 5.2% 2 0.288s +─UnifyAbstractReflexivity.unify_transfor 3.4% 4.3% 7 0.076s +─ReflectiveTactics.unify_abstract_cbv_in 2.8% 3.8% 1 0.220s +─Glue.refine_to_reflective_glue' ------- 0.1% 3.6% 1 0.208s +─rewrite H' ---------------------------- 3.4% 3.4% 1 0.200s +─generalize dependent (constr) --------- 3.0% 3.0% 4 0.060s +─congruence ---------------------------- 2.8% 2.8% 1 0.160s +─do_tac -------------------------------- 0.0% 2.6% 4 0.044s +─destruct H ---------------------------- 2.6% 2.6% 4 0.044s +─IntegrationTestTemporaryMiscCommon.do_s 0.1% 2.6% 1 0.152s +─DestructHyps.do_one_match_then -------- 0.0% 2.6% 6 0.044s +─DestructHyps.do_all_matches_then ------ 0.0% 2.6% 2 0.076s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.4% 2.5% 3 0.140s +─Glue.zrange_to_reflective ------------- 0.0% 2.2% 1 0.128s +─rewrite H ----------------------------- 1.9% 2.1% 3 0.112s +─ReflectiveTactics.do_reify ------------ 0.0% 2.1% 1 0.120s +─k ------------------------------------- 1.9% 2.0% 1 0.116s +─Reify.Reify_rhs_gen ------------------- 0.1% 2.0% 1 0.116s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_nonzero -------------------- 0.0% 100.0% 1 5.800s + ├─IntegrationTestTemporaryMiscCommon.no 0.2% 85.5% 1 4.960s + │ ├─destruct (Decidable.dec x), (Decida 37.4% 37.4% 1 2.168s + │ ├─destruct (Decidable.dec x) as [H| H 22.0% 22.0% 1 1.276s + │ ├─IntegrationTestTemporaryMiscCommon. 0.1% 8.1% 2 0.368s + │ │ ├─rewrite <- (ZRange.is_bounded_by_ 5.2% 5.2% 2 0.288s + │ │ └─DestructHyps.do_all_matches_then 0.0% 2.6% 2 0.076s + │ │ └DestructHyps.do_one_match_then -- 0.0% 2.6% 6 0.044s + │ │ └do_tac -------------------------- 0.0% 2.6% 4 0.044s + │ │ └destruct H ---------------------- 2.6% 2.6% 4 0.044s + │ ├─rewrite H' ------------------------ 3.4% 3.4% 1 0.200s + │ ├─generalize dependent (constr) ----- 3.0% 3.0% 4 0.060s + │ ├─congruence ------------------------ 2.8% 2.8% 1 0.160s + │ ├─IntegrationTestTemporaryMiscCommon. 0.1% 2.6% 1 0.152s + │ │└<Crypto.Util.Tactics.MoveLetIn.with 0.4% 2.5% 3 0.140s + │ │└k --------------------------------- 1.9% 2.0% 1 0.116s + │ └─rewrite H ------------------------- 1.7% 2.0% 2 0.112s + └─Pipeline.refine_reflectively_gen ---- 0.0% 14.5% 1 0.840s + ├─ReflectiveTactics.do_reflective_pip 0.0% 10.9% 1 0.632s + │└ReflectiveTactics.solve_side_condit 0.0% 10.6% 1 0.612s + │ ├─ReflectiveTactics.solve_post_reif 0.3% 8.5% 1 0.492s + │ │ ├─UnifyAbstractReflexivity.unify_ 3.4% 4.3% 7 0.076s + │ │ └─ReflectiveTactics.unify_abstrac 2.8% 3.8% 1 0.220s + │ └─ReflectiveTactics.do_reify ------ 0.0% 2.1% 1 0.120s + │ └Reify.Reify_rhs_gen ------------- 0.1% 2.0% 1 0.116s + └─Glue.refine_to_reflective_glue' --- 0.1% 3.6% 1 0.208s + └Glue.zrange_to_reflective --------- 0.0% 2.2% 1 0.128s + +Finished transaction in 6.657 secs (6.299u,0.s) (successful) +Closed under the global context +total time: 5.800s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_nonzero -------------------- 0.0% 100.0% 1 5.800s +─IntegrationTestTemporaryMiscCommon.nonz 0.2% 85.5% 1 4.960s +─destruct (Decidable.dec x), (Decidable. 37.4% 37.4% 1 2.168s +─destruct (Decidable.dec x) as [H| H] -- 22.0% 22.0% 1 1.276s +─Pipeline.refine_reflectively_gen ------ 0.0% 14.5% 1 0.840s +─ReflectiveTactics.do_reflective_pipelin 0.0% 10.9% 1 0.632s +─ReflectiveTactics.solve_side_conditions 0.0% 10.6% 1 0.612s +─ReflectiveTactics.solve_post_reified_si 0.3% 8.5% 1 0.492s +─IntegrationTestTemporaryMiscCommon.op_s 0.1% 8.1% 2 0.368s +─rewrite <- (ZRange.is_bounded_by_None_r 5.2% 5.2% 2 0.288s +─UnifyAbstractReflexivity.unify_transfor 3.4% 4.3% 7 0.076s +─ReflectiveTactics.unify_abstract_cbv_in 2.8% 3.8% 1 0.220s +─Glue.refine_to_reflective_glue' ------- 0.1% 3.6% 1 0.208s +─rewrite H' ---------------------------- 3.4% 3.4% 1 0.200s +─generalize dependent (constr) --------- 3.0% 3.0% 4 0.060s +─congruence ---------------------------- 2.8% 2.8% 1 0.160s +─do_tac -------------------------------- 0.0% 2.6% 4 0.044s +─destruct H ---------------------------- 2.6% 2.6% 4 0.044s +─IntegrationTestTemporaryMiscCommon.do_s 0.1% 2.6% 1 0.152s +─DestructHyps.do_one_match_then -------- 0.0% 2.6% 6 0.044s +─DestructHyps.do_all_matches_then ------ 0.0% 2.6% 2 0.076s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.4% 2.5% 3 0.140s +─Glue.zrange_to_reflective ------------- 0.0% 2.2% 1 0.128s +─rewrite H ----------------------------- 1.9% 2.1% 3 0.112s +─ReflectiveTactics.do_reify ------------ 0.0% 2.1% 1 0.120s +─k ------------------------------------- 1.9% 2.0% 1 0.116s +─Reify.Reify_rhs_gen ------------------- 0.1% 2.0% 1 0.116s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_nonzero -------------------- 0.0% 100.0% 1 5.800s + ├─IntegrationTestTemporaryMiscCommon.no 0.2% 85.5% 1 4.960s + │ ├─destruct (Decidable.dec x), (Decida 37.4% 37.4% 1 2.168s + │ ├─destruct (Decidable.dec x) as [H| H 22.0% 22.0% 1 1.276s + │ ├─IntegrationTestTemporaryMiscCommon. 0.1% 8.1% 2 0.368s + │ │ ├─rewrite <- (ZRange.is_bounded_by_ 5.2% 5.2% 2 0.288s + │ │ └─DestructHyps.do_all_matches_then 0.0% 2.6% 2 0.076s + │ │ └DestructHyps.do_one_match_then -- 0.0% 2.6% 6 0.044s + │ │ └do_tac -------------------------- 0.0% 2.6% 4 0.044s + │ │ └destruct H ---------------------- 2.6% 2.6% 4 0.044s + │ ├─rewrite H' ------------------------ 3.4% 3.4% 1 0.200s + │ ├─generalize dependent (constr) ----- 3.0% 3.0% 4 0.060s + │ ├─congruence ------------------------ 2.8% 2.8% 1 0.160s + │ ├─IntegrationTestTemporaryMiscCommon. 0.1% 2.6% 1 0.152s + │ │└<Crypto.Util.Tactics.MoveLetIn.with 0.4% 2.5% 3 0.140s + │ │└k --------------------------------- 1.9% 2.0% 1 0.116s + │ └─rewrite H ------------------------- 1.7% 2.0% 2 0.112s + └─Pipeline.refine_reflectively_gen ---- 0.0% 14.5% 1 0.840s + ├─ReflectiveTactics.do_reflective_pip 0.0% 10.9% 1 0.632s + │└ReflectiveTactics.solve_side_condit 0.0% 10.6% 1 0.612s + │ ├─ReflectiveTactics.solve_post_reif 0.3% 8.5% 1 0.492s + │ │ ├─UnifyAbstractReflexivity.unify_ 3.4% 4.3% 7 0.076s + │ │ └─ReflectiveTactics.unify_abstrac 2.8% 3.8% 1 0.220s + │ └─ReflectiveTactics.do_reify ------ 0.0% 2.1% 1 0.120s + │ └Reify.Reify_rhs_gen ------------- 0.1% 2.0% 1 0.116s + └─Glue.refine_to_reflective_glue' --- 0.1% 3.6% 1 0.208s + └Glue.zrange_to_reflective --------- 0.0% 2.2% 1 0.128s + +src/Specific/NISTP256/AMD64/fenz (real: 27.81, user: 25.50, sys: 0.22, mem: 756080 ko) +COQC src/Specific/NISTP256/AMD64/feopp.v +Finished transaction in 7.73 secs (7.112u,0.008s) (successful) +total time: 7.072s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 62.5% 1 4.420s +─IntegrationTestTemporaryMiscCommon.fact 18.7% 51.6% 1 3.648s +─Pipeline.refine_reflectively_gen ------ 0.0% 37.5% 1 2.652s +─ReflectiveTactics.do_reflective_pipelin 0.0% 32.6% 1 2.308s +─ReflectiveTactics.solve_side_conditions 0.0% 32.2% 1 2.276s +─reflexivity --------------------------- 24.8% 24.8% 8 1.700s +─ReflectiveTactics.solve_post_reified_si 0.5% 18.5% 1 1.308s +─ReflectiveTactics.do_reify ------------ 0.0% 13.7% 1 0.968s +─UnifyAbstractReflexivity.unify_transfor 11.2% 13.6% 7 0.284s +─Reify.Reify_rhs_gen ------------------- 0.6% 13.4% 1 0.948s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 9.7% 1 0.684s +─rewrite <- (ZRange.is_bounded_by_None_r 9.0% 9.0% 4 0.328s +─op_sig_side_conditions_t -------------- 0.0% 7.8% 1 0.552s +─rewrite <- (lem : lemT) by by_tac ltac: 0.1% 7.4% 1 0.520s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 7.4% 1 0.520s +─by_tac -------------------------------- 0.0% 7.2% 2 0.404s +─Reify.do_reify_abs_goal --------------- 7.1% 7.2% 2 0.512s +─Reify.do_reifyf_goal ------------------ 6.6% 6.7% 62 0.472s +─DestructHyps.do_one_match_then -------- 0.2% 5.8% 14 0.048s +─DestructHyps.do_all_matches_then ------ 0.0% 5.8% 4 0.124s +─do_tac -------------------------------- 0.0% 5.6% 10 0.048s +─destruct H ---------------------------- 5.6% 5.6% 10 0.048s +─Glue.refine_to_reflective_glue' ------- 0.0% 4.9% 1 0.344s +─ReflectiveTactics.unify_abstract_cbv_in 2.9% 4.2% 1 0.300s +─Glue.zrange_to_reflective ------------- 0.0% 3.3% 1 0.232s +─unify (constr) (constr) --------------- 3.2% 3.2% 7 0.088s +─Glue.zrange_to_reflective_goal -------- 1.9% 2.6% 1 0.184s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 2.3% 1 0.164s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.4% 2.2% 3 0.152s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 62.5% 1 4.420s + ├─IntegrationTestTemporaryMiscCommon.fa 18.7% 51.6% 1 3.648s + │ ├─reflexivity ----------------------- 24.0% 24.0% 1 1.700s + │ └─op_sig_side_conditions_t ---------- 0.0% 7.8% 1 0.552s + │ ├─rewrite <- (ZRange.is_bounded_by_ 4.2% 4.2% 2 0.284s + │ └─DestructHyps.do_all_matches_then 0.0% 3.5% 2 0.124s + │ └DestructHyps.do_one_match_then -- 0.2% 3.5% 8 0.044s + │ └do_tac -------------------------- 0.0% 3.3% 6 0.040s + │ └destruct H ---------------------- 3.3% 3.3% 6 0.040s + └─IntegrationTestTemporaryMiscCommon.do 0.0% 9.7% 1 0.684s + ├─IntegrationTestTemporaryMiscCommon. 0.0% 7.4% 1 0.520s + │└rewrite <- (lem : lemT) by by_tac l 0.1% 7.4% 1 0.520s + │└by_tac ---------------------------- 0.0% 7.2% 2 0.404s + │ ├─rewrite <- (ZRange.is_bounded_by_ 4.8% 4.8% 2 0.328s + │ └─DestructHyps.do_all_matches_then 0.0% 2.3% 2 0.088s + │ └DestructHyps.do_one_match_then -- 0.0% 2.3% 6 0.048s + │ └do_tac -------------------------- 0.0% 2.3% 4 0.048s + │ └destruct H ---------------------- 2.3% 2.3% 4 0.048s + └─IntegrationTestTemporaryMiscCommon. 0.0% 2.3% 1 0.164s + └<Crypto.Util.Tactics.MoveLetIn.with 0.4% 2.2% 3 0.152s +─Pipeline.refine_reflectively_gen ------ 0.0% 37.5% 1 2.652s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 32.6% 1 2.308s + │└ReflectiveTactics.solve_side_conditio 0.0% 32.2% 1 2.276s + │ ├─ReflectiveTactics.solve_post_reifie 0.5% 18.5% 1 1.308s + │ │ ├─UnifyAbstractReflexivity.unify_tr 11.2% 13.6% 7 0.284s + │ │ └─ReflectiveTactics.unify_abstract_ 2.9% 4.2% 1 0.300s + │ └─ReflectiveTactics.do_reify -------- 0.0% 13.7% 1 0.968s + │ └Reify.Reify_rhs_gen --------------- 0.6% 13.4% 1 0.948s + │ └Reify.do_reify_abs_goal ----------- 7.1% 7.2% 2 0.512s + │ └Reify.do_reifyf_goal -------------- 6.6% 6.7% 62 0.472s + └─Glue.refine_to_reflective_glue' ----- 0.0% 4.9% 1 0.344s + └Glue.zrange_to_reflective ----------- 0.0% 3.3% 1 0.232s + └Glue.zrange_to_reflective_goal ------ 1.9% 2.6% 1 0.184s + +Finished transaction in 7.732 secs (7.1u,0.003s) (successful) +Closed under the global context +total time: 7.072s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 62.5% 1 4.420s +─IntegrationTestTemporaryMiscCommon.fact 18.7% 51.6% 1 3.648s +─Pipeline.refine_reflectively_gen ------ 0.0% 37.5% 1 2.652s +─ReflectiveTactics.do_reflective_pipelin 0.0% 32.6% 1 2.308s +─ReflectiveTactics.solve_side_conditions 0.0% 32.2% 1 2.276s +─reflexivity --------------------------- 24.8% 24.8% 8 1.700s +─ReflectiveTactics.solve_post_reified_si 0.5% 18.5% 1 1.308s +─ReflectiveTactics.do_reify ------------ 0.0% 13.7% 1 0.968s +─UnifyAbstractReflexivity.unify_transfor 11.2% 13.6% 7 0.284s +─Reify.Reify_rhs_gen ------------------- 0.6% 13.4% 1 0.948s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 9.7% 1 0.684s +─rewrite <- (ZRange.is_bounded_by_None_r 9.0% 9.0% 4 0.328s +─op_sig_side_conditions_t -------------- 0.0% 7.8% 1 0.552s +─rewrite <- (lem : lemT) by by_tac ltac: 0.1% 7.4% 1 0.520s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 7.4% 1 0.520s +─by_tac -------------------------------- 0.0% 7.2% 2 0.404s +─Reify.do_reify_abs_goal --------------- 7.1% 7.2% 2 0.512s +─Reify.do_reifyf_goal ------------------ 6.6% 6.7% 62 0.472s +─DestructHyps.do_one_match_then -------- 0.2% 5.8% 14 0.048s +─DestructHyps.do_all_matches_then ------ 0.0% 5.8% 4 0.124s +─do_tac -------------------------------- 0.0% 5.6% 10 0.048s +─destruct H ---------------------------- 5.6% 5.6% 10 0.048s +─Glue.refine_to_reflective_glue' ------- 0.0% 4.9% 1 0.344s +─ReflectiveTactics.unify_abstract_cbv_in 2.9% 4.2% 1 0.300s +─Glue.zrange_to_reflective ------------- 0.0% 3.3% 1 0.232s +─unify (constr) (constr) --------------- 3.2% 3.2% 7 0.088s +─Glue.zrange_to_reflective_goal -------- 1.9% 2.6% 1 0.184s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 2.3% 1 0.164s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.4% 2.2% 3 0.152s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 62.5% 1 4.420s + ├─IntegrationTestTemporaryMiscCommon.fa 18.7% 51.6% 1 3.648s + │ ├─reflexivity ----------------------- 24.0% 24.0% 1 1.700s + │ └─op_sig_side_conditions_t ---------- 0.0% 7.8% 1 0.552s + │ ├─rewrite <- (ZRange.is_bounded_by_ 4.2% 4.2% 2 0.284s + │ └─DestructHyps.do_all_matches_then 0.0% 3.5% 2 0.124s + │ └DestructHyps.do_one_match_then -- 0.2% 3.5% 8 0.044s + │ └do_tac -------------------------- 0.0% 3.3% 6 0.040s + │ └destruct H ---------------------- 3.3% 3.3% 6 0.040s + └─IntegrationTestTemporaryMiscCommon.do 0.0% 9.7% 1 0.684s + ├─IntegrationTestTemporaryMiscCommon. 0.0% 7.4% 1 0.520s + │└rewrite <- (lem : lemT) by by_tac l 0.1% 7.4% 1 0.520s + │└by_tac ---------------------------- 0.0% 7.2% 2 0.404s + │ ├─rewrite <- (ZRange.is_bounded_by_ 4.8% 4.8% 2 0.328s + │ └─DestructHyps.do_all_matches_then 0.0% 2.3% 2 0.088s + │ └DestructHyps.do_one_match_then -- 0.0% 2.3% 6 0.048s + │ └do_tac -------------------------- 0.0% 2.3% 4 0.048s + │ └destruct H ---------------------- 2.3% 2.3% 4 0.048s + └─IntegrationTestTemporaryMiscCommon. 0.0% 2.3% 1 0.164s + └<Crypto.Util.Tactics.MoveLetIn.with 0.4% 2.2% 3 0.152s +─Pipeline.refine_reflectively_gen ------ 0.0% 37.5% 1 2.652s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 32.6% 1 2.308s + │└ReflectiveTactics.solve_side_conditio 0.0% 32.2% 1 2.276s + │ ├─ReflectiveTactics.solve_post_reifie 0.5% 18.5% 1 1.308s + │ │ ├─UnifyAbstractReflexivity.unify_tr 11.2% 13.6% 7 0.284s + │ │ └─ReflectiveTactics.unify_abstract_ 2.9% 4.2% 1 0.300s + │ └─ReflectiveTactics.do_reify -------- 0.0% 13.7% 1 0.968s + │ └Reify.Reify_rhs_gen --------------- 0.6% 13.4% 1 0.948s + │ └Reify.do_reify_abs_goal ----------- 7.1% 7.2% 2 0.512s + │ └Reify.do_reifyf_goal -------------- 6.6% 6.7% 62 0.472s + └─Glue.refine_to_reflective_glue' ----- 0.0% 4.9% 1 0.344s + └Glue.zrange_to_reflective ----------- 0.0% 3.3% 1 0.232s + └Glue.zrange_to_reflective_goal ------ 1.9% 2.6% 1 0.184s + +src/Specific/NISTP256/AMD64/feopp (real: 31.00, user: 28.51, sys: 0.20, mem: 765208 ko) +COQC src/Specific/NISTP256/AMD64/fesub.v +Finished transaction in 12.996 secs (12.091u,0.004s) (successful) +total time: 12.048s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 66.1% 1 7.964s +─IntegrationTestTemporaryMiscCommon.fact 16.2% 50.9% 1 6.128s +─Pipeline.refine_reflectively_gen ------ 0.0% 33.9% 1 4.084s +─ReflectiveTactics.do_reflective_pipelin 0.0% 28.3% 1 3.404s +─ReflectiveTactics.solve_side_conditions 0.0% 27.8% 1 3.352s +─reflexivity --------------------------- 21.7% 21.7% 8 2.480s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 14.1% 1 1.704s +─ReflectiveTactics.solve_post_reified_si 0.4% 14.1% 1 1.696s +─ReflectiveTactics.do_reify ------------ 0.0% 13.7% 1 1.656s +─Reify.Reify_rhs_gen ------------------- 0.9% 13.2% 1 1.592s +─DestructHyps.do_all_matches_then ------ 0.0% 12.9% 8 0.232s +─DestructHyps.do_one_match_then -------- 0.6% 12.9% 44 0.052s +─op_sig_side_conditions_t -------------- 0.0% 12.7% 1 1.528s +─do_tac -------------------------------- 0.0% 12.3% 36 0.048s +─destruct H ---------------------------- 12.3% 12.3% 36 0.048s +─rewrite <- (lem : lemT) by by_tac ltac: 0.1% 11.2% 1 1.352s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 11.2% 1 1.352s +─by_tac -------------------------------- 0.0% 11.1% 4 0.476s +─UnifyAbstractReflexivity.unify_transfor 8.8% 10.6% 7 0.344s +─rewrite <- (ZRange.is_bounded_by_None_r 10.5% 10.5% 8 0.316s +─Reify.do_reify_abs_goal --------------- 6.0% 6.1% 2 0.732s +─Glue.refine_to_reflective_glue' ------- 0.0% 5.6% 1 0.680s +─Reify.do_reifyf_goal ------------------ 5.4% 5.5% 80 0.660s +─Glue.zrange_to_reflective ------------- 0.0% 3.6% 1 0.428s +─ReflectiveTactics.unify_abstract_cbv_in 2.2% 3.0% 1 0.360s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 2.9% 1 0.348s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.5% 2.8% 3 0.332s +─Glue.zrange_to_reflective_goal -------- 1.7% 2.6% 1 0.316s +─k ------------------------------------- 2.1% 2.2% 1 0.268s +─unify (constr) (constr) --------------- 2.1% 2.1% 8 0.092s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 66.1% 1 7.964s + ├─IntegrationTestTemporaryMiscCommon.fa 16.2% 50.9% 1 6.128s + │ ├─reflexivity ----------------------- 20.6% 20.6% 1 2.480s + │ └─op_sig_side_conditions_t ---------- 0.0% 12.7% 1 1.528s + │ ├─DestructHyps.do_all_matches_then 0.0% 7.3% 4 0.232s + │ │└DestructHyps.do_one_match_then -- 0.3% 7.3% 24 0.052s + │ │└do_tac -------------------------- 0.0% 7.0% 20 0.048s + │ │└destruct H ---------------------- 6.9% 6.9% 20 0.048s + │ └─rewrite <- (ZRange.is_bounded_by_ 5.2% 5.2% 4 0.300s + └─IntegrationTestTemporaryMiscCommon.do 0.0% 14.1% 1 1.704s + ├─IntegrationTestTemporaryMiscCommon. 0.0% 11.2% 1 1.352s + │└rewrite <- (lem : lemT) by by_tac l 0.1% 11.2% 1 1.352s + │└by_tac ---------------------------- 0.0% 11.1% 4 0.476s + │ ├─DestructHyps.do_all_matches_then 0.0% 5.6% 4 0.176s + │ │└DestructHyps.do_one_match_then -- 0.2% 5.6% 20 0.052s + │ │└do_tac -------------------------- 0.0% 5.3% 16 0.048s + │ │└destruct H ---------------------- 5.3% 5.3% 16 0.048s + │ └─rewrite <- (ZRange.is_bounded_by_ 5.3% 5.3% 4 0.316s + └─IntegrationTestTemporaryMiscCommon. 0.0% 2.9% 1 0.348s + └<Crypto.Util.Tactics.MoveLetIn.with 0.5% 2.8% 3 0.332s + └k --------------------------------- 2.1% 2.2% 1 0.268s +─Pipeline.refine_reflectively_gen ------ 0.0% 33.9% 1 4.084s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 28.3% 1 3.404s + │└ReflectiveTactics.solve_side_conditio 0.0% 27.8% 1 3.352s + │ ├─ReflectiveTactics.solve_post_reifie 0.4% 14.1% 1 1.696s + │ │ ├─UnifyAbstractReflexivity.unify_tr 8.8% 10.6% 7 0.344s + │ │ └─ReflectiveTactics.unify_abstract_ 2.2% 3.0% 1 0.360s + │ └─ReflectiveTactics.do_reify -------- 0.0% 13.7% 1 1.656s + │ └Reify.Reify_rhs_gen --------------- 0.9% 13.2% 1 1.592s + │ └Reify.do_reify_abs_goal ----------- 6.0% 6.1% 2 0.732s + │ └Reify.do_reifyf_goal -------------- 5.4% 5.5% 80 0.660s + └─Glue.refine_to_reflective_glue' ----- 0.0% 5.6% 1 0.680s + └Glue.zrange_to_reflective ----------- 0.0% 3.6% 1 0.428s + └Glue.zrange_to_reflective_goal ------ 1.7% 2.6% 1 0.316s + +Finished transaction in 13.895 secs (12.78u,0.02s) (successful) +Closed under the global context +total time: 12.048s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 66.1% 1 7.964s +─IntegrationTestTemporaryMiscCommon.fact 16.2% 50.9% 1 6.128s +─Pipeline.refine_reflectively_gen ------ 0.0% 33.9% 1 4.084s +─ReflectiveTactics.do_reflective_pipelin 0.0% 28.3% 1 3.404s +─ReflectiveTactics.solve_side_conditions 0.0% 27.8% 1 3.352s +─reflexivity --------------------------- 21.7% 21.7% 8 2.480s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 14.1% 1 1.704s +─ReflectiveTactics.solve_post_reified_si 0.4% 14.1% 1 1.696s +─ReflectiveTactics.do_reify ------------ 0.0% 13.7% 1 1.656s +─Reify.Reify_rhs_gen ------------------- 0.9% 13.2% 1 1.592s +─DestructHyps.do_all_matches_then ------ 0.0% 12.9% 8 0.232s +─DestructHyps.do_one_match_then -------- 0.6% 12.9% 44 0.052s +─op_sig_side_conditions_t -------------- 0.0% 12.7% 1 1.528s +─do_tac -------------------------------- 0.0% 12.3% 36 0.048s +─destruct H ---------------------------- 12.3% 12.3% 36 0.048s +─rewrite <- (lem : lemT) by by_tac ltac: 0.1% 11.2% 1 1.352s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 11.2% 1 1.352s +─by_tac -------------------------------- 0.0% 11.1% 4 0.476s +─UnifyAbstractReflexivity.unify_transfor 8.8% 10.6% 7 0.344s +─rewrite <- (ZRange.is_bounded_by_None_r 10.5% 10.5% 8 0.316s +─Reify.do_reify_abs_goal --------------- 6.0% 6.1% 2 0.732s +─Glue.refine_to_reflective_glue' ------- 0.0% 5.6% 1 0.680s +─Reify.do_reifyf_goal ------------------ 5.4% 5.5% 80 0.660s +─Glue.zrange_to_reflective ------------- 0.0% 3.6% 1 0.428s +─ReflectiveTactics.unify_abstract_cbv_in 2.2% 3.0% 1 0.360s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 2.9% 1 0.348s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.5% 2.8% 3 0.332s +─Glue.zrange_to_reflective_goal -------- 1.7% 2.6% 1 0.316s +─k ------------------------------------- 2.1% 2.2% 1 0.268s +─unify (constr) (constr) --------------- 2.1% 2.1% 8 0.092s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 66.1% 1 7.964s + ├─IntegrationTestTemporaryMiscCommon.fa 16.2% 50.9% 1 6.128s + │ ├─reflexivity ----------------------- 20.6% 20.6% 1 2.480s + │ └─op_sig_side_conditions_t ---------- 0.0% 12.7% 1 1.528s + │ ├─DestructHyps.do_all_matches_then 0.0% 7.3% 4 0.232s + │ │└DestructHyps.do_one_match_then -- 0.3% 7.3% 24 0.052s + │ │└do_tac -------------------------- 0.0% 7.0% 20 0.048s + │ │└destruct H ---------------------- 6.9% 6.9% 20 0.048s + │ └─rewrite <- (ZRange.is_bounded_by_ 5.2% 5.2% 4 0.300s + └─IntegrationTestTemporaryMiscCommon.do 0.0% 14.1% 1 1.704s + ├─IntegrationTestTemporaryMiscCommon. 0.0% 11.2% 1 1.352s + │└rewrite <- (lem : lemT) by by_tac l 0.1% 11.2% 1 1.352s + │└by_tac ---------------------------- 0.0% 11.1% 4 0.476s + │ ├─DestructHyps.do_all_matches_then 0.0% 5.6% 4 0.176s + │ │└DestructHyps.do_one_match_then -- 0.2% 5.6% 20 0.052s + │ │└do_tac -------------------------- 0.0% 5.3% 16 0.048s + │ │└destruct H ---------------------- 5.3% 5.3% 16 0.048s + │ └─rewrite <- (ZRange.is_bounded_by_ 5.3% 5.3% 4 0.316s + └─IntegrationTestTemporaryMiscCommon. 0.0% 2.9% 1 0.348s + └<Crypto.Util.Tactics.MoveLetIn.with 0.5% 2.8% 3 0.332s + └k --------------------------------- 2.1% 2.2% 1 0.268s +─Pipeline.refine_reflectively_gen ------ 0.0% 33.9% 1 4.084s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 28.3% 1 3.404s + │└ReflectiveTactics.solve_side_conditio 0.0% 27.8% 1 3.352s + │ ├─ReflectiveTactics.solve_post_reifie 0.4% 14.1% 1 1.696s + │ │ ├─UnifyAbstractReflexivity.unify_tr 8.8% 10.6% 7 0.344s + │ │ └─ReflectiveTactics.unify_abstract_ 2.2% 3.0% 1 0.360s + │ └─ReflectiveTactics.do_reify -------- 0.0% 13.7% 1 1.656s + │ └Reify.Reify_rhs_gen --------------- 0.9% 13.2% 1 1.592s + │ └Reify.do_reify_abs_goal ----------- 6.0% 6.1% 2 0.732s + │ └Reify.do_reifyf_goal -------------- 5.4% 5.5% 80 0.660s + └─Glue.refine_to_reflective_glue' ----- 0.0% 5.6% 1 0.680s + └Glue.zrange_to_reflective ----------- 0.0% 3.6% 1 0.428s + └Glue.zrange_to_reflective_goal ------ 1.7% 2.6% 1 0.316s + +src/Specific/NISTP256/AMD64/fesub (real: 43.34, user: 39.59, sys: 0.26, mem: 793376 ko) +COQC src/Specific/NISTP256/AMD64/feaddDisplay > src/Specific/NISTP256/AMD64/feaddDisplay.log +COQC src/Specific/NISTP256/AMD64/fenzDisplay > src/Specific/NISTP256/AMD64/fenzDisplay.log +COQC src/Specific/solinas32_2e255m765_12limbs/femul.v +Finished transaction in 50.426 secs (46.528u,0.072s) (successful) +total time: 46.544s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ -0.0% 94.9% 1 44.164s +─ReflectiveTactics.do_reflective_pipelin 0.0% 87.1% 1 40.552s +─ReflectiveTactics.solve_side_conditions 0.0% 86.7% 1 40.372s +─ReflectiveTactics.do_reify ------------ 0.0% 59.6% 1 27.740s +─Reify.Reify_rhs_gen ------------------- 1.6% 58.9% 1 27.432s +─Reify.do_reify_abs_goal --------------- 43.3% 43.6% 2 20.312s +─Reify.do_reifyf_goal ------------------ 42.5% 42.8% 108 10.328s +─ReflectiveTactics.solve_post_reified_si 0.1% 27.1% 1 12.632s +─UnifyAbstractReflexivity.unify_transfor 18.6% 23.5% 7 3.552s +─eexact -------------------------------- 13.7% 13.7% 110 0.136s +─Glue.refine_to_reflective_glue' ------- 0.0% 7.8% 1 3.612s +─Glue.zrange_to_reflective ------------- 0.0% 7.2% 1 3.332s +─Glue.zrange_to_reflective_goal -------- 1.7% 5.5% 1 2.544s +─synthesize ---------------------------- 0.0% 5.1% 1 2.380s +─unify (constr) (constr) --------------- 5.1% 5.1% 6 1.068s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 5.0% 1 2.320s +─change G' ----------------------------- 4.8% 4.8% 1 2.252s +─rewrite H ----------------------------- 3.8% 3.8% 1 1.748s +─pose proof (pf : Interpretation.Bo 3.6% 3.6% 1 1.664s +─prove_interp_compile_correct ---------- 0.0% 3.5% 1 1.616s +─rewrite ?EtaInterp.InterpExprEta ------ 3.2% 3.2% 1 1.468s +─ReflectiveTactics.unify_abstract_cbv_in 1.6% 2.4% 1 1.124s +─reflexivity --------------------------- 2.1% 2.1% 7 0.396s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ -0.0% 94.9% 1 44.164s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 87.1% 1 40.552s + │└ReflectiveTactics.solve_side_conditio 0.0% 86.7% 1 40.372s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 59.6% 1 27.740s + │ │└Reify.Reify_rhs_gen --------------- 1.6% 58.9% 1 27.432s + │ │ ├─Reify.do_reify_abs_goal --------- 43.3% 43.6% 2 20.312s + │ │ │└Reify.do_reifyf_goal ------------ 42.5% 42.8% 108 10.328s + │ │ │└eexact -------------------------- 13.2% 13.2% 108 0.072s + │ │ ├─rewrite H ----------------------- 3.8% 3.8% 1 1.748s + │ │ └─prove_interp_compile_correct ---- 0.0% 3.5% 1 1.616s + │ │ └rewrite ?EtaInterp.InterpExprEta 3.2% 3.2% 1 1.468s + │ └─ReflectiveTactics.solve_post_reifie 0.1% 27.1% 1 12.632s + │ ├─UnifyAbstractReflexivity.unify_tr 18.6% 23.5% 7 3.552s + │ │└unify (constr) (constr) --------- 4.3% 4.3% 5 1.068s + │ └─ReflectiveTactics.unify_abstract_ 1.6% 2.4% 1 1.124s + └─Glue.refine_to_reflective_glue' ----- 0.0% 7.8% 1 3.612s + └Glue.zrange_to_reflective ----------- 0.0% 7.2% 1 3.332s + └Glue.zrange_to_reflective_goal ------ 1.7% 5.5% 1 2.544s + └pose proof (pf : Interpretation. 3.6% 3.6% 1 1.664s +─synthesize ---------------------------- 0.0% 5.1% 1 2.380s +└IntegrationTestTemporaryMiscCommon.do_r 0.0% 5.0% 1 2.320s +└change G' ----------------------------- 4.8% 4.8% 1 2.252s + +Finished transaction in 80.129 secs (74.068u,0.024s) (successful) +Closed under the global context +total time: 46.544s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ -0.0% 94.9% 1 44.164s +─ReflectiveTactics.do_reflective_pipelin 0.0% 87.1% 1 40.552s +─ReflectiveTactics.solve_side_conditions 0.0% 86.7% 1 40.372s +─ReflectiveTactics.do_reify ------------ 0.0% 59.6% 1 27.740s +─Reify.Reify_rhs_gen ------------------- 1.6% 58.9% 1 27.432s +─Reify.do_reify_abs_goal --------------- 43.3% 43.6% 2 20.312s +─Reify.do_reifyf_goal ------------------ 42.5% 42.8% 108 10.328s +─ReflectiveTactics.solve_post_reified_si 0.1% 27.1% 1 12.632s +─UnifyAbstractReflexivity.unify_transfor 18.6% 23.5% 7 3.552s +─eexact -------------------------------- 13.7% 13.7% 110 0.136s +─Glue.refine_to_reflective_glue' ------- 0.0% 7.8% 1 3.612s +─Glue.zrange_to_reflective ------------- 0.0% 7.2% 1 3.332s +─Glue.zrange_to_reflective_goal -------- 1.7% 5.5% 1 2.544s +─synthesize ---------------------------- 0.0% 5.1% 1 2.380s +─unify (constr) (constr) --------------- 5.1% 5.1% 6 1.068s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 5.0% 1 2.320s +─change G' ----------------------------- 4.8% 4.8% 1 2.252s +─rewrite H ----------------------------- 3.8% 3.8% 1 1.748s +─pose proof (pf : Interpretation.Bo 3.6% 3.6% 1 1.664s +─prove_interp_compile_correct ---------- 0.0% 3.5% 1 1.616s +─rewrite ?EtaInterp.InterpExprEta ------ 3.2% 3.2% 1 1.468s +─ReflectiveTactics.unify_abstract_cbv_in 1.6% 2.4% 1 1.124s +─reflexivity --------------------------- 2.1% 2.1% 7 0.396s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ -0.0% 94.9% 1 44.164s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 87.1% 1 40.552s + │└ReflectiveTactics.solve_side_conditio 0.0% 86.7% 1 40.372s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 59.6% 1 27.740s + │ │└Reify.Reify_rhs_gen --------------- 1.6% 58.9% 1 27.432s + │ │ ├─Reify.do_reify_abs_goal --------- 43.3% 43.6% 2 20.312s + │ │ │└Reify.do_reifyf_goal ------------ 42.5% 42.8% 108 10.328s + │ │ │└eexact -------------------------- 13.2% 13.2% 108 0.072s + │ │ ├─rewrite H ----------------------- 3.8% 3.8% 1 1.748s + │ │ └─prove_interp_compile_correct ---- 0.0% 3.5% 1 1.616s + │ │ └rewrite ?EtaInterp.InterpExprEta 3.2% 3.2% 1 1.468s + │ └─ReflectiveTactics.solve_post_reifie 0.1% 27.1% 1 12.632s + │ ├─UnifyAbstractReflexivity.unify_tr 18.6% 23.5% 7 3.552s + │ │└unify (constr) (constr) --------- 4.3% 4.3% 5 1.068s + │ └─ReflectiveTactics.unify_abstract_ 1.6% 2.4% 1 1.124s + └─Glue.refine_to_reflective_glue' ----- 0.0% 7.8% 1 3.612s + └Glue.zrange_to_reflective ----------- 0.0% 7.2% 1 3.332s + └Glue.zrange_to_reflective_goal ------ 1.7% 5.5% 1 2.544s + └pose proof (pf : Interpretation. 3.6% 3.6% 1 1.664s +─synthesize ---------------------------- 0.0% 5.1% 1 2.380s +└IntegrationTestTemporaryMiscCommon.do_r 0.0% 5.0% 1 2.320s +└change G' ----------------------------- 4.8% 4.8% 1 2.252s + +src/Specific/solinas32_2e255m765_12limbs/femul (real: 155.79, user: 143.70, sys: 0.32, mem: 1454696 ko) +COQC src/Specific/NISTP256/AMD64/feoppDisplay > src/Specific/NISTP256/AMD64/feoppDisplay.log +COQC src/Specific/NISTP256/AMD64/fesubDisplay > src/Specific/NISTP256/AMD64/fesubDisplay.log +COQC src/Specific/X25519/C64/fesquareDisplay > src/Specific/X25519/C64/fesquareDisplay.log +COQC src/Specific/X25519/C64/fesubDisplay > src/Specific/X25519/C64/fesubDisplay.log +COQC src/Specific/X25519/C64/freezeDisplay > src/Specific/X25519/C64/freezeDisplay.log +COQC src/Specific/solinas32_2e255m765_13limbs/femul.v +Finished transaction in 61.854 secs (57.328u,0.079s) (successful) +total time: 57.348s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 94.6% 1 54.224s +─ReflectiveTactics.do_reflective_pipelin 0.0% 86.2% 1 49.452s +─ReflectiveTactics.solve_side_conditions 0.0% 85.9% 1 49.264s +─ReflectiveTactics.do_reify ------------ -0.0% 57.6% 1 33.004s +─Reify.Reify_rhs_gen ------------------- 1.3% 56.9% 1 32.608s +─Reify.do_reify_abs_goal --------------- 43.1% 43.3% 2 24.840s +─Reify.do_reifyf_goal ------------------ 42.3% 42.6% 117 12.704s +─ReflectiveTactics.solve_post_reified_si 0.1% 28.4% 1 16.260s +─UnifyAbstractReflexivity.unify_transfor 19.6% 25.0% 7 4.824s +─eexact -------------------------------- 13.9% 13.9% 119 0.144s +─Glue.refine_to_reflective_glue' ------- 0.0% 8.3% 1 4.772s +─Glue.zrange_to_reflective ------------- 0.0% 7.8% 1 4.484s +─Glue.zrange_to_reflective_goal -------- 1.7% 6.0% 1 3.464s +─synthesize ---------------------------- 0.0% 5.4% 1 3.124s +─unify (constr) (constr) --------------- 5.4% 5.4% 6 1.540s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 5.3% 1 3.040s +─change G' ----------------------------- 5.2% 5.2% 1 2.964s +─pose proof (pf : Interpretation.Bo 4.2% 4.2% 1 2.416s +─prove_interp_compile_correct ---------- 0.0% 3.3% 1 1.904s +─rewrite H ----------------------------- 3.3% 3.3% 1 1.896s +─rewrite ?EtaInterp.InterpExprEta ------ 3.0% 3.0% 1 1.732s +─ReflectiveTactics.unify_abstract_cbv_in 1.4% 2.1% 1 1.212s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 94.6% 1 54.224s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 86.2% 1 49.452s + │└ReflectiveTactics.solve_side_conditio 0.0% 85.9% 1 49.264s + │ ├─ReflectiveTactics.do_reify -------- -0.0% 57.6% 1 33.004s + │ │└Reify.Reify_rhs_gen --------------- 1.3% 56.9% 1 32.608s + │ │ ├─Reify.do_reify_abs_goal --------- 43.1% 43.3% 2 24.840s + │ │ │└Reify.do_reifyf_goal ------------ 42.3% 42.6% 117 12.704s + │ │ │└eexact -------------------------- 13.4% 13.4% 117 0.084s + │ │ ├─prove_interp_compile_correct ---- 0.0% 3.3% 1 1.904s + │ │ │└rewrite ?EtaInterp.InterpExprEta 3.0% 3.0% 1 1.732s + │ │ └─rewrite H ----------------------- 3.3% 3.3% 1 1.896s + │ └─ReflectiveTactics.solve_post_reifie 0.1% 28.4% 1 16.260s + │ ├─UnifyAbstractReflexivity.unify_tr 19.6% 25.0% 7 4.824s + │ │└unify (constr) (constr) --------- 4.8% 4.8% 5 1.540s + │ └─ReflectiveTactics.unify_abstract_ 1.4% 2.1% 1 1.212s + └─Glue.refine_to_reflective_glue' ----- 0.0% 8.3% 1 4.772s + └Glue.zrange_to_reflective ----------- 0.0% 7.8% 1 4.484s + └Glue.zrange_to_reflective_goal ------ 1.7% 6.0% 1 3.464s + └pose proof (pf : Interpretation. 4.2% 4.2% 1 2.416s +─synthesize ---------------------------- 0.0% 5.4% 1 3.124s +└IntegrationTestTemporaryMiscCommon.do_r 0.0% 5.3% 1 3.040s +└change G' ----------------------------- 5.2% 5.2% 1 2.964s + +Finished transaction in 94.432 secs (86.96u,0.02s) (successful) +Closed under the global context +total time: 57.348s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 94.6% 1 54.224s +─ReflectiveTactics.do_reflective_pipelin 0.0% 86.2% 1 49.452s +─ReflectiveTactics.solve_side_conditions 0.0% 85.9% 1 49.264s +─ReflectiveTactics.do_reify ------------ -0.0% 57.6% 1 33.004s +─Reify.Reify_rhs_gen ------------------- 1.3% 56.9% 1 32.608s +─Reify.do_reify_abs_goal --------------- 43.1% 43.3% 2 24.840s +─Reify.do_reifyf_goal ------------------ 42.3% 42.6% 117 12.704s +─ReflectiveTactics.solve_post_reified_si 0.1% 28.4% 1 16.260s +─UnifyAbstractReflexivity.unify_transfor 19.6% 25.0% 7 4.824s +─eexact -------------------------------- 13.9% 13.9% 119 0.144s +─Glue.refine_to_reflective_glue' ------- 0.0% 8.3% 1 4.772s +─Glue.zrange_to_reflective ------------- 0.0% 7.8% 1 4.484s +─Glue.zrange_to_reflective_goal -------- 1.7% 6.0% 1 3.464s +─synthesize ---------------------------- 0.0% 5.4% 1 3.124s +─unify (constr) (constr) --------------- 5.4% 5.4% 6 1.540s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 5.3% 1 3.040s +─change G' ----------------------------- 5.2% 5.2% 1 2.964s +─pose proof (pf : Interpretation.Bo 4.2% 4.2% 1 2.416s +─prove_interp_compile_correct ---------- 0.0% 3.3% 1 1.904s +─rewrite H ----------------------------- 3.3% 3.3% 1 1.896s +─rewrite ?EtaInterp.InterpExprEta ------ 3.0% 3.0% 1 1.732s +─ReflectiveTactics.unify_abstract_cbv_in 1.4% 2.1% 1 1.212s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 94.6% 1 54.224s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 86.2% 1 49.452s + │└ReflectiveTactics.solve_side_conditio 0.0% 85.9% 1 49.264s + │ ├─ReflectiveTactics.do_reify -------- -0.0% 57.6% 1 33.004s + │ │└Reify.Reify_rhs_gen --------------- 1.3% 56.9% 1 32.608s + │ │ ├─Reify.do_reify_abs_goal --------- 43.1% 43.3% 2 24.840s + │ │ │└Reify.do_reifyf_goal ------------ 42.3% 42.6% 117 12.704s + │ │ │└eexact -------------------------- 13.4% 13.4% 117 0.084s + │ │ ├─prove_interp_compile_correct ---- 0.0% 3.3% 1 1.904s + │ │ │└rewrite ?EtaInterp.InterpExprEta 3.0% 3.0% 1 1.732s + │ │ └─rewrite H ----------------------- 3.3% 3.3% 1 1.896s + │ └─ReflectiveTactics.solve_post_reifie 0.1% 28.4% 1 16.260s + │ ├─UnifyAbstractReflexivity.unify_tr 19.6% 25.0% 7 4.824s + │ │└unify (constr) (constr) --------- 4.8% 4.8% 5 1.540s + │ └─ReflectiveTactics.unify_abstract_ 1.4% 2.1% 1 1.212s + └─Glue.refine_to_reflective_glue' ----- 0.0% 8.3% 1 4.772s + └Glue.zrange_to_reflective ----------- 0.0% 7.8% 1 4.484s + └Glue.zrange_to_reflective_goal ------ 1.7% 6.0% 1 3.464s + └pose proof (pf : Interpretation. 4.2% 4.2% 1 2.416s +─synthesize ---------------------------- 0.0% 5.4% 1 3.124s +└IntegrationTestTemporaryMiscCommon.do_r 0.0% 5.3% 1 3.040s +└change G' ----------------------------- 5.2% 5.2% 1 2.964s + +src/Specific/solinas32_2e255m765_13limbs/femul (real: 181.77, user: 168.52, sys: 0.40, mem: 1589516 ko) +COQC src/Specific/NISTP256/AMD64/femul.v +Finished transaction in 119.257 secs (109.936u,0.256s) (successful) +total time: 110.140s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.1% 1 106.964s +─ReflectiveTactics.do_reflective_pipelin -0.0% 96.4% 1 106.196s +─ReflectiveTactics.solve_side_conditions 0.0% 96.2% 1 105.992s +─ReflectiveTactics.do_reify ------------ -0.0% 83.7% 1 92.208s +─Reify.Reify_rhs_gen ------------------- 0.7% 83.5% 1 91.960s +─Reify.do_reify_abs_goal --------------- 77.7% 77.8% 2 85.708s +─Reify.do_reifyf_goal ------------------ 77.4% 77.5% 901 85.364s +─eexact -------------------------------- 17.9% 17.9% 903 0.136s +─ReflectiveTactics.solve_post_reified_si 0.3% 12.5% 1 13.784s +─UnifyAbstractReflexivity.unify_transfor 9.8% 11.2% 7 3.356s +─synthesize_montgomery ----------------- 0.0% 2.9% 1 3.176s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.1% 1 106.964s +└ReflectiveTactics.do_reflective_pipelin -0.0% 96.4% 1 106.196s +└ReflectiveTactics.solve_side_conditions 0.0% 96.2% 1 105.992s + ├─ReflectiveTactics.do_reify ---------- -0.0% 83.7% 1 92.208s + │└Reify.Reify_rhs_gen ----------------- 0.7% 83.5% 1 91.960s + │└Reify.do_reify_abs_goal ------------- 77.7% 77.8% 2 85.708s + │└Reify.do_reifyf_goal ---------------- 77.4% 77.5% 901 85.364s + │└eexact ------------------------------ 17.7% 17.7% 901 0.136s + └─ReflectiveTactics.solve_post_reified_ 0.3% 12.5% 1 13.784s + └UnifyAbstractReflexivity.unify_transf 9.8% 11.2% 7 3.356s +─synthesize_montgomery ----------------- 0.0% 2.9% 1 3.176s + +Finished transaction in 61.452 secs (58.503u,0.055s) (successful) +Closed under the global context +total time: 110.140s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.1% 1 106.964s +─ReflectiveTactics.do_reflective_pipelin -0.0% 96.4% 1 106.196s +─ReflectiveTactics.solve_side_conditions 0.0% 96.2% 1 105.992s +─ReflectiveTactics.do_reify ------------ -0.0% 83.7% 1 92.208s +─Reify.Reify_rhs_gen ------------------- 0.7% 83.5% 1 91.960s +─Reify.do_reify_abs_goal --------------- 77.7% 77.8% 2 85.708s +─Reify.do_reifyf_goal ------------------ 77.4% 77.5% 901 85.364s +─eexact -------------------------------- 17.9% 17.9% 903 0.136s +─ReflectiveTactics.solve_post_reified_si 0.3% 12.5% 1 13.784s +─UnifyAbstractReflexivity.unify_transfor 9.8% 11.2% 7 3.356s +─synthesize_montgomery ----------------- 0.0% 2.9% 1 3.176s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.1% 1 106.964s +└ReflectiveTactics.do_reflective_pipelin -0.0% 96.4% 1 106.196s +└ReflectiveTactics.solve_side_conditions 0.0% 96.2% 1 105.992s + ├─ReflectiveTactics.do_reify ---------- -0.0% 83.7% 1 92.208s + │└Reify.Reify_rhs_gen ----------------- 0.7% 83.5% 1 91.960s + │└Reify.do_reify_abs_goal ------------- 77.7% 77.8% 2 85.708s + │└Reify.do_reifyf_goal ---------------- 77.4% 77.5% 901 85.364s + │└eexact ------------------------------ 17.7% 17.7% 901 0.136s + └─ReflectiveTactics.solve_post_reified_ 0.3% 12.5% 1 13.784s + └UnifyAbstractReflexivity.unify_transf 9.8% 11.2% 7 3.356s +─synthesize_montgomery ----------------- 0.0% 2.9% 1 3.176s + +src/Specific/NISTP256/AMD64/femul (real: 202.96, user: 189.62, sys: 0.64, mem: 3302508 ko) +COQC src/Specific/NISTP256/AMD64/femulDisplay > src/Specific/NISTP256/AMD64/femulDisplay.log +COQC src/Specific/X25519/C64/ladderstep.v +total time: 52.080s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_xzladderstep --------------- 0.0% 100.0% 1 52.080s +─Pipeline.refine_reflectively_gen ------ 0.0% 98.5% 1 51.320s +─ReflectiveTactics.do_reflective_pipelin 0.0% 93.8% 1 48.872s +─ReflectiveTactics.solve_side_conditions 0.0% 93.7% 1 48.776s +─ReflectiveTactics.solve_post_reified_si 0.2% 56.5% 1 29.412s +─UnifyAbstractReflexivity.unify_transfor 44.7% 49.1% 7 6.968s +─ReflectiveTactics.do_reify ------------ 0.0% 37.2% 1 19.364s +─Reify.Reify_rhs_gen ------------------- 2.1% 23.4% 1 12.200s +─Reify.do_reifyf_goal ------------------ 11.2% 11.3% 138 1.884s +─Compilers.Reify.reify_context_variables 0.1% 9.2% 1 4.808s +─rewrite H ----------------------------- 7.3% 7.3% 1 3.816s +─ReflectiveTactics.unify_abstract_cbv_in 4.7% 6.4% 1 3.336s +─Glue.refine_to_reflective_glue' ------- 0.0% 4.7% 1 2.448s +─Glue.zrange_to_reflective ------------- 0.0% 4.0% 1 2.068s +─Reify.transitivity_tt ----------------- 0.1% 3.7% 2 0.984s +─transitivity -------------------------- 3.5% 3.5% 10 0.880s +─reflexivity --------------------------- 3.4% 3.4% 11 0.772s +─Glue.zrange_to_reflective_goal -------- 2.4% 3.3% 1 1.728s +─eexact -------------------------------- 3.2% 3.2% 140 0.032s +─unify (constr) (constr) --------------- 3.1% 3.1% 6 0.852s +─clear (var_list) ---------------------- 3.1% 3.1% 98 0.584s +─UnfoldArg.unfold_second_arg ----------- 0.4% 3.0% 2 1.576s +─tac ----------------------------------- 2.1% 3.0% 2 1.564s +─ClearAll.clear_all -------------------- 0.2% 2.8% 7 0.584s +─ChangeInAll.change_with_compute_in_all 0.0% 2.6% 221 0.012s +─change c with c' in * ----------------- 2.5% 2.5% 221 0.012s +─Reify.do_reify_abs_goal --------------- 2.4% 2.5% 2 1.276s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_xzladderstep --------------- 0.0% 100.0% 1 52.080s +└Pipeline.refine_reflectively_gen ------ 0.0% 98.5% 1 51.320s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 93.8% 1 48.872s + │└ReflectiveTactics.solve_side_conditio 0.0% 93.7% 1 48.776s + │ ├─ReflectiveTactics.solve_post_reifie 0.2% 56.5% 1 29.412s + │ │ ├─UnifyAbstractReflexivity.unify_tr 44.7% 49.1% 7 6.968s + │ │ │└ClearAll.clear_all -------------- 0.2% 2.8% 7 0.584s + │ │ │└clear (var_list) ---------------- 2.7% 2.7% 65 0.584s + │ │ └─ReflectiveTactics.unify_abstract_ 4.7% 6.4% 1 3.336s + │ └─ReflectiveTactics.do_reify -------- 0.0% 37.2% 1 19.364s + │ ├─Reify.Reify_rhs_gen ------------- 2.1% 23.4% 1 12.200s + │ │ ├─rewrite H --------------------- 7.3% 7.3% 1 3.816s + │ │ ├─Reify.transitivity_tt --------- 0.1% 3.7% 2 0.984s + │ │ │└transitivity ------------------ 3.4% 3.4% 4 0.880s + │ │ ├─tac --------------------------- 2.1% 3.0% 1 1.564s + │ │ └─Reify.do_reify_abs_goal ------- 2.4% 2.5% 2 1.276s + │ │ └Reify.do_reifyf_goal ---------- 2.2% 2.2% 25 1.148s + │ ├─Compilers.Reify.reify_context_var 0.1% 9.2% 1 4.808s + │ │└Reify.do_reifyf_goal ------------ 9.0% 9.1% 113 1.884s + │ │└eexact -------------------------- 2.4% 2.4% 113 0.032s + │ └─UnfoldArg.unfold_second_arg ----- 0.4% 3.0% 2 1.576s + │ └ChangeInAll.change_with_compute_i 0.0% 2.6% 221 0.012s + │ └change c with c' in * ----------- 2.5% 2.5% 221 0.012s + └─Glue.refine_to_reflective_glue' ----- 0.0% 4.7% 1 2.448s + └Glue.zrange_to_reflective ----------- 0.0% 4.0% 1 2.068s + └Glue.zrange_to_reflective_goal ------ 2.4% 3.3% 1 1.728s + +Finished transaction in 171.122 secs (161.392u,0.039s) (successful) +Closed under the global context +total time: 52.080s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_xzladderstep --------------- 0.0% 100.0% 1 52.080s +─Pipeline.refine_reflectively_gen ------ 0.0% 98.5% 1 51.320s +─ReflectiveTactics.do_reflective_pipelin 0.0% 93.8% 1 48.872s +─ReflectiveTactics.solve_side_conditions 0.0% 93.7% 1 48.776s +─ReflectiveTactics.solve_post_reified_si 0.2% 56.5% 1 29.412s +─UnifyAbstractReflexivity.unify_transfor 44.7% 49.1% 7 6.968s +─ReflectiveTactics.do_reify ------------ 0.0% 37.2% 1 19.364s +─Reify.Reify_rhs_gen ------------------- 2.1% 23.4% 1 12.200s +─Reify.do_reifyf_goal ------------------ 11.2% 11.3% 138 1.884s +─Compilers.Reify.reify_context_variables 0.1% 9.2% 1 4.808s +─rewrite H ----------------------------- 7.3% 7.3% 1 3.816s +─ReflectiveTactics.unify_abstract_cbv_in 4.7% 6.4% 1 3.336s +─Glue.refine_to_reflective_glue' ------- 0.0% 4.7% 1 2.448s +─Glue.zrange_to_reflective ------------- 0.0% 4.0% 1 2.068s +─Reify.transitivity_tt ----------------- 0.1% 3.7% 2 0.984s +─transitivity -------------------------- 3.5% 3.5% 10 0.880s +─reflexivity --------------------------- 3.4% 3.4% 11 0.772s +─Glue.zrange_to_reflective_goal -------- 2.4% 3.3% 1 1.728s +─eexact -------------------------------- 3.2% 3.2% 140 0.032s +─unify (constr) (constr) --------------- 3.1% 3.1% 6 0.852s +─clear (var_list) ---------------------- 3.1% 3.1% 98 0.584s +─UnfoldArg.unfold_second_arg ----------- 0.4% 3.0% 2 1.576s +─tac ----------------------------------- 2.1% 3.0% 2 1.564s +─ClearAll.clear_all -------------------- 0.2% 2.8% 7 0.584s +─ChangeInAll.change_with_compute_in_all 0.0% 2.6% 221 0.012s +─change c with c' in * ----------------- 2.5% 2.5% 221 0.012s +─Reify.do_reify_abs_goal --------------- 2.4% 2.5% 2 1.276s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_xzladderstep --------------- 0.0% 100.0% 1 52.080s +└Pipeline.refine_reflectively_gen ------ 0.0% 98.5% 1 51.320s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 93.8% 1 48.872s + │└ReflectiveTactics.solve_side_conditio 0.0% 93.7% 1 48.776s + │ ├─ReflectiveTactics.solve_post_reifie 0.2% 56.5% 1 29.412s + │ │ ├─UnifyAbstractReflexivity.unify_tr 44.7% 49.1% 7 6.968s + │ │ │└ClearAll.clear_all -------------- 0.2% 2.8% 7 0.584s + │ │ │└clear (var_list) ---------------- 2.7% 2.7% 65 0.584s + │ │ └─ReflectiveTactics.unify_abstract_ 4.7% 6.4% 1 3.336s + │ └─ReflectiveTactics.do_reify -------- 0.0% 37.2% 1 19.364s + │ ├─Reify.Reify_rhs_gen ------------- 2.1% 23.4% 1 12.200s + │ │ ├─rewrite H --------------------- 7.3% 7.3% 1 3.816s + │ │ ├─Reify.transitivity_tt --------- 0.1% 3.7% 2 0.984s + │ │ │└transitivity ------------------ 3.4% 3.4% 4 0.880s + │ │ ├─tac --------------------------- 2.1% 3.0% 1 1.564s + │ │ └─Reify.do_reify_abs_goal ------- 2.4% 2.5% 2 1.276s + │ │ └Reify.do_reifyf_goal ---------- 2.2% 2.2% 25 1.148s + │ ├─Compilers.Reify.reify_context_var 0.1% 9.2% 1 4.808s + │ │└Reify.do_reifyf_goal ------------ 9.0% 9.1% 113 1.884s + │ │└eexact -------------------------- 2.4% 2.4% 113 0.032s + │ └─UnfoldArg.unfold_second_arg ----- 0.4% 3.0% 2 1.576s + │ └ChangeInAll.change_with_compute_i 0.0% 2.6% 221 0.012s + │ └change c with c' in * ----------- 2.5% 2.5% 221 0.012s + └─Glue.refine_to_reflective_glue' ----- 0.0% 4.7% 1 2.448s + └Glue.zrange_to_reflective ----------- 0.0% 4.0% 1 2.068s + └Glue.zrange_to_reflective_goal ------ 2.4% 3.3% 1 1.728s + +src/Specific/X25519/C64/ladderstep (real: 256.77, user: 241.34, sys: 0.45, mem: 1617000 ko) +COQC src/Specific/X25519/C64/ladderstepDisplay > src/Specific/X25519/C64/ladderstepDisplay.log diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-before.log.in b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-before.log.in new file mode 100644 index 0000000000..14102902b1 --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-before.log.in @@ -0,0 +1,1662 @@ +COQDEP src/Compilers/Z/Bounds/Pipeline/Definition.v +COQDEP src/Compilers/Z/Bounds/Pipeline/ReflectiveTactics.v +/home/jgross/.local64/coq/coq-master/bin/coq_makefile -f _CoqProject INSTALLDEFAULTROOT = Crypto -o Makefile-old +COQ_MAKEFILE -f _CoqProject > Makefile.coq +make --no-print-directory -C coqprime +make[1]: Nothing to be done for 'all'. +ECHO > _CoqProject +COQC src/Compilers/Z/Bounds/Pipeline/Definition.v +src/Compilers/Z/Bounds/Pipeline/Definition (real: 7.40, user: 7.22, sys: 0.15, mem: 578344 ko) +COQC src/Compilers/Z/Bounds/Pipeline/ReflectiveTactics.v +src/Compilers/Z/Bounds/Pipeline/ReflectiveTactics (real: 1.73, user: 1.58, sys: 0.14, mem: 546112 ko) +COQC src/Compilers/Z/Bounds/Pipeline.v +src/Compilers/Z/Bounds/Pipeline (real: 1.18, user: 1.04, sys: 0.14, mem: 539160 ko) +COQC src/Specific/Framework/SynthesisFramework.v +src/Specific/Framework/SynthesisFramework (real: 1.95, user: 1.72, sys: 0.22, mem: 648632 ko) +COQC src/Specific/X25519/C64/Synthesis.v +src/Specific/X25519/C64/Synthesis (real: 11.23, user: 10.30, sys: 0.19, mem: 687812 ko) +COQC src/Specific/NISTP256/AMD64/Synthesis.v +src/Specific/NISTP256/AMD64/Synthesis (real: 13.74, user: 12.54, sys: 0.23, mem: 667664 ko) +COQC src/Specific/X25519/C64/feadd.v +Finished transaction in 2.852 secs (2.699u,0.012s) (successful) +total time: 2.664s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.4% 1 2.596s +─ReflectiveTactics.do_reflective_pipelin 0.0% 70.9% 1 1.888s +─ReflectiveTactics.solve_side_conditions 0.0% 69.5% 1 1.852s +─ReflectiveTactics.solve_post_reified_si 1.4% 43.7% 1 1.164s +─UnifyAbstractReflexivity.unify_transfor 27.0% 31.7% 8 0.256s +─Glue.refine_to_reflective_glue' ------- 0.0% 26.6% 1 0.708s +─ReflectiveTactics.do_reify ------------ 0.0% 25.8% 1 0.688s +─Reify.Reify_rhs_gen ------------------- 2.0% 24.0% 1 0.640s +─Glue.zrange_to_reflective ------------- 0.0% 17.9% 1 0.476s +─Glue.zrange_to_reflective_goal -------- 8.1% 13.1% 1 0.348s +─Reify.do_reify_abs_goal --------------- 12.8% 12.9% 2 0.344s +─Reify.do_reifyf_goal ------------------ 11.7% 11.9% 16 0.316s +─ReflectiveTactics.unify_abstract_cbv_in 7.7% 10.2% 1 0.272s +─unify (constr) (constr) --------------- 6.0% 6.0% 7 0.064s +─Glue.pattern_sig_sig_assoc ------------ 0.0% 5.0% 1 0.132s +─assert (H : is_bounded_by' bounds (map' 4.5% 4.7% 2 0.068s +─Glue.pattern_proj1_sig_in_sig --------- 1.5% 4.7% 1 0.124s +─pose proof (pf : Interpretation.Bo 3.3% 3.3% 1 0.088s +─Glue.split_BoundedWordToZ ------------- 0.2% 3.0% 1 0.080s +─destruct x ---------------------------- 2.7% 2.7% 4 0.032s +─clearbody (ne_var_list) --------------- 2.7% 2.7% 4 0.056s +─destruct_sig -------------------------- 0.0% 2.7% 4 0.040s +─synthesize ---------------------------- 0.0% 2.6% 1 0.068s +─prove_interp_compile_correct ---------- 0.0% 2.4% 1 0.064s +─reflexivity --------------------------- 2.3% 2.3% 7 0.028s +─rewrite ?EtaInterp.InterpExprEta ------ 2.3% 2.3% 1 0.060s +─ClearbodyAll.clearbody_all ------------ 0.0% 2.1% 2 0.056s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.4% 1 2.596s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 70.9% 1 1.888s + │└ReflectiveTactics.solve_side_conditio 0.0% 69.5% 1 1.852s + │ ├─ReflectiveTactics.solve_post_reifie 1.4% 43.7% 1 1.164s + │ │ ├─UnifyAbstractReflexivity.unify_tr 27.0% 31.7% 8 0.256s + │ │ │└unify (constr) (constr) --------- 3.6% 3.6% 6 0.028s + │ │ └─ReflectiveTactics.unify_abstract_ 7.7% 10.2% 1 0.272s + │ │ └unify (constr) (constr) --------- 2.4% 2.4% 1 0.064s + │ └─ReflectiveTactics.do_reify -------- 0.0% 25.8% 1 0.688s + │ └Reify.Reify_rhs_gen --------------- 2.0% 24.0% 1 0.640s + │ ├─Reify.do_reify_abs_goal --------- 12.8% 12.9% 2 0.344s + │ │└Reify.do_reifyf_goal ------------ 11.7% 11.9% 16 0.316s + │ └─prove_interp_compile_correct ---- 0.0% 2.4% 1 0.064s + │ └rewrite ?EtaInterp.InterpExprEta 2.3% 2.3% 1 0.060s + └─Glue.refine_to_reflective_glue' ----- 0.0% 26.6% 1 0.708s + ├─Glue.zrange_to_reflective --------- 0.0% 17.9% 1 0.476s + │ ├─Glue.zrange_to_reflective_goal -- 8.1% 13.1% 1 0.348s + │ │└pose proof (pf : Interpretat 3.3% 3.3% 1 0.088s + │ └─assert (H : is_bounded_by' bounds 4.5% 4.7% 2 0.068s + ├─Glue.pattern_sig_sig_assoc -------- 0.0% 5.0% 1 0.132s + │└Glue.pattern_proj1_sig_in_sig ----- 1.5% 4.7% 1 0.124s + │└ClearbodyAll.clearbody_all -------- 0.0% 2.1% 2 0.056s + │└clearbody (ne_var_list) ----------- 2.1% 2.1% 1 0.056s + └─Glue.split_BoundedWordToZ --------- 0.2% 3.0% 1 0.080s + └destruct_sig ---------------------- 0.0% 2.7% 4 0.040s + └destruct x ------------------------ 2.1% 2.1% 2 0.032s +─synthesize ---------------------------- 0.0% 2.6% 1 0.068s + +Finished transaction in 5.46 secs (5.068u,0.003s) (successful) +Closed under the global context +total time: 2.664s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.4% 1 2.596s +─ReflectiveTactics.do_reflective_pipelin 0.0% 70.9% 1 1.888s +─ReflectiveTactics.solve_side_conditions 0.0% 69.5% 1 1.852s +─ReflectiveTactics.solve_post_reified_si 1.4% 43.7% 1 1.164s +─UnifyAbstractReflexivity.unify_transfor 27.0% 31.7% 8 0.256s +─Glue.refine_to_reflective_glue' ------- 0.0% 26.6% 1 0.708s +─ReflectiveTactics.do_reify ------------ 0.0% 25.8% 1 0.688s +─Reify.Reify_rhs_gen ------------------- 2.0% 24.0% 1 0.640s +─Glue.zrange_to_reflective ------------- 0.0% 17.9% 1 0.476s +─Glue.zrange_to_reflective_goal -------- 8.1% 13.1% 1 0.348s +─Reify.do_reify_abs_goal --------------- 12.8% 12.9% 2 0.344s +─Reify.do_reifyf_goal ------------------ 11.7% 11.9% 16 0.316s +─ReflectiveTactics.unify_abstract_cbv_in 7.7% 10.2% 1 0.272s +─unify (constr) (constr) --------------- 6.0% 6.0% 7 0.064s +─Glue.pattern_sig_sig_assoc ------------ 0.0% 5.0% 1 0.132s +─assert (H : is_bounded_by' bounds (map' 4.5% 4.7% 2 0.068s +─Glue.pattern_proj1_sig_in_sig --------- 1.5% 4.7% 1 0.124s +─pose proof (pf : Interpretation.Bo 3.3% 3.3% 1 0.088s +─Glue.split_BoundedWordToZ ------------- 0.2% 3.0% 1 0.080s +─destruct x ---------------------------- 2.7% 2.7% 4 0.032s +─clearbody (ne_var_list) --------------- 2.7% 2.7% 4 0.056s +─destruct_sig -------------------------- 0.0% 2.7% 4 0.040s +─synthesize ---------------------------- 0.0% 2.6% 1 0.068s +─prove_interp_compile_correct ---------- 0.0% 2.4% 1 0.064s +─reflexivity --------------------------- 2.3% 2.3% 7 0.028s +─rewrite ?EtaInterp.InterpExprEta ------ 2.3% 2.3% 1 0.060s +─ClearbodyAll.clearbody_all ------------ 0.0% 2.1% 2 0.056s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.4% 1 2.596s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 70.9% 1 1.888s + │└ReflectiveTactics.solve_side_conditio 0.0% 69.5% 1 1.852s + │ ├─ReflectiveTactics.solve_post_reifie 1.4% 43.7% 1 1.164s + │ │ ├─UnifyAbstractReflexivity.unify_tr 27.0% 31.7% 8 0.256s + │ │ │└unify (constr) (constr) --------- 3.6% 3.6% 6 0.028s + │ │ └─ReflectiveTactics.unify_abstract_ 7.7% 10.2% 1 0.272s + │ │ └unify (constr) (constr) --------- 2.4% 2.4% 1 0.064s + │ └─ReflectiveTactics.do_reify -------- 0.0% 25.8% 1 0.688s + │ └Reify.Reify_rhs_gen --------------- 2.0% 24.0% 1 0.640s + │ ├─Reify.do_reify_abs_goal --------- 12.8% 12.9% 2 0.344s + │ │└Reify.do_reifyf_goal ------------ 11.7% 11.9% 16 0.316s + │ └─prove_interp_compile_correct ---- 0.0% 2.4% 1 0.064s + │ └rewrite ?EtaInterp.InterpExprEta 2.3% 2.3% 1 0.060s + └─Glue.refine_to_reflective_glue' ----- 0.0% 26.6% 1 0.708s + ├─Glue.zrange_to_reflective --------- 0.0% 17.9% 1 0.476s + │ ├─Glue.zrange_to_reflective_goal -- 8.1% 13.1% 1 0.348s + │ │└pose proof (pf : Interpretat 3.3% 3.3% 1 0.088s + │ └─assert (H : is_bounded_by' bounds 4.5% 4.7% 2 0.068s + ├─Glue.pattern_sig_sig_assoc -------- 0.0% 5.0% 1 0.132s + │└Glue.pattern_proj1_sig_in_sig ----- 1.5% 4.7% 1 0.124s + │└ClearbodyAll.clearbody_all -------- 0.0% 2.1% 2 0.056s + │└clearbody (ne_var_list) ----------- 2.1% 2.1% 1 0.056s + └─Glue.split_BoundedWordToZ --------- 0.2% 3.0% 1 0.080s + └destruct_sig ---------------------- 0.0% 2.7% 4 0.040s + └destruct x ------------------------ 2.1% 2.1% 2 0.032s +─synthesize ---------------------------- 0.0% 2.6% 1 0.068s + +src/Specific/X25519/C64/feadd (real: 23.43, user: 21.41, sys: 0.26, mem: 766168 ko) +COQC src/Specific/solinas32_2e255m765_12limbs/Synthesis.v +src/Specific/solinas32_2e255m765_12limbs/Synthesis (real: 39.53, user: 36.64, sys: 0.21, mem: 729464 ko) +COQC src/Specific/X25519/C64/fecarry.v +Finished transaction in 4.798 secs (4.375u,0.003s) (successful) +total time: 4.332s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.1% 99.0% 1 4.288s +─ReflectiveTactics.do_reflective_pipelin 0.0% 89.2% 1 3.864s +─ReflectiveTactics.solve_side_conditions 0.0% 88.1% 1 3.816s +─ReflectiveTactics.do_reify ------------ 0.0% 53.2% 1 2.304s +─Reify.Reify_rhs_gen ------------------- 1.8% 52.6% 1 2.280s +─ReflectiveTactics.solve_post_reified_si 0.6% 34.9% 1 1.512s +─Reify.do_reify_abs_goal --------------- 33.5% 33.9% 2 1.468s +─Reify.do_reifyf_goal ------------------ 32.1% 32.5% 29 1.408s +─UnifyAbstractReflexivity.unify_transfor 22.5% 27.1% 8 0.316s +─Glue.refine_to_reflective_glue' ------- 0.1% 9.7% 1 0.420s +─eexact -------------------------------- 9.3% 9.3% 31 0.024s +─ReflectiveTactics.unify_abstract_cbv_in 5.2% 7.0% 1 0.304s +─Glue.zrange_to_reflective ------------- 0.1% 6.2% 1 0.268s +─prove_interp_compile_correct ---------- 0.0% 5.6% 1 0.244s +─rewrite ?EtaInterp.InterpExprEta ------ 5.3% 5.3% 1 0.228s +─unify (constr) (constr) --------------- 5.3% 5.3% 7 0.076s +─Glue.zrange_to_reflective_goal -------- 4.0% 4.9% 1 0.212s +─rewrite H ----------------------------- 3.4% 3.4% 1 0.148s +─tac ----------------------------------- 1.8% 2.6% 2 0.112s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.1% 99.0% 1 4.288s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 89.2% 1 3.864s + │└ReflectiveTactics.solve_side_conditio 0.0% 88.1% 1 3.816s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 53.2% 1 2.304s + │ │└Reify.Reify_rhs_gen --------------- 1.8% 52.6% 1 2.280s + │ │ ├─Reify.do_reify_abs_goal --------- 33.5% 33.9% 2 1.468s + │ │ │└Reify.do_reifyf_goal ------------ 32.1% 32.5% 29 1.408s + │ │ │└eexact -------------------------- 8.6% 8.6% 29 0.024s + │ │ ├─prove_interp_compile_correct ---- 0.0% 5.6% 1 0.244s + │ │ │└rewrite ?EtaInterp.InterpExprEta 5.3% 5.3% 1 0.228s + │ │ ├─rewrite H ----------------------- 3.4% 3.4% 1 0.148s + │ │ └─tac ----------------------------- 1.8% 2.6% 1 0.112s + │ └─ReflectiveTactics.solve_post_reifie 0.6% 34.9% 1 1.512s + │ ├─UnifyAbstractReflexivity.unify_tr 22.5% 27.1% 8 0.316s + │ │└unify (constr) (constr) --------- 3.5% 3.5% 6 0.044s + │ └─ReflectiveTactics.unify_abstract_ 5.2% 7.0% 1 0.304s + └─Glue.refine_to_reflective_glue' ----- 0.1% 9.7% 1 0.420s + └Glue.zrange_to_reflective ----------- 0.1% 6.2% 1 0.268s + └Glue.zrange_to_reflective_goal ------ 4.0% 4.9% 1 0.212s + +Finished transaction in 8.342 secs (7.604u,0.008s) (successful) +Closed under the global context +total time: 4.332s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.1% 99.0% 1 4.288s +─ReflectiveTactics.do_reflective_pipelin 0.0% 89.2% 1 3.864s +─ReflectiveTactics.solve_side_conditions 0.0% 88.1% 1 3.816s +─ReflectiveTactics.do_reify ------------ 0.0% 53.2% 1 2.304s +─Reify.Reify_rhs_gen ------------------- 1.8% 52.6% 1 2.280s +─ReflectiveTactics.solve_post_reified_si 0.6% 34.9% 1 1.512s +─Reify.do_reify_abs_goal --------------- 33.5% 33.9% 2 1.468s +─Reify.do_reifyf_goal ------------------ 32.1% 32.5% 29 1.408s +─UnifyAbstractReflexivity.unify_transfor 22.5% 27.1% 8 0.316s +─Glue.refine_to_reflective_glue' ------- 0.1% 9.7% 1 0.420s +─eexact -------------------------------- 9.3% 9.3% 31 0.024s +─ReflectiveTactics.unify_abstract_cbv_in 5.2% 7.0% 1 0.304s +─Glue.zrange_to_reflective ------------- 0.1% 6.2% 1 0.268s +─prove_interp_compile_correct ---------- 0.0% 5.6% 1 0.244s +─rewrite ?EtaInterp.InterpExprEta ------ 5.3% 5.3% 1 0.228s +─unify (constr) (constr) --------------- 5.3% 5.3% 7 0.076s +─Glue.zrange_to_reflective_goal -------- 4.0% 4.9% 1 0.212s +─rewrite H ----------------------------- 3.4% 3.4% 1 0.148s +─tac ----------------------------------- 1.8% 2.6% 2 0.112s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.1% 99.0% 1 4.288s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 89.2% 1 3.864s + │└ReflectiveTactics.solve_side_conditio 0.0% 88.1% 1 3.816s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 53.2% 1 2.304s + │ │└Reify.Reify_rhs_gen --------------- 1.8% 52.6% 1 2.280s + │ │ ├─Reify.do_reify_abs_goal --------- 33.5% 33.9% 2 1.468s + │ │ │└Reify.do_reifyf_goal ------------ 32.1% 32.5% 29 1.408s + │ │ │└eexact -------------------------- 8.6% 8.6% 29 0.024s + │ │ ├─prove_interp_compile_correct ---- 0.0% 5.6% 1 0.244s + │ │ │└rewrite ?EtaInterp.InterpExprEta 5.3% 5.3% 1 0.228s + │ │ ├─rewrite H ----------------------- 3.4% 3.4% 1 0.148s + │ │ └─tac ----------------------------- 1.8% 2.6% 1 0.112s + │ └─ReflectiveTactics.solve_post_reifie 0.6% 34.9% 1 1.512s + │ ├─UnifyAbstractReflexivity.unify_tr 22.5% 27.1% 8 0.316s + │ │└unify (constr) (constr) --------- 3.5% 3.5% 6 0.044s + │ └─ReflectiveTactics.unify_abstract_ 5.2% 7.0% 1 0.304s + └─Glue.refine_to_reflective_glue' ----- 0.1% 9.7% 1 0.420s + └Glue.zrange_to_reflective ----------- 0.1% 6.2% 1 0.268s + └Glue.zrange_to_reflective_goal ------ 4.0% 4.9% 1 0.212s + +src/Specific/X25519/C64/fecarry (real: 28.85, user: 26.31, sys: 0.25, mem: 787148 ko) +COQC src/Specific/solinas32_2e255m765_13limbs/Synthesis.v +src/Specific/solinas32_2e255m765_13limbs/Synthesis (real: 49.50, user: 45.58, sys: 0.18, mem: 744472 ko) +COQC src/Specific/X25519/C64/femul.v +Finished transaction in 9.325 secs (8.62u,0.016s) (successful) +total time: 8.576s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 95.8% 1 8.220s +─ReflectiveTactics.do_reflective_pipelin 0.0% 87.7% 1 7.524s +─ReflectiveTactics.solve_side_conditions 0.0% 87.0% 1 7.460s +─ReflectiveTactics.do_reify ------------ 0.0% 43.8% 1 3.760s +─ReflectiveTactics.solve_post_reified_si 0.6% 43.1% 1 3.700s +─Reify.Reify_rhs_gen ------------------- 1.4% 43.0% 1 3.688s +─UnifyAbstractReflexivity.unify_transfor 31.1% 36.7% 8 1.096s +─Reify.do_reify_abs_goal --------------- 26.3% 26.6% 2 2.284s +─Reify.do_reifyf_goal ------------------ 25.3% 25.6% 58 1.440s +─Glue.refine_to_reflective_glue' ------- 0.0% 8.1% 1 0.696s +─eexact -------------------------------- 7.6% 7.6% 60 0.032s +─unify (constr) (constr) --------------- 5.8% 5.8% 7 0.128s +─Glue.zrange_to_reflective ------------- 0.0% 5.7% 1 0.488s +─ReflectiveTactics.unify_abstract_cbv_in 3.8% 5.5% 1 0.468s +─prove_interp_compile_correct ---------- 0.0% 5.2% 1 0.448s +─rewrite ?EtaInterp.InterpExprEta ------ 4.9% 4.9% 1 0.416s +─Glue.zrange_to_reflective_goal -------- 2.6% 4.2% 1 0.364s +─synthesize ---------------------------- 0.0% 4.2% 1 0.356s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 3.8% 1 0.328s +─rewrite H ----------------------------- 3.2% 3.2% 1 0.276s +─change G' ----------------------------- 3.2% 3.2% 1 0.272s +─tac ----------------------------------- 1.4% 2.1% 2 0.180s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 95.8% 1 8.220s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 87.7% 1 7.524s + │└ReflectiveTactics.solve_side_conditio 0.0% 87.0% 1 7.460s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 43.8% 1 3.760s + │ │└Reify.Reify_rhs_gen --------------- 1.4% 43.0% 1 3.688s + │ │ ├─Reify.do_reify_abs_goal --------- 26.3% 26.6% 2 2.284s + │ │ │└Reify.do_reifyf_goal ------------ 25.3% 25.6% 58 1.440s + │ │ │└eexact -------------------------- 6.9% 6.9% 58 0.032s + │ │ ├─prove_interp_compile_correct ---- 0.0% 5.2% 1 0.448s + │ │ │└rewrite ?EtaInterp.InterpExprEta 4.9% 4.9% 1 0.416s + │ │ ├─rewrite H ----------------------- 3.2% 3.2% 1 0.276s + │ │ └─tac ----------------------------- 1.4% 2.1% 1 0.180s + │ └─ReflectiveTactics.solve_post_reifie 0.6% 43.1% 1 3.700s + │ ├─UnifyAbstractReflexivity.unify_tr 31.1% 36.7% 8 1.096s + │ │└unify (constr) (constr) --------- 4.3% 4.3% 6 0.092s + │ └─ReflectiveTactics.unify_abstract_ 3.8% 5.5% 1 0.468s + └─Glue.refine_to_reflective_glue' ----- 0.0% 8.1% 1 0.696s + └Glue.zrange_to_reflective ----------- 0.0% 5.7% 1 0.488s + └Glue.zrange_to_reflective_goal ------ 2.6% 4.2% 1 0.364s +─synthesize ---------------------------- 0.0% 4.2% 1 0.356s +└IntegrationTestTemporaryMiscCommon.do_r 0.0% 3.8% 1 0.328s +└change G' ----------------------------- 3.2% 3.2% 1 0.272s + +Finished transaction in 16.611 secs (15.352u,0.s) (successful) +Closed under the global context +total time: 8.576s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 95.8% 1 8.220s +─ReflectiveTactics.do_reflective_pipelin 0.0% 87.7% 1 7.524s +─ReflectiveTactics.solve_side_conditions 0.0% 87.0% 1 7.460s +─ReflectiveTactics.do_reify ------------ 0.0% 43.8% 1 3.760s +─ReflectiveTactics.solve_post_reified_si 0.6% 43.1% 1 3.700s +─Reify.Reify_rhs_gen ------------------- 1.4% 43.0% 1 3.688s +─UnifyAbstractReflexivity.unify_transfor 31.1% 36.7% 8 1.096s +─Reify.do_reify_abs_goal --------------- 26.3% 26.6% 2 2.284s +─Reify.do_reifyf_goal ------------------ 25.3% 25.6% 58 1.440s +─Glue.refine_to_reflective_glue' ------- 0.0% 8.1% 1 0.696s +─eexact -------------------------------- 7.6% 7.6% 60 0.032s +─unify (constr) (constr) --------------- 5.8% 5.8% 7 0.128s +─Glue.zrange_to_reflective ------------- 0.0% 5.7% 1 0.488s +─ReflectiveTactics.unify_abstract_cbv_in 3.8% 5.5% 1 0.468s +─prove_interp_compile_correct ---------- 0.0% 5.2% 1 0.448s +─rewrite ?EtaInterp.InterpExprEta ------ 4.9% 4.9% 1 0.416s +─Glue.zrange_to_reflective_goal -------- 2.6% 4.2% 1 0.364s +─synthesize ---------------------------- 0.0% 4.2% 1 0.356s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 3.8% 1 0.328s +─rewrite H ----------------------------- 3.2% 3.2% 1 0.276s +─change G' ----------------------------- 3.2% 3.2% 1 0.272s +─tac ----------------------------------- 1.4% 2.1% 2 0.180s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 95.8% 1 8.220s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 87.7% 1 7.524s + │└ReflectiveTactics.solve_side_conditio 0.0% 87.0% 1 7.460s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 43.8% 1 3.760s + │ │└Reify.Reify_rhs_gen --------------- 1.4% 43.0% 1 3.688s + │ │ ├─Reify.do_reify_abs_goal --------- 26.3% 26.6% 2 2.284s + │ │ │└Reify.do_reifyf_goal ------------ 25.3% 25.6% 58 1.440s + │ │ │└eexact -------------------------- 6.9% 6.9% 58 0.032s + │ │ ├─prove_interp_compile_correct ---- 0.0% 5.2% 1 0.448s + │ │ │└rewrite ?EtaInterp.InterpExprEta 4.9% 4.9% 1 0.416s + │ │ ├─rewrite H ----------------------- 3.2% 3.2% 1 0.276s + │ │ └─tac ----------------------------- 1.4% 2.1% 1 0.180s + │ └─ReflectiveTactics.solve_post_reifie 0.6% 43.1% 1 3.700s + │ ├─UnifyAbstractReflexivity.unify_tr 31.1% 36.7% 8 1.096s + │ │└unify (constr) (constr) --------- 4.3% 4.3% 6 0.092s + │ └─ReflectiveTactics.unify_abstract_ 3.8% 5.5% 1 0.468s + └─Glue.refine_to_reflective_glue' ----- 0.0% 8.1% 1 0.696s + └Glue.zrange_to_reflective ----------- 0.0% 5.7% 1 0.488s + └Glue.zrange_to_reflective_goal ------ 2.6% 4.2% 1 0.364s +─synthesize ---------------------------- 0.0% 4.2% 1 0.356s +└IntegrationTestTemporaryMiscCommon.do_r 0.0% 3.8% 1 0.328s +└change G' ----------------------------- 3.2% 3.2% 1 0.272s + +src/Specific/X25519/C64/femul (real: 42.98, user: 39.50, sys: 0.29, mem: 839624 ko) +COQC src/Specific/X25519/C64/feaddDisplay > src/Specific/X25519/C64/feaddDisplay.log +COQC src/Specific/X25519/C64/fecarryDisplay > src/Specific/X25519/C64/fecarryDisplay.log +COQC src/Specific/X25519/C64/fesub.v +Finished transaction in 3.729 secs (3.48u,0.012s) (successful) +total time: 3.444s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 98.0% 1 3.376s +─ReflectiveTactics.do_reflective_pipelin 0.0% 77.1% 1 2.656s +─ReflectiveTactics.solve_side_conditions 0.0% 75.8% 1 2.612s +─ReflectiveTactics.solve_post_reified_si 1.2% 40.1% 1 1.380s +─ReflectiveTactics.do_reify ------------ 0.0% 35.8% 1 1.232s +─Reify.Reify_rhs_gen ------------------- 1.4% 34.4% 1 1.184s +─UnifyAbstractReflexivity.unify_transfor 25.7% 30.5% 8 0.324s +─Glue.refine_to_reflective_glue' ------- 0.0% 20.9% 1 0.720s +─Reify.do_reify_abs_goal --------------- 18.5% 18.8% 2 0.648s +─Reify.do_reifyf_goal ------------------ 17.3% 17.5% 16 0.604s +─Glue.zrange_to_reflective ------------- 0.0% 14.2% 1 0.488s +─Glue.zrange_to_reflective_goal -------- 6.5% 10.6% 1 0.364s +─ReflectiveTactics.unify_abstract_cbv_in 5.8% 8.0% 1 0.276s +─unify (constr) (constr) --------------- 5.8% 5.8% 7 0.076s +─eexact -------------------------------- 4.4% 4.4% 18 0.012s +─Glue.pattern_sig_sig_assoc ------------ 0.0% 3.8% 1 0.132s +─assert (H : is_bounded_by' bounds (map' 3.6% 3.6% 2 0.064s +─Glue.pattern_proj1_sig_in_sig --------- 1.2% 3.6% 1 0.124s +─prove_interp_compile_correct ---------- 0.0% 3.5% 1 0.120s +─rewrite H ----------------------------- 3.4% 3.4% 1 0.116s +─rewrite ?EtaInterp.InterpExprEta ------ 3.1% 3.1% 1 0.108s +─pose proof (pf : Interpretation.Bo 2.7% 2.7% 1 0.092s +─reflexivity --------------------------- 2.6% 2.6% 7 0.032s +─Glue.split_BoundedWordToZ ------------- 0.2% 2.4% 1 0.084s +─tac ----------------------------------- 1.7% 2.2% 2 0.076s +─Reify.transitivity_tt ----------------- 0.1% 2.2% 2 0.040s +─transitivity -------------------------- 2.1% 2.1% 5 0.032s +─clearbody (ne_var_list) --------------- 2.1% 2.1% 4 0.056s +─destruct_sig -------------------------- 0.0% 2.1% 4 0.040s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 98.0% 1 3.376s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 77.1% 1 2.656s + │└ReflectiveTactics.solve_side_conditio 0.0% 75.8% 1 2.612s + │ ├─ReflectiveTactics.solve_post_reifie 1.2% 40.1% 1 1.380s + │ │ ├─UnifyAbstractReflexivity.unify_tr 25.7% 30.5% 8 0.324s + │ │ │└unify (constr) (constr) --------- 3.6% 3.6% 6 0.040s + │ │ └─ReflectiveTactics.unify_abstract_ 5.8% 8.0% 1 0.276s + │ │ └unify (constr) (constr) --------- 2.2% 2.2% 1 0.076s + │ └─ReflectiveTactics.do_reify -------- 0.0% 35.8% 1 1.232s + │ └Reify.Reify_rhs_gen --------------- 1.4% 34.4% 1 1.184s + │ ├─Reify.do_reify_abs_goal --------- 18.5% 18.8% 2 0.648s + │ │└Reify.do_reifyf_goal ------------ 17.3% 17.5% 16 0.604s + │ │└eexact -------------------------- 3.8% 3.8% 16 0.012s + │ ├─prove_interp_compile_correct ---- 0.0% 3.5% 1 0.120s + │ │└rewrite ?EtaInterp.InterpExprEta 3.1% 3.1% 1 0.108s + │ ├─rewrite H ----------------------- 3.4% 3.4% 1 0.116s + │ ├─tac ----------------------------- 1.7% 2.2% 1 0.076s + │ └─Reify.transitivity_tt ----------- 0.1% 2.2% 2 0.040s + └─Glue.refine_to_reflective_glue' ----- 0.0% 20.9% 1 0.720s + ├─Glue.zrange_to_reflective --------- 0.0% 14.2% 1 0.488s + │ ├─Glue.zrange_to_reflective_goal -- 6.5% 10.6% 1 0.364s + │ │└pose proof (pf : Interpretat 2.7% 2.7% 1 0.092s + │ └─assert (H : is_bounded_by' bounds 3.6% 3.6% 2 0.064s + ├─Glue.pattern_sig_sig_assoc -------- 0.0% 3.8% 1 0.132s + │└Glue.pattern_proj1_sig_in_sig ----- 1.2% 3.6% 1 0.124s + └─Glue.split_BoundedWordToZ --------- 0.2% 2.4% 1 0.084s + └destruct_sig ---------------------- 0.0% 2.1% 4 0.040s + +Finished transaction in 6.763 secs (6.183u,0.s) (successful) +Closed under the global context +total time: 3.444s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 98.0% 1 3.376s +─ReflectiveTactics.do_reflective_pipelin 0.0% 77.1% 1 2.656s +─ReflectiveTactics.solve_side_conditions 0.0% 75.8% 1 2.612s +─ReflectiveTactics.solve_post_reified_si 1.2% 40.1% 1 1.380s +─ReflectiveTactics.do_reify ------------ 0.0% 35.8% 1 1.232s +─Reify.Reify_rhs_gen ------------------- 1.4% 34.4% 1 1.184s +─UnifyAbstractReflexivity.unify_transfor 25.7% 30.5% 8 0.324s +─Glue.refine_to_reflective_glue' ------- 0.0% 20.9% 1 0.720s +─Reify.do_reify_abs_goal --------------- 18.5% 18.8% 2 0.648s +─Reify.do_reifyf_goal ------------------ 17.3% 17.5% 16 0.604s +─Glue.zrange_to_reflective ------------- 0.0% 14.2% 1 0.488s +─Glue.zrange_to_reflective_goal -------- 6.5% 10.6% 1 0.364s +─ReflectiveTactics.unify_abstract_cbv_in 5.8% 8.0% 1 0.276s +─unify (constr) (constr) --------------- 5.8% 5.8% 7 0.076s +─eexact -------------------------------- 4.4% 4.4% 18 0.012s +─Glue.pattern_sig_sig_assoc ------------ 0.0% 3.8% 1 0.132s +─assert (H : is_bounded_by' bounds (map' 3.6% 3.6% 2 0.064s +─Glue.pattern_proj1_sig_in_sig --------- 1.2% 3.6% 1 0.124s +─prove_interp_compile_correct ---------- 0.0% 3.5% 1 0.120s +─rewrite H ----------------------------- 3.4% 3.4% 1 0.116s +─rewrite ?EtaInterp.InterpExprEta ------ 3.1% 3.1% 1 0.108s +─pose proof (pf : Interpretation.Bo 2.7% 2.7% 1 0.092s +─reflexivity --------------------------- 2.6% 2.6% 7 0.032s +─Glue.split_BoundedWordToZ ------------- 0.2% 2.4% 1 0.084s +─tac ----------------------------------- 1.7% 2.2% 2 0.076s +─Reify.transitivity_tt ----------------- 0.1% 2.2% 2 0.040s +─transitivity -------------------------- 2.1% 2.1% 5 0.032s +─clearbody (ne_var_list) --------------- 2.1% 2.1% 4 0.056s +─destruct_sig -------------------------- 0.0% 2.1% 4 0.040s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 98.0% 1 3.376s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 77.1% 1 2.656s + │└ReflectiveTactics.solve_side_conditio 0.0% 75.8% 1 2.612s + │ ├─ReflectiveTactics.solve_post_reifie 1.2% 40.1% 1 1.380s + │ │ ├─UnifyAbstractReflexivity.unify_tr 25.7% 30.5% 8 0.324s + │ │ │└unify (constr) (constr) --------- 3.6% 3.6% 6 0.040s + │ │ └─ReflectiveTactics.unify_abstract_ 5.8% 8.0% 1 0.276s + │ │ └unify (constr) (constr) --------- 2.2% 2.2% 1 0.076s + │ └─ReflectiveTactics.do_reify -------- 0.0% 35.8% 1 1.232s + │ └Reify.Reify_rhs_gen --------------- 1.4% 34.4% 1 1.184s + │ ├─Reify.do_reify_abs_goal --------- 18.5% 18.8% 2 0.648s + │ │└Reify.do_reifyf_goal ------------ 17.3% 17.5% 16 0.604s + │ │└eexact -------------------------- 3.8% 3.8% 16 0.012s + │ ├─prove_interp_compile_correct ---- 0.0% 3.5% 1 0.120s + │ │└rewrite ?EtaInterp.InterpExprEta 3.1% 3.1% 1 0.108s + │ ├─rewrite H ----------------------- 3.4% 3.4% 1 0.116s + │ ├─tac ----------------------------- 1.7% 2.2% 1 0.076s + │ └─Reify.transitivity_tt ----------- 0.1% 2.2% 2 0.040s + └─Glue.refine_to_reflective_glue' ----- 0.0% 20.9% 1 0.720s + ├─Glue.zrange_to_reflective --------- 0.0% 14.2% 1 0.488s + │ ├─Glue.zrange_to_reflective_goal -- 6.5% 10.6% 1 0.364s + │ │└pose proof (pf : Interpretat 2.7% 2.7% 1 0.092s + │ └─assert (H : is_bounded_by' bounds 3.6% 3.6% 2 0.064s + ├─Glue.pattern_sig_sig_assoc -------- 0.0% 3.8% 1 0.132s + │└Glue.pattern_proj1_sig_in_sig ----- 1.2% 3.6% 1 0.124s + └─Glue.split_BoundedWordToZ --------- 0.2% 2.4% 1 0.084s + └destruct_sig ---------------------- 0.0% 2.1% 4 0.040s + +src/Specific/X25519/C64/fesub (real: 26.11, user: 23.72, sys: 0.24, mem: 781808 ko) +COQC src/Specific/X25519/C64/fesquare.v +Finished transaction in 6.477 secs (6.044u,0.008s) (successful) +total time: 6.012s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize ---------------------------- 0.0% 100.0% 1 6.012s +─Pipeline.refine_reflectively_gen ------ 0.0% 95.9% 1 5.764s +─ReflectiveTactics.do_reflective_pipelin 0.0% 89.6% 1 5.388s +─ReflectiveTactics.solve_side_conditions 0.0% 88.8% 1 5.340s +─ReflectiveTactics.do_reify ------------ 0.0% 47.0% 1 2.828s +─Reify.Reify_rhs_gen ------------------- 1.5% 46.3% 1 2.784s +─ReflectiveTactics.solve_post_reified_si 0.5% 41.8% 1 2.512s +─UnifyAbstractReflexivity.unify_transfor 28.5% 34.1% 8 0.552s +─Reify.do_reify_abs_goal --------------- 28.7% 29.1% 2 1.752s +─Reify.do_reifyf_goal ------------------ 27.6% 27.9% 47 1.320s +─eexact -------------------------------- 8.4% 8.4% 49 0.024s +─ReflectiveTactics.unify_abstract_cbv_in 5.0% 6.9% 1 0.412s +─unify (constr) (constr) --------------- 6.3% 6.3% 7 0.104s +─Glue.refine_to_reflective_glue' ------- 0.0% 6.3% 1 0.376s +─prove_interp_compile_correct ---------- 0.0% 5.3% 1 0.316s +─rewrite ?EtaInterp.InterpExprEta ------ 4.8% 4.8% 1 0.288s +─Glue.zrange_to_reflective ------------- 0.0% 4.4% 1 0.264s +─IntegrationTestTemporaryMiscCommon.do_r 0.1% 3.7% 1 0.224s +─Glue.zrange_to_reflective_goal -------- 2.6% 3.3% 1 0.196s +─change G' ----------------------------- 3.1% 3.1% 1 0.188s +─rewrite H ----------------------------- 3.0% 3.0% 1 0.180s +─tac ----------------------------------- 1.9% 2.7% 2 0.160s +─reflexivity --------------------------- 2.4% 2.4% 7 0.060s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize ---------------------------- 0.0% 100.0% 1 6.012s + ├─Pipeline.refine_reflectively_gen ---- 0.0% 95.9% 1 5.764s + │ ├─ReflectiveTactics.do_reflective_pip 0.0% 89.6% 1 5.388s + │ │└ReflectiveTactics.solve_side_condit 0.0% 88.8% 1 5.340s + │ │ ├─ReflectiveTactics.do_reify ------ 0.0% 47.0% 1 2.828s + │ │ │└Reify.Reify_rhs_gen ------------- 1.5% 46.3% 1 2.784s + │ │ │ ├─Reify.do_reify_abs_goal ------- 28.7% 29.1% 2 1.752s + │ │ │ │└Reify.do_reifyf_goal ---------- 27.6% 27.9% 47 1.320s + │ │ │ │└eexact ------------------------ 7.7% 7.7% 47 0.024s + │ │ │ ├─prove_interp_compile_correct -- 0.0% 5.3% 1 0.316s + │ │ │ │└rewrite ?EtaInterp.InterpExprEt 4.8% 4.8% 1 0.288s + │ │ │ ├─rewrite H --------------------- 3.0% 3.0% 1 0.180s + │ │ │ └─tac --------------------------- 1.9% 2.7% 1 0.160s + │ │ └─ReflectiveTactics.solve_post_reif 0.5% 41.8% 1 2.512s + │ │ ├─UnifyAbstractReflexivity.unify_ 28.5% 34.1% 8 0.552s + │ │ │└unify (constr) (constr) ------- 4.6% 4.6% 6 0.076s + │ │ └─ReflectiveTactics.unify_abstrac 5.0% 6.9% 1 0.412s + │ └─Glue.refine_to_reflective_glue' --- 0.0% 6.3% 1 0.376s + │ └Glue.zrange_to_reflective --------- 0.0% 4.4% 1 0.264s + │ └Glue.zrange_to_reflective_goal ---- 2.6% 3.3% 1 0.196s + └─IntegrationTestTemporaryMiscCommon.do 0.1% 3.7% 1 0.224s + └change G' --------------------------- 3.1% 3.1% 1 0.188s + +Finished transaction in 12.356 secs (11.331u,0.004s) (successful) +Closed under the global context +total time: 6.012s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize ---------------------------- 0.0% 100.0% 1 6.012s +─Pipeline.refine_reflectively_gen ------ 0.0% 95.9% 1 5.764s +─ReflectiveTactics.do_reflective_pipelin 0.0% 89.6% 1 5.388s +─ReflectiveTactics.solve_side_conditions 0.0% 88.8% 1 5.340s +─ReflectiveTactics.do_reify ------------ 0.0% 47.0% 1 2.828s +─Reify.Reify_rhs_gen ------------------- 1.5% 46.3% 1 2.784s +─ReflectiveTactics.solve_post_reified_si 0.5% 41.8% 1 2.512s +─UnifyAbstractReflexivity.unify_transfor 28.5% 34.1% 8 0.552s +─Reify.do_reify_abs_goal --------------- 28.7% 29.1% 2 1.752s +─Reify.do_reifyf_goal ------------------ 27.6% 27.9% 47 1.320s +─eexact -------------------------------- 8.4% 8.4% 49 0.024s +─ReflectiveTactics.unify_abstract_cbv_in 5.0% 6.9% 1 0.412s +─unify (constr) (constr) --------------- 6.3% 6.3% 7 0.104s +─Glue.refine_to_reflective_glue' ------- 0.0% 6.3% 1 0.376s +─prove_interp_compile_correct ---------- 0.0% 5.3% 1 0.316s +─rewrite ?EtaInterp.InterpExprEta ------ 4.8% 4.8% 1 0.288s +─Glue.zrange_to_reflective ------------- 0.0% 4.4% 1 0.264s +─IntegrationTestTemporaryMiscCommon.do_r 0.1% 3.7% 1 0.224s +─Glue.zrange_to_reflective_goal -------- 2.6% 3.3% 1 0.196s +─change G' ----------------------------- 3.1% 3.1% 1 0.188s +─rewrite H ----------------------------- 3.0% 3.0% 1 0.180s +─tac ----------------------------------- 1.9% 2.7% 2 0.160s +─reflexivity --------------------------- 2.4% 2.4% 7 0.060s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize ---------------------------- 0.0% 100.0% 1 6.012s + ├─Pipeline.refine_reflectively_gen ---- 0.0% 95.9% 1 5.764s + │ ├─ReflectiveTactics.do_reflective_pip 0.0% 89.6% 1 5.388s + │ │└ReflectiveTactics.solve_side_condit 0.0% 88.8% 1 5.340s + │ │ ├─ReflectiveTactics.do_reify ------ 0.0% 47.0% 1 2.828s + │ │ │└Reify.Reify_rhs_gen ------------- 1.5% 46.3% 1 2.784s + │ │ │ ├─Reify.do_reify_abs_goal ------- 28.7% 29.1% 2 1.752s + │ │ │ │└Reify.do_reifyf_goal ---------- 27.6% 27.9% 47 1.320s + │ │ │ │└eexact ------------------------ 7.7% 7.7% 47 0.024s + │ │ │ ├─prove_interp_compile_correct -- 0.0% 5.3% 1 0.316s + │ │ │ │└rewrite ?EtaInterp.InterpExprEt 4.8% 4.8% 1 0.288s + │ │ │ ├─rewrite H --------------------- 3.0% 3.0% 1 0.180s + │ │ │ └─tac --------------------------- 1.9% 2.7% 1 0.160s + │ │ └─ReflectiveTactics.solve_post_reif 0.5% 41.8% 1 2.512s + │ │ ├─UnifyAbstractReflexivity.unify_ 28.5% 34.1% 8 0.552s + │ │ │└unify (constr) (constr) ------- 4.6% 4.6% 6 0.076s + │ │ └─ReflectiveTactics.unify_abstrac 5.0% 6.9% 1 0.412s + │ └─Glue.refine_to_reflective_glue' --- 0.0% 6.3% 1 0.376s + │ └Glue.zrange_to_reflective --------- 0.0% 4.4% 1 0.264s + │ └Glue.zrange_to_reflective_goal ---- 2.6% 3.3% 1 0.196s + └─IntegrationTestTemporaryMiscCommon.do 0.1% 3.7% 1 0.224s + └change G' --------------------------- 3.1% 3.1% 1 0.188s + +src/Specific/X25519/C64/fesquare (real: 35.23, user: 32.24, sys: 0.26, mem: 802776 ko) +COQC src/Specific/X25519/C64/femulDisplay > src/Specific/X25519/C64/femulDisplay.log +COQC src/Specific/X25519/C64/freeze.v +Finished transaction in 7.785 secs (7.139u,0.019s) (successful) +total time: 7.112s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_freeze --------------------- -0.0% 100.0% 1 7.112s +─Pipeline.refine_reflectively_gen ------ 0.0% 99.2% 1 7.056s +─ReflectiveTactics.do_reflective_pipelin 0.0% 92.8% 1 6.600s +─ReflectiveTactics.solve_side_conditions -0.0% 91.8% 1 6.532s +─ReflectiveTactics.do_reify ------------ 0.0% 57.1% 1 4.060s +─Reify.Reify_rhs_gen ------------------- 1.5% 56.4% 1 4.012s +─Reify.do_reify_abs_goal --------------- 40.1% 40.3% 2 2.868s +─Reify.do_reifyf_goal ------------------ 39.1% 39.4% 129 2.800s +─ReflectiveTactics.solve_post_reified_si 0.6% 34.8% 1 2.472s +─UnifyAbstractReflexivity.unify_transfor 25.2% 29.4% 8 0.428s +─eexact -------------------------------- 12.9% 12.9% 131 0.028s +─Glue.refine_to_reflective_glue' ------- 0.1% 6.4% 1 0.456s +─prove_interp_compile_correct ---------- 0.0% 4.7% 1 0.332s +─unify (constr) (constr) --------------- 4.6% 4.6% 7 0.096s +─ReflectiveTactics.unify_abstract_cbv_in 3.1% 4.6% 1 0.324s +─rewrite ?EtaInterp.InterpExprEta ------ 4.3% 4.3% 1 0.308s +─Glue.zrange_to_reflective ------------- 0.0% 4.1% 1 0.292s +─Glue.zrange_to_reflective_goal -------- 2.6% 3.2% 1 0.228s +─rewrite H ----------------------------- 3.0% 3.0% 1 0.212s +─reflexivity --------------------------- 2.3% 2.3% 7 0.064s +─Reify.transitivity_tt ----------------- 0.0% 2.1% 2 0.096s +─transitivity -------------------------- 2.1% 2.1% 5 0.084s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_freeze --------------------- -0.0% 100.0% 1 7.112s +└Pipeline.refine_reflectively_gen ------ 0.0% 99.2% 1 7.056s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 92.8% 1 6.600s + │└ReflectiveTactics.solve_side_conditio -0.0% 91.8% 1 6.532s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 57.1% 1 4.060s + │ │└Reify.Reify_rhs_gen --------------- 1.5% 56.4% 1 4.012s + │ │ ├─Reify.do_reify_abs_goal --------- 40.1% 40.3% 2 2.868s + │ │ │└Reify.do_reifyf_goal ------------ 39.1% 39.4% 129 2.800s + │ │ │└eexact -------------------------- 12.4% 12.4% 129 0.028s + │ │ ├─prove_interp_compile_correct ---- 0.0% 4.7% 1 0.332s + │ │ │└rewrite ?EtaInterp.InterpExprEta 4.3% 4.3% 1 0.308s + │ │ ├─rewrite H ----------------------- 3.0% 3.0% 1 0.212s + │ │ └─Reify.transitivity_tt ----------- 0.0% 2.1% 2 0.096s + │ │ └transitivity -------------------- 2.0% 2.0% 4 0.084s + │ └─ReflectiveTactics.solve_post_reifie 0.6% 34.8% 1 2.472s + │ ├─UnifyAbstractReflexivity.unify_tr 25.2% 29.4% 8 0.428s + │ │└unify (constr) (constr) --------- 3.2% 3.2% 6 0.068s + │ └─ReflectiveTactics.unify_abstract_ 3.1% 4.6% 1 0.324s + └─Glue.refine_to_reflective_glue' ----- 0.1% 6.4% 1 0.456s + └Glue.zrange_to_reflective ----------- 0.0% 4.1% 1 0.292s + └Glue.zrange_to_reflective_goal ------ 2.6% 3.2% 1 0.228s + +Finished transaction in 12.063 secs (11.036u,0.012s) (successful) +Closed under the global context +total time: 7.112s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_freeze --------------------- -0.0% 100.0% 1 7.112s +─Pipeline.refine_reflectively_gen ------ 0.0% 99.2% 1 7.056s +─ReflectiveTactics.do_reflective_pipelin 0.0% 92.8% 1 6.600s +─ReflectiveTactics.solve_side_conditions -0.0% 91.8% 1 6.532s +─ReflectiveTactics.do_reify ------------ 0.0% 57.1% 1 4.060s +─Reify.Reify_rhs_gen ------------------- 1.5% 56.4% 1 4.012s +─Reify.do_reify_abs_goal --------------- 40.1% 40.3% 2 2.868s +─Reify.do_reifyf_goal ------------------ 39.1% 39.4% 129 2.800s +─ReflectiveTactics.solve_post_reified_si 0.6% 34.8% 1 2.472s +─UnifyAbstractReflexivity.unify_transfor 25.2% 29.4% 8 0.428s +─eexact -------------------------------- 12.9% 12.9% 131 0.028s +─Glue.refine_to_reflective_glue' ------- 0.1% 6.4% 1 0.456s +─prove_interp_compile_correct ---------- 0.0% 4.7% 1 0.332s +─unify (constr) (constr) --------------- 4.6% 4.6% 7 0.096s +─ReflectiveTactics.unify_abstract_cbv_in 3.1% 4.6% 1 0.324s +─rewrite ?EtaInterp.InterpExprEta ------ 4.3% 4.3% 1 0.308s +─Glue.zrange_to_reflective ------------- 0.0% 4.1% 1 0.292s +─Glue.zrange_to_reflective_goal -------- 2.6% 3.2% 1 0.228s +─rewrite H ----------------------------- 3.0% 3.0% 1 0.212s +─reflexivity --------------------------- 2.3% 2.3% 7 0.064s +─Reify.transitivity_tt ----------------- 0.0% 2.1% 2 0.096s +─transitivity -------------------------- 2.1% 2.1% 5 0.084s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_freeze --------------------- -0.0% 100.0% 1 7.112s +└Pipeline.refine_reflectively_gen ------ 0.0% 99.2% 1 7.056s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 92.8% 1 6.600s + │└ReflectiveTactics.solve_side_conditio -0.0% 91.8% 1 6.532s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 57.1% 1 4.060s + │ │└Reify.Reify_rhs_gen --------------- 1.5% 56.4% 1 4.012s + │ │ ├─Reify.do_reify_abs_goal --------- 40.1% 40.3% 2 2.868s + │ │ │└Reify.do_reifyf_goal ------------ 39.1% 39.4% 129 2.800s + │ │ │└eexact -------------------------- 12.4% 12.4% 129 0.028s + │ │ ├─prove_interp_compile_correct ---- 0.0% 4.7% 1 0.332s + │ │ │└rewrite ?EtaInterp.InterpExprEta 4.3% 4.3% 1 0.308s + │ │ ├─rewrite H ----------------------- 3.0% 3.0% 1 0.212s + │ │ └─Reify.transitivity_tt ----------- 0.0% 2.1% 2 0.096s + │ │ └transitivity -------------------- 2.0% 2.0% 4 0.084s + │ └─ReflectiveTactics.solve_post_reifie 0.6% 34.8% 1 2.472s + │ ├─UnifyAbstractReflexivity.unify_tr 25.2% 29.4% 8 0.428s + │ │└unify (constr) (constr) --------- 3.2% 3.2% 6 0.068s + │ └─ReflectiveTactics.unify_abstract_ 3.1% 4.6% 1 0.324s + └─Glue.refine_to_reflective_glue' ----- 0.1% 6.4% 1 0.456s + └Glue.zrange_to_reflective ----------- 0.0% 4.1% 1 0.292s + └Glue.zrange_to_reflective_goal ------ 2.6% 3.2% 1 0.228s + +src/Specific/X25519/C64/freeze (real: 36.42, user: 33.24, sys: 0.26, mem: 826476 ko) +COQC src/Specific/NISTP256/AMD64/feadd.v +Finished transaction in 9.065 secs (8.452u,0.004s) (successful) +total time: 8.408s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 56.0% 1 4.712s +─ReflectiveTactics.do_reflective_pipelin 0.0% 47.7% 1 4.012s +─ReflectiveTactics.solve_side_conditions 0.0% 47.1% 1 3.960s +─synthesize_montgomery ----------------- 0.0% 44.0% 1 3.696s +─ReflectiveTactics.solve_post_reified_si 0.6% 26.4% 1 2.220s +─UnifyAbstractReflexivity.unify_transfor 18.0% 21.3% 8 0.508s +─IntegrationTestTemporaryMiscCommon.fact 1.3% 21.3% 1 1.788s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 21.0% 1 1.768s +─ReflectiveTactics.do_reify ------------ 0.0% 20.7% 1 1.740s +─Reify.Reify_rhs_gen ------------------- 1.0% 20.0% 1 1.684s +─DestructHyps.do_all_matches_then ------ 0.1% 18.6% 8 0.220s +─DestructHyps.do_one_match_then -------- 0.8% 18.5% 44 0.056s +─op_sig_side_conditions_t -------------- 0.0% 17.9% 1 1.504s +─do_tac -------------------------------- 0.0% 17.7% 43 0.052s +─destruct H ---------------------------- 17.7% 17.7% 36 0.052s +─rewrite <- (lem : lemT) by by_tac ltac: 0.3% 17.3% 1 1.452s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 17.3% 1 1.452s +─by_tac -------------------------------- 0.0% 17.0% 4 0.532s +─rewrite <- (ZRange.is_bounded_by_None_r 15.7% 15.8% 8 0.360s +─Reify.do_reify_abs_goal --------------- 9.1% 9.3% 2 0.780s +─Reify.do_reifyf_goal ------------------ 8.5% 8.6% 93 0.716s +─Glue.refine_to_reflective_glue' ------- 0.0% 8.3% 1 0.700s +─Glue.zrange_to_reflective ------------- 0.0% 5.3% 1 0.444s +─ReflectiveTactics.unify_abstract_cbv_in 2.9% 4.3% 1 0.360s +─Glue.zrange_to_reflective_goal -------- 2.5% 4.0% 1 0.336s +─unify (constr) (constr) --------------- 3.9% 3.9% 9 0.108s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 3.8% 1 0.316s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.8% 3.6% 3 0.300s +─k ------------------------------------- 2.6% 2.8% 1 0.232s +─rewrite H ----------------------------- 2.4% 2.4% 2 0.192s +─prove_interp_compile_correct ---------- 0.0% 2.4% 1 0.200s +─rewrite ?EtaInterp.InterpExprEta ------ 2.2% 2.2% 1 0.188s +─apply (fun f => MapProjections.proj2 2.1% 2.1% 2 0.108s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 56.0% 1 4.712s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 47.7% 1 4.012s + │└ReflectiveTactics.solve_side_conditio 0.0% 47.1% 1 3.960s + │ ├─ReflectiveTactics.solve_post_reifie 0.6% 26.4% 1 2.220s + │ │ ├─UnifyAbstractReflexivity.unify_tr 18.0% 21.3% 8 0.508s + │ │ │└unify (constr) (constr) --------- 2.6% 2.6% 6 0.064s + │ │ └─ReflectiveTactics.unify_abstract_ 2.9% 4.3% 1 0.360s + │ └─ReflectiveTactics.do_reify -------- 0.0% 20.7% 1 1.740s + │ └Reify.Reify_rhs_gen --------------- 1.0% 20.0% 1 1.684s + │ ├─Reify.do_reify_abs_goal --------- 9.1% 9.3% 2 0.780s + │ │└Reify.do_reifyf_goal ------------ 8.5% 8.6% 93 0.716s + │ ├─prove_interp_compile_correct ---- 0.0% 2.4% 1 0.200s + │ │└rewrite ?EtaInterp.InterpExprEta 2.2% 2.2% 1 0.188s + │ └─rewrite H ----------------------- 2.3% 2.3% 1 0.192s + └─Glue.refine_to_reflective_glue' ----- 0.0% 8.3% 1 0.700s + └Glue.zrange_to_reflective ----------- 0.0% 5.3% 1 0.444s + └Glue.zrange_to_reflective_goal ------ 2.5% 4.0% 1 0.336s +─synthesize_montgomery ----------------- 0.0% 44.0% 1 3.696s + ├─IntegrationTestTemporaryMiscCommon.fa 1.3% 21.3% 1 1.788s + │└op_sig_side_conditions_t ------------ 0.0% 17.9% 1 1.504s + │ ├─DestructHyps.do_all_matches_then -- 0.1% 10.1% 4 0.220s + │ │└DestructHyps.do_one_match_then ---- 0.4% 10.0% 24 0.052s + │ │└do_tac ---------------------------- 0.0% 9.6% 20 0.048s + │ │└destruct H ------------------------ 9.6% 9.6% 20 0.048s + │ └─rewrite <- (ZRange.is_bounded_by_No 7.5% 7.6% 4 0.308s + └─IntegrationTestTemporaryMiscCommon.do 0.0% 21.0% 1 1.768s + ├─IntegrationTestTemporaryMiscCommon. 0.0% 17.3% 1 1.452s + │└rewrite <- (lem : lemT) by by_tac l 0.3% 17.3% 1 1.452s + │└by_tac ---------------------------- 0.0% 17.0% 4 0.532s + │ ├─DestructHyps.do_all_matches_then 0.0% 8.5% 4 0.184s + │ │└DestructHyps.do_one_match_then -- 0.3% 8.5% 20 0.056s + │ │└do_tac -------------------------- 0.0% 8.2% 16 0.052s + │ │└destruct H ---------------------- 8.2% 8.2% 16 0.052s + │ └─rewrite <- (ZRange.is_bounded_by_ 8.2% 8.3% 4 0.360s + └─IntegrationTestTemporaryMiscCommon. 0.0% 3.8% 1 0.316s + └<Crypto.Util.Tactics.MoveLetIn.with 0.8% 3.6% 3 0.300s + └k --------------------------------- 2.6% 2.8% 1 0.232s + +Finished transaction in 15.052 secs (13.947u,0.003s) (successful) +Closed under the global context +total time: 8.408s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 56.0% 1 4.712s +─ReflectiveTactics.do_reflective_pipelin 0.0% 47.7% 1 4.012s +─ReflectiveTactics.solve_side_conditions 0.0% 47.1% 1 3.960s +─synthesize_montgomery ----------------- 0.0% 44.0% 1 3.696s +─ReflectiveTactics.solve_post_reified_si 0.6% 26.4% 1 2.220s +─UnifyAbstractReflexivity.unify_transfor 18.0% 21.3% 8 0.508s +─IntegrationTestTemporaryMiscCommon.fact 1.3% 21.3% 1 1.788s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 21.0% 1 1.768s +─ReflectiveTactics.do_reify ------------ 0.0% 20.7% 1 1.740s +─Reify.Reify_rhs_gen ------------------- 1.0% 20.0% 1 1.684s +─DestructHyps.do_all_matches_then ------ 0.1% 18.6% 8 0.220s +─DestructHyps.do_one_match_then -------- 0.8% 18.5% 44 0.056s +─op_sig_side_conditions_t -------------- 0.0% 17.9% 1 1.504s +─do_tac -------------------------------- 0.0% 17.7% 43 0.052s +─destruct H ---------------------------- 17.7% 17.7% 36 0.052s +─rewrite <- (lem : lemT) by by_tac ltac: 0.3% 17.3% 1 1.452s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 17.3% 1 1.452s +─by_tac -------------------------------- 0.0% 17.0% 4 0.532s +─rewrite <- (ZRange.is_bounded_by_None_r 15.7% 15.8% 8 0.360s +─Reify.do_reify_abs_goal --------------- 9.1% 9.3% 2 0.780s +─Reify.do_reifyf_goal ------------------ 8.5% 8.6% 93 0.716s +─Glue.refine_to_reflective_glue' ------- 0.0% 8.3% 1 0.700s +─Glue.zrange_to_reflective ------------- 0.0% 5.3% 1 0.444s +─ReflectiveTactics.unify_abstract_cbv_in 2.9% 4.3% 1 0.360s +─Glue.zrange_to_reflective_goal -------- 2.5% 4.0% 1 0.336s +─unify (constr) (constr) --------------- 3.9% 3.9% 9 0.108s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 3.8% 1 0.316s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.8% 3.6% 3 0.300s +─k ------------------------------------- 2.6% 2.8% 1 0.232s +─rewrite H ----------------------------- 2.4% 2.4% 2 0.192s +─prove_interp_compile_correct ---------- 0.0% 2.4% 1 0.200s +─rewrite ?EtaInterp.InterpExprEta ------ 2.2% 2.2% 1 0.188s +─apply (fun f => MapProjections.proj2 2.1% 2.1% 2 0.108s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 56.0% 1 4.712s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 47.7% 1 4.012s + │└ReflectiveTactics.solve_side_conditio 0.0% 47.1% 1 3.960s + │ ├─ReflectiveTactics.solve_post_reifie 0.6% 26.4% 1 2.220s + │ │ ├─UnifyAbstractReflexivity.unify_tr 18.0% 21.3% 8 0.508s + │ │ │└unify (constr) (constr) --------- 2.6% 2.6% 6 0.064s + │ │ └─ReflectiveTactics.unify_abstract_ 2.9% 4.3% 1 0.360s + │ └─ReflectiveTactics.do_reify -------- 0.0% 20.7% 1 1.740s + │ └Reify.Reify_rhs_gen --------------- 1.0% 20.0% 1 1.684s + │ ├─Reify.do_reify_abs_goal --------- 9.1% 9.3% 2 0.780s + │ │└Reify.do_reifyf_goal ------------ 8.5% 8.6% 93 0.716s + │ ├─prove_interp_compile_correct ---- 0.0% 2.4% 1 0.200s + │ │└rewrite ?EtaInterp.InterpExprEta 2.2% 2.2% 1 0.188s + │ └─rewrite H ----------------------- 2.3% 2.3% 1 0.192s + └─Glue.refine_to_reflective_glue' ----- 0.0% 8.3% 1 0.700s + └Glue.zrange_to_reflective ----------- 0.0% 5.3% 1 0.444s + └Glue.zrange_to_reflective_goal ------ 2.5% 4.0% 1 0.336s +─synthesize_montgomery ----------------- 0.0% 44.0% 1 3.696s + ├─IntegrationTestTemporaryMiscCommon.fa 1.3% 21.3% 1 1.788s + │└op_sig_side_conditions_t ------------ 0.0% 17.9% 1 1.504s + │ ├─DestructHyps.do_all_matches_then -- 0.1% 10.1% 4 0.220s + │ │└DestructHyps.do_one_match_then ---- 0.4% 10.0% 24 0.052s + │ │└do_tac ---------------------------- 0.0% 9.6% 20 0.048s + │ │└destruct H ------------------------ 9.6% 9.6% 20 0.048s + │ └─rewrite <- (ZRange.is_bounded_by_No 7.5% 7.6% 4 0.308s + └─IntegrationTestTemporaryMiscCommon.do 0.0% 21.0% 1 1.768s + ├─IntegrationTestTemporaryMiscCommon. 0.0% 17.3% 1 1.452s + │└rewrite <- (lem : lemT) by by_tac l 0.3% 17.3% 1 1.452s + │└by_tac ---------------------------- 0.0% 17.0% 4 0.532s + │ ├─DestructHyps.do_all_matches_then 0.0% 8.5% 4 0.184s + │ │└DestructHyps.do_one_match_then -- 0.3% 8.5% 20 0.056s + │ │└do_tac -------------------------- 0.0% 8.2% 16 0.052s + │ │└destruct H ---------------------- 8.2% 8.2% 16 0.052s + │ └─rewrite <- (ZRange.is_bounded_by_ 8.2% 8.3% 4 0.360s + └─IntegrationTestTemporaryMiscCommon. 0.0% 3.8% 1 0.316s + └<Crypto.Util.Tactics.MoveLetIn.with 0.8% 3.6% 3 0.300s + └k --------------------------------- 2.6% 2.8% 1 0.232s + +src/Specific/NISTP256/AMD64/feadd (real: 40.48, user: 37.21, sys: 0.27, mem: 797944 ko) +COQC src/Specific/NISTP256/AMD64/fenz.v +Finished transaction in 6.724 secs (6.196u,0.007s) (successful) +total time: 6.180s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_nonzero -------------------- 0.0% 100.0% 1 6.180s +─IntegrationTestTemporaryMiscCommon.nonz 0.1% 84.5% 1 5.224s +─destruct (Decidable.dec x), (Decidable. 36.7% 36.7% 1 2.268s +─destruct (Decidable.dec x) as [H| H] -- 21.6% 21.6% 1 1.336s +─Pipeline.refine_reflectively_gen ------ 0.1% 15.5% 1 0.956s +─ReflectiveTactics.do_reflective_pipelin 0.0% 11.9% 1 0.736s +─ReflectiveTactics.solve_side_conditions 0.0% 11.6% 1 0.716s +─ReflectiveTactics.solve_post_reified_si 0.3% 9.6% 1 0.592s +─IntegrationTestTemporaryMiscCommon.op_s 0.1% 7.9% 2 0.392s +─rewrite <- (ZRange.is_bounded_by_None_r 5.2% 5.2% 2 0.308s +─UnifyAbstractReflexivity.unify_transfor 4.2% 5.2% 8 0.076s +─ReflectiveTactics.unify_abstract_cbv_in 3.0% 4.0% 1 0.248s +─Glue.refine_to_reflective_glue' ------- 0.0% 3.5% 1 0.216s +─rewrite H' ---------------------------- 3.4% 3.4% 1 0.208s +─generalize dependent (constr) --------- 3.1% 3.1% 4 0.068s +─congruence ---------------------------- 2.8% 2.8% 1 0.176s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 2.7% 1 0.164s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.5% 2.6% 3 0.156s +─DestructHyps.do_one_match_then -------- 0.1% 2.5% 6 0.048s +─DestructHyps.do_all_matches_then ------ 0.0% 2.5% 2 0.084s +─do_tac -------------------------------- 0.0% 2.5% 7 0.044s +─destruct H ---------------------------- 2.5% 2.5% 4 0.044s +─Glue.zrange_to_reflective ------------- 0.1% 2.1% 1 0.132s +─rewrite H ----------------------------- 1.9% 2.1% 3 0.116s +─k ------------------------------------- 1.9% 2.0% 1 0.124s +─ReflectiveTactics.do_reify ------------ 0.0% 2.0% 1 0.124s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_nonzero -------------------- 0.0% 100.0% 1 6.180s + ├─IntegrationTestTemporaryMiscCommon.no 0.1% 84.5% 1 5.224s + │ ├─destruct (Decidable.dec x), (Decida 36.7% 36.7% 1 2.268s + │ ├─destruct (Decidable.dec x) as [H| H 21.6% 21.6% 1 1.336s + │ ├─IntegrationTestTemporaryMiscCommon. 0.1% 7.9% 2 0.392s + │ │ ├─rewrite <- (ZRange.is_bounded_by_ 5.2% 5.2% 2 0.308s + │ │ └─DestructHyps.do_all_matches_then 0.0% 2.5% 2 0.084s + │ │ └DestructHyps.do_one_match_then -- 0.1% 2.5% 6 0.048s + │ │ └do_tac -------------------------- 0.0% 2.5% 4 0.044s + │ │ └destruct H ---------------------- 2.5% 2.5% 4 0.044s + │ ├─rewrite H' ------------------------ 3.4% 3.4% 1 0.208s + │ ├─generalize dependent (constr) ----- 3.1% 3.1% 4 0.068s + │ ├─congruence ------------------------ 2.8% 2.8% 1 0.176s + │ └─IntegrationTestTemporaryMiscCommon. 0.0% 2.7% 1 0.164s + │ └<Crypto.Util.Tactics.MoveLetIn.with 0.5% 2.6% 3 0.156s + │ └k --------------------------------- 1.9% 2.0% 1 0.124s + └─Pipeline.refine_reflectively_gen ---- 0.1% 15.5% 1 0.956s + ├─ReflectiveTactics.do_reflective_pip 0.0% 11.9% 1 0.736s + │└ReflectiveTactics.solve_side_condit 0.0% 11.6% 1 0.716s + │ ├─ReflectiveTactics.solve_post_reif 0.3% 9.6% 1 0.592s + │ │ ├─UnifyAbstractReflexivity.unify_ 4.2% 5.2% 8 0.076s + │ │ └─ReflectiveTactics.unify_abstrac 3.0% 4.0% 1 0.248s + │ └─ReflectiveTactics.do_reify ------ 0.0% 2.0% 1 0.124s + └─Glue.refine_to_reflective_glue' --- 0.0% 3.5% 1 0.216s + └Glue.zrange_to_reflective --------- 0.1% 2.1% 1 0.132s + +Finished transaction in 7.301 secs (6.731u,0.s) (successful) +Closed under the global context +total time: 6.180s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_nonzero -------------------- 0.0% 100.0% 1 6.180s +─IntegrationTestTemporaryMiscCommon.nonz 0.1% 84.5% 1 5.224s +─destruct (Decidable.dec x), (Decidable. 36.7% 36.7% 1 2.268s +─destruct (Decidable.dec x) as [H| H] -- 21.6% 21.6% 1 1.336s +─Pipeline.refine_reflectively_gen ------ 0.1% 15.5% 1 0.956s +─ReflectiveTactics.do_reflective_pipelin 0.0% 11.9% 1 0.736s +─ReflectiveTactics.solve_side_conditions 0.0% 11.6% 1 0.716s +─ReflectiveTactics.solve_post_reified_si 0.3% 9.6% 1 0.592s +─IntegrationTestTemporaryMiscCommon.op_s 0.1% 7.9% 2 0.392s +─rewrite <- (ZRange.is_bounded_by_None_r 5.2% 5.2% 2 0.308s +─UnifyAbstractReflexivity.unify_transfor 4.2% 5.2% 8 0.076s +─ReflectiveTactics.unify_abstract_cbv_in 3.0% 4.0% 1 0.248s +─Glue.refine_to_reflective_glue' ------- 0.0% 3.5% 1 0.216s +─rewrite H' ---------------------------- 3.4% 3.4% 1 0.208s +─generalize dependent (constr) --------- 3.1% 3.1% 4 0.068s +─congruence ---------------------------- 2.8% 2.8% 1 0.176s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 2.7% 1 0.164s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.5% 2.6% 3 0.156s +─DestructHyps.do_one_match_then -------- 0.1% 2.5% 6 0.048s +─DestructHyps.do_all_matches_then ------ 0.0% 2.5% 2 0.084s +─do_tac -------------------------------- 0.0% 2.5% 7 0.044s +─destruct H ---------------------------- 2.5% 2.5% 4 0.044s +─Glue.zrange_to_reflective ------------- 0.1% 2.1% 1 0.132s +─rewrite H ----------------------------- 1.9% 2.1% 3 0.116s +─k ------------------------------------- 1.9% 2.0% 1 0.124s +─ReflectiveTactics.do_reify ------------ 0.0% 2.0% 1 0.124s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_nonzero -------------------- 0.0% 100.0% 1 6.180s + ├─IntegrationTestTemporaryMiscCommon.no 0.1% 84.5% 1 5.224s + │ ├─destruct (Decidable.dec x), (Decida 36.7% 36.7% 1 2.268s + │ ├─destruct (Decidable.dec x) as [H| H 21.6% 21.6% 1 1.336s + │ ├─IntegrationTestTemporaryMiscCommon. 0.1% 7.9% 2 0.392s + │ │ ├─rewrite <- (ZRange.is_bounded_by_ 5.2% 5.2% 2 0.308s + │ │ └─DestructHyps.do_all_matches_then 0.0% 2.5% 2 0.084s + │ │ └DestructHyps.do_one_match_then -- 0.1% 2.5% 6 0.048s + │ │ └do_tac -------------------------- 0.0% 2.5% 4 0.044s + │ │ └destruct H ---------------------- 2.5% 2.5% 4 0.044s + │ ├─rewrite H' ------------------------ 3.4% 3.4% 1 0.208s + │ ├─generalize dependent (constr) ----- 3.1% 3.1% 4 0.068s + │ ├─congruence ------------------------ 2.8% 2.8% 1 0.176s + │ └─IntegrationTestTemporaryMiscCommon. 0.0% 2.7% 1 0.164s + │ └<Crypto.Util.Tactics.MoveLetIn.with 0.5% 2.6% 3 0.156s + │ └k --------------------------------- 1.9% 2.0% 1 0.124s + └─Pipeline.refine_reflectively_gen ---- 0.1% 15.5% 1 0.956s + ├─ReflectiveTactics.do_reflective_pip 0.0% 11.9% 1 0.736s + │└ReflectiveTactics.solve_side_condit 0.0% 11.6% 1 0.716s + │ ├─ReflectiveTactics.solve_post_reif 0.3% 9.6% 1 0.592s + │ │ ├─UnifyAbstractReflexivity.unify_ 4.2% 5.2% 8 0.076s + │ │ └─ReflectiveTactics.unify_abstrac 3.0% 4.0% 1 0.248s + │ └─ReflectiveTactics.do_reify ------ 0.0% 2.0% 1 0.124s + └─Glue.refine_to_reflective_glue' --- 0.0% 3.5% 1 0.216s + └Glue.zrange_to_reflective --------- 0.1% 2.1% 1 0.132s + +src/Specific/NISTP256/AMD64/fenz (real: 28.91, user: 26.41, sys: 0.19, mem: 756216 ko) +COQC src/Specific/NISTP256/AMD64/feopp.v +Finished transaction in 7.716 secs (7.216u,0.s) (successful) +total time: 7.168s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 59.8% 1 4.284s +─IntegrationTestTemporaryMiscCommon.fact 17.6% 49.1% 1 3.516s +─Pipeline.refine_reflectively_gen ------ 0.0% 40.2% 1 2.884s +─ReflectiveTactics.do_reflective_pipelin 0.0% 35.3% 1 2.528s +─ReflectiveTactics.solve_side_conditions 0.0% 34.8% 1 2.492s +─reflexivity --------------------------- 23.8% 23.8% 8 1.660s +─ReflectiveTactics.solve_post_reified_si 0.4% 21.0% 1 1.504s +─UnifyAbstractReflexivity.unify_transfor 13.8% 16.4% 8 0.268s +─ReflectiveTactics.do_reify ------------ 0.1% 13.8% 1 0.988s +─Reify.Reify_rhs_gen ------------------- 0.8% 13.6% 1 0.972s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 9.5% 1 0.680s +─rewrite <- (ZRange.is_bounded_by_None_r 8.7% 8.7% 4 0.332s +─rewrite <- (lem : lemT) by by_tac ltac: 0.1% 7.3% 1 0.520s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 7.3% 1 0.520s +─op_sig_side_conditions_t -------------- 0.0% 7.2% 1 0.516s +─by_tac -------------------------------- 0.0% 7.1% 2 0.412s +─Reify.do_reify_abs_goal --------------- 6.9% 7.0% 2 0.500s +─Reify.do_reifyf_goal ------------------ 6.3% 6.5% 62 0.460s +─DestructHyps.do_one_match_then -------- 0.3% 5.4% 14 0.044s +─DestructHyps.do_all_matches_then ------ 0.0% 5.4% 4 0.116s +─do_tac -------------------------------- 0.0% 5.1% 13 0.044s +─destruct H ---------------------------- 5.1% 5.1% 10 0.044s +─Glue.refine_to_reflective_glue' ------- 0.0% 5.0% 1 0.356s +─ReflectiveTactics.unify_abstract_cbv_in 3.1% 4.1% 1 0.292s +─Glue.zrange_to_reflective ------------- 0.0% 3.4% 1 0.244s +─unify (constr) (constr) --------------- 3.1% 3.1% 8 0.072s +─Glue.zrange_to_reflective_goal -------- 2.1% 2.7% 1 0.196s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 2.2% 1 0.160s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.3% 2.2% 3 0.152s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 59.8% 1 4.284s + ├─IntegrationTestTemporaryMiscCommon.fa 17.6% 49.1% 1 3.516s + │ ├─reflexivity ----------------------- 23.2% 23.2% 1 1.660s + │ └─op_sig_side_conditions_t ---------- 0.0% 7.2% 1 0.516s + │ ├─rewrite <- (ZRange.is_bounded_by_ 3.9% 3.9% 2 0.272s + │ └─DestructHyps.do_all_matches_then 0.0% 3.2% 2 0.116s + │ └DestructHyps.do_one_match_then -- 0.2% 3.2% 8 0.044s + │ └do_tac -------------------------- 0.0% 3.0% 6 0.040s + │ └destruct H ---------------------- 3.0% 3.0% 6 0.040s + └─IntegrationTestTemporaryMiscCommon.do 0.0% 9.5% 1 0.680s + ├─IntegrationTestTemporaryMiscCommon. 0.0% 7.3% 1 0.520s + │└rewrite <- (lem : lemT) by by_tac l 0.1% 7.3% 1 0.520s + │└by_tac ---------------------------- 0.0% 7.1% 2 0.412s + │ ├─rewrite <- (ZRange.is_bounded_by_ 4.8% 4.8% 2 0.332s + │ └─DestructHyps.do_all_matches_then 0.0% 2.2% 2 0.080s + │ └DestructHyps.do_one_match_then -- 0.1% 2.2% 6 0.044s + │ └do_tac -------------------------- 0.0% 2.2% 4 0.044s + │ └destruct H ---------------------- 2.2% 2.2% 4 0.044s + └─IntegrationTestTemporaryMiscCommon. 0.0% 2.2% 1 0.160s + └<Crypto.Util.Tactics.MoveLetIn.with 0.3% 2.2% 3 0.152s +─Pipeline.refine_reflectively_gen ------ 0.0% 40.2% 1 2.884s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 35.3% 1 2.528s + │└ReflectiveTactics.solve_side_conditio 0.0% 34.8% 1 2.492s + │ ├─ReflectiveTactics.solve_post_reifie 0.4% 21.0% 1 1.504s + │ │ ├─UnifyAbstractReflexivity.unify_tr 13.8% 16.4% 8 0.268s + │ │ │└unify (constr) (constr) --------- 2.1% 2.1% 6 0.048s + │ │ └─ReflectiveTactics.unify_abstract_ 3.1% 4.1% 1 0.292s + │ └─ReflectiveTactics.do_reify -------- 0.1% 13.8% 1 0.988s + │ └Reify.Reify_rhs_gen --------------- 0.8% 13.6% 1 0.972s + │ └Reify.do_reify_abs_goal ----------- 6.9% 7.0% 2 0.500s + │ └Reify.do_reifyf_goal -------------- 6.3% 6.5% 62 0.460s + └─Glue.refine_to_reflective_glue' ----- 0.0% 5.0% 1 0.356s + └Glue.zrange_to_reflective ----------- 0.0% 3.4% 1 0.244s + └Glue.zrange_to_reflective_goal ------ 2.1% 2.7% 1 0.196s + +Finished transaction in 8.918 secs (8.116u,0.004s) (successful) +Closed under the global context +total time: 7.168s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 59.8% 1 4.284s +─IntegrationTestTemporaryMiscCommon.fact 17.6% 49.1% 1 3.516s +─Pipeline.refine_reflectively_gen ------ 0.0% 40.2% 1 2.884s +─ReflectiveTactics.do_reflective_pipelin 0.0% 35.3% 1 2.528s +─ReflectiveTactics.solve_side_conditions 0.0% 34.8% 1 2.492s +─reflexivity --------------------------- 23.8% 23.8% 8 1.660s +─ReflectiveTactics.solve_post_reified_si 0.4% 21.0% 1 1.504s +─UnifyAbstractReflexivity.unify_transfor 13.8% 16.4% 8 0.268s +─ReflectiveTactics.do_reify ------------ 0.1% 13.8% 1 0.988s +─Reify.Reify_rhs_gen ------------------- 0.8% 13.6% 1 0.972s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 9.5% 1 0.680s +─rewrite <- (ZRange.is_bounded_by_None_r 8.7% 8.7% 4 0.332s +─rewrite <- (lem : lemT) by by_tac ltac: 0.1% 7.3% 1 0.520s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 7.3% 1 0.520s +─op_sig_side_conditions_t -------------- 0.0% 7.2% 1 0.516s +─by_tac -------------------------------- 0.0% 7.1% 2 0.412s +─Reify.do_reify_abs_goal --------------- 6.9% 7.0% 2 0.500s +─Reify.do_reifyf_goal ------------------ 6.3% 6.5% 62 0.460s +─DestructHyps.do_one_match_then -------- 0.3% 5.4% 14 0.044s +─DestructHyps.do_all_matches_then ------ 0.0% 5.4% 4 0.116s +─do_tac -------------------------------- 0.0% 5.1% 13 0.044s +─destruct H ---------------------------- 5.1% 5.1% 10 0.044s +─Glue.refine_to_reflective_glue' ------- 0.0% 5.0% 1 0.356s +─ReflectiveTactics.unify_abstract_cbv_in 3.1% 4.1% 1 0.292s +─Glue.zrange_to_reflective ------------- 0.0% 3.4% 1 0.244s +─unify (constr) (constr) --------------- 3.1% 3.1% 8 0.072s +─Glue.zrange_to_reflective_goal -------- 2.1% 2.7% 1 0.196s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 2.2% 1 0.160s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.3% 2.2% 3 0.152s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 59.8% 1 4.284s + ├─IntegrationTestTemporaryMiscCommon.fa 17.6% 49.1% 1 3.516s + │ ├─reflexivity ----------------------- 23.2% 23.2% 1 1.660s + │ └─op_sig_side_conditions_t ---------- 0.0% 7.2% 1 0.516s + │ ├─rewrite <- (ZRange.is_bounded_by_ 3.9% 3.9% 2 0.272s + │ └─DestructHyps.do_all_matches_then 0.0% 3.2% 2 0.116s + │ └DestructHyps.do_one_match_then -- 0.2% 3.2% 8 0.044s + │ └do_tac -------------------------- 0.0% 3.0% 6 0.040s + │ └destruct H ---------------------- 3.0% 3.0% 6 0.040s + └─IntegrationTestTemporaryMiscCommon.do 0.0% 9.5% 1 0.680s + ├─IntegrationTestTemporaryMiscCommon. 0.0% 7.3% 1 0.520s + │└rewrite <- (lem : lemT) by by_tac l 0.1% 7.3% 1 0.520s + │└by_tac ---------------------------- 0.0% 7.1% 2 0.412s + │ ├─rewrite <- (ZRange.is_bounded_by_ 4.8% 4.8% 2 0.332s + │ └─DestructHyps.do_all_matches_then 0.0% 2.2% 2 0.080s + │ └DestructHyps.do_one_match_then -- 0.1% 2.2% 6 0.044s + │ └do_tac -------------------------- 0.0% 2.2% 4 0.044s + │ └destruct H ---------------------- 2.2% 2.2% 4 0.044s + └─IntegrationTestTemporaryMiscCommon. 0.0% 2.2% 1 0.160s + └<Crypto.Util.Tactics.MoveLetIn.with 0.3% 2.2% 3 0.152s +─Pipeline.refine_reflectively_gen ------ 0.0% 40.2% 1 2.884s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 35.3% 1 2.528s + │└ReflectiveTactics.solve_side_conditio 0.0% 34.8% 1 2.492s + │ ├─ReflectiveTactics.solve_post_reifie 0.4% 21.0% 1 1.504s + │ │ ├─UnifyAbstractReflexivity.unify_tr 13.8% 16.4% 8 0.268s + │ │ │└unify (constr) (constr) --------- 2.1% 2.1% 6 0.048s + │ │ └─ReflectiveTactics.unify_abstract_ 3.1% 4.1% 1 0.292s + │ └─ReflectiveTactics.do_reify -------- 0.1% 13.8% 1 0.988s + │ └Reify.Reify_rhs_gen --------------- 0.8% 13.6% 1 0.972s + │ └Reify.do_reify_abs_goal ----------- 6.9% 7.0% 2 0.500s + │ └Reify.do_reifyf_goal -------------- 6.3% 6.5% 62 0.460s + └─Glue.refine_to_reflective_glue' ----- 0.0% 5.0% 1 0.356s + └Glue.zrange_to_reflective ----------- 0.0% 3.4% 1 0.244s + └Glue.zrange_to_reflective_goal ------ 2.1% 2.7% 1 0.196s + +src/Specific/NISTP256/AMD64/feopp (real: 32.08, user: 29.46, sys: 0.25, mem: 765212 ko) +COQC src/Specific/NISTP256/AMD64/fesub.v +Finished transaction in 12.83 secs (11.988u,0.019s) (successful) +total time: 11.956s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 63.2% 1 7.560s +─IntegrationTestTemporaryMiscCommon.fact 15.6% 48.5% 1 5.796s +─Pipeline.refine_reflectively_gen ------ 0.0% 36.8% 1 4.396s +─ReflectiveTactics.do_reflective_pipelin 0.0% 31.0% 1 3.712s +─ReflectiveTactics.solve_side_conditions 0.0% 30.6% 1 3.656s +─reflexivity --------------------------- 20.3% 20.3% 8 2.312s +─ReflectiveTactics.solve_post_reified_si 0.5% 17.3% 1 2.064s +─UnifyAbstractReflexivity.unify_transfor 11.8% 13.9% 8 0.452s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 13.7% 1 1.636s +─ReflectiveTactics.do_reify ------------ 0.0% 13.3% 1 1.592s +─Reify.Reify_rhs_gen ------------------- 0.9% 12.8% 1 1.536s +─DestructHyps.do_all_matches_then ------ 0.1% 12.6% 8 0.224s +─DestructHyps.do_one_match_then -------- 0.5% 12.5% 44 0.056s +─op_sig_side_conditions_t -------------- 0.0% 12.2% 1 1.456s +─do_tac -------------------------------- 0.0% 12.0% 43 0.052s +─destruct H ---------------------------- 11.9% 11.9% 36 0.052s +─rewrite <- (lem : lemT) by by_tac ltac: 0.2% 11.1% 1 1.324s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 11.1% 1 1.324s +─by_tac -------------------------------- 0.0% 10.9% 4 0.488s +─rewrite <- (ZRange.is_bounded_by_None_r 10.1% 10.2% 8 0.328s +─Reify.do_reify_abs_goal --------------- 6.0% 6.1% 2 0.724s +─Glue.refine_to_reflective_glue' ------- 0.0% 5.7% 1 0.680s +─Reify.do_reifyf_goal ------------------ 5.5% 5.6% 80 0.660s +─Glue.zrange_to_reflective ------------- 0.0% 3.6% 1 0.432s +─ReflectiveTactics.unify_abstract_cbv_in 2.0% 2.8% 1 0.340s +─Glue.zrange_to_reflective_goal -------- 1.7% 2.7% 1 0.324s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 2.6% 1 0.312s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.5% 2.5% 3 0.300s +─unify (constr) (constr) --------------- 2.4% 2.4% 9 0.100s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 63.2% 1 7.560s + ├─IntegrationTestTemporaryMiscCommon.fa 15.6% 48.5% 1 5.796s + │ ├─reflexivity ----------------------- 19.3% 19.3% 1 2.312s + │ └─op_sig_side_conditions_t ---------- 0.0% 12.2% 1 1.456s + │ ├─DestructHyps.do_all_matches_then 0.1% 7.1% 4 0.224s + │ │└DestructHyps.do_one_match_then -- 0.3% 7.1% 24 0.056s + │ │└do_tac -------------------------- 0.0% 6.7% 20 0.052s + │ │└destruct H ---------------------- 6.7% 6.7% 20 0.052s + │ └─rewrite <- (ZRange.is_bounded_by_ 4.9% 4.9% 4 0.292s + └─IntegrationTestTemporaryMiscCommon.do 0.0% 13.7% 1 1.636s + ├─IntegrationTestTemporaryMiscCommon. 0.0% 11.1% 1 1.324s + │└rewrite <- (lem : lemT) by by_tac l 0.2% 11.1% 1 1.324s + │└by_tac ---------------------------- 0.0% 10.9% 4 0.488s + │ ├─DestructHyps.do_all_matches_then 0.0% 5.5% 4 0.176s + │ │└DestructHyps.do_one_match_then -- 0.2% 5.5% 20 0.048s + │ │└do_tac -------------------------- 0.0% 5.3% 16 0.048s + │ │└destruct H ---------------------- 5.2% 5.2% 16 0.048s + │ └─rewrite <- (ZRange.is_bounded_by_ 5.3% 5.3% 4 0.328s + └─IntegrationTestTemporaryMiscCommon. 0.0% 2.6% 1 0.312s + └<Crypto.Util.Tactics.MoveLetIn.with 0.5% 2.5% 3 0.300s +─Pipeline.refine_reflectively_gen ------ 0.0% 36.8% 1 4.396s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 31.0% 1 3.712s + │└ReflectiveTactics.solve_side_conditio 0.0% 30.6% 1 3.656s + │ ├─ReflectiveTactics.solve_post_reifie 0.5% 17.3% 1 2.064s + │ │ ├─UnifyAbstractReflexivity.unify_tr 11.8% 13.9% 8 0.452s + │ │ └─ReflectiveTactics.unify_abstract_ 2.0% 2.8% 1 0.340s + │ └─ReflectiveTactics.do_reify -------- 0.0% 13.3% 1 1.592s + │ └Reify.Reify_rhs_gen --------------- 0.9% 12.8% 1 1.536s + │ └Reify.do_reify_abs_goal ----------- 6.0% 6.1% 2 0.724s + │ └Reify.do_reifyf_goal -------------- 5.5% 5.6% 80 0.660s + └─Glue.refine_to_reflective_glue' ----- 0.0% 5.7% 1 0.680s + └Glue.zrange_to_reflective ----------- 0.0% 3.6% 1 0.432s + └Glue.zrange_to_reflective_goal ------ 1.7% 2.7% 1 0.324s + +Finished transaction in 14.576 secs (13.372u,0.004s) (successful) +Closed under the global context +total time: 11.956s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 63.2% 1 7.560s +─IntegrationTestTemporaryMiscCommon.fact 15.6% 48.5% 1 5.796s +─Pipeline.refine_reflectively_gen ------ 0.0% 36.8% 1 4.396s +─ReflectiveTactics.do_reflective_pipelin 0.0% 31.0% 1 3.712s +─ReflectiveTactics.solve_side_conditions 0.0% 30.6% 1 3.656s +─reflexivity --------------------------- 20.3% 20.3% 8 2.312s +─ReflectiveTactics.solve_post_reified_si 0.5% 17.3% 1 2.064s +─UnifyAbstractReflexivity.unify_transfor 11.8% 13.9% 8 0.452s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 13.7% 1 1.636s +─ReflectiveTactics.do_reify ------------ 0.0% 13.3% 1 1.592s +─Reify.Reify_rhs_gen ------------------- 0.9% 12.8% 1 1.536s +─DestructHyps.do_all_matches_then ------ 0.1% 12.6% 8 0.224s +─DestructHyps.do_one_match_then -------- 0.5% 12.5% 44 0.056s +─op_sig_side_conditions_t -------------- 0.0% 12.2% 1 1.456s +─do_tac -------------------------------- 0.0% 12.0% 43 0.052s +─destruct H ---------------------------- 11.9% 11.9% 36 0.052s +─rewrite <- (lem : lemT) by by_tac ltac: 0.2% 11.1% 1 1.324s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 11.1% 1 1.324s +─by_tac -------------------------------- 0.0% 10.9% 4 0.488s +─rewrite <- (ZRange.is_bounded_by_None_r 10.1% 10.2% 8 0.328s +─Reify.do_reify_abs_goal --------------- 6.0% 6.1% 2 0.724s +─Glue.refine_to_reflective_glue' ------- 0.0% 5.7% 1 0.680s +─Reify.do_reifyf_goal ------------------ 5.5% 5.6% 80 0.660s +─Glue.zrange_to_reflective ------------- 0.0% 3.6% 1 0.432s +─ReflectiveTactics.unify_abstract_cbv_in 2.0% 2.8% 1 0.340s +─Glue.zrange_to_reflective_goal -------- 1.7% 2.7% 1 0.324s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 2.6% 1 0.312s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.5% 2.5% 3 0.300s +─unify (constr) (constr) --------------- 2.4% 2.4% 9 0.100s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 63.2% 1 7.560s + ├─IntegrationTestTemporaryMiscCommon.fa 15.6% 48.5% 1 5.796s + │ ├─reflexivity ----------------------- 19.3% 19.3% 1 2.312s + │ └─op_sig_side_conditions_t ---------- 0.0% 12.2% 1 1.456s + │ ├─DestructHyps.do_all_matches_then 0.1% 7.1% 4 0.224s + │ │└DestructHyps.do_one_match_then -- 0.3% 7.1% 24 0.056s + │ │└do_tac -------------------------- 0.0% 6.7% 20 0.052s + │ │└destruct H ---------------------- 6.7% 6.7% 20 0.052s + │ └─rewrite <- (ZRange.is_bounded_by_ 4.9% 4.9% 4 0.292s + └─IntegrationTestTemporaryMiscCommon.do 0.0% 13.7% 1 1.636s + ├─IntegrationTestTemporaryMiscCommon. 0.0% 11.1% 1 1.324s + │└rewrite <- (lem : lemT) by by_tac l 0.2% 11.1% 1 1.324s + │└by_tac ---------------------------- 0.0% 10.9% 4 0.488s + │ ├─DestructHyps.do_all_matches_then 0.0% 5.5% 4 0.176s + │ │└DestructHyps.do_one_match_then -- 0.2% 5.5% 20 0.048s + │ │└do_tac -------------------------- 0.0% 5.3% 16 0.048s + │ │└destruct H ---------------------- 5.2% 5.2% 16 0.048s + │ └─rewrite <- (ZRange.is_bounded_by_ 5.3% 5.3% 4 0.328s + └─IntegrationTestTemporaryMiscCommon. 0.0% 2.6% 1 0.312s + └<Crypto.Util.Tactics.MoveLetIn.with 0.5% 2.5% 3 0.300s +─Pipeline.refine_reflectively_gen ------ 0.0% 36.8% 1 4.396s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 31.0% 1 3.712s + │└ReflectiveTactics.solve_side_conditio 0.0% 30.6% 1 3.656s + │ ├─ReflectiveTactics.solve_post_reifie 0.5% 17.3% 1 2.064s + │ │ ├─UnifyAbstractReflexivity.unify_tr 11.8% 13.9% 8 0.452s + │ │ └─ReflectiveTactics.unify_abstract_ 2.0% 2.8% 1 0.340s + │ └─ReflectiveTactics.do_reify -------- 0.0% 13.3% 1 1.592s + │ └Reify.Reify_rhs_gen --------------- 0.9% 12.8% 1 1.536s + │ └Reify.do_reify_abs_goal ----------- 6.0% 6.1% 2 0.724s + │ └Reify.do_reifyf_goal -------------- 5.5% 5.6% 80 0.660s + └─Glue.refine_to_reflective_glue' ----- 0.0% 5.7% 1 0.680s + └Glue.zrange_to_reflective ----------- 0.0% 3.6% 1 0.432s + └Glue.zrange_to_reflective_goal ------ 1.7% 2.7% 1 0.324s + +src/Specific/NISTP256/AMD64/fesub (real: 43.78, user: 40.09, sys: 0.30, mem: 799668 ko) +COQC src/Specific/NISTP256/AMD64/feaddDisplay > src/Specific/NISTP256/AMD64/feaddDisplay.log +COQC src/Specific/NISTP256/AMD64/fenzDisplay > src/Specific/NISTP256/AMD64/fenzDisplay.log +COQC src/Specific/NISTP256/AMD64/feoppDisplay > src/Specific/NISTP256/AMD64/feoppDisplay.log +COQC src/Specific/NISTP256/AMD64/fesubDisplay > src/Specific/NISTP256/AMD64/fesubDisplay.log +COQC src/Specific/X25519/C64/fesquareDisplay > src/Specific/X25519/C64/fesquareDisplay.log +COQC src/Specific/solinas32_2e255m765_12limbs/femul.v +Finished transaction in 60.265 secs (55.388u,0.103s) (successful) +total time: 55.440s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 95.9% 1 53.156s +─ReflectiveTactics.do_reflective_pipelin 0.0% 89.2% 1 49.464s +─ReflectiveTactics.solve_side_conditions 0.0% 88.9% 1 49.288s +─ReflectiveTactics.do_reify ------------ -0.0% 49.9% 1 27.684s +─Reify.Reify_rhs_gen ------------------- 1.3% 49.3% 1 27.348s +─ReflectiveTactics.solve_post_reified_si 0.1% 39.0% 1 21.604s +─Reify.do_reify_abs_goal --------------- 36.3% 36.6% 2 20.272s +─UnifyAbstractReflexivity.unify_transfor 30.8% 36.1% 8 8.636s +─Reify.do_reifyf_goal ------------------ 35.7% 35.9% 108 10.356s +─eexact -------------------------------- 11.5% 11.5% 110 0.128s +─Glue.refine_to_reflective_glue' ------- 0.0% 6.7% 1 3.692s +─Glue.zrange_to_reflective ------------- 0.0% 6.2% 1 3.424s +─unify (constr) (constr) --------------- 4.9% 4.9% 7 1.140s +─Glue.zrange_to_reflective_goal -------- 1.4% 4.7% 1 2.592s +─synthesize ---------------------------- 0.0% 4.1% 1 2.284s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 4.0% 1 2.220s +─change G' ----------------------------- 3.9% 3.9% 1 2.148s +─pose proof (pf : Interpretation.Bo 3.1% 3.1% 1 1.736s +─rewrite H ----------------------------- 3.1% 3.1% 1 1.692s +─prove_interp_compile_correct ---------- 0.0% 3.0% 1 1.636s +─rewrite ?EtaInterp.InterpExprEta ------ 2.7% 2.7% 1 1.484s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 95.9% 1 53.156s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 89.2% 1 49.464s + │└ReflectiveTactics.solve_side_conditio 0.0% 88.9% 1 49.288s + │ ├─ReflectiveTactics.do_reify -------- -0.0% 49.9% 1 27.684s + │ │└Reify.Reify_rhs_gen --------------- 1.3% 49.3% 1 27.348s + │ │ ├─Reify.do_reify_abs_goal --------- 36.3% 36.6% 2 20.272s + │ │ │└Reify.do_reifyf_goal ------------ 35.7% 35.9% 108 10.356s + │ │ │└eexact -------------------------- 11.1% 11.1% 108 0.072s + │ │ ├─rewrite H ----------------------- 3.1% 3.1% 1 1.692s + │ │ └─prove_interp_compile_correct ---- 0.0% 3.0% 1 1.636s + │ │ └rewrite ?EtaInterp.InterpExprEta 2.7% 2.7% 1 1.484s + │ └─ReflectiveTactics.solve_post_reifie 0.1% 39.0% 1 21.604s + │ └UnifyAbstractReflexivity.unify_tran 30.8% 36.1% 8 8.636s + │ └unify (constr) (constr) ----------- 4.4% 4.4% 6 1.140s + └─Glue.refine_to_reflective_glue' ----- 0.0% 6.7% 1 3.692s + └Glue.zrange_to_reflective ----------- 0.0% 6.2% 1 3.424s + └Glue.zrange_to_reflective_goal ------ 1.4% 4.7% 1 2.592s + └pose proof (pf : Interpretation. 3.1% 3.1% 1 1.736s +─synthesize ---------------------------- 0.0% 4.1% 1 2.284s +└IntegrationTestTemporaryMiscCommon.do_r 0.0% 4.0% 1 2.220s +└change G' ----------------------------- 3.9% 3.9% 1 2.148s + +Finished transaction in 92.046 secs (84.315u,0.032s) (successful) +Closed under the global context +total time: 55.440s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 95.9% 1 53.156s +─ReflectiveTactics.do_reflective_pipelin 0.0% 89.2% 1 49.464s +─ReflectiveTactics.solve_side_conditions 0.0% 88.9% 1 49.288s +─ReflectiveTactics.do_reify ------------ -0.0% 49.9% 1 27.684s +─Reify.Reify_rhs_gen ------------------- 1.3% 49.3% 1 27.348s +─ReflectiveTactics.solve_post_reified_si 0.1% 39.0% 1 21.604s +─Reify.do_reify_abs_goal --------------- 36.3% 36.6% 2 20.272s +─UnifyAbstractReflexivity.unify_transfor 30.8% 36.1% 8 8.636s +─Reify.do_reifyf_goal ------------------ 35.7% 35.9% 108 10.356s +─eexact -------------------------------- 11.5% 11.5% 110 0.128s +─Glue.refine_to_reflective_glue' ------- 0.0% 6.7% 1 3.692s +─Glue.zrange_to_reflective ------------- 0.0% 6.2% 1 3.424s +─unify (constr) (constr) --------------- 4.9% 4.9% 7 1.140s +─Glue.zrange_to_reflective_goal -------- 1.4% 4.7% 1 2.592s +─synthesize ---------------------------- 0.0% 4.1% 1 2.284s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 4.0% 1 2.220s +─change G' ----------------------------- 3.9% 3.9% 1 2.148s +─pose proof (pf : Interpretation.Bo 3.1% 3.1% 1 1.736s +─rewrite H ----------------------------- 3.1% 3.1% 1 1.692s +─prove_interp_compile_correct ---------- 0.0% 3.0% 1 1.636s +─rewrite ?EtaInterp.InterpExprEta ------ 2.7% 2.7% 1 1.484s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 95.9% 1 53.156s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 89.2% 1 49.464s + │└ReflectiveTactics.solve_side_conditio 0.0% 88.9% 1 49.288s + │ ├─ReflectiveTactics.do_reify -------- -0.0% 49.9% 1 27.684s + │ │└Reify.Reify_rhs_gen --------------- 1.3% 49.3% 1 27.348s + │ │ ├─Reify.do_reify_abs_goal --------- 36.3% 36.6% 2 20.272s + │ │ │└Reify.do_reifyf_goal ------------ 35.7% 35.9% 108 10.356s + │ │ │└eexact -------------------------- 11.1% 11.1% 108 0.072s + │ │ ├─rewrite H ----------------------- 3.1% 3.1% 1 1.692s + │ │ └─prove_interp_compile_correct ---- 0.0% 3.0% 1 1.636s + │ │ └rewrite ?EtaInterp.InterpExprEta 2.7% 2.7% 1 1.484s + │ └─ReflectiveTactics.solve_post_reifie 0.1% 39.0% 1 21.604s + │ └UnifyAbstractReflexivity.unify_tran 30.8% 36.1% 8 8.636s + │ └unify (constr) (constr) ----------- 4.4% 4.4% 6 1.140s + └─Glue.refine_to_reflective_glue' ----- 0.0% 6.7% 1 3.692s + └Glue.zrange_to_reflective ----------- 0.0% 6.2% 1 3.424s + └Glue.zrange_to_reflective_goal ------ 1.4% 4.7% 1 2.592s + └pose proof (pf : Interpretation. 3.1% 3.1% 1 1.736s +─synthesize ---------------------------- 0.0% 4.1% 1 2.284s +└IntegrationTestTemporaryMiscCommon.do_r 0.0% 4.0% 1 2.220s +└change G' ----------------------------- 3.9% 3.9% 1 2.148s + +src/Specific/solinas32_2e255m765_12limbs/femul (real: 179.21, user: 164.11, sys: 0.42, mem: 1549104 ko) +COQC src/Specific/X25519/C64/fesubDisplay > src/Specific/X25519/C64/fesubDisplay.log +COQC src/Specific/X25519/C64/freezeDisplay > src/Specific/X25519/C64/freezeDisplay.log +COQC src/Specific/solinas32_2e255m765_13limbs/femul.v +Finished transaction in 74.548 secs (68.928u,0.079s) (successful) +total time: 68.948s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 95.7% 1 65.956s +─ReflectiveTactics.do_reflective_pipelin 0.0% 88.7% 1 61.172s +─ReflectiveTactics.solve_side_conditions 0.0% 88.4% 1 60.944s +─ReflectiveTactics.do_reify ------------ 0.0% 48.5% 1 33.408s +─Reify.Reify_rhs_gen ------------------- 1.3% 47.9% 1 33.020s +─ReflectiveTactics.solve_post_reified_si 0.1% 39.9% 1 27.536s +─UnifyAbstractReflexivity.unify_transfor 32.0% 37.2% 8 11.528s +─Reify.do_reify_abs_goal --------------- 36.0% 36.2% 2 24.960s +─Reify.do_reifyf_goal ------------------ 35.3% 35.5% 117 12.840s +─eexact -------------------------------- 11.4% 11.4% 119 0.160s +─Glue.refine_to_reflective_glue' ------- 0.0% 6.9% 1 4.784s +─Glue.zrange_to_reflective ------------- 0.0% 6.5% 1 4.512s +─Glue.zrange_to_reflective_goal -------- 1.3% 4.9% 1 3.396s +─unify (constr) (constr) --------------- 4.9% 4.9% 7 1.524s +─synthesize ---------------------------- 0.0% 4.3% 1 2.992s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 4.2% 1 2.912s +─change G' ----------------------------- 4.1% 4.1% 1 2.840s +─pose proof (pf : Interpretation.Bo 3.5% 3.5% 1 2.420s +─rewrite H ----------------------------- 3.0% 3.0% 1 2.084s +─prove_interp_compile_correct ---------- 0.0% 2.7% 1 1.856s +─rewrite ?EtaInterp.InterpExprEta ------ 2.5% 2.5% 1 1.692s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 95.7% 1 65.956s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 88.7% 1 61.172s + │└ReflectiveTactics.solve_side_conditio 0.0% 88.4% 1 60.944s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 48.5% 1 33.408s + │ │└Reify.Reify_rhs_gen --------------- 1.3% 47.9% 1 33.020s + │ │ ├─Reify.do_reify_abs_goal --------- 36.0% 36.2% 2 24.960s + │ │ │└Reify.do_reifyf_goal ------------ 35.3% 35.5% 117 12.840s + │ │ │└eexact -------------------------- 10.9% 10.9% 117 0.088s + │ │ ├─rewrite H ----------------------- 3.0% 3.0% 1 2.084s + │ │ └─prove_interp_compile_correct ---- 0.0% 2.7% 1 1.856s + │ │ └rewrite ?EtaInterp.InterpExprEta 2.5% 2.5% 1 1.692s + │ └─ReflectiveTactics.solve_post_reifie 0.1% 39.9% 1 27.536s + │ └UnifyAbstractReflexivity.unify_tran 32.0% 37.2% 8 11.528s + │ └unify (constr) (constr) ----------- 4.3% 4.3% 6 1.524s + └─Glue.refine_to_reflective_glue' ----- 0.0% 6.9% 1 4.784s + └Glue.zrange_to_reflective ----------- 0.0% 6.5% 1 4.512s + └Glue.zrange_to_reflective_goal ------ 1.3% 4.9% 1 3.396s + └pose proof (pf : Interpretation. 3.5% 3.5% 1 2.420s +─synthesize ---------------------------- 0.0% 4.3% 1 2.992s +└IntegrationTestTemporaryMiscCommon.do_r 0.0% 4.2% 1 2.912s +└change G' ----------------------------- 4.1% 4.1% 1 2.840s + +Finished transaction in 105.62 secs (97.6u,0.02s) (successful) +Closed under the global context +total time: 68.948s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 95.7% 1 65.956s +─ReflectiveTactics.do_reflective_pipelin 0.0% 88.7% 1 61.172s +─ReflectiveTactics.solve_side_conditions 0.0% 88.4% 1 60.944s +─ReflectiveTactics.do_reify ------------ 0.0% 48.5% 1 33.408s +─Reify.Reify_rhs_gen ------------------- 1.3% 47.9% 1 33.020s +─ReflectiveTactics.solve_post_reified_si 0.1% 39.9% 1 27.536s +─UnifyAbstractReflexivity.unify_transfor 32.0% 37.2% 8 11.528s +─Reify.do_reify_abs_goal --------------- 36.0% 36.2% 2 24.960s +─Reify.do_reifyf_goal ------------------ 35.3% 35.5% 117 12.840s +─eexact -------------------------------- 11.4% 11.4% 119 0.160s +─Glue.refine_to_reflective_glue' ------- 0.0% 6.9% 1 4.784s +─Glue.zrange_to_reflective ------------- 0.0% 6.5% 1 4.512s +─Glue.zrange_to_reflective_goal -------- 1.3% 4.9% 1 3.396s +─unify (constr) (constr) --------------- 4.9% 4.9% 7 1.524s +─synthesize ---------------------------- 0.0% 4.3% 1 2.992s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 4.2% 1 2.912s +─change G' ----------------------------- 4.1% 4.1% 1 2.840s +─pose proof (pf : Interpretation.Bo 3.5% 3.5% 1 2.420s +─rewrite H ----------------------------- 3.0% 3.0% 1 2.084s +─prove_interp_compile_correct ---------- 0.0% 2.7% 1 1.856s +─rewrite ?EtaInterp.InterpExprEta ------ 2.5% 2.5% 1 1.692s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 95.7% 1 65.956s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 88.7% 1 61.172s + │└ReflectiveTactics.solve_side_conditio 0.0% 88.4% 1 60.944s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 48.5% 1 33.408s + │ │└Reify.Reify_rhs_gen --------------- 1.3% 47.9% 1 33.020s + │ │ ├─Reify.do_reify_abs_goal --------- 36.0% 36.2% 2 24.960s + │ │ │└Reify.do_reifyf_goal ------------ 35.3% 35.5% 117 12.840s + │ │ │└eexact -------------------------- 10.9% 10.9% 117 0.088s + │ │ ├─rewrite H ----------------------- 3.0% 3.0% 1 2.084s + │ │ └─prove_interp_compile_correct ---- 0.0% 2.7% 1 1.856s + │ │ └rewrite ?EtaInterp.InterpExprEta 2.5% 2.5% 1 1.692s + │ └─ReflectiveTactics.solve_post_reifie 0.1% 39.9% 1 27.536s + │ └UnifyAbstractReflexivity.unify_tran 32.0% 37.2% 8 11.528s + │ └unify (constr) (constr) ----------- 4.3% 4.3% 6 1.524s + └─Glue.refine_to_reflective_glue' ----- 0.0% 6.9% 1 4.784s + └Glue.zrange_to_reflective ----------- 0.0% 6.5% 1 4.512s + └Glue.zrange_to_reflective_goal ------ 1.3% 4.9% 1 3.396s + └pose proof (pf : Interpretation. 3.5% 3.5% 1 2.420s +─synthesize ---------------------------- 0.0% 4.3% 1 2.992s +└IntegrationTestTemporaryMiscCommon.do_r 0.0% 4.2% 1 2.912s +└change G' ----------------------------- 4.1% 4.1% 1 2.840s + +src/Specific/solinas32_2e255m765_13limbs/femul (real: 207.94, user: 192.95, sys: 0.48, mem: 1656912 ko) +COQC src/Specific/NISTP256/AMD64/femul.v +Finished transaction in 122.29 secs (111.972u,0.239s) (successful) +total time: 112.164s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.1% 1 108.944s +─ReflectiveTactics.do_reflective_pipelin -0.0% 96.5% 1 108.236s +─ReflectiveTactics.solve_side_conditions 0.0% 96.3% 1 108.000s +─ReflectiveTactics.do_reify ------------ 0.0% 81.8% 1 91.740s +─Reify.Reify_rhs_gen ------------------- 0.7% 81.6% 1 91.504s +─Reify.do_reify_abs_goal --------------- 75.6% 75.7% 2 84.892s +─Reify.do_reifyf_goal ------------------ 75.2% 75.4% 901 84.532s +─eexact -------------------------------- 17.1% 17.1% 903 0.140s +─ReflectiveTactics.solve_post_reified_si 0.2% 14.5% 1 16.260s +─UnifyAbstractReflexivity.unify_transfor 11.7% 13.3% 8 3.152s +─synthesize_montgomery ----------------- 0.0% 2.9% 1 3.220s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.1% 1 108.944s +└ReflectiveTactics.do_reflective_pipelin -0.0% 96.5% 1 108.236s +└ReflectiveTactics.solve_side_conditions 0.0% 96.3% 1 108.000s + ├─ReflectiveTactics.do_reify ---------- 0.0% 81.8% 1 91.740s + │└Reify.Reify_rhs_gen ----------------- 0.7% 81.6% 1 91.504s + │└Reify.do_reify_abs_goal ------------- 75.6% 75.7% 2 84.892s + │└Reify.do_reifyf_goal ---------------- 75.2% 75.4% 901 84.532s + │└eexact ------------------------------ 16.9% 16.9% 901 0.140s + └─ReflectiveTactics.solve_post_reified_ 0.2% 14.5% 1 16.260s + └UnifyAbstractReflexivity.unify_transf 11.7% 13.3% 8 3.152s +─synthesize_montgomery ----------------- 0.0% 2.9% 1 3.220s + +Finished transaction in 72.408 secs (68.432u,0.064s) (successful) +Closed under the global context +total time: 112.164s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.1% 1 108.944s +─ReflectiveTactics.do_reflective_pipelin -0.0% 96.5% 1 108.236s +─ReflectiveTactics.solve_side_conditions 0.0% 96.3% 1 108.000s +─ReflectiveTactics.do_reify ------------ 0.0% 81.8% 1 91.740s +─Reify.Reify_rhs_gen ------------------- 0.7% 81.6% 1 91.504s +─Reify.do_reify_abs_goal --------------- 75.6% 75.7% 2 84.892s +─Reify.do_reifyf_goal ------------------ 75.2% 75.4% 901 84.532s +─eexact -------------------------------- 17.1% 17.1% 903 0.140s +─ReflectiveTactics.solve_post_reified_si 0.2% 14.5% 1 16.260s +─UnifyAbstractReflexivity.unify_transfor 11.7% 13.3% 8 3.152s +─synthesize_montgomery ----------------- 0.0% 2.9% 1 3.220s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.1% 1 108.944s +└ReflectiveTactics.do_reflective_pipelin -0.0% 96.5% 1 108.236s +└ReflectiveTactics.solve_side_conditions 0.0% 96.3% 1 108.000s + ├─ReflectiveTactics.do_reify ---------- 0.0% 81.8% 1 91.740s + │└Reify.Reify_rhs_gen ----------------- 0.7% 81.6% 1 91.504s + │└Reify.do_reify_abs_goal ------------- 75.6% 75.7% 2 84.892s + │└Reify.do_reifyf_goal ---------------- 75.2% 75.4% 901 84.532s + │└eexact ------------------------------ 16.9% 16.9% 901 0.140s + └─ReflectiveTactics.solve_post_reified_ 0.2% 14.5% 1 16.260s + └UnifyAbstractReflexivity.unify_transf 11.7% 13.3% 8 3.152s +─synthesize_montgomery ----------------- 0.0% 2.9% 1 3.220s + +src/Specific/NISTP256/AMD64/femul (real: 217.80, user: 202.52, sys: 0.53, mem: 3307052 ko) +COQC src/Specific/NISTP256/AMD64/femulDisplay > src/Specific/NISTP256/AMD64/femulDisplay.log +COQC src/Specific/X25519/C64/ladderstep.v +total time: 82.012s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_xzladderstep --------------- 0.0% 100.0% 1 82.012s +─Pipeline.refine_reflectively_gen ------ 0.0% 99.0% 1 81.228s +─ReflectiveTactics.do_reflective_pipelin 0.0% 96.1% 1 78.784s +─ReflectiveTactics.solve_side_conditions 0.0% 95.9% 1 78.684s +─ReflectiveTactics.solve_post_reified_si 0.1% 72.6% 1 59.540s +─UnifyAbstractReflexivity.unify_transfor 64.6% 68.0% 8 30.740s +─ReflectiveTactics.do_reify ------------ 0.0% 23.3% 1 19.144s +─Reify.Reify_rhs_gen ------------------- 1.2% 14.5% 1 11.860s +─Reify.do_reifyf_goal ------------------ 7.1% 7.2% 138 1.908s +─Compilers.Reify.reify_context_variables 0.0% 5.9% 1 4.828s +─rewrite H ----------------------------- 4.4% 4.4% 1 3.600s +─ReflectiveTactics.unify_abstract_cbv_in 2.9% 4.0% 1 3.288s +─Glue.refine_to_reflective_glue' ------- 0.0% 3.0% 1 2.444s +─Glue.zrange_to_reflective ------------- 0.0% 2.5% 1 2.060s +─reflexivity --------------------------- 2.3% 2.3% 11 0.816s +─Reify.transitivity_tt ----------------- 0.0% 2.1% 2 0.968s +─Glue.zrange_to_reflective_goal -------- 1.4% 2.1% 1 1.720s +─clear (var_list) ---------------------- 2.0% 2.0% 159 0.584s +─eexact -------------------------------- 2.0% 2.0% 140 0.032s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_xzladderstep --------------- 0.0% 100.0% 1 82.012s +└Pipeline.refine_reflectively_gen ------ 0.0% 99.0% 1 81.228s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 96.1% 1 78.784s + │└ReflectiveTactics.solve_side_conditio 0.0% 95.9% 1 78.684s + │ ├─ReflectiveTactics.solve_post_reifie 0.1% 72.6% 1 59.540s + │ │ ├─UnifyAbstractReflexivity.unify_tr 64.6% 68.0% 8 30.740s + │ │ └─ReflectiveTactics.unify_abstract_ 2.9% 4.0% 1 3.288s + │ └─ReflectiveTactics.do_reify -------- 0.0% 23.3% 1 19.144s + │ ├─Reify.Reify_rhs_gen ------------- 1.2% 14.5% 1 11.860s + │ │ ├─rewrite H --------------------- 4.4% 4.4% 1 3.600s + │ │ └─Reify.transitivity_tt --------- 0.0% 2.1% 2 0.968s + │ └─Compilers.Reify.reify_context_var 0.0% 5.9% 1 4.828s + │ └Reify.do_reifyf_goal ------------ 5.7% 5.8% 113 1.908s + └─Glue.refine_to_reflective_glue' ----- 0.0% 3.0% 1 2.444s + └Glue.zrange_to_reflective ----------- 0.0% 2.5% 1 2.060s + └Glue.zrange_to_reflective_goal ------ 1.4% 2.1% 1 1.720s + +Finished transaction in 194.903 secs (185.732u,0.043s) (successful) +Closed under the global context +total time: 82.012s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_xzladderstep --------------- 0.0% 100.0% 1 82.012s +─Pipeline.refine_reflectively_gen ------ 0.0% 99.0% 1 81.228s +─ReflectiveTactics.do_reflective_pipelin 0.0% 96.1% 1 78.784s +─ReflectiveTactics.solve_side_conditions 0.0% 95.9% 1 78.684s +─ReflectiveTactics.solve_post_reified_si 0.1% 72.6% 1 59.540s +─UnifyAbstractReflexivity.unify_transfor 64.6% 68.0% 8 30.740s +─ReflectiveTactics.do_reify ------------ 0.0% 23.3% 1 19.144s +─Reify.Reify_rhs_gen ------------------- 1.2% 14.5% 1 11.860s +─Reify.do_reifyf_goal ------------------ 7.1% 7.2% 138 1.908s +─Compilers.Reify.reify_context_variables 0.0% 5.9% 1 4.828s +─rewrite H ----------------------------- 4.4% 4.4% 1 3.600s +─ReflectiveTactics.unify_abstract_cbv_in 2.9% 4.0% 1 3.288s +─Glue.refine_to_reflective_glue' ------- 0.0% 3.0% 1 2.444s +─Glue.zrange_to_reflective ------------- 0.0% 2.5% 1 2.060s +─reflexivity --------------------------- 2.3% 2.3% 11 0.816s +─Reify.transitivity_tt ----------------- 0.0% 2.1% 2 0.968s +─Glue.zrange_to_reflective_goal -------- 1.4% 2.1% 1 1.720s +─clear (var_list) ---------------------- 2.0% 2.0% 159 0.584s +─eexact -------------------------------- 2.0% 2.0% 140 0.032s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_xzladderstep --------------- 0.0% 100.0% 1 82.012s +└Pipeline.refine_reflectively_gen ------ 0.0% 99.0% 1 81.228s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 96.1% 1 78.784s + │└ReflectiveTactics.solve_side_conditio 0.0% 95.9% 1 78.684s + │ ├─ReflectiveTactics.solve_post_reifie 0.1% 72.6% 1 59.540s + │ │ ├─UnifyAbstractReflexivity.unify_tr 64.6% 68.0% 8 30.740s + │ │ └─ReflectiveTactics.unify_abstract_ 2.9% 4.0% 1 3.288s + │ └─ReflectiveTactics.do_reify -------- 0.0% 23.3% 1 19.144s + │ ├─Reify.Reify_rhs_gen ------------- 1.2% 14.5% 1 11.860s + │ │ ├─rewrite H --------------------- 4.4% 4.4% 1 3.600s + │ │ └─Reify.transitivity_tt --------- 0.0% 2.1% 2 0.968s + │ └─Compilers.Reify.reify_context_var 0.0% 5.9% 1 4.828s + │ └Reify.do_reifyf_goal ------------ 5.7% 5.8% 113 1.908s + └─Glue.refine_to_reflective_glue' ----- 0.0% 3.0% 1 2.444s + └Glue.zrange_to_reflective ----------- 0.0% 2.5% 1 2.060s + └Glue.zrange_to_reflective_goal ------ 1.4% 2.1% 1 1.720s + +src/Specific/X25519/C64/ladderstep (real: 316.83, user: 299.49, sys: 0.52, mem: 1621500 ko) +COQC src/Specific/X25519/C64/ladderstepDisplay > src/Specific/X25519/C64/ladderstepDisplay.log diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-real-absolute.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-real-absolute.log.expected new file mode 100644 index 0000000000..2a2d2c1b2f --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-real-absolute.log.expected @@ -0,0 +1,26 @@ + After | Peak Mem | File Name | Before | Peak Mem || Change || Change (mem) | % Change | % Change (mem) +--------------------------------------------------------------------------------------------------------------------------------------------------------- +20m46.07s | 3302508 ko | Total Time / Peak Mem | 23m06.30s | 3307052 ko || -2m20.23s || -4544 ko | -10.11% | -0.13% +--------------------------------------------------------------------------------------------------------------------------------------------------------- + 3m22.96s | 3302508 ko | Specific/NISTP256/AMD64/femul | 3m37.80s | 3307052 ko || -0m14.84s || -4544 ko | -6.81% | -0.13% + 4m16.77s | 1617000 ko | Specific/X25519/C64/ladderstep | 5m16.83s | 1621500 ko || -1m00.06s || -4500 ko | -18.95% | -0.27% + 3m01.77s | 1589516 ko | Specific/solinas32_2e255m765_13limbs/femul | 3m27.94s | 1656912 ko || -0m26.16s || -67396 ko | -12.58% | -4.06% + 2m35.79s | 1454696 ko | Specific/solinas32_2e255m765_12limbs/femul | 2m59.21s | 1549104 ko || -0m23.42s || -94408 ko | -13.06% | -6.09% + 0m34.35s | 828104 ko | Specific/X25519/C64/freeze | 0m36.42s | 826476 ko || -0m02.07s || 1628 ko | -5.68% | +0.19% + 0m39.72s | 825448 ko | Specific/X25519/C64/femul | 0m42.98s | 839624 ko || -0m03.25s || -14176 ko | -7.58% | -1.68% + 0m33.08s | 799620 ko | Specific/X25519/C64/fesquare | 0m35.23s | 802776 ko || -0m02.14s || -3156 ko | -6.10% | -0.39% + 0m38.19s | 799216 ko | Specific/NISTP256/AMD64/feadd | 0m40.48s | 797944 ko || -0m02.28s || 1272 ko | -5.65% | +0.15% + 0m43.34s | 793376 ko | Specific/NISTP256/AMD64/fesub | 0m43.78s | 799668 ko || -0m00.43s || -6292 ko | -1.00% | -0.78% + 0m27.11s | 786052 ko | Specific/X25519/C64/fecarry | 0m28.85s | 787148 ko || -0m01.74s || -1096 ko | -6.03% | -0.13% + 0m24.71s | 778792 ko | Specific/X25519/C64/fesub | 0m26.11s | 781808 ko || -0m01.39s || -3016 ko | -5.36% | -0.38% + 0m22.81s | 766300 ko | Specific/X25519/C64/feadd | 0m23.43s | 766168 ko || -0m00.62s || 132 ko | -2.64% | +0.01% + 0m31.00s | 765208 ko | Specific/NISTP256/AMD64/feopp | 0m32.08s | 765212 ko || -0m01.07s || -4 ko | -3.36% | -0.00% + 0m27.81s | 756080 ko | Specific/NISTP256/AMD64/fenz | 0m28.91s | 756216 ko || -0m01.10s || -136 ko | -3.80% | -0.01% + 0m49.44s | 744240 ko | Specific/solinas32_2e255m765_13limbs/Synthesis | 0m49.50s | 744472 ko || -0m00.06s || -232 ko | -0.12% | -0.03% + 0m40.13s | 728464 ko | Specific/solinas32_2e255m765_12limbs/Synthesis | 0m39.53s | 729464 ko || +0m00.60s || -1000 ko | +1.51% | -0.13% + 0m11.15s | 687760 ko | Specific/X25519/C64/Synthesis | 0m11.23s | 687812 ko || -0m00.08s || -52 ko | -0.71% | -0.00% + 0m13.45s | 668216 ko | Specific/NISTP256/AMD64/Synthesis | 0m13.74s | 667664 ko || -0m00.29s || 552 ko | -2.11% | +0.08% + 0m01.85s | 646300 ko | Specific/Framework/SynthesisFramework | 0m01.95s | 648632 ko || -0m00.09s || -2332 ko | -5.12% | -0.35% + 0m07.33s | 574388 ko | Compilers/Z/Bounds/Pipeline/Definition | 0m07.40s | 578344 ko || -0m00.07s || -3956 ko | -0.94% | -0.68% + 0m01.93s | 544172 ko | Compilers/Z/Bounds/Pipeline/ReflectiveTactics | 0m01.73s | 546112 ko || +0m00.19s || -1940 ko | +11.56% | -0.35% + 0m01.38s | 539808 ko | Compilers/Z/Bounds/Pipeline | 0m01.18s | 539160 ko || +0m00.19s || 648 ko | +16.94% | +0.12%
\ No newline at end of file diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-real-auto.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-real-auto.log.expected new file mode 100644 index 0000000000..7e4cfaec1c --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-real-auto.log.expected @@ -0,0 +1,26 @@ + After | Peak Mem | File Name | Before | Peak Mem || Change || Change (mem) | % Change | % Change (mem) +--------------------------------------------------------------------------------------------------------------------------------------------------------- +20m46.07s | 3302508 ko | Total Time / Peak Mem | 23m06.30s | 3307052 ko || -2m20.23s || -4544 ko | -10.11% | -0.13% +--------------------------------------------------------------------------------------------------------------------------------------------------------- + 2m35.79s | 1454696 ko | Specific/solinas32_2e255m765_12limbs/femul | 2m59.21s | 1549104 ko || -0m23.42s || -94408 ko | -13.06% | -6.09% + 3m01.77s | 1589516 ko | Specific/solinas32_2e255m765_13limbs/femul | 3m27.94s | 1656912 ko || -0m26.16s || -67396 ko | -12.58% | -4.06% + 0m39.72s | 825448 ko | Specific/X25519/C64/femul | 0m42.98s | 839624 ko || -0m03.25s || -14176 ko | -7.58% | -1.68% + 0m43.34s | 793376 ko | Specific/NISTP256/AMD64/fesub | 0m43.78s | 799668 ko || -0m00.43s || -6292 ko | -1.00% | -0.78% + 3m22.96s | 3302508 ko | Specific/NISTP256/AMD64/femul | 3m37.80s | 3307052 ko || -0m14.84s || -4544 ko | -6.81% | -0.13% + 4m16.77s | 1617000 ko | Specific/X25519/C64/ladderstep | 5m16.83s | 1621500 ko || -1m00.06s || -4500 ko | -18.95% | -0.27% + 0m07.33s | 574388 ko | Compilers/Z/Bounds/Pipeline/Definition | 0m07.40s | 578344 ko || -0m00.07s || -3956 ko | -0.94% | -0.68% + 0m33.08s | 799620 ko | Specific/X25519/C64/fesquare | 0m35.23s | 802776 ko || -0m02.14s || -3156 ko | -6.10% | -0.39% + 0m24.71s | 778792 ko | Specific/X25519/C64/fesub | 0m26.11s | 781808 ko || -0m01.39s || -3016 ko | -5.36% | -0.38% + 0m01.85s | 646300 ko | Specific/Framework/SynthesisFramework | 0m01.95s | 648632 ko || -0m00.09s || -2332 ko | -5.12% | -0.35% + 0m01.93s | 544172 ko | Compilers/Z/Bounds/Pipeline/ReflectiveTactics | 0m01.73s | 546112 ko || +0m00.19s || -1940 ko | +11.56% | -0.35% + 0m34.35s | 828104 ko | Specific/X25519/C64/freeze | 0m36.42s | 826476 ko || -0m02.07s || 1628 ko | -5.68% | +0.19% + 0m38.19s | 799216 ko | Specific/NISTP256/AMD64/feadd | 0m40.48s | 797944 ko || -0m02.28s || 1272 ko | -5.65% | +0.15% + 0m27.11s | 786052 ko | Specific/X25519/C64/fecarry | 0m28.85s | 787148 ko || -0m01.74s || -1096 ko | -6.03% | -0.13% + 0m40.13s | 728464 ko | Specific/solinas32_2e255m765_12limbs/Synthesis | 0m39.53s | 729464 ko || +0m00.60s || -1000 ko | +1.51% | -0.13% + 0m01.38s | 539808 ko | Compilers/Z/Bounds/Pipeline | 0m01.18s | 539160 ko || +0m00.19s || 648 ko | +16.94% | +0.12% + 0m13.45s | 668216 ko | Specific/NISTP256/AMD64/Synthesis | 0m13.74s | 667664 ko || -0m00.29s || 552 ko | -2.11% | +0.08% + 0m49.44s | 744240 ko | Specific/solinas32_2e255m765_13limbs/Synthesis | 0m49.50s | 744472 ko || -0m00.06s || -232 ko | -0.12% | -0.03% + 0m27.81s | 756080 ko | Specific/NISTP256/AMD64/fenz | 0m28.91s | 756216 ko || -0m01.10s || -136 ko | -3.80% | -0.01% + 0m22.81s | 766300 ko | Specific/X25519/C64/feadd | 0m23.43s | 766168 ko || -0m00.62s || 132 ko | -2.64% | +0.01% + 0m11.15s | 687760 ko | Specific/X25519/C64/Synthesis | 0m11.23s | 687812 ko || -0m00.08s || -52 ko | -0.71% | -0.00% + 0m31.00s | 765208 ko | Specific/NISTP256/AMD64/feopp | 0m32.08s | 765212 ko || -0m01.07s || -4 ko | -3.36% | -0.00%
\ No newline at end of file diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-real-diff.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-real-diff.log.expected new file mode 100644 index 0000000000..7842f91f1f --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-real-diff.log.expected @@ -0,0 +1,26 @@ + After | Peak Mem | File Name | Before | Peak Mem || Change || Change (mem) | % Change | % Change (mem) +--------------------------------------------------------------------------------------------------------------------------------------------------------- +20m46.07s | 3302508 ko | Total Time / Peak Mem | 23m06.30s | 3307052 ko || -2m20.23s || -4544 ko | -10.11% | -0.13% +--------------------------------------------------------------------------------------------------------------------------------------------------------- + 0m34.35s | 828104 ko | Specific/X25519/C64/freeze | 0m36.42s | 826476 ko || -0m02.07s || 1628 ko | -5.68% | +0.19% + 0m38.19s | 799216 ko | Specific/NISTP256/AMD64/feadd | 0m40.48s | 797944 ko || -0m02.28s || 1272 ko | -5.65% | +0.15% + 0m01.38s | 539808 ko | Compilers/Z/Bounds/Pipeline | 0m01.18s | 539160 ko || +0m00.19s || 648 ko | +16.94% | +0.12% + 0m13.45s | 668216 ko | Specific/NISTP256/AMD64/Synthesis | 0m13.74s | 667664 ko || -0m00.29s || 552 ko | -2.11% | +0.08% + 0m22.81s | 766300 ko | Specific/X25519/C64/feadd | 0m23.43s | 766168 ko || -0m00.62s || 132 ko | -2.64% | +0.01% + 0m31.00s | 765208 ko | Specific/NISTP256/AMD64/feopp | 0m32.08s | 765212 ko || -0m01.07s || -4 ko | -3.36% | -0.00% + 0m11.15s | 687760 ko | Specific/X25519/C64/Synthesis | 0m11.23s | 687812 ko || -0m00.08s || -52 ko | -0.71% | -0.00% + 0m27.81s | 756080 ko | Specific/NISTP256/AMD64/fenz | 0m28.91s | 756216 ko || -0m01.10s || -136 ko | -3.80% | -0.01% + 0m49.44s | 744240 ko | Specific/solinas32_2e255m765_13limbs/Synthesis | 0m49.50s | 744472 ko || -0m00.06s || -232 ko | -0.12% | -0.03% + 0m40.13s | 728464 ko | Specific/solinas32_2e255m765_12limbs/Synthesis | 0m39.53s | 729464 ko || +0m00.60s || -1000 ko | +1.51% | -0.13% + 0m27.11s | 786052 ko | Specific/X25519/C64/fecarry | 0m28.85s | 787148 ko || -0m01.74s || -1096 ko | -6.03% | -0.13% + 0m01.93s | 544172 ko | Compilers/Z/Bounds/Pipeline/ReflectiveTactics | 0m01.73s | 546112 ko || +0m00.19s || -1940 ko | +11.56% | -0.35% + 0m01.85s | 646300 ko | Specific/Framework/SynthesisFramework | 0m01.95s | 648632 ko || -0m00.09s || -2332 ko | -5.12% | -0.35% + 0m24.71s | 778792 ko | Specific/X25519/C64/fesub | 0m26.11s | 781808 ko || -0m01.39s || -3016 ko | -5.36% | -0.38% + 0m33.08s | 799620 ko | Specific/X25519/C64/fesquare | 0m35.23s | 802776 ko || -0m02.14s || -3156 ko | -6.10% | -0.39% + 0m07.33s | 574388 ko | Compilers/Z/Bounds/Pipeline/Definition | 0m07.40s | 578344 ko || -0m00.07s || -3956 ko | -0.94% | -0.68% + 4m16.77s | 1617000 ko | Specific/X25519/C64/ladderstep | 5m16.83s | 1621500 ko || -1m00.06s || -4500 ko | -18.95% | -0.27% + 3m22.96s | 3302508 ko | Specific/NISTP256/AMD64/femul | 3m37.80s | 3307052 ko || -0m14.84s || -4544 ko | -6.81% | -0.13% + 0m43.34s | 793376 ko | Specific/NISTP256/AMD64/fesub | 0m43.78s | 799668 ko || -0m00.43s || -6292 ko | -1.00% | -0.78% + 0m39.72s | 825448 ko | Specific/X25519/C64/femul | 0m42.98s | 839624 ko || -0m03.25s || -14176 ko | -7.58% | -1.68% + 3m01.77s | 1589516 ko | Specific/solinas32_2e255m765_13limbs/femul | 3m27.94s | 1656912 ko || -0m26.16s || -67396 ko | -12.58% | -4.06% + 2m35.79s | 1454696 ko | Specific/solinas32_2e255m765_12limbs/femul | 2m59.21s | 1549104 ko || -0m23.42s || -94408 ko | -13.06% | -6.09%
\ No newline at end of file diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-real.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-real.log.expected new file mode 100644 index 0000000000..7e4cfaec1c --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-real.log.expected @@ -0,0 +1,26 @@ + After | Peak Mem | File Name | Before | Peak Mem || Change || Change (mem) | % Change | % Change (mem) +--------------------------------------------------------------------------------------------------------------------------------------------------------- +20m46.07s | 3302508 ko | Total Time / Peak Mem | 23m06.30s | 3307052 ko || -2m20.23s || -4544 ko | -10.11% | -0.13% +--------------------------------------------------------------------------------------------------------------------------------------------------------- + 2m35.79s | 1454696 ko | Specific/solinas32_2e255m765_12limbs/femul | 2m59.21s | 1549104 ko || -0m23.42s || -94408 ko | -13.06% | -6.09% + 3m01.77s | 1589516 ko | Specific/solinas32_2e255m765_13limbs/femul | 3m27.94s | 1656912 ko || -0m26.16s || -67396 ko | -12.58% | -4.06% + 0m39.72s | 825448 ko | Specific/X25519/C64/femul | 0m42.98s | 839624 ko || -0m03.25s || -14176 ko | -7.58% | -1.68% + 0m43.34s | 793376 ko | Specific/NISTP256/AMD64/fesub | 0m43.78s | 799668 ko || -0m00.43s || -6292 ko | -1.00% | -0.78% + 3m22.96s | 3302508 ko | Specific/NISTP256/AMD64/femul | 3m37.80s | 3307052 ko || -0m14.84s || -4544 ko | -6.81% | -0.13% + 4m16.77s | 1617000 ko | Specific/X25519/C64/ladderstep | 5m16.83s | 1621500 ko || -1m00.06s || -4500 ko | -18.95% | -0.27% + 0m07.33s | 574388 ko | Compilers/Z/Bounds/Pipeline/Definition | 0m07.40s | 578344 ko || -0m00.07s || -3956 ko | -0.94% | -0.68% + 0m33.08s | 799620 ko | Specific/X25519/C64/fesquare | 0m35.23s | 802776 ko || -0m02.14s || -3156 ko | -6.10% | -0.39% + 0m24.71s | 778792 ko | Specific/X25519/C64/fesub | 0m26.11s | 781808 ko || -0m01.39s || -3016 ko | -5.36% | -0.38% + 0m01.85s | 646300 ko | Specific/Framework/SynthesisFramework | 0m01.95s | 648632 ko || -0m00.09s || -2332 ko | -5.12% | -0.35% + 0m01.93s | 544172 ko | Compilers/Z/Bounds/Pipeline/ReflectiveTactics | 0m01.73s | 546112 ko || +0m00.19s || -1940 ko | +11.56% | -0.35% + 0m34.35s | 828104 ko | Specific/X25519/C64/freeze | 0m36.42s | 826476 ko || -0m02.07s || 1628 ko | -5.68% | +0.19% + 0m38.19s | 799216 ko | Specific/NISTP256/AMD64/feadd | 0m40.48s | 797944 ko || -0m02.28s || 1272 ko | -5.65% | +0.15% + 0m27.11s | 786052 ko | Specific/X25519/C64/fecarry | 0m28.85s | 787148 ko || -0m01.74s || -1096 ko | -6.03% | -0.13% + 0m40.13s | 728464 ko | Specific/solinas32_2e255m765_12limbs/Synthesis | 0m39.53s | 729464 ko || +0m00.60s || -1000 ko | +1.51% | -0.13% + 0m01.38s | 539808 ko | Compilers/Z/Bounds/Pipeline | 0m01.18s | 539160 ko || +0m00.19s || 648 ko | +16.94% | +0.12% + 0m13.45s | 668216 ko | Specific/NISTP256/AMD64/Synthesis | 0m13.74s | 667664 ko || -0m00.29s || 552 ko | -2.11% | +0.08% + 0m49.44s | 744240 ko | Specific/solinas32_2e255m765_13limbs/Synthesis | 0m49.50s | 744472 ko || -0m00.06s || -232 ko | -0.12% | -0.03% + 0m27.81s | 756080 ko | Specific/NISTP256/AMD64/fenz | 0m28.91s | 756216 ko || -0m01.10s || -136 ko | -3.80% | -0.01% + 0m22.81s | 766300 ko | Specific/X25519/C64/feadd | 0m23.43s | 766168 ko || -0m00.62s || 132 ko | -2.64% | +0.01% + 0m11.15s | 687760 ko | Specific/X25519/C64/Synthesis | 0m11.23s | 687812 ko || -0m00.08s || -52 ko | -0.71% | -0.00% + 0m31.00s | 765208 ko | Specific/NISTP256/AMD64/feopp | 0m32.08s | 765212 ko || -0m01.07s || -4 ko | -3.36% | -0.00%
\ No newline at end of file diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-user-absolute.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-user-absolute.log.expected new file mode 100644 index 0000000000..ea116a804f --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-user-absolute.log.expected @@ -0,0 +1,26 @@ + After | Peak Mem | File Name | Before | Peak Mem || Change || Change (mem) | % Change | % Change (mem) +--------------------------------------------------------------------------------------------------------------------------------------------------------- +19m16.04s | 3302508 ko | Total Time / Peak Mem | 21m25.27s | 3307052 ko || -2m09.23s || -4544 ko | -10.05% | -0.13% +--------------------------------------------------------------------------------------------------------------------------------------------------------- + 3m09.62s | 3302508 ko | Specific/NISTP256/AMD64/femul | 3m22.52s | 3307052 ko || -0m12.90s || -4544 ko | -6.36% | -0.13% + 4m01.34s | 1617000 ko | Specific/X25519/C64/ladderstep | 4m59.49s | 1621500 ko || -0m58.15s || -4500 ko | -19.41% | -0.27% + 2m48.52s | 1589516 ko | Specific/solinas32_2e255m765_13limbs/femul | 3m12.95s | 1656912 ko || -0m24.42s || -67396 ko | -12.66% | -4.06% + 2m23.70s | 1454696 ko | Specific/solinas32_2e255m765_12limbs/femul | 2m44.11s | 1549104 ko || -0m20.41s || -94408 ko | -12.43% | -6.09% + 0m31.50s | 828104 ko | Specific/X25519/C64/freeze | 0m33.24s | 826476 ko || -0m01.74s || 1628 ko | -5.23% | +0.19% + 0m36.32s | 825448 ko | Specific/X25519/C64/femul | 0m39.50s | 839624 ko || -0m03.17s || -14176 ko | -8.05% | -1.68% + 0m30.13s | 799620 ko | Specific/X25519/C64/fesquare | 0m32.24s | 802776 ko || -0m02.11s || -3156 ko | -6.54% | -0.39% + 0m35.40s | 799216 ko | Specific/NISTP256/AMD64/feadd | 0m37.21s | 797944 ko || -0m01.81s || 1272 ko | -4.86% | +0.15% + 0m39.59s | 793376 ko | Specific/NISTP256/AMD64/fesub | 0m40.09s | 799668 ko || -0m00.50s || -6292 ko | -1.24% | -0.78% + 0m24.99s | 786052 ko | Specific/X25519/C64/fecarry | 0m26.31s | 787148 ko || -0m01.32s || -1096 ko | -5.01% | -0.13% + 0m22.65s | 778792 ko | Specific/X25519/C64/fesub | 0m23.72s | 781808 ko || -0m01.07s || -3016 ko | -4.51% | -0.38% + 0m20.93s | 766300 ko | Specific/X25519/C64/feadd | 0m21.41s | 766168 ko || -0m00.48s || 132 ko | -2.24% | +0.01% + 0m28.51s | 765208 ko | Specific/NISTP256/AMD64/feopp | 0m29.46s | 765212 ko || -0m00.94s || -4 ko | -3.22% | -0.00% + 0m25.50s | 756080 ko | Specific/NISTP256/AMD64/fenz | 0m26.41s | 756216 ko || -0m00.91s || -136 ko | -3.44% | -0.01% + 0m45.75s | 744240 ko | Specific/solinas32_2e255m765_13limbs/Synthesis | 0m45.58s | 744472 ko || +0m00.17s || -232 ko | +0.37% | -0.03% + 0m36.92s | 728464 ko | Specific/solinas32_2e255m765_12limbs/Synthesis | 0m36.64s | 729464 ko || +0m00.28s || -1000 ko | +0.76% | -0.13% + 0m10.37s | 687760 ko | Specific/X25519/C64/Synthesis | 0m10.30s | 687812 ko || +0m00.06s || -52 ko | +0.67% | -0.00% + 0m12.55s | 668216 ko | Specific/NISTP256/AMD64/Synthesis | 0m12.54s | 667664 ko || +0m00.01s || 552 ko | +0.07% | +0.08% + 0m01.67s | 646300 ko | Specific/Framework/SynthesisFramework | 0m01.72s | 648632 ko || -0m00.05s || -2332 ko | -2.90% | -0.35% + 0m07.18s | 574388 ko | Compilers/Z/Bounds/Pipeline/Definition | 0m07.22s | 578344 ko || -0m00.04s || -3956 ko | -0.55% | -0.68% + 0m01.72s | 544172 ko | Compilers/Z/Bounds/Pipeline/ReflectiveTactics | 0m01.58s | 546112 ko || +0m00.13s || -1940 ko | +8.86% | -0.35% + 0m01.19s | 539808 ko | Compilers/Z/Bounds/Pipeline | 0m01.04s | 539160 ko || +0m00.14s || 648 ko | +14.42% | +0.12%
\ No newline at end of file diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-user-auto.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-user-auto.log.expected new file mode 100644 index 0000000000..128f140662 --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-user-auto.log.expected @@ -0,0 +1,26 @@ + After | Peak Mem | File Name | Before | Peak Mem || Change || Change (mem) | % Change | % Change (mem) +--------------------------------------------------------------------------------------------------------------------------------------------------------- +19m16.04s | 3302508 ko | Total Time / Peak Mem | 21m25.27s | 3307052 ko || -2m09.23s || -4544 ko | -10.05% | -0.13% +--------------------------------------------------------------------------------------------------------------------------------------------------------- + 2m23.70s | 1454696 ko | Specific/solinas32_2e255m765_12limbs/femul | 2m44.11s | 1549104 ko || -0m20.41s || -94408 ko | -12.43% | -6.09% + 2m48.52s | 1589516 ko | Specific/solinas32_2e255m765_13limbs/femul | 3m12.95s | 1656912 ko || -0m24.42s || -67396 ko | -12.66% | -4.06% + 0m36.32s | 825448 ko | Specific/X25519/C64/femul | 0m39.50s | 839624 ko || -0m03.17s || -14176 ko | -8.05% | -1.68% + 0m39.59s | 793376 ko | Specific/NISTP256/AMD64/fesub | 0m40.09s | 799668 ko || -0m00.50s || -6292 ko | -1.24% | -0.78% + 3m09.62s | 3302508 ko | Specific/NISTP256/AMD64/femul | 3m22.52s | 3307052 ko || -0m12.90s || -4544 ko | -6.36% | -0.13% + 4m01.34s | 1617000 ko | Specific/X25519/C64/ladderstep | 4m59.49s | 1621500 ko || -0m58.15s || -4500 ko | -19.41% | -0.27% + 0m07.18s | 574388 ko | Compilers/Z/Bounds/Pipeline/Definition | 0m07.22s | 578344 ko || -0m00.04s || -3956 ko | -0.55% | -0.68% + 0m30.13s | 799620 ko | Specific/X25519/C64/fesquare | 0m32.24s | 802776 ko || -0m02.11s || -3156 ko | -6.54% | -0.39% + 0m22.65s | 778792 ko | Specific/X25519/C64/fesub | 0m23.72s | 781808 ko || -0m01.07s || -3016 ko | -4.51% | -0.38% + 0m01.67s | 646300 ko | Specific/Framework/SynthesisFramework | 0m01.72s | 648632 ko || -0m00.05s || -2332 ko | -2.90% | -0.35% + 0m01.72s | 544172 ko | Compilers/Z/Bounds/Pipeline/ReflectiveTactics | 0m01.58s | 546112 ko || +0m00.13s || -1940 ko | +8.86% | -0.35% + 0m31.50s | 828104 ko | Specific/X25519/C64/freeze | 0m33.24s | 826476 ko || -0m01.74s || 1628 ko | -5.23% | +0.19% + 0m35.40s | 799216 ko | Specific/NISTP256/AMD64/feadd | 0m37.21s | 797944 ko || -0m01.81s || 1272 ko | -4.86% | +0.15% + 0m24.99s | 786052 ko | Specific/X25519/C64/fecarry | 0m26.31s | 787148 ko || -0m01.32s || -1096 ko | -5.01% | -0.13% + 0m36.92s | 728464 ko | Specific/solinas32_2e255m765_12limbs/Synthesis | 0m36.64s | 729464 ko || +0m00.28s || -1000 ko | +0.76% | -0.13% + 0m01.19s | 539808 ko | Compilers/Z/Bounds/Pipeline | 0m01.04s | 539160 ko || +0m00.14s || 648 ko | +14.42% | +0.12% + 0m12.55s | 668216 ko | Specific/NISTP256/AMD64/Synthesis | 0m12.54s | 667664 ko || +0m00.01s || 552 ko | +0.07% | +0.08% + 0m45.75s | 744240 ko | Specific/solinas32_2e255m765_13limbs/Synthesis | 0m45.58s | 744472 ko || +0m00.17s || -232 ko | +0.37% | -0.03% + 0m25.50s | 756080 ko | Specific/NISTP256/AMD64/fenz | 0m26.41s | 756216 ko || -0m00.91s || -136 ko | -3.44% | -0.01% + 0m20.93s | 766300 ko | Specific/X25519/C64/feadd | 0m21.41s | 766168 ko || -0m00.48s || 132 ko | -2.24% | +0.01% + 0m10.37s | 687760 ko | Specific/X25519/C64/Synthesis | 0m10.30s | 687812 ko || +0m00.06s || -52 ko | +0.67% | -0.00% + 0m28.51s | 765208 ko | Specific/NISTP256/AMD64/feopp | 0m29.46s | 765212 ko || -0m00.94s || -4 ko | -3.22% | -0.00%
\ No newline at end of file diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-user-diff.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-user-diff.log.expected new file mode 100644 index 0000000000..79dc49892f --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-user-diff.log.expected @@ -0,0 +1,26 @@ + After | Peak Mem | File Name | Before | Peak Mem || Change || Change (mem) | % Change | % Change (mem) +--------------------------------------------------------------------------------------------------------------------------------------------------------- +19m16.04s | 3302508 ko | Total Time / Peak Mem | 21m25.27s | 3307052 ko || -2m09.23s || -4544 ko | -10.05% | -0.13% +--------------------------------------------------------------------------------------------------------------------------------------------------------- + 0m31.50s | 828104 ko | Specific/X25519/C64/freeze | 0m33.24s | 826476 ko || -0m01.74s || 1628 ko | -5.23% | +0.19% + 0m35.40s | 799216 ko | Specific/NISTP256/AMD64/feadd | 0m37.21s | 797944 ko || -0m01.81s || 1272 ko | -4.86% | +0.15% + 0m01.19s | 539808 ko | Compilers/Z/Bounds/Pipeline | 0m01.04s | 539160 ko || +0m00.14s || 648 ko | +14.42% | +0.12% + 0m12.55s | 668216 ko | Specific/NISTP256/AMD64/Synthesis | 0m12.54s | 667664 ko || +0m00.01s || 552 ko | +0.07% | +0.08% + 0m20.93s | 766300 ko | Specific/X25519/C64/feadd | 0m21.41s | 766168 ko || -0m00.48s || 132 ko | -2.24% | +0.01% + 0m28.51s | 765208 ko | Specific/NISTP256/AMD64/feopp | 0m29.46s | 765212 ko || -0m00.94s || -4 ko | -3.22% | -0.00% + 0m10.37s | 687760 ko | Specific/X25519/C64/Synthesis | 0m10.30s | 687812 ko || +0m00.06s || -52 ko | +0.67% | -0.00% + 0m25.50s | 756080 ko | Specific/NISTP256/AMD64/fenz | 0m26.41s | 756216 ko || -0m00.91s || -136 ko | -3.44% | -0.01% + 0m45.75s | 744240 ko | Specific/solinas32_2e255m765_13limbs/Synthesis | 0m45.58s | 744472 ko || +0m00.17s || -232 ko | +0.37% | -0.03% + 0m36.92s | 728464 ko | Specific/solinas32_2e255m765_12limbs/Synthesis | 0m36.64s | 729464 ko || +0m00.28s || -1000 ko | +0.76% | -0.13% + 0m24.99s | 786052 ko | Specific/X25519/C64/fecarry | 0m26.31s | 787148 ko || -0m01.32s || -1096 ko | -5.01% | -0.13% + 0m01.72s | 544172 ko | Compilers/Z/Bounds/Pipeline/ReflectiveTactics | 0m01.58s | 546112 ko || +0m00.13s || -1940 ko | +8.86% | -0.35% + 0m01.67s | 646300 ko | Specific/Framework/SynthesisFramework | 0m01.72s | 648632 ko || -0m00.05s || -2332 ko | -2.90% | -0.35% + 0m22.65s | 778792 ko | Specific/X25519/C64/fesub | 0m23.72s | 781808 ko || -0m01.07s || -3016 ko | -4.51% | -0.38% + 0m30.13s | 799620 ko | Specific/X25519/C64/fesquare | 0m32.24s | 802776 ko || -0m02.11s || -3156 ko | -6.54% | -0.39% + 0m07.18s | 574388 ko | Compilers/Z/Bounds/Pipeline/Definition | 0m07.22s | 578344 ko || -0m00.04s || -3956 ko | -0.55% | -0.68% + 4m01.34s | 1617000 ko | Specific/X25519/C64/ladderstep | 4m59.49s | 1621500 ko || -0m58.15s || -4500 ko | -19.41% | -0.27% + 3m09.62s | 3302508 ko | Specific/NISTP256/AMD64/femul | 3m22.52s | 3307052 ko || -0m12.90s || -4544 ko | -6.36% | -0.13% + 0m39.59s | 793376 ko | Specific/NISTP256/AMD64/fesub | 0m40.09s | 799668 ko || -0m00.50s || -6292 ko | -1.24% | -0.78% + 0m36.32s | 825448 ko | Specific/X25519/C64/femul | 0m39.50s | 839624 ko || -0m03.17s || -14176 ko | -8.05% | -1.68% + 2m48.52s | 1589516 ko | Specific/solinas32_2e255m765_13limbs/femul | 3m12.95s | 1656912 ko || -0m24.42s || -67396 ko | -12.66% | -4.06% + 2m23.70s | 1454696 ko | Specific/solinas32_2e255m765_12limbs/femul | 2m44.11s | 1549104 ko || -0m20.41s || -94408 ko | -12.43% | -6.09%
\ No newline at end of file diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-user.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-user.log.expected new file mode 100644 index 0000000000..128f140662 --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-user.log.expected @@ -0,0 +1,26 @@ + After | Peak Mem | File Name | Before | Peak Mem || Change || Change (mem) | % Change | % Change (mem) +--------------------------------------------------------------------------------------------------------------------------------------------------------- +19m16.04s | 3302508 ko | Total Time / Peak Mem | 21m25.27s | 3307052 ko || -2m09.23s || -4544 ko | -10.05% | -0.13% +--------------------------------------------------------------------------------------------------------------------------------------------------------- + 2m23.70s | 1454696 ko | Specific/solinas32_2e255m765_12limbs/femul | 2m44.11s | 1549104 ko || -0m20.41s || -94408 ko | -12.43% | -6.09% + 2m48.52s | 1589516 ko | Specific/solinas32_2e255m765_13limbs/femul | 3m12.95s | 1656912 ko || -0m24.42s || -67396 ko | -12.66% | -4.06% + 0m36.32s | 825448 ko | Specific/X25519/C64/femul | 0m39.50s | 839624 ko || -0m03.17s || -14176 ko | -8.05% | -1.68% + 0m39.59s | 793376 ko | Specific/NISTP256/AMD64/fesub | 0m40.09s | 799668 ko || -0m00.50s || -6292 ko | -1.24% | -0.78% + 3m09.62s | 3302508 ko | Specific/NISTP256/AMD64/femul | 3m22.52s | 3307052 ko || -0m12.90s || -4544 ko | -6.36% | -0.13% + 4m01.34s | 1617000 ko | Specific/X25519/C64/ladderstep | 4m59.49s | 1621500 ko || -0m58.15s || -4500 ko | -19.41% | -0.27% + 0m07.18s | 574388 ko | Compilers/Z/Bounds/Pipeline/Definition | 0m07.22s | 578344 ko || -0m00.04s || -3956 ko | -0.55% | -0.68% + 0m30.13s | 799620 ko | Specific/X25519/C64/fesquare | 0m32.24s | 802776 ko || -0m02.11s || -3156 ko | -6.54% | -0.39% + 0m22.65s | 778792 ko | Specific/X25519/C64/fesub | 0m23.72s | 781808 ko || -0m01.07s || -3016 ko | -4.51% | -0.38% + 0m01.67s | 646300 ko | Specific/Framework/SynthesisFramework | 0m01.72s | 648632 ko || -0m00.05s || -2332 ko | -2.90% | -0.35% + 0m01.72s | 544172 ko | Compilers/Z/Bounds/Pipeline/ReflectiveTactics | 0m01.58s | 546112 ko || +0m00.13s || -1940 ko | +8.86% | -0.35% + 0m31.50s | 828104 ko | Specific/X25519/C64/freeze | 0m33.24s | 826476 ko || -0m01.74s || 1628 ko | -5.23% | +0.19% + 0m35.40s | 799216 ko | Specific/NISTP256/AMD64/feadd | 0m37.21s | 797944 ko || -0m01.81s || 1272 ko | -4.86% | +0.15% + 0m24.99s | 786052 ko | Specific/X25519/C64/fecarry | 0m26.31s | 787148 ko || -0m01.32s || -1096 ko | -5.01% | -0.13% + 0m36.92s | 728464 ko | Specific/solinas32_2e255m765_12limbs/Synthesis | 0m36.64s | 729464 ko || +0m00.28s || -1000 ko | +0.76% | -0.13% + 0m01.19s | 539808 ko | Compilers/Z/Bounds/Pipeline | 0m01.04s | 539160 ko || +0m00.14s || 648 ko | +14.42% | +0.12% + 0m12.55s | 668216 ko | Specific/NISTP256/AMD64/Synthesis | 0m12.54s | 667664 ko || +0m00.01s || 552 ko | +0.07% | +0.08% + 0m45.75s | 744240 ko | Specific/solinas32_2e255m765_13limbs/Synthesis | 0m45.58s | 744472 ko || +0m00.17s || -232 ko | +0.37% | -0.03% + 0m25.50s | 756080 ko | Specific/NISTP256/AMD64/fenz | 0m26.41s | 756216 ko || -0m00.91s || -136 ko | -3.44% | -0.01% + 0m20.93s | 766300 ko | Specific/X25519/C64/feadd | 0m21.41s | 766168 ko || -0m00.48s || 132 ko | -2.24% | +0.01% + 0m10.37s | 687760 ko | Specific/X25519/C64/Synthesis | 0m10.30s | 687812 ko || +0m00.06s || -52 ko | +0.67% | -0.00% + 0m28.51s | 765208 ko | Specific/NISTP256/AMD64/feopp | 0m29.46s | 765212 ko || -0m00.94s || -4 ko | -3.22% | -0.00%
\ No newline at end of file diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/run.sh b/test-suite/coq-makefile/timing/precomputed-time-tests/run.sh index 4b5acb9168..8935759705 100755 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/run.sh +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/run.sh @@ -11,3 +11,4 @@ export COQLIB ./002-single-file-sorting/run.sh ./003-non-utf8/run.sh ./004-per-file-fuzz/run.sh +./005-correct-diff-sorting-order-mem/run.sh diff --git a/test-suite/coq-makefile/timing/run.sh b/test-suite/coq-makefile/timing/run.sh index 4ee4aae36c..ed5a4f93f5 100755 --- a/test-suite/coq-makefile/timing/run.sh +++ b/test-suite/coq-makefile/timing/run.sh @@ -55,15 +55,17 @@ TO_SED_IN_BOTH=( TO_SED_IN_PER_FILE=( -e s'/ */ /g' # unclear whether this is actually needed for per-file timing; it's been here from the start -e s'/\(Total.*\)-\(.*\)-/\1+\2+/g' # Overall time in the per-file timing diff should be around 0; if it comes out negative, we remove the sign + -e s'/- ko/ko/g' # for small amounts of memory, signs can flip, so we remove mem signs ) TO_SED_IN_PER_LINE=( -e s'/ */ /g' # Sometimes 0 will show up as 0m00.s, sometimes it'll end up being more like 0m00.001s; we must strip out the spaces that result from left-aligning numbers of different widths based on how many digits Coq's [-time] gives + -e s'/^ *//g' # the number of leading spaces can differ, e.g., as in the difference between ' 0m13.53s' vs '0m13.582s' ) for file in time-of-build-before.log time-of-build-after.log time-of-build-both.log; do for ext in "" .desired; do - grep -v 'warning: undefined variable' < ${file}${ext} | sed "${TO_SED_IN_BOTH[@]}" "${TO_SED_IN_PER_FILE[@]}" > ${file}${ext}.processed + sed "${TO_SED_IN_BOTH[@]}" "${TO_SED_IN_PER_FILE[@]}" ${file}${ext} > ${file}${ext}.processed done echo "cat $file" cat "$file" diff --git a/test-suite/coqdoc/Record.html.out b/test-suite/coqdoc/Record.html.out new file mode 100644 index 0000000000..371188dfbe --- /dev/null +++ b/test-suite/coqdoc/Record.html.out @@ -0,0 +1,34 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" +"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8" /> +<link href="coqdoc.css" rel="stylesheet" type="text/css" /> +<title>Coqdoc.Record</title> +</head> + +<body> + +<div id="page"> + +<div id="header"> +</div> + +<div id="main"> + +<h1 class="libtitle">Library Coqdoc.Record</h1> + +<div class="code"> +<span class="id" title="keyword">Record</span> <a id="a" class="idref" href="#a"><span class="id" title="record">a</span></a> := { <a id="b" class="idref" href="#b"><span class="id" title="projection">b</span></a> : <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a> ; <a id="c" class="idref" href="#c"><span class="id" title="projection">c</span></a> : <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#bool"><span class="id" title="inductive">bool</span></a> }.<br/> +<span class="id" title="keyword">Definition</span> <a id="d" class="idref" href="#d"><span class="id" title="definition">d</span></a> := {| <a class="idref" href="Coqdoc.Record.html#b"><span class="id" title="projection">b</span></a> := 0 ; <a class="idref" href="Coqdoc.Record.html#c"><span class="id" title="projection">c</span></a> := <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#true"><span class="id" title="constructor">true</span></a> |}.<br/> +</div> +</div> + +<div id="footer"> +<hr/><a href="index.html">Index</a><hr/>This page has been generated by <a href="http://coq.inria.fr/">coqdoc</a> +</div> + +</div> + +</body> +</html>
\ No newline at end of file diff --git a/test-suite/coqdoc/Record.tex.out b/test-suite/coqdoc/Record.tex.out new file mode 100644 index 0000000000..4130ea9472 --- /dev/null +++ b/test-suite/coqdoc/Record.tex.out @@ -0,0 +1,27 @@ +\documentclass[12pt]{report} +\usepackage[utf8x]{inputenc} + +%Warning: tipa declares many non-standard macros used by utf8x to +%interpret utf8 characters but extra packages might have to be added +%such as "textgreek" for Greek letters not already in tipa +%or "stmaryrd" for mathematical symbols. +%Utf8 codes missing a LaTeX interpretation can be defined by using +%\DeclareUnicodeCharacter{code}{interpretation}. +%Use coqdoc's option -p to add new packages or declarations. +\usepackage{tipa} + +\usepackage[T1]{fontenc} +\usepackage{fullpage} +\usepackage{coqdoc} +\usepackage{amsmath,amssymb} +\usepackage{url} +\begin{document} +\coqlibrary{Coqdoc.Record}{Library }{Coqdoc.Record} + +\begin{coqdoccode} +\coqdocnoindent +\coqdockw{Record} \coqdef{Coqdoc.Record.a}{a}{\coqdocrecord{a}} := \{ \coqdef{Coqdoc.Record.b}{b}{\coqdocprojection{b}} : \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}} ; \coqdef{Coqdoc.Record.c}{c}{\coqdocprojection{c}} : \coqexternalref{bool}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{bool}} \}.\coqdoceol +\coqdocnoindent +\coqdockw{Definition} \coqdef{Coqdoc.Record.d}{d}{\coqdocdefinition{d}} := \{| \coqref{Coqdoc.Record.b}{\coqdocprojection{b}} := 0 ; \coqref{Coqdoc.Record.c}{\coqdocprojection{c}} := \coqexternalref{true}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocconstructor{true}} |\}.\coqdoceol +\end{coqdoccode} +\end{document} diff --git a/test-suite/coqdoc/Record.v b/test-suite/coqdoc/Record.v new file mode 100644 index 0000000000..f362aade98 --- /dev/null +++ b/test-suite/coqdoc/Record.v @@ -0,0 +1,2 @@ +Record a := { b : nat ; c : bool }. +Definition d := {| b := 0 ; c := true |}. diff --git a/test-suite/coqdoc/binder.html.out b/test-suite/coqdoc/binder.html.out new file mode 100644 index 0000000000..af8eb46845 --- /dev/null +++ b/test-suite/coqdoc/binder.html.out @@ -0,0 +1,41 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" +"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8" /> +<link href="coqdoc.css" rel="stylesheet" type="text/css" /> +<title>Coqdoc.binder</title> +</head> + +<body> + +<div id="page"> + +<div id="header"> +</div> + +<div id="main"> + +<h1 class="libtitle">Library Coqdoc.binder</h1> + +<div class="code"> +</div> + +<div class="doc"> +Link binders +</div> +<div class="code"> + +<br/> +<span class="id" title="keyword">Definition</span> <a id="foo" class="idref" href="#foo"><span class="id" title="definition">foo</span></a> <a id="alpha:1" class="idref" href="#alpha:1"><span class="id" title="binder">alpha</span></a> <a id="beta:2" class="idref" href="#beta:2"><span class="id" title="binder">beta</span></a> := <a class="idref" href="Coqdoc.binder.html#alpha:1"><span class="id" title="variable">alpha</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#0dacc1786c5ba797d47dd85006231633"><span class="id" title="notation">+</span></a> <a class="idref" href="Coqdoc.binder.html#beta:2"><span class="id" title="variable">beta</span></a>.<br/> +</div> +</div> + +<div id="footer"> +<hr/><a href="index.html">Index</a><hr/>This page has been generated by <a href="http://coq.inria.fr/">coqdoc</a> +</div> + +</div> + +</body> +</html>
\ No newline at end of file diff --git a/test-suite/coqdoc/binder.tex.out b/test-suite/coqdoc/binder.tex.out new file mode 100644 index 0000000000..2b5648aee6 --- /dev/null +++ b/test-suite/coqdoc/binder.tex.out @@ -0,0 +1,28 @@ +\documentclass[12pt]{report} +\usepackage[utf8x]{inputenc} + +%Warning: tipa declares many non-standard macros used by utf8x to +%interpret utf8 characters but extra packages might have to be added +%such as "textgreek" for Greek letters not already in tipa +%or "stmaryrd" for mathematical symbols. +%Utf8 codes missing a LaTeX interpretation can be defined by using +%\DeclareUnicodeCharacter{code}{interpretation}. +%Use coqdoc's option -p to add new packages or declarations. +\usepackage{tipa} + +\usepackage[T1]{fontenc} +\usepackage{fullpage} +\usepackage{coqdoc} +\usepackage{amsmath,amssymb} +\usepackage{url} +\begin{document} +\coqlibrary{Coqdoc.binder}{Library }{Coqdoc.binder} + +\begin{coqdoccode} +\end{coqdoccode} +Link binders \begin{coqdoccode} +\coqdocemptyline +\coqdocnoindent +\coqdockw{Definition} \coqdef{Coqdoc.binder.foo}{foo}{\coqdocdefinition{foo}} \coqdef{Coqdoc.binder.alpha:1}{alpha}{\coqdocbinder{alpha}} \coqdef{Coqdoc.binder.beta:2}{beta}{\coqdocbinder{beta}} := \coqref{Coqdoc.binder.alpha:1}{\coqdocvariable{alpha}} \coqexternalref{::nat scope:x '+' x}{http://coq.inria.fr/stdlib/Coq.Init.Peano}{\coqdocnotation{+}} \coqref{Coqdoc.binder.beta:2}{\coqdocvariable{beta}}.\coqdoceol +\end{coqdoccode} +\end{document} diff --git a/test-suite/coqdoc/binder.v b/test-suite/coqdoc/binder.v new file mode 100644 index 0000000000..283ef64ac5 --- /dev/null +++ b/test-suite/coqdoc/binder.v @@ -0,0 +1,3 @@ +(** Link binders *) + +Definition foo alpha beta := alpha + beta. diff --git a/test-suite/coqdoc/bug11194.html.out b/test-suite/coqdoc/bug11194.html.out new file mode 100644 index 0000000000..56bf6eaaca --- /dev/null +++ b/test-suite/coqdoc/bug11194.html.out @@ -0,0 +1,37 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" +"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8" /> +<link href="coqdoc.css" rel="stylesheet" type="text/css" /> +<title>Coqdoc.bug11194</title> +</head> + +<body> + +<div id="page"> + +<div id="header"> +</div> + +<div id="main"> + +<h1 class="libtitle">Library Coqdoc.bug11194</h1> + +<div class="code"> +<span class="id" title="keyword">Record</span> <a id="a_struct" class="idref" href="#a_struct"><span class="id" title="record">a_struct</span></a> := { <a id="anum" class="idref" href="#anum"><span class="id" title="projection">anum</span></a> : <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a> }.<br/> +<span class="id" title="keyword">Canonical</span> <span class="id" title="keyword">Structure</span> <a id="a_struct_0" class="idref" href="#a_struct_0"><span class="id" title="definition">a_struct_0</span></a> := {| <a class="idref" href="Coqdoc.bug11194.html#anum"><span class="id" title="projection">anum</span></a> := 0|}.<br/> +<span class="id" title="keyword">Definition</span> <a id="rename_a_s_0" class="idref" href="#rename_a_s_0"><span class="id" title="definition">rename_a_s_0</span></a> := <a class="idref" href="Coqdoc.bug11194.html#a_struct_0"><span class="id" title="definition">a_struct_0</span></a>.<br/> +<span class="id" title="keyword">Coercion</span> <a id="some_nat" class="idref" href="#some_nat"><span class="id" title="definition">some_nat</span></a> := (@<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#Some"><span class="id" title="constructor">Some</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>).<br/> +<span class="id" title="keyword">Definition</span> <a id="rename_some_nat" class="idref" href="#rename_some_nat"><span class="id" title="definition">rename_some_nat</span></a> := <a class="idref" href="Coqdoc.bug11194.html#some_nat"><span class="id" title="definition">some_nat</span></a>.<br/> +</div> +</div> + +<div id="footer"> +<hr/><a href="index.html">Index</a><hr/>This page has been generated by <a href="http://coq.inria.fr/">coqdoc</a> +</div> + +</div> + +</body> +</html>
\ No newline at end of file diff --git a/test-suite/coqdoc/bug11194.tex.out b/test-suite/coqdoc/bug11194.tex.out new file mode 100644 index 0000000000..a262b45fc8 --- /dev/null +++ b/test-suite/coqdoc/bug11194.tex.out @@ -0,0 +1,33 @@ +\documentclass[12pt]{report} +\usepackage[utf8x]{inputenc} + +%Warning: tipa declares many non-standard macros used by utf8x to +%interpret utf8 characters but extra packages might have to be added +%such as "textgreek" for Greek letters not already in tipa +%or "stmaryrd" for mathematical symbols. +%Utf8 codes missing a LaTeX interpretation can be defined by using +%\DeclareUnicodeCharacter{code}{interpretation}. +%Use coqdoc's option -p to add new packages or declarations. +\usepackage{tipa} + +\usepackage[T1]{fontenc} +\usepackage{fullpage} +\usepackage{coqdoc} +\usepackage{amsmath,amssymb} +\usepackage{url} +\begin{document} +\coqlibrary{Coqdoc.bug11194}{Library }{Coqdoc.bug11194} + +\begin{coqdoccode} +\coqdocnoindent +\coqdockw{Record} \coqdef{Coqdoc.bug11194.a struct}{a\_struct}{\coqdocrecord{a\_struct}} := \{ \coqdef{Coqdoc.bug11194.anum}{anum}{\coqdocprojection{anum}} : \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}} \}.\coqdoceol +\coqdocnoindent +\coqdockw{Canonical} \coqdockw{Structure} \coqdef{Coqdoc.bug11194.a struct 0}{a\_struct\_0}{\coqdocdefinition{a\_struct\_0}} := \{| \coqref{Coqdoc.bug11194.anum}{\coqdocprojection{anum}} := 0|\}.\coqdoceol +\coqdocnoindent +\coqdockw{Definition} \coqdef{Coqdoc.bug11194.rename a s 0}{rename\_a\_s\_0}{\coqdocdefinition{rename\_a\_s\_0}} := \coqref{Coqdoc.bug11194.a struct 0}{\coqdocdefinition{a\_struct\_0}}.\coqdoceol +\coqdocnoindent +\coqdockw{Coercion} \coqdef{Coqdoc.bug11194.some nat}{some\_nat}{\coqdocdefinition{some\_nat}} := (@\coqexternalref{Some}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocconstructor{Some}} \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}}).\coqdoceol +\coqdocnoindent +\coqdockw{Definition} \coqdef{Coqdoc.bug11194.rename some nat}{rename\_some\_nat}{\coqdocdefinition{rename\_some\_nat}} := \coqref{Coqdoc.bug11194.some nat}{\coqdocdefinition{some\_nat}}.\coqdoceol +\end{coqdoccode} +\end{document} diff --git a/test-suite/coqdoc/bug11194.v b/test-suite/coqdoc/bug11194.v new file mode 100644 index 0000000000..b1d2a54f25 --- /dev/null +++ b/test-suite/coqdoc/bug11194.v @@ -0,0 +1,5 @@ +Record a_struct := { anum : nat }. +Canonical Structure a_struct_0 := {| anum := 0|}. +Definition rename_a_s_0 := a_struct_0. +Coercion some_nat := (@Some nat). +Definition rename_some_nat := some_nat. diff --git a/test-suite/coqdoc/bug11353.html.out b/test-suite/coqdoc/bug11353.html.out index 0b4b4b6e37..f9d6a79906 100644 --- a/test-suite/coqdoc/bug11353.html.out +++ b/test-suite/coqdoc/bug11353.html.out @@ -19,13 +19,13 @@ <h1 class="libtitle">Library Coqdoc.bug11353</h1> <div class="code"> -<span class="id" title="keyword">Definition</span> <a name="a"><span class="id" title="definition">a</span></a> := 0. #[ <span class="id" title="var">universes</span>( <span class="id" title="var">template</span>) ]<br/> -<span class="id" title="keyword">Inductive</span> <a name="mysum"><span class="id" title="inductive">mysum</span></a> (<span class="id" title="var">A</span> <span class="id" title="var">B</span>:<span class="id" title="keyword">Type</span>) : <span class="id" title="keyword">Type</span> :=<br/> - | <a name="myinl"><span class="id" title="constructor">myinl</span></a> : <a class="idref" href="Coqdoc.bug11353.html#A"><span class="id" title="variable">A</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#1c93e43e07fbeaeb6a625cb6614beb5d"><span class="id" title="notation">→</span></a> <a class="idref" href="Coqdoc.bug11353.html#mysum"><span class="id" title="inductive">mysum</span></a> <a class="idref" href="Coqdoc.bug11353.html#A"><span class="id" title="variable">A</span></a> <a class="idref" href="Coqdoc.bug11353.html#B"><span class="id" title="variable">B</span></a><br/> - | <a name="myinr"><span class="id" title="constructor">myinr</span></a> : <a class="idref" href="Coqdoc.bug11353.html#B"><span class="id" title="variable">B</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#1c93e43e07fbeaeb6a625cb6614beb5d"><span class="id" title="notation">→</span></a> <a class="idref" href="Coqdoc.bug11353.html#mysum"><span class="id" title="inductive">mysum</span></a> <a class="idref" href="Coqdoc.bug11353.html#A"><span class="id" title="variable">A</span></a> <a class="idref" href="Coqdoc.bug11353.html#B"><span class="id" title="variable">B</span></a>.<br/> +<span class="id" title="keyword">Definition</span> <a id="a" class="idref" href="#a"><span class="id" title="definition">a</span></a> := 0. #[ <span class="id" title="var">universes</span>( <span class="id" title="var">template</span>) ]<br/> +<span class="id" title="keyword">Inductive</span> <a id="mysum" class="idref" href="#mysum"><span class="id" title="inductive">mysum</span></a> (<a id="A:1" class="idref" href="#A:1"><span class="id" title="binder">A</span></a> <a id="B:2" class="idref" href="#B:2"><span class="id" title="binder">B</span></a>:<span class="id" title="keyword">Type</span>) : <span class="id" title="keyword">Type</span> :=<br/> + | <a id="myinl" class="idref" href="#myinl"><span class="id" title="constructor">myinl</span></a> : <a class="idref" href="Coqdoc.bug11353.html#A:1"><span class="id" title="variable">A</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#::type_scope:x_'->'_x"><span class="id" title="notation">→</span></a> <a class="idref" href="Coqdoc.bug11353.html#mysum:3"><span class="id" title="inductive">mysum</span></a> <a class="idref" href="Coqdoc.bug11353.html#A:1"><span class="id" title="variable">A</span></a> <a class="idref" href="Coqdoc.bug11353.html#B:2"><span class="id" title="variable">B</span></a><br/> + | <a id="myinr" class="idref" href="#myinr"><span class="id" title="constructor">myinr</span></a> : <a class="idref" href="Coqdoc.bug11353.html#B:2"><span class="id" title="variable">B</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#::type_scope:x_'->'_x"><span class="id" title="notation">→</span></a> <a class="idref" href="Coqdoc.bug11353.html#mysum:3"><span class="id" title="inductive">mysum</span></a> <a class="idref" href="Coqdoc.bug11353.html#A:1"><span class="id" title="variable">A</span></a> <a class="idref" href="Coqdoc.bug11353.html#B:2"><span class="id" title="variable">B</span></a>.<br/> <br/> -#[<span class="id" title="var">local</span>]<span class="id" title="keyword">Definition</span> <a name="b"><span class="id" title="definition">b</span></a> := 1.<br/> +#[<span class="id" title="var">local</span>]<span class="id" title="keyword">Definition</span> <a id="b" class="idref" href="#b"><span class="id" title="definition">b</span></a> := 1.<br/> </div> </div> diff --git a/test-suite/coqdoc/bug11353.tex.out b/test-suite/coqdoc/bug11353.tex.out index a6478682d8..12ea109d0e 100644 --- a/test-suite/coqdoc/bug11353.tex.out +++ b/test-suite/coqdoc/bug11353.tex.out @@ -22,11 +22,11 @@ \coqdocnoindent \coqdockw{Definition} \coqdef{Coqdoc.bug11353.a}{a}{\coqdocdefinition{a}} := 0. \#[ \coqdocvar{universes}( \coqdocvar{template}) ]\coqdoceol \coqdocnoindent -\coqdockw{Inductive} \coqdef{Coqdoc.bug11353.mysum}{mysum}{\coqdocinductive{mysum}} (\coqdocvar{A} \coqdocvar{B}:\coqdockw{Type}) : \coqdockw{Type} :=\coqdoceol +\coqdockw{Inductive} \coqdef{Coqdoc.bug11353.mysum}{mysum}{\coqdocinductive{mysum}} (\coqdef{Coqdoc.bug11353.A:1}{A}{\coqdocbinder{A}} \coqdef{Coqdoc.bug11353.B:2}{B}{\coqdocbinder{B}}:\coqdockw{Type}) : \coqdockw{Type} :=\coqdoceol \coqdocindent{1.00em} -\ensuremath{|} \coqdef{Coqdoc.bug11353.myinl}{myinl}{\coqdocconstructor{myinl}} : \coqdocvariable{A} \coqexternalref{::type scope:x '->' x}{http://coq.inria.fr/stdlib/Coq.Init.Logic}{\coqdocnotation{\ensuremath{\rightarrow}}} \coqref{Coqdoc.bug11353.mysum}{\coqdocinductive{mysum}} \coqdocvariable{A} \coqdocvariable{B}\coqdoceol +\ensuremath{|} \coqdef{Coqdoc.bug11353.myinl}{myinl}{\coqdocconstructor{myinl}} : \coqref{Coqdoc.bug11353.A:1}{\coqdocvariable{A}} \coqexternalref{::type scope:x '->' x}{http://coq.inria.fr/stdlib/Coq.Init.Logic}{\coqdocnotation{\ensuremath{\rightarrow}}} \coqref{Coqdoc.bug11353.mysum:3}{\coqdocinductive{mysum}} \coqref{Coqdoc.bug11353.A:1}{\coqdocvariable{A}} \coqref{Coqdoc.bug11353.B:2}{\coqdocvariable{B}}\coqdoceol \coqdocindent{1.00em} -\ensuremath{|} \coqdef{Coqdoc.bug11353.myinr}{myinr}{\coqdocconstructor{myinr}} : \coqdocvariable{B} \coqexternalref{::type scope:x '->' x}{http://coq.inria.fr/stdlib/Coq.Init.Logic}{\coqdocnotation{\ensuremath{\rightarrow}}} \coqref{Coqdoc.bug11353.mysum}{\coqdocinductive{mysum}} \coqdocvariable{A} \coqdocvariable{B}.\coqdoceol +\ensuremath{|} \coqdef{Coqdoc.bug11353.myinr}{myinr}{\coqdocconstructor{myinr}} : \coqref{Coqdoc.bug11353.B:2}{\coqdocvariable{B}} \coqexternalref{::type scope:x '->' x}{http://coq.inria.fr/stdlib/Coq.Init.Logic}{\coqdocnotation{\ensuremath{\rightarrow}}} \coqref{Coqdoc.bug11353.mysum:3}{\coqdocinductive{mysum}} \coqref{Coqdoc.bug11353.A:1}{\coqdocvariable{A}} \coqref{Coqdoc.bug11353.B:2}{\coqdocvariable{B}}.\coqdoceol \coqdocemptyline \coqdocnoindent \#[\coqdocvar{local}]\coqdockw{Definition} \coqdef{Coqdoc.bug11353.b}{b}{\coqdocdefinition{b}} := 1.\coqdoceol diff --git a/test-suite/coqdoc/bug5648.html.out b/test-suite/coqdoc/bug5648.html.out index 5c5a2dc299..e1d1c1313e 100644 --- a/test-suite/coqdoc/bug5648.html.out +++ b/test-suite/coqdoc/bug5648.html.out @@ -19,18 +19,18 @@ <h1 class="libtitle">Library Coqdoc.bug5648</h1> <div class="code"> -<span class="id" title="keyword">Lemma</span> <a name="a"><span class="id" title="lemma">a</span></a> : <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#True"><span class="id" title="inductive">True</span></a>.<br/> +<span class="id" title="keyword">Lemma</span> <a id="a" class="idref" href="#a"><span class="id" title="lemma">a</span></a> : <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#True"><span class="id" title="inductive">True</span></a>.<br/> <span class="id" title="keyword">Proof</span>.<br/> <span class="id" title="tactic">auto</span>.<br/> <span class="id" title="keyword">Qed</span>.<br/> <br/> -<span class="id" title="keyword">Variant</span> <a name="t"><span class="id" title="inductive">t</span></a> :=<br/> -| <a name="A"><span class="id" title="constructor">A</span></a> | <a name="Add"><span class="id" title="constructor">Add</span></a> | <a name="G"><span class="id" title="constructor">G</span></a> | <a name="Goal"><span class="id" title="constructor">Goal</span></a> | <a name="L"><span class="id" title="constructor">L</span></a> | <a name="Lemma"><span class="id" title="constructor">Lemma</span></a> | <a name="P"><span class="id" title="constructor">P</span></a> | <a name="Proof"><span class="id" title="constructor">Proof</span></a> .<br/> +<span class="id" title="keyword">Variant</span> <a id="t" class="idref" href="#t"><span class="id" title="inductive">t</span></a> :=<br/> +| <a id="A" class="idref" href="#A"><span class="id" title="constructor">A</span></a> | <a id="Add" class="idref" href="#Add"><span class="id" title="constructor">Add</span></a> | <a id="G" class="idref" href="#G"><span class="id" title="constructor">G</span></a> | <a id="Goal" class="idref" href="#Goal"><span class="id" title="constructor">Goal</span></a> | <a id="L" class="idref" href="#L"><span class="id" title="constructor">L</span></a> | <a id="Lemma" class="idref" href="#Lemma"><span class="id" title="constructor">Lemma</span></a> | <a id="P" class="idref" href="#P"><span class="id" title="constructor">P</span></a> | <a id="Proof" class="idref" href="#Proof"><span class="id" title="constructor">Proof</span></a> .<br/> <br/> -<span class="id" title="keyword">Definition</span> <a name="d"><span class="id" title="definition">d</span></a> <span class="id" title="var">x</span> :=<br/> - <span class="id" title="keyword">match</span> <a class="idref" href="Coqdoc.bug5648.html#x"><span class="id" title="variable">x</span></a> <span class="id" title="keyword">with</span><br/> +<span class="id" title="keyword">Definition</span> <a id="d" class="idref" href="#d"><span class="id" title="definition">d</span></a> <a id="x:3" class="idref" href="#x:3"><span class="id" title="binder">x</span></a> :=<br/> + <span class="id" title="keyword">match</span> <a class="idref" href="Coqdoc.bug5648.html#x:3"><span class="id" title="variable">x</span></a> <span class="id" title="keyword">with</span><br/> | <a class="idref" href="Coqdoc.bug5648.html#A"><span class="id" title="constructor">A</span></a> ⇒ 0<br/> | <a class="idref" href="Coqdoc.bug5648.html#Add"><span class="id" title="constructor">Add</span></a> ⇒ 1<br/> | <a class="idref" href="Coqdoc.bug5648.html#G"><span class="id" title="constructor">G</span></a> ⇒ 2<br/> diff --git a/test-suite/coqdoc/bug5648.tex.out b/test-suite/coqdoc/bug5648.tex.out index 82f7da2309..c221d7ca8a 100644 --- a/test-suite/coqdoc/bug5648.tex.out +++ b/test-suite/coqdoc/bug5648.tex.out @@ -34,9 +34,9 @@ \ensuremath{|} \coqdef{Coqdoc.bug5648.A}{A}{\coqdocconstructor{A}} \ensuremath{|} \coqdef{Coqdoc.bug5648.Add}{Add}{\coqdocconstructor{Add}} \ensuremath{|} \coqdef{Coqdoc.bug5648.G}{G}{\coqdocconstructor{G}} \ensuremath{|} \coqdef{Coqdoc.bug5648.Goal}{Goal}{\coqdocconstructor{Goal}} \ensuremath{|} \coqdef{Coqdoc.bug5648.L}{L}{\coqdocconstructor{L}} \ensuremath{|} \coqdef{Coqdoc.bug5648.Lemma}{Lemma}{\coqdocconstructor{Lemma}} \ensuremath{|} \coqdef{Coqdoc.bug5648.P}{P}{\coqdocconstructor{P}} \ensuremath{|} \coqdef{Coqdoc.bug5648.Proof}{Proof}{\coqdocconstructor{Proof}} .\coqdoceol \coqdocemptyline \coqdocnoindent -\coqdockw{Definition} \coqdef{Coqdoc.bug5648.d}{d}{\coqdocdefinition{d}} \coqdocvar{x} :=\coqdoceol +\coqdockw{Definition} \coqdef{Coqdoc.bug5648.d}{d}{\coqdocdefinition{d}} \coqdef{Coqdoc.bug5648.x:3}{x}{\coqdocbinder{x}} :=\coqdoceol \coqdocindent{1.00em} -\coqdockw{match} \coqdocvariable{x} \coqdockw{with}\coqdoceol +\coqdockw{match} \coqref{Coqdoc.bug5648.x:3}{\coqdocvariable{x}} \coqdockw{with}\coqdoceol \coqdocindent{1.00em} \ensuremath{|} \coqref{Coqdoc.bug5648.A}{\coqdocconstructor{A}} \ensuremath{\Rightarrow} 0\coqdoceol \coqdocindent{1.00em} diff --git a/test-suite/coqdoc/bug5700.html.out b/test-suite/coqdoc/bug5700.html.out index b96fc6281d..286e8bba4d 100644 --- a/test-suite/coqdoc/bug5700.html.out +++ b/test-suite/coqdoc/bug5700.html.out @@ -26,7 +26,7 @@ </div> <div class="code"> -<span class="id" title="keyword">Definition</span> <a name="const1"><span class="id" title="definition">const1</span></a> := 1.<br/> +<span class="id" title="keyword">Definition</span> <a id="const1" class="idref" href="#const1"><span class="id" title="definition">const1</span></a> := 1.<br/> <br/> </div> @@ -36,7 +36,7 @@ </div> <div class="code"> -<span class="id" title="keyword">Definition</span> <a name="const2"><span class="id" title="definition">const2</span></a> := 2.<br/> +<span class="id" title="keyword">Definition</span> <a id="const2" class="idref" href="#const2"><span class="id" title="definition">const2</span></a> := 2.<br/> </div> </div> diff --git a/test-suite/coqdoc/links.html.out b/test-suite/coqdoc/links.html.out index d2d4d5d764..12d284dc54 100644 --- a/test-suite/coqdoc/links.html.out +++ b/test-suite/coqdoc/links.html.out @@ -51,93 +51,93 @@ Various checks for coqdoc <span class="id" title="keyword">Require</span> <span class="id" title="keyword">Import</span> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Strings.String.html#"><span class="id" title="library">String</span></a>.<br/> <br/> -<span class="id" title="keyword">Definition</span> <a name="g"><span class="id" title="definition">g</span></a> := "dfjkh""sdfhj forall <> * ~"%<span class="id" title="var">string</span>.<br/> +<span class="id" title="keyword">Definition</span> <a id="g" class="idref" href="#g"><span class="id" title="definition">g</span></a> := "dfjkh""sdfhj forall <> * ~"%<span class="id" title="var">string</span>.<br/> <br/> -<span class="id" title="keyword">Definition</span> <a name="a"><span class="id" title="definition">a</span></a> (<span class="id" title="var">b</span>: <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>) := <a class="idref" href="Coqdoc.links.html#b"><span class="id" title="variable">b</span></a>.<br/> +<span class="id" title="keyword">Definition</span> <a id="a" class="idref" href="#a"><span class="id" title="definition">a</span></a> (<a id="b:1" class="idref" href="#b:1"><span class="id" title="binder">b</span></a>: <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>) := <a class="idref" href="Coqdoc.links.html#b:1"><span class="id" title="variable">b</span></a>.<br/> <br/> -<span class="id" title="keyword">Definition</span> <a name="f"><span class="id" title="definition">f</span></a> := <span class="id" title="keyword">∀</span> <span class="id" title="var">C</span>:<span class="id" title="keyword">Prop</span>, <a class="idref" href="Coqdoc.links.html#C"><span class="id" title="variable">C</span></a>.<br/> +<span class="id" title="keyword">Definition</span> <a id="f" class="idref" href="#f"><span class="id" title="definition">f</span></a> := <span class="id" title="keyword">∀</span> <a id="C:2" class="idref" href="#C:2"><span class="id" title="binder">C</span></a>:<span class="id" title="keyword">Prop</span>, <a class="idref" href="Coqdoc.links.html#C:2"><span class="id" title="variable">C</span></a>.<br/> <br/> -<span class="id" title="keyword">Notation</span> <a name="f03f7a04ef75ff3ac66ca5c23554e52e"><span class="id" title="notation">"</span></a>n ++ m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#plus"><span class="id" title="abbreviation">plus</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>).<br/> +<span class="id" title="keyword">Notation</span> <a id="f03f7a04ef75ff3ac66ca5c23554e52e" class="idref" href="#f03f7a04ef75ff3ac66ca5c23554e52e"><span class="id" title="notation">"</span></a>n ++ m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#plus"><span class="id" title="abbreviation">plus</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>).<br/> <br/> -<span class="id" title="keyword">Notation</span> <a name="f03f7a04ef75ff3ac66ca5c23554e52e"><span class="id" title="notation">"</span></a>n ++ m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#mult"><span class="id" title="abbreviation">mult</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>). +<span class="id" title="keyword">Notation</span> <a id="f03f7a04ef75ff3ac66ca5c23554e52e" class="idref" href="#f03f7a04ef75ff3ac66ca5c23554e52e"><span class="id" title="notation">"</span></a>n ++ m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#mult"><span class="id" title="abbreviation">mult</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>). <br/> -<span class="id" title="keyword">Notation</span> <a name="f07b3676d96b68749d342542fd80e2b0"><span class="id" title="notation">"</span></a>n ** m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#plus"><span class="id" title="abbreviation">plus</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>) (<span class="id" title="tactic">at</span> <span class="id" title="keyword">level</span> 60).<br/> +<span class="id" title="keyword">Notation</span> <a id="f07b3676d96b68749d342542fd80e2b0" class="idref" href="#f07b3676d96b68749d342542fd80e2b0"><span class="id" title="notation">"</span></a>n ** m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#plus"><span class="id" title="abbreviation">plus</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>) (<span class="id" title="tactic">at</span> <span class="id" title="keyword">level</span> 60).<br/> <br/> -<span class="id" title="keyword">Notation</span> <a name="a647c51c9816a1b44fcfa5312db8344a"><span class="id" title="notation">"</span></a>n ▵ m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#plus"><span class="id" title="abbreviation">plus</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>) (<span class="id" title="tactic">at</span> <span class="id" title="keyword">level</span> 60).<br/> +<span class="id" title="keyword">Notation</span> <a id="a647c51c9816a1b44fcfa5312db8344a" class="idref" href="#a647c51c9816a1b44fcfa5312db8344a"><span class="id" title="notation">"</span></a>n ▵ m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#plus"><span class="id" title="abbreviation">plus</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>) (<span class="id" title="tactic">at</span> <span class="id" title="keyword">level</span> 60).<br/> <br/> -<span class="id" title="keyword">Notation</span> <a name="3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">"</span></a>n '_' ++ 'x' m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#plus"><span class="id" title="abbreviation">plus</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>) (<span class="id" title="tactic">at</span> <span class="id" title="keyword">level</span> 3).<br/> +<span class="id" title="keyword">Notation</span> <a id="3dd9eae9daa65efe5444f5fc3529a2e7" class="idref" href="#3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">"</span></a>n '_' ++ 'x' m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#plus"><span class="id" title="abbreviation">plus</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>) (<span class="id" title="tactic">at</span> <span class="id" title="keyword">level</span> 3).<br/> <br/> -<span class="id" title="keyword">Inductive</span> <a name="eq"><span class="id" title="inductive">eq</span></a> (<span class="id" title="var">A</span>:<span class="id" title="keyword">Type</span>) (<span class="id" title="var">x</span>:<a class="idref" href="Coqdoc.links.html#A"><span class="id" title="variable">A</span></a>) : <span class="id" title="var">A</span> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#1c93e43e07fbeaeb6a625cb6614beb5d"><span class="id" title="notation">→</span></a> <span class="id" title="keyword">Prop</span> := <a name="eq_refl"><span class="id" title="constructor">eq_refl</span></a> : <a class="idref" href="Coqdoc.links.html#x"><span class="id" title="variable">x</span></a> <a class="idref" href="Coqdoc.links.html#b8b2ebc8e1a8b9aa935c0702efb5dccf"><span class="id" title="notation">=</span></a> <a class="idref" href="Coqdoc.links.html#x"><span class="id" title="variable">x</span></a> <a class="idref" href="Coqdoc.links.html#b8b2ebc8e1a8b9aa935c0702efb5dccf"><span class="id" title="notation">:></span></a><a class="idref" href="Coqdoc.links.html#A"><span class="id" title="variable">A</span></a><br/> +<span class="id" title="keyword">Inductive</span> <a id="eq" class="idref" href="#eq"><span class="id" title="inductive">eq</span></a> (<a id="A:3" class="idref" href="#A:3"><span class="id" title="binder">A</span></a>:<span class="id" title="keyword">Type</span>) (<a id="x:4" class="idref" href="#x:4"><span class="id" title="binder">x</span></a>:<a class="idref" href="Coqdoc.links.html#A:3"><span class="id" title="variable">A</span></a>) : <span class="id" title="var">A</span> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#::type_scope:x_'->'_x"><span class="id" title="notation">→</span></a> <span class="id" title="keyword">Prop</span> := <a id="eq_refl" class="idref" href="#eq_refl"><span class="id" title="constructor">eq_refl</span></a> : <a class="idref" href="Coqdoc.links.html#x:4"><span class="id" title="variable">x</span></a> <a class="idref" href="Coqdoc.links.html#b8b2ebc8e1a8b9aa935c0702efb5dccf"><span class="id" title="notation">=</span></a> <a class="idref" href="Coqdoc.links.html#x:4"><span class="id" title="variable">x</span></a> <a class="idref" href="Coqdoc.links.html#b8b2ebc8e1a8b9aa935c0702efb5dccf"><span class="id" title="notation">:></span></a><a class="idref" href="Coqdoc.links.html#A:3"><span class="id" title="variable">A</span></a><br/> <br/> -<span class="id" title="keyword">where</span> <a name="b8b2ebc8e1a8b9aa935c0702efb5dccf"><span class="id" title="notation">"</span></a>x = y :> A" := (@<a class="idref" href="Coqdoc.links.html#eq"><span class="id" title="inductive">eq</span></a> <span class="id" title="var">A</span> <span class="id" title="var">x</span> <span class="id" title="var">y</span>) : <span class="id" title="var">type_scope</span>.<br/> +<span class="id" title="keyword">where</span> <a id="b8b2ebc8e1a8b9aa935c0702efb5dccf" class="idref" href="#b8b2ebc8e1a8b9aa935c0702efb5dccf"><span class="id" title="notation">"</span></a>x = y :> A" := (@<a class="idref" href="Coqdoc.links.html#eq:6"><span class="id" title="inductive">eq</span></a> <span class="id" title="var">A</span> <span class="id" title="var">x</span> <span class="id" title="var">y</span>) : <span class="id" title="var">type_scope</span>.<br/> <br/> -<span class="id" title="keyword">Definition</span> <a name="eq0"><span class="id" title="definition">eq0</span></a> := 0 <a class="idref" href="Coqdoc.links.html#b8b2ebc8e1a8b9aa935c0702efb5dccf"><span class="id" title="notation">=</span></a> 0 <a class="idref" href="Coqdoc.links.html#b8b2ebc8e1a8b9aa935c0702efb5dccf"><span class="id" title="notation">:></span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>.<br/> +<span class="id" title="keyword">Definition</span> <a id="eq0" class="idref" href="#eq0"><span class="id" title="definition">eq0</span></a> := 0 <a class="idref" href="Coqdoc.links.html#b8b2ebc8e1a8b9aa935c0702efb5dccf"><span class="id" title="notation">=</span></a> 0 <a class="idref" href="Coqdoc.links.html#b8b2ebc8e1a8b9aa935c0702efb5dccf"><span class="id" title="notation">:></span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>.<br/> <br/> -<span class="id" title="keyword">Notation</span> <a name="2c0c193cd2aedf7ecdb713db64dbfce6"><span class="id" title="notation">"</span></a>( x # y ; .. ; z )" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#pair"><span class="id" title="constructor">pair</span></a> .. (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#pair"><span class="id" title="constructor">pair</span></a> <span class="id" title="var">x</span> <span class="id" title="var">y</span>) .. <span class="id" title="var">z</span>).<br/> +<span class="id" title="keyword">Notation</span> <a id="2c0c193cd2aedf7ecdb713db64dbfce6" class="idref" href="#2c0c193cd2aedf7ecdb713db64dbfce6"><span class="id" title="notation">"</span></a>( x # y ; .. ; z )" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#pair"><span class="id" title="constructor">pair</span></a> .. (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#pair"><span class="id" title="constructor">pair</span></a> <span class="id" title="var">x</span> <span class="id" title="var">y</span>) .. <span class="id" title="var">z</span>).<br/> <br/> -<span class="id" title="keyword">Definition</span> <a name="9f5a1d89cbd4d38f5e289576db7123d1"><span class="id" title="definition">b_α</span></a> := <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#e6756e10c36f149b18b4a8741ed83079"><span class="id" title="notation">(</span></a><a class="idref" href="Coqdoc.links.html#2c0c193cd2aedf7ecdb713db64dbfce6"><span class="id" title="notation">(</span></a>0<a class="idref" href="Coqdoc.links.html#2c0c193cd2aedf7ecdb713db64dbfce6"><span class="id" title="notation">#</span></a>0<a class="idref" href="Coqdoc.links.html#2c0c193cd2aedf7ecdb713db64dbfce6"><span class="id" title="notation">;</span></a>0<a class="idref" href="Coqdoc.links.html#2c0c193cd2aedf7ecdb713db64dbfce6"><span class="id" title="notation">)</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#e6756e10c36f149b18b4a8741ed83079"><span class="id" title="notation">,</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#e6756e10c36f149b18b4a8741ed83079"><span class="id" title="notation">(</span></a>0 <a class="idref" href="Coqdoc.links.html#f07b3676d96b68749d342542fd80e2b0"><span class="id" title="notation">**</span></a> 0<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#e6756e10c36f149b18b4a8741ed83079"><span class="id" title="notation">))</span></a>.<br/> +<span class="id" title="keyword">Definition</span> <a id="9f5a1d89cbd4d38f5e289576db7123d1" class="idref" href="#9f5a1d89cbd4d38f5e289576db7123d1"><span class="id" title="definition">b_α</span></a> := <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#e6756e10c36f149b18b4a8741ed83079"><span class="id" title="notation">(</span></a><a class="idref" href="Coqdoc.links.html#2c0c193cd2aedf7ecdb713db64dbfce6"><span class="id" title="notation">(</span></a>0<a class="idref" href="Coqdoc.links.html#2c0c193cd2aedf7ecdb713db64dbfce6"><span class="id" title="notation">#</span></a>0<a class="idref" href="Coqdoc.links.html#2c0c193cd2aedf7ecdb713db64dbfce6"><span class="id" title="notation">;</span></a>0<a class="idref" href="Coqdoc.links.html#2c0c193cd2aedf7ecdb713db64dbfce6"><span class="id" title="notation">)</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#e6756e10c36f149b18b4a8741ed83079"><span class="id" title="notation">,</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#e6756e10c36f149b18b4a8741ed83079"><span class="id" title="notation">(</span></a>0 <a class="idref" href="Coqdoc.links.html#f07b3676d96b68749d342542fd80e2b0"><span class="id" title="notation">**</span></a> 0<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#e6756e10c36f149b18b4a8741ed83079"><span class="id" title="notation">))</span></a>.<br/> <br/> -<span class="id" title="keyword">Notation</span> <a name="h"><span class="id" title="abbreviation">h</span></a> := <a class="idref" href="Coqdoc.links.html#a"><span class="id" title="definition">a</span></a>.<br/> +<span class="id" title="keyword">Notation</span> <a id="h" class="idref" href="#h"><span class="id" title="abbreviation">h</span></a> := <a class="idref" href="Coqdoc.links.html#a"><span class="id" title="definition">a</span></a>.<br/> <br/> - <span class="id" title="keyword">Section</span> <a name="test"><span class="id" title="section">test</span></a>.<br/> + <span class="id" title="keyword">Section</span> <a id="test" class="idref" href="#test"><span class="id" title="section">test</span></a>.<br/> <br/> - <span class="id" title="keyword">Variables</span> <a name="test.b'"><span class="id" title="variable">b'</span></a> <a name="test.b2"><span class="id" title="variable">b2</span></a>: <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>.<br/> + <span class="id" title="keyword">Variables</span> <a id="test.b'" class="idref" href="#test.b'"><span class="id" title="variable">b'</span></a> <a id="test.b2" class="idref" href="#test.b2"><span class="id" title="variable">b2</span></a>: <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>.<br/> <br/> - <span class="id" title="keyword">Notation</span> <a name="2158f15740ce05a939b657be222c26d6"><span class="id" title="notation">"</span></a>n + m" := (<span class="id" title="var">n</span> <a class="idref" href="Coqdoc.links.html#a647c51c9816a1b44fcfa5312db8344a"><span class="id" title="notation">▵</span></a> <span class="id" title="var">m</span>) : <span class="id" title="var">my_scope</span>.<br/> + <span class="id" title="keyword">Notation</span> <a id="2158f15740ce05a939b657be222c26d6" class="idref" href="#2158f15740ce05a939b657be222c26d6"><span class="id" title="notation">"</span></a>n + m" := (<span class="id" title="var">n</span> <a class="idref" href="Coqdoc.links.html#a647c51c9816a1b44fcfa5312db8344a"><span class="id" title="notation">▵</span></a> <span class="id" title="var">m</span>) : <span class="id" title="var">my_scope</span>.<br/> <br/> <span class="id" title="keyword">Delimit</span> <span class="id" title="keyword">Scope</span> <span class="id" title="var">my_scope</span> <span class="id" title="keyword">with</span> <span class="id" title="var">my</span>.<br/> <br/> - <span class="id" title="keyword">Notation</span> <a name="l"><span class="id" title="abbreviation">l</span></a> := 0.<br/> + <span class="id" title="keyword">Notation</span> <a id="l" class="idref" href="#l"><span class="id" title="abbreviation">l</span></a> := 0.<br/> <br/> - <span class="id" title="keyword">Definition</span> <a name="ab410a966ac148e9b78c65c6cdf301fd"><span class="id" title="definition">α</span></a> := (0 <a class="idref" href="Coqdoc.links.html#2158f15740ce05a939b657be222c26d6"><span class="id" title="notation">+</span></a> <a class="idref" href="Coqdoc.links.html#l"><span class="id" title="abbreviation">l</span></a>)%<span class="id" title="var">my</span>.<br/> + <span class="id" title="keyword">Definition</span> <a id="ab410a966ac148e9b78c65c6cdf301fd" class="idref" href="#ab410a966ac148e9b78c65c6cdf301fd"><span class="id" title="definition">α</span></a> := (0 <a class="idref" href="Coqdoc.links.html#2158f15740ce05a939b657be222c26d6"><span class="id" title="notation">+</span></a> <a class="idref" href="Coqdoc.links.html#l"><span class="id" title="abbreviation">l</span></a>)%<span class="id" title="var">my</span>.<br/> <br/> - <span class="id" title="keyword">Definition</span> <a name="a'"><span class="id" title="definition">a'</span></a> <span class="id" title="var">b</span> := <a class="idref" href="Coqdoc.links.html#test.b'"><span class="id" title="variable">b'</span></a><a class="idref" href="Coqdoc.links.html#f03f7a04ef75ff3ac66ca5c23554e52e"><span class="id" title="notation">++</span></a>0<a class="idref" href="Coqdoc.links.html#f03f7a04ef75ff3ac66ca5c23554e52e"><span class="id" title="notation">++</span></a><a class="idref" href="Coqdoc.links.html#test.b2"><span class="id" title="variable">b2</span></a> <a class="idref" href="Coqdoc.links.html#3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">_</span></a> <a class="idref" href="Coqdoc.links.html#3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">++</span></a><a class="idref" href="Coqdoc.links.html#3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">x</span></a> <a class="idref" href="Coqdoc.links.html#b"><span class="id" title="variable">b</span></a>.<br/> + <span class="id" title="keyword">Definition</span> <a id="a'" class="idref" href="#a'"><span class="id" title="definition">a'</span></a> <a id="b:9" class="idref" href="#b:9"><span class="id" title="binder">b</span></a> := <a class="idref" href="Coqdoc.links.html#test.b'"><span class="id" title="variable">b'</span></a><a class="idref" href="Coqdoc.links.html#f03f7a04ef75ff3ac66ca5c23554e52e"><span class="id" title="notation">++</span></a>0<a class="idref" href="Coqdoc.links.html#f03f7a04ef75ff3ac66ca5c23554e52e"><span class="id" title="notation">++</span></a><a class="idref" href="Coqdoc.links.html#test.b2"><span class="id" title="variable">b2</span></a> <a class="idref" href="Coqdoc.links.html#3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">_</span></a> <a class="idref" href="Coqdoc.links.html#3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">++</span></a><a class="idref" href="Coqdoc.links.html#3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">x</span></a> <a class="idref" href="Coqdoc.links.html#b:9"><span class="id" title="variable">b</span></a>.<br/> <br/> - <span class="id" title="keyword">Definition</span> <a name="c"><span class="id" title="definition">c</span></a> := <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Specif.html#87727981cdc1579fef00b9d9c1d3b9da"><span class="id" title="notation">{</span></a><a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#True"><span class="id" title="inductive">True</span></a><a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Specif.html#87727981cdc1579fef00b9d9c1d3b9da"><span class="id" title="notation">}+{</span></a><a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#True"><span class="id" title="inductive">True</span></a><a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Specif.html#87727981cdc1579fef00b9d9c1d3b9da"><span class="id" title="notation">}</span></a>.<br/> + <span class="id" title="keyword">Definition</span> <a id="c" class="idref" href="#c"><span class="id" title="definition">c</span></a> := <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Specif.html#87727981cdc1579fef00b9d9c1d3b9da"><span class="id" title="notation">{</span></a><a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#True"><span class="id" title="inductive">True</span></a><a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Specif.html#87727981cdc1579fef00b9d9c1d3b9da"><span class="id" title="notation">}+{</span></a><a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#True"><span class="id" title="inductive">True</span></a><a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Specif.html#87727981cdc1579fef00b9d9c1d3b9da"><span class="id" title="notation">}</span></a>.<br/> <br/> - <span class="id" title="keyword">Definition</span> <a name="d"><span class="id" title="definition">d</span></a> := (1<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#0dacc1786c5ba797d47dd85006231633"><span class="id" title="notation">+</span></a>2)%<span class="id" title="var">nat</span>.<br/> + <span class="id" title="keyword">Definition</span> <a id="d" class="idref" href="#d"><span class="id" title="definition">d</span></a> := (1<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#0dacc1786c5ba797d47dd85006231633"><span class="id" title="notation">+</span></a>2)%<span class="id" title="var">nat</span>.<br/> <br/> - <span class="id" title="keyword">Lemma</span> <a name="e"><span class="id" title="lemma">e</span></a> : <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#e03f39daf98516fa530d3f6f5a1b4d92"><span class="id" title="notation">+</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>.<br/> + <span class="id" title="keyword">Lemma</span> <a id="e" class="idref" href="#e"><span class="id" title="lemma">e</span></a> : <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#e03f39daf98516fa530d3f6f5a1b4d92"><span class="id" title="notation">+</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>.<br/> <span class="id" title="var">Admitted</span>.<br/> <br/> <span class="id" title="keyword">End</span> <a class="idref" href="Coqdoc.links.html#test"><span class="id" title="section">test</span></a>.<br/> <br/> - <span class="id" title="keyword">Section</span> <a name="test2"><span class="id" title="section">test2</span></a>.<br/> + <span class="id" title="keyword">Section</span> <a id="test2" class="idref" href="#test2"><span class="id" title="section">test2</span></a>.<br/> <br/> - <span class="id" title="keyword">Variables</span> <a name="test2.b'"><span class="id" title="variable">b'</span></a>: <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>.<br/> + <span class="id" title="keyword">Variables</span> <a id="test2.b'" class="idref" href="#test2.b'"><span class="id" title="variable">b'</span></a>: <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>.<br/> <br/> - <span class="id" title="keyword">Section</span> <a name="test2.test"><span class="id" title="section">test</span></a>.<br/> + <span class="id" title="keyword">Section</span> <a id="test2.test" class="idref" href="#test2.test"><span class="id" title="section">test</span></a>.<br/> <br/> - <span class="id" title="keyword">Variables</span> <a name="test2.test.b2"><span class="id" title="variable">b2</span></a>: <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>.<br/> + <span class="id" title="keyword">Variables</span> <a id="test2.test.b2" class="idref" href="#test2.test.b2"><span class="id" title="variable">b2</span></a>: <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>.<br/> <br/> - <span class="id" title="keyword">Definition</span> <a name="a''"><span class="id" title="definition">a''</span></a> <span class="id" title="var">b</span> := <a class="idref" href="Coqdoc.links.html#test2.b'"><span class="id" title="variable">b'</span></a> <a class="idref" href="Coqdoc.links.html#f03f7a04ef75ff3ac66ca5c23554e52e"><span class="id" title="notation">++</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#O"><span class="id" title="constructor">O</span></a> <a class="idref" href="Coqdoc.links.html#f03f7a04ef75ff3ac66ca5c23554e52e"><span class="id" title="notation">++</span></a> <a class="idref" href="Coqdoc.links.html#test2.test.b2"><span class="id" title="variable">b2</span></a> <a class="idref" href="Coqdoc.links.html#3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">_</span></a> <a class="idref" href="Coqdoc.links.html#3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">++</span></a> <a class="idref" href="Coqdoc.links.html#3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">x</span></a> <a class="idref" href="Coqdoc.links.html#b"><span class="id" title="variable">b</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#0dacc1786c5ba797d47dd85006231633"><span class="id" title="notation">+</span></a> <a class="idref" href="Coqdoc.links.html#h"><span class="id" title="abbreviation">h</span></a> 0.<br/> + <span class="id" title="keyword">Definition</span> <a id="a''" class="idref" href="#a''"><span class="id" title="definition">a''</span></a> <a id="b:12" class="idref" href="#b:12"><span class="id" title="binder">b</span></a> := <a class="idref" href="Coqdoc.links.html#test2.b'"><span class="id" title="variable">b'</span></a> <a class="idref" href="Coqdoc.links.html#f03f7a04ef75ff3ac66ca5c23554e52e"><span class="id" title="notation">++</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#O"><span class="id" title="constructor">O</span></a> <a class="idref" href="Coqdoc.links.html#f03f7a04ef75ff3ac66ca5c23554e52e"><span class="id" title="notation">++</span></a> <a class="idref" href="Coqdoc.links.html#test2.test.b2"><span class="id" title="variable">b2</span></a> <a class="idref" href="Coqdoc.links.html#3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">_</span></a> <a class="idref" href="Coqdoc.links.html#3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">++</span></a> <a class="idref" href="Coqdoc.links.html#3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">x</span></a> <a class="idref" href="Coqdoc.links.html#b:12"><span class="id" title="variable">b</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#0dacc1786c5ba797d47dd85006231633"><span class="id" title="notation">+</span></a> <a class="idref" href="Coqdoc.links.html#h"><span class="id" title="abbreviation">h</span></a> 0.<br/> <br/> <span class="id" title="keyword">End</span> <a class="idref" href="Coqdoc.links.html#test2.test"><span class="id" title="section">test</span></a>.<br/> diff --git a/test-suite/coqdoc/links.tex.out b/test-suite/coqdoc/links.tex.out index 24f96ff1e6..2304f5ecc1 100644 --- a/test-suite/coqdoc/links.tex.out +++ b/test-suite/coqdoc/links.tex.out @@ -45,10 +45,10 @@ Various checks for coqdoc \coqdockw{Definition} \coqdef{Coqdoc.links.g}{g}{\coqdocdefinition{g}} := "dfjkh""sdfhj forall <> * \~{}"\%\coqdocvar{string}.\coqdoceol \coqdocemptyline \coqdocnoindent -\coqdockw{Definition} \coqdef{Coqdoc.links.a}{a}{\coqdocdefinition{a}} (\coqdocvar{b}: \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}}) := \coqdocvariable{b}.\coqdoceol +\coqdockw{Definition} \coqdef{Coqdoc.links.a}{a}{\coqdocdefinition{a}} (\coqdef{Coqdoc.links.b:1}{b}{\coqdocbinder{b}}: \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}}) := \coqref{Coqdoc.links.b:1}{\coqdocvariable{b}}.\coqdoceol \coqdocemptyline \coqdocnoindent -\coqdockw{Definition} \coqdef{Coqdoc.links.f}{f}{\coqdocdefinition{f}} := \coqdockw{\ensuremath{\forall}} \coqdocvar{C}:\coqdockw{Prop}, \coqdocvariable{C}.\coqdoceol +\coqdockw{Definition} \coqdef{Coqdoc.links.f}{f}{\coqdocdefinition{f}} := \coqdockw{\ensuremath{\forall}} \coqdef{Coqdoc.links.C:2}{C}{\coqdocbinder{C}}:\coqdockw{Prop}, \coqref{Coqdoc.links.C:2}{\coqdocvariable{C}}.\coqdoceol \coqdocemptyline \coqdocnoindent \coqdockw{Notation} \coqdef{Coqdoc.links.:::x '++' x}{"}{"}n ++ m" := (\coqexternalref{plus}{http://coq.inria.fr/stdlib/Coq.Init.Peano}{\coqdocabbreviation{plus}} \coqdocvar{n} \coqdocvar{m}).\coqdoceol @@ -65,11 +65,11 @@ Various checks for coqdoc \coqdockw{Notation} \coqdef{Coqdoc.links.:::x ''' ''' '++' 'x' x}{"}{"}n '\_' ++ 'x' m" := (\coqexternalref{plus}{http://coq.inria.fr/stdlib/Coq.Init.Peano}{\coqdocabbreviation{plus}} \coqdocvar{n} \coqdocvar{m}) (\coqdoctac{at} \coqdockw{level} 3).\coqdoceol \coqdocemptyline \coqdocnoindent -\coqdockw{Inductive} \coqdef{Coqdoc.links.eq}{eq}{\coqdocinductive{eq}} (\coqdocvar{A}:\coqdockw{Type}) (\coqdocvar{x}:\coqdocvariable{A}) : \coqdocvar{A} \coqexternalref{::type scope:x '->' x}{http://coq.inria.fr/stdlib/Coq.Init.Logic}{\coqdocnotation{\ensuremath{\rightarrow}}} \coqdockw{Prop} := \coqdef{Coqdoc.links.eq refl}{eq\_refl}{\coqdocconstructor{eq\_refl}} : \coqdocvariable{x} \coqref{Coqdoc.links.::type scope:x '=' x ':>' x}{\coqdocnotation{=}} \coqdocvariable{x} \coqref{Coqdoc.links.::type scope:x '=' x ':>' x}{\coqdocnotation{:>}}\coqdocvariable{A}\coqdoceol +\coqdockw{Inductive} \coqdef{Coqdoc.links.eq}{eq}{\coqdocinductive{eq}} (\coqdef{Coqdoc.links.A:3}{A}{\coqdocbinder{A}}:\coqdockw{Type}) (\coqdef{Coqdoc.links.x:4}{x}{\coqdocbinder{x}}:\coqref{Coqdoc.links.A:3}{\coqdocvariable{A}}) : \coqdocvar{A} \coqexternalref{::type scope:x '->' x}{http://coq.inria.fr/stdlib/Coq.Init.Logic}{\coqdocnotation{\ensuremath{\rightarrow}}} \coqdockw{Prop} := \coqdef{Coqdoc.links.eq refl}{eq\_refl}{\coqdocconstructor{eq\_refl}} : \coqref{Coqdoc.links.x:4}{\coqdocvariable{x}} \coqref{Coqdoc.links.::type scope:x '=' x ':>' x}{\coqdocnotation{=}} \coqref{Coqdoc.links.x:4}{\coqdocvariable{x}} \coqref{Coqdoc.links.::type scope:x '=' x ':>' x}{\coqdocnotation{:>}}\coqref{Coqdoc.links.A:3}{\coqdocvariable{A}}\coqdoceol \coqdocnoindent \coqdoceol \coqdocnoindent -\coqdockw{where} \coqdef{Coqdoc.links.::type scope:x '=' x ':>' x}{"}{"}x = y :> A" := (@\coqref{Coqdoc.links.eq}{\coqdocinductive{eq}} \coqdocvar{A} \coqdocvar{x} \coqdocvar{y}) : \coqdocvar{type\_scope}.\coqdoceol +\coqdockw{where} \coqdef{Coqdoc.links.::type scope:x '=' x ':>' x}{"}{"}x = y :> A" := (@\coqref{Coqdoc.links.eq:6}{\coqdocinductive{eq}} \coqdocvar{A} \coqdocvar{x} \coqdocvar{y}) : \coqdocvar{type\_scope}.\coqdoceol \coqdocemptyline \coqdocnoindent \coqdockw{Definition} \coqdef{Coqdoc.links.eq0}{eq0}{\coqdocdefinition{eq0}} := 0 \coqref{Coqdoc.links.::type scope:x '=' x ':>' x}{\coqdocnotation{=}} 0 \coqref{Coqdoc.links.::type scope:x '=' x ':>' x}{\coqdocnotation{:>}} \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}}.\coqdoceol @@ -102,7 +102,7 @@ Various checks for coqdoc \coqdockw{Definition} \coqdef{Coqdoc.links.xCExB1}{α}{\coqdocdefinition{α}} := (0 \coqref{Coqdoc.links.test.::my scope:x '+' x}{\coqdocnotation{+}} \coqref{Coqdoc.links.l}{\coqdocabbreviation{l}})\%\coqdocvar{my}.\coqdoceol \coqdocemptyline \coqdocindent{2.00em} -\coqdockw{Definition} \coqdef{Coqdoc.links.a'}{a'}{\coqdocdefinition{a'}} \coqdocvar{b} := \coqdocvariable{b'}\coqref{Coqdoc.links.:::x '++' x}{\coqdocnotation{++}}0\coqref{Coqdoc.links.:::x '++' x}{\coqdocnotation{++}}\coqdocvariable{b2} \coqref{Coqdoc.links.:::x ''' ''' '++' 'x' x}{\coqdocnotation{\_}} \coqref{Coqdoc.links.:::x ''' ''' '++' 'x' x}{\coqdocnotation{++}}\coqref{Coqdoc.links.:::x ''' ''' '++' 'x' x}{\coqdocnotation{x}} \coqdocvariable{b}.\coqdoceol +\coqdockw{Definition} \coqdef{Coqdoc.links.a'}{a'}{\coqdocdefinition{a'}} \coqdef{Coqdoc.links.b:9}{b}{\coqdocbinder{b}} := \coqref{Coqdoc.links.test.b'}{\coqdocvariable{b'}}\coqref{Coqdoc.links.:::x '++' x}{\coqdocnotation{++}}0\coqref{Coqdoc.links.:::x '++' x}{\coqdocnotation{++}}\coqref{Coqdoc.links.test.b2}{\coqdocvariable{b2}} \coqref{Coqdoc.links.:::x ''' ''' '++' 'x' x}{\coqdocnotation{\_}} \coqref{Coqdoc.links.:::x ''' ''' '++' 'x' x}{\coqdocnotation{++}}\coqref{Coqdoc.links.:::x ''' ''' '++' 'x' x}{\coqdocnotation{x}} \coqref{Coqdoc.links.b:9}{\coqdocvariable{b}}.\coqdoceol \coqdocemptyline \coqdocindent{2.00em} \coqdockw{Definition} \coqdef{Coqdoc.links.c}{c}{\coqdocdefinition{c}} := \coqexternalref{::type scope:'x7B' x 'x7D' '+' 'x7B' x 'x7D'}{http://coq.inria.fr/stdlib/Coq.Init.Specif}{\coqdocnotation{\{}}\coqexternalref{True}{http://coq.inria.fr/stdlib/Coq.Init.Logic}{\coqdocinductive{True}}\coqexternalref{::type scope:'x7B' x 'x7D' '+' 'x7B' x 'x7D'}{http://coq.inria.fr/stdlib/Coq.Init.Specif}{\coqdocnotation{\}+\{}}\coqexternalref{True}{http://coq.inria.fr/stdlib/Coq.Init.Logic}{\coqdocinductive{True}}\coqexternalref{::type scope:'x7B' x 'x7D' '+' 'x7B' x 'x7D'}{http://coq.inria.fr/stdlib/Coq.Init.Specif}{\coqdocnotation{\}}}.\coqdoceol @@ -131,7 +131,7 @@ Various checks for coqdoc \coqdockw{Variables} \coqdef{Coqdoc.links.test2.test.b2}{b2}{\coqdocvariable{b2}}: \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}}.\coqdoceol \coqdocemptyline \coqdocindent{3.00em} -\coqdockw{Definition} \coqdef{Coqdoc.links.a''}{a'{}'}{\coqdocdefinition{a'{}'}} \coqdocvar{b} := \coqdocvariable{b'} \coqref{Coqdoc.links.:::x '++' x}{\coqdocnotation{++}} \coqexternalref{O}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocconstructor{O}} \coqref{Coqdoc.links.:::x '++' x}{\coqdocnotation{++}} \coqdocvariable{b2} \coqref{Coqdoc.links.:::x ''' ''' '++' 'x' x}{\coqdocnotation{\_}} \coqref{Coqdoc.links.:::x ''' ''' '++' 'x' x}{\coqdocnotation{++}} \coqref{Coqdoc.links.:::x ''' ''' '++' 'x' x}{\coqdocnotation{x}} \coqdocvariable{b} \coqexternalref{::nat scope:x '+' x}{http://coq.inria.fr/stdlib/Coq.Init.Peano}{\coqdocnotation{+}} \coqref{Coqdoc.links.h}{\coqdocabbreviation{h}} 0.\coqdoceol +\coqdockw{Definition} \coqdef{Coqdoc.links.a''}{a'{}'}{\coqdocdefinition{a'{}'}} \coqdef{Coqdoc.links.b:12}{b}{\coqdocbinder{b}} := \coqref{Coqdoc.links.test2.b'}{\coqdocvariable{b'}} \coqref{Coqdoc.links.:::x '++' x}{\coqdocnotation{++}} \coqexternalref{O}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocconstructor{O}} \coqref{Coqdoc.links.:::x '++' x}{\coqdocnotation{++}} \coqref{Coqdoc.links.test2.test.b2}{\coqdocvariable{b2}} \coqref{Coqdoc.links.:::x ''' ''' '++' 'x' x}{\coqdocnotation{\_}} \coqref{Coqdoc.links.:::x ''' ''' '++' 'x' x}{\coqdocnotation{++}} \coqref{Coqdoc.links.:::x ''' ''' '++' 'x' x}{\coqdocnotation{x}} \coqref{Coqdoc.links.b:12}{\coqdocvariable{b}} \coqexternalref{::nat scope:x '+' x}{http://coq.inria.fr/stdlib/Coq.Init.Peano}{\coqdocnotation{+}} \coqref{Coqdoc.links.h}{\coqdocabbreviation{h}} 0.\coqdoceol \coqdocemptyline \coqdocindent{2.00em} \coqdockw{End} \coqref{Coqdoc.links.test2.test}{\coqdocsection{test}}.\coqdoceol diff --git a/test-suite/micromega/bug_12210.v b/test-suite/micromega/bug_12210.v new file mode 100644 index 0000000000..ca011def09 --- /dev/null +++ b/test-suite/micromega/bug_12210.v @@ -0,0 +1,19 @@ +Require Import PeanoNat Lia. + +Goal forall x, Nat.le x x. +Proof. +intros. +lia. +Qed. + +Goal forall x, Nat.lt x x -> False. +Proof. +intros. +lia. +Qed. + +Goal forall x, Nat.eq x x. +Proof. +intros. +lia. +Qed. diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out index abc7f0f88e..e0aa758812 100644 --- a/test-suite/output/Arguments_renaming.out +++ b/test-suite/output/Arguments_renaming.out @@ -2,9 +2,9 @@ The command has indeed failed with message: Flag "rename" expected to rename A into B. File "stdin", line 3, characters 0-25: Warning: This command is just asserting the names of arguments of identity. -If this is what you want add ': assert' to silence the warning. If you want -to clear implicit arguments add ': clear implicits'. If you want to clear -notation scopes add ': clear scopes' [arguments-assert,vernacular] +If this is what you want, add ': assert' to silence the warning. If you want +to clear implicit arguments, add ': clear implicits'. If you want to clear +notation scopes, add ': clear scopes' [arguments-assert,vernacular] @eq_refl : forall (B : Type) (y : B), y = y eq_refl diff --git a/test-suite/output/BadOptionValueType.out b/test-suite/output/BadOptionValueType.out index 34d8518a75..7388982e7f 100644 --- a/test-suite/output/BadOptionValueType.out +++ b/test-suite/output/BadOptionValueType.out @@ -1,8 +1,14 @@ The command has indeed failed with message: Bad type of value for this option: expected int, got string. The command has indeed failed with message: -Bad type of value for this option: expected bool, got string. +This is an option. A value must be provided. The command has indeed failed with message: -Bad type of value for this option: expected bool, got int. +Bad type of value for this option: expected string, got int. The command has indeed failed with message: -Bad type of value for this option: expected bool, got int. +This is an option. A value must be provided. +The command has indeed failed with message: +This is a flag. It does not take a value. +The command has indeed failed with message: +This is a flag. It does not take a value. +The command has indeed failed with message: +This option does not support the "Unset" command. diff --git a/test-suite/output/BadOptionValueType.v b/test-suite/output/BadOptionValueType.v index b61c3757ba..12ca7bae21 100644 --- a/test-suite/output/BadOptionValueType.v +++ b/test-suite/output/BadOptionValueType.v @@ -1,4 +1,7 @@ Fail Set Default Timeout "2". +Fail Set Default Timeout. +Fail Set Bullet Behavior 2. +Fail Set Bullet Behavior. Fail Set Debug Eauto "yes". Fail Set Debug Eauto 1. -Fail Set Implicit Arguments 1. +Fail Unset Warnings. diff --git a/test-suite/output/Inductive.out b/test-suite/output/Inductive.out index ff2556c5dc..e6c2806433 100644 --- a/test-suite/output/Inductive.out +++ b/test-suite/output/Inductive.out @@ -1,6 +1,10 @@ The command has indeed failed with message: -Last occurrence of "list'" must have "A" as 1st argument in - "A -> list' A -> list' (A * A)%type". +In environment +list' : Set -> Set +A : Set +a : A +l : list' A +Unable to unify "list' (A * A)%type" with "list' A". Inductive foo (A : Type) (x : A) (y : A := x) : Prop := Foo : foo A x Arguments foo _%type_scope diff --git a/test-suite/output/Notations4.out b/test-suite/output/Notations4.out index e121b5e86c..f48eaac4c9 100644 --- a/test-suite/output/Notations4.out +++ b/test-suite/output/Notations4.out @@ -14,6 +14,10 @@ Entry constr:myconstr is : nat [<< # 0 >>] : option nat +[b + c] + : nat +fun a : nat => [a + a] + : nat -> nat [1 {f 1}] : Expr fun (x : nat) (y z : Expr) => [1 + y z + {f x}] @@ -81,18 +85,18 @@ fun x : nat => [x] : nat -> nat ∀ x : nat, x = x : Prop -File "stdin", line 219, characters 0-160: +File "stdin", line 226, characters 0-160: Warning: Notation "∀ _ .. _ , _" was already defined with a different format in scope type_scope. [notation-incompatible-format,parsing] ∀x : nat,x = x : Prop -File "stdin", line 232, characters 0-60: +File "stdin", line 239, characters 0-60: Warning: Notation "_ %%% _" was already defined with a different format. [notation-incompatible-format,parsing] -File "stdin", line 236, characters 0-64: +File "stdin", line 243, characters 0-64: Warning: Notation "_ %%% _" was already defined with a different format. [notation-incompatible-format,parsing] -File "stdin", line 241, characters 0-62: +File "stdin", line 248, characters 0-62: Warning: Lonely notation "_ %%%% _" was already defined with a different format. [notation-incompatible-format,parsing] 3 %% 4 @@ -101,9 +105,9 @@ format. [notation-incompatible-format,parsing] : nat 3 %% 4 : nat -File "stdin", line 269, characters 0-61: +File "stdin", line 276, characters 0-61: Warning: The format modifier is irrelevant for only parsing rules. [irrelevant-format-only-parsing,parsing] -File "stdin", line 273, characters 0-63: +File "stdin", line 280, characters 0-63: Warning: The only parsing modifier has no effect in Reserved Notation. [irrelevant-reserved-notation-only-parsing,parsing] diff --git a/test-suite/output/Notations4.v b/test-suite/output/Notations4.v index 1cf0d919b1..4d4b37a8b2 100644 --- a/test-suite/output/Notations4.v +++ b/test-suite/output/Notations4.v @@ -22,6 +22,13 @@ Notation "<< x >>" := x (in custom myconstr at level 3, x custom anotherconstr a Notation "# x" := (Some x) (in custom anotherconstr at level 8, x constr at level 9). Check [ << # 0 >> ]. +(* Now check with global *) + +Axiom c : nat. +Notation "x" := x (in custom myconstr at level 0, x global). +Check [ b + c ]. +Check fun a => [ a + a ]. + End A. Module B. diff --git a/test-suite/output/NotationsSigma.out b/test-suite/output/NotationsSigma.out new file mode 100644 index 0000000000..0e4df87148 --- /dev/null +++ b/test-suite/output/NotationsSigma.out @@ -0,0 +1,40 @@ +{0 = 0} + {0 < 1} + : Set +(0 = 0) + {0 < 1} + : Set +{x : nat | x = 1} + : Set +{x : nat | x = 1 & 0 < x} + : Set +{x : nat | x = 1} + : Set +{x : nat | x = 1 & 0 < x} + : Set +{x : nat & x = 1} + : Set +{x : nat & x = 1 & 0 < x} + : Set +{x : nat & x = 1} + : Set +{x : nat & x = 1 & 0 < x} + : Set +{'(x, _) : nat * ?T | x = 1} + : Type +where +?T : [pat : nat * ?T |- Type] (pat cannot be used) +{'(x, y) : nat * nat | x = 1 & y = 0} + : Set +{'(x, _) : nat * nat | x = 1} + : Set +{'(x, y) : nat * nat | x = 1 & y = 0} + : Set +{'(x, _) : nat * ?T & x = 1} + : Type +where +?T : [pat : nat * ?T |- Type] (pat cannot be used) +{'(x, y) : nat * nat & x = 1 & y = 0} + : Type +{'(x, _) : nat * nat & x = 1} + : Type +{'(x, y) : nat * nat & x = 1 & y = 0} + : Type diff --git a/test-suite/output/NotationsSigma.v b/test-suite/output/NotationsSigma.v new file mode 100644 index 0000000000..6780d63a04 --- /dev/null +++ b/test-suite/output/NotationsSigma.v @@ -0,0 +1,22 @@ +(* Check notations for sigma types *) + +Check { 0 = 0 } + { 0 < 1 }. +Check (0 = 0) + { 0 < 1 }. + +Check { x | x = 1 }. +Check { x | x = 1 & 0 < x }. +Check { x : nat | x = 1 }. +Check { x : nat | x = 1 & 0 < x }. +Check { x & x = 1 }. +Check { x & x = 1 & 0 < x }. +Check { x : nat & x = 1 }. +Check { x : nat & x = 1 & 0 < x }. + +Check {'(x,y) | x = 1 }. +Check {'(x,y) | x = 1 & y = 0 }. +Check {'(x,y) : nat * nat | x = 1 }. +Check {'(x,y) : nat * nat | x = 1 & y = 0 }. +Check {'(x,y) & x = 1 }. +Check {'(x,y) & x = 1 & y = 0 }. +Check {'(x,y) : nat * nat & x = 1 }. +Check {'(x,y) : nat * nat & x = 1 & y = 0 }. diff --git a/test-suite/output/PatternsInBinders.out b/test-suite/output/PatternsInBinders.out index 4f09f00c56..bdfa8afb6a 100644 --- a/test-suite/output/PatternsInBinders.out +++ b/test-suite/output/PatternsInBinders.out @@ -4,7 +4,7 @@ fun '(x, y) => (y, x) : A * B -> B * A forall '(x, y), swap (x, y) = (y, x) : Prop -proj_informative = fun '(exist _ x _) => x : A +proj_informative = fun '(exist _ x _) => x : {x : A | P x} -> A foo = fun '(Bar n b tt p) => if b then n + p else n - p : Foo -> nat @@ -29,8 +29,7 @@ exists '(x, y) '(z, w), swap (x, y) = (z, w) ∀ '(x, y), swap (x, y) = (y, x) : Prop both_z = -fun pat : nat * nat => -let '(n, p) as x := pat return (F x) in (Z n, Z p) : F (n, p) +fun pat : nat * nat => let '(n, p) as x := pat return (F x) in (Z n, Z p) : forall pat : nat * nat, F pat fun '(x, y) '(z, t) => swap (x, y) = (z, t) : A * B -> B * A -> Prop diff --git a/test-suite/output/Projections.out b/test-suite/output/Projections.out index e9c28faf1d..1dd89c9bcd 100644 --- a/test-suite/output/Projections.out +++ b/test-suite/output/Projections.out @@ -1,2 +1,17 @@ fun S : store => S.(store_funcs) : store -> host_func +a = +fun A : Type => +let B := A in fun (C : Type) (u : U A C) => (A, B, C, c _ _ u) + : forall A : Type, + let B := A in + forall C : Type, U A C -> Type * Type * Type * (B * A * C) + +Arguments a (_ _)%type_scope +b = +fun A : Type => let B := A in fun (C : Type) (u : U A C) => b _ _ u + : forall A : Type, + let B := A in + forall (C : Type) (u : U A C), (A, B, C, c _ _ u) = (A, B, C, c _ _ u) + +Arguments b (_ _)%type_scope diff --git a/test-suite/output/Projections.v b/test-suite/output/Projections.v index 14d63d39c4..83a581338f 100644 --- a/test-suite/output/Projections.v +++ b/test-suite/output/Projections.v @@ -10,3 +10,12 @@ Section store. End store. Check (fun (S:@store nat) => S.(store_funcs)). + +Module LocalDefUnfolding. + +Unset Printing Projections. +Record U A (B:=A) C := {c:B*A*C;a:=(A,B,C,c);b:a=a}. +Print a. +Print b. + +End LocalDefUnfolding. diff --git a/test-suite/output/Search.out b/test-suite/output/Search.out index 9d8e830d64..593d0c7f67 100644 --- a/test-suite/output/Search.out +++ b/test-suite/output/Search.out @@ -136,7 +136,7 @@ h': newdef n <> n (use "About" for full details on implicit arguments) (use "About" for full details on implicit arguments) The command has indeed failed with message: -No such goal. +[Focus] No such goal. The command has indeed failed with message: Query commands only support the single numbered goal selector. The command has indeed failed with message: diff --git a/test-suite/output/UselessSyndef.out b/test-suite/output/UselessSyndef.out new file mode 100644 index 0000000000..ce484889b3 --- /dev/null +++ b/test-suite/output/UselessSyndef.out @@ -0,0 +1,2 @@ +a + : nat diff --git a/test-suite/output/UselessSyndef.v b/test-suite/output/UselessSyndef.v new file mode 100644 index 0000000000..96ad6e9f5c --- /dev/null +++ b/test-suite/output/UselessSyndef.v @@ -0,0 +1,10 @@ +Module M. + Definition a := 0. +End M. +Module N. + Notation a := M.a (only parsing). +End N. + +Import M. Import N. + +Check a. diff --git a/test-suite/output/bug_11934.out b/test-suite/output/bug_11934.out new file mode 100644 index 0000000000..072136c82e --- /dev/null +++ b/test-suite/output/bug_11934.out @@ -0,0 +1,13 @@ +thing = forall x y : foo, bla x y + : Prop +thing = +forall (x : foo@{thing.u0}) (y : foo@{thing.u1}), bla x y + : Prop +(* {thing.u1 thing.u0} |= bla.u0 = thing.u0 + bla.u1 = thing.u1 *) +thing = +forall (x : @foo@{thing.u0} True) (y : @foo@{thing.u1} True), +@bla True True x y + : Prop +(* {thing.u1 thing.u0} |= bla.u0 = thing.u0 + bla.u1 = thing.u1 *) diff --git a/test-suite/output/bug_11934.v b/test-suite/output/bug_11934.v new file mode 100644 index 0000000000..fe9772dc62 --- /dev/null +++ b/test-suite/output/bug_11934.v @@ -0,0 +1,13 @@ +Polymorphic Axiom foo@{u} : Prop -> Prop. +Arguments foo {_}. + +Axiom bla : forall {A B}, @foo A -> @foo B -> Prop. +Definition thing := forall (x:@foo@{Type} True) (y:@foo@{Type} True), bla x y. + +Print thing. (* forall x y : foo, bla x y *) + +Set Printing Universes. +Print thing. (* forall (x : foo@{thing.u0}) (y : foo@{thing.u1}), bla x y *) + +Set Printing Implicit. +Print thing. (* BAD: forall x y : @foo@{thing.u0} True, @bla True True x y *) diff --git a/test-suite/output/undeclared_key.out b/test-suite/output/undeclared_key.out new file mode 100644 index 0000000000..ed768751fc --- /dev/null +++ b/test-suite/output/undeclared_key.out @@ -0,0 +1,13 @@ +The command has indeed failed with message: +There is no flag, option or table with this name: "Search Blacklists". +The command has indeed failed with message: +There is no qualid-valued table with this name: "Search Blacklist". +File "stdin", line 3, characters 0-22: +Warning: There is no flag or option with this name: "Search Blacklists". +[unknown-option,option] +The command has indeed failed with message: +There is no string-valued table with this name: "Search Blacklists". +The command has indeed failed with message: +There is no qualid-valued table with this name: "Search Blacklist". +The command has indeed failed with message: +There is no qualid-valued table with this name: "Search Blacklist". diff --git a/test-suite/output/undeclared_key.v b/test-suite/output/undeclared_key.v new file mode 100644 index 0000000000..4134bc8bfa --- /dev/null +++ b/test-suite/output/undeclared_key.v @@ -0,0 +1,6 @@ +Fail Test Search Blacklists. +Fail Test Search Blacklist for foo. +Set Search Blacklists. +Fail Remove Search Blacklists "bar" foo. +Fail Remove Search Blacklist "bar" foo. +Fail Add Search Blacklist "bar" foo. diff --git a/test-suite/success/ConversionOrder.v b/test-suite/success/ConversionOrder.v new file mode 100644 index 0000000000..1e0b4dbf23 --- /dev/null +++ b/test-suite/success/ConversionOrder.v @@ -0,0 +1,16 @@ +(* The kernel may convert application arguments right to left, + resulting in ill-typed terms, but should be robust to them. *) + +Inductive Hide := hide : forall A, A -> Hide. + +Lemma foo : (hide Type Type) = (hide (nat -> Type) (fun x : nat => Type)). +Proof. + Fail reflexivity. + match goal with |- ?l = _ => exact_no_check (eq_refl l) end. + Fail Defined. +Abort. + +Definition HideMore (_:Hide) := 0. + +Definition foo : HideMore (hide Type Type) = HideMore (hide (nat -> Type) (fun x : nat => Type)) + := eq_refl. diff --git a/test-suite/success/InductiveVsImplicitsVsTC.v b/test-suite/success/InductiveVsImplicitsVsTC.v new file mode 100644 index 0000000000..a98de32b70 --- /dev/null +++ b/test-suite/success/InductiveVsImplicitsVsTC.v @@ -0,0 +1,26 @@ +Module NoConv. + Class C := {}. + + Definition useC {c:C} := nat. + + Inductive foo {a b : C} := CC : useC -> foo. + (* If TC search runs before parameter unification it will pick the + wrong instance for the first parameter. + + useC makes sure we don't completely skip TC search. + *) +End NoConv. + +Module ForConv. + + Class Bla := { bla : Type }. + + Instance bli : Bla := { bla := nat }. + + Inductive vs := C : forall x : bla, x = 2 -> vs. + (* here we need to resolve TC to pass the conversion problem if we + combined with the previous example it would fail as TC resolution + for conversion is unrestricted and so would resolve the + conclusion too early. *) + +End ForConv. diff --git a/test-suite/success/PartialImport.v b/test-suite/success/PartialImport.v new file mode 100644 index 0000000000..720083aec5 --- /dev/null +++ b/test-suite/success/PartialImport.v @@ -0,0 +1,58 @@ +Module M. + + Definition a := 0. + Definition b := 1. + + Module N. + + Notation c := (a + b). + + End N. + + Inductive even : nat -> Prop := + | even_0 : even 0 + | even_S n : odd n -> even (S n) + with odd : nat -> Set := + odd_S n : even n -> odd (S n). + +End M. + +Module Simple. + + Import M(a). + + Check a. + Fail Check b. + Fail Check N.c. + + (* todo output test: this prints a+M.b since the notation isn't imported *) + Check M.N.c. + + Fail Import M(c). + Fail Import M(M.b). + + Import M(N.c). + Check N.c. + (* interestingly prints N.c (also does with unfiltered Import M) *) + + Import M(even(..)). + Check even. Check even_0. Check even_S. + Check even_sind. Check even_ind. + Fail Check even_rect. (* doesn't exist *) + Fail Check odd. Check M.odd. + Fail Check odd_S. Fail Check odd_sind. + +End Simple. + +Module WithExport. + + Module X. + Export M(a, N.c). + End X. + + Import X. + Check a. + Check N.c. (* also prints N.c *) + Fail Check b. + +End WithExport. diff --git a/test-suite/success/Scheme.v b/test-suite/success/Scheme.v index 4b928007cf..273cb48295 100644 --- a/test-suite/success/Scheme.v +++ b/test-suite/success/Scheme.v @@ -18,7 +18,7 @@ Check myeq_rew. Check myeq_rew_dep. Check myeq_rew_fwd_dep. Check myeq_rew_r. -Check internal_myeq_sym_involutive. +Check myeq_sym_involutive. Check myeq_rew_r_dep. Check myeq_rew_fwd_r_dep. diff --git a/test-suite/success/let_universes.v b/test-suite/success/let_universes.v new file mode 100644 index 0000000000..c780ec010f --- /dev/null +++ b/test-suite/success/let_universes.v @@ -0,0 +1,5 @@ +Section S. +Let bla@{} := Prop. +Let bli@{u} := Type@{u}. +Fail Let blo@{} := Type. +End S. diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v index 82055c4752..f78c0ecc1e 100644 --- a/theories/FSets/FMapAVL.v +++ b/theories/FSets/FMapAVL.v @@ -550,14 +550,14 @@ Ltac intuition_in := repeat (intuition; inv In; inv MapsTo). Let's do its job by hand: *) Ltac join_tac := - intros l; induction l as [| ll _ lx ld lr Hlr lh]; - [ | intros x d r; induction r as [| rl Hrl rx rd rr _ rh]; unfold join; - [ | destruct (gt_le_dec lh (rh+2)) as [GT|LE]; + intros ?l; induction l as [| ?ll _ ?lx ?ld ?lr ?Hlr ?lh]; + [ | intros ?x ?d ?r; induction r as [| ?rl ?Hrl ?rx ?rd ?rr _ ?rh]; unfold join; + [ | destruct (gt_le_dec lh (rh+2)) as [?GT|?LE]; [ match goal with |- context [ bal ?u ?v ?w ?z ] => replace (bal u v w z) with (bal ll lx ld (join lr x d (Node rl rx rd rr rh))); [ | auto] end - | destruct (gt_le_dec rh (lh+2)) as [GT'|LE']; + | destruct (gt_le_dec rh (lh+2)) as [?GT'|?LE']; [ match goal with |- context [ bal ?u ?v ?w ?z ] => replace (bal u v w z) with (bal (join (Node ll lx ld lr lh) x d rl) rx rd rr); [ | auto] diff --git a/theories/Init/Byte.v b/theories/Init/Byte.v index 33eabb20d9..7449b52d76 100644 --- a/theories/Init/Byte.v +++ b/theories/Init/Byte.v @@ -10,6 +10,7 @@ (** * Bytes *) +Require Import Coq.Init.Ltac. Require Import Coq.Init.Datatypes. Require Import Coq.Init.Logic. Require Import Coq.Init.Specif. diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index 50d4314a6b..0f2717beef 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -11,6 +11,7 @@ Set Implicit Arguments. Require Import Notations. +Require Import Ltac. Require Import Logic. (********************************************************************) diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index ae48febc49..8f9f68a292 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -11,6 +11,7 @@ Set Implicit Arguments. Require Export Notations. +Require Import Ltac. Notation "A -> B" := (forall (_ : A), B) : type_scope. diff --git a/theories/Init/Logic_Type.v b/theories/Init/Logic_Type.v index d07fe68715..3d9937ae89 100644 --- a/theories/Init/Logic_Type.v +++ b/theories/Init/Logic_Type.v @@ -13,6 +13,7 @@ Set Implicit Arguments. +Require Import Ltac. Require Import Datatypes. Require Export Logic. diff --git a/theories/Init/Ltac.v b/theories/Init/Ltac.v new file mode 100644 index 0000000000..ac5a69a38a --- /dev/null +++ b/theories/Init/Ltac.v @@ -0,0 +1,13 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \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) *) +(************************************************************************) + +Declare ML Module "ltac_plugin". + +Export Set Default Proof Mode "Classic". diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v index fdb88a0c82..da540cb099 100644 --- a/theories/Init/Notations.v +++ b/theories/Init/Notations.v @@ -68,33 +68,40 @@ Reserved Notation "{ x }" (at level 0, x at level 99). (** Notations for sigma-types or subsets *) -Reserved Notation "{ A } + { B }" (at level 50, left associativity). -Reserved Notation "A + { B }" (at level 50, left associativity). +Reserved Notation "{ A } + { B }" (at level 50, left associativity). +Reserved Notation "A + { B }" (at level 50, left associativity). -Reserved Notation "{ x | P }" (at level 0, x at level 99). -Reserved Notation "{ x | P & Q }" (at level 0, x at level 99). +Reserved Notation "{ x | P }" (at level 0, x at level 99). +Reserved Notation "{ x | P & Q }" (at level 0, x at level 99). -Reserved Notation "{ x : A | P }" (at level 0, x at level 99). -Reserved Notation "{ x : A | P & Q }" (at level 0, x at level 99). +Reserved Notation "{ x : A | P }" (at level 0, x at level 99). +Reserved Notation "{ x : A | P & Q }" (at level 0, x at level 99). -Reserved Notation "{ x & P }" (at level 0, x at level 99). -Reserved Notation "{ x : A & P }" (at level 0, x at level 99). -Reserved Notation "{ x : A & P & Q }" (at level 0, x at level 99). +Reserved Notation "{ x & P }" (at level 0, x at level 99). +Reserved Notation "{ x & P & Q }" (at level 0, x at level 99). + +Reserved Notation "{ x : A & P }" (at level 0, x at level 99). +Reserved Notation "{ x : A & P & Q }" (at level 0, x at level 99). Reserved Notation "{ ' pat | P }" - (at level 0, pat strict pattern, format "{ ' pat | P }"). + (at level 0, pat strict pattern, format "{ ' pat | P }"). Reserved Notation "{ ' pat | P & Q }" - (at level 0, pat strict pattern, format "{ ' pat | P & Q }"). + (at level 0, pat strict pattern, format "{ ' pat | P & Q }"). Reserved Notation "{ ' pat : A | P }" (at level 0, pat strict pattern, format "{ ' pat : A | P }"). Reserved Notation "{ ' pat : A | P & Q }" - (at level 0, pat strict pattern, format "{ ' pat : A | P & Q }"). + (at level 0, pat strict pattern, format "{ ' pat : A | P & Q }"). + +Reserved Notation "{ ' pat & P }" + (at level 0, pat strict pattern, format "{ ' pat & P }"). +Reserved Notation "{ ' pat & P & Q }" + (at level 0, pat strict pattern, format "{ ' pat & P & Q }"). Reserved Notation "{ ' pat : A & P }" - (at level 0, pat strict pattern, format "{ ' pat : A & P }"). + (at level 0, pat strict pattern, format "{ ' pat : A & P }"). Reserved Notation "{ ' pat : A & P & Q }" - (at level 0, pat strict pattern, format "{ ' pat : A & P & Q }"). + (at level 0, pat strict pattern, format "{ ' pat : A & P & Q }"). (** Support for Gonthier-Ssreflect's "if c is pat then u else v" *) @@ -122,9 +129,3 @@ Bind Scope type_scope with Sortclass. Open Scope core_scope. Open Scope function_scope. Open Scope type_scope. - -(** ML Tactic Notations *) - -Declare ML Module "ltac_plugin". - -Global Set Default Proof Mode "Classic". diff --git a/theories/Init/Peano.v b/theories/Init/Peano.v index 394fa879c4..02903643d4 100644 --- a/theories/Init/Peano.v +++ b/theories/Init/Peano.v @@ -26,6 +26,7 @@ *) Require Import Notations. +Require Import Ltac. Require Import Datatypes. Require Import Logic. Require Coq.Init.Nat. diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v index 71ba3e645d..6a81517d7e 100644 --- a/theories/Init/Prelude.v +++ b/theories/Init/Prelude.v @@ -18,10 +18,11 @@ Require Coq.Init.Decimal. Require Coq.Init.Nat. Require Export Peano. Require Export Coq.Init.Wf. +Require Export Coq.Init.Ltac. Require Export Coq.Init.Tactics. Require Export Coq.Init.Tauto. (* Some initially available plugins. See also: - - ltac_plugin (in Notations) + - ltac_plugin (in Ltac) - tauto_plugin (in Tauto). *) Declare ML Module "cc_plugin". diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v index 692fe3d8d0..4ff007570e 100644 --- a/theories/Init/Specif.v +++ b/theories/Init/Specif.v @@ -14,6 +14,7 @@ Set Implicit Arguments. Set Reversible Pattern Implicit. Require Import Notations. +Require Import Ltac. Require Import Datatypes. Require Import Logic. @@ -58,23 +59,26 @@ Arguments sig2 (A P Q)%type. Arguments sigT (A P)%type. Arguments sigT2 (A P Q)%type. -Notation "{ x | P }" := (sig (fun x => P)) : type_scope. -Notation "{ x | P & Q }" := (sig2 (fun x => P) (fun x => Q)) : type_scope. -Notation "{ x : A | P }" := (sig (A:=A) (fun x => P)) : type_scope. -Notation "{ x : A | P & Q }" := (sig2 (A:=A) (fun x => P) (fun x => Q)) : +Notation "{ x | P }" := (sig (fun x => P)) : type_scope. +Notation "{ x | P & Q }" := (sig2 (fun x => P) (fun x => Q)) : type_scope. +Notation "{ x : A | P }" := (sig (A:=A) (fun x => P)) : type_scope. +Notation "{ x : A | P & Q }" := (sig2 (A:=A) (fun x => P) (fun x => Q)) : type_scope. -Notation "{ x & P }" := (sigT (fun x => P)) : type_scope. -Notation "{ x : A & P }" := (sigT (A:=A) (fun x => P)) : type_scope. -Notation "{ x : A & P & Q }" := (sigT2 (A:=A) (fun x => P) (fun x => Q)) : +Notation "{ x & P }" := (sigT (fun x => P)) : type_scope. +Notation "{ x & P & Q }" := (sigT2 (fun x => P) (fun x => Q)) : type_scope. +Notation "{ x : A & P }" := (sigT (A:=A) (fun x => P)) : type_scope. +Notation "{ x : A & P & Q }" := (sigT2 (A:=A) (fun x => P) (fun x => Q)) : type_scope. -Notation "{ ' pat | P }" := (sig (fun pat => P)) : type_scope. -Notation "{ ' pat | P & Q }" := (sig2 (fun pat => P) (fun pat => Q)) : type_scope. -Notation "{ ' pat : A | P }" := (sig (A:=A) (fun pat => P)) : type_scope. -Notation "{ ' pat : A | P & Q }" := (sig2 (A:=A) (fun pat => P) (fun pat => Q)) : +Notation "{ ' pat | P }" := (sig (fun pat => P)) : type_scope. +Notation "{ ' pat | P & Q }" := (sig2 (fun pat => P) (fun pat => Q)) : type_scope. +Notation "{ ' pat : A | P }" := (sig (A:=A) (fun pat => P)) : type_scope. +Notation "{ ' pat : A | P & Q }" := (sig2 (A:=A) (fun pat => P) (fun pat => Q)) : type_scope. -Notation "{ ' pat : A & P }" := (sigT (A:=A) (fun pat => P)) : type_scope. -Notation "{ ' pat : A & P & Q }" := (sigT2 (A:=A) (fun pat => P) (fun pat => Q)) : +Notation "{ ' pat & P }" := (sigT (fun pat => P)) : type_scope. +Notation "{ ' pat & P & Q }" := (sigT2 (fun pat => P) (fun pat => Q)) : type_scope. +Notation "{ ' pat : A & P }" := (sigT (A:=A) (fun pat => P)) : type_scope. +Notation "{ ' pat : A & P & Q }" := (sigT2 (A:=A) (fun pat => P) (fun pat => Q)) : type_scope. Add Printing Let sig. diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v index a4347bbe62..b13206db94 100644 --- a/theories/Init/Tactics.v +++ b/theories/Init/Tactics.v @@ -9,6 +9,7 @@ (************************************************************************) Require Import Notations. +Require Import Ltac. Require Import Logic. Require Import Specif. diff --git a/theories/Init/Tauto.v b/theories/Init/Tauto.v index 87b7a9a3be..2fc6f3cfa6 100644 --- a/theories/Init/Tauto.v +++ b/theories/Init/Tauto.v @@ -1,4 +1,17 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \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) *) +(************************************************************************) + +(** * The tauto and intuition tactics *) + Require Import Notations. +Require Import Ltac. Require Import Datatypes. Require Import Logic. diff --git a/theories/Init/Wf.v b/theories/Init/Wf.v index 06afd9bac0..a305626eb3 100644 --- a/theories/Init/Wf.v +++ b/theories/Init/Wf.v @@ -16,6 +16,7 @@ Set Implicit Arguments. Require Import Notations. +Require Import Ltac. Require Import Logic. Require Import Datatypes. diff --git a/theories/Lists/List.v b/theories/Lists/List.v index f050f11170..5d5f74db44 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -2559,6 +2559,33 @@ Section ReDun. * now apply incl_Add_inv with a l'. Qed. + Lemma NoDup_incl_NoDup (l l' : list A) : NoDup l -> + length l' <= length l -> incl l l' -> NoDup l'. + Proof. + revert l'; induction l; simpl; intros l' Hnd Hlen Hincl. + - now destruct l'; inversion Hlen. + - assert (In a l') as Ha by now apply Hincl; left. + apply in_split in Ha as [l1' [l2' ->]]. + inversion_clear Hnd as [|? ? Hnin Hnd']. + apply (NoDup_Add (Add_app a l1' l2')); split. + + apply IHl; auto. + * rewrite app_length. + rewrite app_length in Hlen; simpl in Hlen; rewrite Nat.add_succ_r in Hlen. + now apply Nat.succ_le_mono. + * apply incl_Add_inv with (u:= l1' ++ l2') in Hincl; auto. + apply Add_app. + + intros Hnin'. + assert (incl (a :: l) (l1' ++ l2')) as Hincl''. + { apply incl_tran with (l1' ++ a :: l2'); auto. + intros x Hin. + apply in_app_or in Hin as [Hin|[->|Hin]]; intuition. } + apply NoDup_incl_length in Hincl''; [ | now constructor ]. + apply (Nat.nle_succ_diag_l (length l1' + length l2')). + rewrite_all app_length. + simpl in Hlen; rewrite Nat.add_succ_r in Hlen. + now transitivity (S (length l)). + Qed. + End ReDun. (** NoDup and map *) diff --git a/theories/Logic/WKL.v b/theories/Logic/WKL.v index 478bc434ad..d9eea2f89d 100644 --- a/theories/Logic/WKL.v +++ b/theories/Logic/WKL.v @@ -25,7 +25,7 @@ Require Import WeakFan List. Import ListNotations. -Require Import Omega. +Require Import Arith. (** [is_path_from P n l] means that there exists a path of length [n] from [l] on which [P] does not hold *) diff --git a/theories/NArith/BinNat.v b/theories/NArith/BinNat.v index f0011fe147..d68c32b371 100644 --- a/theories/NArith/BinNat.v +++ b/theories/NArith/BinNat.v @@ -943,6 +943,64 @@ Proof. destruct p; simpl; trivial. Qed. +(** ** Properties of [iter] *) + +Lemma iter_swap_gen : forall A B (f:A -> B) (g:A -> A) (h:B -> B), + (forall a, f (g a) = h (f a)) -> forall n a, + f (iter n g a) = iter n h (f a). +Proof. + destruct n; simpl; intros; rewrite ?H; trivial. + now apply Pos.iter_swap_gen. +Qed. + +Theorem iter_swap : + forall n (A:Type) (f:A -> A) (x:A), + iter n f (f x) = f (iter n f x). +Proof. + intros. symmetry. now apply iter_swap_gen. +Qed. + +Theorem iter_succ : + forall n (A:Type) (f:A -> A) (x:A), + iter (succ n) f x = f (iter n f x). +Proof. + destruct n; intros; simpl; trivial. + now apply Pos.iter_succ. +Qed. + +Theorem iter_succ_r : + forall n (A:Type) (f:A -> A) (x:A), + iter (succ n) f x = iter n f (f x). +Proof. + intros; now rewrite iter_succ, iter_swap. +Qed. + +Theorem iter_add : + forall p q (A:Type) (f:A -> A) (x:A), + iter (p+q) f x = iter p f (iter q f x). +Proof. + induction p using peano_ind; intros; trivial. + now rewrite add_succ_l, !iter_succ, IHp. +Qed. + +Theorem iter_ind : + forall (A:Type) (f:A -> A) (a:A) (P:N -> A -> Prop), + P 0 a -> + (forall n a', P n a' -> P (succ n) (f a')) -> + forall n, P n (iter n f a). +Proof. + induction n using peano_ind; trivial. + rewrite iter_succ; auto. +Qed. + +Theorem iter_invariant : + forall (n:N) (A:Type) (f:A -> A) (Inv:A -> Prop), + (forall x:A, Inv x -> Inv (f x)) -> + forall x:A, Inv x -> Inv (iter n f x). +Proof. + intros; apply iter_ind with (P := fun _ => Inv); trivial. +Qed. + End N. Bind Scope N_scope with N.t N. diff --git a/theories/Numbers/Cyclic/Int63/Int63.v b/theories/Numbers/Cyclic/Int63/Int63.v index c4f738ac39..bacc4a7650 100644 --- a/theories/Numbers/Cyclic/Int63/Int63.v +++ b/theories/Numbers/Cyclic/Int63/Int63.v @@ -690,7 +690,7 @@ Proof. now intros h; rewrite (to_Z_inj _ 0 h). Qed. Lemma tail00_spec x : φ x = 0 -> φ (tail0 x) = φ digits. Proof. now intros h; rewrite (to_Z_inj _ 0 h). Qed. -Infix "≡" := (eqm wB) (at level 80) : int63_scope. +Infix "≡" := (eqm wB) (at level 70, no associativity) : int63_scope. Lemma eqm_mod x y : x mod wB ≡ y mod wB → x ≡ y. Proof. diff --git a/theories/PArith/BinPos.v b/theories/PArith/BinPos.v index 99e77fd596..4179765dca 100644 --- a/theories/PArith/BinPos.v +++ b/theories/PArith/BinPos.v @@ -597,6 +597,13 @@ Proof. now rewrite !IHp, iter_swap. Qed. +Theorem iter_succ_r : + forall p (A:Type) (f:A -> A) (x:A), + iter f x (succ p) = iter f (f x) p. +Proof. + intros; now rewrite iter_succ, iter_swap. +Qed. + Theorem iter_add : forall p q (A:Type) (f:A -> A) (x:A), iter f x (p+q) = iter f (iter f x q) p. @@ -606,14 +613,22 @@ Proof. now rewrite add_succ_l, !iter_succ, IHp. Qed. +Theorem iter_ind : + forall (A:Type) (f:A -> A) (a:A) (P:positive -> A -> Prop), + P 1 (f a) -> + (forall p a', P p a' -> P (succ p) (f a')) -> + forall p, P p (iter f a p). +Proof. + induction p using peano_ind; trivial. + rewrite iter_succ; auto. +Qed. + Theorem iter_invariant : forall (p:positive) (A:Type) (f:A -> A) (Inv:A -> Prop), (forall x:A, Inv x -> Inv (f x)) -> forall x:A, Inv x -> Inv (iter f x p). Proof. - induction p as [p IHp|p IHp|]; simpl; trivial. - intros A f Inv H x H0. apply H, IHp, IHp; trivial. - intros A f Inv H x H0. apply IHp, IHp; trivial. + intros; apply iter_ind with (P := fun _ => Inv); auto. Qed. (** ** Properties of power *) @@ -1738,7 +1753,7 @@ Qed. Ltac destr_pggcdn IHn := match goal with |- context [ ggcdn _ ?x ?y ] => - generalize (IHn x y); destruct ggcdn as (g,(u,v)); simpl + generalize (IHn x y); destruct ggcdn as (?g,(?u,?v)); simpl end. Lemma ggcdn_correct_divisors : forall n a b, diff --git a/theories/Reals/Machin.v b/theories/Reals/Machin.v index d345158d1a..7c3b9097e5 100644 --- a/theories/Reals/Machin.v +++ b/theories/Reals/Machin.v @@ -39,11 +39,11 @@ assert (cos (atan v) <> 0). destruct (atan_bound v); apply Rgt_not_eq, cos_gt_0; auto. rewrite <- Ropp_div; assumption. assert (t : forall a b c, a - b = c -> a = b + c) by (intros; subst; field). -apply t, tan_is_inj; clear t; try assumption. +apply t, tan_inj; clear t; try assumption. rewrite tan_minus; auto. - rewrite !atan_right_inv; reflexivity. + rewrite !tan_atan; reflexivity. apply Rgt_not_eq, cos_gt_0; rewrite <- ?Ropp_div; tauto. -rewrite !atan_right_inv; assumption. +rewrite !tan_atan; assumption. Qed. Lemma tech : forall x y , -1 <= x <= 1 -> -1 < y < 1 -> diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v index c5fcb49b82..33e40a115b 100644 --- a/theories/Reals/RIneq.v +++ b/theories/Reals/RIneq.v @@ -746,6 +746,9 @@ Proof. Qed. Hint Resolve Rminus_diag_eq: real. +Lemma Rminus_eq_0 x : x - x = 0. +Proof. ring. Qed. + (**********) Lemma Rminus_diag_uniq : forall r1 r2, r1 - r2 = 0 -> r1 = r2. Proof. @@ -794,6 +797,10 @@ Proof. intros; ring. Qed. +Lemma Rmult_minus_distr_r: + forall r1 r2 r3, (r2 - r3) * r1 = r2 * r1 - r3 * r1. +Proof. intros; ring. Qed. + (*********************************************************) (** ** Inverse *) (*********************************************************) @@ -823,7 +830,7 @@ Hint Resolve Rinv_involutive: real. Lemma Rinv_mult_distr : forall r1 r2, r1 <> 0 -> r2 <> 0 -> / (r1 * r2) = / r1 * / r2. Proof. - intros; field; auto. + intros; field; auto. Qed. (*********) @@ -2017,6 +2024,12 @@ Lemma Ropp_div : forall x y, -x/y = - (x / y). intros x y; unfold Rdiv; ring. Qed. +Lemma Ropp_div_den : forall x y : R, y<>0 -> x / - y = - (x / y). +Proof. + intros. + field; assumption. +Qed. + Lemma double : forall r1, 2 * r1 = r1 + r1. Proof. intro; ring. @@ -2130,6 +2143,15 @@ Record negreal : Type := mknegreal {neg :> R; cond_neg : neg < 0}. Record nonzeroreal : Type := mknonzeroreal {nonzero :> R; cond_nonzero : nonzero <> 0}. +(** ** A few common instances *) + +Lemma pos_half_prf : 0 < /2. +Proof. + apply Rinv_0_lt_compat, Rlt_0_2. +Qed. + +Definition posreal_one := mkposreal (1) (Rlt_0_1). +Definition posreal_half := mkposreal (/2) pos_half_prf. (** Compatibility *) diff --git a/theories/Reals/R_sqr.v b/theories/Reals/R_sqr.v index 12f5ece2cf..f17961aa7a 100644 --- a/theories/Reals/R_sqr.v +++ b/theories/Reals/R_sqr.v @@ -72,7 +72,7 @@ Proof. rewrite Rinv_mult_distr. repeat rewrite Rmult_assoc. apply Rmult_eq_compat_l. - rewrite Rmult_comm. + rewrite Rmult_comm. repeat rewrite Rmult_assoc. apply Rmult_eq_compat_l. reflexivity. @@ -181,6 +181,38 @@ Proof. apply Rsqr_incr_1; assumption. Qed. +Lemma neg_pos_Rsqr_lt : forall x y : R, - y < x -> x < y -> Rsqr x < Rsqr y. +Proof. + intros x y Hneg Hpos. + destruct (Rcase_abs x) as [Hlt|HLe]. + - rewrite (Rsqr_neg x); apply Rsqr_incrst_1. + + rewrite <- (Ropp_involutive y); apply Ropp_lt_contravar; exact Hneg. + + rewrite <- (Ropp_0). apply Ropp_le_contravar, Rlt_le; exact Hlt. + + apply (Rlt_trans _ _ _ Hneg) in Hlt. + rewrite <- (Ropp_0) in Hlt; apply Ropp_lt_cancel in Hlt; apply Rlt_le; exact Hlt. + - apply Rsqr_incrst_1. + + exact Hpos. + + apply Rge_le; exact HLe. + + apply Rge_le in HLe. + apply (Rle_lt_trans _ _ _ HLe), Rlt_le in Hpos; exact Hpos. +Qed. + +Lemma Rsqr_bounds_le : forall a b:R, -a <= b <= a -> 0 <= Rsqr b <= Rsqr a. +Proof. + intros a b [H1 H2]. + split. + - apply Rle_0_sqr. + - apply neg_pos_Rsqr_le; assumption. +Qed. + +Lemma Rsqr_bounds_lt : forall a b:R, -a < b < a -> 0 <= Rsqr b < Rsqr a. +Proof. + intros a b [H1 H2]. + split. + - apply Rle_0_sqr. + - apply neg_pos_Rsqr_lt; assumption. +Qed. + Lemma Rsqr_abs : forall x:R, Rsqr x = Rsqr (Rabs x). Proof. intro; unfold Rabs; case (Rcase_abs x); intro; diff --git a/theories/Reals/R_sqrt.v b/theories/Reals/R_sqrt.v index b5d43b3c4c..7961a178b1 100644 --- a/theories/Reals/R_sqrt.v +++ b/theories/Reals/R_sqrt.v @@ -100,6 +100,9 @@ Lemma sqrt_pow2 : forall x, 0 <= x -> sqrt (x ^ 2) = x. intros; simpl; rewrite Rmult_1_r, sqrt_square; auto. Qed. +Lemma pow2_sqrt x : 0 <= x -> sqrt x ^ 2 = x. +Proof. now intros x0; simpl; rewrite -> Rmult_1_r, sqrt_sqrt. Qed. + Lemma sqrt_Rsqr_abs : forall x:R, sqrt (Rsqr x) = Rabs x. Proof. intro x; rewrite Rsqr_abs; apply sqrt_Rsqr; apply Rabs_pos. @@ -290,6 +293,14 @@ Proof. now apply sqrt_le_1_alt. Qed. +Lemma sqrt_neg_0 x : x <= 0 -> sqrt x = 0. +Proof. + intros Hx. + apply Rle_le_eq; split. + - rewrite <- sqrt_0; apply sqrt_le_1_alt, Hx. + - apply sqrt_pos. +Qed. + Lemma sqrt_inj : forall x y:R, 0 <= x -> 0 <= y -> sqrt x = sqrt y -> x = y. Proof. intros; cut (Rsqr (sqrt x) = Rsqr (sqrt y)). @@ -327,6 +338,20 @@ Proof. apply (Rmult_lt_compat_l (sqrt x) (sqrt x) 1 (sqrt_lt_R0 x H1) H3). Qed. +Lemma inv_sqrt x : 0 < x -> / sqrt x = sqrt (/ x). +Proof. +intros x0. +assert (sqrt x <> 0). + apply Rgt_not_eq. + now apply sqrt_lt_R0. +apply Rmult_eq_reg_r with (sqrt x); auto. +rewrite Rinv_l; auto. +rewrite <- sqrt_mult_alt. + now rewrite -> Rinv_l, sqrt_1; auto with real. +apply Rlt_le. +now apply Rinv_0_lt_compat. +Qed. + Lemma sqrt_cauchy : forall a b c d:R, a * c + b * d <= sqrt (Rsqr a + Rsqr b) * sqrt (Rsqr c + Rsqr d). diff --git a/theories/Reals/Ranalysis1.v b/theories/Reals/Ranalysis1.v index 8ba4057e03..6594648489 100644 --- a/theories/Reals/Ranalysis1.v +++ b/theories/Reals/Ranalysis1.v @@ -27,6 +27,7 @@ Definition div_fct f1 f2 (x:R) : R := f1 x / f2 x. Definition div_real_fct (a:R) f (x:R) : R := a / f x. Definition comp f1 f2 (x:R) : R := f1 (f2 x). Definition inv_fct f (x:R) : R := / f x. +Definition mirr_fct f (x:R) : R := f (- x). Declare Scope Rfun_scope. Delimit Scope Rfun_scope with F. @@ -40,6 +41,7 @@ Arguments opp_fct f%F x%R. Arguments mult_real_fct a%R f%F x%R. Arguments div_real_fct a%R f%F x%R. Arguments comp (f1 f2)%F x%R. +Arguments mirr_fct f%F x%R. Infix "+" := plus_fct : Rfun_scope. Notation "- x" := (opp_fct x) : Rfun_scope. @@ -92,7 +94,7 @@ exists (Rmin a a'); split. intros y cy; rewrite <- !q. apply Pa'. split;[| apply Rlt_le_trans with (Rmin a a');[ | apply Rmin_r]];tauto. - rewrite R_dist_eq; assumption. + rewrite R_dist_eq; assumption. apply Rlt_le_trans with (Rmin a a');[ | apply Rmin_l]; tauto. Qed. @@ -499,7 +501,7 @@ Qed. (* Extensionally equal functions have the same derivative. *) -Lemma derivable_pt_lim_ext : forall f g x l, (forall z, f z = g z) -> +Lemma derivable_pt_lim_ext : forall f g x l, (forall z, f z = g z) -> derivable_pt_lim f x l -> derivable_pt_lim g x l. intros f g x l fg df e ep; destruct (df e ep) as [d pd]; exists d; intros h; rewrite <- !fg; apply pd. @@ -507,7 +509,7 @@ Qed. (* extensionally equal functions have the same derivative, locally. *) -Lemma derivable_pt_lim_locally_ext : forall f g x a b l, +Lemma derivable_pt_lim_locally_ext : forall f g x a b l, a < x < b -> (forall z, a < z < b -> f z = g z) -> derivable_pt_lim f x l -> derivable_pt_lim g x l. @@ -577,6 +579,124 @@ Qed. (** * Main rules *) (****************************************************************) +(** ** Rules for derivable_pt_lim (value of the derivative at a point) *) + +Lemma derivable_pt_lim_id : forall x:R, derivable_pt_lim id x 1. +Proof. + intro; unfold derivable_pt_lim. + intros eps Heps; exists (mkposreal eps Heps); intros h H1 H2; + unfold id; replace ((x + h - x) / h - 1) with 0. + rewrite Rabs_R0; apply Rle_lt_trans with (Rabs h). + apply Rabs_pos. + assumption. + unfold Rminus; rewrite Rplus_assoc; rewrite (Rplus_comm x); + rewrite Rplus_assoc. + rewrite Rplus_opp_l; rewrite Rplus_0_r; unfold Rdiv; + rewrite <- Rinv_r_sym. + symmetry ; apply Rplus_opp_r. + assumption. +Qed. + +Lemma derivable_pt_lim_comp : + forall f1 f2 (x l1 l2:R), + derivable_pt_lim f1 x l1 -> + derivable_pt_lim f2 (f1 x) l2 -> derivable_pt_lim (f2 o f1) x (l2 * l1). +Proof. + intros; assert (H1 := derivable_pt_lim_D_in f1 (fun y:R => l1) x). + elim H1; intros. + assert (H4 := H3 H). + assert (H5 := derivable_pt_lim_D_in f2 (fun y:R => l2) (f1 x)). + elim H5; intros. + assert (H8 := H7 H0). + clear H1 H2 H3 H5 H6 H7. + assert (H1 := derivable_pt_lim_D_in (f2 o f1)%F (fun y:R => l2 * l1) x). + elim H1; intros. + clear H1 H3; apply H2. + unfold comp; + cut + (D_in (fun x0:R => f2 (f1 x0)) (fun y:R => l2 * l1) + (Dgf no_cond no_cond f1) x -> + D_in (fun x0:R => f2 (f1 x0)) (fun y:R => l2 * l1) no_cond x). + intro; apply H1. + rewrite Rmult_comm; + apply (Dcomp no_cond no_cond (fun y:R => l1) (fun y:R => l2) f1 f2 x); + assumption. + unfold Dgf, D_in, no_cond; unfold limit1_in; + unfold limit_in; unfold dist; simpl; + unfold R_dist; intros. + elim (H1 eps H3); intros. + exists x0; intros; split. + elim H5; intros; assumption. + intros; elim H5; intros; apply H9; split. + unfold D_x; split. + split; trivial. + elim H6; intros; unfold D_x in H10; elim H10; intros; assumption. + elim H6; intros; assumption. +Qed. + +Lemma derivable_pt_lim_opp : + forall f (x l:R), derivable_pt_lim f x l -> derivable_pt_lim (- f) x (- l). +Proof. + intros f x l H. + apply uniqueness_step3. + unfold opp_fct, limit1_in, limit_in, dist; simpl; unfold R_dist. + apply uniqueness_step2 in H. + unfold limit1_in, limit_in, dist in H; simpl in H; unfold R_dist in H. + intros eps Heps; specialize (H eps Heps). + destruct H as [alp [Halp H]]; exists alp. + split; [assumption|]. + intros x0 Hx0; specialize(H x0 Hx0). + rewrite <- Rabs_Ropp in H. + match goal with H:Rabs(?a)<eps |- Rabs(?b)<eps => replace b with a by (field; tauto) end. + assumption. +Qed. + +Lemma derivable_pt_lim_opp_fwd : + forall f (x l:R), derivable_pt_lim f x (- l) -> derivable_pt_lim (- f) x l. +Proof. + intros f x l H. + apply uniqueness_step3. + unfold opp_fct, limit1_in, limit_in, dist; simpl; unfold R_dist. + apply uniqueness_step2 in H. + unfold limit1_in, limit_in, dist in H; simpl in H; unfold R_dist in H. + intros eps Heps; specialize (H eps Heps). + destruct H as [alp [Halp H]]; exists alp. + split; [assumption|]. + intros x0 Hx0; specialize(H x0 Hx0). + rewrite <- Rabs_Ropp in H. + match goal with H:Rabs(?a)<eps |- Rabs(?b)<eps => replace b with a by (field; tauto) end. + assumption. +Qed. + +Lemma derivable_pt_lim_opp_rev : + forall f (x l:R), derivable_pt_lim (- f) x (- l) -> derivable_pt_lim f x l. +Proof. + intros f x l H. + apply derivable_pt_lim_ext with (f := fun x => - - (f x)). + - intros; rewrite Ropp_involutive; reflexivity. + - apply derivable_pt_lim_opp_fwd; exact H. +Qed. + +Lemma derivable_pt_lim_mirr_fwd : + forall f (x l:R), derivable_pt_lim f (- x) (- l) -> derivable_pt_lim (mirr_fct f) x l. +Proof. + intros f x l H. + change (mirr_fct f) with (comp f (opp_fct id)). + replace l with ((-l) * -1) by ring. + apply derivable_pt_lim_comp; [| exact H]. + apply derivable_pt_lim_opp. + apply derivable_pt_lim_id. +Qed. + +Lemma derivable_pt_lim_mirr_rev : + forall f (x l:R), derivable_pt_lim (mirr_fct f) (- x) (- l) -> derivable_pt_lim f x l. +Proof. + intros f x l H. + apply derivable_pt_lim_ext with (f := fun x => (mirr_fct f (- x))). + - intros; unfold mirr_fct; rewrite Ropp_involutive; reflexivity. + - apply derivable_pt_lim_mirr_fwd; exact H. +Qed. + Lemma derivable_pt_lim_plus : forall f1 f2 (x l1 l2:R), derivable_pt_lim f1 x l1 -> @@ -605,28 +725,6 @@ Lemma derivable_pt_lim_plus : intro; unfold Rdiv; ring. Qed. -Lemma derivable_pt_lim_opp : - forall f (x l:R), derivable_pt_lim f x l -> derivable_pt_lim (- f) x (- l). -Proof. - intros. - apply uniqueness_step3. - assert (H1 := uniqueness_step2 _ _ _ H). - unfold opp_fct. - cut (forall h:R, (- f (x + h) - - f x) / h = - ((f (x + h) - f x) / h)). - intro. - generalize - (limit_Ropp (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) l 0 H1). - unfold limit1_in; unfold limit_in; unfold dist; - simpl; unfold R_dist; intros. - elim (H2 eps H3); intros. - exists x0. - elim H4; intros. - split. - assumption. - intros; rewrite H0; apply H6; assumption. - intro; unfold Rdiv; ring. -Qed. - Lemma derivable_pt_lim_minus : forall f1 f2 (x l1 l2:R), derivable_pt_lim f1 x l1 -> @@ -718,22 +816,6 @@ intros f x l a df; unfold Rdiv; rewrite Rmult_comm; apply derivable_pt_lim_scal; assumption. Qed. -Lemma derivable_pt_lim_id : forall x:R, derivable_pt_lim id x 1. -Proof. - intro; unfold derivable_pt_lim. - intros eps Heps; exists (mkposreal eps Heps); intros h H1 H2; - unfold id; replace ((x + h - x) / h - 1) with 0. - rewrite Rabs_R0; apply Rle_lt_trans with (Rabs h). - apply Rabs_pos. - assumption. - unfold Rminus; rewrite Rplus_assoc; rewrite (Rplus_comm x); - rewrite Rplus_assoc. - rewrite Rplus_opp_l; rewrite Rplus_0_r; unfold Rdiv; - rewrite <- Rinv_r_sym. - symmetry ; apply Rplus_opp_r. - assumption. -Qed. - Lemma derivable_pt_lim_Rsqr : forall x:R, derivable_pt_lim Rsqr x (2 * x). Proof. intro; unfold derivable_pt_lim. @@ -748,63 +830,93 @@ Proof. ring. Qed. -Lemma derivable_pt_lim_comp : - forall f1 f2 (x l1 l2:R), - derivable_pt_lim f1 x l1 -> - derivable_pt_lim f2 (f1 x) l2 -> derivable_pt_lim (f2 o f1) x (l2 * l1). +(** ** Rules for derivable_pt (derivability at a point) *) + +Lemma derivable_pt_id : forall x:R, derivable_pt id x. Proof. - intros; assert (H1 := derivable_pt_lim_D_in f1 (fun y:R => l1) x). - elim H1; intros. - assert (H4 := H3 H). - assert (H5 := derivable_pt_lim_D_in f2 (fun y:R => l2) (f1 x)). - elim H5; intros. - assert (H8 := H7 H0). - clear H1 H2 H3 H5 H6 H7. - assert (H1 := derivable_pt_lim_D_in (f2 o f1)%F (fun y:R => l2 * l1) x). - elim H1; intros. - clear H1 H3; apply H2. - unfold comp; - cut - (D_in (fun x0:R => f2 (f1 x0)) (fun y:R => l2 * l1) - (Dgf no_cond no_cond f1) x -> - D_in (fun x0:R => f2 (f1 x0)) (fun y:R => l2 * l1) no_cond x). - intro; apply H1. - rewrite Rmult_comm; - apply (Dcomp no_cond no_cond (fun y:R => l1) (fun y:R => l2) f1 f2 x); - assumption. - unfold Dgf, D_in, no_cond; unfold limit1_in; - unfold limit_in; unfold dist; simpl; - unfold R_dist; intros. - elim (H1 eps H3); intros. - exists x0; intros; split. - elim H5; intros; assumption. - intros; elim H5; intros; apply H9; split. - unfold D_x; split. - split; trivial. - elim H6; intros; unfold D_x in H10; elim H10; intros; assumption. - elim H6; intros; assumption. + unfold derivable_pt; intro. + exists 1. + apply derivable_pt_lim_id. Qed. -Lemma derivable_pt_plus : +Lemma derivable_pt_comp : forall f1 f2 (x:R), - derivable_pt f1 x -> derivable_pt f2 x -> derivable_pt (f1 + f2) x. + derivable_pt f1 x -> derivable_pt f2 (f1 x) -> derivable_pt (f2 o f1) x. Proof. unfold derivable_pt; intros f1 f2 x X X0. elim X; intros. elim X0; intros. - exists (x0 + x1). - apply derivable_pt_lim_plus; assumption. + exists (x1 * x0). + apply derivable_pt_lim_comp; assumption. +Qed. + +Lemma derivable_pt_xeq: + forall (f : R -> R) (x1 x2 : R), x1=x2 -> derivable_pt f x1 -> derivable_pt f x2. +Proof. + intros f x1 x2 Heq H. + subst; assumption. Qed. Lemma derivable_pt_opp : - forall f (x:R), derivable_pt f x -> derivable_pt (- f) x. + forall (f : R -> R) (x:R), derivable_pt f x -> derivable_pt (- f) x. Proof. - unfold derivable_pt; intros f x X. - elim X; intros. - exists (- x0). + intros f x H. + unfold derivable_pt in H. + destruct H as [l H]; exists (-l). apply derivable_pt_lim_opp; assumption. Qed. +Lemma derivable_pt_opp_rev: + forall (f : R -> R) (x : R), derivable_pt (- f) x -> derivable_pt f x. +Proof. + intros f x H. + unfold derivable_pt in H. + destruct H as [l H]; exists (-l). + apply derivable_pt_lim_opp_rev. + rewrite Ropp_involutive; assumption. +Qed. + +Lemma derivable_pt_mirr: + forall (f : R -> R) (x : R), derivable_pt f (-x) -> derivable_pt (mirr_fct f) x. +Proof. + intros f x H. + unfold derivable_pt in H. + destruct H as [l H]; exists (-l). + apply derivable_pt_lim_mirr_fwd. + rewrite Ropp_involutive; assumption. +Qed. + +Lemma derivable_pt_mirr_rev: + forall (f : R -> R) (x : R), derivable_pt (mirr_fct f) (- x) -> derivable_pt f x. +Proof. + intros f x H. + unfold derivable_pt in H. + destruct H as [l H]; exists (-l). + apply derivable_pt_lim_mirr_rev. + rewrite Ropp_involutive; assumption. +Qed. + +Lemma derivable_pt_mirr_prem: + forall (f : R -> R) (x : R), derivable_pt (mirr_fct f) x -> derivable_pt f (-x). +Proof. + intros f x H. + unfold derivable_pt in H. + destruct H as [l H]; exists (-l). + apply derivable_pt_lim_mirr_rev. + repeat rewrite Ropp_involutive; assumption. +Qed. + +Lemma derivable_pt_plus : + forall f1 f2 (x:R), + derivable_pt f1 x -> derivable_pt f2 x -> derivable_pt (f1 + f2) x. +Proof. + unfold derivable_pt; intros f1 f2 x X X0. + elim X; intros. + elim X0; intros. + exists (x0 + x1). + apply derivable_pt_lim_plus; assumption. +Qed. + Lemma derivable_pt_minus : forall f1 f2 (x:R), derivable_pt f1 x -> derivable_pt f2 x -> derivable_pt (f1 - f2) x. @@ -843,35 +955,24 @@ Proof. apply derivable_pt_lim_scal; assumption. Qed. -Lemma derivable_pt_id : forall x:R, derivable_pt id x. -Proof. - unfold derivable_pt; intro. - exists 1. - apply derivable_pt_lim_id. -Qed. - Lemma derivable_pt_Rsqr : forall x:R, derivable_pt Rsqr x. Proof. unfold derivable_pt; intro; exists (2 * x). apply derivable_pt_lim_Rsqr. Qed. -Lemma derivable_pt_comp : - forall f1 f2 (x:R), - derivable_pt f1 x -> derivable_pt f2 (f1 x) -> derivable_pt (f2 o f1) x. +(** ** Rules for derivable (derivability on whole domain) *) + +Lemma derivable_id : derivable id. Proof. - unfold derivable_pt; intros f1 f2 x X X0. - elim X; intros. - elim X0; intros. - exists (x1 * x0). - apply derivable_pt_lim_comp; assumption. + unfold derivable; intro; apply derivable_pt_id. Qed. -Lemma derivable_plus : - forall f1 f2, derivable f1 -> derivable f2 -> derivable (f1 + f2). +Lemma derivable_comp : + forall f1 f2, derivable f1 -> derivable f2 -> derivable (f2 o f1). Proof. unfold derivable; intros f1 f2 X X0 x. - apply (derivable_pt_plus _ _ x (X _) (X0 _)). + apply (derivable_pt_comp _ _ x (X _) (X0 _)). Qed. Lemma derivable_opp : forall f, derivable f -> derivable (- f). @@ -880,6 +981,19 @@ Proof. apply (derivable_pt_opp _ x (X _)). Qed. +Lemma derivable_mirr : forall f, derivable f -> derivable (mirr_fct f). +Proof. + unfold derivable; intros f X x. + apply (derivable_pt_mirr _ x (X _)). +Qed. + +Lemma derivable_plus : + forall f1 f2, derivable f1 -> derivable f2 -> derivable (f1 + f2). +Proof. + unfold derivable; intros f1 f2 X X0 x. + apply (derivable_pt_plus _ _ x (X _) (X0 _)). +Qed. + Lemma derivable_minus : forall f1 f2, derivable f1 -> derivable f2 -> derivable (f1 - f2). Proof. @@ -907,33 +1021,30 @@ Proof. apply (derivable_pt_scal _ a x (X _)). Qed. -Lemma derivable_id : derivable id. -Proof. - unfold derivable; intro; apply derivable_pt_id. -Qed. - Lemma derivable_Rsqr : derivable Rsqr. Proof. unfold derivable; intro; apply derivable_pt_Rsqr. Qed. -Lemma derivable_comp : - forall f1 f2, derivable f1 -> derivable f2 -> derivable (f2 o f1). +(** ** Rules for derive_pt (derivative function on whole domain) *) + +Lemma derive_pt_id : forall x:R, derive_pt id x (derivable_pt_id _) = 1. Proof. - unfold derivable; intros f1 f2 X X0 x. - apply (derivable_pt_comp _ _ x (X _) (X0 _)). + intros. + apply derive_pt_eq_0. + apply derivable_pt_lim_id. Qed. -Lemma derive_pt_plus : - forall f1 f2 (x:R) (pr1:derivable_pt f1 x) (pr2:derivable_pt f2 x), - derive_pt (f1 + f2) x (derivable_pt_plus _ _ _ pr1 pr2) = - derive_pt f1 x pr1 + derive_pt f2 x pr2. +Lemma derive_pt_comp : + forall f1 f2 (x:R) (pr1:derivable_pt f1 x) (pr2:derivable_pt f2 (f1 x)), + derive_pt (f2 o f1) x (derivable_pt_comp _ _ _ pr1 pr2) = + derive_pt f2 (f1 x) pr2 * derive_pt f1 x pr1. Proof. intros. assert (H := derivable_derive f1 x pr1). - assert (H0 := derivable_derive f2 x pr2). + assert (H0 := derivable_derive f2 (f1 x) pr2). assert - (H1 := derivable_derive (f1 + f2)%F x (derivable_pt_plus _ _ _ pr1 pr2)). + (H1 := derivable_derive (f2 o f1)%F x (derivable_pt_comp _ _ _ pr1 pr2)). elim H; clear H; intros l1 H. elim H0; clear H0; intros l2 H0. elim H1; clear H1; intros l H1. @@ -942,7 +1053,7 @@ Proof. unfold derive_pt in H; rewrite H in H3. assert (H4 := proj2_sig pr2). unfold derive_pt in H0; rewrite H0 in H4. - apply derivable_pt_lim_plus; assumption. + apply derivable_pt_lim_comp; assumption. Qed. Lemma derive_pt_opp : @@ -950,14 +1061,68 @@ Lemma derive_pt_opp : derive_pt (- f) x (derivable_pt_opp _ _ pr1) = - derive_pt f x pr1. Proof. intros. - assert (H := derivable_derive f x pr1). - assert (H0 := derivable_derive (- f)%F x (derivable_pt_opp _ _ pr1)). + apply derive_pt_eq_0. + apply derivable_pt_lim_opp_fwd. + rewrite Ropp_involutive. + apply (derive_pt_eq_1 _ _ _ pr1). + reflexivity. +Qed. + +Lemma derive_pt_opp_rev : + forall f (x:R) (pr1:derivable_pt (- f) x), + derive_pt (- f) x pr1 = - derive_pt f x (derivable_pt_opp_rev _ _ pr1). +Proof. + intros. + apply derive_pt_eq_0. + apply derivable_pt_lim_opp_fwd. + rewrite Ropp_involutive. + apply (derive_pt_eq_1 _ _ _ (derivable_pt_opp_rev _ _ pr1)). + reflexivity. +Qed. + +Lemma derive_pt_mirr : + forall f (x:R) (pr1:derivable_pt f (-x)), + derive_pt (mirr_fct f) x (derivable_pt_mirr _ _ pr1) = - derive_pt f (-x) pr1. +Proof. + intros. + apply derive_pt_eq_0. + apply derivable_pt_lim_mirr_fwd. + rewrite Ropp_involutive. + apply (derive_pt_eq_1 _ _ _ pr1). + reflexivity. +Qed. + +Lemma derive_pt_mirr_rev : + forall f (x:R) (pr1:derivable_pt (mirr_fct f) x), + derive_pt (mirr_fct f) x pr1 = - derive_pt f (-x) (derivable_pt_mirr_prem f x pr1). +Proof. + intros. + apply derive_pt_eq_0. + apply derivable_pt_lim_mirr_fwd. + rewrite Ropp_involutive. + apply (derive_pt_eq_1 _ _ _ (derivable_pt_mirr_prem f x pr1)). + reflexivity. +Qed. + +Lemma derive_pt_plus : + forall f1 f2 (x:R) (pr1:derivable_pt f1 x) (pr2:derivable_pt f2 x), + derive_pt (f1 + f2) x (derivable_pt_plus _ _ _ pr1 pr2) = + derive_pt f1 x pr1 + derive_pt f2 x pr2. +Proof. + intros. + assert (H := derivable_derive f1 x pr1). + assert (H0 := derivable_derive f2 x pr2). + assert + (H1 := derivable_derive (f1 + f2)%F x (derivable_pt_plus _ _ _ pr1 pr2)). elim H; clear H; intros l1 H. elim H0; clear H0; intros l2 H0. - rewrite H; apply derive_pt_eq_0. + elim H1; clear H1; intros l H1. + rewrite H; rewrite H0; apply derive_pt_eq_0. assert (H3 := proj2_sig pr1). unfold derive_pt in H; rewrite H in H3. - apply derivable_pt_lim_opp; assumption. + assert (H4 := proj2_sig pr2). + unfold derive_pt in H0; rewrite H0 in H4. + apply derivable_pt_lim_plus; assumption. Qed. Lemma derive_pt_minus : @@ -1027,13 +1192,6 @@ Proof. apply derivable_pt_lim_scal; assumption. Qed. -Lemma derive_pt_id : forall x:R, derive_pt id x (derivable_pt_id _) = 1. -Proof. - intros. - apply derive_pt_eq_0. - apply derivable_pt_lim_id. -Qed. - Lemma derive_pt_Rsqr : forall x:R, derive_pt Rsqr x (derivable_pt_Rsqr _) = 2 * x. Proof. @@ -1042,28 +1200,8 @@ Proof. apply derivable_pt_lim_Rsqr. Qed. -Lemma derive_pt_comp : - forall f1 f2 (x:R) (pr1:derivable_pt f1 x) (pr2:derivable_pt f2 (f1 x)), - derive_pt (f2 o f1) x (derivable_pt_comp _ _ _ pr1 pr2) = - derive_pt f2 (f1 x) pr2 * derive_pt f1 x pr1. -Proof. - intros. - assert (H := derivable_derive f1 x pr1). - assert (H0 := derivable_derive f2 (f1 x) pr2). - assert - (H1 := derivable_derive (f2 o f1)%F x (derivable_pt_comp _ _ _ pr1 pr2)). - elim H; clear H; intros l1 H. - elim H0; clear H0; intros l2 H0. - elim H1; clear H1; intros l H1. - rewrite H; rewrite H0; apply derive_pt_eq_0. - assert (H3 := proj2_sig pr1). - unfold derive_pt in H; rewrite H in H3. - assert (H4 := proj2_sig pr2). - unfold derive_pt in H0; rewrite H0 in H4. - apply derivable_pt_lim_comp; assumption. -Qed. +(** ** Definition and derivative of power function with natural number exponent *) -(* Pow *) Definition pow_fct (n:nat) (y:R) : R := y ^ n. Lemma derivable_pt_lim_pow_pos : @@ -1141,6 +1279,8 @@ Proof. apply derivable_pt_lim_pow. Qed. +(** ** Irrelevance of derivability proof for derivative *) + Lemma pr_nu : forall f (x:R) (pr1 pr2:derivable_pt f x), derive_pt f x pr1 = derive_pt f x pr2. @@ -1149,6 +1289,16 @@ Proof. apply (uniqueness_limite f x x0 x1 H0 H1). Qed. +(** In dependently typed environments it is sometimes hard to rewrite. + Having pr_nu for separate x with a proof that they are equal helps. *) + +Lemma pr_nu_xeq : + forall f (x1 x2:R) (pr1:derivable_pt f x1) (pr2:derivable_pt f x2), + x1 = x2 -> derive_pt f x1 pr1 = derive_pt f x2 pr2. +Proof. + intros f x1 x2 H1 H2 Heq. + subst. apply pr_nu. +Qed. (************************************************************) (** * Local extremum's condition *) diff --git a/theories/Reals/Ranalysis5.v b/theories/Reals/Ranalysis5.v index 1713679c21..e73c73e8dd 100644 --- a/theories/Reals/Ranalysis5.v +++ b/theories/Reals/Ranalysis5.v @@ -219,7 +219,7 @@ intros f g lb ub f_incr_interv Hyp g_wf x x_encad. intro cond. apply Rlt_le ; apply f_incr_interv ; assumption. intro cond ; right ; rewrite cond ; reflexivity. assert (Hyp2:forall x, lb <= x <= ub -> f (g (f x)) = f x). - intros ; apply Hyp. apply f_incr_interv2 ; intuition. + intros ; apply Hyp. apply f_incr_interv2 ; intuition. apply f_incr_interv2 ; intuition. unfold comp ; unfold comp in Hyp. apply f_inj. @@ -279,8 +279,8 @@ Proof. intros. (* f x y f_cont_interv x_lt_y fx_neg fy_pos.*) cut (x <= y). intro. - generalize (dicho_lb_cv x y (fun z:R => cond_positivity (f z)) H3). - generalize (dicho_up_cv x y (fun z:R => cond_positivity (f z)) H3). + generalize (dicho_lb_cv x y (fun z:R => cond_positivity (f z)) H3). + generalize (dicho_up_cv x y (fun z:R => cond_positivity (f z)) H3). intros X X0. elim X; intros x0 p. elim X0; intros x1 p0. @@ -411,10 +411,10 @@ Qed. (* begin hide *) Ltac case_le H := - let t := type of H in - let h' := fresh in + let t := type of H in + let h' := fresh in match t with ?x <= ?y => case (total_order_T x y); - [intros h'; case h'; clear h' | + [intros h'; case h'; clear h' | intros h'; clear -H h'; elimtype False; lra ] end. (* end hide *) @@ -585,7 +585,7 @@ intros f g lb ub lb_lt_ub f_incr_interv f_eq_g f_cont_interv b b_encad. assert (x1_lt_x2 : x1 < x2). apply Rlt_trans with (r2:=x) ; assumption. assert (f_cont_myinterv : forall a : R, x1 <= a <= x2 -> continuity_pt f a). - intros ; apply f_cont_interv ; split. + intros ; apply f_cont_interv ; split. apply Rle_trans with (r2 := x1) ; intuition. apply Rle_trans with (r2 := x2) ; intuition. elim (f_interv_is_interv f x1 x2 y x1_lt_x2 Main f_cont_myinterv) ; intros x' Temp. @@ -708,7 +708,7 @@ intros f g lb ub x Prf g_cont_pur lb_lt_ub x_encad Prg_incr f_eq_g df_neq. rewrite l_null in Hl. apply df_neq. rewrite derive_pt_eq. - exact Hl. + exact Hl. elim (Hlinv' Premisse Premisse2 eps eps_pos). intros alpha cond. assert (alpha_pos := proj1 cond) ; assert (inv_cont := proj2 cond) ; clear cond. @@ -763,7 +763,7 @@ intros f g lb ub x Prf g_cont_pur lb_lt_ub x_encad Prg_incr f_eq_g df_neq. replace ((g (x + h) - g x) / h) with (1/ (h / (g (x + h) - g x))). assert (Hrewr : h = (comp f g ) (x+h) - (comp f g) x). rewrite f_eq_g. rewrite f_eq_g ; unfold id. rewrite Rplus_comm ; - unfold Rminus ; rewrite Rplus_assoc ; rewrite Rplus_opp_r. intuition. intuition. + unfold Rminus ; rewrite Rplus_assoc ; rewrite Rplus_opp_r. intuition. intuition. assumption. split ; [|intuition]. assert (Sublemma : forall x y z, - z <= y - x -> x <= y + z). @@ -791,7 +791,7 @@ intros f g lb ub x Prf g_cont_pur lb_lt_ub x_encad Prg_incr f_eq_g df_neq. rewrite f_eq_g. rewrite f_eq_g. unfold id ; rewrite Rplus_comm ; unfold Rminus ; rewrite Rplus_assoc ; rewrite Rplus_opp_r ; intuition. assumption. assumption. - rewrite Hrewr at 1. + rewrite Hrewr at 1. unfold comp. replace (g(x+h)) with (g x + (g (x+h) - g(x))) by field. pose (h':=g (x+h) - g x). @@ -811,7 +811,7 @@ intros f g lb ub x Prf g_cont_pur lb_lt_ub x_encad Prg_incr f_eq_g df_neq. apply inv_cont. split. exact h'_neq. - rewrite Rminus_0_r. + rewrite Rminus_0_r. unfold continuity_pt, continue_in, limit1_in, limit_in in g_cont_pur. elim (g_cont_pur mydelta mydelta_pos). intros delta3 cond3. @@ -830,7 +830,7 @@ intros f g lb ub x Prf g_cont_pur lb_lt_ub x_encad Prg_incr f_eq_g df_neq. intro Hfalse ; apply h_neq. apply (Rplus_0_r_uniq x). symmetry ; assumption. - replace (x + h - x) with h by field. + replace (x + h - x) with h by field. apply Rlt_le_trans with (r2:=delta''). assumption ; unfold delta''. intuition. apply Rle_trans with (r2:=mydelta''). apply Req_le. unfold delta''. intuition. @@ -863,25 +863,28 @@ exists (1 / derive_pt f (g x) (Prf (g x) Prg_incr)). apply derivable_pt_lim_recip_interv ; assumption. Qed. -Lemma derivable_pt_recip_interv_prelim1 :forall (f g:R->R) (lb ub x : R), +Lemma derivable_pt_recip_interv_prelim1 : forall (f g:R->R) (lb ub x : R), lb < ub -> f lb < x < f ub -> - (forall x : R, f lb <= x -> x <= f ub -> comp f g x = id x) -> (forall x : R, f lb <= x -> x <= f ub -> lb <= g x <= ub) -> - (forall x y : R, lb <= x -> x < y -> y <= ub -> f x < f y) -> (forall a : R, lb <= a <= ub -> derivable_pt f a) -> derivable_pt f (g x). Proof. -intros f g lb ub x lb_lt_ub x_encad f_eq_g g_ok f_incr f_derivable. - apply f_derivable. - assert (Left_inv := leftinv_is_rightinv_interv f g lb ub f_incr f_eq_g g_ok). - replace lb with ((comp g f) lb). - replace ub with ((comp g f) ub). - unfold comp. - assert (Temp:= f_incr_implies_g_incr_interv f g lb ub lb_lt_ub f_incr f_eq_g g_ok). - split ; apply Rlt_le ; apply Temp ; intuition. - apply Left_inv ; intuition. - apply Left_inv ; intuition. + intros f g lb ub x lb_lt_ub x_encad g_wf f_deriv. + apply f_deriv. + apply g_wf; lra. +Qed. + +Lemma derivable_pt_recip_interv_prelim1_decr : forall (f g:R->R) (lb ub x : R), + lb < ub -> + f ub < x < f lb -> + (forall x : R, f ub <= x -> x <= f lb -> lb <= g x <= ub) -> + (forall a : R, lb <= a <= ub -> derivable_pt f a) -> + derivable_pt f (g x). +Proof. + intros f g lb ub x lb_lt_ub x_encad g_wf f_deriv. + apply f_deriv. + apply g_wf; lra. Qed. Lemma derivable_pt_recip_interv : forall (f g:R->R) (lb ub x : R) @@ -892,7 +895,7 @@ Lemma derivable_pt_recip_interv : forall (f g:R->R) (lb ub x : R) (f_derivable:forall a : R, lb <= a <= ub -> derivable_pt f a), derive_pt f (g x) (derivable_pt_recip_interv_prelim1 f g lb ub x lb_lt_ub - x_encad f_eq_g g_wf f_incr f_derivable) + x_encad g_wf f_derivable) <> 0 -> derivable_pt g x. Proof. @@ -916,8 +919,54 @@ intros f g lb ub x lb_lt_ub x_encad f_eq_g g_wf f_incr f_derivable Df_neq. exact (proj1 x_encad). exact (proj2 x_encad). apply f_incr ; intuition. assumption. intros x0 x0_encad ; apply f_eq_g ; intuition. - rewrite pr_nu_var2_interv with (g:=f) (lb:=lb) (ub:=ub) (pr2:=derivable_pt_recip_interv_prelim1 f g lb ub x lb_lt_ub x_encad - f_eq_g g_wf f_incr f_derivable) ; [| |rewrite g_eq_f in g_incr ; rewrite g_eq_f in g_incr| ] ; intuition. + rewrite pr_nu_var2_interv with (g:=f) (lb:=lb) (ub:=ub) + (pr2:=derivable_pt_recip_interv_prelim1 f g lb ub x lb_lt_ub x_encad g_wf f_derivable); + [| |rewrite g_eq_f in g_incr ; rewrite g_eq_f in g_incr| ] ; intuition. +Qed. + +Lemma derivable_pt_recip_interv_decr : forall (f g:R->R) (lb ub x : R) + (lb_lt_ub:lb < ub) + (x_encad:f ub < x < f lb) + (f_eq_g:forall x : R, f ub <= x -> x <= f lb -> comp f g x = id x) + (g_wf:forall x : R, f ub <= x -> x <= f lb -> lb <= g x <= ub) + (f_decr:forall x y : R, lb <= x -> x < y -> y <= ub -> f y < f x) + (f_derivable:forall a : R, lb <= a <= ub -> derivable_pt f a), + derive_pt f (g x) + (derivable_pt_recip_interv_prelim1_decr f g lb ub x lb_lt_ub + x_encad g_wf f_derivable) + <> 0 -> + derivable_pt g x. +Proof. + intros. + apply derivable_pt_opp_rev. + unshelve eapply (derivable_pt_recip_interv (mirr_fct f) (opp_fct g) (-ub) (-lb) (x)). +- lra. +- unfold mirr_fct; repeat rewrite Ropp_involutive; lra. +- intros x0 H1 H2. + unfold mirr_fct in H1,H2; unfold opp_fct. + rewrite Ropp_involutive in H1,H2. + pose proof g_wf x0 as g_wfs; lra. +- intros x0 H1. + apply derivable_pt_mirr, f_derivable; lra. +- intros x0 H1 H2. + unfold mirr_fct in H1,H2 |-*; unfold opp_fct, comp. + rewrite Ropp_involutive in H1,H2 |-*. + apply f_eq_g; lra. +- intros x0 y0 H1 H2 H3. + unfold mirr_fct. + apply f_decr; lra. +- (* In order to rewrite with derive_pt_mirr the term must have the form + derive_pt (mirr_fct f) _ (derivable_pt_mirr ... + pr_nu is a sort of proof irrelevance lemma for derive_pt equalities *) + unshelve erewrite (pr_nu _ _ _). + + apply derivable_pt_mirr. + unfold opp_fct; rewrite Ropp_involutive. + apply f_derivable; apply g_wf; lra. + + rewrite derive_pt_mirr. + unfold opp_fct; rewrite Ropp_involutive. + match goal with H:context[derive_pt _ _ ?pr] |- _ => rewrite (pr_nu f (g x) _ pr) end. + apply Ropp_neq_0_compat. + assumption. Qed. (****************************************************) @@ -937,8 +986,8 @@ intros f g lb ub x Prf Prg lb_lt_ub x_encad local_recip Df_neq. ((derive_pt g x Prg) * (derive_pt f (g x) Prf) * / (derive_pt f (g x) Prf)). unfold Rdiv. rewrite (Rmult_comm _ (/ derive_pt f (g x) Prf)). - rewrite (Rmult_comm _ (/ derive_pt f (g x) Prf)). - apply Rmult_eq_compat_l. + rewrite (Rmult_comm _ (/ derive_pt f (g x) Prf)). + apply Rmult_eq_compat_l. rewrite Rmult_comm. rewrite <- derive_pt_comp. assert (x_encad2 : lb <= x <= ub) by intuition. @@ -948,7 +997,7 @@ intros f g lb ub x Prf Prg lb_lt_ub x_encad local_recip Df_neq. assumption. Qed. -Lemma derive_pt_recip_interv_prelim1_0 : forall (f g:R->R) (lb ub x:R), +Lemma derive_pt_recip_interv_prelim1_0 : forall (f g:R->R) (lb ub x:R), lb < ub -> f lb < x < f ub -> (forall x y : R, lb <= x -> x < y -> y <= ub -> f x < f y) -> @@ -967,7 +1016,7 @@ intros f g lb ub x lb_lt_ub x_encad f_incr g_wf f_eq_g. intuition. Qed. -Lemma derive_pt_recip_interv_prelim1_1 : forall (f g:R->R) (lb ub x:R), +Lemma derive_pt_recip_interv_prelim1_1 : forall (f g:R->R) (lb ub x:R), lb < ub -> f lb < x < f ub -> (forall x y : R, lb <= x -> x < y -> y <= ub -> f x < f y) -> @@ -980,6 +1029,32 @@ intros f g lb ub x lb_lt_ub x_encad f_incr g_wf f_eq_g. split ; apply Rlt_le ; intuition. Qed. +Lemma derive_pt_recip_interv_prelim1_1_decr : forall (f g:R->R) (lb ub x:R), + lb < ub -> + f ub < x < f lb -> + (forall x y : R, lb <= x -> x < y -> y <= ub -> f y < f x) -> + (forall x : R, f ub <= x -> x <= f lb -> lb <= g x <= ub) -> + (forall x, f ub <= x -> x <= f lb -> (comp f g) x = id x) -> + lb <= g x <= ub. +Proof. + intros f g lb ub x lb_lt_ub x_encad f_decr g_wf f_eq_g. + enough (-ub <= - g x <= - lb) by lra. + unshelve eapply (derive_pt_recip_interv_prelim1_1 (mirr_fct f) (opp_fct g) (-ub) (-lb) (x)). +- lra. +- unfold mirr_fct; repeat rewrite Ropp_involutive; lra. +- intros x0 y0 H1 H2 H3. + unfold mirr_fct. + apply f_decr; lra. +- intros x0 H1 H2. + unfold mirr_fct in H1,H2; unfold opp_fct. + rewrite Ropp_involutive in H1,H2. + pose proof g_wf x0 as g_wfs; lra. +- intros x0 H1 H2. + unfold mirr_fct in H1,H2 |-*; unfold opp_fct, comp. + rewrite Ropp_involutive in H1,H2 |-*. + apply f_eq_g; lra. +Qed. + Lemma derive_pt_recip_interv : forall (f g:R->R) (lb ub x:R) (lb_lt_ub:lb < ub) (x_encad:f lb < x < f ub) (f_incr:forall x y : R, lb <= x -> x < y -> y <= ub -> f x < f y) @@ -987,7 +1062,7 @@ Lemma derive_pt_recip_interv : forall (f g:R->R) (lb ub x:R) (Prf:forall a : R, lb <= a <= ub -> derivable_pt f a) (f_eq_g:forall x, f lb <= x -> x <= f ub -> (comp f g) x = id x) (Df_neq:derive_pt f (g x) (derivable_pt_recip_interv_prelim1 f g lb ub x - lb_lt_ub x_encad f_eq_g g_wf f_incr Prf) <> 0), + lb_lt_ub x_encad g_wf Prf) <> 0), derive_pt g x (derivable_pt_recip_interv f g lb ub x lb_lt_ub x_encad f_eq_g g_wf f_incr Prf Df_neq) = @@ -1005,7 +1080,75 @@ intros. [intuition | intuition | | intuition]. exact (derive_pt_recip_interv_prelim1_0 f g lb ub x lb_lt_ub x_encad f_incr g_wf f_eq_g). Qed. - + +Lemma derive_pt_recip_interv_decr : forall (f g:R->R) (lb ub x:R) + (lb_lt_ub:lb < ub) + (x_encad:f ub < x < f lb) + (f_decr:forall x y : R, lb <= x -> x < y -> y <= ub -> f y < f x) + (g_wf:forall x : R, f ub <= x -> x <= f lb -> lb <= g x <= ub) + (Prf:forall a : R, lb <= a <= ub -> derivable_pt f a) + (f_eq_g:forall x, f ub <= x -> x <= f lb -> (comp f g) x = id x) + (Df_neq:derive_pt f (g x) (derivable_pt_recip_interv_prelim1_decr f g lb ub x + lb_lt_ub x_encad g_wf Prf) <> 0), + derive_pt g x (derivable_pt_recip_interv_decr f g lb ub x lb_lt_ub x_encad f_eq_g + g_wf f_decr Prf Df_neq) + = + 1 / (derive_pt f (g x) (Prf (g x) (derive_pt_recip_interv_prelim1_1_decr f g lb ub x + lb_lt_ub x_encad f_decr g_wf f_eq_g))). +Proof. + (* This proof based on derive_pt_recip_interv looks fairly long compared to the direct proof above, + but the direct proof needs a lot of lengthy preparation lemmas e.g. derivable_pt_lim_recip_interv. *) + intros. + (* Note: here "unshelve epose" with proving the premises first does not work. + The more abstract form with the unbound evars has less issues with dependent rewriting. *) + epose proof (derive_pt_recip_interv (mirr_fct f) (opp_fct g) (-ub) (-lb) (x) _ _ _ _ _ _ _). + rewrite derive_pt_mirr_rev in H. + rewrite derive_pt_opp_rev in H. + unfold opp_fct in H. + match goal with + | H:context[derive_pt ?f ?x1 ?pr1] |- context[derive_pt ?f ?x2 ?pr2] => + rewrite (pr_nu_xeq f x1 x2 pr1 pr2 (Ropp_involutive x2)) in H + end. + match goal with + | H:context[derive_pt ?f ?x ?pr1] |- context[derive_pt ?f ?x ?pr2] => + rewrite (pr_nu f x pr1 pr2) in H + end. + apply Ropp_eq_compat in H; rewrite Ropp_involutive in H. + rewrite H; field. + pose proof Df_neq as Df_neq'. + match goal with + | H:context[derive_pt ?f ?x ?pr1] |- context[derive_pt ?f ?x ?pr2] => + rewrite (pr_nu f x pr1 pr2) in H + end. + assumption. + +Unshelve. +- abstract lra. +- unfold mirr_fct; repeat rewrite Ropp_involutive; abstract lra. +- intros x0 y0 H1 H2 H3. + unfold mirr_fct. + apply f_decr; abstract lra. +- intros x0 H1 H2. + unfold mirr_fct in H1,H2; unfold opp_fct. + rewrite Ropp_involutive in H1,H2. + pose proof g_wf x0 as g_wfs; abstract lra. +- intros x0 H1. + apply derivable_pt_mirr, Prf; abstract lra. +- intros x0 H1 H2. + unfold mirr_fct in H1,H2 |-*; unfold opp_fct, comp. + rewrite Ropp_involutive in H1,H2 |-*. + apply f_eq_g; abstract lra. +- unshelve erewrite (pr_nu _ _ _). + apply derivable_pt_mirr. + unfold opp_fct; rewrite Ropp_involutive. + apply Prf; apply g_wf; abstract lra. + rewrite derive_pt_mirr. + unfold opp_fct; rewrite Ropp_involutive. + apply Ropp_neq_0_compat. + erewrite (pr_nu _ _ _). + apply Df_neq. +Qed. + (****************************************************) (** * Existence of the derivative of a function which is the limit of a sequence of functions *) (****************************************************) @@ -1105,7 +1248,7 @@ assert (Main : Rabs ((f (x+h) - fn N (x+h)) - (f x - fn N x) + (fn N (x+h) - fn Rabs h * Rabs (fn' N c - g c) + Rabs h * Rabs (g c - g x)). rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ; apply Rplus_le_compat_l ; apply Rplus_le_compat_l ; - rewrite <- Rmult_plus_distr_l ; apply Rmult_le_compat_l. + rewrite <- Rmult_plus_distr_l ; apply Rmult_le_compat_l. solve[apply Rabs_pos]. solve[apply Rabs_triang]. apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + @@ -1129,7 +1272,7 @@ assert (Main : Rabs ((f (x+h) - fn N (x+h)) - (f x - fn N x) + (fn N (x+h) - fn solve[unfold no_cond ; intuition]. apply Rgt_not_eq ; exact (proj2 P). apply Rlt_trans with (Rabs h). - apply Rabs_def1. + apply Rabs_def1. apply Rlt_trans with 0. destruct P; lra. apply Rabs_pos_lt ; assumption. @@ -1142,7 +1285,7 @@ assert (Main : Rabs ((f (x+h) - fn N (x+h)) - (f x - fn N x) + (fn N (x+h) - fn rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite <- Rmult_plus_distr_l. replace (Rabs h * eps / 4 + (Rabs h * eps / 4 + Rabs h * (eps / 8 + eps / 8))) with (Rabs h * (eps / 4 + eps / 4 + eps / 8 + eps / 8)) by field. - apply Rmult_lt_compat_l. + apply Rmult_lt_compat_l. apply Rabs_pos_lt ; assumption. lra. assert (H := pr1 c P) ; elim H ; clear H ; intros l Hl. @@ -1211,7 +1354,7 @@ assert (Main : Rabs ((f (x+h) - fn N (x+h)) - (f x - fn N x) + (fn N (x+h) - fn Rabs h * Rabs (fn' N c - g c) + Rabs h * Rabs (g c - g x)). rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ; apply Rplus_le_compat_l ; apply Rplus_le_compat_l ; - rewrite <- Rmult_plus_distr_l ; apply Rmult_le_compat_l. + rewrite <- Rmult_plus_distr_l ; apply Rmult_le_compat_l. solve[apply Rabs_pos]. solve[apply Rabs_triang]. apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + @@ -1247,7 +1390,7 @@ assert (Main : Rabs ((f (x+h) - fn N (x+h)) - (f x - fn N x) + (fn N (x+h) - fn rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite <- Rmult_plus_distr_l. replace (Rabs h * eps / 4 + (Rabs h * eps / 4 + Rabs h * (eps / 8 + eps / 8))) with (Rabs h * (eps / 4 + eps / 4 + eps / 8 + eps / 8)) by field. - apply Rmult_lt_compat_l. + apply Rmult_lt_compat_l. apply Rabs_pos_lt ; assumption. lra. assert (H := pr1 c P) ; elim H ; clear H ; intros l Hl. @@ -1270,7 +1413,7 @@ assert (Main : Rabs ((f (x+h) - fn N (x+h)) - (f x - fn N x) + (fn N (x+h) - fn apply uniqueness_limite with (f:= fn N) (x:=c) ; assumption. rewrite Main ; reflexivity. reflexivity. - replace ((f (x + h) - f x) / h - g x) with ((/h) * ((f (x + h) - f x) - h * g x)). + replace ((f (x + h) - f x) / h - g x) with ((/h) * ((f (x + h) - f x) - h * g x)). rewrite Rabs_mult ; rewrite Rabs_Rinv. replace eps with (/ Rabs h * (Rabs h * eps)). apply Rmult_lt_compat_l. diff --git a/theories/Reals/Ratan.v b/theories/Reals/Ratan.v index a6d053b80d..361bea6e85 100644 --- a/theories/Reals/Ratan.v +++ b/theories/Reals/Ratan.v @@ -12,6 +12,7 @@ Require Import Lra. Require Import Rbase. Require Import PSeries_reg. Require Import Rtrigo1. +Require Import Rtrigo_facts. Require Import Ranalysis_reg. Require Import Rfunctions. Require Import AltSeries. @@ -24,26 +25,21 @@ Require Import Lia. Local Open Scope R_scope. -(** Tools *) +(*********************************************************) +(** * Preliminaries *) +(*********************************************************) -Lemma Ropp_div : forall x y, -x/y = -(x/y). -Proof. -intros x y; unfold Rdiv; rewrite <-Ropp_mult_distr_l_reverse; reflexivity. -Qed. - -Definition pos_half_prf : 0 < /2. -Proof. lra. Qed. +(** ** Various generic lemmas which probably should go somewhere else *) -Definition pos_half := mkposreal (/2) pos_half_prf. - -Lemma Boule_half_to_interval : - forall x , Boule (/2) pos_half x -> 0 <= x <= 1. +Lemma Boule_half_to_interval : forall x, + Boule (/2) posreal_half x -> 0 <= x <= 1. Proof. -unfold Boule, pos_half; simpl. +unfold Boule, posreal_half; simpl. intros x b; apply Rabs_def2 in b; destruct b; split; lra. Qed. -Lemma Boule_lt : forall c r x, Boule c r x -> Rabs x < Rabs c + r. +Lemma Boule_lt : forall c r x, + Boule c r x -> Rabs x < Rabs c + r. Proof. unfold Boule; intros c r x h. apply Rabs_def2 in h; destruct h; apply Rabs_def1; @@ -52,9 +48,10 @@ apply Rabs_def2 in h; destruct h; apply Rabs_def1; Qed. (* The following lemma does not belong here. *) -Lemma Un_cv_ext : - forall un vn, (forall n, un n = vn n) -> - forall l, Un_cv un l -> Un_cv vn l. +Lemma Un_cv_ext : forall un vn, + (forall n, un n = vn n) -> + forall l, Un_cv un l -> + Un_cv vn l. Proof. intros un vn quv l P eps ep; destruct (P eps ep) as [N Pn]; exists N. intro n; rewrite <- quv; apply Pn. @@ -62,7 +59,7 @@ Qed. (* The following two lemmas are general purposes about alternated series. They do not belong here. *) -Lemma Alt_first_term_bound :forall f l N n, +Lemma Alt_first_term_bound : forall f l N n, Un_decreasing f -> Un_cv f 0 -> Un_cv (sum_f_R0 (tg_alt f)) l -> (N <= n)%nat -> @@ -87,7 +84,7 @@ intros [ | N] Npos n decr to0 cv nN. (sum_f_R0 (tg_alt (fun i => ((-1) ^ S N * f(S N + i)%nat)))) (l - sum_f_R0 (tg_alt f) N)). intros eps ep; destruct (cv eps ep) as [M PM]; exists M. - intros n' nM. + intros n' nM. match goal with |- ?C => set (U := C) end. assert (nM' : (n' + S N >= M)%nat) by lia. generalize (PM _ nM'); unfold R_dist. @@ -102,7 +99,7 @@ intros [ | N] Npos n decr to0 cv nN. lia. assert (cv'' : Un_cv (sum_f_R0 (tg_alt (fun i => f (S N + i)%nat))) ((-1) ^ S N * (l - sum_f_R0 (tg_alt f) N))). - apply (Un_cv_ext (fun n => (-1) ^ S N * + apply (Un_cv_ext (fun n => (-1) ^ S N * sum_f_R0 (tg_alt (fun i : nat => (-1) ^ S N * f (S N + i)%nat)) n)). intros n0; rewrite scal_sum; apply sum_eq; intros i _. unfold tg_alt; ring_simplify; replace (((-1) ^ S N) ^ 2) with 1. @@ -122,7 +119,7 @@ intros [ | N] Npos n decr to0 cv nN. assert (t := decreasing_prop _ _ _ (CV_ALT_step1 f decr) dist). apply Rle_trans with (sum_f_R0 (tg_alt f) (2 * p) - l). unfold Rminus; apply Rplus_le_compat_r; exact t. - match goal with _ : ?a <= l, _ : l <= ?b |- _ => + match goal with _ : ?a <= l, _ : l <= ?b |- _ => replace (f (S (2 * p))) with (b - a) by (rewrite tech5; unfold tg_alt; rewrite pow_1_odd; ring); lra end. @@ -171,15 +168,15 @@ solve[apply decr]. Qed. Lemma Alt_CVU : forall (f : nat -> R -> R) g h c r, - (forall x, Boule c r x ->Un_decreasing (fun n => f n x)) -> + (forall x, Boule c r x ->Un_decreasing (fun n => f n x)) -> (forall x, Boule c r x -> Un_cv (fun n => f n x) 0) -> - (forall x, Boule c r x -> + (forall x, Boule c r x -> Un_cv (sum_f_R0 (tg_alt (fun i => f i x))) (g x)) -> (forall x n, Boule c r x -> f n x <= h n) -> (Un_cv h 0) -> CVU (fun N x => sum_f_R0 (tg_alt (fun i => f i x)) N) g c r. Proof. -intros f g h c r decr to0 to_g bound bound0 eps ep. +intros f g h c r decr to0 to_g bound bound0 eps ep. assert (ep' : 0 <eps/2) by lra. destruct (bound0 _ ep) as [N Pn]; exists N. intros n y nN dy. @@ -192,10 +189,10 @@ generalize (Pn _ nN); unfold R_dist; rewrite Rminus_0_r; intros t. apply Rabs_def2 in t; tauto. Qed. -(* The following lemmas are general purpose lemmas about squares. +(* The following lemmas are general purpose lemmas about squares. They do not belong here *) -Lemma pow2_ge_0 : forall x, 0 <= x ^ 2. +Lemma pow2_ge_0 : forall x, 0 <= x^2. Proof. intros x; destruct (Rle_lt_dec 0 x). replace (x ^ 2) with (x * x) by field. @@ -204,26 +201,29 @@ intros x; destruct (Rle_lt_dec 0 x). apply Rmult_le_pos; lra. Qed. -Lemma pow2_abs : forall x, Rabs x ^ 2 = x ^ 2. +Lemma pow2_abs : forall x, Rabs x^2 = x^2. Proof. intros x; destruct (Rle_lt_dec 0 x). rewrite Rabs_pos_eq;[field | assumption]. rewrite <- Rabs_Ropp, Rabs_pos_eq;[field | lra]. Qed. -(** * Properties of tangent *) +(** ** Properties of tangent *) + +(** *** Derivative of tangent *) -Lemma derivable_pt_tan : forall x, -PI/2 < x < PI/2 -> derivable_pt tan x. +Lemma derivable_pt_tan : forall x, -PI/2 < x < PI/2 -> + derivable_pt tan x. Proof. intros x xint. - unfold derivable_pt, tan. + unfold derivable_pt, tan. apply derivable_pt_div ; [reg | reg | ]. apply Rgt_not_eq. unfold Rgt ; apply cos_gt_0; [unfold Rdiv; rewrite <- Ropp_mult_distr_l_reverse; fold (-PI/2) |];tauto. Qed. -Lemma derive_pt_tan : forall (x:R), +Lemma derive_pt_tan : forall x, forall (Pr1: -PI/2 < x < PI/2), derive_pt tan x (derivable_pt_tan x Pr1) = 1 + (tan x)^2. Proof. @@ -233,15 +233,15 @@ assert (cos x <> 0). unfold tan; reg; unfold pow, Rsqr; field; assumption. Qed. -(** Proof that tangent is a bijection *) +(** *** Proof that tangent is a bijection *) + (* to be removed? *) -Lemma derive_increasing_interv : - forall (a b:R) (f:R -> R), - a < b -> - forall (pr:forall x, a < x < b -> derivable_pt f x), - (forall t:R, forall (t_encad : a < t < b), 0 < derive_pt f t (pr t t_encad)) -> - forall x y:R, a < x < b -> a < y < b -> x < y -> f x < f y. +Lemma derive_increasing_interv : forall (a b : R) (f : R -> R), + a < b -> + forall (pr:forall x, a < x < b -> derivable_pt f x), + (forall t:R, forall (t_encad : a < t < b), 0 < derive_pt f t (pr t t_encad)) -> + forall x y:R, a < x < b -> a < y < b -> x < y -> f x < f y. Proof. intros a b f a_lt_b pr Df_gt_0 x y x_encad y_encad x_lt_y. assert (derivable_id_interv : forall c : R, x < c < y -> derivable_pt id c). @@ -255,7 +255,7 @@ intros a b f a_lt_b pr Df_gt_0 x y x_encad y_encad x_lt_y. apply Rlt_le_trans with (r2:=x) ; [exact (proj1 x_encad) | exact (proj1 c_encad)]. apply Rle_lt_trans with (r2:=y) ; [ exact (proj2 c_encad) | exact (proj2 y_encad)]. assert (id_cont_interv : forall c : R, x <= c <= y -> continuity_pt id c). - intros ; apply derivable_continuous_pt ; apply derivable_pt_id. + intros ; apply derivable_continuous_pt ; apply derivable_pt_id. elim (MVT f id x y derivable_f_interv derivable_id_interv x_lt_y f_cont_interv id_cont_interv). intros c Temp ; elim Temp ; clear Temp ; intros Pr eq. replace (id y - id x) with (y - x) in eq by intuition. @@ -296,8 +296,7 @@ Qed. (* The following lemmas about PI should probably be in Rtrigo. *) -Lemma PI2_lower_bound : - forall x, 0 < x < 2 -> 0 < cos x -> x < PI/2. +Lemma PI2_lower_bound : forall x, 0 < x < 2 -> 0 < cos x -> x < PI/2. Proof. intros x [xp xlt2] cx. destruct (Rtotal_order x (PI/2)) as [xltpi2 | [xeqpi2 | xgtpi2]]. @@ -305,7 +304,7 @@ destruct (Rtotal_order x (PI/2)) as [xltpi2 | [xeqpi2 | xgtpi2]]. now case (Rgt_not_eq _ _ cx); rewrite xeqpi2, cos_PI2. destruct (MVT_cor1 cos (PI/2) x derivable_cos xgtpi2) as [c [Pc [cint1 cint2]]]. -revert Pc; rewrite cos_PI2, Rminus_0_r. +revert Pc; rewrite cos_PI2, Rminus_0_r. rewrite <- (pr_nu cos c (derivable_pt_cos c)), derive_pt_cos. assert (0 < c < 2) by (split; assert (t := PI2_RGT_0); lra). assert (0 < sin c) by now apply sin_pos_tech. @@ -330,18 +329,16 @@ Qed. Lemma PI2_1 : 1 < PI/2. Proof. assert (t := PI2_3_2); lra. Qed. -Lemma tan_increasing : - forall x y:R, - -PI/2 < x -> - x < y -> - y < PI/2 -> tan x < tan y. +Lemma tan_increasing : forall x y, + -PI/2 < x -> x < y -> y < PI/2 -> + tan x < tan y. Proof. intros x y Z_le_x x_lt_y y_le_1. assert (x_encad : -PI/2 < x < PI/2). split ; [assumption | apply Rlt_trans with (r2:=y) ; assumption]. assert (y_encad : -PI/2 < y < PI/2). split ; [apply Rlt_trans with (r2:=x) ; intuition | intuition ]. - assert (local_derivable_pt_tan : forall x : R, -PI/2 < x < PI/2 -> + assert (local_derivable_pt_tan : forall x, -PI/2 < x < PI/2 -> derivable_pt tan x). intros ; apply derivable_pt_tan ; intuition. apply derive_increasing_interv with (a:=-PI/2) (b:=PI/2) (pr:=local_derivable_pt_tan) ; intuition. @@ -352,8 +349,11 @@ intros x y Z_le_x x_lt_y y_le_1. apply plus_Rsqr_gt_0. Qed. -Lemma tan_is_inj : forall x y, -PI/2 < x < PI/2 -> -PI/2 < y < PI/2 -> - tan x = tan y -> x = y. + +Lemma tan_inj : forall x y, + -PI/2 < x < PI/2 -> -PI/2 < y < PI/2 -> + tan x = tan y -> + x = y. Proof. intros a b a_encad b_encad fa_eq_fb. case(total_order_T a b). @@ -366,9 +366,12 @@ Proof. case (Rlt_not_eq (tan b) (tan a)) ; [|symmetry] ; assumption. Qed. -Lemma exists_atan_in_frame : - forall lb ub y, lb < ub -> -PI/2 < lb -> ub < PI/2 -> - tan lb < y < tan ub -> {x | lb < x < ub /\ tan x = y}. +Notation tan_is_inj := tan_inj (only parsing). (* compat *) + +Lemma exists_atan_in_frame : forall lb ub y, + lb < ub -> -PI/2 < lb -> ub < PI/2 -> + tan lb < y < tan ub -> + {x | lb < x < ub /\ tan x = y}. Proof. intros lb ub y lb_lt_ub lb_cond ub_cond y_encad. case y_encad ; intros y_encad1 y_encad2. @@ -384,9 +387,9 @@ intros lb ub y lb_lt_ub lb_cond ub_cond y_encad. assumption. intros x x_cond. replace (tan x - y - (tan a - y)) with (tan x - tan a) by field. exact (Temp x x_cond). - assert (H1 : (fun x : R => tan x - y) lb < 0). + assert (H1 : (fun x => tan x - y) lb < 0). apply Rlt_minus. assumption. - assert (H2 : 0 < (fun x : R => tan x - y) ub). + assert (H2 : 0 < (fun x => tan x - y) ub). apply Rgt_minus. assumption. destruct (IVT_interv (fun x => tan x - y) lb ub Cont lb_lt_ub H1 H2) as (x,Hx). exists x. @@ -409,7 +412,12 @@ intros lb ub y lb_lt_ub lb_cond ub_cond y_encad. case H4 ; intuition. Qed. -(** * Definition of arctangent as the reciprocal function of tangent and proof of this status *) +(*********************************************************) +(** * Definition of arctangent *) +(*********************************************************) + +(** ** Definition of arctangent as the reciprocal function of tangent and proof of this status *) + Lemma tan_1_gt_1 : tan 1 > 1. Proof. assert (0 < cos 1) by (apply cos_gt_0; assert (t:=PI2_1); lra). @@ -516,7 +524,7 @@ split. apply Rgt_not_eq; assumption. unfold tan. set (u' := PI / 2); unfold Rdiv; apply Rmult_lt_compat_r; unfold u'. - apply Rinv_0_lt_compat. + apply Rinv_0_lt_compat. rewrite cos_shift; assumption. assert (vlt3 : u < /4). replace (/4) with (/2 * /2) by field. @@ -565,25 +573,31 @@ Qed. Definition atan x := let (v, _) := pre_atan x in v. -Lemma atan_bound : forall x, -PI/2 < atan x < PI/2. +Lemma atan_bound : forall x, + -PI/2 < atan x < PI/2. Proof. intros x; unfold atan; destruct (pre_atan x) as [v [int _]]; exact int. Qed. -Lemma atan_right_inv : forall x, tan (atan x) = x. +Lemma tan_atan : forall x, + tan (atan x) = x. Proof. intros x; unfold atan; destruct (pre_atan x) as [v [_ q]]; exact q. Qed. -Lemma atan_opp : forall x, atan (- x) = - atan x. +Notation atan_right_inv := tan_atan (only parsing). (* compat *) + +Lemma atan_opp : forall x, + atan (- x) = - atan x. Proof. intros x; generalize (atan_bound (-x)); rewrite Ropp_div;intros [a b]. generalize (atan_bound x); rewrite Ropp_div; intros [c d]. -apply tan_is_inj; try rewrite Ropp_div; try split; try lra. -rewrite tan_neg, !atan_right_inv; reflexivity. +apply tan_inj; try rewrite Ropp_div; try split; try lra. +rewrite tan_neg, !tan_atan; reflexivity. Qed. -Lemma derivable_pt_atan : forall x, derivable_pt atan x. +Lemma derivable_pt_atan : forall x, + derivable_pt atan x. Proof. intros x. destruct (frame_tan x) as [ub [[ub0 ubpi] P]]. @@ -591,22 +605,22 @@ assert (lb_lt_ub : -ub < ub) by apply pos_opp_lt, ub0. assert (xint : tan(-ub) < x < tan ub). assert (xint' : x < tan ub /\ -(tan ub) < x) by apply Rabs_def2, P. rewrite tan_neg; tauto. -assert (inv_p : forall x, tan(-ub) <= x -> x <= tan ub -> +assert (inv_p : forall x, tan(-ub) <= x -> x <= tan ub -> comp tan atan x = id x). - intros; apply atan_right_inv. + intros; apply tan_atan. assert (int_tan : forall y, tan (- ub) <= y -> y <= tan ub -> -ub <= atan y <= ub). clear -ub0 ubpi; intros y lo up; split. destruct (Rle_lt_dec (-ub) (atan y)) as [h | abs]; auto. assert (y < tan (-ub)). - rewrite <- (atan_right_inv y); apply tan_increasing. + rewrite <- (tan_atan y); apply tan_increasing. destruct (atan_bound y); assumption. assumption. lra. lra. destruct (Rle_lt_dec (atan y) ub) as [h | abs]; auto. assert (tan ub < y). - rewrite <- (atan_right_inv y); apply tan_increasing. + rewrite <- (tan_atan y); apply tan_increasing. rewrite Ropp_div; lra. assumption. destruct (atan_bound y); assumption. @@ -620,8 +634,8 @@ assert (der : forall a, -ub <= a <= ub -> derivable_pt tan a). intros a [la ua]; apply derivable_pt_tan. rewrite Ropp_div; split; lra. assert (df_neq : derive_pt tan (atan x) - (derivable_pt_recip_interv_prelim1 tan atan - (- ub) ub x lb_lt_ub xint inv_p int_tan incr der) <> 0). + (derivable_pt_recip_interv_prelim1 tan atan + (- ub) ub x lb_lt_ub xint int_tan der) <> 0). rewrite <- (pr_nu tan (atan x) (derivable_pt_tan (atan x) (atan_bound x))). rewrite derive_pt_tan. @@ -631,7 +645,8 @@ apply (derivable_pt_recip_interv tan atan (-ub) ub x exact df_neq. Qed. -Lemma atan_increasing : forall x y, x < y -> atan x < atan y. +Lemma atan_increasing : forall x y, + x < y -> atan x < atan y. Proof. intros x y d. assert (t1 := atan_bound x). @@ -640,7 +655,7 @@ destruct (Rlt_le_dec (atan x) (atan y)) as [lt | bad]. assumption. apply Rlt_not_le in d. case d. -rewrite <- (atan_right_inv y), <- (atan_right_inv x). +rewrite <- (tan_atan y), <- (tan_atan x). destruct bad as [ylt | yx]. apply Rlt_le, tan_increasing; try tauto. solve[rewrite yx; apply Rle_refl]. @@ -648,26 +663,80 @@ Qed. Lemma atan_0 : atan 0 = 0. Proof. -apply tan_is_inj; try (apply atan_bound). +apply tan_inj; try (apply atan_bound). assert (t := PI_RGT_0); rewrite Ropp_div; split; lra. -rewrite atan_right_inv, tan_0. +rewrite tan_atan, tan_0. reflexivity. Qed. +Lemma atan_eq0 : forall x, + atan x = 0 -> x = 0. +Proof. +intros x. +generalize (atan_increasing 0 x) (atan_increasing x 0). +rewrite atan_0. +lra. +Qed. + Lemma atan_1 : atan 1 = PI/4. Proof. assert (ut := PI_RGT_0). assert (-PI/2 < PI/4 < PI/2) by (rewrite Ropp_div; split; lra). assert (t := atan_bound 1). -apply tan_is_inj; auto. -rewrite tan_PI4, atan_right_inv; reflexivity. +apply tan_inj; auto. +rewrite tan_PI4, tan_atan; reflexivity. Qed. -(** atan's derivative value is the function 1 / (1+x²) *) +Lemma atan_tan : forall x, - (PI / 2) < x < PI / 2 -> + atan (tan x) = x. +Proof. +intros x xB. +apply tan_inj. +- now apply atan_bound. +- lra. +- now apply tan_atan. +Qed. + +Lemma atan_inv : forall x, (0 < x)%R -> + atan (/ x) = (PI / 2 - atan x)%R. +Proof. +intros x Hx. +apply tan_inj. +- apply atan_bound. +- split. + + apply Rlt_trans with R0. + * unfold Rdiv. + rewrite Ropp_mult_distr_l_reverse. + apply Ropp_lt_gt_0_contravar. + apply PI2_RGT_0. + * apply Rgt_minus. + apply atan_bound. + + apply Rplus_lt_reg_r with (atan x - PI / 2)%R. + ring_simplify. + rewrite <- atan_0. + now apply atan_increasing. +- rewrite tan_atan. + unfold tan. + rewrite sin_shift. + rewrite cos_shift. + rewrite <- Rinv_Rdiv. + + apply f_equal, sym_eq, tan_atan. + + apply Rgt_not_eq, sin_gt_0. + * rewrite <- atan_0. + now apply atan_increasing. + * apply Rlt_trans with (2 := PI2_Rlt_PI). + apply atan_bound. + + apply Rgt_not_eq, cos_gt_0. + unfold Rdiv. + rewrite <- Ropp_mult_distr_l_reverse. + apply atan_bound. + apply atan_bound. +Qed. + +(** ** Derivative of arctangent *) Lemma derive_pt_atan : forall x, - derive_pt atan x (derivable_pt_atan x) = - 1 / (1 + x²). + derive_pt atan x (derivable_pt_atan x) = 1 / (1 + x²). Proof. intros x. destruct (frame_tan x) as [ub [[ub0 ubpi] Pub]]. @@ -675,22 +744,22 @@ assert (lb_lt_ub : -ub < ub) by apply pos_opp_lt, ub0. assert (xint : tan(-ub) < x < tan ub). assert (xint' : x < tan ub /\ -(tan ub) < x) by apply Rabs_def2, Pub. rewrite tan_neg; tauto. -assert (inv_p : forall x, tan(-ub) <= x -> x <= tan ub -> +assert (inv_p : forall x, tan(-ub) <= x -> x <= tan ub -> comp tan atan x = id x). - intros; apply atan_right_inv. + intros; apply tan_atan. assert (int_tan : forall y, tan (- ub) <= y -> y <= tan ub -> -ub <= atan y <= ub). clear -ub0 ubpi; intros y lo up; split. destruct (Rle_lt_dec (-ub) (atan y)) as [h | abs]; auto. assert (y < tan (-ub)). - rewrite <- (atan_right_inv y); apply tan_increasing. + rewrite <- (tan_atan y); apply tan_increasing. destruct (atan_bound y); assumption. assumption. lra. lra. destruct (Rle_lt_dec (atan y) ub) as [h | abs]; auto. assert (tan ub < y). - rewrite <- (atan_right_inv y); apply tan_increasing. + rewrite <- (tan_atan y); apply tan_increasing. rewrite Ropp_div; lra. assumption. destruct (atan_bound y); assumption. @@ -704,8 +773,8 @@ assert (der : forall a, -ub <= a <= ub -> derivable_pt tan a). intros a [la ua]; apply derivable_pt_tan. rewrite Ropp_div; split; lra. assert (df_neq : derive_pt tan (atan x) - (derivable_pt_recip_interv_prelim1 tan atan - (- ub) ub x lb_lt_ub xint inv_p int_tan incr der) <> 0). + (derivable_pt_recip_interv_prelim1 tan atan + (- ub) ub x lb_lt_ub xint int_tan der) <> 0). rewrite <- (pr_nu tan (atan x) (derivable_pt_tan (atan x) (atan_bound x))). rewrite derive_pt_tan. @@ -716,14 +785,14 @@ rewrite <- (pr_nu atan x (derivable_pt_recip_interv tan atan (- ub) ub x lb_lt_ub xint inv_p int_tan incr der df_neq)). rewrite t. assert (t' := atan_bound x). -rewrite <- (pr_nu tan (atan x) (derivable_pt_tan _ t')). -rewrite derive_pt_tan, atan_right_inv. +rewrite <- (pr_nu tan (atan x) (derivable_pt_tan _ t')). +rewrite derive_pt_tan, tan_atan. replace (Rsqr x) with (x ^ 2) by (unfold Rsqr; ring). reflexivity. Qed. -Lemma derivable_pt_lim_atan : - forall x, derivable_pt_lim atan x (/(1 + x^2)). +Lemma derivable_pt_lim_atan : forall x, + derivable_pt_lim atan x (/ (1 + x^2)). Proof. intros x. apply derive_pt_eq_1 with (derivable_pt_atan x). @@ -732,12 +801,14 @@ rewrite <- (Rmult_1_l (Rinv _)). apply derive_pt_atan. Qed. -(** * Definition of the arctangent function as the sum of the arctan power series *) +(** ** Definition of the arctangent function as the sum of the arctan power series *) + (* Proof taken from Guillaume Melquiond's interval package for Coq *) Definition Ratan_seq x := fun n => (x ^ (2 * n + 1) / INR (2 * n + 1))%R. -Lemma Ratan_seq_decreasing : forall x, (0 <= x <= 1)%R -> Un_decreasing (Ratan_seq x). +Lemma Ratan_seq_decreasing : forall x, (0 <= x <= 1)%R -> + Un_decreasing (Ratan_seq x). Proof. intros x Hx n. unfold Ratan_seq, Rdiv. @@ -780,7 +851,8 @@ intros x Hx n. lia. Qed. -Lemma Ratan_seq_converging : forall x, (0 <= x <= 1)%R -> Un_cv (Ratan_seq x) 0. +Lemma Ratan_seq_converging : forall x, (0 <= x <= 1)%R -> + Un_cv (Ratan_seq x) 0. Proof. intros x Hx eps Heps. destruct (archimed (/ eps)) as (HN,_). @@ -858,18 +930,18 @@ exact (alternated_series (Ratan_seq x) (Ratan_seq_decreasing _ Hx) (Ratan_seq_converging _ Hx)). Defined. -Lemma Ratan_seq_opp : forall x n, Ratan_seq (-x) n = -Ratan_seq x n. +Lemma Ratan_seq_opp : forall x n, + Ratan_seq (-x) n = -Ratan_seq x n. Proof. intros x n; unfold Ratan_seq. rewrite !pow_add, !pow_mult, !pow_1. unfold Rdiv; replace ((-x) ^ 2) with (x ^ 2) by ring; ring. Qed. -Lemma sum_Ratan_seq_opp : - forall x n, sum_f_R0 (tg_alt (Ratan_seq (- x))) n = - - sum_f_R0 (tg_alt (Ratan_seq x)) n. +Lemma sum_Ratan_seq_opp : forall x n, + sum_f_R0 (tg_alt (Ratan_seq (- x))) n = - sum_f_R0 (tg_alt (Ratan_seq x)) n. Proof. -intros x n; replace (-sum_f_R0 (tg_alt (Ratan_seq x)) n) with +intros x n; replace (-sum_f_R0 (tg_alt (Ratan_seq x)) n) with (-1 * sum_f_R0 (tg_alt (Ratan_seq x)) n) by ring. rewrite scal_sum; apply sum_eq; intros i _; unfold tg_alt. rewrite Ratan_seq_opp; ring. @@ -906,7 +978,7 @@ Definition ps_atan (x : R) : R := | right h => atan x end. -(** * Proof of the equivalence of the two definitions between -1 and 1 *) +(** ** Proof of the equivalence of the two definitions between -1 and 1 *) Lemma ps_atan0_0 : ps_atan 0 = 0. Proof. @@ -923,15 +995,14 @@ unfold ps_atan. case h2; split; lra. Qed. -Lemma ps_atan_exists_1_opp : - forall x h h', proj1_sig (ps_atan_exists_1 (-x) h) = - -(proj1_sig (ps_atan_exists_1 x h')). +Lemma ps_atan_exists_1_opp : forall x h h', + proj1_sig (ps_atan_exists_1 (-x) h) = -(proj1_sig (ps_atan_exists_1 x h')). Proof. intros x h h'; destruct (ps_atan_exists_1 (-x) h) as [v Pv]. destruct (ps_atan_exists_1 x h') as [u Pu]; simpl. assert (Pu' : Un_cv (fun N => (-1) * sum_f_R0 (tg_alt (Ratan_seq x)) N) (-1 * u)). apply CV_mult;[ | assumption]. - intros eps ep; exists 0%nat; intros; rewrite R_dist_eq; assumption. + intros eps ep; exists 0%nat; intros; rewrite R_dist_eq; assumption. assert (Pv' : Un_cv (fun N : nat => -1 * sum_f_R0 (tg_alt (Ratan_seq x)) N) v). apply Un_cv_ext with (2 := Pv); intros n; rewrite sum_Ratan_seq_opp; ring. @@ -939,7 +1010,8 @@ replace (-u) with (-1 * u) by ring. apply UL_sequence with (1:=Pv') (2:= Pu'). Qed. -Lemma ps_atan_opp : forall x, ps_atan (-x) = -ps_atan x. +Lemma ps_atan_opp : forall x, + ps_atan (-x) = -ps_atan x. Proof. intros x; unfold ps_atan. destruct (in_int (- x)) as [inside | outside]. @@ -954,10 +1026,9 @@ Qed. (** atan = ps_atan *) -Lemma ps_atanSeq_continuity_pt_1 : forall (N:nat) (x:R), - 0 <= x -> - x <= 1 -> - continuity_pt (fun x => sum_f_R0 (tg_alt (Ratan_seq x)) N) x. +Lemma ps_atanSeq_continuity_pt_1 : forall (N : nat) (x : R), + 0 <= x -> x <= 1 -> + continuity_pt (fun x => sum_f_R0 (tg_alt (Ratan_seq x)) N) x. Proof. assert (Sublemma : forall (x:R) (N:nat), sum_f_R0 (tg_alt (Ratan_seq x)) N = x * (comp (fun x => sum_f_R0 (fun n => (fun i : nat => (-1) ^ i / INR (2 * i + 1)) n * x ^ n) N) (fun x => x ^ 2) x)). intros x N. @@ -1020,10 +1091,11 @@ Qed. (** Definition of ps_atan's derivative *) -Definition Datan_seq := fun (x:R) (n:nat) => x ^ (2*n). +Definition Datan_seq := fun (x : R) (n : nat) => x ^ (2*n). -Lemma pow_lt_1_compat : forall x n, 0 <= x < 1 -> (0 < n)%nat -> - 0 <= x ^ n < 1. +Lemma pow_lt_1_compat : forall x n, + 0 <= x < 1 -> (0 < n)%nat -> + 0 <= x ^ n < 1. Proof. intros x n hx; induction 1; simpl. rewrite Rmult_1_r; tauto. @@ -1032,12 +1104,14 @@ split. rewrite <- (Rmult_1_r 1); apply Rmult_le_0_lt_compat; intuition. Qed. -Lemma Datan_seq_Rabs : forall x n, Datan_seq (Rabs x) n = Datan_seq x n. +Lemma Datan_seq_Rabs : forall x n, + Datan_seq (Rabs x) n = Datan_seq x n. Proof. intros x n; unfold Datan_seq; rewrite !pow_mult, pow2_abs; reflexivity. Qed. -Lemma Datan_seq_pos : forall x n, 0 < x -> 0 < Datan_seq x n. +Lemma Datan_seq_pos : forall x n, 0 < x -> + 0 < Datan_seq x n. Proof. intros x n x_lb ; unfold Datan_seq ; induction n. simpl ; intuition. @@ -1063,7 +1137,9 @@ f_equal. ring. Qed. -Lemma Datan_seq_increasing : forall x y n, (n > 0)%nat -> 0 <= x < y -> Datan_seq x n < Datan_seq y n. +Lemma Datan_seq_increasing : forall x y n, + (n > 0)%nat -> 0 <= x < y -> + Datan_seq x n < Datan_seq y n. Proof. intros x y n n_lb x_encad ; assert (x_pos : x >= 0) by intuition. assert (y_pos : y > 0). apply Rle_lt_trans with (r2:=x) ; intuition. @@ -1086,7 +1162,8 @@ intros x y n n_lb x_encad ; assert (x_pos : x >= 0) by intuition. rewrite pow_i. intuition. lia. Qed. -Lemma Datan_seq_decreasing : forall x, -1 < x -> x < 1 -> Un_decreasing (Datan_seq x). +Lemma Datan_seq_decreasing : forall x, -1 < x -> x < 1 -> + Un_decreasing (Datan_seq x). Proof. intros x x_lb x_ub n. unfold Datan_seq. @@ -1103,7 +1180,8 @@ apply (pow_lt_1_compat (Rabs x) 2) in intabs. lia. Qed. -Lemma Datan_seq_CV_0 : forall x, -1 < x -> x < 1 -> Un_cv (Datan_seq x) 0. +Lemma Datan_seq_CV_0 : forall x, -1 < x -> x < 1 -> + Un_cv (Datan_seq x) 0. Proof. intros x x_lb x_ub eps eps_pos. assert (x_ub2 : Rabs (x^2) < 1). @@ -1119,7 +1197,7 @@ rewrite pow_mult ; field. Qed. Lemma Datan_lim : forall x, -1 < x -> x < 1 -> - Un_cv (fun N : nat => sum_f_R0 (tg_alt (Datan_seq x)) N) (/ (1 + x ^ 2)). + Un_cv (fun N : nat => sum_f_R0 (tg_alt (Datan_seq x)) N) (/ (1 + x ^ 2)). Proof. intros x x_lb x_ub eps eps_pos. assert (Tool0 : 0 <= x ^ 2) by apply pow2_ge_0. @@ -1132,14 +1210,14 @@ assert (x_ub2' : 0<= Rabs (x^2) < 1). apply pow_lt_1_compat;[split;[apply Rabs_pos | ] | lia]. apply Rabs_def1; assumption. assert (x_ub2 : Rabs (x^2) < 1) by tauto. -assert (eps'_pos : ((1+x^2)*eps) > 0). +assert (eps'_pos : ((1 + x^2)*eps) > 0). apply Rmult_gt_0_compat ; assumption. elim (pow_lt_1_zero _ x_ub2 _ eps'_pos) ; intros N HN ; exists N. intros n Hn. assert (H1 : - x^2 <> 1). apply Rlt_not_eq; apply Rle_lt_trans with (2 := Rlt_0_1). assert (t := pow2_ge_0 x); lra. -rewrite Datan_sum_eq. +rewrite Datan_sum_eq. unfold R_dist. assert (tool : forall a b, a / b - /b = (-1 + a) /b). intros a b; rewrite <- (Rmult_1_l (/b)); unfold Rdiv, Rminus. @@ -1158,7 +1236,7 @@ assert (tool : forall k, Rabs ((-x ^ 2) ^ k) = Rabs ((x ^ 2) ^ k)). rewrite tool, (Rabs_pos_eq (/ _)); clear tool;[ | apply Rlt_le; assumption]. assert (tool : forall a b c, 0 < b -> a < b * c -> a * / b < c). intros a b c bp h; replace c with (b * c * /b). - apply Rmult_lt_compat_r. + apply Rmult_lt_compat_r. apply Rinv_0_lt_compat; assumption. assumption. field; apply Rgt_not_eq; exact bp. @@ -1167,11 +1245,11 @@ apply HN; lia. Qed. Lemma Datan_CVU_prelim : forall c (r : posreal), Rabs c + r < 1 -> - CVU (fun N x => sum_f_R0 (tg_alt (Datan_seq x)) N) - (fun y : R => / (1 + y ^ 2)) c r. + CVU (fun N x => sum_f_R0 (tg_alt (Datan_seq x)) N) + (fun y : R => / (1 + y ^ 2)) c r. Proof. intros c r ub_ub eps eps_pos. -apply (Alt_CVU (fun x n => Datan_seq n x) +apply (Alt_CVU (fun x n => Datan_seq n x) (fun x => /(1 + x ^ 2)) (Datan_seq (Rabs c + r)) c r). intros x inb; apply Datan_seq_decreasing; @@ -1198,10 +1276,9 @@ apply (Alt_CVU (fun x n => Datan_seq n x) assumption. Qed. -Lemma Datan_is_datan : forall (N:nat) (x:R), - -1 <= x -> - x < 1 -> -derivable_pt_lim (fun x => sum_f_R0 (tg_alt (Ratan_seq x)) N) x (sum_f_R0 (tg_alt (Datan_seq x)) N). +Lemma Datan_is_datan : forall (N : nat) (x : R), + -1 <= x -> x < 1 -> + derivable_pt_lim (fun x => sum_f_R0 (tg_alt (Ratan_seq x)) N) x (sum_f_R0 (tg_alt (Datan_seq x)) N). Proof. assert (Tool : forall N, (-1) ^ (S (2 * N)) = - 1). intro n ; induction n. @@ -1218,20 +1295,20 @@ intros N x x_lb x_ub. intros eps eps_pos. elim (derivable_pt_lim_id x eps eps_pos) ; intros delta Hdelta ; exists delta. intros h hneq h_b. - replace (1 * ((x + h) * 1 / 1) - 1 * (x * 1 / 1)) with (id (x + h) - id x). + replace (1 * ((x + h) * 1 / 1) - 1 * (x * 1 / 1)) with (id (x + h) - id x). rewrite Rmult_1_r. apply Hdelta ; assumption. unfold id ; field ; assumption. intros eps eps_pos. assert (eps_3_pos : (eps/3) > 0) by lra. elim (IHN (eps/3) eps_3_pos) ; intros delta1 Hdelta1. - assert (Main : derivable_pt_lim (fun x : R =>tg_alt (Ratan_seq x) (S N)) x ((tg_alt (Datan_seq x)) (S N))). + assert (Main : derivable_pt_lim (fun x =>tg_alt (Ratan_seq x) (S N)) x ((tg_alt (Datan_seq x)) (S N))). clear -Tool ; intros eps' eps'_pos. elim (derivable_pt_lim_pow x (2 * (S N) + 1) eps' eps'_pos) ; intros delta Hdelta ; exists delta. intros h h_neq h_b ; unfold tg_alt, Ratan_seq, Datan_seq. replace (((-1) ^ S N * ((x + h) ^ (2 * S N + 1) / INR (2 * S N + 1)) - (-1) ^ S N * (x ^ (2 * S N + 1) / INR (2 * S N + 1))) / h - - (-1) ^ S N * x ^ (2 * S N)) + (-1) ^ S N * x ^ (2 * S N)) with (((-1)^(S N)) * ((((x + h) ^ (2 * S N + 1) / INR (2 * S N + 1)) - (x ^ (2 * S N + 1) / INR (2 * S N + 1))) / h - x ^ (2 * S N))). rewrite Rabs_mult ; rewrite pow_1_abs ; rewrite Rmult_1_l. @@ -1299,9 +1376,9 @@ Qed. Lemma Ratan_CVU' : CVU (fun N x => sum_f_R0 (tg_alt (Ratan_seq x)) N) - ps_atan (/2) (mkposreal (/2) pos_half_prf). + ps_atan (/2) posreal_half. Proof. -apply (Alt_CVU (fun i r => Ratan_seq r i) ps_atan PI_tg (/2) pos_half); +apply (Alt_CVU (fun i r => Ratan_seq r i) ps_atan PI_tg (/2) posreal_half); lazy beta. now intros; apply Ratan_seq_decreasing, Boule_half_to_interval. now intros; apply Ratan_seq_converging, Boule_half_to_interval. @@ -1311,7 +1388,7 @@ apply (Alt_CVU (fun i r => Ratan_seq r i) ps_atan PI_tg (/2) pos_half); destruct (ps_atan_exists_1 x inside) as [v Pv]. apply Un_cv_ext with (2 := Pv);[reflexivity]. intros x n b; apply Boule_half_to_interval in b. - rewrite <- (Rmult_1_l (PI_tg n)); unfold Ratan_seq, PI_tg. + rewrite <- (Rmult_1_l (PI_tg n)); unfold Ratan_seq, PI_tg. apply Rmult_le_compat_r. apply Rlt_le, Rinv_0_lt_compat, (lt_INR 0); lia. rewrite <- (pow1 (2 * n + 1)); apply pow_incr; assumption. @@ -1320,12 +1397,12 @@ Qed. Lemma Ratan_CVU : CVU (fun N x => sum_f_R0 (tg_alt (Ratan_seq x)) N) - ps_atan 0 (mkposreal 1 Rlt_0_1). + ps_atan 0 (mkposreal 1 Rlt_0_1). Proof. intros eps ep; destruct (Ratan_CVU' eps ep) as [N Pn]. exists N; intros n x nN b_y. case (Rtotal_order 0 x) as [xgt0 | [x0 | x0]]. - assert (Boule (/2) {| pos := / 2; cond_pos := pos_half_prf|} x). + assert (Boule (/2) posreal_half x). revert b_y; unfold Boule; simpl; intros b_y; apply Rabs_def2 in b_y. destruct b_y; unfold Boule; simpl; apply Rabs_def1; lra. apply Pn; assumption. @@ -1338,7 +1415,7 @@ case (Rtotal_order 0 x) as [xgt0 | [x0 | x0]]. replace (ps_atan x - sum_f_R0 (tg_alt (Ratan_seq x)) n) with (-(ps_atan (-x) - sum_f_R0 (tg_alt (Ratan_seq (-x))) n)). rewrite Rabs_Ropp. - assert (Boule (/2) {| pos := / 2; cond_pos := pos_half_prf|} (-x)). + assert (Boule (/2) posreal_half (-x)). revert b_y; unfold Boule; simpl; intros b_y; apply Rabs_def2 in b_y. destruct b_y; unfold Boule; simpl; apply Rabs_def1; lra. apply Pn; assumption. @@ -1353,8 +1430,8 @@ reflexivity. Qed. Lemma Ratan_is_ps_atan : forall eps, eps > 0 -> - exists N, forall n, (n >= N)%nat -> forall x, -1 < x -> x < 1 -> - Rabs (sum_f_R0 (tg_alt (Ratan_seq x)) n - ps_atan x) < eps. + exists N, forall n, (n >= N)%nat -> forall x, -1 < x -> x < 1 -> + Rabs (sum_f_R0 (tg_alt (Ratan_seq x)) n - ps_atan x) < eps. Proof. intros eps ep. destruct (Ratan_CVU _ ep) as [N1 PN1]. @@ -1363,7 +1440,7 @@ apply PN1; [assumption | ]. unfold Boule; simpl; rewrite Rminus_0_r; apply Rabs_def1; assumption. Qed. -Lemma Datan_continuity : continuity (fun x => /(1+x ^ 2)). +Lemma Datan_continuity : continuity (fun x => /(1 + x^2)). Proof. apply continuity_inv. apply continuity_plus. @@ -1383,7 +1460,7 @@ intros x x_encad. destruct (boule_in_interval (-1) 1 x x_encad) as [c [r [Pcr1 [P1 P2]]]]. change (/ (1 + x ^ 2)) with ((fun u => /(1 + u ^ 2)) x). assert (t := derivable_pt_lim_CVU). -apply derivable_pt_lim_CVU with +apply derivable_pt_lim_CVU with (fn := (fun N x => sum_f_R0 (tg_alt (Ratan_seq x)) N)) (fn' := (fun N x => sum_f_R0 (tg_alt (Datan_seq x)) N)) (c := c) (r := r). @@ -1408,19 +1485,17 @@ apply derivable_pt_lim_CVU with intros; apply Datan_continuity. Qed. -Lemma derivable_pt_ps_atan : - forall x, -1 < x < 1 -> derivable_pt ps_atan x. +Lemma derivable_pt_ps_atan : forall x, -1 < x < 1 -> + derivable_pt ps_atan x. Proof. intros x x_encad. -exists (/(1+x^2)) ; apply derivable_pt_lim_ps_atan; assumption. +exists (/(1 + x^2)) ; apply derivable_pt_lim_ps_atan; assumption. Qed. Lemma ps_atan_continuity_pt_1 : forall eps : R, - eps > 0 -> - exists alp : R, - alp > 0 /\ - (forall x, x < 1 -> 0 < x -> R_dist x 1 < alp -> - dist R_met (ps_atan x) (Alt_PI/4) < eps). + eps > 0 -> + exists alp : R, alp > 0 /\ (forall x, x < 1 -> 0 < x -> R_dist x 1 < alp -> + dist R_met (ps_atan x) (Alt_PI/4) < eps). Proof. intros eps eps_pos. assert (eps_3_pos : eps / 3 > 0) by lra. @@ -1468,8 +1543,8 @@ ring. Qed. Lemma Datan_eq_DatanSeq_interv : forall x, -1 < x < 1 -> - forall (Pratan:derivable_pt ps_atan x) (Prmymeta:derivable_pt atan x), - derive_pt ps_atan x Pratan = derive_pt atan x Prmymeta. + forall (Pratan:derivable_pt ps_atan x) (Prmymeta:derivable_pt atan x), + derive_pt ps_atan x Pratan = derive_pt atan x Prmymeta. Proof. assert (freq : 0 < tan 1) by apply (Rlt_trans _ _ _ Rlt_0_1 tan_1_gt_1). intros x x_encad Pratan Prmymeta. @@ -1477,7 +1552,7 @@ intros x x_encad Pratan Prmymeta. (pr2 := derivable_pt_ps_atan x x_encad). rewrite pr_nu_var2_interv with (f:=atan) (g:=atan) (lb:=-1) (ub:= 1) (pr2:=derivable_pt_atan x). assert (Temp := derivable_pt_lim_ps_atan x x_encad). - assert (Hrew1 : derive_pt ps_atan x (derivable_pt_ps_atan x x_encad) = (/(1+x^2))). + assert (Hrew1 : derive_pt ps_atan x (derivable_pt_ps_atan x x_encad) = (/(1 + x^2))). apply derive_pt_eq_0 ; assumption. rewrite derive_pt_atan. rewrite Hrew1. @@ -1491,8 +1566,8 @@ intros x x_encad Pratan Prmymeta. intros; reflexivity. Qed. -Lemma atan_eq_ps_atan : - forall x, 0 < x < 1 -> atan x = ps_atan x. +Lemma atan_eq_ps_atan : forall x, 0 < x < 1 -> + atan x = ps_atan x. Proof. intros x x_encad. assert (pr1 : forall c : R, 0 < c < x -> derivable_pt (atan - ps_atan) c). @@ -1506,7 +1581,7 @@ assert (pr2 : forall c : R, 0 < c < x -> derivable_pt id c). assert (delta_cont : forall c : R, 0 <= c <= x -> continuity_pt (atan - ps_atan) c). intros c [[c_encad1 | c_encad1 ] [c_encad2 | c_encad2]]; apply continuity_pt_minus. - apply derivable_continuous_pt ; apply derivable_pt_atan. + apply derivable_continuous_pt ; apply derivable_pt_atan. apply derivable_continuous_pt ; apply derivable_pt_ps_atan. split; destruct x_encad; lra. apply derivable_continuous_pt, derivable_pt_atan. @@ -1532,20 +1607,20 @@ assert (Temp : forall (pr: derivable_pt (atan - ps_atan) d), derive_pt (atan - p unfold pr3. rewrite derive_pt_minus. rewrite Datan_eq_DatanSeq_interv with (Prmymeta := derivable_pt_atan d). intuition. - assumption. + assumption. destruct d_encad; lra. assumption. reflexivity. assert (iatan0 : atan 0 = 0). - apply tan_is_inj. + apply tan_inj. apply atan_bound. rewrite Ropp_div; assert (t := PI2_RGT_0); split; lra. - rewrite tan_0, atan_right_inv; reflexivity. + rewrite tan_0, tan_atan; reflexivity. generalize Main; rewrite Temp, Rmult_0_r. replace ((atan - ps_atan)%F x) with (atan x - ps_atan x) by intuition. replace ((atan - ps_atan)%F 0) with (atan 0 - ps_atan 0) by intuition. rewrite iatan0, ps_atan0_0, !Rminus_0_r. -replace (derive_pt id d (pr2 d d_encad)) with 1. +replace (derive_pt id d (pr2 d d_encad)) with 1. rewrite Rmult_1_r. solve[intros M; apply Rminus_diag_uniq; auto]. rewrite pr_nu_var with (g:=id) (pr2:=derivable_pt_id d). @@ -1553,7 +1628,6 @@ rewrite pr_nu_var with (g:=id) (pr2:=derivable_pt_id d). tauto. Qed. - Theorem Alt_PI_eq : Alt_PI = PI. Proof. apply Rmult_eq_reg_r with (/4); fold (Alt_PI/4); fold (PI/4); @@ -1585,7 +1659,7 @@ assert (Xa : exists a, 0 < a < 1 /\ R_dist a 1 < alpha /\ by (apply Rmax_lub_lt; lra). split;[split;[ | apply Rmax_lub_lt]; lra | ]. assert (0 <= 1 - Rmax (/ 2) (Rmax (1 - alpha / 2) (1 - beta / 2))). - assert (Rmax (/2) (Rmax (1 - alpha / 2) + assert (Rmax (/2) (Rmax (1 - alpha / 2) (1 - beta /2)) <= 1) by (apply Rmax_lub; lra). lra. split; unfold R_dist; rewrite <-Rabs_Ropp, Ropp_minus_distr, @@ -1602,10 +1676,504 @@ split;[exact I | apply Rgt_not_eq; assumption]. split; assumption. Qed. -Lemma PI_ineq : - forall N : nat, - sum_f_R0 (tg_alt PI_tg) (S (2 * N)) <= PI / 4 <= - sum_f_R0 (tg_alt PI_tg) (2 * N). +Lemma PI_ineq : forall N : nat, + sum_f_R0 (tg_alt PI_tg) (S (2 * N)) <= PI/4 <= sum_f_R0 (tg_alt PI_tg) (2 * N). Proof. intros; rewrite <- Alt_PI_eq; apply Alt_PI_ineq. Qed. + +(** ** Relation between arctangent and sine and cosine *) + +Lemma sin_atan: forall x, + sin (atan x) = x / sqrt (1 + x²). +Proof. +intros x. +pose proof (atan_right_inv x) as Hatan. +remember (atan(x)) as α. +rewrite <- Hatan. +apply sin_tan. +apply cos_gt_0. + all: pose proof atan_bound x; lra. +Qed. + +Lemma cos_atan: forall x, + cos (atan x) = 1 / sqrt(1 + x²). +Proof. + intros x. + pose proof (atan_right_inv x) as Hatan. + remember (atan(x)) as α. + rewrite <- Hatan. + apply cos_tan. + apply cos_gt_0. + all: pose proof atan_bound x; lra. +Qed. + +(*********************************************************) +(** * Definition of arcsine based on arctangent *) +(*********************************************************) + +(** asin is defined by cases so that it is defined in the full range from -1 .. 1 *) + +Definition asin x := + if Rle_dec x (-1) then - (PI / 2) else + if Rle_dec 1 x then PI / 2 else + atan (x / sqrt (1 - x²)). + +(** ** Relation between arcsin and arctangent *) + +Lemma asin_atan : forall x, -1 < x < 1 -> + asin x = atan (x / sqrt (1 - x²)). +Proof. +intros x. +unfold asin; repeat case Rle_dec; intros; lra. +Qed. + +(** ** arcsine of specific values *) + +Lemma asin_0 : asin 0 = 0. +Proof. +unfold asin; repeat case Rle_dec; intros; try lra. +replace (0/_) with 0. +- apply atan_0. +- field. + rewrite Rsqr_pow2; field_simplify (1 - 0^2). + rewrite sqrt_1; lra. +Qed. + +Lemma asin_1 : asin 1 = PI / 2. +Proof. +unfold asin; repeat case Rle_dec; lra. +Qed. + +Lemma asin_inv_sqrt2 : asin (/sqrt 2) = PI/4. +Proof. +rewrite asin_atan. + pose proof sqrt2_neq_0 as SH. + rewrite Rsqr_pow2, <-Rinv_pow, <- Rsqr_pow2, Rsqr_sqrt; try lra. + replace (1 - /2) with (/2) by lra. + rewrite <- inv_sqrt; try lra. + now rewrite <- atan_1; apply f_equal; field. +split. + apply (Rlt_trans _ 0); try lra. + now apply Rinv_0_lt_compat; apply sqrt_lt_R0; lra. +replace 1 with (/ sqrt 1). + apply Rinv_1_lt_contravar. + now rewrite sqrt_1; lra. + now apply sqrt_lt_1; lra. +now rewrite sqrt_1; lra. +Qed. + +Lemma asin_opp : forall x, + asin (- x) = - asin x. +Proof. +intros x. +unfold asin; repeat case Rle_dec; intros; try lra. +rewrite <- Rsqr_neg. +rewrite Ropp_div. +rewrite atan_opp. +reflexivity. +Qed. + +(** ** Bounds of arcsine *) + +Lemma asin_bound : forall x, + - (PI/2) <= asin x <= PI/2. +Proof. +intros x. +pose proof PI_RGT_0. +unfold asin; repeat case Rle_dec; try lra. +intros Hx1 Hx2. +pose proof atan_bound (x / sqrt (1 - x²)); lra. +Qed. + +Lemma asin_bound_lt : forall x, -1 < x < 1 -> + - (PI/2) < asin x < PI/2. +Proof. +intros x HxB. +pose proof PI_RGT_0. +unfold asin; repeat case Rle_dec; try lra. +intros Hx1 Hx2. +pose proof atan_bound (x / sqrt (1 - x²)); lra. +Qed. + +(** ** arcsine is the left and right inverse of sine *) + +Lemma sin_asin : forall x, -1 <= x <= 1 -> + sin (asin x) = x. +Proof. + intros x. +unfold asin; repeat case Rle_dec. + rewrite sin_antisym, sin_PI2; lra. + rewrite sin_PI2; lra. +intros Hx1 Hx2 Hx3. +rewrite sin_atan. +assert (forall a b c:R, b<>0 -> c<> 0 -> a/b/c = a/(b*c)) as R_divdiv_divmul by (intros; field; lra). +rewrite R_divdiv_divmul. + rewrite <- sqrt_mult_alt. + rewrite Rsqr_div, Rsqr_sqrt. + field_simplify((1 - x²) * (1 + x² / (1 - x²))). + rewrite sqrt_1. + field. +(* Pose a few things useful for several subgoals *) +all: pose proof Rsqr_bounds_lt 1 x ltac:(lra) as Hxsqr; + rewrite Rsqr_1 in Hxsqr. +all: pose proof sqrt_lt_R0 (1 - x²) ltac:(lra). +(* Do 6 first, because it produces more subgoals *) +all: swap 1 6. +rewrite Rsqr_div, Rsqr_sqrt. +field_simplify(1 + x² / (1 - x²)). +rewrite sqrt_div. +rewrite sqrt_1. +pose proof Rdiv_lt_0_compat 1 (sqrt (- x² + 1)) ltac:(lra) as Hrange. +pose proof sqrt_lt_R0 (- x² + 1) ltac:(lra) as Hrangep. +specialize (Hrange Hrangep). +lra. +(* The rest can all be done with lra *) +all: try lra. +Qed. + +Lemma asin_sin : forall x, -(PI/2) <= x <= PI/2 -> + asin (sin x) = x. +Proof. +intros x HB. +apply sin_inj; auto. + apply asin_bound. +apply sin_asin. +apply SIN_bound. +Qed. + +(** ** Relation between arcsin, cosine and tangent *) + +Lemma cos_asin : forall x, -1 <= x <= 1 -> + cos (asin x) = sqrt (1 - x²). +Proof. + intros x Hxrange. + pose proof (sin_asin x) ltac:(lra) as Hasin. + remember (asin(x)) as α. + rewrite <- Hasin. + apply cos_sin. + pose proof cos_ge_0 α. + pose proof asin_bound x. + lra. +Qed. + +Lemma tan_asin : forall x, -1 <= x <= 1 -> + tan (asin x) = x / sqrt (1 - x²). +Proof. + intros x Hxrange. + pose proof (sin_asin x) Hxrange as Hasin. + remember (asin(x)) as α. + rewrite <- Hasin. + apply tan_sin. + pose proof cos_ge_0 α. + pose proof asin_bound x. + lra. +Qed. + +(** ** Derivative of arcsine *) + +Lemma derivable_pt_asin : forall x, -1 < x < 1 -> + derivable_pt asin x. +Proof. + intros x H. + + eapply (derivable_pt_recip_interv sin asin (-PI/2) (PI/2)); [shelve ..|]. + + rewrite <- (pr_nu sin (asin x) (derivable_pt_sin (asin x))). + rewrite derive_pt_sin. + (* The asin bounds are needed later, so pose them before asin is unfolded *) + pose proof asin_bound_lt x ltac:(lra) as HxB3. + unfold asin in *. + destruct (Rle_dec x (-1)); destruct (Rle_dec 1 x); [lra .. |]. + apply Rgt_not_eq; apply cos_gt_0; lra. + + Unshelve. + - pose proof PI_RGT_0 as HPi; lra. + - rewrite Ropp_div,sin_antisym,sin_PI2; lra. + - clear x H; intros x Ha Hb. + rewrite Ropp_div; apply asin_bound. + - intros a Ha; reg. + - intros x0 Ha Hb. + unfold comp,id. + apply sin_asin. + rewrite Ropp_div,sin_antisym,sin_PI2 in Ha; rewrite sin_PI2 in Hb; lra. + - intros x1 x2 Ha Hb Hc. + apply sin_increasing_1; lra. +Qed. + +Lemma derive_pt_asin : forall (x : R) (Hxrange : -1 < x < 1), + derive_pt asin x (derivable_pt_asin x Hxrange) = 1 / sqrt (1 - x²). +Proof. + intros x Hxrange. + + epose proof (derive_pt_recip_interv sin asin (-PI/2) (PI/2) x _ _ _ _ _ _ _) as Hd. + + rewrite <- (pr_nu sin (asin x) (derivable_pt_sin (asin x))) in Hd. + rewrite <- (pr_nu asin x (derivable_pt_asin x Hxrange)) in Hd. + rewrite derive_pt_sin in Hd. + rewrite cos_asin in Hd by lra. + assumption. + + Unshelve. + - pose proof PI_RGT_0. lra. + - rewrite Ropp_div,sin_antisym,sin_PI2; lra. + - intros x1 x2 Ha Hb Hc. + apply sin_increasing_1; lra. + - intros x0 Ha Hb. + pose proof asin_bound x0; lra. + - intros a Ha; reg. + - intros x0 Ha Hb. + unfold comp,id. + apply sin_asin. + rewrite Ropp_div,sin_antisym,sin_PI2 in Ha; rewrite sin_PI2 in Hb; lra. + - rewrite <- (pr_nu sin (asin x) (derivable_pt_sin (asin x))). + rewrite derive_pt_sin. + rewrite cos_asin by lra. + apply Rgt_not_eq. + apply sqrt_lt_R0. + pose proof Rsqr_bounds_lt 1 x ltac:(lra) as Hxsqrrange. + rewrite Rsqr_1 in Hxsqrrange; lra. +Qed. + +(*********************************************************) +(** * Definition of arccosine based on arctangent *) +(*********************************************************) + +(** acos is defined by cases so that it is defined in the full range from -1 .. 1 *) + +Definition acos x := + if Rle_dec x (-1) then PI else + if Rle_dec 1 x then 0 else + PI/2 - atan (x/sqrt(1 - x²)). + +(** ** Relation between arccosine, arcsine and arctangent *) + +Lemma acos_atan : forall x, 0 < x -> + acos x = atan (sqrt (1 - x²) / x). +Proof. + intros x. + unfold acos; repeat case Rle_dec; [lra | |]. + - intros Hx1 Hx2 Hx3. + pose proof Rsqr_bounds_le x 1 ltac:(lra)as Hxsqr. + rewrite Rsqr_1 in Hxsqr. + rewrite sqrt_neg_0 by lra. + replace (0/x) with 0 by (field;lra). + rewrite atan_0; reflexivity. + - intros Hx1 Hx2 Hx3. + pose proof atan_inv (sqrt (1 - x²) / x) as Hatan. + pose proof Rsqr_bounds_lt 1 x ltac:(lra)as Hxsqr. + rewrite Rsqr_1 in Hxsqr. + replace (/ (sqrt (1 - x²) / x)) with (x/sqrt (1 - x²)) in Hatan. + + rewrite Hatan; [field|]. + apply Rdiv_lt_0_compat; [|assumption]. + apply sqrt_lt_R0; lra. + + field; split. + lra. + assert(sqrt (1 - x²) >0) by (apply sqrt_lt_R0; lra); lra. +Qed. + +Lemma acos_asin : forall x, -1 <= x <= 1 -> + acos x = PI/2 - asin x. +Proof. + intros x. + unfold acos, asin; repeat case Rle_dec; lra. +Qed. + +Lemma asin_acos : forall x, -1 <= x <= 1 -> + asin x = PI/2 - acos x. +Proof. + intros x. + unfold acos, asin; repeat case Rle_dec; lra. +Qed. + +(** ** arccosine of specific values *) + +Lemma acos_0 : acos 0 = PI/2. +Proof. + unfold acos; repeat case Rle_dec; [lra..|]. + intros Hx1 Hx2. + replace (0/_) with 0. + rewrite atan_0; field. + field. + rewrite Rsqr_pow2; field_simplify (1 - 0^2). + rewrite sqrt_1; lra. +Qed. + +Lemma acos_1 : acos 1 = 0. +Proof. + unfold acos; repeat case Rle_dec; lra. +Qed. + +Lemma acos_opp : forall x, + acos (- x) = PI - acos x. +Proof. + intros x. + unfold acos; repeat case Rle_dec; try lra. + intros Hx1 Hx2 Hx3 Hx4. + rewrite <- Rsqr_neg, Ropp_div, atan_opp. + lra. +Qed. + +Lemma acos_inv_sqrt2 : acos (/sqrt 2) = PI/4. +Proof. + rewrite acos_asin. + rewrite asin_inv_sqrt2. + lra. + split. + apply Rlt_le. + apply (Rlt_trans (-1) 0 (/ sqrt 2)); try lra. + apply Rinv_0_lt_compat. + apply Rlt_sqrt2_0. + replace 1 with (/ sqrt 1). + apply Rlt_le. + apply Rinv_1_lt_contravar. + rewrite sqrt_1; lra. + apply sqrt_lt_1; lra. + rewrite sqrt_1; lra. +Qed. + +(** ** Bounds of arccosine *) + +Lemma acos_bound : forall x, + 0 <= acos x <= PI. +Proof. + intros x. + pose proof PI_RGT_0. + unfold acos; repeat case Rle_dec; try lra. + intros Hx1 Hx2. + pose proof atan_bound (x / sqrt (1 - x²)); lra. +Qed. + +Lemma acos_bound_lt : forall x, -1 < x < 1 -> + 0 < acos x < PI. +Proof. + intros x xB. + pose proof PI_RGT_0. + unfold acos; repeat case Rle_dec; try lra. + intros Hx1 Hx2. + pose proof atan_bound (x / sqrt (1 - x²)); lra. +Qed. + +(** ** arccosine is the left and right inverse of cosine *) + +Lemma cos_acos : forall x, -1 <= x <= 1 -> + cos (acos x) = x. +Proof. + intros x xB. + assert (H : x = -1 \/ -1 < x) by lra. + destruct H as [He|Hl]. + rewrite He. + change (IZR (-1)) with (-(IZR 1)). + now rewrite acos_opp, acos_1, Rminus_0_r, cos_PI. + assert (H : x = 1 \/ x < 1) by lra. + destruct H as [He1|Hl1]. + now rewrite He1, acos_1, cos_0. + rewrite acos_asin, cos_shift; try lra. + rewrite sin_asin; lra. +Qed. + +Lemma acos_cos : forall x, 0 <= x <= PI -> + acos (cos x) = x. +Proof. + intros x HB. + apply cos_inj; try lra. + apply acos_bound. + apply cos_acos. + apply COS_bound. +Qed. + +(** ** Relation between arccosine, sine and tangent *) + +Lemma sin_acos : forall x, -1 <= x <= 1 -> + sin (acos x) = sqrt (1 - x²). +Proof. + intros x Hxrange. + pose proof (cos_acos x) ltac:(lra) as Hacos. + remember (acos(x)) as α. + rewrite <- Hacos. + apply sin_cos. + pose proof sin_ge_0 α. + pose proof acos_bound x. + lra. +Qed. + +Lemma tan_acos : forall x, -1 <= x <= 1 -> + tan (acos x) = sqrt (1 - x²) / x. +Proof. + intros x Hxrange. + pose proof (cos_acos x) Hxrange as Hacos. + remember (acos(x)) as α. + rewrite <- Hacos. + apply tan_cos. + pose proof sin_ge_0 α. + pose proof acos_bound x. + lra. +Qed. + +(** ** Derivative of arccosine *) + +Lemma derivable_pt_acos : forall x, -1 < x < 1 -> + derivable_pt acos x. +Proof. + intros x H. + + eapply (derivable_pt_recip_interv_decr cos acos 0 PI); [shelve ..|]. + + rewrite <- (pr_nu cos (acos x) (derivable_pt_cos (acos x))). + rewrite derive_pt_cos. + (* The acos bounds are needed later, so pose them before acos is unfolded *) + pose proof acos_bound_lt x ltac:(lra) as Hbnd. + unfold acos in *. + destruct (Rle_dec x (-1)); destruct (Rle_dec 1 x); [lra..|]. + apply Rlt_not_eq, Ropp_lt_gt_0_contravar, Rlt_gt. + apply sin_gt_0; lra. + + Unshelve. + - pose proof PI_RGT_0 as HPi; lra. + - rewrite cos_0; rewrite cos_PI; lra. + - clear x H; intros x H1 H2. + apply acos_bound. + - intros a Ha; reg. + - intros x0 H1 H2. + unfold comp,id. + apply cos_acos. + rewrite cos_PI in H1; rewrite cos_0 in H2; lra. + - intros x1 x2 H1 H2 H3. + pose proof cos_decreasing_1 x1 x2; lra. +Qed. + +Lemma derive_pt_acos : forall (x : R) (Hxrange : -1 < x < 1), + derive_pt acos x (derivable_pt_acos x Hxrange) = -1 / sqrt (1 - x²). +Proof. + intros x Hxrange. + + epose proof (derive_pt_recip_interv_decr cos acos 0 PI x _ _ _ _ _ _ _ ) as Hd. + + rewrite <- (pr_nu cos (acos x) (derivable_pt_cos (acos x))) in Hd. + rewrite <- (pr_nu acos x (derivable_pt_acos x Hxrange)) in Hd. + rewrite derive_pt_cos in Hd. + rewrite sin_acos in Hd by lra. + rewrite Hd; field. + apply Rgt_not_eq, Rlt_gt; rewrite <- sqrt_0. + pose proof Rsqr_bounds_lt 1 x ltac:(lra) as Hxb; rewrite Rsqr_1 in Hxb. + apply sqrt_lt_1; lra. + +Unshelve. + - pose proof PI_RGT_0; lra. + - rewrite cos_PI,cos_0; lra. + - intros x1 x2 Ha Hb Hc. + apply cos_decreasing_1; lra. + - intros x0 Ha Hb. + pose proof acos_bound x0; lra. + - intros a Ha; reg. + - intros x0 Ha Hb. + unfold comp,id. + apply cos_acos. + rewrite cos_PI in Ha; rewrite cos_0 in Hb; lra. + - rewrite <- (pr_nu cos (acos x) (derivable_pt_cos (acos x))). + rewrite derive_pt_cos. + rewrite sin_acos by lra. + apply Rlt_not_eq; rewrite <- Ropp_0; apply Ropp_lt_contravar; rewrite <- sqrt_0. + pose proof Rsqr_bounds_lt 1 x ltac:(lra) as Hxb; rewrite Rsqr_1 in Hxb. + apply sqrt_lt_1; lra. +Qed. diff --git a/theories/Reals/Rpower.v b/theories/Reals/Rpower.v index ad1b0e1ef7..047c9d0804 100644 --- a/theories/Reals/Rpower.v +++ b/theories/Reals/Rpower.v @@ -768,8 +768,6 @@ assert (t: forall x y z, x - z = y -> x - y - z = 0);[ | apply t; clear t]. intros a b c H; rewrite <- H; ring. apply Rmult_eq_reg_l with (2 * (x + sqrt (x ^ 2 + 1)));[ | apply Rgt_not_eq, Rmult_lt_0_compat;[apply Rlt_0_2 | assumption]]. -assert (pow2_sqrt : forall x, 0 <= x -> sqrt x ^ 2 = x) by - (intros; simpl; rewrite Rmult_1_r, sqrt_sqrt; auto). field_simplify;[rewrite pow2_sqrt;[field | ] | apply Rgt_not_eq; lra]. apply Rplus_le_le_0_compat;[simpl; rewrite Rmult_1_r; apply (Rle_0_sqr x)|apply Rlt_le, Rlt_0_1]. Qed. diff --git a/theories/Reals/Rtrigo1.v b/theories/Reals/Rtrigo1.v index d8c9c4f7ea..f5daa50ba4 100644 --- a/theories/Reals/Rtrigo1.v +++ b/theories/Reals/Rtrigo1.v @@ -1173,6 +1173,18 @@ Proof. apply (sin_increasing_1 (x - PI) (y - PI) H7 H8 H5 H6 H4). Qed. +Lemma sin_inj x y : -(PI/2) <= x <= PI/2 -> -(PI/2) <= y <= PI/2 -> sin x = sin y -> x = y. +Proof. +intros xP yP Hsin. +destruct (total_order_T x y) as [[H|H]|H]; auto. +- assert (sin x < sin y). + now apply sin_increasing_1; lra. + now lra. +- assert (sin y < sin x). + now apply sin_increasing_1; lra. + now lra. +Qed. + Lemma cos_increasing_0 : forall x y:R, PI <= x -> x <= 2 * PI -> PI <= y -> y <= 2 * PI -> cos x < cos y -> x < y. @@ -1253,6 +1265,18 @@ Proof. apply (cos_increasing_1 (PI + x) (PI + y) H3 H2 H1 H0 H). Qed. +Lemma cos_inj x y : 0 <= x <= PI -> 0 <= y <= PI -> cos x = cos y -> x = y. +Proof. +intros xP yP Hcos. +destruct (total_order_T x y) as [[H|H]|H]; auto. +- assert (cos y < cos x). + now apply cos_decreasing_1; lra. + now lra. +- assert (cos x < cos y). + now apply cos_decreasing_1; lra. + now lra. +Qed. + Lemma tan_diff : forall x y:R, cos x <> 0 -> cos y <> 0 -> tan x - tan y = sin (x - y) / (cos x * cos y). diff --git a/theories/Reals/Rtrigo_facts.v b/theories/Reals/Rtrigo_facts.v new file mode 100755 index 0000000000..9f2ad677a8 --- /dev/null +++ b/theories/Reals/Rtrigo_facts.v @@ -0,0 +1,287 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <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) *) +(************************************************************************) + +Require Import Rbase. +Require Import Rtrigo1. +Require Import Rfunctions. + +Require Import Lra. +Require Import Ranalysis_reg. + +Local Open Scope R_scope. + +(*********************************************************) +(** * Bounds of expressions with trigonometric functions *) +(*********************************************************) + +Lemma sin2_bound : forall x, + 0 <= (sin x)² <= 1. +Proof. + intros x. + rewrite <- Rsqr_1. + apply Rsqr_bounds_le. + apply SIN_bound. +Qed. + +Lemma cos2_bound : forall x, + 0 <= (cos x)² <= 1. +Proof. + intros x. + rewrite <- Rsqr_1. + apply Rsqr_bounds_le. + apply COS_bound. +Qed. + +(*********************************************************) +(** * Express trigonometric functions with each other *) +(*********************************************************) + +(** ** Express sin and cos with each other *) + +Lemma cos_sin : forall x, cos x >=0 -> + cos x = sqrt(1 - (sin x)²). +Proof. + intros x H. + apply Rsqr_inj. + - lra. + - apply sqrt_pos. + - rewrite Rsqr_sqrt. + apply cos2. + pose proof sin2_bound x. + lra. +Qed. + +Lemma cos_sin_opp : forall x, cos x <=0 -> + cos x = - sqrt(1 - (sin x)²). +Proof. + intros x H. + rewrite <- (Ropp_involutive (cos x)). + apply Ropp_eq_compat. + apply Rsqr_inj. + - lra. + - apply sqrt_pos. + - rewrite Rsqr_sqrt. + rewrite <- Rsqr_neg. + apply cos2. + pose proof sin2_bound x. + lra. +Qed. + +Lemma cos_sin_Rabs : forall x, + Rabs (cos x) = sqrt(1 - (sin x)²). +Proof. + intros x. + unfold Rabs. + destruct (Rcase_abs (cos x)). + - rewrite <- (Ropp_involutive (sqrt (1 - (sin x)²))). + apply Ropp_eq_compat. + apply cos_sin_opp; lra. + - apply cos_sin; assumption. +Qed. + +Lemma sin_cos : forall x, sin x >=0 -> + sin x = sqrt(1 - (cos x)²). +Proof. + intros x H. + apply Rsqr_inj. + - lra. + - apply sqrt_pos. + - rewrite Rsqr_sqrt. + apply sin2. + pose proof cos2_bound x. + lra. +Qed. + +Lemma sin_cos_opp : forall x, sin x <=0 -> + sin x = - sqrt(1 - (cos x)²). +Proof. + intros x H. + rewrite <- (Ropp_involutive (sin x)). + apply Ropp_eq_compat. + apply Rsqr_inj. + - lra. + - apply sqrt_pos. + - rewrite Rsqr_sqrt. + rewrite <- Rsqr_neg. + apply sin2. + pose proof cos2_bound x. + lra. +Qed. + +Lemma sin_cos_Rabs : forall x, + Rabs (sin x) = sqrt(1 - (cos x)²). +Proof. + intros x. + unfold Rabs. + destruct (Rcase_abs (sin x)). + - rewrite <- ( Ropp_involutive (sqrt (1 - (cos x)²))). + apply Ropp_eq_compat. + apply sin_cos_opp; lra. + - apply sin_cos; assumption. +Qed. + +(** ** Express tan with sin and cos *) + +Lemma tan_sin : forall x, 0 <= cos x -> + tan x = sin x / sqrt (1 - (sin x)²). +Proof. + intros x H. + unfold tan. + rewrite <- (sqrt_Rsqr (cos x)) by assumption. + rewrite <- (cos2 x). + reflexivity. +Qed. + +Lemma tan_sin_opp : forall x, 0 > cos x -> + tan x = - (sin x / sqrt (1 - (sin x)²)). +Proof. + intros x H. + unfold tan. + rewrite cos_sin_opp by lra. + rewrite Ropp_div_den. + reflexivity. + pose proof cos_sin_opp x. + lra. +Qed. + +(** Note: tan_sin_Rabs wouldn't make a lot of sense, because one would need Rabs on both sides *) + +Lemma tan_cos : forall x, 0 <= sin x -> + tan x = sqrt (1 - (cos x)²) / cos x. +Proof. + intros x H. + unfold tan. + rewrite <- (sqrt_Rsqr (sin x)) by assumption. + rewrite <- (sin2 x). + reflexivity. +Qed. + +Lemma tan_cos_opp : forall x, 0 >= sin x -> + tan x = - sqrt (1 - (cos x)²) / cos x. +Proof. + intros x H. + unfold tan. + rewrite sin_cos_opp by lra. + reflexivity. +Qed. + +(** ** Express sin and cos with tan *) + +Lemma sin_tan : forall x, 0 < cos x -> + sin x = tan x / sqrt (1 + (tan x)²). +Proof. + intros. + assert(Hcosle:0<=cos x) by lra. + pose proof tan_sin x Hcosle as Htan. + rewrite Htan. + repeat rewrite <- Rsqr_pow2 in *. + assert (forall a b c:R, b<>0 -> c<> 0 -> a/b/c = a/(b*c)) as R_divdiv_divmul by (intros; field; lra). + rewrite R_divdiv_divmul. + rewrite <- sqrt_mult_alt. + rewrite Rsqr_div, Rsqr_sqrt. + field_simplify ((1 - (sin x)²) * (1 + (sin x)² / (1 - (sin x)²))). + rewrite sqrt_1. + field. + all: pose proof (sin2 x); pose proof Rsqr_pos_lt (cos x); try lra. + all: assert( forall a, 0 < a -> a <> 0) as Hne by (intros; lra). + all: apply Hne, sqrt_lt_R0; try lra. + rewrite <- Htan. + pose proof Rle_0_sqr (tan x); lra. +Qed. + +Lemma cos_tan : forall x, 0 < cos x -> + cos x = 1 / sqrt (1 + (tan x)²). +Proof. + intros. + destruct (Rcase_abs (sin x)) as [Hsignsin|Hsignsin]. + - assert(Hsinle:0>=sin x) by lra. + pose proof tan_cos_opp x Hsinle as Htan. + rewrite Htan. + rewrite Rsqr_div. + rewrite <- Rsqr_neg. + rewrite Rsqr_sqrt. + field_simplify( 1 + (1 - (cos x)²) / (cos x)² ). + rewrite sqrt_div_alt. + rewrite sqrt_1. + field_simplify_eq. + rewrite sqrt_Rsqr. + reflexivity. + all: pose proof cos2_bound x. + all: pose proof Rsqr_pos_lt (cos x) ltac:(lra). + all: pose proof sqrt_lt_R0 (cos x)² ltac:(assumption). + all: lra. + - assert(Hsinge:0<=sin x) by lra. + pose proof tan_cos x Hsinge as Htan. + rewrite Htan. + rewrite Rsqr_div. + rewrite Rsqr_sqrt. + field_simplify( 1 + (1 - (cos x)²) / (cos x)² ). + rewrite sqrt_div_alt. + rewrite sqrt_1. + field_simplify_eq. + rewrite sqrt_Rsqr. + reflexivity. + all: pose proof cos2_bound x. + all: pose proof Rsqr_pos_lt (cos x) ltac:(lra). + all: pose proof sqrt_lt_R0 (cos x)² ltac:(assumption). + all: lra. +Qed. + +(*********************************************************) +(** * Additional shift lemmas for sin, cos, tan *) +(*********************************************************) + +Lemma sin_pi_minus : forall x, + sin (PI - x) = sin x. +Proof. + intros x. + rewrite sin_minus, cos_PI, sin_PI. + ring. +Qed. + +Lemma sin_pi_plus : forall x, + sin (PI + x) = - sin x. +Proof. + intros x. + rewrite sin_plus, cos_PI, sin_PI. + ring. +Qed. + +Lemma cos_pi_minus : forall x, + cos (PI - x) = - cos x. +Proof. + intros x. + rewrite cos_minus, cos_PI, sin_PI. + ring. +Qed. + +Lemma cos_pi_plus : forall x, + cos (PI + x) = - cos x. +Proof. + intros x. + rewrite cos_plus, cos_PI, sin_PI. + ring. +Qed. + +Lemma tan_pi_minus : forall x, cos x <> 0 -> + tan (PI - x) = - tan x. +Proof. + intros x H. + unfold tan; rewrite sin_pi_minus, cos_pi_minus. + field; assumption. +Qed. + +Lemma tan_pi_plus : forall x, cos x <> 0 -> + tan (PI + x) = tan x. +Proof. + intros x H. + unfold tan; rewrite sin_pi_plus, cos_pi_plus. + field; assumption. +Qed. diff --git a/theories/Sorting/CPermutation.v b/theories/Sorting/CPermutation.v new file mode 100644 index 0000000000..fac9cd1d6d --- /dev/null +++ b/theories/Sorting/CPermutation.v @@ -0,0 +1,283 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \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) *) +(************************************************************************) + +(** * Circular Shifts (aka Cyclic Permutations) *) + +(** The main inductive [CPermutation] relates lists up to circular shifts of their elements. + +For example: [CPermutation [a1;a2;a3;a4;a5] [a4;a5;a1;a2;a3]] + +Note: Terminology does not seem to be strongly fixed in English. For the record, it is "permutations circulaires" in French. +*) + +Require Import List Permutation Morphisms PeanoNat. +Import ListNotations. (* For notations [] and [a;b;c] *) +Set Implicit Arguments. + +Section CPermutation. + +Variable A:Type. + +(** Definition *) + +Inductive CPermutation : list A -> list A -> Prop := +| cperm : forall l1 l2, CPermutation (l1 ++ l2) (l2 ++ l1). + +Instance CPermutation_Permutation : Proper (CPermutation ==> (@Permutation A)) id. +Proof. intros ? ? [? ?]; apply Permutation_app_comm. Qed. + +(** Some facts about [CPermutation] *) + +Theorem CPermutation_nil : forall l, CPermutation [] l -> l = []. +Proof. +intros l HC; inversion HC as [l1 l2 Heq]; subst. +now apply app_eq_nil in Heq; destruct Heq; subst. +Qed. + +Theorem CPermutation_nil_cons : forall l a, ~ CPermutation [] (a :: l). +Proof. intros l a HC; apply CPermutation_nil in HC; inversion HC. Qed. + +Theorem CPermutation_nil_app_cons : forall l1 l2 a, + ~ CPermutation [] (l1 ++ a ::l2). +Proof. +intros l1 l2 a HC; apply CPermutation_nil in HC; destruct l1; inversion HC. +Qed. + +Lemma CPermutation_split : forall l1 l2, + CPermutation l1 l2 <-> exists n, l2 = skipn n l1 ++ firstn n l1. +Proof. +intros l1 l2; split. +- intros [l1' l2']. + exists (length l1'). + rewrite skipn_app, skipn_all, Nat.sub_diag; simpl; f_equal. + now rewrite firstn_app, firstn_all, Nat.sub_diag; simpl; rewrite app_nil_r. +- now intros [n ->]; rewrite <- (firstn_skipn n) at 1. +Qed. + + +(** Equivalence relation *) + +Theorem CPermutation_refl : forall l, CPermutation l l. +Proof. +intros l; now rewrite <- (app_nil_l l) at 1; rewrite <- (app_nil_r l) at 2. +Qed. + +Instance CPermutation_refl' : Proper (Logic.eq ==> CPermutation) id. +Proof. intros ? ? ->; apply CPermutation_refl. Qed. + +Theorem CPermutation_sym : forall l l', CPermutation l l' -> CPermutation l' l. +Proof. now intros ? ? [? ?]. Qed. + +Theorem CPermutation_trans : forall l l' l'', + CPermutation l l' -> CPermutation l' l'' -> CPermutation l l''. +Proof. +intros l l' l'' HC1 HC2. +inversion HC1 as [l1 l2]; inversion HC2 as [l3 l4 Heq Heq']; subst. +clear - Heq; revert l1 l2 l4 Heq; clear; induction l3; simpl; intros. +- now subst; rewrite app_nil_r. +- destruct l2 as [| b]. + + simpl in Heq; subst. + now rewrite app_nil_r, app_comm_cons. + + inversion Heq as [[Heqb Heq']]; subst. + replace (l1 ++ b :: l2) with ((l1 ++ b :: nil) ++ l2) + by now rewrite <- app_assoc, <- app_comm_cons. + replace (l4 ++ b :: l3) with ((l4 ++ b :: nil) ++ l3) + by now rewrite <- app_assoc, <- app_comm_cons. + apply IHl3. + now rewrite 2 app_assoc, Heq'. +Qed. + +End CPermutation. + +Hint Resolve CPermutation_refl : core. + +(* These hints do not reduce the size of the problem to solve and they + must be used with care to avoid combinatoric explosions *) + +Local Hint Resolve cperm CPermutation_sym CPermutation_trans : core. + +Instance CPermutation_Equivalence A : Equivalence (@CPermutation A) | 10 := { + Equivalence_Reflexive := @CPermutation_refl A ; + Equivalence_Symmetric := @CPermutation_sym A ; + Equivalence_Transitive := @CPermutation_trans A }. + + +Section CPermutation_properties. + +Variable A B:Type. + +Implicit Types a b : A. +Implicit Types l : list A. + +(** Compatibility with others operations on lists *) + +Lemma CPermutation_app : forall l1 l2 l3, + CPermutation (l1 ++ l2) l3 -> CPermutation (l2 ++ l1) l3. +Proof. intros l1 l2 l3 HC; now transitivity (l1 ++ l2). Qed. + +Theorem CPermutation_app_comm : forall l1 l2, CPermutation (l1 ++ l2) (l2 ++ l1). +Proof. apply cperm. Qed. + +Lemma CPermutation_app_rot : forall l1 l2 l3, + CPermutation (l1 ++ l2 ++ l3) (l2 ++ l3 ++ l1). +Proof. intros l1 l2 l3; now rewrite (app_assoc l2). Qed. + +Lemma CPermutation_cons_append : forall l a, + CPermutation (a :: l) (l ++ [a]). +Proof. intros l a; now rewrite <- (app_nil_l l), app_comm_cons. Qed. + +Lemma CPermutation_morph_cons : forall P : list A -> Prop, + (forall a l, P (l ++ [a]) -> P (a :: l)) -> + Proper (@CPermutation A ==> iff) P. +Proof. +enough (forall P : list A -> Prop, + (forall a l, P (l ++ [a]) -> P (a :: l)) -> + forall l1 l2, CPermutation l1 l2 -> P l1 -> P l2) + as Himp + by now intros P HP l1 l2 HC; split; [ | symmetry in HC ]; apply Himp. +intros P HP l1 l2 [l1' l2']. +revert l1'; induction l2' using rev_ind; intros l1' HPl. +- now rewrite app_nil_r in HPl. +- rewrite app_assoc in HPl. + apply HP in HPl. + rewrite <- app_assoc, <- app_comm_cons, app_nil_l. + now apply IHl2'. +Qed. + +Lemma CPermutation_length_1 : forall a b, CPermutation [a] [b] -> a = b. +Proof. intros; now apply Permutation_length_1, CPermutation_Permutation. Qed. + +Lemma CPermutation_length_1_inv : forall l a, CPermutation [a] l -> l = [a]. +Proof. intros; now apply Permutation_length_1_inv, CPermutation_Permutation. Qed. + +Lemma CPermutation_swap : forall a b, CPermutation [a; b] [b; a]. +Proof. +intros; now change [a; b] with ([a] ++ [b]); change [b; a] with ([b] ++ [a]). +Qed. + +Lemma CPermutation_length_2 : forall a1 a2 b1 b2, + CPermutation [a1; a2] [b1; b2] -> + a1 = b1 /\ a2 = b2 \/ a1 = b2 /\ a2 = b1. +Proof. intros; now apply Permutation_length_2, CPermutation_Permutation. Qed. + +Lemma CPermutation_length_2_inv : forall a b l, + CPermutation [a; b] l -> l = [a; b] \/ l = [b; a]. +Proof. intros; now apply Permutation_length_2_inv, CPermutation_Permutation. Qed. + +Lemma CPermutation_vs_elt_inv : forall l l1 l2 a, + CPermutation l (l1 ++ a :: l2) -> + exists l' l'', l2 ++ l1 = l'' ++ l' /\ l = l' ++ a :: l''. +Proof. +intros l l1 l2 a HC. +inversion HC as [l1' l2' Heq' Heq]; clear HC; subst. +enough (exists l3, (l2' ++ l3 = l1 /\ l1' = l3 ++ a :: l2) + \/ (l2' = l1 ++ a :: l3 /\ l3 ++ l1' = l2)) + as [l3 [[<- ->]|[-> <-]]]. +- exists l3, (l2 ++ l2'); rewrite app_comm_cons; intuition. +- exists (l1' ++ l1), l3; intuition. +- revert l1' l2' l2 Heq; induction l1; simpl; intros l1' l2' l2 Heq. + + destruct l2'; inversion Heq; subst. + * exists nil; intuition. + * exists l2'; intuition. + + destruct l2'; inversion Heq; subst. + * exists (a0 :: l1); intuition. + * apply IHl1 in H1 as [l3 [[<- ->]|[-> <-]]]; exists l3; intuition. +Qed. + +Lemma CPermutation_vs_cons_inv : forall l l0 a, + CPermutation l (a :: l0) -> exists l' l'', l0 = l'' ++ l' /\ l = l' ++ a :: l''. +Proof. intros; rewrite <- (app_nil_r l0); now apply CPermutation_vs_elt_inv. Qed. + +End CPermutation_properties. + + +(** [rev], [in], [map], [Forall], [Exists], etc. *) + +Global Instance CPermutation_rev A : + Proper (@CPermutation A ==> @CPermutation A) (@rev A) | 10. +Proof. +intro l; induction l; intros l' HC. +- now apply CPermutation_nil in HC; subst. +- symmetry in HC. + destruct (CPermutation_vs_cons_inv HC) as [l1 [l2 [-> ->]]]. + simpl; rewrite ? rev_app_distr; simpl. + now rewrite <- app_assoc. +Qed. + +Global Instance CPermutation_in A a : + Proper (@CPermutation A ==> Basics.impl) (In a). +Proof. +intros l l' HC Hin. +now apply Permutation_in with l; [ apply CPermutation_Permutation | ]. +Qed. + +Global Instance CPermutation_in' A : + Proper (Logic.eq ==> @CPermutation A ==> iff) (@In A) | 10. +Proof. intros a a' <- l l' HC; split; now apply CPermutation_in. Qed. + +Global Instance CPermutation_map A B (f : A -> B) : + Proper (@CPermutation A ==> @CPermutation B) (map f) | 10. +Proof. now intros ? ? [l1 l2]; rewrite 2 map_app. Qed. + +Lemma CPermutation_map_inv A B : forall (f : A -> B) m l, + CPermutation m (map f l) -> exists l', m = map f l' /\ CPermutation l l'. +Proof. +induction m as [| b m]; intros l HC. +- exists nil; split; auto. + destruct l; auto. + apply CPermutation_nil in HC; inversion HC. +- symmetry in HC. + destruct (CPermutation_vs_cons_inv HC) as [m1 [m2 [-> Heq]]]. + apply map_eq_app in Heq as [l1 [l1' [-> [-> Heq]]]]. + symmetry in Heq. + apply map_eq_cons in Heq as [a [l1'' [-> [-> ->]]]]. + exists (a :: l1'' ++ l1); split. + + now simpl; rewrite map_app. + + now rewrite app_comm_cons. +Qed. + +Lemma CPermutation_image A B : forall (f : A -> B) a l l', + CPermutation (a :: l) (map f l') -> exists a', a = f a'. +Proof. +intros f a l l' HP. +now apply CPermutation_Permutation, Permutation_image in HP. +Qed. + +Instance CPermutation_Forall A (P : A -> Prop) : + Proper (@CPermutation A ==> Basics.impl) (Forall P). +Proof. +intros ? ? [? ?] HF. +now apply Forall_app in HF; apply Forall_app. +Qed. + +Instance CPermutation_Exists A (P : A -> Prop) : + Proper (@CPermutation A ==> Basics.impl) (Exists P). +Proof. +intros ? ? [? ?] HE. +apply Exists_app in HE; apply Exists_app; intuition. +Qed. + +Lemma CPermutation_Forall2 A B (P : A -> B -> Prop) : + forall l1 l1' l2, CPermutation l1 l1' -> Forall2 P l1 l2 -> exists l2', + CPermutation l2 l2' /\ Forall2 P l1' l2'. +Proof. +intros ? ? ? [? ?] HF. +apply Forall2_app_inv_l in HF as (l2' & l2'' & HF' & HF'' & ->). +exists (l2'' ++ l2'); intuition. +now apply Forall2_app. +Qed. + + +(** As an equivalence relation compatible with some operations, +[CPermutation] can be used through [rewrite]. *) +Example CPermutation_rewrite_rev A (l1 l2 l3: list A) : + CPermutation l1 l2 -> + CPermutation (rev l1) l3 -> CPermutation l3 (rev l2). +Proof. intros HP1 HP2; rewrite <- HP1, HP2; reflexivity. Qed. diff --git a/theories/Sorting/Permutation.v b/theories/Sorting/Permutation.v index 23881f63cb..ffef8a216d 100644 --- a/theories/Sorting/Permutation.v +++ b/theories/Sorting/Permutation.v @@ -15,7 +15,7 @@ (* Adapted in May 2006 by Jean-Marc Notin from initial contents by Laurent Théry (Huffmann contribution, October 2003) *) -Require Import List Setoid Compare_dec Morphisms FinFun. +Require Import List Setoid Compare_dec Morphisms FinFun PeanoNat. Import ListNotations. (* For notations [] and [a;b;c] *) Set Implicit Arguments. (* Set Universe Polymorphism. *) @@ -56,6 +56,11 @@ Proof. induction l; constructor. exact IHl. Qed. +Instance Permutation_refl' : Proper (Logic.eq ==> Permutation) id. +Proof. + intros x y Heq; rewrite Heq; apply Permutation_refl. +Qed. + Theorem Permutation_sym : forall l l' : list A, Permutation l l' -> Permutation l' l. Proof. @@ -87,15 +92,28 @@ Instance Permutation_Equivalence A : Equivalence (@Permutation A) | 10 := { Equivalence_Symmetric := @Permutation_sym A ; Equivalence_Transitive := @Permutation_trans A }. +Lemma Permutation_morph_transp A : forall P : list A -> Prop, + (forall a b l1 l2, P (l1 ++ a :: b :: l2) -> P (l1 ++ b :: a :: l2)) -> + Proper (@Permutation A ==> Basics.impl) P. +Proof. + intros P HT l1 l2 HP. + enough (forall l0, P (l0 ++ l1) -> P (l0 ++ l2)) as IH + by (intro; rewrite <- (app_nil_l l2); now apply (IH nil)). + induction HP; intuition. + rewrite <- (app_nil_l l'), app_comm_cons, app_assoc. + now apply IHHP; rewrite <- app_assoc. +Qed. + Instance Permutation_cons A : Proper (Logic.eq ==> @Permutation A ==> @Permutation A) (@cons A) | 10. Proof. repeat intro; subst; auto using perm_skip. Qed. + Section Permutation_properties. -Variable A:Type. +Variable A B:Type. Implicit Types a b : A. Implicit Types l m : list A. @@ -168,6 +186,30 @@ Proof. Qed. Local Hint Resolve Permutation_app_comm : core. +Lemma Permutation_app_rot : forall l1 l2 l3: list A, + Permutation (l1 ++ l2 ++ l3) (l2 ++ l3 ++ l1). +Proof. + intros l1 l2 l3; now rewrite (app_assoc l2). +Qed. +Local Hint Resolve Permutation_app_rot : core. + +Lemma Permutation_app_swap_app : forall l1 l2 l3: list A, + Permutation (l1 ++ l2 ++ l3) (l2 ++ l1 ++ l3). +Proof. + intros. + rewrite 2 app_assoc. + apply Permutation_app_tail, Permutation_app_comm. +Qed. +Local Hint Resolve Permutation_app_swap_app : core. + +Lemma Permutation_app_middle : forall l l1 l2 l3 l4, + Permutation (l1 ++ l2) (l3 ++ l4) -> + Permutation (l1 ++ l ++ l2) (l3 ++ l ++ l4). +Proof. + intros l l1 l2 l3 l4 HP. + now rewrite Permutation_app_swap_app, HP, Permutation_app_swap_app. +Qed. + Theorem Permutation_cons_app : forall (l l1 l2:list A) a, Permutation l (l1 ++ l2) -> Permutation (a :: l) (l1 ++ a :: l2). Proof. @@ -190,6 +232,24 @@ Proof. Qed. Local Hint Resolve Permutation_middle : core. +Lemma Permutation_middle2 : forall l1 l2 l3 a b, + Permutation (a :: b :: l1 ++ l2 ++ l3) (l1 ++ a :: l2 ++ b :: l3). +Proof. + intros l1 l2 l3 a b. + apply Permutation_cons_app. + rewrite 2 app_assoc. + now apply Permutation_cons_app. +Qed. +Local Hint Resolve Permutation_middle2 : core. + +Lemma Permutation_elt : forall l1 l2 l1' l2' (a:A), + Permutation (l1 ++ l2) (l1' ++ l2') -> + Permutation (l1 ++ a :: l2) (l1' ++ a :: l2'). +Proof. + intros l1 l2 l1' l2' a HP. + transitivity (a :: l1 ++ l2); auto. +Qed. + Theorem Permutation_rev : forall (l : list A), Permutation l (rev l). Proof. induction l as [| x l]; simpl; trivial. now rewrite IHl at 1. @@ -213,6 +273,46 @@ Proof. exact Permutation_length. Qed. +Instance Permutation_Forall (P : A -> Prop) : + Proper ((@Permutation A) ==> Basics.impl) (Forall P). +Proof. + intros l1 l2 HP. + induction HP; intro HF; auto. + - inversion_clear HF; auto. + - inversion_clear HF as [ | ? ? HF1 HF2]. + inversion_clear HF2; auto. +Qed. + +Instance Permutation_Exists (P : A -> Prop) : + Proper ((@Permutation A) ==> Basics.impl) (Exists P). +Proof. + intros l1 l2 HP. + induction HP; intro HF; auto. + - inversion_clear HF; auto. + - inversion_clear HF as [ | ? ? HF1 ]; auto. + inversion_clear HF1; auto. +Qed. + +Lemma Permutation_Forall2 (P : A -> B -> Prop) : + forall l1 l1' (l2 : list B), Permutation l1 l1' -> Forall2 P l1 l2 -> + exists l2' : list B, Permutation l2 l2' /\ Forall2 P l1' l2'. +Proof. + intros l1 l1' l2 HP. + revert l2; induction HP; intros l2 HF; inversion HF as [ | ? b ? ? HF1 HF2 ]; subst. + - now exists nil. + - apply IHHP in HF2 as [l2' [HP2 HF2]]. + exists (b :: l2'); auto. + - inversion_clear HF2 as [ | ? b' ? l2' HF3 HF4 ]. + exists (b' :: b :: l2'); auto. + - apply Permutation_nil in HP1; subst. + apply Permutation_nil in HP2; subst. + now exists nil. + - apply IHHP1 in HF as [l2' [HP2' HF2']]. + apply IHHP2 in HF2' as [l2'' [HP2'' HF2'']]. + exists l2''; split; auto. + now transitivity l2'. +Qed. + Theorem Permutation_ind_bis : forall P : list A -> list A -> Prop, P [] [] -> @@ -301,6 +401,16 @@ Proof. rewrite 2 (Permutation_app_comm _ l). apply Permutation_app_inv_l. Qed. +Lemma Permutation_app_inv_m l l1 l2 l3 l4 : + Permutation (l1 ++ l ++ l2) (l3 ++ l ++ l4) -> + Permutation (l1 ++ l2) (l3 ++ l4). +Proof. + intros HP. + apply (Permutation_app_inv_l l). + transitivity (l1 ++ l ++ l2); auto. + transitivity (l3 ++ l ++ l4); auto. +Qed. + Lemma Permutation_length_1_inv: forall a l, Permutation [a] l -> l = [a]. Proof. intros a l H; remember [a] as m in H. @@ -335,6 +445,38 @@ Proof. apply Permutation_length_2_inv in H as [H|H]; injection H as [= -> ->]; auto. Qed. +Lemma Permutation_vs_elt_inv : forall l l1 l2 a, + Permutation l (l1 ++ a :: l2) -> exists l' l'', l = l' ++ a :: l''. +Proof. + intros l l1 l2 a HP. + symmetry in HP. + apply (Permutation_in a), in_split in HP; trivial. + apply in_elt. +Qed. + +Lemma Permutation_vs_cons_inv : forall l l1 a, + Permutation l (a :: l1) -> exists l' l'', l = l' ++ a :: l''. +Proof. + intros l l1 a HP. + rewrite <- (app_nil_l (a :: l1)) in HP. + apply (Permutation_vs_elt_inv _ _ _ HP). +Qed. + +Lemma Permutation_vs_cons_cons_inv : forall l l' a b, + Permutation l (a :: b :: l') -> + exists l1 l2 l3, l = l1 ++ a :: l2 ++ b :: l3 \/ l = l1 ++ b :: l2 ++ a :: l3. +Proof. + intros l l' a b HP. + destruct (Permutation_vs_cons_inv HP) as [l1 [l2]]; subst. + symmetry in HP. + apply Permutation_cons_app_inv in HP. + apply (Permutation_in b), in_app_or in HP; [|now apply in_eq]. + destruct HP as [(l3 & l4 & ->)%in_split | (l3 & l4 & ->)%in_split]. + - exists l3, l4, l2; right. + now rewrite <-app_assoc; simpl. + - now exists l1, l3, l4; left. +Qed. + Lemma NoDup_Permutation l l' : NoDup l -> NoDup l' -> (forall x:A, In x l <-> In x l') -> Permutation l l'. Proof. @@ -357,18 +499,20 @@ Proof. rewrite (NoDup_Add AD) in Hl'. tauto. Qed. -Lemma NoDup_Permutation_bis l l' : NoDup l -> NoDup l' -> +Lemma NoDup_Permutation_bis l l' : NoDup l -> length l' <= length l -> incl l l' -> Permutation l l'. Proof. intros. apply NoDup_Permutation; auto. - split; auto. apply NoDup_length_incl; trivial. + - now apply NoDup_incl_NoDup with l. + - split; auto. + apply NoDup_length_incl; trivial. Qed. Lemma Permutation_NoDup l l' : Permutation l l' -> NoDup l -> NoDup l'. Proof. induction 1; auto. - * inversion_clear 1; constructor; eauto using Permutation_in. - * inversion_clear 1 as [|? ? H1 H2]. inversion_clear H2; simpl in *. + - inversion_clear 1; constructor; eauto using Permutation_in. + - inversion_clear 1 as [|? ? H1 H2]. inversion_clear H2; simpl in *. constructor. simpl; intuition. constructor; intuition. Qed. @@ -397,6 +541,63 @@ Proof. exact Permutation_map. Qed. +Lemma Permutation_map_inv : forall l1 l2, + Permutation l1 (map f l2) -> exists l3, l1 = map f l3 /\ Permutation l2 l3. +Proof. + induction l1; intros l2 HP. + - exists nil; split; auto. + apply Permutation_nil in HP. + destruct l2; auto. + inversion HP. + - symmetry in HP. + destruct (Permutation_vs_cons_inv HP) as [l3 [l4 Heq]]. + destruct (map_eq_app _ _ _ _ Heq) as [l1' [l2' [Heq1 [Heq2 Heq3]]]]; subst. + symmetry in Heq3. + destruct (map_eq_cons _ _ Heq3) as [b [l1'' [Heq1' [Heq2' Heq3']]]]; subst. + rewrite map_app in HP; simpl in HP. + symmetry in HP. + apply Permutation_cons_app_inv in HP. + rewrite <- map_app in HP. + destruct (IHl1 _ HP) as [l3 [Heq1'' Heq2'']]; subst. + exists (b :: l3); split; auto. + symmetry in Heq2''; symmetry; apply (Permutation_cons_app _ _ _ Heq2''). +Qed. + +Lemma Permutation_image : forall a l l', + Permutation (a :: l) (map f l') -> exists a', a = f a'. +Proof. + intros a l l' HP. + destruct (Permutation_map_inv _ HP) as [l'' [Heq _]]. + destruct l'' as [ | a' l'']; inversion_clear Heq. + now exists a'. +Qed. + +Lemma Permutation_elt_map_inv: forall l1 l2 l3 l4 a, + Permutation (l1 ++ a :: l2) (l3 ++ map f l4) -> (forall b, a <> f b) -> + exists l1' l2', l3 = l1' ++ a :: l2'. +Proof. + intros l1 l2 l3 l4 a HP Hf. + apply (Permutation_in a), in_app_or in HP; [| now apply in_elt]. + destruct HP as [HP%in_split | (x & Heq & ?)%in_map_iff]; trivial; subst. + now contradiction (Hf x). +Qed. + +Instance Permutation_flat_map (g : A -> list B) : + Proper ((@Permutation A) ==> (@Permutation B)) (flat_map g). +Proof. + intros l1; induction l1; intros l2 HP. + - now apply Permutation_nil in HP; subst. + - symmetry in HP. + destruct (Permutation_vs_cons_inv HP) as [l' [l'']]; subst. + symmetry in HP. + apply Permutation_cons_app_inv in HP. + rewrite flat_map_app; simpl. + rewrite <- (app_nil_l _). + apply Permutation_app_middle; simpl. + rewrite <- flat_map_app. + apply (IHl1 _ HP). +Qed. + End Permutation_map. Lemma nat_bijection_Permutation n f : @@ -573,6 +774,86 @@ Qed. End Permutation_alt. +Instance Permutation_list_sum : Proper (@Permutation nat ==> eq) list_sum. +Proof. + intros l1 l2 HP; induction HP; simpl; intuition. + - rewrite 2 (Nat.add_comm x). + apply Nat.add_assoc. + - now transitivity (list_sum l'). +Qed. + +Instance Permutation_list_max : Proper (@Permutation nat ==> eq) list_max. +Proof. + intros l1 l2 HP; induction HP; simpl; intuition. + - rewrite 2 (Nat.max_comm x). + apply Nat.max_assoc. + - now transitivity (list_max l'). +Qed. + +Section Permutation_transp. + +Variable A:Type. + +(** Permutation definition based on transpositions for induction with fixed length *) +Inductive Permutation_transp : list A -> list A -> Prop := +| perm_t_refl : forall l, Permutation_transp l l +| perm_t_swap : forall x y l1 l2, Permutation_transp (l1 ++ y :: x :: l2) (l1 ++ x :: y :: l2) +| perm_t_trans l l' l'' : + Permutation_transp l l' -> Permutation_transp l' l'' -> Permutation_transp l l''. + +Instance Permutation_transp_sym : Symmetric Permutation_transp. +Proof. + intros l1 l2 HP; induction HP; subst; try (now constructor). + now apply (perm_t_trans IHHP2). +Qed. + +Instance Permutation_transp_equiv : Equivalence Permutation_transp. +Proof. + split. + - intros l; apply perm_t_refl. + - apply Permutation_transp_sym. + - intros l1 l2 l3 ;apply perm_t_trans. +Qed. + +Lemma Permutation_transp_cons : forall (x : A) l1 l2, + Permutation_transp l1 l2 -> Permutation_transp (x :: l1) (x :: l2). +Proof. + intros x l1 l2 HP. + induction HP. + - reflexivity. + - rewrite 2 app_comm_cons. + apply perm_t_swap. + - now transitivity (x :: l'). +Qed. + +Lemma Permutation_Permutation_transp : forall l1 l2 : list A, + Permutation l1 l2 <-> Permutation_transp l1 l2. +Proof. + intros l1 l2; split; intros HP; induction HP; intuition. + - now apply Permutation_transp_cons. + - rewrite <- (app_nil_l (y :: _)). + rewrite <- (app_nil_l (x :: y :: _)). + apply perm_t_swap. + - now transitivity l'. + - apply Permutation_app_head. + apply perm_swap. + - now transitivity l'. +Qed. + +Lemma Permutation_ind_transp : forall P : list A -> list A -> Prop, + (forall l, P l l) -> + (forall x y l1 l2, P (l1 ++ y :: x :: l2) (l1 ++ x :: y :: l2)) -> + (forall l l' l'', + Permutation l l' -> P l l' -> Permutation l' l'' -> P l' l'' -> P l l'') -> + forall l1 l2, Permutation l1 l2 -> P l1 l2. +Proof. + intros P Hr Ht Htr l1 l2 HP; apply Permutation_Permutation_transp in HP. + revert Hr Ht Htr; induction HP; intros Hr Ht Htr; auto. + apply (Htr _ l'); intuition; now apply Permutation_Permutation_transp. +Qed. + +End Permutation_transp. + (* begin hide *) Notation Permutation_app_swap := Permutation_app_comm (only parsing). (* end hide *) diff --git a/theories/Structures/OrderedTypeEx.v b/theories/Structures/OrderedTypeEx.v index 288aa0c789..83c690ab71 100644 --- a/theories/Structures/OrderedTypeEx.v +++ b/theories/Structures/OrderedTypeEx.v @@ -317,6 +317,82 @@ Module PositiveOrderedTypeBits <: UsualOrderedType. End PositiveOrderedTypeBits. +Module Ascii_as_OT <: UsualOrderedType. + Definition t := ascii. + + Definition eq := @eq ascii. + Definition eq_refl := @eq_refl t. + Definition eq_sym := @eq_sym t. + Definition eq_trans := @eq_trans t. + + Definition cmp (a b : ascii) : comparison := + N.compare (N_of_ascii a) (N_of_ascii b). + + Lemma cmp_eq (a b : ascii): + cmp a b = Eq <-> a = b. + Proof. + unfold cmp. + rewrite N.compare_eq_iff. + split. 2:{ intro. now subst. } + intro H. + rewrite<- (ascii_N_embedding a). + rewrite<- (ascii_N_embedding b). + now rewrite H. + Qed. + + Lemma cmp_lt_nat (a b : ascii): + cmp a b = Lt <-> (nat_of_ascii a < nat_of_ascii b)%nat. + Proof. + unfold cmp. unfold nat_of_ascii. + rewrite N2Nat.inj_compare. + rewrite Nat.compare_lt_iff. + reflexivity. + Qed. + + Lemma cmp_antisym (a b : ascii): + cmp a b = CompOpp (cmp b a). + Proof. + unfold cmp. + apply N.compare_antisym. + Qed. + + Definition lt (x y : ascii) := (N_of_ascii x < N_of_ascii y)%N. + + Lemma lt_trans (x y z : ascii): + lt x y -> lt y z -> lt x z. + Proof. + apply N.lt_trans. + Qed. + + Lemma lt_not_eq (x y : ascii): + lt x y -> x <> y. + Proof. + intros L H. subst. + exact (N.lt_irrefl _ L). + Qed. + + Local Lemma compare_helper_eq {a b : ascii} (E : cmp a b = Eq): + a = b. + Proof. + now apply cmp_eq. + Qed. + + Local Lemma compare_helper_gt {a b : ascii} (G : cmp a b = Gt): + lt b a. + Proof. + now apply N.compare_gt_iff. + Qed. + + Definition compare (a b : ascii) : Compare lt eq a b := + match cmp a b as z return _ = z -> _ with + | Lt => fun E => LT E + | Gt => fun E => GT (compare_helper_gt E) + | Eq => fun E => EQ (compare_helper_eq E) + end Logic.eq_refl. + + Definition eq_dec (x y : ascii): {x = y} + { ~ (x = y)} := ascii_dec x y. +End Ascii_as_OT. + (** [String] is an ordered type with respect to the usual lexical order. *) Module String_as_OT <: UsualOrderedType. @@ -378,32 +454,106 @@ Module String_as_OT <: UsualOrderedType. apply Nat.lt_irrefl in H2; auto. Qed. - Definition compare x y : Compare lt eq x y. + Fixpoint cmp (a b : string) : comparison := + match a, b with + | EmptyString, EmptyString => Eq + | EmptyString, _ => Lt + | String _ _, EmptyString => Gt + | String a_head a_tail, String b_head b_tail => + match Ascii_as_OT.cmp a_head b_head with + | Lt => Lt + | Gt => Gt + | Eq => cmp a_tail b_tail + end + end. + + Lemma cmp_eq (a b : string): + cmp a b = Eq <-> a = b. Proof. - generalize dependent y. - induction x as [ | a s1]; destruct y as [ | b s2]. - - apply EQ; constructor. - - apply LT; constructor. - - apply GT; constructor. - - destruct ((nat_of_ascii a) ?= (nat_of_ascii b))%nat eqn:ltb. - + assert (a = b). - { - apply Nat.compare_eq in ltb. - assert (ascii_of_nat (nat_of_ascii a) - = ascii_of_nat (nat_of_ascii b)) by auto. - repeat rewrite ascii_nat_embedding in H. - auto. - } - subst. - destruct (IHs1 s2). - * apply LT; constructor; auto. - * apply EQ. unfold eq in e. subst. constructor; auto. - * apply GT; constructor; auto. - + apply nat_compare_lt in ltb. - apply LT; constructor; auto. - + apply nat_compare_gt in ltb. - apply GT; constructor; auto. - Defined. + revert b. + induction a, b; try easy. + cbn. + remember (Ascii_as_OT.cmp _ _) as c eqn:Heqc. symmetry in Heqc. + destruct c; split; try discriminate; + try rewrite Ascii_as_OT.cmp_eq in Heqc; try subst; + try rewrite IHa; intro H. + { now subst. } + { now inversion H. } + { inversion H; subst. rewrite<- Heqc. now rewrite Ascii_as_OT.cmp_eq. } + { inversion H; subst. rewrite<- Heqc. now rewrite Ascii_as_OT.cmp_eq. } + Qed. + + Lemma cmp_antisym (a b : string): + cmp a b = CompOpp (cmp b a). + Proof. + revert b. + induction a, b; try easy. + cbn. rewrite IHa. clear IHa. + remember (Ascii_as_OT.cmp _ _) as c eqn:Heqc. symmetry in Heqc. + destruct c; rewrite Ascii_as_OT.cmp_antisym in Heqc; + destruct Ascii_as_OT.cmp; cbn in *; easy. + Qed. + + Lemma cmp_lt (a b : string): + cmp a b = Lt <-> lt a b. + Proof. + revert b. + induction a as [ | a_head a_tail ], b; try easy; cbn. + { split; trivial. intro. apply lts_empty. } + remember (Ascii_as_OT.cmp _ _) as c eqn:Heqc. symmetry in Heqc. + destruct c; split; intro H; try discriminate; trivial. + { + rewrite Ascii_as_OT.cmp_eq in Heqc. subst. + apply String_as_OT.lts_tail. + apply IHa_tail. + assumption. + } + { + rewrite Ascii_as_OT.cmp_eq in Heqc. subst. + inversion H; subst. { rewrite IHa_tail. assumption. } + exfalso. apply (Nat.lt_irrefl (nat_of_ascii a)). assumption. + } + { + apply String_as_OT.lts_head. + rewrite<- Ascii_as_OT.cmp_lt_nat. + assumption. + } + { + exfalso. inversion H; subst. + { + assert(X: Ascii_as_OT.cmp a a = Eq). { apply Ascii_as_OT.cmp_eq. trivial. } + rewrite Heqc in X. discriminate. + } + rewrite<- Ascii_as_OT.cmp_lt_nat in *. rewrite Heqc in *. discriminate. + } + Qed. + + Local Lemma compare_helper_lt {a b : string} (L : cmp a b = Lt): + lt a b. + Proof. + now apply cmp_lt. + Qed. + + Local Lemma compare_helper_gt {a b : string} (G : cmp a b = Gt): + lt b a. + Proof. + rewrite cmp_antisym in G. + rewrite CompOpp_iff in G. + now apply cmp_lt. + Qed. + + Local Lemma compare_helper_eq {a b : string} (E : cmp a b = Eq): + a = b. + Proof. + now apply cmp_eq. + Qed. + + Definition compare (a b : string) : Compare lt eq a b := + match cmp a b as z return _ = z -> _ with + | Lt => fun E => LT (compare_helper_lt E) + | Gt => fun E => GT (compare_helper_gt E) + | Eq => fun E => EQ (compare_helper_eq E) + end Logic.eq_refl. Definition eq_dec (x y : string): {x = y} + { ~ (x = y)} := string_dec x y. End String_as_OT. diff --git a/theories/Vectors/VectorSpec.v b/theories/Vectors/VectorSpec.v index 466e2bf994..443931e5bb 100644 --- a/theories/Vectors/VectorSpec.v +++ b/theories/Vectors/VectorSpec.v @@ -15,7 +15,7 @@ *) Require Fin. -Require Import VectorDef. +Require Import VectorDef PeanoNat Eqdep_dec. Import VectorNotations. Definition cons_inj {A} {a1 a2} {n} {v1 v2 : t A n} @@ -32,6 +32,8 @@ Defined. (** Lemmas are done for functions that use [Fin.t] but thanks to [Peano_dec.le_unique], all is true for the one that use [lt] *) +(** ** Properties of [nth] and [nth_order] *) + Lemma eq_nth_iff A n (v1 v2: t A n): (forall p1 p2, p1 = p2 -> v1 [@ p1 ] = v2 [@ p2 ]) <-> v1 = v2. Proof. @@ -44,12 +46,35 @@ split. - intros; now f_equal. Qed. +Lemma nth_order_hd A: forall n (v : t A (S n)) (H : 0 < S n), + nth_order v H = hd v. +Proof. intros; now rewrite (eta v). Qed. + +Lemma nth_order_tl A: forall n k (v : t A (S n)) (H : k < n) (HS : S k < S n), + nth_order (tl v) H = nth_order v HS. +Proof. +induction n; intros. +- inversion H. +- rewrite (eta v). + unfold nth_order; simpl. + now rewrite (Fin.of_nat_ext H (Lt.lt_S_n _ _ HS)). +Qed. + Lemma nth_order_last A: forall n (v: t A (S n)) (H: n < S n), nth_order v H = last v. Proof. unfold nth_order; refine (@rectS _ _ _ _); now simpl. Qed. +Lemma nth_order_ext A: forall n k (v : t A n) (H1 H2 : k < n), + nth_order v H1 = nth_order v H2. +Proof. +intros; unfold nth_order. +now rewrite (Fin.of_nat_ext H1 H2). +Qed. + +(** ** Properties of [shiftin] and [shiftrepeat] *) + Lemma shiftin_nth A a n (v: t A n) k1 k2 (eq: k1 = k2): nth (shiftin a v) (Fin.L_R 1 k1) = nth v k2. Proof. @@ -82,11 +107,99 @@ Proof. refine (@rectS _ _ _ _); now simpl. Qed. +(** ** Properties of [replace] *) + +Lemma nth_order_replace_eq A: forall n k (v : t A n) a (H1 : k < n) (H2 : k < n), + nth_order (replace v (Fin.of_nat_lt H2) a) H1 = a. +Proof. +intros n k; revert n; induction k; intros; + (destruct n; [ inversion H1 | subst ]). +- now rewrite nth_order_hd, (eta v). +- rewrite <- (nth_order_tl _ _ _ _ (proj2 (Nat.succ_lt_mono _ _) H1)), (eta v). + apply IHk. +Qed. + +Lemma nth_order_replace_neq A: forall n k1 k2, k1 <> k2 -> + forall (v : t A n) a (H1 : k1 < n) (H2 : k2 < n), + nth_order (replace v (Fin.of_nat_lt H2) a) H1 = nth_order v H1. +Proof. +intros n k1; revert n; induction k1; intros; + (destruct n ; [ inversion H1 | subst ]). +- rewrite 2 nth_order_hd. + destruct k2; intuition. + now rewrite 2 (eta v). +- rewrite <- 2 (nth_order_tl _ _ _ _ (proj2 (Nat.succ_lt_mono _ _) H1)), (eta v). + destruct k2; auto. + apply IHk1. + intros Hk; apply H; now subst. +Qed. + +Lemma replace_id A: forall n p (v : t A n), + replace v p (nth v p) = v. +Proof. +induction p; intros; rewrite 2 (eta v); simpl; auto. +now rewrite IHp. +Qed. + +Lemma replace_replace_eq A: forall n p (v : t A n) a b, + replace (replace v p a) p b = replace v p b. +Proof. +intros. +induction p; rewrite 2 (eta v); simpl; auto. +now rewrite IHp. +Qed. + +Lemma replace_replace_neq A: forall n p1 p2 (v : t A n) a b, p1 <> p2 -> + replace (replace v p1 a) p2 b = replace (replace v p2 b) p1 a. +Proof. +apply (Fin.rect2 (fun n p1 p2 => forall v a b, + p1 <> p2 -> replace (replace v p1 a) p2 b = replace (replace v p2 b) p1 a)). +- intros n v a b Hneq. + now contradiction Hneq. +- intros n p2 v; revert n v p2. + refine (@rectS _ _ _ _); auto. +- intros n p1 v; revert n v p1. + refine (@rectS _ _ _ _); auto. +- intros n p1 p2 IH v; revert n v p1 p2 IH. + refine (@rectS _ _ _ _); simpl; do 6 intro; [ | do 3 intro ]; intro Hneq; + f_equal; apply IH; intros Heq; apply Hneq; now subst. +Qed. + +(** ** Properties of [const] *) + Lemma const_nth A (a: A) n (p: Fin.t n): (const a n)[@ p] = a. Proof. now induction p. Qed. +(** ** Properties of [map] *) + +Lemma map_id A: forall n (v : t A n), + map (fun x => x) v = v. +Proof. +induction v; simpl; [ | rewrite IHv ]; auto. +Qed. + +Lemma map_map A B C: forall (f:A->B) (g:B->C) n (v : t A n), + map g (map f v) = map (fun x => g (f x)) v. +Proof. +induction v; simpl; [ | rewrite IHv ]; auto. +Qed. + +Lemma map_ext_in A B: forall (f g:A->B) n (v : t A n), + (forall a, In a v -> f a = g a) -> map f v = map g v. +Proof. +induction v; simpl; auto. +intros; rewrite H by constructor; rewrite IHv; intuition. +apply H; now constructor. +Qed. + +Lemma map_ext A B: forall (f g:A->B), (forall a, f a = g a) -> + forall n (v : t A n), map f v = map g v. +Proof. +intros; apply map_ext_in; auto. +Qed. + Lemma nth_map {A B} (f: A -> B) {n} v (p1 p2: Fin.t n) (eq: p1 = p2): (map f v) [@ p1] = f (v [@ p2]). Proof. @@ -105,6 +218,8 @@ refine (@rect2 _ _ _ _ _); simpl. now simpl. Qed. +(** ** Properties of [fold_left] *) + Lemma fold_left_right_assoc_eq {A B} {f: A -> B -> A} (assoc: forall a b c, f (f a b) c = f (f a c) b) {n} (v: t B n): forall a, fold_left f a v = fold_right (fun x y => f y x) v a. @@ -118,6 +233,8 @@ assert (forall n h (v: t B n) a, fold_left f (f a h) v = f (fold_left f a v) h). + simpl. intros; now rewrite<- (IHv). Qed. +(** ** Properties of [to_list] *) + Lemma to_list_of_list_opp {A} (l: list A): to_list (of_list l) = l. Proof. induction l. @@ -125,6 +242,8 @@ induction l. - unfold to_list; simpl. now f_equal. Qed. +(** ** Properties of [take] *) + Lemma take_O : forall {A} {n} le (v:t A n), take 0 le v = []. Proof. reflexivity. @@ -153,10 +272,14 @@ Proof. - destruct v. inversion le. simpl. apply f_equal. apply IHp. Qed. +(** ** Properties of [uncons] and [splitat] *) + Lemma uncons_cons {A} : forall {n : nat} (a : A) (v : t A n), uncons (a::v) = (a,v). Proof. reflexivity. Qed. +(* [append] *) + Lemma append_comm_cons {A} : forall {n m : nat} (v : t A n) (w : t A m) (a : A), a :: (v ++ w) = (a :: v) ++ w. Proof. reflexivity. Qed. @@ -187,3 +310,80 @@ Proof with auto. f_equal... apply IHv... Qed. + +(** ** Properties of [Forall] and [Forall2] *) + +Lemma Forall_impl A: forall (P Q : A -> Prop), (forall a, P a -> Q a) -> + forall n (v : t A n), Forall P v -> Forall Q v. +Proof. +induction v; intros HP; constructor; inversion HP as [| ? ? ? ? ? Heq1 [Heq2 He]]; + apply (inj_pair2_eq_dec _ Nat.eq_dec) in He; subst; intuition. +Qed. + +Lemma Forall_forall A: forall P n (v : t A n), + Forall P v <-> forall a, In a v -> P a. +Proof. +intros P n v; split. +- intros HP a Hin. + revert HP; induction Hin; intros HP; + inversion HP as [| ? ? ? ? ? Heq1 [Heq2 He]]; subst; auto. + apply (inj_pair2_eq_dec _ Nat.eq_dec) in He; subst; auto. +- induction v; intros Hin; constructor. + + apply Hin; constructor. + + apply IHv; intros a Ha. + apply Hin; now constructor. +Qed. + +Lemma Forall_nth_order A: forall P n (v : t A n), + Forall P v <-> forall i (Hi : i < n), P (nth_order v Hi). +Proof. +split; induction n. +- intros HF i Hi; inversion Hi. +- intros HF i Hi. + rewrite (eta v). + rewrite (eta v) in HF. + inversion HF as [| ? ? ? ? ? Heq1 [Heq2 He]]; subst. + apply (inj_pair2_eq_dec _ Nat.eq_dec) in He ; subst. + destruct i. + + now rewrite nth_order_hd. + + rewrite <- (nth_order_tl _ _ _ _ (proj2 (Nat.succ_lt_mono _ _) Hi) Hi). + now apply IHn. +- intros HP; apply case0; constructor. +- intros HP. + rewrite (eta v) in HP. + rewrite (eta v); constructor. + + specialize HP with 0 (Nat.lt_0_succ n). + now rewrite nth_order_hd in HP. + + apply IHn; intros. + specialize HP with (S i) (proj1 (Nat.succ_lt_mono _ _) Hi). + now rewrite <- (nth_order_tl _ _ _ _ Hi) in HP. +Qed. + +Lemma Forall2_nth_order A: forall P n (v1 v2 : t A n), + Forall2 P v1 v2 + <-> forall i (Hi1 : i < n) (Hi2 : i < n), P (nth_order v1 Hi1) (nth_order v2 Hi2). +Proof. +split; induction n. +- intros HF i Hi1 Hi2; inversion Hi1. +- intros HF i Hi1 Hi2. + rewrite (eta v1), (eta v2). + rewrite (eta v1), (eta v2) in HF. + inversion HF as [| ? ? ? ? ? ? ? Heq [Heq1 He1] [Heq2 He2]]. + apply (inj_pair2_eq_dec _ Nat.eq_dec) in He1. + apply (inj_pair2_eq_dec _ Nat.eq_dec) in He2; subst. + destruct i. + + now rewrite nth_order_hd. + + rewrite <- (nth_order_tl _ _ _ _ (proj2 (Nat.succ_lt_mono _ _) Hi1) Hi1). + rewrite <- (nth_order_tl _ _ _ _ (proj2 (Nat.succ_lt_mono _ _) Hi2) Hi2). + now apply IHn. +- intros _; revert v1; apply case0; revert v2; apply case0; constructor. +- intros HP. + rewrite (eta v1), (eta v2) in HP. + rewrite (eta v1), (eta v2); constructor. + + specialize HP with 0 (Nat.lt_0_succ _) (Nat.lt_0_succ _). + now rewrite nth_order_hd in HP. + + apply IHn; intros. + specialize HP with (S i) (proj1 (Nat.succ_lt_mono _ _) Hi1) + (proj1 (Nat.succ_lt_mono _ _) Hi2). + now rewrite <- (nth_order_tl _ _ _ _ Hi1), <- (nth_order_tl _ _ _ _ Hi2) in HP. +Qed. diff --git a/theories/dune b/theories/dune new file mode 100644 index 0000000000..b9af76d699 --- /dev/null +++ b/theories/dune @@ -0,0 +1,38 @@ +(coq.theory + (name Coq) + (package coq) + (synopsis "Coq's Standard Library") + (flags -q) + ; (mode native) + (boot) + ; (per_file + ; (Init/*.v -> -boot)) + (libraries + coq.plugins.ltac + coq.plugins.tauto + + coq.plugins.cc + coq.plugins.firstorder + + coq.plugins.numeral_notation + coq.plugins.string_notation + coq.plugins.int63_syntax + coq.plugins.r_syntax + coq.plugins.float_syntax + + coq.plugins.btauto + coq.plugins.rtauto + + coq.plugins.setoid_ring + coq.plugins.nsatz + coq.plugins.omega + + coq.plugins.zify + coq.plugins.micromega + + coq.plugins.funind + + coq.plugins.ssreflect + coq.plugins.derive)) + +(include_subdirs qualified) diff --git a/theories/ltac/Ltac.v b/theories/ltac/Ltac.v deleted file mode 100644 index e69de29bb2..0000000000 --- a/theories/ltac/Ltac.v +++ /dev/null diff --git a/theories/micromega/Lia.v b/theories/micromega/Lia.v index f3b70f61d2..3d955fec4f 100644 --- a/theories/micromega/Lia.v +++ b/theories/micromega/Lia.v @@ -21,7 +21,7 @@ Declare ML Module "micromega_plugin". Ltac zchecker := - intros __wit __varmap __ff ; + intros ?__wit ?__varmap ?__ff ; exact (ZTautoChecker_sound __ff __wit (@eq_refl bool true <: @eq bool (ZTautoChecker __ff __wit) true) (@find Z Z0 __varmap)). diff --git a/theories/micromega/Lqa.v b/theories/micromega/Lqa.v index 786c9275f0..8a4d59b1bd 100644 --- a/theories/micromega/Lqa.v +++ b/theories/micromega/Lqa.v @@ -23,7 +23,7 @@ Require Coq.micromega.Tauto. Declare ML Module "micromega_plugin". Ltac rchange := - intros __wit __varmap __ff ; + intros ?__wit ?__varmap ?__ff ; change (Tauto.eval_bf (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; apply (QTautoChecker_sound __ff __wit). diff --git a/theories/micromega/Lra.v b/theories/micromega/Lra.v index 3ac4772ba4..22cef50e0d 100644 --- a/theories/micromega/Lra.v +++ b/theories/micromega/Lra.v @@ -23,7 +23,7 @@ Require Coq.micromega.Tauto. Declare ML Module "micromega_plugin". Ltac rchange := - intros __wit __varmap __ff ; + intros ?__wit ?__varmap ?__ff ; change (Tauto.eval_bf (Reval_formula (@find R 0%R __varmap)) __ff) ; apply (RTautoChecker_sound __ff __wit). diff --git a/theories/micromega/ZArith_hints.v b/theories/micromega/ZArith_hints.v new file mode 100644 index 0000000000..a6d3d92a99 --- /dev/null +++ b/theories/micromega/ZArith_hints.v @@ -0,0 +1,43 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \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) *) +(************************************************************************) +Require Import Lia. +Import ZArith_base. + +Hint Resolve Z.le_refl Z.add_comm Z.add_assoc Z.mul_comm Z.mul_assoc Z.add_0_l + Z.add_0_r Z.mul_1_l Z.add_opp_diag_l Z.add_opp_diag_r Z.mul_add_distr_r + Z.mul_add_distr_l: zarith. + +Require Export Zhints. + +Hint Extern 10 (_ = _ :>nat) => abstract lia: zarith. +Hint Extern 10 (_ <= _) => abstract lia: zarith. +Hint Extern 10 (_ < _) => abstract lia: zarith. +Hint Extern 10 (_ >= _) => abstract lia: zarith. +Hint Extern 10 (_ > _) => abstract lia: zarith. + +Hint Extern 10 (_ <> _ :>nat) => abstract lia: zarith. +Hint Extern 10 (~ _ <= _) => abstract lia: zarith. +Hint Extern 10 (~ _ < _) => abstract lia: zarith. +Hint Extern 10 (~ _ >= _) => abstract lia: zarith. +Hint Extern 10 (~ _ > _) => abstract lia: zarith. + +Hint Extern 10 (_ = _ :>Z) => abstract lia: zarith. +Hint Extern 10 (_ <= _)%Z => abstract lia: zarith. +Hint Extern 10 (_ < _)%Z => abstract lia: zarith. +Hint Extern 10 (_ >= _)%Z => abstract lia: zarith. +Hint Extern 10 (_ > _)%Z => abstract lia: zarith. + +Hint Extern 10 (_ <> _ :>Z) => abstract lia: zarith. +Hint Extern 10 (~ (_ <= _)%Z) => abstract lia: zarith. +Hint Extern 10 (~ (_ < _)%Z) => abstract lia: zarith. +Hint Extern 10 (~ (_ >= _)%Z) => abstract lia: zarith. +Hint Extern 10 (~ (_ > _)%Z) => abstract lia: zarith. + +Hint Extern 10 False => abstract lia: zarith. diff --git a/theories/micromega/ZifyInst.v b/theories/micromega/ZifyInst.v index 521ac61e18..5b15dc072a 100644 --- a/theories/micromega/ZifyInst.v +++ b/theories/micromega/ZifyInst.v @@ -42,6 +42,9 @@ Instance Op_lt : BinRel lt := {| TR := Z.lt; TRInj := Nat2Z.inj_lt |}. Add BinRel Op_lt. +Instance Op_Nat_lt : BinRel Nat.lt := Op_lt. +Add BinRel Op_Nat_lt. + Instance Op_gt : BinRel gt := {| TR := Z.gt; TRInj := Nat2Z.inj_gt |}. Add BinRel Op_gt. @@ -50,10 +53,16 @@ Instance Op_le : BinRel le := {| TR := Z.le; TRInj := Nat2Z.inj_le |}. Add BinRel Op_le. +Instance Op_Nat_le : BinRel Nat.le := Op_le. +Add BinRel Op_Nat_le. + Instance Op_eq_nat : BinRel (@eq nat) := {| TR := @eq Z ; TRInj := fun x y : nat => iff_sym (Nat2Z.inj_iff x y) |}. Add BinRel Op_eq_nat. +Instance Op_Nat_eq : BinRel (Nat.eq) := Op_eq_nat. +Add BinRel Op_Nat_eq. + (* zify_nat_op *) Instance Op_plus : BinOp Nat.add := {| TBOp := Z.add; TBOpInj := Nat2Z.inj_add |}. diff --git a/theories/nsatz/Nsatz.v b/theories/nsatz/Nsatz.v index 93b84f3a02..70180f47c7 100644 --- a/theories/nsatz/Nsatz.v +++ b/theories/nsatz/Nsatz.v @@ -9,9 +9,9 @@ (************************************************************************) (* - Tactic nsatz: proofs of polynomials equalities in an integral domain + Tactic nsatz: proofs of polynomials equalities in an integral domain (commutative ring without zero divisor). - + Examples: see test-suite/success/Nsatz.v Reification is done using type classes, defined in Ncring_tac.v @@ -33,416 +33,9 @@ Require Import DiscrR. Require Import ZArith. Require Import Lia. -Declare ML Module "nsatz_plugin". - -Section nsatz1. - -Context {R:Type}`{Rid:Integral_domain R}. - -Lemma psos_r1b: forall x y:R, x - y == 0 -> x == y. -intros x y H; setoid_replace x with ((x - y) + y); simpl; - [setoid_rewrite H | idtac]; simpl. cring. cring. -Qed. - -Lemma psos_r1: forall x y, x == y -> x - y == 0. -intros x y H; simpl; setoid_rewrite H; simpl; cring. -Qed. - -Lemma nsatzR_diff: forall x y:R, not (x == y) -> not (x - y == 0). -intros. -intro; apply H. -simpl; setoid_replace x with ((x - y) + y). simpl. -setoid_rewrite H0. -simpl; cring. -simpl. simpl; cring. -Qed. - -(* adpatation du code de Benjamin aux setoides *) -Export Ring_polynom. -Export InitialRing. - -Definition PolZ := Pol Z. -Definition PEZ := PExpr Z. - -Definition P0Z : PolZ := P0 (C:=Z) 0%Z. - -Definition PolZadd : PolZ -> PolZ -> PolZ := - @Padd Z 0%Z Z.add Zeq_bool. - -Definition PolZmul : PolZ -> PolZ -> PolZ := - @Pmul Z 0%Z 1%Z Z.add Z.mul Zeq_bool. - -Definition PolZeq := @Peq Z Zeq_bool. - -Definition norm := - @norm_aux Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Zeq_bool. - -Fixpoint mult_l (la : list PEZ) (lp: list PolZ) : PolZ := - match la, lp with - | a::la, p::lp => PolZadd (PolZmul (norm a) p) (mult_l la lp) - | _, _ => P0Z - end. - -Fixpoint compute_list (lla: list (list PEZ)) (lp:list PolZ) := - match lla with - | List.nil => lp - | la::lla => compute_list lla ((mult_l la lp)::lp) - end. - -Definition check (lpe:list PEZ) (qe:PEZ) (certif: list (list PEZ) * list PEZ) := - let (lla, lq) := certif in - let lp := List.map norm lpe in - PolZeq (norm qe) (mult_l lq (compute_list lla lp)). - - -(* Correction *) -Definition PhiR : list R -> PolZ -> R := - (Pphi ring0 add mul - (InitialRing.gen_phiZ ring0 ring1 add mul opp)). - -Definition PEevalR : list R -> PEZ -> R := - PEeval ring0 ring1 add mul sub opp - (gen_phiZ ring0 ring1 add mul opp) - N.to_nat pow. - -Lemma P0Z_correct : forall l, PhiR l P0Z = 0. -Proof. trivial. Qed. - -Lemma Rext: ring_eq_ext add mul opp _==_. -Proof. -constructor; solve_proper. -Qed. - -Lemma Rset : Setoid_Theory R _==_. -apply ring_setoid. -Qed. - -Definition Rtheory:ring_theory ring0 ring1 add mul sub opp _==_. -apply mk_rt. -apply ring_add_0_l. -apply ring_add_comm. -apply ring_add_assoc. -apply ring_mul_1_l. -apply cring_mul_comm. -apply ring_mul_assoc. -apply ring_distr_l. -apply ring_sub_def. -apply ring_opp_def. -Defined. - -Lemma PolZadd_correct : forall P' P l, - PhiR l (PolZadd P P') == ((PhiR l P) + (PhiR l P')). -Proof. -unfold PolZadd, PhiR. intros. simpl. - refine (Padd_ok Rset Rext (Rth_ARth Rset Rext Rtheory) - (gen_phiZ_morph Rset Rext Rtheory) _ _ _). -Qed. - -Lemma PolZmul_correct : forall P P' l, - PhiR l (PolZmul P P') == ((PhiR l P) * (PhiR l P')). -Proof. -unfold PolZmul, PhiR. intros. - refine (Pmul_ok Rset Rext (Rth_ARth Rset Rext Rtheory) - (gen_phiZ_morph Rset Rext Rtheory) _ _ _). -Qed. - -Lemma R_power_theory - : Ring_theory.power_theory ring1 mul _==_ N.to_nat pow. -apply Ring_theory.mkpow_th. unfold pow. intros. rewrite Nnat.N2Nat.id. -reflexivity. Qed. - -Lemma norm_correct : - forall (l : list R) (pe : PEZ), PEevalR l pe == PhiR l (norm pe). -Proof. - intros;apply (norm_aux_spec Rset Rext (Rth_ARth Rset Rext Rtheory) - (gen_phiZ_morph Rset Rext Rtheory) R_power_theory). -Qed. - -Lemma PolZeq_correct : forall P P' l, - PolZeq P P' = true -> - PhiR l P == PhiR l P'. -Proof. - intros;apply - (Peq_ok Rset Rext (gen_phiZ_morph Rset Rext Rtheory));trivial. -Qed. - -Fixpoint Cond0 (A:Type) (Interp:A->R) (l:list A) : Prop := - match l with - | List.nil => True - | a::l => Interp a == 0 /\ Cond0 A Interp l - end. - -Lemma mult_l_correct : forall l la lp, - Cond0 PolZ (PhiR l) lp -> - PhiR l (mult_l la lp) == 0. -Proof. - induction la;simpl;intros. cring. - destruct lp;trivial. simpl. cring. - simpl in H;destruct H. - rewrite PolZadd_correct. - simpl. rewrite PolZmul_correct. simpl. rewrite H. - rewrite IHla. cring. trivial. -Qed. - -Lemma compute_list_correct : forall l lla lp, - Cond0 PolZ (PhiR l) lp -> - Cond0 PolZ (PhiR l) (compute_list lla lp). -Proof. - induction lla;simpl;intros;trivial. - apply IHlla;simpl;split;trivial. - apply mult_l_correct;trivial. -Qed. - -Lemma check_correct : - forall l lpe qe certif, - check lpe qe certif = true -> - Cond0 PEZ (PEevalR l) lpe -> - PEevalR l qe == 0. -Proof. - unfold check;intros l lpe qe (lla, lq) H2 H1. - apply PolZeq_correct with (l:=l) in H2. - rewrite norm_correct, H2. - apply mult_l_correct. - apply compute_list_correct. - clear H2 lq lla qe;induction lpe;simpl;trivial. - simpl in H1;destruct H1. - rewrite <- norm_correct;auto. -Qed. - -(* fin *) - -Definition R2:= 1 + 1. - -Fixpoint IPR p {struct p}: R := - match p with - xH => ring1 - | xO xH => 1+1 - | xO p1 => R2*(IPR p1) - | xI xH => 1+(1+1) - | xI p1 => 1+(R2*(IPR p1)) - end. - -Definition IZR1 z := - match z with Z0 => 0 - | Zpos p => IPR p - | Zneg p => -(IPR p) - end. - -Fixpoint interpret3 t fv {struct t}: R := - match t with - | (PEadd t1 t2) => - let v1 := interpret3 t1 fv in - let v2 := interpret3 t2 fv in (v1 + v2) - | (PEmul t1 t2) => - let v1 := interpret3 t1 fv in - let v2 := interpret3 t2 fv in (v1 * v2) - | (PEsub t1 t2) => - let v1 := interpret3 t1 fv in - let v2 := interpret3 t2 fv in (v1 - v2) - | (PEopp t1) => - let v1 := interpret3 t1 fv in (-v1) - | (PEpow t1 t2) => - let v1 := interpret3 t1 fv in pow v1 (N.to_nat t2) - | (PEc t1) => (IZR1 t1) - | PEO => 0 - | PEI => 1 - | (PEX _ n) => List.nth (pred (Pos.to_nat n)) fv 0 - end. - - -End nsatz1. - -Ltac equality_to_goal H x y:= - (* eliminate trivial hypotheses, but it takes time!: - let h := fresh "nH" in - (assert (h:equality x y); - [solve [cring] | clear H; clear h]) - || *) try (generalize (@psos_r1 _ _ _ _ _ _ _ _ _ _ _ x y H); clear H) -. - -Ltac equalities_to_goal := - lazymatch goal with - | H: (_ ?x ?y) |- _ => equality_to_goal H x y - | H: (_ _ ?x ?y) |- _ => equality_to_goal H x y - | H: (_ _ _ ?x ?y) |- _ => equality_to_goal H x y - | H: (_ _ _ _ ?x ?y) |- _ => equality_to_goal H x y -(* extension possible :-) *) - | H: (?x == ?y) |- _ => equality_to_goal H x y - end. - -(* lp est incluse dans fv. La met en tete. *) - -Ltac parametres_en_tete fv lp := - match fv with - | (@nil _) => lp - | (@cons _ ?x ?fv1) => - let res := AddFvTail x lp in - parametres_en_tete fv1 res - end. - -Ltac append1 a l := - match l with - | (@nil _) => constr:(cons a l) - | (cons ?x ?l) => let l' := append1 a l in constr:(cons x l') - end. - -Ltac rev l := - match l with - |(@nil _) => l - | (cons ?x ?l) => let l' := rev l in append1 x l' - end. - -Ltac nsatz_call_n info nparam p rr lp kont := -(* idtac "Trying power: " rr;*) - let ll := constr:(PEc info :: PEc nparam :: PEpow p rr :: lp) in -(* idtac "calcul...";*) - nsatz_compute ll; -(* idtac "done";*) - match goal with - | |- (?c::PEpow _ ?r::?lq0)::?lci0 = _ -> _ => - intros _; - let lci := fresh "lci" in - set (lci:=lci0); - let lq := fresh "lq" in - set (lq:=lq0); - kont c rr lq lci - end. - -Ltac nsatz_call radicalmax info nparam p lp kont := - let rec try_n n := - lazymatch n with - | 0%N => fail - | _ => - (let r := eval compute in (N.sub radicalmax (N.pred n)) in - nsatz_call_n info nparam p r lp kont) || - let n' := eval compute in (N.pred n) in try_n n' - end in - try_n radicalmax. - - -Ltac lterm_goal g := - match g with - ?b1 == ?b2 => constr:(b1::b2::nil) - | ?b1 == ?b2 -> ?g => let l := lterm_goal g in constr:(b1::b2::l) - end. - -Ltac reify_goal l le lb:= - match le with - nil => idtac - | ?e::?le1 => - match lb with - ?b::?lb1 => (* idtac "b="; idtac b;*) - let x := fresh "B" in - set (x:= b) at 1; - change x with (interpret3 e l); - clear x; - reify_goal l le1 lb1 - end - end. - -Ltac get_lpol g := - match g with - (interpret3 ?p _) == _ => constr:(p::nil) - | (interpret3 ?p _) == _ -> ?g => - let l := get_lpol g in constr:(p::l) - end. - -Ltac nsatz_generic radicalmax info lparam lvar := - let nparam := eval compute in (Z.of_nat (List.length lparam)) in - match goal with - |- ?g => let lb := lterm_goal g in - match (match lvar with - |(@nil _) => - match lparam with - |(@nil _) => - let r := eval red in (list_reifyl (lterm:=lb)) in r - |_ => - match eval red in (list_reifyl (lterm:=lb)) with - |(?fv, ?le) => - let fv := parametres_en_tete fv lparam in - (* we reify a second time, with the good order - for variables *) - let r := eval red in - (list_reifyl (lterm:=lb) (lvar:=fv)) in r - end - end - |_ => - let fv := parametres_en_tete lvar lparam in - let r := eval red in (list_reifyl (lterm:=lb) (lvar:=fv)) in r - end) with - |(?fv, ?le) => - reify_goal fv le lb ; - match goal with - |- ?g => - let lp := get_lpol g in - let lpol := eval compute in (List.rev lp) in - intros; - - let SplitPolyList kont := - match lpol with - | ?p2::?lp2 => kont p2 lp2 - | _ => idtac "polynomial not in the ideal" - end in - - SplitPolyList ltac:(fun p lp => - let p21 := fresh "p21" in - let lp21 := fresh "lp21" in - set (p21:=p) ; - set (lp21:=lp); -(* idtac "nparam:"; idtac nparam; idtac "p:"; idtac p; idtac "lp:"; idtac lp; *) - nsatz_call radicalmax info nparam p lp ltac:(fun c r lq lci => - let q := fresh "q" in - set (q := PEmul c (PEpow p21 r)); - let Hg := fresh "Hg" in - assert (Hg:check lp21 q (lci,lq) = true); - [ (vm_compute;reflexivity) || idtac "invalid nsatz certificate" - | let Hg2 := fresh "Hg" in - assert (Hg2: (interpret3 q fv) == 0); - [ (*simpl*) idtac; - generalize (@check_correct _ _ _ _ _ _ _ _ _ _ _ fv lp21 q (lci,lq) Hg); - let cc := fresh "H" in - (*simpl*) idtac; intro cc; apply cc; clear cc; - (*simpl*) idtac; - repeat (split;[assumption|idtac]); exact I - | (*simpl in Hg2;*) (*simpl*) idtac; - apply Rintegral_domain_pow with (interpret3 c fv) (N.to_nat r); - (*simpl*) idtac; - try apply integral_domain_one_zero; - try apply integral_domain_minus_one_zero; - try trivial; - try exact integral_domain_one_zero; - try exact integral_domain_minus_one_zero - || (solve [simpl; unfold R2, equality, eq_notation, addition, add_notation, - one, one_notation, multiplication, mul_notation, zero, zero_notation; - discrR || lia ]) - || ((*simpl*) idtac) || idtac "could not prove discrimination result" - ] - ] -) -) -end end end . - -Ltac nsatz_default:= - intros; - try apply (@psos_r1b _ _ _ _ _ _ _ _ _ _ _); - match goal with |- (@equality ?r _ _ _) => - repeat equalities_to_goal; - nsatz_generic 6%N 1%Z (@nil r) (@nil r) - end. - -Tactic Notation "nsatz" := nsatz_default. - -Tactic Notation "nsatz" "with" - "radicalmax" ":=" constr(radicalmax) - "strategy" ":=" constr(info) - "parameters" ":=" constr(lparam) - "variables" ":=" constr(lvar):= - intros; - try apply (@psos_r1b _ _ _ _ _ _ _ _ _ _ _); - match goal with |- (@equality ?r _ _ _) => - repeat equalities_to_goal; - nsatz_generic radicalmax info lparam lvar - end. +Require Export NsatzTactic. +(** Make use of [discrR] in [nsatz] *) +Ltac nsatz_internal_discrR ::= discrR. (* Real numbers *) Require Import Reals. @@ -462,7 +55,7 @@ try (try apply Rsth; intros; try rewrite H; try rewrite H0; reflexivity)). exact Rplus_0_l. exact Rplus_comm. symmetry. apply Rplus_assoc. exact Rmult_1_l. exact Rmult_1_r. symmetry. apply Rmult_assoc. - exact Rmult_plus_distr_r. intros; apply Rmult_plus_distr_l. + exact Rmult_plus_distr_r. intros; apply Rmult_plus_distr_l. exact Rplus_opp_r. Defined. @@ -479,8 +72,8 @@ Qed. Instance Rcri: (Cring (Rr:=Rri)). red. exact Rmult_comm. Defined. -Instance Rdi : (Integral_domain (Rcr:=Rcri)). -constructor. +Instance Rdi : (Integral_domain (Rcr:=Rcri)). +constructor. exact Rmult_integral. exact R_one_zero. Defined. (* Rational numbers *) @@ -491,14 +84,14 @@ Defined. Instance Qri : (Ring (Ro:=Qops)). constructor. -try apply Q_Setoid. -apply Qplus_comp. -apply Qmult_comp. -apply Qminus_comp. +try apply Q_Setoid. +apply Qplus_comp. +apply Qmult_comp. +apply Qminus_comp. apply Qopp_comp. exact Qplus_0_l. exact Qplus_comm. apply Qplus_assoc. exact Qmult_1_l. exact Qmult_1_r. apply Qmult_assoc. - apply Qmult_plus_distr_l. intros. apply Qmult_plus_distr_r. + apply Qmult_plus_distr_l. intros. apply Qmult_plus_distr_r. reflexivity. exact Qplus_opp_r. Defined. @@ -508,8 +101,8 @@ Proof. unfold Qeq. simpl. lia. Qed. Instance Qcri: (Cring (Rr:=Qri)). red. exact Qmult_comm. Defined. -Instance Qdi : (Integral_domain (Rcr:=Qcri)). -constructor. +Instance Qdi : (Integral_domain (Rcr:=Qcri)). +constructor. exact Qmult_integral. exact Q_one_zero. Defined. (* Integers *) @@ -519,7 +112,6 @@ Proof. lia. Qed. Instance Zcri: (Cring (Rr:=Zr)). red. exact Z.mul_comm. Defined. -Instance Zdi : (Integral_domain (Rcr:=Zcri)). -constructor. +Instance Zdi : (Integral_domain (Rcr:=Zcri)). +constructor. exact Zmult_integral. exact Z_one_zero. Defined. - diff --git a/theories/nsatz/NsatzTactic.v b/theories/nsatz/NsatzTactic.v new file mode 100644 index 0000000000..db7dab2c46 --- /dev/null +++ b/theories/nsatz/NsatzTactic.v @@ -0,0 +1,449 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \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) *) +(************************************************************************) + +(* + Tactic nsatz: proofs of polynomials equalities in an integral domain +(commutative ring without zero divisor). + +Examples: see test-suite/success/Nsatz.v + +Reification is done using type classes, defined in Ncring_tac.v + +*) + +Require Import List. +Require Import Setoid. +Require Import BinPos. +Require Import BinList. +Require Import Znumtheory. +Require Export Morphisms Setoid Bool. +Require Export Algebra_syntax. +Require Export Ncring. +Require Export Ncring_initial. +Require Export Ncring_tac. +Require Export Integral_domain. +Require Import ZArith. +Require Import Lia. + +Declare ML Module "nsatz_plugin". + +Section nsatz1. + +Context {R:Type}`{Rid:Integral_domain R}. + +Lemma psos_r1b: forall x y:R, x - y == 0 -> x == y. +intros x y H; setoid_replace x with ((x - y) + y); simpl; + [setoid_rewrite H | idtac]; simpl. cring. cring. +Qed. + +Lemma psos_r1: forall x y, x == y -> x - y == 0. +intros x y H; simpl; setoid_rewrite H; simpl; cring. +Qed. + +Lemma nsatzR_diff: forall x y:R, not (x == y) -> not (x - y == 0). +intros. +intro; apply H. +simpl; setoid_replace x with ((x - y) + y). simpl. +setoid_rewrite H0. +simpl; cring. +simpl. simpl; cring. +Qed. + +(* adpatation du code de Benjamin aux setoides *) +Export Ring_polynom. +Export InitialRing. + +Definition PolZ := Pol Z. +Definition PEZ := PExpr Z. + +Definition P0Z : PolZ := P0 (C:=Z) 0%Z. + +Definition PolZadd : PolZ -> PolZ -> PolZ := + @Padd Z 0%Z Z.add Zeq_bool. + +Definition PolZmul : PolZ -> PolZ -> PolZ := + @Pmul Z 0%Z 1%Z Z.add Z.mul Zeq_bool. + +Definition PolZeq := @Peq Z Zeq_bool. + +Definition norm := + @norm_aux Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Zeq_bool. + +Fixpoint mult_l (la : list PEZ) (lp: list PolZ) : PolZ := + match la, lp with + | a::la, p::lp => PolZadd (PolZmul (norm a) p) (mult_l la lp) + | _, _ => P0Z + end. + +Fixpoint compute_list (lla: list (list PEZ)) (lp:list PolZ) := + match lla with + | List.nil => lp + | la::lla => compute_list lla ((mult_l la lp)::lp) + end. + +Definition check (lpe:list PEZ) (qe:PEZ) (certif: list (list PEZ) * list PEZ) := + let (lla, lq) := certif in + let lp := List.map norm lpe in + PolZeq (norm qe) (mult_l lq (compute_list lla lp)). + + +(* Correction *) +Definition PhiR : list R -> PolZ -> R := + (Pphi ring0 add mul + (InitialRing.gen_phiZ ring0 ring1 add mul opp)). + +Definition PEevalR : list R -> PEZ -> R := + PEeval ring0 ring1 add mul sub opp + (gen_phiZ ring0 ring1 add mul opp) + N.to_nat pow. + +Lemma P0Z_correct : forall l, PhiR l P0Z = 0. +Proof. trivial. Qed. + +Lemma Rext: ring_eq_ext add mul opp _==_. +Proof. +constructor; solve_proper. +Qed. + +Lemma Rset : Setoid_Theory R _==_. +apply ring_setoid. +Qed. + +Definition Rtheory:ring_theory ring0 ring1 add mul sub opp _==_. +apply mk_rt. +apply ring_add_0_l. +apply ring_add_comm. +apply ring_add_assoc. +apply ring_mul_1_l. +apply cring_mul_comm. +apply ring_mul_assoc. +apply ring_distr_l. +apply ring_sub_def. +apply ring_opp_def. +Defined. + +Lemma PolZadd_correct : forall P' P l, + PhiR l (PolZadd P P') == ((PhiR l P) + (PhiR l P')). +Proof. +unfold PolZadd, PhiR. intros. simpl. + refine (Padd_ok Rset Rext (Rth_ARth Rset Rext Rtheory) + (gen_phiZ_morph Rset Rext Rtheory) _ _ _). +Qed. + +Lemma PolZmul_correct : forall P P' l, + PhiR l (PolZmul P P') == ((PhiR l P) * (PhiR l P')). +Proof. +unfold PolZmul, PhiR. intros. + refine (Pmul_ok Rset Rext (Rth_ARth Rset Rext Rtheory) + (gen_phiZ_morph Rset Rext Rtheory) _ _ _). +Qed. + +Lemma R_power_theory + : Ring_theory.power_theory ring1 mul _==_ N.to_nat pow. +apply Ring_theory.mkpow_th. unfold pow. intros. rewrite Nnat.N2Nat.id. +reflexivity. Qed. + +Lemma norm_correct : + forall (l : list R) (pe : PEZ), PEevalR l pe == PhiR l (norm pe). +Proof. + intros;apply (norm_aux_spec Rset Rext (Rth_ARth Rset Rext Rtheory) + (gen_phiZ_morph Rset Rext Rtheory) R_power_theory). +Qed. + +Lemma PolZeq_correct : forall P P' l, + PolZeq P P' = true -> + PhiR l P == PhiR l P'. +Proof. + intros;apply + (Peq_ok Rset Rext (gen_phiZ_morph Rset Rext Rtheory));trivial. +Qed. + +Fixpoint Cond0 (A:Type) (Interp:A->R) (l:list A) : Prop := + match l with + | List.nil => True + | a::l => Interp a == 0 /\ Cond0 A Interp l + end. + +Lemma mult_l_correct : forall l la lp, + Cond0 PolZ (PhiR l) lp -> + PhiR l (mult_l la lp) == 0. +Proof. + induction la;simpl;intros. cring. + destruct lp;trivial. simpl. cring. + simpl in H;destruct H. + rewrite PolZadd_correct. + simpl. rewrite PolZmul_correct. simpl. rewrite H. + rewrite IHla. cring. trivial. +Qed. + +Lemma compute_list_correct : forall l lla lp, + Cond0 PolZ (PhiR l) lp -> + Cond0 PolZ (PhiR l) (compute_list lla lp). +Proof. + induction lla;simpl;intros;trivial. + apply IHlla;simpl;split;trivial. + apply mult_l_correct;trivial. +Qed. + +Lemma check_correct : + forall l lpe qe certif, + check lpe qe certif = true -> + Cond0 PEZ (PEevalR l) lpe -> + PEevalR l qe == 0. +Proof. + unfold check;intros l lpe qe (lla, lq) H2 H1. + apply PolZeq_correct with (l:=l) in H2. + rewrite norm_correct, H2. + apply mult_l_correct. + apply compute_list_correct. + clear H2 lq lla qe;induction lpe;simpl;trivial. + simpl in H1;destruct H1. + rewrite <- norm_correct;auto. +Qed. + +(* fin *) + +Definition R2:= 1 + 1. + +Fixpoint IPR p {struct p}: R := + match p with + xH => ring1 + | xO xH => 1+1 + | xO p1 => R2*(IPR p1) + | xI xH => 1+(1+1) + | xI p1 => 1+(R2*(IPR p1)) + end. + +Definition IZR1 z := + match z with Z0 => 0 + | Zpos p => IPR p + | Zneg p => -(IPR p) + end. + +Fixpoint interpret3 t fv {struct t}: R := + match t with + | (PEadd t1 t2) => + let v1 := interpret3 t1 fv in + let v2 := interpret3 t2 fv in (v1 + v2) + | (PEmul t1 t2) => + let v1 := interpret3 t1 fv in + let v2 := interpret3 t2 fv in (v1 * v2) + | (PEsub t1 t2) => + let v1 := interpret3 t1 fv in + let v2 := interpret3 t2 fv in (v1 - v2) + | (PEopp t1) => + let v1 := interpret3 t1 fv in (-v1) + | (PEpow t1 t2) => + let v1 := interpret3 t1 fv in pow v1 (N.to_nat t2) + | (PEc t1) => (IZR1 t1) + | PEO => 0 + | PEI => 1 + | (PEX _ n) => List.nth (pred (Pos.to_nat n)) fv 0 + end. + + +End nsatz1. + +Ltac equality_to_goal H x y:= + (* eliminate trivial hypotheses, but it takes time!: + let h := fresh "nH" in + (assert (h:equality x y); + [solve [cring] | clear H; clear h]) + || *) try (generalize (@psos_r1 _ _ _ _ _ _ _ _ _ _ _ x y H); clear H) +. + +Ltac equalities_to_goal := + lazymatch goal with + | H: (_ ?x ?y) |- _ => equality_to_goal H x y + | H: (_ _ ?x ?y) |- _ => equality_to_goal H x y + | H: (_ _ _ ?x ?y) |- _ => equality_to_goal H x y + | H: (_ _ _ _ ?x ?y) |- _ => equality_to_goal H x y +(* extension possible :-) *) + | H: (?x == ?y) |- _ => equality_to_goal H x y + end. + +(* lp est incluse dans fv. La met en tete. *) + +Ltac parametres_en_tete fv lp := + match fv with + | (@nil _) => lp + | (@cons _ ?x ?fv1) => + let res := AddFvTail x lp in + parametres_en_tete fv1 res + end. + +Ltac append1 a l := + match l with + | (@nil _) => constr:(cons a l) + | (cons ?x ?l) => let l' := append1 a l in constr:(cons x l') + end. + +Ltac rev l := + match l with + |(@nil _) => l + | (cons ?x ?l) => let l' := rev l in append1 x l' + end. + +Ltac nsatz_call_n info nparam p rr lp kont := +(* idtac "Trying power: " rr;*) + let ll := constr:(PEc info :: PEc nparam :: PEpow p rr :: lp) in +(* idtac "calcul...";*) + nsatz_compute ll; +(* idtac "done";*) + match goal with + | |- (?c::PEpow _ ?r::?lq0)::?lci0 = _ -> _ => + intros _; + let lci := fresh "lci" in + set (lci:=lci0); + let lq := fresh "lq" in + set (lq:=lq0); + kont c rr lq lci + end. + +Ltac nsatz_call radicalmax info nparam p lp kont := + let rec try_n n := + lazymatch n with + | 0%N => fail + | _ => + (let r := eval compute in (N.sub radicalmax (N.pred n)) in + nsatz_call_n info nparam p r lp kont) || + let n' := eval compute in (N.pred n) in try_n n' + end in + try_n radicalmax. + + +Ltac lterm_goal g := + match g with + ?b1 == ?b2 => constr:(b1::b2::nil) + | ?b1 == ?b2 -> ?g => let l := lterm_goal g in constr:(b1::b2::l) + end. + +Ltac reify_goal l le lb:= + match le with + nil => idtac + | ?e::?le1 => + match lb with + ?b::?lb1 => (* idtac "b="; idtac b;*) + let x := fresh "B" in + set (x:= b) at 1; + change x with (interpret3 e l); + clear x; + reify_goal l le1 lb1 + end + end. + +Ltac get_lpol g := + match g with + (interpret3 ?p _) == _ => constr:(p::nil) + | (interpret3 ?p _) == _ -> ?g => + let l := get_lpol g in constr:(p::l) + end. + +(** We only make use of [discrR] if [nsatz] support for reals is + loaded. To do this, we redefine this tactic in Nsatz.v to make + use of real discrimination. *) +Ltac nsatz_internal_discrR := idtac. + +Ltac nsatz_generic radicalmax info lparam lvar := + let nparam := eval compute in (Z.of_nat (List.length lparam)) in + match goal with + |- ?g => let lb := lterm_goal g in + match (match lvar with + |(@nil _) => + match lparam with + |(@nil _) => + let r := eval red in (list_reifyl (lterm:=lb)) in r + |_ => + match eval red in (list_reifyl (lterm:=lb)) with + |(?fv, ?le) => + let fv := parametres_en_tete fv lparam in + (* we reify a second time, with the good order + for variables *) + let r := eval red in + (list_reifyl (lterm:=lb) (lvar:=fv)) in r + end + end + |_ => + let fv := parametres_en_tete lvar lparam in + let r := eval red in (list_reifyl (lterm:=lb) (lvar:=fv)) in r + end) with + |(?fv, ?le) => + reify_goal fv le lb ; + match goal with + |- ?g => + let lp := get_lpol g in + let lpol := eval compute in (List.rev lp) in + intros; + + let SplitPolyList kont := + match lpol with + | ?p2::?lp2 => kont p2 lp2 + | _ => idtac "polynomial not in the ideal" + end in + + SplitPolyList ltac:(fun p lp => + let p21 := fresh "p21" in + let lp21 := fresh "lp21" in + set (p21:=p) ; + set (lp21:=lp); +(* idtac "nparam:"; idtac nparam; idtac "p:"; idtac p; idtac "lp:"; idtac lp; *) + nsatz_call radicalmax info nparam p lp ltac:(fun c r lq lci => + let q := fresh "q" in + set (q := PEmul c (PEpow p21 r)); + let Hg := fresh "Hg" in + assert (Hg:check lp21 q (lci,lq) = true); + [ (vm_compute;reflexivity) || idtac "invalid nsatz certificate" + | let Hg2 := fresh "Hg" in + assert (Hg2: (interpret3 q fv) == 0); + [ (*simpl*) idtac; + generalize (@check_correct _ _ _ _ _ _ _ _ _ _ _ fv lp21 q (lci,lq) Hg); + let cc := fresh "H" in + (*simpl*) idtac; intro cc; apply cc; clear cc; + (*simpl*) idtac; + repeat (split;[assumption|idtac]); exact I + | (*simpl in Hg2;*) (*simpl*) idtac; + apply Rintegral_domain_pow with (interpret3 c fv) (N.to_nat r); + (*simpl*) idtac; + try apply integral_domain_one_zero; + try apply integral_domain_minus_one_zero; + try trivial; + try exact integral_domain_one_zero; + try exact integral_domain_minus_one_zero + || (solve [simpl; unfold R2, equality, eq_notation, addition, add_notation, + one, one_notation, multiplication, mul_notation, zero, zero_notation; + nsatz_internal_discrR || lia ]) + || ((*simpl*) idtac) || idtac "could not prove discrimination result" + ] + ] +) +) +end end end . + +Ltac nsatz_default:= + intros; + try apply (@psos_r1b _ _ _ _ _ _ _ _ _ _ _); + match goal with |- (@equality ?r _ _ _) => + repeat equalities_to_goal; + nsatz_generic 6%N 1%Z (@nil r) (@nil r) + end. + +Tactic Notation "nsatz" := nsatz_default. + +Tactic Notation "nsatz" "with" + "radicalmax" ":=" constr(radicalmax) + "strategy" ":=" constr(info) + "parameters" ":=" constr(lparam) + "variables" ":=" constr(lvar):= + intros; + try apply (@psos_r1b _ _ _ _ _ _ _ _ _ _ _); + match goal with |- (@equality ?r _ _ _) => + repeat equalities_to_goal; + nsatz_generic radicalmax info lparam lvar + end. diff --git a/theories/omega/Omega.v b/theories/omega/Omega.v index 10a5aa47b3..5c52284621 100644 --- a/theories/omega/Omega.v +++ b/theories/omega/Omega.v @@ -19,38 +19,6 @@ Require Export ZArith_base. Require Export OmegaLemmas. Require Export PreOmega. -Require Import Lia. +Require Export ZArith_hints. Declare ML Module "omega_plugin". - -Hint Resolve Z.le_refl Z.add_comm Z.add_assoc Z.mul_comm Z.mul_assoc Z.add_0_l - Z.add_0_r Z.mul_1_l Z.add_opp_diag_l Z.add_opp_diag_r Z.mul_add_distr_r - Z.mul_add_distr_l: zarith. - -Require Export Zhints. - -Hint Extern 10 (_ = _ :>nat) => abstract lia: zarith. -Hint Extern 10 (_ <= _) => abstract lia: zarith. -Hint Extern 10 (_ < _) => abstract lia: zarith. -Hint Extern 10 (_ >= _) => abstract lia: zarith. -Hint Extern 10 (_ > _) => abstract lia: zarith. - -Hint Extern 10 (_ <> _ :>nat) => abstract lia: zarith. -Hint Extern 10 (~ _ <= _) => abstract lia: zarith. -Hint Extern 10 (~ _ < _) => abstract lia: zarith. -Hint Extern 10 (~ _ >= _) => abstract lia: zarith. -Hint Extern 10 (~ _ > _) => abstract lia: zarith. - -Hint Extern 10 (_ = _ :>Z) => abstract lia: zarith. -Hint Extern 10 (_ <= _)%Z => abstract lia: zarith. -Hint Extern 10 (_ < _)%Z => abstract lia: zarith. -Hint Extern 10 (_ >= _)%Z => abstract lia: zarith. -Hint Extern 10 (_ > _)%Z => abstract lia: zarith. - -Hint Extern 10 (_ <> _ :>Z) => abstract lia: zarith. -Hint Extern 10 (~ (_ <= _)%Z) => abstract lia: zarith. -Hint Extern 10 (~ (_ < _)%Z) => abstract lia: zarith. -Hint Extern 10 (~ (_ >= _)%Z) => abstract lia: zarith. -Hint Extern 10 (~ (_ > _)%Z) => abstract lia: zarith. - -Hint Extern 10 False => abstract lia: zarith. diff --git a/theories/setoid_ring/Field_tac.v b/theories/setoid_ring/Field_tac.v index 89a5ca6740..15b2618e47 100644 --- a/theories/setoid_ring/Field_tac.v +++ b/theories/setoid_ring/Field_tac.v @@ -215,7 +215,7 @@ Ltac fold_field_cond req := Ltac simpl_PCond FLD := let req := get_FldEq FLD in let lemma := get_CondLemma FLD in - try (apply lemma; intros lock lock_def; vm_compute; rewrite lock_def; clear lock_def lock); + try (apply lemma; intros ?lock ?lock_def; vm_compute; rewrite lock_def; clear lock_def lock); protect_fv "field_cond"; fold_field_cond req; try exact I. @@ -223,7 +223,7 @@ Ltac simpl_PCond FLD := Ltac simpl_PCond_BEURK FLD := let req := get_FldEq FLD in let lemma := get_CondLemma FLD in - (apply lemma; intros lock lock_def; vm_compute; rewrite lock_def; clear lock_def lock); + (apply lemma; intros ?lock ?lock_def; vm_compute; rewrite lock_def; clear lock_def lock); protect_fv "field_cond"; fold_field_cond req. diff --git a/theories/setoid_ring/Rings_Z.v b/theories/setoid_ring/Rings_Z.v index f489b00145..372bba7926 100644 --- a/theories/setoid_ring/Rings_Z.v +++ b/theories/setoid_ring/Rings_Z.v @@ -11,7 +11,6 @@ Require Export Cring. Require Export Integral_domain. Require Export Ncring_initial. -Require Export Omega. Instance Zcri: (Cring (Rr:=Zr)). red. exact Z.mul_comm. Defined. diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in index b8e498898b..57ba036a62 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -54,7 +54,7 @@ OCAMLWARN := $(COQMF_WARN) # # Parameters are make variable assignments. # They can be passed to (each call to) make on the command line. -# They can also be put in @LOCAL_FILE@ once an for all. +# They can also be put in @LOCAL_FILE@ once and for all. # For retro-compatibility reasons they can be put in the _CoqProject, but this # practice is discouraged since _CoqProject better not contain make specific # code (be nice to user interfaces). @@ -66,12 +66,12 @@ VERBOSE ?= TIMED?= TIMECMD?= # Use command time on linux, gtime on Mac OS -TIMEFMT?="$* (real: %e, user: %U, sys: %S, mem: %M ko)" +TIMEFMT?="$@ (real: %e, user: %U, sys: %S, mem: %M ko)" ifneq (,$(TIMED)) -ifeq (0,$(shell command time -f $(TIMEFMT) true >/dev/null 2>/dev/null; echo $$?)) +ifeq (0,$(shell command time -f "" true >/dev/null 2>/dev/null; echo $$?)) STDTIME?=command time -f $(TIMEFMT) else -ifeq (0,$(shell gtime -f $(TIMEFMT) true >/dev/null 2>/dev/null; echo $$?)) +ifeq (0,$(shell gtime -f "" true >/dev/null 2>/dev/null; echo $$?)) STDTIME?=gtime -f $(TIMEFMT) else STDTIME?=command time @@ -132,6 +132,10 @@ TIMING_SORT_BY ?= auto TIMING_FUZZ ?= 0 # Option for changing whether to use real or user time for timing tables TIMING_REAL?= +# Option for including the memory column(s) +TIMING_INCLUDE_MEM?= +# Option for sorting by the memory column +TIMING_SORT_BY_MEM?= # Output file names for timed builds TIME_OF_BUILD_FILE ?= time-of-build.log TIME_OF_BUILD_BEFORE_FILE ?= time-of-build-before.log @@ -355,6 +359,18 @@ TIMING_USER_ARG := endif endif +ifeq (0,$(TIMING_INCLUDE_MEM)) +TIMING_INCLUDE_MEM_ARG := --no-include-mem +else +TIMING_INCLUDE_MEM_ARG := +endif + +ifeq (1,$(TIMING_SORT_BY_MEM)) +TIMING_SORT_BY_MEM_ARG := --sort-by-mem +else +TIMING_SORT_BY_MEM_ARG := +endif + make-pretty-timed-before:: TIME_OF_BUILD_FILE=$(TIME_OF_BUILD_BEFORE_FILE) make-pretty-timed-after:: TIME_OF_BUILD_FILE=$(TIME_OF_BUILD_AFTER_FILE) make-pretty-timed make-pretty-timed-before make-pretty-timed-after:: @@ -362,9 +378,9 @@ make-pretty-timed make-pretty-timed-before make-pretty-timed-after:: $(HIDE)($(MAKE) --no-print-directory -f "$(PARENT)" $(TGTS) TIMED=1 2>&1 && touch pretty-timed-success.ok) | tee -a $(TIME_OF_BUILD_FILE) $(HIDE)rm pretty-timed-success.ok # must not be -f; must fail if the touch failed print-pretty-timed:: - $(HIDE)$(COQMAKE_ONE_TIME_FILE) $(TIMING_REAL_ARG) $(TIME_OF_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) + $(HIDE)$(COQMAKE_ONE_TIME_FILE) $(TIMING_INCLUDE_MEM_ARG) $(TIMING_SORT_BY_MEM_ARG) $(TIMING_REAL_ARG) $(TIME_OF_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) print-pretty-timed-diff:: - $(HIDE)$(COQMAKE_BOTH_TIME_FILES) --sort-by=$(TIMING_SORT_BY) $(TIMING_REAL_ARG) $(TIME_OF_BUILD_AFTER_FILE) $(TIME_OF_BUILD_BEFORE_FILE) $(TIME_OF_PRETTY_BOTH_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) + $(HIDE)$(COQMAKE_BOTH_TIME_FILES) --sort-by=$(TIMING_SORT_BY) $(TIMING_INCLUDE_MEM_ARG) $(TIMING_SORT_BY_MEM_ARG) $(TIMING_REAL_ARG) $(TIME_OF_BUILD_AFTER_FILE) $(TIME_OF_BUILD_BEFORE_FILE) $(TIME_OF_PRETTY_BOTH_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) ifeq (,$(BEFORE)) print-pretty-single-time-diff:: @echo 'Error: Usage: $(MAKE) print-pretty-single-time-diff AFTER=path/to/file.v.after-timing BEFORE=path/to/file.v.before-timing' @@ -616,6 +632,7 @@ cleanall:: clean $(HIDE)rm -f $(VOFILES:.vo=.v.before-timing) $(HIDE)rm -f $(VOFILES:.vo=.v.after-timing) $(HIDE)rm -f $(VOFILES:.vo=.v.timing.diff) + $(HIDE)rm -f .lia.cache .nia.cache .PHONY: cleanall archclean:: diff --git a/tools/TimeFileMaker.py b/tools/TimeFileMaker.py index 210901f8a7..c4620f5b50 100644 --- a/tools/TimeFileMaker.py +++ b/tools/TimeFileMaker.py @@ -15,6 +15,9 @@ STRIP_REG = re.compile('^(coq/|contrib/|)(?:theories/|src/)?') STRIP_REP = r'\1' INFINITY = '\u221e' +TIME_KEY = 'time' +MEM_KEY = 'mem' + def nonnegative(arg): v = int(arg) if v < 0: raise argparse.ArgumentTypeError("%s is an invalid non-negative int value" % arg) @@ -37,6 +40,11 @@ def add_sort_by(parser): 'The "absolute" method sorts by the total time taken.\n' + 'The "diff" method sorts by the signed difference in time.')) +def add_sort_by_mem(parser): + return parser.add_argument( + '--sort-by-mem', action='store_true', dest='sort_by_mem', + help=('Sort the table entries by memory rather than time.')) + def add_fuzz(parser): return parser.add_argument( '--fuzz', dest='fuzz', metavar='N', type=nonnegative, default=0, @@ -55,9 +63,9 @@ def add_real(parser, single_timing=False): help=(r'''Use real times rather than user times. ''' + ('''By default, the input is expected to contain lines in the format: -FILE_NAME (...user: NUMBER_IN_SECONDS...) +FILE_NAME (...user: NUMBER_IN_SECONDS...mem: NUMBER ko...) If --real is passed, then the lines are instead expected in the format: -FILE_NAME (...real: NUMBER_IN_SECONDS...)''' if not single_timing else +FILE_NAME (...real: NUMBER_IN_SECONDS...mem: NUMBER ko...)''' if not single_timing else '''The input is expected to contain lines in the format: Chars START - END COMMAND NUMBER secs (NUMBERu...)'''))) @@ -67,12 +75,17 @@ def add_user(parser, single_timing=False): help=(r'''Use user times rather than real times. ''' + ('''By default, the input is expected to contain lines in the format: -FILE_NAME (...real: NUMBER_IN_SECONDS...) +FILE_NAME (...real: NUMBER_IN_SECONDS...mem: NUMBER ko...) If --user is passed, then the lines are instead expected in the format: -FILE_NAME (...user: NUMBER_IN_SECONDS...)''' if not single_timing else +FILE_NAME (...user: NUMBER_IN_SECONDS...mem: NUMBER ko...)''' if not single_timing else '''The input is expected to contain lines in the format: Chars START - END COMMAND NUMBER secs (NUMBERu...)'''))) +def add_include_mem(parser): + return parser.add_argument( + '--no-include-mem', dest='include_mem', default=True, action='store_false', + help=(r'''Don't include memory in the table.''')) + # N.B. We need to include default=None for nargs='*', c.f., https://bugs.python.org/issue28609#msg280180 def add_file_name_gen(parser, prefix='', descr='file containing the build log', stddir='in', defaults=None, **kwargs): extra = ('' if defaults is None else ' (defaults to %s if no argument is passed)' % defaults) @@ -113,14 +126,24 @@ def get_file_lines(file_name): def get_file(file_name): return ''.join(get_file_lines(file_name)) -def get_times(file_name, use_real=False): - ''' - Reads the contents of file_name, which should be the output of - 'make TIMED=1', and parses it to construct a dict mapping file - names to compile durations, as strings. Removes common prefixes - using STRIP_REG and STRIP_REP. - ''' - lines = get_file(file_name) +def merge_dicts(d1, d2): + if d2 is None: return d1 + if d1 is None: return d2 + assert(isinstance(d1, dict)) + assert(isinstance(d2, dict)) + ret = {} + for k in set(list(d1.keys()) + list(d2.keys())): + ret[k] = merge_dicts(d1.get(k), d2.get(k)) + return ret + +def get_mems_of_lines(lines): + reg = re.compile(r'^([^\s]+) \([^\)]*?mem: ([0-9]+) ko[^\)]*?\)\s*$', re.MULTILINE) + mems = reg.findall(lines) + if all(STRIP_REG.search(name.strip()) for name, mem in mems): + mems = tuple((STRIP_REG.sub(STRIP_REP, name.strip()), mem) for name, mem in mems) + return dict((name, {MEM_KEY:int(mem)}) for name, mem in mems) + +def get_times_of_lines(lines, use_real=False): reg_user = re.compile(r'^([^\s]+) \([^\)]*?user: ([0-9\.]+)[^\)]*?\)\s*$', re.MULTILINE) reg_real = re.compile(r'^([^\s]+) \([^\)]*?real: ([0-9\.]+)[^\)]*?\)\s*$', re.MULTILINE) reg = reg_real if use_real else reg_user @@ -130,7 +153,31 @@ def get_times(file_name, use_real=False): times = reg.findall(lines) if all(STRIP_REG.search(name.strip()) for name, time in times): times = tuple((STRIP_REG.sub(STRIP_REP, name.strip()), time) for name, time in times) - return dict((name, reformat_time_string(time)) for name, time in times) + return dict((name, {TIME_KEY:reformat_time_string(time)}) for name, time in times) + +def get_times_and_mems(file_name, use_real=False, include_mem=True): + # we only get the file once, in case it is a stream like stdin + lines = get_file(file_name) + return merge_dicts(get_times_of_lines(lines, use_real=use_real), + (get_mems_of_lines(lines) if include_mem else None)) + +def get_mems(file_name): + ''' + Reads the contents of file_name, which should be the output of + 'make TIMED=1', and parses it to construct a dict mapping file + names to peak memory usage, as integers. Removes common prefixes + using STRIP_REG and STRIP_REP. + ''' + return get_mems_of_lines(get_file(file_name)) + +def get_times(file_name, use_real=False): + ''' + Reads the contents of file_name, which should be the output of + 'make TIMED=1', and parses it to construct a dict mapping file + names to compile durations, as strings. Removes common prefixes + using STRIP_REG and STRIP_REP. + ''' + return get_times_of_lines(get_file(file_name)) def get_single_file_times(file_name, use_real=False): ''' @@ -144,7 +191,7 @@ def get_single_file_times(file_name, use_real=False): if len(times) == 0: return dict() longest = max(max((len(start), len(stop))) for start, stop, name, real, user, extra in times) FORMAT = 'Chars %%0%dd - %%0%dd %%s' % (longest, longest) - return dict((FORMAT % (int(start), int(stop), name), reformat_time_string(real if use_real else user)) for start, stop, name, real, user, extra in times) + return dict((FORMAT % (int(start), int(stop), name), {TIME_KEY:reformat_time_string(real if use_real else user)}) for start, stop, name, real, user, extra in times) def fuzz_merge(l1, l2, fuzz): '''Takes two iterables of ((start, end, code), times) and a fuzz @@ -215,20 +262,30 @@ def adjust_fuzz(left_dict, right_dict, fuzz): def fix_sign_for_sorting(num, descending=True): return -num if descending else num -def make_sorting_key(times_dict, descending=True): - def get_key(name): - minutes, seconds = times_dict[name].replace('s', '').split('m') - return (fix_sign_for_sorting(int(minutes), descending=descending), - fix_sign_for_sorting(float(seconds), descending=descending), - name) +def make_sorting_key(stats_dict, descending=True, sort_by_mem=False): + if sort_by_mem: + def get_key(name): + if MEM_KEY not in stats_dict[name].keys(): + print('WARNING: %s has no mem key: %s' % (name, repr(stats_dict[name])), file=sys.stderr) + mem = stats_dict[name].get(MEM_KEY, '0') + return (fix_sign_for_sorting(int(mem), descending=descending), + name) + else: + def get_key(name): + if TIME_KEY not in stats_dict[name].keys(): + print('WARNING: %s has no time key: %s' % (name, repr(stats_dict[name])), file=sys.stderr) + minutes, seconds = stats_dict[name].get(TIME_KEY, '0m00s').replace('s', '').split('m') + return (fix_sign_for_sorting(int(minutes), descending=descending), + fix_sign_for_sorting(float(seconds), descending=descending), + name) return get_key -def get_sorted_file_list_from_times_dict(times_dict, descending=True): +def get_sorted_file_list_from_stats_dict(stats_dict, descending=True, sort_by_mem=False): ''' Takes the output dict of get_times and returns the list of keys, sorted by duration. ''' - return sorted(times_dict.keys(), key=make_sorting_key(times_dict, descending=descending)) + return sorted(stats_dict.keys(), key=make_sorting_key(stats_dict, descending=descending, sort_by_mem=sort_by_mem)) def to_seconds(time): ''' @@ -265,85 +322,149 @@ def format_percentage(num, signed=True): frac_part = int(100 * (num * 100 - whole_part)) return sign + '%d.%02d%%' % (whole_part, frac_part) -def make_diff_table_string(left_times_dict, right_times_dict, +def make_diff_table_string(left_dict, right_dict, sort_by='auto', - descending=True, - left_tag="After", tag="File Name", right_tag="Before", with_percent=True, - change_tag="Change", percent_change_tag="% Change"): + descending=True, sort_by_mem=False, + left_tag='After', tag='File Name', right_tag='Before', with_percent=True, + left_mem_tag='Peak Mem', right_mem_tag='Peak Mem', + include_mem=False, + change_tag='Change', percent_change_tag='% Change', + change_mem_tag='Change (mem)', percent_change_mem_tag='% Change (mem)', + mem_fmt='%d ko'): # We first get the names of all of the compiled files: all files # that were compiled either before or after. all_names_dict = dict() - all_names_dict.update(right_times_dict) - all_names_dict.update(left_times_dict) # do the left (after) last, so that we give precedence to those ones + all_names_dict.update(right_dict) + all_names_dict.update(left_dict) # do the left (after) last, so that we give precedence to those ones if len(all_names_dict.keys()) == 0: return 'No timing data' - prediff_times = tuple((name, to_seconds(left_times_dict.get(name,'0m0.0s')), to_seconds(right_times_dict.get(name,'0m0.0s'))) + get_time = (lambda d, name: to_seconds(d.get(name, {}).get(TIME_KEY, '0m0.0s'))) + prediff_times = tuple((name, get_time(left_dict, name), get_time(right_dict, name)) for name in all_names_dict.keys()) diff_times_dict = dict((name, from_seconds(lseconds - rseconds, signed=True)) for name, lseconds, rseconds in prediff_times) percent_diff_times_dict = dict((name, ((format_percentage((lseconds - rseconds) / rseconds)) if rseconds != 0 else (INFINITY if lseconds > 0 else 'N/A'))) for name, lseconds, rseconds in prediff_times) + + get_mem = (lambda d, name: d.get(name, {}).get(MEM_KEY, 0)) + prediff_mems = tuple((name, get_mem(left_dict, name), get_mem(right_dict, name)) + for name in all_names_dict.keys()) + diff_mems_dict = dict((name, lmem - rmem) for name, lmem, rmem in prediff_mems) + percent_diff_mems_dict = dict((name, ((format_percentage((lmem - rmem) / float(rmem))) + if rmem != 0 else (INFINITY if lmem > 0 else 'N/A'))) + for name, lmem, rmem in prediff_mems) + # update to sort by approximate difference, first - get_key_abs = make_sorting_key(all_names_dict, descending=descending) - get_key_diff_float = (lambda name: fix_sign_for_sorting(to_seconds(diff_times_dict[name]), descending=descending)) - get_key_diff_absint = (lambda name: fix_sign_for_sorting(int(abs(to_seconds(diff_times_dict[name]))), descending=descending)) + if sort_by_mem: + get_prekey = (lambda name: diff_mems_dict[name]) + else: + get_prekey = (lambda name: to_seconds(diff_times_dict[name])) + get_key_abs = make_sorting_key(all_names_dict, descending=descending, sort_by_mem=sort_by_mem) + get_key_diff_float = (lambda name: fix_sign_for_sorting(get_prekey(name), descending=descending)) + get_key_diff_absint = (lambda name: fix_sign_for_sorting(int(abs(get_prekey(name))), descending=descending)) + get_key_with_name = (lambda get_key: lambda name: (get_key(name), name)) if sort_by == 'absolute': - get_key = get_key_abs + get_key = get_key_with_name(get_key_abs) elif sort_by == 'diff': - get_key = get_key_diff_float + get_key = get_key_with_name(get_key_diff_float) else: # sort_by == 'auto' - get_key = (lambda name: (get_key_diff_absint(name), get_key_abs(name))) + get_key = get_key_with_name((lambda name: (get_key_diff_absint(name), get_key_abs(name)))) names = sorted(all_names_dict.keys(), key=get_key) - #names = get_sorted_file_list_from_times_dict(all_names_dict, descending=descending) + #names = get_sorted_file_list_from_stats_dict(all_names_dict, descending=descending) # set the widths of each of the columns by the longest thing to go in that column - left_sum = sum_times(left_times_dict.values()) - right_sum = sum_times(right_times_dict.values()) - left_sum_float = sum(sorted(map(to_seconds, left_times_dict.values()))) - right_sum_float = sum(sorted(map(to_seconds, right_times_dict.values()))) + left_sum = sum_times(v[TIME_KEY] for v in left_dict.values() if TIME_KEY in v.keys()) + right_sum = sum_times(v[TIME_KEY] for v in right_dict.values() if TIME_KEY in v.keys()) + left_sum_float = sum(sorted(to_seconds(v[TIME_KEY]) for v in left_dict.values() if TIME_KEY in v.keys())) + right_sum_float = sum(sorted(to_seconds(v[TIME_KEY]) for v in right_dict.values() if TIME_KEY in v.keys())) diff_sum = from_seconds(left_sum_float - right_sum_float, signed=True) percent_diff_sum = (format_percentage((left_sum_float - right_sum_float) / right_sum_float) if right_sum_float > 0 else 'N/A') - left_width = max(max(map(len, ['N/A'] + list(left_times_dict.values()))), len(left_sum)) - right_width = max(max(map(len, ['N/A'] + list(right_times_dict.values()))), len(right_sum)) + + left_width = max(max(map(len, ['N/A', left_tag] + [v[TIME_KEY] for v in left_dict.values() if TIME_KEY in v.keys()])), len(left_sum)) + right_width = max(max(map(len, ['N/A', right_tag] + [v[TIME_KEY] for v in right_dict.values() if TIME_KEY in v.keys()])), len(right_sum)) far_right_width = max(max(map(len, ['N/A', change_tag] + list(diff_times_dict.values()))), len(diff_sum)) far_far_right_width = max(max(map(len, ['N/A', percent_change_tag] + list(percent_diff_times_dict.values()))), len(percent_diff_sum)) - middle_width = max(map(len, names + [tag, "Total"])) - format_string = ("%%(left)-%ds | %%(middle)-%ds | %%(right)-%ds || %%(far_right)-%ds" - % (left_width, middle_width, right_width, far_right_width)) + total_string = 'Total' if not include_mem else 'Total Time / Peak Mem' + middle_width = max(map(len, names + [tag, total_string])) + + left_peak = max(v.get(MEM_KEY, 0) for v in left_dict.values()) + right_peak = max(v.get(MEM_KEY, 0) for v in right_dict.values()) + diff_peak = left_peak - right_peak + percent_diff_peak = (format_percentage((left_peak - right_peak) / float(right_peak)) + if right_peak != 0 else (INFINITY if left_peak > 0 else 'N/A')) + + left_mem_width = max(max(map(len, ['N/A', left_mem_tag] + [mem_fmt % v.get(MEM_KEY, 0) for v in left_dict.values()])), len(mem_fmt % left_peak)) + right_mem_width = max(max(map(len, ['N/A', right_mem_tag] + [mem_fmt % v.get(MEM_KEY, 0) for v in right_dict.values()])), len(mem_fmt % right_peak)) + far_right_mem_width = max(max(map(len, ['N/A', change_mem_tag] + [mem_fmt % v for v in diff_mems_dict.values()])), len(mem_fmt % diff_peak)) + far_far_right_mem_width = max(max(map(len, ['N/A', percent_change_mem_tag] + list(percent_diff_mems_dict.values()))), len(percent_diff_peak)) + + if include_mem: + format_string = ("%%(left)%ds | %%(left_mem)%ds | %%(middle)-%ds | %%(right)%ds | %%(right_mem)%ds || %%(far_right)%ds || %%(far_right_mem)%ds" + % (left_width, left_mem_width, middle_width, right_width, right_mem_width, far_right_width, far_right_mem_width)) + else: + format_string = ("%%(left)%ds | %%(middle)-%ds | %%(right)%ds || %%(far_right)%ds" + % (left_width, middle_width, right_width, far_right_width)) + if with_percent: - format_string += " | %%(far_far_right)-%ds" % far_far_right_width - header = format_string % {'left': left_tag, 'middle': tag, 'right': right_tag, 'far_right': change_tag, 'far_far_right': percent_change_tag} - total = format_string % {'left': left_sum, 'middle': "Total", 'right': right_sum, 'far_right': diff_sum, 'far_far_right': percent_diff_sum} + format_string += " | %%(far_far_right)%ds" % far_far_right_width + if include_mem: + format_string += " | %%(far_far_right_mem)%ds" % far_far_right_mem_width + + header = format_string % {'left': left_tag, 'left_mem': left_mem_tag, + 'middle': tag, + 'right': right_tag, 'right_mem': right_mem_tag, + 'far_right': change_tag, 'far_right_mem': change_mem_tag, + 'far_far_right': percent_change_tag, 'far_far_right_mem': percent_change_mem_tag} + total = format_string % {'left': left_sum, 'left_mem': mem_fmt % left_peak, + 'middle': total_string, + 'right': right_sum, 'right_mem': mem_fmt % right_peak, + 'far_right': diff_sum, 'far_right_mem': mem_fmt % diff_peak, + 'far_far_right': percent_diff_sum, 'far_far_right_mem': percent_diff_peak} # separator to go between headers and body sep = '-' * len(header) # the representation of the default value (0), to get replaced by N/A - left_rep, right_rep, far_right_rep, far_far_right_rep = ("%%-%ds | " % left_width) % 0, (" | %%-%ds || " % right_width) % 0, ("|| %%-%ds" % far_right_width) % 0, ("| %%-%ds" % far_far_right_width) % 0 + left_rep, right_rep, far_right_rep, far_far_right_rep = ("%%%ds | " % left_width) % 'N/A', (" | %%%ds |" % right_width) % 'N/A', ("|| %%%ds" % far_right_width) % 'N/A', ("| %%%ds" % far_far_right_width) % 'N/A' + left_mem_rep, right_mem_rep, far_right_mem_rep, far_far_right_mem_rep = ("%%%ds | " % left_mem_width) % 'N/A', (" | %%%ds |" % right_mem_width) % 'N/A', ("|| %%%ds" % far_right_mem_width) % 'N/A', ("| %%%ds" % far_far_right_mem_width) % 'N/A' + get_formatted_mem = (lambda k, v: (mem_fmt % v[k]) if k in v.keys() else 'N/A') return '\n'.join([header, sep, total, sep] + - [format_string % {'left': left_times_dict.get(name, 0), + [format_string % {'left': left_dict.get(name, {}).get(TIME_KEY, 'N/A'), + 'left_mem': get_formatted_mem(MEM_KEY, left_dict.get(name, {})), 'middle': name, - 'right': right_times_dict.get(name, 0), - 'far_right': diff_times_dict.get(name, 0), - 'far_far_right': percent_diff_times_dict.get(name, 0)} - for name in names]).replace(left_rep, 'N/A'.center(len(left_rep) - 3) + ' | ').replace(right_rep, ' | ' + 'N/A'.center(len(right_rep) - 7) + ' || ').replace(far_right_rep, '|| ' + 'N/A'.center(len(far_right_rep) - 3)).replace(far_far_right_rep, '| ' + 'N/A'.center(len(far_far_right_rep) - 2)) - -def make_table_string(times_dict, - descending=True, - tag="Time"): - if len(times_dict.keys()) == 0: return 'No timing data' + 'right': right_dict.get(name, {}).get(TIME_KEY, 'N/A'), + 'right_mem': get_formatted_mem(MEM_KEY, right_dict.get(name, {})), + 'far_right': diff_times_dict.get(name, 'N/A'), + 'far_right_mem': get_formatted_mem(name, diff_mems_dict), + 'far_far_right': percent_diff_times_dict.get(name, 'N/A'), + 'far_far_right_mem': percent_diff_mems_dict.get(name, 'N/A')} + for name in names]).replace(left_rep, 'N/A'.center(len(left_rep) - 3) + ' | ').replace(right_rep, ' | ' + 'N/A'.center(len(right_rep) - 5) + ' |').replace(far_right_rep, '|| ' + 'N/A'.center(len(far_right_rep) - 3)).replace(far_far_right_rep, '| ' + 'N/A'.center(len(far_far_right_rep) - 2)).replace(left_mem_rep, 'N/A'.center(len(left_mem_rep) - 3) + ' | ').replace(right_mem_rep, ' | ' + 'N/A'.center(len(right_mem_rep) - 5) + ' |').replace(far_right_mem_rep, '|| ' + 'N/A'.center(len(far_right_mem_rep) - 3)).replace(far_far_right_mem_rep, '| ' + 'N/A'.center(len(far_far_right_mem_rep) - 2)) + +def make_table_string(stats_dict, + descending=True, sort_by_mem=False, + tag="Time", mem_tag="Peak Mem", mem_fmt='%d ko', + include_mem=False): + if len(stats_dict.keys()) == 0: return 'No timing data' # We first get the names of all of the compiled files, sorted by # duration - names = get_sorted_file_list_from_times_dict(times_dict, descending=descending) + names = get_sorted_file_list_from_stats_dict(stats_dict, descending=descending, sort_by_mem=sort_by_mem) # compute the widths of the columns - times_width = max(max(map(len, times_dict.values())), len(sum_times(times_dict.values()))) - names_width = max(map(len, names + ["File Name", "Total"])) - format_string = "%%-%ds | %%-%ds" % (times_width, names_width) - header = format_string % (tag, "File Name") - total = format_string % (sum_times(times_dict.values()), - "Total") + times_width = max(len('N/A'), len(tag), max(len(v[TIME_KEY]) for v in stats_dict.values() if TIME_KEY in v.keys()), len(sum_times(v[TIME_KEY] for v in stats_dict.values() if TIME_KEY in v.keys()))) + mems_width = max(len('N/A'), len(mem_tag), max(len(mem_fmt % v.get(MEM_KEY, 0)) for v in stats_dict.values()), len(mem_fmt % (max(v.get(MEM_KEY, 0) for v in stats_dict.values())))) + total_string = 'Total' if not include_mem else 'Total Time / Peak Mem' + names_width = max(map(len, names + ["File Name", total_string])) + if include_mem: + format_string = "%%(time)%ds | %%(mem)%ds | %%(name)-%ds" % (times_width, mems_width, names_width) + else: + format_string = "%%(time)%ds | %%(name)-%ds" % (times_width, names_width) + get_formatted_mem = (lambda k, v: (mem_fmt % v[k]) if k in v.keys() else 'N/A') + header = format_string % {'time': tag, 'mem': mem_tag, 'name': 'File Name'} + total = format_string % {'time': sum_times(v[TIME_KEY] for v in stats_dict.values() if TIME_KEY in v.keys()), + 'mem': ((mem_fmt % max(v[MEM_KEY] for v in stats_dict.values() if MEM_KEY in v.keys())) if any(MEM_KEY in v.keys() for v in stats_dict.values()) else 'N/A'), + 'name': total_string} sep = '-' * len(header) return '\n'.join([header, sep, total, sep] + - [format_string % (times_dict[name], - name) + [format_string % {'time': stats_dict[name].get(TIME_KEY, 'N/A'), + 'mem': get_formatted_mem(MEM_KEY, stats_dict[name]), + 'name': name} for name in names]) def print_or_write_table(table, files): diff --git a/tools/coq_dune.ml b/tools/coq_dune.ml deleted file mode 100644 index 472e6b4948..0000000000 --- a/tools/coq_dune.ml +++ /dev/null @@ -1,301 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \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) *) -(************************************************************************) - -(* LICENSE NOTE: This file is dually MIT/LGPL 2.1+ licensed. MIT license: - * - * Permission is hereby granted, free of charge, to any person obtaining a copy - * of this software and associated documentation files (the "Software"), to deal - * in the Software without restriction, including without limitation the rights - * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell - * copies of the Software, and to permit persons to whom the Software is - * furnished to do so, subject to the following conditions: - * - * The above copyright notice and this permission notice shall be included in all - * copies or substantial portions of the Software. - * - * 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 OR COPYRIGHT HOLDERS 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. - *) - -(* coq_dune: generate dune build rules for .vo files *) -(* *) -(* At some point this file will become a Dune plugin, so it is very *) -(* important that this file can be bootstrapped with: *) -(* *) -(* ocamlfind ocamlopt -linkpkg -package str coq_dune.ml -o coq_dune *) - -open Format - -(* Keeping this file self-contained as it is a "bootstrap" utility *) -(* Is OCaml missing these basic functions in the stdlib? *) -module Aux = struct - - let option_iter f o = match o with - | Some x -> f x - | None -> () - - let option_cata d f o = match o with - | Some x -> f x - | None -> d - - let list_compare f = let rec lc x y = match x, y with - | [], [] -> 0 - | [], _ -> -1 - | _, [] -> 1 - | x::xs, y::ys -> let r = f x y in if r = 0 then lc xs ys else r - in lc - - let rec pp_list pp sep fmt l = match l with - | [] -> () - | [l] -> fprintf fmt "%a" pp l - | x::xs -> fprintf fmt "%a%a%a" pp x sep () (pp_list pp sep) xs - - let rec pmap f l = match l with - | [] -> [] - | x :: xs -> - begin match f x with - | None -> pmap f xs - | Some r -> r :: pmap f xs - end - - let sep fmt () = fprintf fmt "@;" - - (* Creation of paths, aware of the platform separator. *) - let bpath l = String.concat Filename.dir_sep l - - module DirOrd = struct - type t = string list - let compare = list_compare String.compare - end - - module DirMap = Map.Make(DirOrd) - - (* Functions available in newer OCaml versions *) - (* Taken from the OCaml std library (c) INRIA / LGPL-2.1 *) - module Legacy = struct - - - (* Fix once we move to OCaml >= 4.06.0 *) - let list_init len f = - let rec init_aux i n f = - if i >= n then [] - else let r = f i in r :: init_aux (i+1) n f - in init_aux 0 len f - - (* Slower version of DirMap.update, waiting for OCaml 4.06.0 *) - let dirmap_update key f map = - match begin - try f (Some (DirMap.find key map)) - with Not_found -> f None - end with - | None -> DirMap.remove key map - | Some x -> DirMap.add key x map - - end - - let add_map_list key elem map = - (* Move to Dirmap.update once we require OCaml >= 4.06.0 *) - Legacy.dirmap_update key (fun l -> Some (option_cata [elem] (fun ll -> elem :: ll) l)) map - - let replace_ext ~file ~newext = - Filename.(remove_extension file) ^ newext - -end - -open Aux - -(* Once this is a Dune plugin the flags will be taken from the env *) -module Options = struct - - type flag = { - enabled : bool; - cmd : string; - } - - let all_opts = - [ { enabled = false; cmd = "-debug"; } - ; { enabled = false; cmd = "-native_compiler"; } - ; { enabled = true; cmd = "-w +default"; } - ] - - let build_coq_flags () = - let popt o = if o.enabled then Some o.cmd else None in - String.concat " " @@ pmap popt all_opts -end - -type vodep = { - target: string; - deps : string list; -} - -type ldep = | VO of vodep | MLG of string -type ddir = ldep list DirMap.t - -(* Filter `.vio` etc... *) -let filter_no_vo = - List.filter (fun f -> Filename.check_suffix f ".vo") - -(* We could have coqdep to output dune files directly *) - -let gen_sub n = - (* Move to List.init once we can depend on OCaml >= 4.06.0 *) - bpath @@ Legacy.list_init n (fun _ -> "..") - -let pp_rule fmt targets deps action = - (* Special printing of the first rule *) - let ppl = pp_list pp_print_string sep in - let pp_deps fmt l = match l with - | [] -> - () - | x :: xs -> - fprintf fmt "(:pp-file %s)%a" x sep (); - pp_list pp_print_string sep fmt xs - in - fprintf fmt - "@[(rule@\n @[(targets @[%a@])@\n(deps @[%a@])@\n(action @[%a@])@])@]@\n" - ppl targets pp_deps deps pp_print_string action - -let gen_coqc_targets vo = - [ vo.target - ; replace_ext ~file:vo.target ~newext:".glob" - ; replace_ext ~file:vo.target ~newext:".vos" - ; "." ^ replace_ext ~file:vo.target ~newext:".aux"] - -(* Generate the dune rule: *) -let pp_vo_dep dir fmt vo = - let depth = List.length dir in - let sdir = gen_sub depth in - (* All files except those in Init implicitly depend on the Prelude, we account for it here. *) - let eflag, edep = if List.tl dir = ["Init"] then "-noinit -R theories Coq", [] else "", [bpath ["theories";"Init";"Prelude.vo"]] in - (* Coq flags *) - let cflag = Options.build_coq_flags () in - (* Correct path from global to local "theories/Init/Decimal.vo" -> "../../theories/Init/Decimal.vo" *) - let deps = List.map (fun s -> bpath [sdir;s]) (edep @ vo.deps) in - (* The source file is also corrected as we will call coqtop from the top dir *) - let source = bpath (dir @ [replace_ext ~file:vo.target ~newext:".v"]) in - (* 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 coqc -q %s %s %s %s))" libflag eflag cflag source in - let all_targets = gen_coqc_targets vo in - pp_rule fmt all_targets deps action - -let pp_mlg_dep _dir fmt ml = - fprintf fmt "@[(coq.pp (modules %s))@]@\n" (Filename.remove_extension ml) - -let pp_dep dir fmt oo = match oo with - | VO vo -> pp_vo_dep dir fmt vo - | MLG f -> pp_mlg_dep dir fmt f - -let out_install fmt dir ff = - let itarget = String.concat "/" dir in - let ff = List.concat @@ pmap (function | VO vo -> Some (gen_coqc_targets vo) | _ -> None) ff in - let pp_ispec fmt tg = fprintf fmt "(%s as coq/%s)" tg (bpath [itarget;tg]) in - fprintf fmt "(install@\n @[(section lib_root)@\n(package coq)@\n(files @[%a@])@])@\n" - (pp_list pp_ispec sep) ff - -(* For each directory, we must record two things, the build rules and - the install specification. *) -let record_dune d ff = - let sd = bpath d in - if Sys.file_exists sd && Sys.is_directory sd then - let out = open_out (bpath [sd;"dune"]) in - let fmt = formatter_of_out_channel out in - if Sys.file_exists (bpath [sd; "plugin_base.dune"]) then - fprintf fmt "(include plugin_base.dune)@\n"; - out_install fmt d ff; - List.iter (pp_dep d fmt) ff; - fprintf fmt "%!"; - close_out out - else - eprintf "error in coq_dune, a directory disappeared: %s@\n%!" sd - -(* File Scanning *) -let scan_mlg ~root m d = - let dir = [root; d] in - let m = DirMap.add dir [] m in - let mlg = Sys.(List.filter (fun f -> Filename.(check_suffix f ".mlg")) - Array.(to_list @@ readdir (bpath dir))) in - List.fold_left (fun m f -> add_map_list [root; d] (MLG f) m) m mlg - -let scan_dir ~root m = - let is_plugin_directory dir = Sys.(is_directory dir && file_exists (bpath [dir;"plugin_base.dune"])) in - let dirs = Sys.(List.filter (fun f -> is_plugin_directory @@ bpath [root;f]) Array.(to_list @@ readdir root)) in - List.fold_left (scan_mlg ~root) m dirs - -let scan_plugins m = scan_dir ~root:"plugins" m -let scan_usercontrib m = scan_dir ~root:"user-contrib" m - -(* This will be removed when we drop support for Make *) -let fix_cmo_cma file = - if String.equal Filename.(extension file) ".cmo" - then replace_ext ~file ~newext:".cma" - else file - -(* Process .vfiles.d and generate a skeleton for the dune file *) -let parse_coqdep_line l = - match Str.(split (regexp ":") l) with - | [targets;deps] -> - let targets = Str.(split (regexp "[ \t]+") targets) in - let deps = Str.(split (regexp "[ \t]+") deps) in - let targets = filter_no_vo targets in - begin match targets with - | [target] -> - let dir, target = Filename.(dirname target, basename target) in - (* coqdep outputs with the '/' directory separator regardless of - the platform. Anyways, I hope we can link to coqdep instead - of having to parse its output soon, that should solve this - kind of issues *) - let deps = List.map fix_cmo_cma deps in - Some (String.split_on_char '/' dir, VO { target; deps; }) - (* Otherwise a vio file, we ignore *) - | _ -> None - end - (* Strange rule, we ignore *) - | _ -> None - -let rec read_vfiles ic map = - try - let rule = parse_coqdep_line (input_line ic) in - (* Add vo_entry to its corresponding map entry *) - let map = option_cata map (fun (dir, vo) -> add_map_list dir vo map) rule in - read_vfiles ic map - with End_of_file -> map - -let out_map map = - DirMap.iter record_dune map - -let exec_ifile f = - match Array.length Sys.argv with - | 1 -> f stdin - | 2 -> - let in_file = Sys.argv.(1) in - begin try - let ic = open_in in_file in - (try f ic - with exn -> - eprintf "Error: exec_ifile @[%s@]@\n%!" (Printexc.to_string exn); - close_in ic) - with _ -> - eprintf "Error: cannot open input file %s@\n%!" in_file - end - | _ -> eprintf "Error: wrong number of arguments@\n%!"; exit 1 - -let _ = - exec_ifile (fun ic -> - let map = scan_plugins DirMap.empty in - let map = scan_usercontrib map in - let map = read_vfiles ic map in - out_map map) diff --git a/tools/coqdoc/coqdoc.css b/tools/coqdoc/coqdoc.css index dbc930f5ec..48096e555a 100644 --- a/tools/coqdoc/coqdoc.css +++ b/tools/coqdoc/coqdoc.css @@ -230,6 +230,10 @@ tr.infrulemiddle hr { color: rgb(40%,0%,40%); } +.id[title="binder"] { + color: rgb(40%,0%,40%); +} + .id[type="definition"] { color: rgb(0%,40%,0%); } @@ -327,3 +331,8 @@ ul.doclist { margin-top: 0em; margin-bottom: 0em; } + +.code :target { + border: 2px solid #D4D4D4; + background-color: #e5eecc; +} diff --git a/tools/coqdoc/coqdoc.sty b/tools/coqdoc/coqdoc.sty index f49f9f0066..aa9c414761 100644 --- a/tools/coqdoc/coqdoc.sty +++ b/tools/coqdoc/coqdoc.sty @@ -72,6 +72,7 @@ \newcommand{\coqdocinductive}[1]{\coqdocind{#1}} \newcommand{\coqdocdefinition}[1]{\coqdoccst{#1}} \newcommand{\coqdocvariable}[1]{\coqdocvar{#1}} +\newcommand{\coqdocbinder}[1]{\coqdocvar{#1}} \newcommand{\coqdocconstructor}[1]{\coqdocconstr{#1}} \newcommand{\coqdoclemma}[1]{\coqdoccst{#1}} \newcommand{\coqdocclass}[1]{\coqdocind{#1}} diff --git a/tools/coqdoc/cpretty.mll b/tools/coqdoc/cpretty.mll index 210ac754a1..86d213453b 100644 --- a/tools/coqdoc/cpretty.mll +++ b/tools/coqdoc/cpretty.mll @@ -32,6 +32,19 @@ in count 0 0 + let count_newlines s = + let len = String.length s in + let n = ref 0 in + String.iteri (fun i c -> + match c with (* skip "\r\n" *) + | '\r' when i + 1 = len || s.[i+1] = '\n' -> incr n + | '\n' -> incr n + | _ -> ()) s; + !n + + (* Whether a string starts with a newline (used on strings that might match the [nl] regexp) *) + let is_nl s = String.length s = 0 || let c = s.[0] in c = '\n' || c = '\r' + let remove_newline s = let n = String.length s in let rec count i = if i == n || s.[i] <> '\n' then i else count (i + 1) in @@ -65,8 +78,12 @@ let eol = s.[String.length s - 1] = '\n' in (eol, if eol then String.sub s 1 (String.length s - 1) else s) + let is_none x = + match x with + | None -> true + | Some _ -> false - let formatted = ref false + let formatted : position option ref = ref None let brackets = ref 0 let comment_level = ref 0 let in_proof = ref None @@ -116,10 +133,15 @@ let begin_show () = save_state (); Cdglobals.gallina := false; Cdglobals.light := false let end_show () = restore_state () + let begin_details s = + save_state (); Cdglobals.gallina := false; Cdglobals.light := false; + Output.start_details s + let end_details () = Output.stop_details (); restore_state () + (* Reset the globals *) let reset () = - formatted := false; + formatted := None; brackets := 0; comment_level := 0 @@ -247,13 +269,28 @@ let parse_comments () = !Cdglobals.parse_comments && not (only_gallina ()) + (* Advance lexbuf by n lines. Equivalent to calling [Lexing.new_line lexbuf] n times *) + let new_lines n lexbuf = + let lcp = lexbuf.lex_curr_p in + if lcp != dummy_pos then + lexbuf.lex_curr_p <- + { lcp with + pos_lnum = lcp.pos_lnum + n; + pos_bol = lcp.pos_cnum } + + let print_position chan p = + Printf.fprintf chan "%s:%d:%d" p.pos_fname p.pos_lnum (p.pos_cnum - p.pos_bol) + + exception MismatchPreformatted of position + + (* let debug lexbuf msg = Printf.printf "%a %s\n" print_position lexbuf.lex_start_p msg *) } (*s Regular expressions *) let space = [' ' '\t'] -let space_nl = [' ' '\t' '\n' '\r'] -let nl = "\r\n" | '\n' +let nl = "\r\n" | '\n' | '\r' +let space_nl = space | nl let firstchar = ['A'-'Z' 'a'-'z' '_'] | @@ -430,10 +467,12 @@ let section = "*" | "**" | "***" | "****" let item_space = " " -let begin_hide = "(*" space* "begin" space+ "hide" space* "*)" space* nl -let end_hide = "(*" space* "end" space+ "hide" space* "*)" space* nl -let begin_show = "(*" space* "begin" space+ "show" space* "*)" space* nl -let end_show = "(*" space* "end" space+ "show" space* "*)" space* nl +let begin_hide = "(*" space* "begin" space+ "hide" space* "*)" space* +let end_hide = "(*" space* "end" space+ "hide" space* "*)" space* +let begin_show = "(*" space* "begin" space+ "show" space* "*)" space* +let end_show = "(*" space* "end" space+ "show" space* "*)" space* +let begin_details = "(*" space* "begin" space+ "details" space* +let end_details = "(*" space* "end" space+ "details" space* "*)" space* (* let begin_verb = "(*" space* "begin" space+ "verb" space* "*)" let end_verb = "(*" space* "end" space+ "verb" space* "*)" @@ -442,24 +481,36 @@ let end_verb = "(*" space* "end" space+ "verb" space* "*)" (*s Scanning Coq, at beginning of line *) rule coq_bol = parse - | space* nl+ - { if not (!in_proof <> None && (!Cdglobals.gallina || !Cdglobals.light)) + | space* (nl+ as s) + { new_lines (String.length s) lexbuf; + if not (!in_proof <> None && (!Cdglobals.gallina || !Cdglobals.light)) then Output.empty_line_of_code (); coq_bol lexbuf } - | space* "(**" space_nl - { Output.end_coq (); Output.start_doc (); + | space* "(**" (space_nl as s) + { if is_nl s then Lexing.new_line lexbuf; + Output.end_coq (); Output.start_doc (); let eol = doc_bol lexbuf in Output.end_doc (); Output.start_coq (); if eol then coq_bol lexbuf else coq lexbuf } - | space* "Comments" space_nl - { Output.end_coq (); Output.start_doc (); comments lexbuf; Output.end_doc (); - Output.start_coq (); coq lexbuf } - | space* begin_hide - { skip_hide lexbuf; coq_bol lexbuf } - | space* begin_show - { begin_show (); coq_bol lexbuf } - | space* end_show - { end_show (); coq_bol lexbuf } + | space* "Comments" (space_nl as s) + { if is_nl s then Lexing.new_line lexbuf; + Output.end_coq (); Output.start_doc (); + comments lexbuf; + Output.end_doc (); Output.start_coq (); + coq lexbuf } + | space* begin_hide nl + { Lexing.new_line lexbuf; skip_hide lexbuf; coq_bol lexbuf } + | space* begin_show nl + { Lexing.new_line lexbuf; begin_show (); coq_bol lexbuf } + | space* end_show nl + { Lexing.new_line lexbuf; end_show (); coq_bol lexbuf } + | space* begin_details nl + { Lexing.new_line lexbuf; + let s = details_body lexbuf in + Output.end_coq (); begin_details s; Output.start_coq (); coq_bol lexbuf } + | space* end_details nl + { Lexing.new_line lexbuf; + Output.end_coq (); end_details (); Output.start_coq (); coq_bol lexbuf } | space* (("Local"|"Global") space+)? gallina_kw_to_hide { let s = lexeme lexbuf in if !Cdglobals.light && section_or_end s then @@ -565,9 +616,10 @@ rule coq_bol = parse and coq = parse | nl - { if not (only_gallina ()) then Output.line_break(); coq_bol lexbuf } - | "(**" space_nl - { Output.end_coq (); Output.start_doc (); + { Lexing.new_line lexbuf; if not (only_gallina ()) then Output.line_break(); coq_bol lexbuf } + | "(**" (space_nl as s) + { if is_nl s then Lexing.new_line lexbuf; + Output.end_coq (); Output.start_doc (); let eol = doc_bol lexbuf in Output.end_doc (); Output.start_coq (); if eol then coq_bol lexbuf else coq lexbuf } @@ -579,8 +631,9 @@ and coq = parse comment lexbuf end else skipped_comment lexbuf in if eol then coq_bol lexbuf else coq lexbuf } - | nl+ space* "]]" - { if not !formatted then + | (nl+ as s) space* "]]" + { new_lines (count_newlines s) lexbuf; + if is_none !formatted then begin (* Isn't this an anomaly *) let s = lexeme lexbuf in @@ -665,8 +718,9 @@ and coq = parse (*s Scanning documentation, at beginning of line *) and doc_bol = parse - | space* section space+ ([^'\n' '*'] | '*'+ [^'\n' ')' '*'])* ('*'+ '\n')? - { let eol, lex = strip_eol (lexeme lexbuf) in + | space* section space+ ([^'\n' '\r' '*'] | '*'+ [^'\n' '\r' ')' '*'])* ('*'+ (nl as s))? + { if not (is_none s) then Lexing.new_line lexbuf; + let eol, lex = strip_eol (lexeme lexbuf) in let lev, s = sec_title lex in if (!Cdglobals.lib_subtitles) && (subtitle (Output.get_module false) s) then @@ -674,24 +728,20 @@ and doc_bol = parse else Output.section lev (fun () -> ignore (doc None (from_string s))); if eol then doc_bol lexbuf else doc None lexbuf } - | space_nl* '-'+ - { let buf' = lexeme lexbuf in - let bufs = Str.split_delim (Str.regexp "['\n']") buf' in - let lines = (List.length bufs) - 1 in - let line = - match bufs with - | [] -> eprintf "Internal error bad_split1 - please report\n"; - exit 1 - | _ -> List.nth bufs lines - in - match check_start_list line with - | Neither -> backtrack_past_newline lexbuf; doc None lexbuf - | List n -> if lines > 0 then Output.paragraph (); - Output.item 1; doc (Some [n]) lexbuf - | Rule -> Output.rule (); doc None lexbuf + | (space_nl* as s) ('-'+ as line) + { let nl_count = count_newlines s in + match check_start_list line with + | Neither -> backtrack_past_newline lexbuf; Lexing.new_line lexbuf; doc None lexbuf + | List n -> + new_lines nl_count lexbuf; + if nl_count > 0 then Output.paragraph (); + Output.item 1; doc (Some [n]) lexbuf + | Rule -> + new_lines nl_count lexbuf; + Output.rule (); doc None lexbuf } - | space* nl+ - { Output.paragraph (); doc_bol lexbuf } + | (space_nl* nl) as s + { new_lines (count_newlines s) lexbuf; Output.paragraph (); doc_bol lexbuf } | "<<" space* { Output.start_verbatim false; verbatim 0 false lexbuf; doc_bol lexbuf } | eof @@ -699,8 +749,7 @@ and doc_bol = parse | '_' { if !Cdglobals.plain_comments then Output.char '_' else start_emph (); doc None lexbuf } - | _ - { backtrack lexbuf; doc None lexbuf } + | "" { doc None lexbuf } (*s Scanning lists - using whitespace *) and doc_list_bol indents = parse @@ -721,11 +770,11 @@ and doc_list_bol indents = parse verbatim 0 false lexbuf; doc_list_bol indents lexbuf } | "[[" nl - { formatted := true; + { formatted := Some lexbuf.lex_start_p; Output.start_inline_coq_block (); ignore(body_bol lexbuf); Output.end_inline_coq_block (); - formatted := false; + formatted := None; doc_list_bol indents lexbuf } | "[[[" nl { inf_rules (Some indents) lexbuf } @@ -788,10 +837,10 @@ and doc indents = parse | "[[" nl { if !Cdglobals.plain_comments then (Output.char '['; Output.char '['; doc indents lexbuf) - else (formatted := true; + else (formatted := Some lexbuf.lex_start_p; Output.start_inline_coq_block (); let eol = body_bol lexbuf in - Output.end_inline_coq_block (); formatted := false; + Output.end_inline_coq_block (); formatted := None; if eol then match indents with | Some ls -> doc_list_bol ls lexbuf @@ -816,16 +865,15 @@ and doc indents = parse if !Cdglobals.parse_comments then comment lexbuf else skipped_comment lexbuf in if eol then bol_parse lexbuf else doc indents lexbuf } - | '*'* "*)" space_nl* "(**" - {(match indents with + | '*'* "*)" (space_nl* as s) "(**" + { let nl_count = count_newlines s in + new_lines nl_count lexbuf; + (match indents with | Some _ -> Output.stop_item () | None -> ()); (* this says - if there is a blank line between the two comments, insert one in the output too *) - let lines = List.length (Str.split_delim (Str.regexp "['\n']") - (lexeme lexbuf)) - in - if lines > 2 then Output.paragraph (); + if nl_count > 1 then Output.paragraph (); doc_bol lexbuf } | '*'* "*)" space* nl @@ -1017,10 +1065,10 @@ and comment = parse comment lexbuf } | "[[" nl { if !Cdglobals.plain_comments then (Output.char '['; Output.char '[') - else (formatted := true; + else (formatted := Some lexbuf.lex_start_p; Output.start_inline_coq_block (); let _ = body_bol lexbuf in - Output.end_inline_coq_block (); formatted := false); + Output.end_inline_coq_block (); formatted := None); comment lexbuf } | "$" { if !Cdglobals.plain_comments then Output.char '$' @@ -1083,13 +1131,14 @@ and skip_to_dot_or_brace = parse and body_bol = parse | space+ { Output.indentation (fst (count_spaces (lexeme lexbuf))); body lexbuf } - | _ { backtrack lexbuf; Output.indentation 0; body lexbuf } + | "" { Output.indentation 0; body lexbuf } and body = parse | nl {Tokens.flush_sublexer(); Output.line_break(); Lexing.new_line lexbuf; body_bol lexbuf} - | nl+ space* "]]" space* nl - { Tokens.flush_sublexer(); - if not !formatted then + | (nl+ as s) space* "]]" space* nl + { new_lines (count_newlines s + 1) lexbuf; + Tokens.flush_sublexer(); + if is_none !formatted then begin let s = lexeme lexbuf in let nlsp,s = remove_newline s in @@ -1107,7 +1156,8 @@ and body = parse end } | "]]" space* nl { Tokens.flush_sublexer(); - if not !formatted then + Lexing.new_line lexbuf; + if is_none !formatted then begin let loc = lexeme_start lexbuf in Output.sublexer ']' loc; @@ -1121,13 +1171,19 @@ and body = parse Output.paragraph (); true end } - | eof { Tokens.flush_sublexer(); false } - | '.' space* nl | '.' space* eof - { Tokens.flush_sublexer(); Output.char '.'; Output.line_break(); - if not !formatted then true else body_bol lexbuf } + | eof + { Tokens.flush_sublexer(); + match !formatted with + | None -> false + | Some p -> raise (MismatchPreformatted p) } + | '.' space* (nl as s | eof) + { if not (is_none s) then new_line lexbuf; + Tokens.flush_sublexer(); Output.char '.'; Output.line_break(); + if is_none !formatted then true else body_bol lexbuf } | '.' space* nl "]]" space* nl - { Tokens.flush_sublexer(); Output.char '.'; - if not !formatted then + { new_lines 2 lexbuf; + Tokens.flush_sublexer(); Output.char '.'; + if is_none !formatted then begin eprintf "Error: stray ]] at %d\n" (lexeme_start lexbuf); flush stderr; @@ -1141,9 +1197,10 @@ and body = parse } | '.' space+ { Tokens.flush_sublexer(); Output.char '.'; Output.char ' '; - if not !formatted then false else body lexbuf } - | "(**" space_nl - { Tokens.flush_sublexer(); Output.end_coq (); Output.start_doc (); + if is_none !formatted then false else body lexbuf } + | "(**" (space_nl as s) + { if is_nl s then new_line lexbuf; + Tokens.flush_sublexer(); Output.end_coq (); Output.start_doc (); let eol = doc_bol lexbuf in Output.end_doc (); Output.start_coq (); if eol then body_bol lexbuf else body lexbuf } @@ -1208,19 +1265,37 @@ and string = parse | _ { let c = lexeme_char lexbuf 0 in Output.char c; string lexbuf } and skip_hide = parse - | eof | end_hide { () } + | eof | end_hide nl { Lexing.new_line lexbuf; () } | _ { skip_hide lexbuf } (*s Reading token pretty-print *) and printing_token_body = parse - | "*)" nl? | eof - { let s = Buffer.contents token_buffer in + | "*)" (nl as s)? | eof + { if not (is_none s) then Lexing.new_line lexbuf; + let s = Buffer.contents token_buffer in Buffer.clear token_buffer; s } - | _ { Buffer.add_string token_buffer (lexeme lexbuf); + | (nl | _) as s + { if is_nl s then Lexing.new_line lexbuf; + Buffer.add_string token_buffer (lexeme lexbuf); printing_token_body lexbuf } +and details_body = parse + | "*)" space* (nl as s)? | eof + { if not (is_none s) then Lexing.new_line lexbuf; + None } + | ":" space* { details_body_rec lexbuf } + +and details_body_rec = parse + | "*)" space* (nl as s)? | eof + { if not (is_none s) then Lexing.new_line lexbuf; + let s = Buffer.contents token_buffer in + Buffer.clear token_buffer; + Some s } + | _ { Buffer.add_string token_buffer (lexeme lexbuf); + details_body_rec lexbuf } + (*s These handle inference rules, parsing the body segments of things enclosed in [[[ ]]] brackets *) and inf_rules indents = parse @@ -1318,6 +1393,14 @@ and st_subtitle = parse (*s Applying the scanners to files *) { + (* coq_bol with error handling *) + let coq_bol' f lb = + Lexing.new_line lb; (* Start numbering lines from 1 *) + try coq_bol lb with + | MismatchPreformatted p -> + Printf.eprintf "%a: mismatched \"[[\"\n" print_position { p with pos_fname = f }; + exit 1 + let coq_file f m = reset (); let c = open_in f in @@ -1325,7 +1408,7 @@ and st_subtitle = parse (Index.current_library := m; Output.initialize (); Output.start_module (); - Output.start_coq (); coq_bol lb; Output.end_coq (); + Output.start_coq (); coq_bol' f lb; Output.end_coq (); close_in c) let detect_subtitle f m = diff --git a/tools/coqdoc/index.ml b/tools/coqdoc/index.ml index 4cc82726f1..723918525d 100644 --- a/tools/coqdoc/index.ml +++ b/tools/coqdoc/index.ml @@ -31,6 +31,7 @@ type entry_type = | Abbreviation | Notation | Section + | Binder type index_entry = | Def of string * entry_type @@ -177,6 +178,7 @@ let type_name = function | Abbreviation -> "abbreviation" | Notation -> "notation" | Section -> "section" + | Binder -> "binder" let prepare_entry s = function | Notation -> @@ -268,6 +270,7 @@ let type_of_string = function | "mod" | "modtype" -> Module | "tac" -> TacticDefinition | "sec" -> Section + | "binder" -> Binder | s -> invalid_arg ("type_of_string:" ^ s) let ill_formed_glob_file f = diff --git a/tools/coqdoc/index.mli b/tools/coqdoc/index.mli index 3426fdd3d3..7a3d401fd7 100644 --- a/tools/coqdoc/index.mli +++ b/tools/coqdoc/index.mli @@ -30,6 +30,7 @@ type entry_type = | Abbreviation | Notation | Section + | Binder val type_name : entry_type -> string diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml index 862715753d..def1cbbcf8 100644 --- a/tools/coqdoc/output.ml +++ b/tools/coqdoc/output.ml @@ -337,11 +337,8 @@ module Latex = struct let id = if fid <> "" then (m ^ "." ^ fid) else m in match find_module m with | Local -> - if typ = Variable then - printf "\\coqdoc%s{%s}" (type_name typ) s - else - (printf "\\coqref{"; label_ident id; - printf "}{\\coqdoc%s{%s}}" (type_name typ) s) + printf "\\coqref{"; label_ident id; + printf "}{\\coqdoc%s{%s}}" (type_name typ) s | External m when !externals -> printf "\\coqexternalref{"; label_ident fid; printf "}{%s}{\\coqdoc%s{%s}}" (escaped m) (type_name typ) s @@ -469,6 +466,11 @@ module Latex = struct let stop_emph () = printf "}" + let start_details _ = () + + let stop_details () = () + + let start_comment () = printf "\\begin{coqdoccomment}\n" let end_comment () = printf "\\end{coqdoccomment}\n" @@ -610,6 +612,7 @@ module Html = struct else match s.[i] with | 'a'..'z' | 'A'..'Z' | '0'..'9' | '.' | '_' -> loop esc (i-1) | '<' | '>' | '&' | '\'' | '\"' -> loop true (i-1) + | '-' | ':' -> loop esc (i-1) (* should be safe in HTML5 attribute name syntax *) | _ -> (* This name contains complex characters: this is probably a notation string, we simply hash it. *) @@ -656,7 +659,8 @@ module Html = struct let reference s r = match r with | Def (fullid,ty) -> - printf "<a name=\"%s\">" (sanitize_name fullid); + let s' = sanitize_name fullid in + printf "<a id=\"%s\" class=\"idref\" href=\"#%s\">" s' s'; printf "<span class=\"id\" title=\"%s\">%s</span></a>" (type_name ty) s | Ref (m,fullid,ty) -> ident_ref m fullid (type_name ty) s @@ -740,6 +744,12 @@ module Html = struct let stop_emph () = printf "</i>" + let start_details = function + | Some s -> printf "<details><summary>%s</summary>" s + | _ -> printf "<details>" + + let stop_details () = printf "</details>" + let start_comment () = printf "<span class=\"comment\">(*" let end_comment () = printf "*)</span>" @@ -811,7 +821,7 @@ module Html = struct | Some n -> if lev <= n then add_toc_entry (Toc_section (lev, f, r)) else ()); stop_item (); - printf "<a name=\"%s\"></a><h%d class=\"section\">" lab lev; + printf "<a id=\"%s\"></a><h%d class=\"section\">" lab lev; f (); printf "</h%d>\n" lev @@ -825,7 +835,7 @@ module Html = struct let letter_index category idx (c,l) = if l <> [] then begin let cat = if category && idx <> "global" then "(" ^ idx ^ ")" else "" in - printf "<a name=\"%s_%c\"></a><h2>%s %s</h2>\n" idx c (display_letter c) cat; + printf "<a id=\"%s_%c\"></a><h2>%s %s</h2>\n" idx c (display_letter c) cat; List.iter (fun (id,(text,link,t)) -> let id' = prepare_entry id t in @@ -1053,6 +1063,9 @@ module TeXmacs = struct let start_emph () = printf "<with|font shape|italic|" let stop_emph () = printf ">" + let start_details _ = () + let stop_details () = () + let start_comment () = () let end_comment () = () @@ -1159,6 +1172,9 @@ module Raw = struct let start_emph () = printf "_" let stop_emph () = printf "_" + let start_details _ = () + let stop_details () = () + let start_comment () = printf "(*" let end_comment () = printf "*)" @@ -1272,6 +1288,11 @@ let start_emph = let stop_emph = select Latex.stop_emph Html.stop_emph TeXmacs.stop_emph Raw.stop_emph +let start_details = + select Latex.start_details Html.start_details TeXmacs.start_details Raw.start_details +let stop_details = + select Latex.stop_details Html.stop_details TeXmacs.stop_details Raw.stop_details + let start_latex_math = select Latex.start_latex_math Html.start_latex_math TeXmacs.start_latex_math Raw.start_latex_math let stop_latex_math = diff --git a/tools/coqdoc/output.mli b/tools/coqdoc/output.mli index 485183a4ed..b7a8d4d858 100644 --- a/tools/coqdoc/output.mli +++ b/tools/coqdoc/output.mli @@ -29,6 +29,9 @@ val start_module : unit -> unit val start_doc : unit -> unit val end_doc : unit -> unit +val start_details : string option -> unit +val stop_details : unit -> unit + val start_emph : unit -> unit val stop_emph : unit -> unit diff --git a/tools/dune b/tools/dune index c0e4e20f72..d591bb0c37 100644 --- a/tools/dune +++ b/tools/dune @@ -49,8 +49,8 @@ (ocamllex coqwc) (executables - (names coq_tex coq_dune) - (public_names coq-tex coq_dune) + (names coq_tex) + (public_names coq-tex) (package coq) - (modules coq_tex coq_dune) + (modules coq_tex) (libraries str)) diff --git a/tools/make-both-time-files.py b/tools/make-both-time-files.py index 5d88548bba..3959ff5c2a 100755 --- a/tools/make-both-time-files.py +++ b/tools/make-both-time-files.py @@ -5,11 +5,13 @@ if __name__ == '__main__': parser = argparse.ArgumentParser(description=r'''Formats timing information from the output of two invocations of `make TIMED=1` into a sorted table.''') add_sort_by(parser) add_real(parser) + add_include_mem(parser) + add_sort_by_mem(parser) add_after_file_name(parser) add_before_file_name(parser) add_output_file_name(parser) args = parser.parse_args() - left_dict = get_times(args.AFTER_FILE_NAME, use_real=args.real) - right_dict = get_times(args.BEFORE_FILE_NAME, use_real=args.real) - table = make_diff_table_string(left_dict, right_dict, sort_by=args.sort_by) + left_dict = get_times_and_mems(args.AFTER_FILE_NAME, use_real=args.real, include_mem=args.include_mem) + right_dict = get_times_and_mems(args.BEFORE_FILE_NAME, use_real=args.real, include_mem=args.include_mem) + table = make_diff_table_string(left_dict, right_dict, sort_by=args.sort_by, include_mem=args.include_mem, sort_by_mem=args.sort_by_mem) print_or_write_table(table, args.OUTPUT_FILE_NAME) diff --git a/tools/make-one-time-file.py b/tools/make-one-time-file.py index 3df7d7e584..df02383724 100755 --- a/tools/make-one-time-file.py +++ b/tools/make-one-time-file.py @@ -7,7 +7,9 @@ if __name__ == '__main__': add_real(parser) add_file_name(parser) add_output_file_name(parser) + add_include_mem(parser) + add_sort_by_mem(parser) args = parser.parse_args() - times_dict = get_times(args.FILE_NAME, use_real=args.real) - table = make_table_string(times_dict) + stats_dict = get_times_and_mems(args.FILE_NAME, use_real=args.real, include_mem=args.include_mem) + table = make_table_string(stats_dict, include_mem=args.include_mem, sort_by_mem=args.sort_by_mem) print_or_write_table(table, args.OUTPUT_FILE_NAME) diff --git a/toplevel/ccompile.ml b/toplevel/ccompile.ml index a7a9b77b56..c8b8660b92 100644 --- a/toplevel/ccompile.ml +++ b/toplevel/ccompile.ml @@ -131,7 +131,7 @@ let set_options = List.iter set_option let compile opts copts ~echo ~f_in ~f_out = let open Vernac.State in let check_pending_proofs () = - let pfs = Vernacstate.Proof_global.get_all_proof_names () [@ocaml.warning "-3"] in + let pfs = Vernacstate.Declare.get_all_proof_names () [@ocaml.warning "-3"] in if not (CList.is_empty pfs) then fatal_error (str "There are pending proofs: " ++ (pfs diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index 4963a806f5..17435c051e 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -44,8 +44,6 @@ type coqargs_logic_config = { impredicative_set : Declarations.set_predicativity; indices_matter : bool; toplevel_name : Stm.interactive_top; - allow_sprop : bool; - cumulative_sprop : bool; } type coqargs_config = { @@ -59,7 +57,6 @@ type coqargs_config = { native_include_dirs : CUnix.physical_path list; stm_flags : Stm.AsyncOpts.stm_opt; debug : bool; - diffs_set : bool; time : bool; print_emacs : bool; set_options : (Goptions.option_name * option_command) list; @@ -112,8 +109,6 @@ let default_logic_config = { impredicative_set = Declarations.PredicativeSet; indices_matter = false; toplevel_name = Stm.TopLogical default_toplevel; - allow_sprop = true; - cumulative_sprop = false; } let default_config = { @@ -127,7 +122,6 @@ let default_config = { native_include_dirs = []; stm_flags = Stm.AsyncOpts.default_opts; debug = false; - diffs_set = false; time = false; print_emacs = false; set_options = []; @@ -178,9 +172,12 @@ let add_vo_require opts d p export = let add_load_vernacular opts verb s = { opts with pre = { opts.pre with load_vernacular_list = (CUnix.make_suffix s ".v",verb) :: opts.pre.load_vernacular_list }} +let add_set_option opts opt_name value = + { opts with config = { opts.config with set_options = (opt_name, value) :: opts.config.set_options }} + (** Options for proof general *) let set_emacs opts = - Printer.enable_goal_tags_printing := true; + Goptions.set_bool_option_value Printer.print_goal_tag_opt_name true; { opts with config = { opts.config with color = `EMACS; print_emacs = true }} let set_logic f oval = @@ -199,14 +196,14 @@ let set_query opts q = | Queries queries -> Queries (queries@[q]) } +let warn_deprecated_sprop_cumul = + CWarnings.create ~name:"deprecated-spropcumul" ~category:"deprecated" + (fun () -> Pp.strbrk "Use the \"Cumulative StrictProp\" flag instead.") + let warn_deprecated_inputstate = CWarnings.create ~name:"deprecated-inputstate" ~category:"deprecated" (fun () -> Pp.strbrk "The inputstate option is deprecated and discouraged.") -let warn_deprecated_simple_require = - CWarnings.create ~name:"deprecated-boot" ~category:"deprecated" - (fun () -> Pp.strbrk "The -require option is deprecated, please use -require-import instead.") - let set_inputstate opts s = warn_deprecated_inputstate (); { opts with pre = { opts.pre with inputstate = Some s }} @@ -291,6 +288,30 @@ let parse_option_set opt = let v = String.sub opt (eqi+1) (len - eqi - 1) in to_opt_key (String.sub opt 0 eqi), Some v +let warn_no_native_compiler = + CWarnings.create ~name:"native-compiler-disabled" ~category:"native-compiler" + Pp.(fun s -> strbrk "Native compiler is disabled," ++ + strbrk " -native-compiler " ++ strbrk s ++ + strbrk " option ignored.") + +let get_native_compiler s = + (* We use two boolean flags because the four states make sense, even if + only three are accessible to the user at the moment. The selection of the + produced artifact(s) (`.vo`, `.vio`, `.coq-native`, ...) should be done by + a separate flag, and the "ondemand" value removed. Once this is done, use + [get_bool] here. *) + let n = match s with + | ("yes" | "on") -> NativeOn {ondemand=false} + | "ondemand" -> NativeOn {ondemand=true} + | ("no" | "off") -> NativeOff + | _ -> + error_wrong_arg ("Error: (yes|no|ondemand) expected after option -native-compiler") in + if not Coq_config.native_compiler && n <> NativeOff then + let () = warn_no_native_compiler s in + NativeOff + else + n + (* Main parsing routine *) (*s Parsing of the command line *) @@ -422,10 +443,6 @@ let parse_args ~help ~init arglist : t * string list = |"-rfrom" -> let from = next () in add_vo_require oval (next ()) (Some from) None - |"-require" -> - warn_deprecated_simple_require (); - add_vo_require oval (next ()) None (Some false) - |"-require-import" | "-ri" -> add_vo_require oval (next ()) None (Some false) |"-require-export" | "-re" -> add_vo_require oval (next ()) None (Some true) @@ -464,31 +481,15 @@ let parse_args ~help ~init arglist : t * string list = { oval with config = { oval.config with enable_VM = get_bool opt (next ()) }} |"-native-compiler" -> - - (* We use two boolean flags because the four states make sense, even if - only three are accessible to the user at the moment. The selection of the - produced artifact(s) (`.vo`, `.vio`, `.coq-native`, ...) should be done by - a separate flag, and the "ondemand" value removed. Once this is done, use - [get_bool] here. *) - let native_compiler = - match (next ()) with - | ("yes" | "on") -> NativeOn {ondemand=false} - | "ondemand" -> NativeOn {ondemand=true} - | ("no" | "off") -> NativeOff - | _ -> - error_wrong_arg ("Error: (yes|no|ondemand) expected after option -native-compiler") - in + let native_compiler = get_native_compiler (next ()) in { oval with config = { oval.config with native_compiler }} | "-set" -> - let opt = next() in - let opt, v = parse_option_set opt in - { oval with config = { oval.config with set_options = (opt, OptionSet v) :: oval.config.set_options }} + let opt, v = parse_option_set @@ next() in + add_set_option oval opt (OptionSet v) | "-unset" -> - let opt = next() in - let opt = to_opt_key opt in - { oval with config = { oval.config with set_options = (opt, OptionUnset) :: oval.config.set_options }} + add_set_option oval (to_opt_key @@ next ()) OptionUnset |"-native-output-dir" -> let native_output_dir = next () in @@ -511,19 +512,19 @@ let parse_args ~help ~init arglist : t * string list = |"-color" -> set_color oval (next ()) |"-config"|"--config" -> set_query oval PrintConfig |"-debug" -> Coqinit.set_debug (); oval - |"-diffs" -> let opt = next () in - if List.exists (fun x -> opt = x) ["off"; "on"; "removed"] then - Proof_diffs.write_diffs_option opt - else - error_wrong_arg "Error: on|off|removed expected after -diffs"; - { oval with config = { oval.config with diffs_set = true }} + |"-diffs" -> + add_set_option oval Proof_diffs.opt_name @@ OptionSet (Some (next ())) |"-stm-debug" -> Stm.stm_debug := true; oval |"-emacs" -> set_emacs oval |"-impredicative-set" -> set_logic (fun o -> { o with impredicative_set = Declarations.ImpredicativeSet }) oval - |"-allow-sprop" -> set_logic (fun o -> { o with allow_sprop = true }) oval - |"-disallow-sprop" -> set_logic (fun o -> { o with allow_sprop = false }) oval - |"-sprop-cumulative" -> set_logic (fun o -> { o with cumulative_sprop = true }) oval + |"-allow-sprop" -> + add_set_option oval Vernacentries.allow_sprop_opt_name (OptionSet None) + |"-disallow-sprop" -> + add_set_option oval Vernacentries.allow_sprop_opt_name OptionUnset + |"-sprop-cumulative" -> + warn_deprecated_sprop_cumul(); + add_set_option oval Vernacentries.cumul_sprop_opt_name (OptionSet None) |"-indices-matter" -> set_logic (fun o -> { o with indices_matter = true }) oval |"-m"|"--memory" -> { oval with post = { oval.post with memory_stat = true }} |"-noinit"|"-nois" -> { oval with pre = { oval.pre with load_init = false }} diff --git a/toplevel/coqargs.mli b/toplevel/coqargs.mli index 3d709db54d..a51ed6766a 100644 --- a/toplevel/coqargs.mli +++ b/toplevel/coqargs.mli @@ -20,8 +20,6 @@ type coqargs_logic_config = { impredicative_set : Declarations.set_predicativity; indices_matter : bool; toplevel_name : Stm.interactive_top; - allow_sprop : bool; - cumulative_sprop : bool; } type coqargs_config = { @@ -35,7 +33,6 @@ type coqargs_config = { native_include_dirs : CUnix.physical_path list; stm_flags : Stm.AsyncOpts.stm_opt; debug : bool; - diffs_set : bool; time : bool; print_emacs : bool; set_options : (Goptions.option_name * option_command) list; diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index b8acdd3af1..2c5faa4df7 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -191,8 +191,8 @@ end from cycling. *) let make_prompt () = try - (Names.Id.to_string (Vernacstate.Proof_global.get_current_proof_name ())) ^ " < " - with Vernacstate.Proof_global.NoCurrentProof -> + (Names.Id.to_string (Vernacstate.Declare.get_current_proof_name ())) ^ " < " + with Vernacstate.Declare.NoCurrentProof -> "Coq < " [@@ocaml.warning "-3"] @@ -352,7 +352,7 @@ let print_anyway c = let top_goal_print ~doc c oldp newp = try let proof_changed = not (Option.equal cproof oldp newp) in - let print_goals = proof_changed && Vernacstate.Proof_global.there_are_pending_proofs () || + let print_goals = proof_changed && Vernacstate.Declare.there_are_pending_proofs () || print_anyway c in if not !Flags.quiet && print_goals then begin let dproof = Stm.get_prev_proof ~doc (Stm.get_current_state ~doc) in @@ -375,7 +375,7 @@ let exit_on_error = point we should consolidate the code *) let show_proof_diff_to_pp pstate = let p = Option.get pstate in - let sigma, env = Pfedit.get_proof_context p in + let sigma, env = Proof.get_proof_context p in let pprf = Proof.partial_proof p in Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf @@ -392,7 +392,7 @@ let show_proof_diff_cmd ~state removed = let show_removed = Some removed in Pp_diff.diff_pp_combined ~tokenize_string ?show_removed o_pp n_pp with - | Pfedit.NoSuchGoal + | Proof.NoSuchGoal _ | Option.IsNone -> n_pp | Pp_diff.Diff_Failure msg -> begin (* todo: print the unparsable string (if we know it) *) @@ -403,7 +403,7 @@ let show_proof_diff_cmd ~state removed = else n_pp with - | Pfedit.NoSuchGoal + | Proof.NoSuchGoal _ | Option.IsNone -> CErrors.user_err (str "No goals to show.") diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index a63cff3e6f..7aad856d0a 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -197,9 +197,8 @@ let init_execution opts custom_init = Global.set_engagement opts.config.logic.impredicative_set; Global.set_indices_matter opts.config.logic.indices_matter; Global.set_VM opts.config.enable_VM; + Flags.set_native_compiler (match opts.config.native_compiler with NativeOff -> false | NativeOn _ -> true); Global.set_native_compiler (match opts.config.native_compiler with NativeOff -> false | NativeOn _ -> true); - Global.set_allow_sprop opts.config.logic.allow_sprop; - if opts.config.logic.cumulative_sprop then Global.make_sprop_cumulative (); (* Native output dir *) Nativelib.output_dir := opts.config.native_output_dir; diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index 076796468f..c4c8492a4a 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -66,7 +66,7 @@ let interp_vernac ~check ~interactive ~state ({CAst.loc;_} as com) = (* Force the command *) let ndoc = if check then Stm.observe ~doc nsid else doc in - let new_proof = Vernacstate.Proof_global.give_me_the_proof_opt () [@ocaml.warning "-3"] in + let new_proof = Vernacstate.Declare.give_me_the_proof_opt () [@ocaml.warning "-3"] in { state with doc = ndoc; sid = nsid; proof = new_proof; } with reraise -> let (reraise, info) = Exninfo.capture reraise in diff --git a/user-contrib/Ltac2/Fresh.v b/user-contrib/Ltac2/Fresh.v index 548bf74a30..5ad9badc8c 100644 --- a/user-contrib/Ltac2/Fresh.v +++ b/user-contrib/Ltac2/Fresh.v @@ -9,6 +9,8 @@ (************************************************************************) Require Import Ltac2.Init. +Require Ltac2.Control. +Require Ltac2.List. Module Free. @@ -21,8 +23,12 @@ Ltac2 @ external of_ids : ident list -> t := "ltac2" "fresh_free_of_ids". Ltac2 @ external of_constr : constr -> t := "ltac2" "fresh_free_of_constr". +Ltac2 of_goal () := of_ids (List.map (fun (id, _, _) => id) (Control.hyps ())). + End Free. Ltac2 @ external fresh : Free.t -> ident -> ident := "ltac2" "fresh_fresh". (** Generate a fresh identifier with the given base name which is not a member of the provided set of free variables. *) + +Ltac2 in_goal id := Fresh.fresh (Free.of_goal ()) id. diff --git a/user-contrib/Ltac2/dune b/user-contrib/Ltac2/dune new file mode 100644 index 0000000000..90869a46a0 --- /dev/null +++ b/user-contrib/Ltac2/dune @@ -0,0 +1,14 @@ +(coq.theory + (name Ltac2) + (package coq) + (synopsis "Ltac2 tactic language") + (libraries coq.plugins.ltac2)) + +(library + (name ltac2_plugin) + (public_name coq.plugins.ltac2) + (synopsis "Ltac2 plugin") + (modules_without_implementation tac2expr tac2qexpr tac2types) + (libraries coq.plugins.ltac)) + +(coq.pp (modules g_ltac2)) diff --git a/user-contrib/Ltac2/g_ltac2.mlg b/user-contrib/Ltac2/g_ltac2.mlg index 57d59fc2ef..13c4d667a0 100644 --- a/user-contrib/Ltac2/g_ltac2.mlg +++ b/user-contrib/Ltac2/g_ltac2.mlg @@ -145,10 +145,10 @@ GRAMMAR EXTEND Gram { CAst.make ~loc @@ CTacCse (e, bl) } ] | "4" LEFTA [ ] - | [ e0 = SELF; ","; el = LIST1 NEXT SEP "," -> + | "3" [ e0 = SELF; ","; el = LIST1 NEXT SEP "," -> { let el = e0 :: el in CAst.make ~loc @@ CTacApp (CAst.make ~loc @@ CTacCst (AbsKn (Tuple (List.length el))), el) } ] - | "::" RIGHTA + | "2" RIGHTA [ e1 = tac2expr; "::"; e2 = tac2expr -> { CAst.make ~loc @@ CTacApp (CAst.make ~loc @@ CTacCst (AbsKn (Other Tac2core.Core.c_cons)), [e1; e2]) } ] diff --git a/user-contrib/Ltac2/tac2core.ml b/user-contrib/Ltac2/tac2core.ml index 2ed854c9f7..e77040a8db 100644 --- a/user-contrib/Ltac2/tac2core.ml +++ b/user-contrib/Ltac2/tac2core.ml @@ -20,7 +20,7 @@ open Proofview.Notations let constr_flags = let open Pretyping in { - use_typeclasses = true; + use_typeclasses = Pretyping.UseTC; solve_unification_constraints = true; fail_evar = true; expand_evars = true; @@ -31,7 +31,7 @@ let constr_flags = let open_constr_no_classes_flags = let open Pretyping in { - use_typeclasses = false; + use_typeclasses = Pretyping.NoUseTC; solve_unification_constraints = true; fail_evar = false; expand_evars = true; @@ -375,7 +375,7 @@ let () = define1 "constr_kind" constr begin fun c -> | Evar (evk, args) -> v_blk 3 [| Value.of_int (Evar.repr evk); - Value.of_array Value.of_constr args; + Value.of_array Value.of_constr (Array.of_list args); |] | Sort s -> v_blk 4 [|Value.of_ext Value.val_sort s|] @@ -469,7 +469,7 @@ let () = define1 "constr_make" valexpr begin fun knd -> | (3, [|evk; args|]) -> let evk = Evar.unsafe_of_int (Value.to_int evk) in let args = Value.to_array Value.to_constr args in - EConstr.mkEvar (evk, args) + EConstr.mkEvar (evk, Array.to_list args) | (4, [|s|]) -> let s = Value.to_ext Value.val_sort s in EConstr.mkSort (EConstr.Unsafe.to_sorts s) @@ -603,7 +603,7 @@ let () = define3 "constr_in_context" ident constr closure begin fun id t c -> thaw c >>= fun _ -> Proofview.Unsafe.tclSETGOALS [Proofview.with_empty_state (Proofview.Goal.goal gl)] >>= fun () -> let args = List.map (fun d -> EConstr.mkVar (get_id d)) (EConstr.named_context env) in - let args = Array.of_list (EConstr.mkRel 1 :: args) in + let args = EConstr.mkRel 1 :: args in let ans = EConstr.mkEvar (evk, args) in let ans = EConstr.mkLambda (Context.make_annot (Name id) Sorts.Relevant, t, ans) in return (Value.of_constr ans) @@ -1290,7 +1290,7 @@ let () = let ist = Tac2interp.get_env ist in let tac = Proofview.tclIGNORE (Tac2interp.interp ist tac) in let name, poly = Id.of_string "ltac2", poly in - let c, sigma = Pfedit.refine_by_tactic ~name ~poly env sigma concl tac in + let c, sigma = Proof.refine_by_tactic ~name ~poly env sigma concl tac in (EConstr.of_constr c, sigma) in GlobEnv.register_constr_interp0 wit_ltac2_constr interp diff --git a/user-contrib/Ltac2/tac2entries.ml b/user-contrib/Ltac2/tac2entries.ml index ebc63ddd01..28e877491e 100644 --- a/user-contrib/Ltac2/tac2entries.ml +++ b/user-contrib/Ltac2/tac2entries.ml @@ -91,7 +91,7 @@ let inTacDef : tacdef -> obj = declare_object {(default_object "TAC2-DEFINITION") with cache_function = cache_tacdef; load_function = load_tacdef; - open_function = open_tacdef; + open_function = simple_open open_tacdef; subst_function = subst_tacdef; classify_function = classify_tacdef} @@ -198,7 +198,7 @@ let inTypDef : typdef -> obj = declare_object {(default_object "TAC2-TYPE-DEFINITION") with cache_function = cache_typdef; load_function = load_typdef; - open_function = open_typdef; + open_function = simple_open open_typdef; subst_function = subst_typdef; classify_function = classify_typdef} @@ -268,7 +268,7 @@ let inTypExt : typext -> obj = declare_object {(default_object "TAC2-TYPE-EXTENSION") with cache_function = cache_typext; load_function = load_typext; - open_function = open_typext; + open_function = simple_open open_typext; subst_function = subst_typext; classify_function = classify_typext} @@ -664,7 +664,7 @@ let classify_synext o = let inTac2Notation : synext -> obj = declare_object {(default_object "TAC2-NOTATION") with cache_function = cache_synext; - open_function = open_synext; + open_function = simple_open open_synext; subst_function = subst_synext; classify_function = classify_synext} @@ -694,7 +694,7 @@ let inTac2Abbreviation : abbreviation -> obj = declare_object {(default_object "TAC2-ABBREVIATION") with cache_function = cache_abbreviation; load_function = load_abbreviation; - open_function = open_abbreviation; + open_function = simple_open open_abbreviation; subst_function = subst_abbreviation; classify_function = classify_abbreviation} @@ -747,7 +747,7 @@ let classify_redefinition o = Substitute o let inTac2Redefinition : redefinition -> obj = declare_object {(default_object "TAC2-REDEFINITION") with cache_function = perform_redefinition; - open_function = (fun _ -> perform_redefinition); + open_function = simple_open (fun _ -> perform_redefinition); subst_function = subst_redefinition; classify_function = classify_redefinition } @@ -795,7 +795,7 @@ let perform_eval ~pstate e = Goal_select.SelectAll, Proof.start ~name ~poly sigma [] | Some pstate -> Goal_select.get_default_goal_selector (), - Proof_global.get_proof pstate + Declare.Proof.get_proof pstate in let v = match selector with | Goal_select.SelectNth i -> Proofview.tclFOCUS i i v @@ -899,10 +899,10 @@ let print_ltac qid = (** Calling tactics *) let solve ~pstate default tac = - let pstate, status = Proof_global.map_fold_proof_endline begin fun etac p -> + let pstate, status = Declare.Proof.map_fold_proof_endline begin fun etac p -> let with_end_tac = if default then Some etac else None in let g = Goal_select.get_default_goal_selector () in - let (p, status) = Pfedit.solve g None tac ?with_end_tac p in + let (p, status) = Proof.solve g None tac ?with_end_tac p in (* in case a strict subtree was completed, go back to the top of the prooftree *) let p = Proof.maximal_unfocus Vernacentries.command_focus p in @@ -962,7 +962,7 @@ let inTac2Init : unit -> obj = declare_object {(default_object "TAC2-INIT") with cache_function = cache_ltac2_init; load_function = load_ltac2_init; - open_function = open_ltac2_init; + open_function = simple_open open_ltac2_init; } let _ = Mltop.declare_cache_obj begin fun () -> diff --git a/user-contrib/Ltac2/tac2entries.mli b/user-contrib/Ltac2/tac2entries.mli index edad118dc9..fc56a54e3a 100644 --- a/user-contrib/Ltac2/tac2entries.mli +++ b/user-contrib/Ltac2/tac2entries.mli @@ -31,7 +31,7 @@ val register_struct val register_notation : ?local:bool -> sexpr list -> int option -> raw_tacexpr -> unit -val perform_eval : pstate:Proof_global.t option -> raw_tacexpr -> unit +val perform_eval : pstate:Declare.Proof.t option -> raw_tacexpr -> unit (** {5 Notations} *) @@ -53,7 +53,7 @@ val print_ltac : Libnames.qualid -> unit (** {5 Eval loop} *) (** Evaluate a tactic expression in the current environment *) -val call : pstate:Proof_global.t -> default:bool -> raw_tacexpr -> Proof_global.t +val call : pstate:Declare.Proof.t -> default:bool -> raw_tacexpr -> Declare.Proof.t (** {5 Toplevel exceptions} *) diff --git a/user-contrib/Ltac2/tac2tactics.ml b/user-contrib/Ltac2/tac2tactics.ml index 30ee1a0b4c..9ca38d64df 100644 --- a/user-contrib/Ltac2/tac2tactics.ml +++ b/user-contrib/Ltac2/tac2tactics.ml @@ -20,7 +20,7 @@ let return = Proofview.tclUNIT let thaw r f = Tac2ffi.app_fun1 f Tac2ffi.unit r () let tactic_infer_flags with_evar = { - Pretyping.use_typeclasses = true; + Pretyping.use_typeclasses = Pretyping.UseTC; Pretyping.solve_unification_constraints = true; Pretyping.fail_evar = not with_evar; Pretyping.expand_evars = true; diff --git a/vernac/.ocamlformat-enable b/vernac/.ocamlformat-enable new file mode 100644 index 0000000000..ffaa7e70f4 --- /dev/null +++ b/vernac/.ocamlformat-enable @@ -0,0 +1 @@ +comHints.ml diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index 0c9b9c7255..ebea5e146c 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -113,8 +113,8 @@ let mkFullInd (ind,u) n = else mkIndU (ind,u) let check_bool_is_defined () = - try let _ = Typeops.type_of_global_in_context (Global.env ()) Coqlib.(lib_ref "core.bool.type") in () - with e when CErrors.noncritical e -> raise (UndefinedCst "bool") + if not (Coqlib.has_ref "core.bool.type") + then raise (UndefinedCst "bool") let check_no_indices mib = if Array.exists (fun mip -> mip.mind_nrealargs <> 0) mib.mind_packets then @@ -122,6 +122,53 @@ let check_no_indices mib = let beq_scheme_kind_aux = ref (fun _ -> failwith "Undefined") +let build_beq_scheme_deps kn = + (* fetching global env *) + let env = Global.env() in + (* fetching the mutual inductive body *) + let mib = Global.lookup_mind kn in + (* number of inductives in the mutual *) + let nb_ind = Array.length mib.mind_packets in + (* number of params in the type *) + let nparrec = mib.mind_nparams_rec in + check_no_indices mib; + let make_one_eq accu i = + (* This function is only trying to recursively compute the inductive types + appearing as arguments of the constructors. This is done to support + equality decision over hereditarily first-order types. It could be + perfomed in a much cleaner way, e.g. using the kernel normal form of + constructor types and kernel whd_all for the argument types. *) + let rec aux accu c = + let (c,a) = Reductionops.whd_betaiota_stack Evd.empty EConstr.(of_constr c) in + let (c,a) = EConstr.Unsafe.(to_constr c, List.map to_constr a) in + match Constr.kind c with + | Cast (x,_,_) -> aux accu (Term.applist (x,a)) + | App _ -> assert false + | Ind ((kn', _), _) -> + if MutInd.equal kn kn' then accu + else + let eff = SchemeMutualDep (kn', !beq_scheme_kind_aux ()) in + List.fold_left aux (eff :: accu) a + | Const (kn, u) -> + (match Environ.constant_opt_value_in env (kn, u) with + | Some c -> aux accu (Term.applist (c,a)) + | None -> accu) + | Rel _ | Var _ | Sort _ | Prod _ | Lambda _ | LetIn _ | Proj _ + | Construct _ | Case _ | CoFix _ | Fix _ | Meta _ | Evar _ | Int _ + | Float _ -> accu + in + let u = Univ.Instance.empty in + let constrs n = get_constructors env (make_ind_family (((kn, i), u), + Context.Rel.to_extended_list mkRel (n+nb_ind-1) mib.mind_params_ctxt)) in + let constrsi = constrs (3+nparrec) in + let fold i accu arg = + let fold accu c = aux accu (RelDecl.get_type c) in + List.fold_left fold accu arg.cs_args + in + Array.fold_left_i fold accu constrsi + in + Array.fold_left_i (fun i accu _ -> make_one_eq accu i) [] mib.mind_packets + let build_beq_scheme mode kn = check_bool_is_defined (); (* fetching global env *) @@ -194,7 +241,7 @@ let build_beq_scheme mode kn = let (c,a) = Reductionops.whd_betaiota_stack Evd.empty EConstr.(of_constr c) in let (c,a) = EConstr.Unsafe.(to_constr c, List.map to_constr a) in match Constr.kind c with - | Rel x -> mkRel (x-nlist+ndx), Evd.empty_side_effects + | Rel x -> mkRel (x-nlist+ndx) | Var x -> (* Support for working in a context with "eq_x : x -> x -> bool" *) let eid = Id.of_string ("eq_"^(Id.to_string x)) in @@ -202,26 +249,23 @@ let build_beq_scheme mode kn = try ignore (Environ.lookup_named eid env) with Not_found -> raise (ParameterWithoutEquality (GlobRef.VarRef x)) in - mkVar eid, Evd.empty_side_effects + mkVar eid | Cast (x,_,_) -> aux (Term.applist (x,a)) | App _ -> assert false | Ind ((kn',i as ind'),u) (*FIXME: universes *) -> - if MutInd.equal kn kn' then mkRel(eqA-nlist-i+nb_ind-1), Evd.empty_side_effects + if MutInd.equal kn kn' then mkRel(eqA-nlist-i+nb_ind-1) else begin try - let eq, eff = - let c, eff = find_scheme ~mode (!beq_scheme_kind_aux()) (kn',i) in - mkConst c, eff in - let eqa, eff = - let eqa, effs = List.split (List.map aux a) in - Array.of_list eqa, - List.fold_left Evd.concat_side_effects eff (List.rev effs) - in + let eq = match lookup_scheme (!beq_scheme_kind_aux()) ind' with + | Some c -> mkConst c + | None -> assert false + in + let eqa = Array.of_list @@ List.map aux a in let args = Array.append (Array.of_list (List.map (fun x -> lift lifti x) a)) eqa in - if Int.equal (Array.length args) 0 then eq, eff - else mkApp (eq, args), eff + if Int.equal (Array.length args) 0 then eq + else mkApp (eq, args) with Not_found -> raise(EqNotFound (ind', fst ind)) end | Sort _ -> raise InductiveWithSort @@ -236,10 +280,10 @@ let build_beq_scheme mode kn = (* Needs Hints, see test suite *) let eq_lbl = Label.make ("eq_" ^ Label.to_string (Constant.label kn)) in let kneq = Constant.change_label kn eq_lbl in - try let _ = Environ.constant_opt_value_in env (kneq, u) in - Term.applist (mkConst kneq,a), - Evd.empty_side_effects - with Not_found -> raise (ParameterWithoutEquality (GlobRef.ConstRef kn))) + if Environ.mem_constant kneq env then + let _ = Environ.constant_opt_value_in env (kneq, u) in + Term.applist (mkConst kneq,a) + else raise (ParameterWithoutEquality (GlobRef.ConstRef kn))) | Proj _ -> raise (EqUnknown "projection") | Construct _ -> raise (EqUnknown "constructor") | Case _ -> raise (EqUnknown "match") @@ -270,7 +314,6 @@ let build_beq_scheme mode kn = let constrsi = constrs (3+nparrec) in let n = Array.length constrsi in let ar = Array.make n (ff ()) in - let eff = ref Evd.empty_side_effects in for i=0 to n-1 do let nb_cstr_args = List.length constrsi.(i).cs_args in let ar2 = Array.make n (ff ()) in @@ -282,13 +325,12 @@ let build_beq_scheme mode kn = | _ -> let eqs = Array.make nb_cstr_args (tt ()) in for ndx = 0 to nb_cstr_args-1 do let cc = RelDecl.get_type (List.nth constrsi.(i).cs_args ndx) in - let eqA, eff' = compute_A_equality rel_list + let eqA = compute_A_equality rel_list nparrec (nparrec+3+2*nb_cstr_args) (nb_cstr_args+ndx+1) cc in - eff := Evd.concat_side_effects eff' !eff; Array.set eqs ndx (mkApp (eqA, [|mkRel (ndx+1+nb_cstr_args);mkRel (ndx+1)|] @@ -314,21 +356,18 @@ let build_beq_scheme mode kn = done; mkNamedLambda (make_annot (Id.of_string "X") Sorts.Relevant) (mkFullInd ind (nb_ind-1+1)) ( mkNamedLambda (make_annot (Id.of_string "Y") Sorts.Relevant) (mkFullInd ind (nb_ind-1+2)) ( - mkCase (ci, do_predicate rel_list 0,mkVar (Id.of_string "X"),ar))), - !eff + mkCase (ci, do_predicate rel_list 0,mkVar (Id.of_string "X"),ar))) in (* build_beq_scheme *) let names = Array.make nb_ind (make_annot Anonymous Sorts.Relevant) and types = Array.make nb_ind mkSet and cores = Array.make nb_ind mkSet in - let eff = ref Evd.empty_side_effects in let u = Univ.Instance.empty in for i=0 to (nb_ind-1) do names.(i) <- make_annot (Name (Id.of_string (rec_name i))) Sorts.Relevant; types.(i) <- mkArrow (mkFullInd ((kn,i),u) 0) Sorts.Relevant (mkArrow (mkFullInd ((kn,i),u) 1) Sorts.Relevant (bb ())); - let c, eff' = make_one_eq i in + let c = make_one_eq i in cores.(i) <- c; - eff := Evd.concat_side_effects eff' !eff done; (Array.init nb_ind (fun i -> let kelim = Inductive.elim_sort (mib,mib.mind_packets.(i)) in @@ -346,10 +385,12 @@ let build_beq_scheme mode kn = Vars.substl subst cores.(i) in create_input fix), - UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ())), - !eff + UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ())) -let beq_scheme_kind = declare_mutual_scheme_object "_beq" build_beq_scheme +let beq_scheme_kind = + declare_mutual_scheme_object "_beq" + ~deps:build_beq_scheme_deps + build_beq_scheme let _ = beq_scheme_kind_aux := fun () -> beq_scheme_kind @@ -373,7 +414,7 @@ so from Ai we can find the correct eq_Ai bl_ai or lb_ai let do_replace_lb mode lb_scheme_key aavoid narg p q = let open EConstr in let avoid = Array.of_list aavoid in - let do_arg sigma hd v offset = + let do_arg env sigma hd v offset = match kind sigma v with | Var s -> let x = narg*offset in @@ -390,7 +431,9 @@ let do_replace_lb mode lb_scheme_key aavoid narg p q = Parameter (see example "J" in test file SchemeEquality.v) *) let lbl = Label.to_string (Constant.label cst) in let newlbl = if Int.equal offset 1 then ("eq_" ^ lbl) else (lbl ^ "_lb") in - mkConst (Constant.change_label cst (Label.make newlbl)) + let newcst = Constant.change_label cst (Label.make newlbl) in + if Environ.mem_constant newcst env then mkConst newcst + else raise (ConstructorWithNonParametricInductiveType (fst hd)) | _ -> raise (ConstructorWithNonParametricInductiveType (fst hd)) in @@ -398,34 +441,18 @@ let do_replace_lb mode lb_scheme_key aavoid narg p q = let type_of_pq = Tacmach.New.pf_get_type_of gl p in let sigma = Tacmach.New.project gl in let env = Tacmach.New.pf_env gl in - let u,v = destruct_ind env sigma type_of_pq - in let lb_type_of_p = - try - let c, eff = find_scheme ~mode lb_scheme_key (fst u) (*FIXME*) in - Proofview.tclUNIT (mkConst c, eff) - with Not_found -> - (* spiwack: the format of this error message should probably - be improved. *) - let err_msg = - (str "Leibniz->boolean:" ++ - str "You have to declare the" ++ - str "decidability over " ++ - Printer.pr_econstr_env env sigma type_of_pq ++ - str " first.") - in - Tacticals.New.tclZEROMSG err_msg - in - lb_type_of_p >>= fun (lb_type_of_p,eff) -> + let u,v = destruct_ind env sigma type_of_pq in + find_scheme ~mode lb_scheme_key (fst u) (*FIXME*) >>= fun c -> + let lb_type_of_p = mkConst c in Proofview.tclEVARMAP >>= fun sigma -> let lb_args = Array.append (Array.append v - (Array.Smart.map (fun x -> do_arg sigma u x 1) v)) - (Array.Smart.map (fun x -> do_arg sigma u x 2) v) + (Array.Smart.map (fun x -> do_arg env sigma u x 1) v)) + (Array.Smart.map (fun x -> do_arg env sigma u x 2) v) in let app = if Array.is_empty lb_args then lb_type_of_p else mkApp (lb_type_of_p,lb_args) in Tacticals.New.tclTHENLIST [ - Proofview.tclEFFECTS eff; Equality.replace p q ; apply app ; Auto.default_auto] end @@ -433,7 +460,7 @@ let do_replace_lb mode lb_scheme_key aavoid narg p q = let do_replace_bl bl_scheme_key (ind,u as indu) aavoid narg lft rgt = let open EConstr in let avoid = Array.of_list aavoid in - let do_arg sigma hd v offset = + let do_arg env sigma hd v offset = match kind sigma v with | Var s -> let x = narg*offset in @@ -450,7 +477,9 @@ let do_replace_bl bl_scheme_key (ind,u as indu) aavoid narg lft rgt = Parameter (see example "J" in test file SchemeEquality.v) *) let lbl = Label.to_string (Constant.label cst) in let newlbl = if Int.equal offset 1 then ("eq_" ^ lbl) else (lbl ^ "_bl") in - mkConst (Constant.change_label cst (Label.make newlbl)) + let newcst = Constant.change_label cst (Label.make newlbl) in + if Environ.mem_constant newcst env then mkConst newcst + else raise (ConstructorWithNonParametricInductiveType (fst hd)) | _ -> raise (ConstructorWithNonParametricInductiveType (fst hd)) in @@ -469,32 +498,18 @@ let do_replace_bl bl_scheme_key (ind,u as indu) aavoid narg lft rgt = in if eq_ind (fst u) ind then Tacticals.New.tclTHENLIST [Equality.replace t1 t2; Auto.default_auto ; aux q1 q2 ] else ( - let bl_t1, eff = - try - let c, eff = find_scheme bl_scheme_key (fst u) (*FIXME*) in - mkConst c, eff - with Not_found -> - (* spiwack: the format of this error message should probably - be improved. *) - let err_msg = - (str "boolean->Leibniz:" ++ - str "You have to declare the" ++ - str "decidability over " ++ - Printer.pr_econstr_env env sigma tt1 ++ - str " first.") - in - user_err err_msg - in let bl_args = + find_scheme bl_scheme_key (fst u) (*FIXME*) >>= fun c -> + let bl_t1 = mkConst c in + let bl_args = Array.append (Array.append v - (Array.Smart.map (fun x -> do_arg sigma u x 1) v)) - (Array.Smart.map (fun x -> do_arg sigma u x 2) v ) + (Array.Smart.map (fun x -> do_arg env sigma u x 1) v)) + (Array.Smart.map (fun x -> do_arg env sigma u x 2) v ) in let app = if Array.is_empty bl_args then bl_t1 else mkApp (bl_t1,bl_args) in Tacticals.New.tclTHENLIST [ - Proofview.tclEFFECTS eff; Equality.replace_by t1 t2 (Tacticals.New.tclTHEN (apply app) (Auto.default_auto)) ; aux q1 q2 ] @@ -547,11 +562,12 @@ let eqI ind l = let list_id = list_id l in let eA = Array.of_list((List.map (fun (s,_,_,_) -> mkVar s) list_id)@ (List.map (fun (_,seq,_,_)-> mkVar seq) list_id )) - and e, eff = - try let c, eff = find_scheme beq_scheme_kind ind in mkConst c, eff - with Not_found -> user_err ~hdr:"AutoIndDecl.eqI" + and e = match lookup_scheme beq_scheme_kind ind with + | Some c -> mkConst c + | None -> + user_err ~hdr:"AutoIndDecl.eqI" (str "The boolean equality on " ++ Printer.pr_inductive (Global.env ()) ind ++ str " is needed."); - in (if Array.equal Constr.equal eA [||] then e else mkApp(e,eA)), eff + in (if Array.equal Constr.equal eA [||] then e else mkApp(e,eA)) (**********************************************************************) (* Boolean->Leibniz *) @@ -559,7 +575,7 @@ let eqI ind l = open Namegen let compute_bl_goal ind lnamesparrec nparrec = - let eqI, eff = eqI ind lnamesparrec in + let eqI = eqI ind lnamesparrec in let list_id = list_id lnamesparrec in let avoid = List.fold_right (Nameops.Name.fold_right (fun id l -> Id.Set.add id l)) (List.map RelDecl.get_name lnamesparrec) Id.Set.empty in let create_input c = @@ -600,7 +616,7 @@ let compute_bl_goal ind lnamesparrec nparrec = (mkApp(eq (),[|bb ();mkApp(eqI,[|mkVar n;mkVar m|]);tt ()|])) Sorts.Relevant (mkApp(eq (),[|mkFullInd (ind,u) (nparrec+3);mkVar n;mkVar m|])) - ))), eff + ))) let compute_bl_tact mode bl_scheme_key ind lnamesparrec nparrec = let list_id = list_id lnamesparrec in @@ -690,16 +706,19 @@ let make_bl_scheme mode mind = let nparrec = mib.mind_nparams_rec in let lnonparrec,lnamesparrec = (* TODO subst *) context_chop (nparams-nparrec) mib.mind_params_ctxt in - let bl_goal, eff = compute_bl_goal ind lnamesparrec nparrec in + let bl_goal = compute_bl_goal ind lnamesparrec nparrec in let uctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in let side_eff = side_effect_of_mode mode in let bl_goal = EConstr.of_constr bl_goal in - let (ans, _, _, ctx) = Pfedit.build_by_tactic ~poly:false ~side_eff (Global.env()) ~uctx ~typ:bl_goal + let (ans, _, _, ctx) = Declare.build_by_tactic ~poly:false ~side_eff (Global.env()) ~uctx ~typ:bl_goal (compute_bl_tact mode (!bl_scheme_kind_aux()) (ind, EConstr.EInstance.empty) lnamesparrec nparrec) in - ([|ans|], ctx), eff + ([|ans|], ctx) -let bl_scheme_kind = declare_mutual_scheme_object "_dec_bl" make_bl_scheme +let bl_scheme_kind = + declare_mutual_scheme_object "_dec_bl" + ~deps:(fun ind -> [SchemeMutualDep (ind, beq_scheme_kind)]) + make_bl_scheme let _ = bl_scheme_kind_aux := fun () -> bl_scheme_kind @@ -710,7 +729,7 @@ let compute_lb_goal ind lnamesparrec nparrec = let list_id = list_id lnamesparrec in let eq = eq () and tt = tt () and bb = bb () in let avoid = List.fold_right (Nameops.Name.fold_right (fun id l -> Id.Set.add id l)) (List.map RelDecl.get_name lnamesparrec) Id.Set.empty in - let eqI, eff = eqI ind lnamesparrec in + let eqI = eqI ind lnamesparrec in let create_input c = let x = next_ident_away (Id.of_string "x") avoid and y = next_ident_away (Id.of_string "y") avoid in @@ -750,7 +769,7 @@ let compute_lb_goal ind lnamesparrec nparrec = (mkApp(eq,[|mkFullInd (ind,u) (nparrec+2);mkVar n;mkVar m|])) Sorts.Relevant (mkApp(eq,[|bb;mkApp(eqI,[|mkVar n;mkVar m|]);tt|])) - ))), eff + ))) let compute_lb_tact mode lb_scheme_key ind lnamesparrec nparrec = let list_id = list_id lnamesparrec in @@ -820,16 +839,19 @@ let make_lb_scheme mode mind = let nparrec = mib.mind_nparams_rec in let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in - let lb_goal, eff = compute_lb_goal ind lnamesparrec nparrec in + let lb_goal = compute_lb_goal ind lnamesparrec nparrec in let uctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in let side_eff = side_effect_of_mode mode in let lb_goal = EConstr.of_constr lb_goal in - let (ans, _, _, ctx) = Pfedit.build_by_tactic ~poly:false ~side_eff (Global.env()) ~uctx ~typ:lb_goal + let (ans, _, _, ctx) = Declare.build_by_tactic ~poly:false ~side_eff (Global.env()) ~uctx ~typ:lb_goal (compute_lb_tact mode (!lb_scheme_kind_aux()) ind lnamesparrec nparrec) in - ([|ans|], ctx), eff + ([|ans|], ctx) -let lb_scheme_kind = declare_mutual_scheme_object "_dec_lb" make_lb_scheme +let lb_scheme_kind = + declare_mutual_scheme_object "_dec_lb" + ~deps:(fun ind -> [SchemeMutualDep (ind, beq_scheme_kind)]) + make_lb_scheme let _ = lb_scheme_kind_aux := fun () -> lb_scheme_kind @@ -837,8 +859,8 @@ let _ = lb_scheme_kind_aux := fun () -> lb_scheme_kind (* Decidable equality *) let check_not_is_defined () = - try ignore (Coqlib.lib_ref "core.not.type") - with Not_found -> raise (UndefinedCst "not") + if not (Coqlib.has_ref "core.not.type") + then raise (UndefinedCst "not") (* {n=m}+{n<>m} part *) let compute_dec_goal ind lnamesparrec nparrec = @@ -904,7 +926,8 @@ let compute_dec_tact ind lnamesparrec nparrec = let eq = eq () and tt = tt () and ff = ff () and bb = bb () in let list_id = list_id lnamesparrec in - let eqI, eff = eqI ind lnamesparrec in + find_scheme beq_scheme_kind ind >>= fun _ -> + let eqI = eqI ind lnamesparrec in let avoid = ref [] in let eqtrue x = mkApp(eq,[|bb;x;tt|]) in let eqfalse x = mkApp(eq,[|bb;x;ff|]) in @@ -926,21 +949,11 @@ let compute_dec_tact ind lnamesparrec nparrec = let eqbnm = mkApp(eqI,[|mkVar freshn;mkVar freshm|]) in let arfresh = Array.of_list fresh_first_intros in let xargs = Array.sub arfresh 0 (2*nparrec) in - begin try - let c, eff = find_scheme bl_scheme_kind ind in - Proofview.tclUNIT (mkConst c,eff) with - Not_found -> - Tacticals.New.tclZEROMSG (str "Error during the decidability part, boolean to leibniz equality is required.") - end >>= fun (blI,eff') -> - begin try - let c, eff = find_scheme lb_scheme_kind ind in - Proofview.tclUNIT (mkConst c,eff) with - Not_found -> - Tacticals.New.tclZEROMSG (str "Error during the decidability part, leibniz to boolean equality is required.") - end >>= fun (lbI,eff'') -> - let eff = (Evd.concat_side_effects eff'' (Evd.concat_side_effects eff' eff)) in + find_scheme bl_scheme_kind ind >>= fun c -> + let blI = mkConst c in + find_scheme lb_scheme_kind ind >>= fun c -> + let lbI = mkConst c in Tacticals.New.tclTHENLIST [ - Proofview.tclEFFECTS eff; intros_using fresh_first_intros; intros_using [freshn;freshm]; (*we do this so we don't have to prove the same goal twice *) @@ -1001,11 +1014,11 @@ let make_eq_decidability mode mind = let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in let side_eff = side_effect_of_mode mode in - let (ans, _, _, ctx) = Pfedit.build_by_tactic ~poly:false ~side_eff (Global.env()) ~uctx + let (ans, _, _, ctx) = Declare.build_by_tactic ~poly:false ~side_eff (Global.env()) ~uctx ~typ:(EConstr.of_constr (compute_dec_goal (ind,u) lnamesparrec nparrec)) (compute_dec_tact ind lnamesparrec nparrec) in - ([|ans|], ctx), Evd.empty_side_effects + ([|ans|], ctx) let eq_dec_scheme_kind = declare_mutual_scheme_object "_eq_dec" make_eq_decidability diff --git a/vernac/canonical.ml b/vernac/canonical.ml index 390ed62bee..eaa6c84791 100644 --- a/vernac/canonical.ml +++ b/vernac/canonical.ml @@ -28,7 +28,7 @@ let discharge_canonical_structure (_,((gref, _ as x), local)) = let inCanonStruc : (GlobRef.t * inductive) * bool -> obj = declare_object {(default_object "CANONICAL-STRUCTURE") with - open_function = open_canonical_structure; + open_function = simple_open open_canonical_structure; cache_function = cache_canonical_structure; subst_function = (fun (subst,(c,local)) -> subst_canonical_structure subst c, local); classify_function = (fun x -> Substitute x); diff --git a/vernac/classes.ml b/vernac/classes.ml index dafd1cc5e4..eb735b7cdf 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -116,7 +116,7 @@ let instance_input : instance -> obj = { (default_object "type classes instances state") with cache_function = cache_instance; load_function = (fun _ x -> cache_instance x); - open_function = (fun _ x -> cache_instance x); + open_function = simple_open (fun _ x -> cache_instance x); classify_function = classify_instance; discharge_function = discharge_instance; rebuild_function = rebuild_instance; @@ -237,7 +237,7 @@ let class_input : typeclass -> obj = { (default_object "type classes state") with cache_function = cache_class; load_function = (fun _ -> cache_class); - open_function = (fun _ -> cache_class); + open_function = simple_open (fun _ -> cache_class); classify_function = (fun x -> Substitute x); discharge_function = (fun a -> Some (discharge_class a)); rebuild_function = rebuild_class; @@ -304,22 +304,19 @@ let id_of_class cl = mip.(0).Declarations.mind_typename | _ -> assert false -let instance_hook info global imps ?hook cst = - Impargs.maybe_declare_manual_implicits false cst imps; +let instance_hook info global ?hook cst = let info = intern_info info in let env = Global.env () in let sigma = Evd.from_env env in declare_instance env sigma (Some info) (not global) cst; (match hook with Some h -> h cst | None -> ()) -let declare_instance_constant info global imps ?hook name udecl poly sigma term termtype = +let declare_instance_constant info global impargs ?hook name udecl poly sigma term termtype = let kind = Decls.(IsDefinition Instance) in - let sigma, entry = DeclareDef.prepare_definition - ~allow_evars:false ~poly sigma ~udecl ~types:(Some termtype) ~body:term in - let kn = Declare.declare_constant ~name ~kind (Declare.DefinitionEntry entry) in - Declare.definition_message name; - DeclareUniv.declare_univ_binders (GlobRef.ConstRef kn) (Evd.universe_binders sigma); - instance_hook info global imps ?hook (GlobRef.ConstRef kn) + let scope = DeclareDef.Global Declare.ImportDefaultBehavior in + let kn = DeclareDef.declare_definition ~name ~kind ~scope ~impargs + ~opaque:false ~poly sigma ~udecl ~types:(Some termtype) ~body:term in + instance_hook info global ?hook kn let do_declare_instance sigma ~global ~poly k u ctx ctx' pri udecl impargs subst name = let subst = List.fold_left2 @@ -328,30 +325,31 @@ let do_declare_instance sigma ~global ~poly k u ctx ctx' pri udecl impargs subst in let (_, ty_constr) = instance_constructor (k,u) subst in let termtype = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in - let sigma, entry = DeclareDef.prepare_parameter ~allow_evars:false ~poly sigma ~udecl ~types:termtype in + let sigma, entry = DeclareDef.prepare_parameter ~poly sigma ~udecl ~types:termtype in let cst = Declare.declare_constant ~name ~kind:Decls.(IsAssumption Logical) (Declare.ParameterEntry entry) in DeclareUniv.declare_univ_binders (GlobRef.ConstRef cst) (Evd.universe_binders sigma); - instance_hook pri global impargs (GlobRef.ConstRef cst) + let cst = (GlobRef.ConstRef cst) in + Impargs.maybe_declare_manual_implicits false cst impargs; + instance_hook pri global cst -let declare_instance_program env sigma ~global ~poly name pri imps udecl term termtype = +let declare_instance_program env sigma ~global ~poly name pri impargs udecl term termtype = let hook { DeclareDef.Hook.S.scope; dref; _ } = let cst = match dref with GlobRef.ConstRef kn -> kn | _ -> assert false in - Impargs.declare_manual_implicits false dref imps; let pri = intern_info pri in let env = Global.env () in let sigma = Evd.from_env env in declare_instance env sigma (Some pri) (not global) (GlobRef.ConstRef cst) in - let obls, _, term, typ = Obligations.eterm_obligations env name sigma 0 term termtype in + let obls, _, term, typ = RetrieveObl.retrieve_obligations env name sigma 0 term termtype in let hook = DeclareDef.Hook.make hook in let uctx = Evd.evar_universe_context sigma in let scope, kind = DeclareDef.Global Declare.ImportDefaultBehavior, Decls.Instance in let _ : DeclareObl.progress = - Obligations.add_definition ~name ~term ~udecl ~scope ~poly ~kind ~hook typ ~uctx obls + Obligations.add_definition ~name ~term ~udecl ~scope ~poly ~kind ~hook ~impargs ~uctx typ obls in () -let declare_instance_open sigma ?hook ~tac ~global ~poly id pri imps udecl ids term termtype = +let declare_instance_open sigma ?hook ~tac ~global ~poly id pri impargs udecl ids term termtype = (* spiwack: it is hard to reorder the actions to do the pretyping after the proof has opened. As a consequence, we use the low-level primitives to code @@ -359,12 +357,12 @@ let declare_instance_open sigma ?hook ~tac ~global ~poly id pri imps udecl ids t let gls = List.rev (Evd.future_goals sigma) in let sigma = Evd.reset_future_goals sigma in let kind = Decls.(IsDefinition Instance) in - let hook = DeclareDef.Hook.(make (fun { S.dref ; _ } -> instance_hook pri global imps ?hook dref)) in + let hook = DeclareDef.Hook.(make (fun { S.dref ; _ } -> instance_hook pri global ?hook dref)) in let info = Lemmas.Info.make ~hook ~kind () in (* XXX: We need to normalize the type, otherwise Admitted / Qed will fails! This is due to a bug in proof_global :( *) let termtype = Evarutil.nf_evar sigma termtype in - let lemma = Lemmas.start_lemma ~name:id ~poly ~udecl ~info sigma termtype in + let lemma = Lemmas.start_lemma ~name:id ~poly ~udecl ~info ~impargs sigma termtype in (* spiwack: I don't know what to do with the status here. *) let lemma = match term with @@ -487,10 +485,8 @@ let do_instance env env' sigma ?hook ~global ~poly cty k u ctx ctx' pri decl imp interp_props ~program_mode:false env' cty k u ctx ctx' subst sigma props in let termtype, sigma = do_instance_resolve_TC termtype sigma env in - if Evd.has_undefined sigma then - CErrors.user_err Pp.(str "Unsolved obligations remaining.") - else - declare_instance_constant pri global imps ?hook id decl poly sigma term termtype + Pretyping.check_evars_are_solved ~program_mode:false env sigma; + declare_instance_constant pri global imps ?hook id decl poly sigma term termtype let do_instance_program env env' sigma ?hook ~global ~poly cty k u ctx ctx' pri decl imps subst id opt_props = let term, termtype, sigma = @@ -516,7 +512,8 @@ let interp_instance_context ~program_mode env ctx ~generalize pl tclass = else tclass in let sigma, (impls, ((env', ctx), imps)) = interp_context_evars ~program_mode env sigma ctx in - let sigma, (c', imps') = interp_type_evars_impls ~program_mode ~impls env' sigma tclass in + let flags = Pretyping.{ all_no_fail_flags with program_mode } in + let sigma, (c', imps') = interp_type_evars_impls ~flags ~impls env' sigma tclass in let imps = imps @ imps' in let ctx', c = decompose_prod_assum sigma c' in let ctx'' = ctx' @ ctx in diff --git a/vernac/classes.mli b/vernac/classes.mli index 9698c14452..f410cddfef 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -22,7 +22,7 @@ val declare_instance : ?warn:bool -> env -> Evd.evar_map -> Does nothing — or emit a “not-a-class” warning if the [warn] argument is set — when said type is not a registered type class. *) -val existing_instance : bool -> qualid -> Hints.hint_info_expr option -> unit +val existing_instance : bool -> qualid -> ComHints.hint_info_expr option -> unit (** globality, reference, optional priority and pattern information *) val new_instance_interactive @@ -34,7 +34,7 @@ val new_instance_interactive -> ?generalize:bool -> ?tac:unit Proofview.tactic -> ?hook:(GlobRef.t -> unit) - -> Hints.hint_info_expr + -> ComHints.hint_info_expr -> (bool * constr_expr) option -> Id.t * Lemmas.t @@ -47,7 +47,7 @@ val new_instance -> (bool * constr_expr) -> ?generalize:bool -> ?hook:(GlobRef.t -> unit) - -> Hints.hint_info_expr + -> ComHints.hint_info_expr -> Id.t val new_instance_program @@ -59,7 +59,7 @@ val new_instance_program -> (bool * constr_expr) option -> ?generalize:bool -> ?hook:(GlobRef.t -> unit) - -> Hints.hint_info_expr + -> ComHints.hint_info_expr -> Id.t val declare_new_instance @@ -69,7 +69,7 @@ val declare_new_instance -> ident_decl -> local_binder_expr list -> constr_expr - -> Hints.hint_info_expr + -> ComHints.hint_info_expr -> unit (** {6 Low level interface used by Add Morphism, do not use } *) diff --git a/vernac/comArguments.ml b/vernac/comArguments.ml index 90791a0906..360e228bfc 100644 --- a/vernac/comArguments.ml +++ b/vernac/comArguments.ml @@ -52,10 +52,10 @@ let warn_arguments_assert = CWarnings.create ~name:"arguments-assert" ~category:"vernacular" Pp.(fun sr -> strbrk "This command is just asserting the names of arguments of " ++ - Printer.pr_global sr ++ strbrk". If this is what you want add " ++ + Printer.pr_global sr ++ strbrk". If this is what you want, add " ++ strbrk "': assert' to silence the warning. If you want " ++ - strbrk "to clear implicit arguments add ': clear implicits'. " ++ - strbrk "If you want to clear notation scopes add ': clear scopes'") + strbrk "to clear implicit arguments, add ': clear implicits'. " ++ + strbrk "If you want to clear notation scopes, add ': clear scopes'") (* [nargs_for_red] is the number of arguments required to trigger reduction, [args] is the main list of arguments statuses, diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index dc9c8e2d3c..776ffd6b9f 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -70,7 +70,8 @@ let declare_axiom is_coe ~poly ~local ~kind typ (univs, pl) imps nl {CAst.v=name (gr,inst) let interp_assumption ~program_mode sigma env impls c = - let sigma, (ty, impls) = interp_type_evars_impls ~program_mode env sigma ~impls c in + let flags = { Pretyping.all_no_fail_flags with program_mode } in + let sigma, (ty, impls) = interp_type_evars_impls ~flags env sigma ~impls c in sigma, (ty, impls) (* When monomorphic the universe constraints and universe names are @@ -90,7 +91,7 @@ let declare_assumptions ~poly ~scope ~kind univs nl l = let () = match scope with | Discharge -> (* declare universes separately for variables *) - Declare.declare_universe_context ~poly (context_set_of_entry (fst univs)) + DeclareUctx.declare_universe_context ~poly (context_set_of_entry (fst univs)) | Global _ -> () in let _, _ = List.fold_left (fun (subst,univs) ((is_coe,idl),typ,imps) -> @@ -160,7 +161,7 @@ let do_assumptions ~program_mode ~poly ~scope ~kind nl l = let env = EConstr.push_named_context (List.map (fun {CAst.v=id} -> LocalAssum (make_annot id r,t)) idl) env in let ienv = List.fold_right (fun {CAst.v=id} ienv -> - let impls = compute_internalization_data env sigma Variable t imps in + let impls = compute_internalization_data env sigma id Variable t imps in Id.Map.add id impls ienv) idl ienv in ((sigma,env,ienv),((is_coe,idl),t,imps))) (sigma,env,empty_internalization_env) l @@ -190,7 +191,7 @@ let context_subst subst (name,b,t,impl) = let context_insection sigma ~poly ctx = let uctx = Evd.universe_context_set sigma in - let () = Declare.declare_universe_context ~poly uctx in + let () = DeclareUctx.declare_universe_context ~poly uctx in let fn subst (name,_,_,_ as d) = let d = context_subst subst d in let () = match d with @@ -203,8 +204,12 @@ let context_insection sigma ~poly ctx = else Monomorphic_entry Univ.ContextSet.empty in let entry = Declare.definition_entry ~univs ~types:t b in - let _ : GlobRef.t = DeclareDef.declare_definition ~name ~scope:DeclareDef.Discharge - ~kind:Decls.(IsDefinition Definition) ~ubind:UnivNames.empty_binders ~impargs:[] entry + (* XXX Fixme: Use DeclareDef.prepare_definition *) + let uctx = Evd.evar_universe_context sigma in + let kind = Decls.(IsDefinition Definition) in + let _ : GlobRef.t = + DeclareDef.declare_entry ~name ~scope:DeclareDef.Discharge + ~kind ~impargs:[] ~uctx entry in () in @@ -221,7 +226,7 @@ let context_nosection sigma ~poly ctx = (* Multiple monomorphic axioms: declare universes separately to avoid redeclaring them. *) let uctx = Evd.universe_context_set sigma in - let () = Declare.declare_universe_context ~poly uctx in + let () = DeclareUctx.declare_universe_context ~poly uctx in Monomorphic_entry Univ.ContextSet.empty in let fn subst d = diff --git a/vernac/comCoercion.ml b/vernac/comCoercion.ml index c339c53a9b..4a8e217fc1 100644 --- a/vernac/comCoercion.ml +++ b/vernac/comCoercion.ml @@ -256,7 +256,7 @@ let classify_coercion obj = let inCoercion : coercion -> obj = declare_object {(default_object "COERCION") with - open_function = open_coercion; + open_function = simple_open open_coercion; cache_function = cache_coercion; subst_function = (fun (subst,c) -> subst_coercion subst c); classify_function = classify_coercion; diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index ba2c1ac115..66d5a4f7f5 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -12,7 +12,6 @@ open Pp open Util open Redexpr open Constrintern -open Pretyping (* Commands of the interface: Constant definitions *) @@ -40,15 +39,56 @@ let check_imps ~impsty ~impsbody = | [], [] -> () in aux impsty impsbody +let protect_pattern_in_binder bl c ctypopt = + (* We turn "Definition d binders := body : typ" into *) + (* "Definition d := fun binders => body:type" *) + (* This is a hack while waiting for LocalPattern in regular environments *) + if List.exists (function Constrexpr.CLocalPattern _ -> true | _ -> false) bl + then + let t = match ctypopt with + | None -> CAst.make ?loc:c.CAst.loc (Constrexpr.CHole (None,Namegen.IntroAnonymous,None)) + | Some t -> t in + let loc = Loc.merge_opt c.CAst.loc t.CAst.loc in + let c = CAst.make ?loc @@ Constrexpr.CCast (c, Glob_term.CastConv t) in + let loc = match List.hd bl with + | Constrexpr.CLocalAssum (a::_,_,_) | Constrexpr.CLocalDef (a,_,_) -> a.CAst.loc + | Constrexpr.CLocalPattern {CAst.loc} -> loc + | Constrexpr.CLocalAssum ([],_,_) -> assert false in + let apply_under_binders f env evd c = + let rec aux env evd c = + let open Constr in + let open EConstr in + let open Context.Rel.Declaration in + match kind evd c with + | Lambda (x,t,c) -> + let evd,c = aux (push_rel (LocalAssum (x,t)) env) evd c in + evd, mkLambda (x,t,c) + | LetIn (x,b,t,c) -> + let evd,c = aux (push_rel (LocalDef (x,b,t)) env) evd c in + evd, mkLetIn (x,t,b,c) + | Case (ci,p,a,bl) -> + let evd,bl = Array.fold_left_map (aux env) evd bl in + evd, mkCase (ci,p,a,bl) + | Cast (c,_,_) -> f env evd c (* we remove the cast we had set *) + (* This last case may happen when reaching the proof of an + impossible case, as when pattern-matching on a vector of length 1 *) + | _ -> (evd,c) in + aux env evd c in + ([], Constrexpr_ops.mkLambdaCN ?loc:(Loc.merge_opt loc c.CAst.loc) bl c, None, apply_under_binders) + else + (bl, c, ctypopt, fun f env evd c -> f env evd c) + let interp_definition ~program_mode pl bl ~poly red_option c ctypopt = + let flags = Pretyping.{ all_no_fail_flags with program_mode } in let env = Global.env() in (* Explicitly bound universes and constraints *) let evd, udecl = Constrexpr_ops.interp_univ_decl_opt env pl in + let (bl, c, ctypopt, apply_under_binders) = protect_pattern_in_binder bl c ctypopt in (* Build the parameters *) let evd, (impls, ((env_bl, ctx), imps1)) = interp_context_evars ~program_mode env evd bl in (* Build the type *) let evd, tyopt = Option.fold_left_map - (interp_type_evars_impls ~program_mode ~impls env_bl) + (interp_type_evars_impls ~flags ~impls env_bl) evd ctypopt in (* Build the body, and merge implicits from parameters and from type/body *) @@ -63,46 +103,31 @@ let interp_definition ~program_mode pl bl ~poly red_option c ctypopt = evd, c, imps1@impsty, Some ty in (* Do the reduction *) - let evd, c = red_constant_body red_option env_bl evd c in + let evd, c = apply_under_binders (red_constant_body red_option) env_bl evd c in (* Declare the definition *) let c = EConstr.it_mkLambda_or_LetIn c ctx in let tyopt = Option.map (fun ty -> EConstr.it_mkProd_or_LetIn ty ctx) tyopt in + (c, tyopt), evd, udecl, imps - let evd, ce = DeclareDef.prepare_definition ~allow_evars:program_mode - ~opaque:false ~poly evd ~udecl ~types:tyopt ~body:c in - - (ce, evd, udecl, imps) - -let check_definition ~program_mode (ce, evd, _, imps) = - let env = Global.env () in - check_evars_are_solved ~program_mode env evd; - ce +let do_definition ?hook ~name ~scope ~poly ~kind udecl bl red_option c ctypopt = + let program_mode = false in + let (body, types), evd, udecl, impargs = + interp_definition ~program_mode udecl bl ~poly red_option c ctypopt + in + let kind = Decls.IsDefinition kind in + let _ : Names.GlobRef.t = + DeclareDef.declare_definition ~name ~scope ~kind ?hook ~impargs + ~opaque:false ~poly evd ~udecl ~types ~body + in () -let do_definition ~program_mode ?hook ~name ~scope ~poly ~kind udecl bl red_option c ctypopt = - let (ce, evd, udecl, impargs as def) = +let do_definition_program ?hook ~name ~scope ~poly ~kind udecl bl red_option c ctypopt = + let program_mode = true in + let (body, types), evd, udecl, impargs = interp_definition ~program_mode udecl bl ~poly red_option c ctypopt in - if program_mode then - let env = Global.env () in - let (c,ctx), sideff = Future.force ce.Declare.proof_entry_body in - assert(Safe_typing.empty_private_constants = sideff.Evd.seff_private); - assert(Univ.ContextSet.is_empty ctx); - Obligations.check_evars env evd; - let c = EConstr.of_constr c in - let typ = match ce.Declare.proof_entry_type with - | Some t -> EConstr.of_constr t - | None -> Retyping.get_type_of env evd c - in - let obls, _, c, cty = - Obligations.eterm_obligations env name evd 0 c typ - in - let uctx = Evd.evar_universe_context evd in - ignore(Obligations.add_definition - ~name ~term:c cty ~uctx ~udecl ~impargs ~scope ~poly ~kind ?hook obls) - else - let ce = check_definition ~program_mode def in - let uctx = Evd.evar_universe_context evd in - let hook_data = Option.map (fun hook -> hook, uctx, []) hook in - let kind = Decls.IsDefinition kind in - ignore(DeclareDef.declare_definition ~name ~scope ~kind ?hook_data ~ubind:(Evd.universe_binders evd) ce ~impargs) + let term, ty, uctx, obls = DeclareDef.prepare_obligation ~name ~poly ~body ~types ~udecl evd in + let _ : DeclareObl.progress = + Obligations.add_definition + ~name ~term ty ~uctx ~udecl ~impargs ~scope ~poly ~kind ?hook obls + in () diff --git a/vernac/comDefinition.mli b/vernac/comDefinition.mli index 6c6da8952e..337da22018 100644 --- a/vernac/comDefinition.mli +++ b/vernac/comDefinition.mli @@ -15,8 +15,7 @@ open Constrexpr (** {6 Definitions/Let} *) val do_definition - : program_mode:bool - -> ?hook:DeclareDef.Hook.t + : ?hook:DeclareDef.Hook.t -> name:Id.t -> scope:DeclareDef.locality -> poly:bool @@ -28,18 +27,15 @@ val do_definition -> constr_expr option -> unit -(************************************************************************) -(** Internal API *) -(************************************************************************) - -(** Not used anywhere. *) -val interp_definition - : program_mode:bool +val do_definition_program + : ?hook:DeclareDef.Hook.t + -> name:Id.t + -> scope:DeclareDef.locality + -> poly:bool + -> kind:Decls.definition_object_kind -> universe_decl_expr option -> local_binder_expr list - -> poly:bool -> red_expr option -> constr_expr -> constr_expr option - -> Evd.side_effects Declare.proof_entry * - Evd.evar_map * UState.universe_decl * Impargs.manual_implicits + -> unit diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index 6580495295..e4fa212a23 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -107,7 +107,8 @@ let interp_fix_context ~program_mode ~cofix env sigma fix = sigma, ((env'', ctx' @ ctx), (impl_env',imps @ imps'), annot) let interp_fix_ccl ~program_mode sigma impls (env,_) fix = - let sigma, (c, impl) = interp_type_evars_impls ~program_mode ~impls env sigma fix.Vernacexpr.rtype in + let flags = Pretyping.{ all_no_fail_flags with program_mode } in + let sigma, (c, impl) = interp_type_evars_impls ~flags ~impls env sigma fix.Vernacexpr.rtype in let r = Retyping.relevance_of_type env sigma c in sigma, (c, r, impl) @@ -140,8 +141,8 @@ let compute_possible_guardness_evidences (ctx,_,recindex) = fixpoints ?) *) List.interval 0 (Context.Rel.nhyps ctx - 1) -type recursive_preentry = - Id.t list * Sorts.relevance list * Constr.t option list * Constr.types list +type ('constr, 'types) recursive_preentry = + Id.t list * Sorts.relevance list * 'constr option list * 'types list (* Wellfounded definition *) @@ -230,7 +231,11 @@ let ground_fixpoint env evd (fixnames,fixrs,fixdefs,fixtypes) = let fixtypes = List.map EConstr.(to_constr evd) fixtypes in Evd.evar_universe_context evd, (fixnames,fixrs,fixdefs,fixtypes) -let interp_fixpoint ~cofix l = +(* XXX: Unify with interp_recursive *) +let interp_fixpoint ~cofix l : + ( (Constr.t, Constr.types) recursive_preentry * + UState.universe_decl * UState.t * + (EConstr.rel_context * Impargs.manual_implicits * int option) list) = let (env,_,pl,evd),fix,info = interp_recursive ~program_mode:false ~cofix l in check_recursive true env evd fix; let uctx,fix = ground_fixpoint env evd fix in @@ -243,8 +248,10 @@ let build_recthms ~indexes fixnames fixtypes fiximps = in let thms = List.map3 (fun name typ (ctx,impargs,_) -> - { DeclareDef.Recthm.name; typ - ; args = List.map Context.Rel.Declaration.get_name ctx; impargs}) + { DeclareDef.Recthm.name + ; typ + ; args = List.map Context.Rel.Declaration.get_name ctx + ; impargs}) fixnames fixtypes fiximps in fix_kind, cofix, thms diff --git a/vernac/comFixpoint.mli b/vernac/comFixpoint.mli index 2ad6c03bae..a19b96f0f3 100644 --- a/vernac/comFixpoint.mli +++ b/vernac/comFixpoint.mli @@ -9,7 +9,6 @@ (************************************************************************) open Names -open Constr open Vernacexpr (** {6 Fixpoints and cofixpoints} *) @@ -40,6 +39,9 @@ val adjust_rec_order -> Constrexpr.recursion_order_expr option -> lident option +(** names / relevance / defs / types *) +type ('constr, 'types) recursive_preentry = Id.t list * Sorts.relevance list * 'constr option list * 'types list + (** Exported for Program *) val interp_recursive : (* Misc arguments *) @@ -49,18 +51,17 @@ val interp_recursive : (* env / signature / univs / evar_map *) (Environ.env * EConstr.named_context * UState.universe_decl * Evd.evar_map) * (* names / defs / types *) - (Id.t list * Sorts.relevance list * EConstr.constr option list * EConstr.types list) * + (EConstr.t, EConstr.types) recursive_preentry * (* ctx per mutual def / implicits / struct annotations *) (EConstr.rel_context * Impargs.manual_implicits * int option) list (** Exported for Funind *) -type recursive_preentry = Id.t list * Sorts.relevance list * constr option list * types list - val interp_fixpoint : cofix:bool -> lident option fix_expr_gen list - -> recursive_preentry * UState.universe_decl * UState.t * + -> (Constr.t, Constr.types) recursive_preentry * + UState.universe_decl * UState.t * (EConstr.rel_context * Impargs.manual_implicits * int option) list (** Very private function, do not use *) diff --git a/vernac/comHints.ml b/vernac/comHints.ml new file mode 100644 index 0000000000..5a48e9c16c --- /dev/null +++ b/vernac/comHints.ml @@ -0,0 +1,174 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \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 + +(** (Partial) implementation of the [Hint] command; some more + functionality still lives in tactics/hints.ml *) + +type hint_info_expr = Constrexpr.constr_pattern_expr Typeclasses.hint_info_gen + +type reference_or_constr = + | HintsReference of Libnames.qualid + | HintsConstr of Constrexpr.constr_expr + +type hints_expr = + | HintsResolve of (hint_info_expr * bool * reference_or_constr) list + | HintsResolveIFF of bool * Libnames.qualid list * int option + | HintsImmediate of reference_or_constr list + | HintsUnfold of Libnames.qualid list + | HintsTransparency of Libnames.qualid Hints.hints_transparency_target * bool + | HintsMode of Libnames.qualid * Hints.hint_mode list + | HintsConstructors of Libnames.qualid list + | HintsExtern of + int * Constrexpr.constr_expr option * Genarg.raw_generic_argument + +let project_hint ~poly pri l2r r = + let open EConstr in + let open Coqlib in + let gr = Smartlocate.global_with_alias r in + let env = Global.env () in + let sigma = Evd.from_env env in + let sigma, c = Evd.fresh_global env sigma gr in + let t = Retyping.get_type_of env sigma c in + let t = + Tacred.reduce_to_quantified_ref env sigma (lib_ref "core.iff.type") t + in + let sign, ccl = decompose_prod_assum sigma t in + let a, b = + match snd (decompose_app sigma ccl) with + | [a; b] -> (a, b) + | _ -> assert false + in + let p = if l2r then lib_ref "core.iff.proj1" else lib_ref "core.iff.proj2" in + let sigma, p = Evd.fresh_global env sigma p in + let c = + Reductionops.whd_beta sigma + (mkApp (c, Context.Rel.to_extended_vect mkRel 0 sign)) + in + let c = + it_mkLambda_or_LetIn + (mkApp + ( p + , [| mkArrow a Sorts.Relevant (Vars.lift 1 b) + ; mkArrow b Sorts.Relevant (Vars.lift 1 a) + ; c |] )) + sign + in + let name = + Nameops.add_suffix + (Nametab.basename_of_global gr) + ("_proj_" ^ if l2r then "l2r" else "r2l") + in + let ctx = Evd.univ_entry ~poly sigma in + let c = EConstr.to_constr sigma c in + let cb = + Declare.(DefinitionEntry (definition_entry ~univs:ctx ~opaque:false c)) + in + let c = + Declare.declare_constant ~local:Declare.ImportDefaultBehavior ~name + ~kind:Decls.(IsDefinition Definition) + cb + in + let info = {Typeclasses.hint_priority = pri; hint_pattern = None} in + (info, false, true, Hints.PathAny, Hints.IsGlobRef (Names.GlobRef.ConstRef c)) + +let warn_deprecated_hint_constr = + CWarnings.create ~name:"deprecated-hint-constr" ~category:"deprecated" + (fun () -> + Pp.strbrk + "Declaring arbitrary terms as hints is deprecated; declare a global \ + reference instead") + +let interp_hints ~poly h = + let env = Global.env () in + let sigma = Evd.from_env env in + let f poly c = + let evd, c = Constrintern.interp_open_constr env sigma c in + let env = Global.env () in + let sigma = Evd.from_env env in + let c, diff = Hints.prepare_hint true env sigma (evd, c) in + if poly then (Hints.IsConstr (c, diff) [@ocaml.warning "-3"]) + else + let () = DeclareUctx.declare_universe_context ~poly:false diff in + (Hints.IsConstr (c, Univ.ContextSet.empty) [@ocaml.warning "-3"]) + in + let fref r = + let gr = Smartlocate.global_with_alias r in + Dumpglob.add_glob ?loc:r.CAst.loc gr; + gr + in + let fr r = Tacred.evaluable_of_global_reference env (fref r) in + let fi c = + let open Hints in + match c with + | HintsReference c -> + let gr = Smartlocate.global_with_alias c in + (PathHints [gr], poly, IsGlobRef gr) + | HintsConstr c -> + let () = warn_deprecated_hint_constr () in + (PathAny, poly, f poly c) + in + let fp = Constrintern.intern_constr_pattern env sigma in + let fres (info, b, r) = + let path, poly, gr = fi r in + let info = + { info with + Typeclasses.hint_pattern = Option.map fp info.Typeclasses.hint_pattern + } + in + (info, poly, b, path, gr) + in + let ft = + let open Hints in + function + | HintsVariables -> HintsVariables + | HintsConstants -> HintsConstants + | HintsReferences lhints -> HintsReferences (List.map fr lhints) + in + let fp = Constrintern.intern_constr_pattern (Global.env ()) in + let open Hints in + match h with + | HintsResolve lhints -> HintsResolveEntry (List.map fres lhints) + | HintsResolveIFF (l2r, lc, n) -> + HintsResolveEntry (List.map (project_hint ~poly n l2r) lc) + | HintsImmediate lhints -> HintsImmediateEntry (List.map fi lhints) + | HintsUnfold lhints -> HintsUnfoldEntry (List.map fr lhints) + | HintsTransparency (t, b) -> HintsTransparencyEntry (ft t, b) + | HintsMode (r, l) -> HintsModeEntry (fref r, l) + | HintsConstructors lqid -> + let constr_hints_of_ind qid = + let ind = Smartlocate.global_inductive_with_alias qid in + let mib, _ = Global.lookup_inductive ind in + Dumpglob.dump_reference ?loc:qid.CAst.loc "<>" + (Libnames.string_of_qualid qid) + "ind"; + List.init (Inductiveops.nconstructors env ind) (fun i -> + let c = (ind, i + 1) in + let gr = Names.GlobRef.ConstructRef c in + ( empty_hint_info + , Declareops.inductive_is_polymorphic mib + , true + , PathHints [gr] + , IsGlobRef gr )) + in + HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid)) + | HintsExtern (pri, patcom, tacexp) -> + let pat = Option.map (fp sigma) patcom in + let l = match pat with None -> [] | Some (l, _) -> l in + let ltacvars = + List.fold_left + (fun accu x -> Names.Id.Set.add x accu) + Names.Id.Set.empty l + in + let env = Genintern.{(empty_glob_sign env) with ltacvars} in + let _, tacexp = Genintern.generic_intern env tacexp in + HintsExternEntry + ({Typeclasses.hint_priority = Some pri; hint_pattern = pat}, tacexp) diff --git a/vernac/comHints.mli b/vernac/comHints.mli new file mode 100644 index 0000000000..77fbef5387 --- /dev/null +++ b/vernac/comHints.mli @@ -0,0 +1,29 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \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 Typeclasses + +type hint_info_expr = Constrexpr.constr_pattern_expr hint_info_gen + +type reference_or_constr = + | HintsReference of Libnames.qualid + | HintsConstr of Constrexpr.constr_expr + +type hints_expr = + | HintsResolve of (hint_info_expr * bool * reference_or_constr) list + | HintsResolveIFF of bool * Libnames.qualid list * int option + | HintsImmediate of reference_or_constr list + | HintsUnfold of Libnames.qualid list + | HintsTransparency of Libnames.qualid Hints.hints_transparency_target * bool + | HintsMode of Libnames.qualid * Hints.hint_mode list + | HintsConstructors of Libnames.qualid list + | HintsExtern of int * Constrexpr.constr_expr option * Genarg.raw_generic_argument + +val interp_hints : poly:bool -> hints_expr -> Hints.hints_entry diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index 1f1700b4d6..cc9b840bed 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -20,7 +20,6 @@ open Nameops open Constrexpr open Constrexpr_ops open Constrintern -open Reductionops open Type_errors open Pretyping open Context.Rel.Declaration @@ -51,20 +50,6 @@ let should_auto_template = 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) - | CLetIn (na,b,t,c) -> CLetIn (na,b,t,complete_conclusion a cs c) - | CHole (k, _, _) -> - let (has_no_args,name,params) = a in - if not has_no_args then - user_err ?loc - (strbrk"Cannot infer the non constant arguments of the conclusion of " - ++ Id.print cs ++ str "."); - let args = List.map (fun id -> CAst.(make ?loc @@ CRef(qualid_of_ident ?loc id,None))) params in - CAppExpl ((None,qualid_of_ident ?loc name,None),List.rev args) - | c -> c - ) - let push_types env idl rl tl = List.fold_left3 (fun env id r t -> EConstr.push_rel (LocalAssum (make_annot (Name id) r,t)) env) env idl rl tl @@ -93,10 +78,6 @@ let check_all_names_different indl = | [] -> () | _ -> raise (InductiveError (SameNamesOverlap l)) -let mk_mltype_data sigma env assums arity indname = - let is_ml_type = is_sort env sigma arity in - (is_ml_type,indname,assums) - (** Make the arity conclusion flexible to avoid generating an upper bound universe now, only if the universe does not appear anywhere else. This is really a hack to stay compatible with the semantics of template polymorphic @@ -145,16 +126,50 @@ let pretype_ind_arity env sigma (loc, c, impls, pseudo_poly) = in sigma, (t, Retyping.relevance_of_sort s, concl, impls) -let interp_cstrs env sigma impls mldata arity ind = +(* ind_rel is the Rel for this inductive in the context without params. + n is how many arguments there are in the constructor. *) +let model_conclusion env sigma ind_rel params n arity_indices = + let model_head = EConstr.mkRel (n + Context.Rel.length params + ind_rel) in + let model_params = Context.Rel.to_extended_vect EConstr.mkRel n params in + let sigma,model_indices = + List.fold_right + (fun (_,t) (sigma, subst) -> + let t = EConstr.Vars.substl subst (EConstr.Vars.liftn n (List.length subst + 1) (EConstr.Vars.liftn 1 (List.length params + List.length subst + 1) t)) in + let sigma, c = Evarutil.new_evar env sigma t in + sigma, c::subst) + arity_indices (sigma, []) in + sigma, EConstr.mkApp (EConstr.mkApp (model_head, model_params), Array.of_list (List.rev model_indices)) + +let interp_cstrs env (sigma, ind_rel) impls params ind arity = let cnames,ctyps = List.split ind.ind_lc in - (* Complete conclusions of constructor types if given in ML-style syntax *) - let ctyps' = List.map2 (complete_conclusion mldata) cnames ctyps in + let arity_indices, cstr_sort = Reductionops.splay_arity env sigma arity in (* Interpret the constructor types *) - let sigma, (ctyps'', cimpls) = + let interp_cstr sigma ctyp = + let flags = + Pretyping.{ all_no_fail_flags with + use_typeclasses = UseTCForConv; + solve_unification_constraints = false } + in + let sigma, (ctyp, cimpl) = interp_type_evars_impls ~flags env sigma ~impls ctyp in + let ctx, concl = Reductionops.splay_prod_assum env sigma ctyp in + let concl_env = EConstr.push_rel_context ctx env in + let sigma_with_model_evars, model = + model_conclusion concl_env sigma ind_rel params (Context.Rel.length ctx) arity_indices + in + (* unify the expected with the provided conclusion *) + let sigma = + try Evarconv.unify concl_env sigma_with_model_evars Reduction.CONV concl model + with Evarconv.UnableToUnify (sigma,e) -> + user_err (Himsg.explain_pretype_error concl_env sigma + (Pretype_errors.CannotUnify (concl, model, (Some e)))) + in + sigma, (ctyp, cimpl) + in + let sigma, (ctyps, cimpls) = on_snd List.split @@ - List.fold_left_map (fun sigma l -> - interp_type_evars_impls ~program_mode:false env sigma ~impls l) sigma ctyps' in - sigma, (cnames, ctyps'', cimpls) + List.fold_left_map interp_cstr sigma ctyps + in + (sigma, pred ind_rel), (cnames, ctyps, cimpls) let sign_level env evd sign = fst (List.fold_right @@ -427,6 +442,30 @@ let interp_params env udecl uparamsl paramsl = sigma, env_params, (ctx_params, env_uparams, ctx_uparams, List.map (RelDecl.get_name %> Name.get_id) assums, userimpls, useruimpls, impls, udecl) +(* When a hole remains for a param, pretend the param is uniform and + do the unification. + [env_ar_par] is [uparams; inds; params] + *) +let maybe_unify_params_in env_ar_par sigma ~ninds ~nparams c = + let is_ind sigma k c = match EConstr.kind sigma c with + | Constr.Rel n -> + (* env is [uparams; inds; params; k other things] *) + n > k + nparams && n <= k + nparams + ninds + | _ -> false + in + let rec aux (env,k as envk) sigma c = match EConstr.kind sigma c with + | Constr.App (h,args) when is_ind sigma k h -> + Array.fold_left_i (fun i sigma arg -> + if i >= nparams || not (EConstr.isEvar sigma arg) then sigma + else Evarconv.unify_delay env sigma arg (EConstr.mkRel (k+nparams-i))) + sigma args + | _ -> Termops.fold_constr_with_full_binders + sigma + (fun d (env,k) -> EConstr.push_rel d env, k+1) + aux envk sigma c + in + aux (env_ar_par,0) sigma c + let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) notations ~cumulative ~poly ~private_ind finite = check_all_names_different indl; List.iter check_param paramsl; @@ -464,20 +503,31 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not (* Compute interpretation metadatas *) let indimpls = List.map (fun impls -> userimpls @ impls) indimpls in - let impls = compute_internalization_env env_uparams sigma ~impls (Inductive (params,true)) indnames fullarities indimpls in - let ntn_impls = compute_internalization_env env_uparams sigma (Inductive (params,true)) indnames fullarities indimpls in - let mldatas = List.map2 (mk_mltype_data sigma env_params params) arities indnames in + let impls = compute_internalization_env env_uparams sigma ~impls Inductive indnames fullarities indimpls in + let ntn_impls = compute_internalization_env env_uparams sigma Inductive indnames fullarities indimpls in - let sigma, constructors = + let ninds = List.length indl in + let (sigma, _), constructors = Metasyntax.with_syntax_protection (fun () -> - (* Temporary declaration of notations and scopes *) - List.iter (Metasyntax.set_notation_for_interpretation env_params ntn_impls) notations; - (* Interpret the constructor types *) - List.fold_left3_map (fun sigma -> interp_cstrs env_ar_params sigma impls) sigma mldatas arities indl) - () in + (* Temporary declaration of notations and scopes *) + List.iter (Metasyntax.set_notation_for_interpretation env_params ntn_impls) notations; + (* Interpret the constructor types *) + List.fold_left2_map + (fun (sigma, ind_rel) -> interp_cstrs env_ar_params (sigma, ind_rel) impls ctx_params) + (sigma, ninds) indl arities) + () + in - (* generalize over the uniform parameters *) let nparams = Context.Rel.length ctx_params in + let sigma = + List.fold_left (fun sigma (_,ctyps,_) -> + List.fold_left (fun sigma ctyp -> + maybe_unify_params_in env_ar_params sigma ~ninds ~nparams ctyp) + sigma ctyps) + sigma constructors + in + + (* generalize over the uniform parameters *) let nuparams = Context.Rel.length ctx_uparams in let uargs = Context.Rel.to_extended_vect EConstr.mkRel 0 ctx_uparams in let uparam_subst = diff --git a/vernac/comInductive.mli b/vernac/comInductive.mli index 2b9da1d4e5..984581152a 100644 --- a/vernac/comInductive.mli +++ b/vernac/comInductive.mli @@ -88,3 +88,9 @@ val template_polymorphism_candidate polymorphic. It should have at least one universe in its monomorphic universe context that can be made parametric in its conclusion sort, if one is given. *) + +val maybe_unify_params_in : Environ.env -> Evd.evar_map -> ninds:int -> nparams:int + -> EConstr.t -> Evd.evar_map +(** [nparams] is the number of parameters which aren't treated as + uniform, ie the length of params (including letins) where the env + is [uniform params, inductives, params]. *) diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index 3bac0419ef..bf38088f71 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -195,13 +195,14 @@ let build_wellfounded (recname,pl,bl,arityc,body) poly r measure notation = let lift_lets = lift_rel_context 1 letbinders in let sigma, intern_body = let ctx = LocalAssum (make_annot (Name recname) Sorts.Relevant, get_type curry_fun) :: binders_rel in - let (r, l, impls, scopes) = - Constrintern.compute_internalization_data env sigma + let interning_data = + Constrintern.compute_internalization_data env sigma recname Constrintern.Recursive full_arity impls in let newimpls = Id.Map.singleton recname - (r, l, impls @ [Some (ExplByName (Id.of_string "recproof"), Impargs.Manual, (true, false))], - scopes @ [None]) in + (Constrintern.extend_internalization_data interning_data + (Some (ExplByName (Id.of_string "recproof"), Impargs.Manual, (true, false))) + None) in interp_casted_constr_evars ~program_mode:true (push_rel_context ctx env) sigma ~impls:newimpls body (lift 1 top_arity) in @@ -254,9 +255,9 @@ let build_wellfounded (recname,pl,bl,arityc,body) poly r measure notation = in (* XXX: Capturing sigma here... bad bad *) let hook = DeclareDef.Hook.make (hook sigma) in - Obligations.check_evars env sigma; + RetrieveObl.check_evars env sigma; let evars, _, evars_def, evars_typ = - Obligations.eterm_obligations env recname sigma 0 def typ + RetrieveObl.retrieve_obligations env recname sigma 0 def typ in let uctx = Evd.evar_universe_context sigma in ignore(Obligations.add_definition ~name:recname ~term:evars_def ~udecl @@ -281,15 +282,15 @@ let do_program_recursive ~scope ~poly fixkind fixl = let evd = Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:true env evd in (* Solve remaining evars *) let evd = nf_evar_map_undefined evd in - let collect_evars id def typ imps = + let collect_evars name def typ impargs = (* Generalize by the recursive prototypes *) let def = nf_evar evd (Termops.it_mkNamedLambda_or_LetIn def rec_sign) in let typ = nf_evar evd (Termops.it_mkNamedProd_or_LetIn typ rec_sign) in let evm = collect_evars_of_term evd def typ in let evars, _, def, typ = - Obligations.eterm_obligations env id evm + RetrieveObl.retrieve_obligations env name evm (List.length rec_sign) def typ in - (id, def, typ, imps, evars) + ({ DeclareDef.Recthm.name; typ; impargs; args = [] }, def, evars) in let (fixnames,fixrs,fixdefs,fixtypes) = fix in let fiximps = List.map pi2 info in diff --git a/vernac/declare.ml b/vernac/declare.ml new file mode 100644 index 0000000000..357f58feea --- /dev/null +++ b/vernac/declare.ml @@ -0,0 +1,879 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \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) *) +(************************************************************************) + +(** This module is about the low-level declaration of logical objects *) + +open Pp +open Util +open Names +open Safe_typing +module NamedDecl = Context.Named.Declaration + +type opacity_flag = Opaque | Transparent + +type t = + { endline_tactic : Genarg.glob_generic_argument option + ; section_vars : Id.Set.t option + ; proof : Proof.t + ; udecl: UState.universe_decl + (** Initial universe declarations *) + ; initial_euctx : UState.t + (** The initial universe context (for the statement) *) + } + +(*** Proof Global manipulation ***) + +let get_proof ps = ps.proof +let get_proof_name ps = (Proof.data ps.proof).Proof.name + +let get_initial_euctx ps = ps.initial_euctx + +let map_proof f p = { p with proof = f p.proof } +let map_fold_proof f p = let proof, res = f p.proof in { p with proof }, res + +let map_fold_proof_endline f ps = + let et = + match ps.endline_tactic with + | None -> Proofview.tclUNIT () + | Some tac -> + let open Geninterp in + let {Proof.poly} = Proof.data ps.proof in + let ist = { lfun = Id.Map.empty; poly; extra = TacStore.empty } in + let Genarg.GenArg (Genarg.Glbwit tag, tac) = tac in + let tac = Geninterp.interp tag ist tac in + Ftactic.run tac (fun _ -> Proofview.tclUNIT ()) + in + let (newpr,ret) = f et ps.proof in + let ps = { ps with proof = newpr } in + ps, ret + +let compact_the_proof pf = map_proof Proof.compact pf + +(* Sets the tactic to be used when a tactic line is closed with [...] *) +let set_endline_tactic tac ps = + { ps with endline_tactic = Some tac } + +(** [start_proof ~name ~udecl ~poly sigma goals] starts a proof of + name [name] with goals [goals] (a list of pairs of environment and + conclusion). The proof is started in the evar map [sigma] (which + can typically contain universe constraints), and with universe + bindings [udecl]. *) +let start_proof ~name ~udecl ~poly sigma goals = + let proof = Proof.start ~name ~poly sigma goals in + let initial_euctx = Evd.evar_universe_context Proof.((data proof).sigma) in + { proof + ; endline_tactic = None + ; section_vars = None + ; udecl + ; initial_euctx + } + +let start_dependent_proof ~name ~udecl ~poly goals = + let proof = Proof.dependent_start ~name ~poly goals in + let initial_euctx = Evd.evar_universe_context Proof.((data proof).sigma) in + { proof + ; endline_tactic = None + ; section_vars = None + ; udecl + ; initial_euctx + } + +let get_used_variables pf = pf.section_vars +let get_universe_decl pf = pf.udecl + +let set_used_variables ps l = + let open Context.Named.Declaration in + let env = Global.env () in + let ids = List.fold_right Id.Set.add l Id.Set.empty in + let ctx = Environ.keep_hyps env ids in + let ctx_set = + List.fold_right Id.Set.add (List.map NamedDecl.get_id ctx) Id.Set.empty in + let vars_of = Environ.global_vars_set in + let aux env entry (ctx, all_safe as orig) = + match entry with + | LocalAssum ({Context.binder_name=x},_) -> + if Id.Set.mem x all_safe then orig + else (ctx, all_safe) + | LocalDef ({Context.binder_name=x},bo, ty) as decl -> + if Id.Set.mem x all_safe then orig else + let vars = Id.Set.union (vars_of env bo) (vars_of env ty) in + if Id.Set.subset vars all_safe + then (decl :: ctx, Id.Set.add x all_safe) + else (ctx, all_safe) in + let ctx, _ = + Environ.fold_named_context aux env ~init:(ctx,ctx_set) in + if not (Option.is_empty ps.section_vars) then + CErrors.user_err Pp.(str "Used section variables can be declared only once"); + ctx, { ps with section_vars = Some (Context.Named.to_vars ctx) } + +let get_open_goals ps = + let Proof.{ goals; stack; shelf } = Proof.data ps.proof in + List.length goals + + List.fold_left (+) 0 + (List.map (fun (l1,l2) -> List.length l1 + List.length l2) stack) + + List.length shelf + +(* object_kind , id *) +exception AlreadyDeclared of (string option * Id.t) + +let _ = CErrors.register_handler (function + | AlreadyDeclared (kind, id) -> + Some + (seq [ Pp.pr_opt_no_spc (fun s -> str s ++ spc ()) kind + ; Id.print id; str " already exists."]) + | _ -> + None) + +type import_status = ImportDefaultBehavior | ImportNeedQualified + +(** Declaration of constants and parameters *) + +type 'a proof_entry = { + proof_entry_body : 'a Entries.const_entry_body; + (* List of section variables *) + proof_entry_secctx : Id.Set.t option; + (* State id on which the completion of type checking is reported *) + proof_entry_feedback : Stateid.t option; + proof_entry_type : Constr.types option; + proof_entry_universes : Entries.universes_entry; + proof_entry_opaque : bool; + proof_entry_inline_code : bool; +} + +let default_univ_entry = Entries.Monomorphic_entry Univ.ContextSet.empty + +let definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?feedback_id ?section_vars ?types + ?(univs=default_univ_entry) ?(eff=Evd.empty_side_effects) ?(univsbody=Univ.ContextSet.empty) body = + { proof_entry_body = Future.from_val ?fix_exn ((body,univsbody), eff); + proof_entry_secctx = section_vars; + proof_entry_type = types; + proof_entry_universes = univs; + proof_entry_opaque = opaque; + proof_entry_feedback = feedback_id; + proof_entry_inline_code = inline} + +type proof_object = + { name : Names.Id.t + (* [name] only used in the STM *) + ; entries : Evd.side_effects proof_entry list + ; uctx: UState.t + } + +let private_poly_univs = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["Private";"Polymorphic";"Universes"] + ~value:true + +(* XXX: This is still separate from close_proof below due to drop_pt in the STM *) +(* XXX: Unsafe_typ:true is needed by vio files, see bf0499bc507d5a39c3d5e3bf1f69191339270729 *) +let prepare_proof ~unsafe_typ { proof } = + let Proof.{name=pid;entry;poly} = Proof.data proof in + let initial_goals = Proofview.initial_goals entry in + let evd = Proof.return ~pid proof in + let eff = Evd.eval_side_effects evd in + let evd = Evd.minimize_universes evd in + let to_constr_body 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 to_constr_typ t = + if unsafe_typ then EConstr.Unsafe.to_constr t else to_constr_body t + in + (* 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... *) + (* EJGA: actually side-effects de-duplication and this codepath is + unrelated. Duplicated side-effects arise from incorrect scheme + generation code, the main bulk of it was mostly fixed by #9836 + but duplication can still happen because of rewriting schemes I + think; however the code below is mostly untested, the only + code-paths that generate several proof entries are derive and + equations and so far there is no code in the CI that will + actually call those and do a side-effect, TTBOMK *) + (* EJGA: likely the right solution is to attach side effects to the first constant only? *) + let proofs = List.map (fun (body, typ) -> (to_constr_body body, eff), to_constr_typ typ) initial_goals in + proofs, Evd.evar_universe_context evd + +let close_proof ~opaque ~keep_body_ucst_separate ps = + + let { section_vars; proof; udecl; initial_euctx } = ps in + let { Proof.name; poly } = Proof.data proof in + let unsafe_typ = keep_body_ucst_separate && not poly in + let elist, uctx = prepare_proof ~unsafe_typ ps in + let opaque = match opaque with Opaque -> true | Transparent -> false in + + let make_entry ((body, eff), typ) = + + let allow_deferred = + not poly && + (keep_body_ucst_separate + || not (Safe_typing.is_empty_private_constants eff.Evd.seff_private)) + in + let used_univs_body = Vars.universes_of_constr body in + let used_univs_typ = Vars.universes_of_constr typ in + let used_univs = Univ.LSet.union used_univs_body used_univs_typ in + let utyp, ubody = + if allow_deferred then + let utyp = UState.univ_entry ~poly initial_euctx in + let uctx = UState.constrain_variables (fst (UState.context_set initial_euctx)) uctx in + (* For vi2vo compilation proofs are computed now but we need to + complement the univ constraints of the typ with the ones of + the body. So we keep the two sets distinct. *) + let uctx_body = UState.restrict uctx used_univs in + let ubody = UState.check_mono_univ_decl uctx_body udecl in + utyp, ubody + else if poly && opaque && private_poly_univs () then + let universes = UState.restrict uctx used_univs in + let typus = UState.restrict universes used_univs_typ in + let utyp = UState.check_univ_decl ~poly typus udecl in + let ubody = Univ.ContextSet.diff + (UState.context_set universes) + (UState.context_set typus) + in + utyp, ubody + else + (* Since the proof is computed now, we can simply have 1 set of + constraints in which we merge the ones for the body and the ones + for the typ. We recheck the declaration after restricting with + the actually used universes. + TODO: check if restrict is really necessary now. *) + let ctx = UState.restrict uctx used_univs in + let utyp = UState.check_univ_decl ~poly ctx udecl in + utyp, Univ.ContextSet.empty + in + definition_entry ~opaque ?section_vars ~univs:utyp ~univsbody:ubody ~types:typ ~eff body + in + let entries = CList.map make_entry elist in + { name; entries; uctx } + +type 'a constant_entry = + | DefinitionEntry of 'a proof_entry + | ParameterEntry of Entries.parameter_entry + | PrimitiveEntry of Entries.primitive_entry + +type constant_obj = { + cst_kind : Decls.logical_kind; + cst_locl : import_status; +} + +let load_constant i ((sp,kn), obj) = + if Nametab.exists_cci sp then + raise (AlreadyDeclared (None, Libnames.basename sp)); + let con = Global.constant_of_delta_kn kn in + Nametab.push (Nametab.Until i) sp (GlobRef.ConstRef con); + Dumpglob.add_constant_kind con obj.cst_kind + +(* Opening means making the name without its module qualification available *) +let open_constant f i ((sp,kn), obj) = + (* Never open a local definition *) + match obj.cst_locl with + | ImportNeedQualified -> () + | ImportDefaultBehavior -> + let con = Global.constant_of_delta_kn kn in + if Libobject.in_filter_ref (GlobRef.ConstRef con) f then + Nametab.push (Nametab.Exactly i) sp (GlobRef.ConstRef con) + +let exists_name id = + Decls.variable_exists id || Global.exists_objlabel (Label.of_id id) + +let check_exists id = + if exists_name id then + raise (AlreadyDeclared (None, id)) + +let cache_constant ((sp,kn), obj) = + (* Invariant: the constant must exist in the logical environment *) + let kn' = + if Global.exists_objlabel (Label.of_id (Libnames.basename sp)) + then Constant.make1 kn + else CErrors.anomaly Pp.(str"Missing constant " ++ Id.print(Libnames.basename sp) ++ str".") + in + assert (Constant.equal kn' (Constant.make1 kn)); + Nametab.push (Nametab.Until 1) sp (GlobRef.ConstRef (Constant.make1 kn)); + Dumpglob.add_constant_kind (Constant.make1 kn) obj.cst_kind + +let discharge_constant ((sp, kn), obj) = + Some obj + +let classify_constant cst = Libobject.Substitute cst + +let (objConstant : constant_obj Libobject.Dyn.tag) = + let open Libobject in + declare_object_full { (default_object "CONSTANT") with + cache_function = cache_constant; + load_function = load_constant; + open_function = open_constant; + classify_function = classify_constant; + subst_function = ident_subst_function; + discharge_function = discharge_constant } + +let inConstant v = Libobject.Dyn.Easy.inj v objConstant + +let update_tables c = + Impargs.declare_constant_implicits c; + Notation.declare_ref_arguments_scope Evd.empty (GlobRef.ConstRef c) + +let register_constant kn kind local = + let o = inConstant { + cst_kind = kind; + cst_locl = local; + } in + let id = Label.to_id (Constant.label kn) in + let _ = Lib.add_leaf id o in + update_tables kn + +let register_side_effect (c, role) = + let () = register_constant c Decls.(IsProof Theorem) ImportDefaultBehavior in + match role with + | None -> () + | Some (Evd.Schema (ind, kind)) -> DeclareScheme.declare_scheme kind [|ind,c|] + +let get_roles export eff = + let map c = + let role = try Some (Cmap.find c eff.Evd.seff_roles) with Not_found -> None in + (c, role) + in + List.map map export + +let export_side_effects eff = + let export = Global.export_private_constants eff.Evd.seff_private in + let export = get_roles export eff in + List.iter register_side_effect export + +let record_aux env s_ty s_bo = + let open Environ in + let in_ty = keep_hyps env s_ty in + let v = + String.concat " " + (CList.map_filter (fun decl -> + let id = NamedDecl.get_id decl in + if List.exists (NamedDecl.get_id %> Id.equal id) in_ty then None + else Some (Id.to_string id)) + (keep_hyps env s_bo)) in + Aux_file.record_in_aux "context_used" v + +let pure_definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?types + ?(univs=default_univ_entry) body = + { proof_entry_body = Future.from_val ?fix_exn ((body,Univ.ContextSet.empty), ()); + proof_entry_secctx = None; + proof_entry_type = types; + proof_entry_universes = univs; + proof_entry_opaque = opaque; + proof_entry_feedback = None; + proof_entry_inline_code = inline} + +let delayed_definition_entry ~opaque ?feedback_id ~section_vars ~univs ?types body = + { proof_entry_body = body + ; proof_entry_secctx = section_vars + ; proof_entry_type = types + ; proof_entry_universes = univs + ; proof_entry_opaque = opaque + ; proof_entry_feedback = feedback_id + ; proof_entry_inline_code = false + } + +let cast_proof_entry e = + let (body, ctx), () = Future.force e.proof_entry_body in + let univs = + if Univ.ContextSet.is_empty ctx then e.proof_entry_universes + else match e.proof_entry_universes with + | Entries.Monomorphic_entry ctx' -> + (* This can actually happen, try compiling EqdepFacts for instance *) + Entries.Monomorphic_entry (Univ.ContextSet.union ctx' ctx) + | Entries.Polymorphic_entry _ -> + CErrors.anomaly Pp.(str "Local universes in non-opaque polymorphic definition."); + in + { Entries.const_entry_body = body; + const_entry_secctx = e.proof_entry_secctx; + const_entry_feedback = e.proof_entry_feedback; + const_entry_type = e.proof_entry_type; + const_entry_universes = univs; + const_entry_inline_code = e.proof_entry_inline_code; + } + +type ('a, 'b) effect_entry = +| EffectEntry : (private_constants, private_constants Entries.const_entry_body) effect_entry +| PureEntry : (unit, Constr.constr) effect_entry + +let cast_opaque_proof_entry (type a b) (entry : (a, b) effect_entry) (e : a proof_entry) : b Entries.opaque_entry = + let typ = match e.proof_entry_type with + | None -> assert false + | Some typ -> typ + in + let secctx = match e.proof_entry_secctx with + | None -> + let open Environ in + let env = Global.env () in + let hyp_typ, hyp_def = + if List.is_empty (Environ.named_context env) then + Id.Set.empty, Id.Set.empty + else + let ids_typ = global_vars_set env typ in + let pf, env = match entry with + | PureEntry -> + let (pf, _), () = Future.force e.proof_entry_body in + pf, env + | EffectEntry -> + let (pf, _), eff = Future.force e.proof_entry_body in + let env = Safe_typing.push_private_constants env eff in + pf, env + in + let vars = global_vars_set env pf in + ids_typ, vars + in + let () = if Aux_file.recording () then record_aux env hyp_typ hyp_def in + Environ.really_needed env (Id.Set.union hyp_typ hyp_def) + | Some hyps -> hyps + in + let (body, univs : b * _) = match entry with + | PureEntry -> + let (body, uctx), () = Future.force e.proof_entry_body in + let univs = match e.proof_entry_universes with + | Entries.Monomorphic_entry uctx' -> + Entries.Monomorphic_entry (Univ.ContextSet.union uctx uctx') + | Entries.Polymorphic_entry _ -> + assert (Univ.ContextSet.is_empty uctx); + e.proof_entry_universes + in + body, univs + | EffectEntry -> e.proof_entry_body, e.proof_entry_universes + in + { Entries.opaque_entry_body = body; + opaque_entry_secctx = secctx; + opaque_entry_feedback = e.proof_entry_feedback; + opaque_entry_type = typ; + opaque_entry_universes = univs; + } + +let feedback_axiom () = Feedback.(feedback AddedAxiom) + +let is_unsafe_typing_flags () = + let open Declarations in + let flags = Environ.typing_flags (Global.env()) in + not (flags.check_universes && flags.check_guarded && flags.check_positive) + +let define_constant ~name cd = + (* Logically define the constant and its subproofs, no libobject tampering *) + let decl, unsafe = match cd with + | DefinitionEntry de -> + (* We deal with side effects *) + if not de.proof_entry_opaque then + let body, eff = Future.force de.proof_entry_body in + (* This globally defines the side-effects in the environment + and registers their libobjects. *) + let () = export_side_effects eff in + let de = { de with proof_entry_body = Future.from_val (body, ()) } in + let cd = Entries.DefinitionEntry (cast_proof_entry de) in + ConstantEntry cd, false + else + let map (body, eff) = body, eff.Evd.seff_private in + let body = Future.chain de.proof_entry_body map in + let de = { de with proof_entry_body = body } in + let de = cast_opaque_proof_entry EffectEntry de in + OpaqueEntry de, false + | ParameterEntry e -> + ConstantEntry (Entries.ParameterEntry e), not (Lib.is_modtype_strict()) + | PrimitiveEntry e -> + ConstantEntry (Entries.PrimitiveEntry e), false + in + let kn = Global.add_constant name decl in + if unsafe || is_unsafe_typing_flags() then feedback_axiom(); + kn + +let declare_constant ?(local = ImportDefaultBehavior) ~name ~kind cd = + let () = check_exists name in + let kn = define_constant ~name cd in + (* Register the libobjects attached to the constants *) + let () = register_constant kn kind local in + kn + +let declare_private_constant ?role ?(local = ImportDefaultBehavior) ~name ~kind de = + let kn, eff = + let de = + if not de.proof_entry_opaque then + DefinitionEff (cast_proof_entry de) + else + let de = cast_opaque_proof_entry PureEntry de in + OpaqueEff de + in + Global.add_private_constant name de + in + let () = register_constant kn kind local in + let seff_roles = match role with + | None -> Cmap.empty + | Some r -> Cmap.singleton kn r + in + let eff = { Evd.seff_private = eff; Evd.seff_roles; } in + kn, eff + +let inline_private_constants ~uctx env ce = + let body, eff = Future.force ce.proof_entry_body in + let cb, ctx = Safe_typing.inline_private_constants env (body, eff.Evd.seff_private) in + let uctx = UState.merge ~sideff:true Evd.univ_rigid uctx ctx in + cb, uctx + +(** Declaration of section variables and local definitions *) +type variable_declaration = + | SectionLocalDef of Evd.side_effects proof_entry + | SectionLocalAssum of { typ:Constr.types; impl:Glob_term.binding_kind; } + +(* This object is only for things which iterate over objects to find + variables (only Prettyp.print_context AFAICT) *) +let objVariable : unit Libobject.Dyn.tag = + let open Libobject in + declare_object_full { (default_object "VARIABLE") with + classify_function = (fun () -> Dispose)} + +let inVariable v = Libobject.Dyn.Easy.inj v objVariable + +let declare_variable ~name ~kind d = + (* Variables are distinguished by only short names *) + if Decls.variable_exists name then + raise (AlreadyDeclared (None, name)); + + let impl,opaque = match d with (* Fails if not well-typed *) + | SectionLocalAssum {typ;impl} -> + let () = Global.push_named_assum (name,typ) in + impl, true + | SectionLocalDef (de) -> + (* The body should already have been forced upstream because it is a + section-local definition, but it's not enforced by typing *) + let ((body, body_ui), eff) = Future.force de.proof_entry_body in + let () = export_side_effects eff in + let poly, entry_ui = match de.proof_entry_universes with + | Entries.Monomorphic_entry uctx -> false, uctx + | Entries.Polymorphic_entry (_, uctx) -> true, Univ.ContextSet.of_context uctx + in + let univs = Univ.ContextSet.union body_ui entry_ui in + (* We must declare the universe constraints before type-checking the + term. *) + let () = DeclareUctx.declare_universe_context ~poly univs in + let se = { + Entries.secdef_body = body; + secdef_secctx = de.proof_entry_secctx; + secdef_feedback = de.proof_entry_feedback; + secdef_type = de.proof_entry_type; + } in + let () = Global.push_named_def (name, se) in + Glob_term.Explicit, de.proof_entry_opaque + in + Nametab.push (Nametab.Until 1) (Libnames.make_path DirPath.empty name) (GlobRef.VarRef name); + Decls.(add_variable_data name {opaque;kind}); + ignore(Lib.add_leaf name (inVariable ()) : Libobject.object_name); + Impargs.declare_var_implicits ~impl name; + Notation.declare_ref_arguments_scope Evd.empty (GlobRef.VarRef name) + +(* Declaration messages *) + +let pr_rank i = pr_nth (i+1) + +let fixpoint_message indexes l = + Flags.if_verbose Feedback.msg_info (match l with + | [] -> CErrors.anomaly (Pp.str "no recursive definition.") + | [id] -> Id.print id ++ str " is recursively defined" ++ + (match indexes with + | Some [|i|] -> str " (decreasing on "++pr_rank i++str " argument)" + | _ -> mt ()) + | l -> hov 0 (prlist_with_sep pr_comma Id.print l ++ + spc () ++ str "are recursively defined" ++ + match indexes with + | Some a -> spc () ++ str "(decreasing respectively on " ++ + prvect_with_sep pr_comma pr_rank a ++ + str " arguments)" + | None -> mt ())) + +let cofixpoint_message l = + Flags.if_verbose Feedback.msg_info (match l with + | [] -> CErrors.anomaly (Pp.str "No corecursive definition.") + | [id] -> Id.print id ++ str " is corecursively defined" + | l -> hov 0 (prlist_with_sep pr_comma Id.print l ++ + spc () ++ str "are corecursively defined")) + +let recursive_message isfix i l = + (if isfix then fixpoint_message i else cofixpoint_message) l + +let definition_message id = + Flags.if_verbose Feedback.msg_info (Id.print id ++ str " is defined") + +let assumption_message id = + (* Changing "assumed" to "declared", "assuming" referring more to + the type of the object than to the name of the object (see + discussion on coqdev: "Chapter 4 of the Reference Manual", 8/10/2015) *) + Flags.if_verbose Feedback.msg_info (Id.print id ++ str " is declared") + +module Internal = struct + + let map_entry_body ~f entry = + { entry with proof_entry_body = Future.chain entry.proof_entry_body f } + + let map_entry_type ~f entry = + { entry with proof_entry_type = f entry.proof_entry_type } + + let set_opacity ~opaque entry = + { entry with proof_entry_opaque = opaque } + + let get_fix_exn entry = Future.fix_exn_of entry.proof_entry_body + + let rec decompose len c t accu = + let open Constr in + let open Context.Rel.Declaration in + if len = 0 then (c, t, accu) + else match kind c, kind t with + | Lambda (na, u, c), Prod (_, _, t) -> + decompose (pred len) c t (LocalAssum (na, u) :: accu) + | LetIn (na, b, u, c), LetIn (_, _, _, t) -> + decompose (pred len) c t (LocalDef (na, b, u) :: accu) + | _ -> assert false + + let rec shrink ctx sign c t accu = + let open Constr in + let open Vars in + match ctx, sign with + | [], [] -> (c, t, accu) + | p :: ctx, decl :: sign -> + if noccurn 1 c && noccurn 1 t then + let c = subst1 mkProp c in + let t = subst1 mkProp t in + shrink ctx sign c t accu + else + let c = Term.mkLambda_or_LetIn p c in + let t = Term.mkProd_or_LetIn p t in + let accu = if Context.Rel.Declaration.is_local_assum p + then mkVar (NamedDecl.get_id decl) :: accu + else accu + in + shrink ctx sign c t accu + | _ -> assert false + + let shrink_entry sign const = + let typ = match const.proof_entry_type with + | None -> assert false + | Some t -> t + in + (* The body has been forced by the call to [build_constant_by_tactic] *) + let () = assert (Future.is_over const.proof_entry_body) in + let ((body, uctx), eff) = Future.force const.proof_entry_body in + let (body, typ, ctx) = decompose (List.length sign) body typ [] in + let (body, typ, args) = shrink ctx sign body typ [] in + { const with + proof_entry_body = Future.from_val ((body, uctx), eff) + ; proof_entry_type = Some typ + }, args + + type nonrec constant_obj = constant_obj + + let objVariable = objVariable + let objConstant = objConstant + +end +(*** Proof Global Environment ***) + +type closed_proof_output = (Constr.t * Evd.side_effects) list * UState.t + +let close_proof_delayed ~feedback_id ps (fpl : closed_proof_output Future.computation) = + let { section_vars; proof; udecl; initial_euctx } = ps in + let { Proof.name; poly; entry; sigma } = Proof.data proof in + + (* We don't allow poly = true in this path *) + if poly then + CErrors.anomaly (Pp.str "Cannot delay universe-polymorphic constants."); + + let fpl, uctx = Future.split2 fpl in + (* Because of dependent subgoals at the beginning of proofs, we could + have existential variables in the initial types of goals, we need to + normalise them for the kernel. *) + let subst_evar k = Evd.existential_opt_value0 sigma k in + let nf = UnivSubst.nf_evars_and_universes_opt_subst subst_evar (UState.subst initial_euctx) in + + (* We only support opaque proofs, this will be enforced by using + different entries soon *) + let opaque = true in + let make_entry p (_, types) = + (* Already checked the univ_decl for the type universes when starting the proof. *) + let univs = UState.univ_entry ~poly:false initial_euctx in + let types = nf (EConstr.Unsafe.to_constr types) in + + Future.chain p (fun (pt,eff) -> + (* Deferred proof, we already checked the universe declaration with + the initial universes, ensure that the final universes respect + the declaration as well. If the declaration is non-extensible, + this will prevent the body from adding universes and constraints. *) + let uctx = Future.force uctx in + let uctx = UState.constrain_variables (fst (UState.context_set initial_euctx)) uctx in + let used_univs = Univ.LSet.union + (Vars.universes_of_constr types) + (Vars.universes_of_constr pt) + in + let univs = UState.restrict uctx used_univs in + let univs = UState.check_mono_univ_decl univs udecl in + (pt,univs),eff) + |> delayed_definition_entry ~opaque ~feedback_id ~section_vars ~univs ~types + in + let entries = Future.map2 make_entry fpl (Proofview.initial_goals entry) in + { name; entries; uctx = initial_euctx } + +let close_future_proof = close_proof_delayed + +let return_partial_proof { proof } = + let proofs = Proof.partial_proof proof in + let Proof.{sigma=evd} = Proof.data proof in + let eff = Evd.eval_side_effects evd in + (* 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 proofs = List.map (fun c -> EConstr.Unsafe.to_constr c, eff) proofs in + proofs, Evd.evar_universe_context evd + +let return_proof ps = + let p, uctx = prepare_proof ~unsafe_typ:false ps in + List.map fst p, uctx + +let update_global_env = + map_proof (fun p -> + let { Proof.sigma } = Proof.data p in + let tac = Proofview.Unsafe.tclEVARS (Evd.update_sigma_env sigma (Global.env ())) in + let p, (status,info), _ = Proof.run_tactic (Global.env ()) tac p in + p) + +let next = let n = ref 0 in fun () -> incr n; !n + +let by tac = map_fold_proof (Proof.solve (Goal_select.SelectNth 1) None tac) + +let build_constant_by_tactic ~name ?(opaque=Transparent) ~uctx ~sign ~poly typ tac = + let evd = Evd.from_ctx uctx in + let goals = [ (Global.env_of_context sign , typ) ] in + let pf = start_proof ~name ~poly ~udecl:UState.default_univ_decl evd goals in + let pf, status = by tac pf in + let { entries; uctx } = close_proof ~opaque ~keep_body_ucst_separate:false pf in + match entries with + | [entry] -> + entry, status, uctx + | _ -> + CErrors.anomaly Pp.(str "[build_constant_by_tactic] close_proof returned more than one proof term") + +let build_by_tactic ?(side_eff=true) env ~uctx ~poly ~typ tac = + let name = Id.of_string ("temporary_proof"^string_of_int (next())) in + let sign = Environ.(val_of_named_context (named_context env)) in + let ce, status, univs = build_constant_by_tactic ~name ~uctx ~sign ~poly typ tac in + let cb, uctx = + if side_eff then inline_private_constants ~uctx env ce + else + (* GG: side effects won't get reset: no need to treat their universes specially *) + let (cb, ctx), _eff = Future.force ce.proof_entry_body in + cb, UState.merge ~sideff:false Evd.univ_rigid uctx ctx + in + cb, ce.proof_entry_type, status, univs + +let declare_abstract ~name ~poly ~kind ~sign ~secsign ~opaque ~solve_tac sigma concl = + (* EJGA: flush_and_check_evars is only used in abstract, could we + use a different API? *) + let concl = + try Evarutil.flush_and_check_evars sigma concl + with Evarutil.Uninstantiated_evar _ -> + CErrors.user_err Pp.(str "\"abstract\" cannot handle existentials.") + in + let sigma, concl = + (* FIXME: should be done only if the tactic succeeds *) + let sigma = Evd.minimize_universes sigma in + sigma, Evarutil.nf_evars_universes sigma concl + in + let concl = EConstr.of_constr concl in + let uctx = Evd.evar_universe_context sigma in + let (const, safe, uctx) = + try build_constant_by_tactic ~name ~opaque:Transparent ~poly ~uctx ~sign:secsign concl solve_tac + with Logic_monad.TacticFailure e as src -> + (* if the tactic [tac] fails, it reports a [TacticFailure e], + which is an error irrelevant to the proof system (in fact it + means that [e] comes from [tac] failing to yield enough + success). Hence it reraises [e]. *) + let (_, info) = Exninfo.capture src in + Exninfo.iraise (e, info) + in + let sigma = Evd.set_universe_context sigma uctx in + let body, effs = Future.force const.proof_entry_body in + (* We drop the side-effects from the entry, they already exist in the ambient environment *) + let const = Internal.map_entry_body const ~f:(fun _ -> body, ()) in + (* EJGA: Hack related to the above call to + `build_constant_by_tactic` with `~opaque:Transparent`. Even if + the abstracted term is destined to be opaque, if we trigger the + `if poly && opaque && private_poly_univs ()` in `Proof_global` + kernel will boom. This deserves more investigation. *) + let const = Internal.set_opacity ~opaque const in + let const, args = Internal.shrink_entry sign const in + let cst () = + (* do not compute the implicit arguments, it may be costly *) + let () = Impargs.make_implicit_args false in + (* ppedrot: seems legit to have abstracted subproofs as local*) + declare_private_constant ~local:ImportNeedQualified ~name ~kind const + in + let cst, eff = Impargs.with_implicit_protection cst () in + let inst = match const.proof_entry_universes with + | Entries.Monomorphic_entry _ -> EConstr.EInstance.empty + | Entries.Polymorphic_entry (_, ctx) -> + (* We mimic what the kernel does, that is ensuring that no additional + constraints appear in the body of polymorphic constants. Ideally this + should be enforced statically. *) + let (_, body_uctx), _ = Future.force const.proof_entry_body in + let () = assert (Univ.ContextSet.is_empty body_uctx) in + EConstr.EInstance.make (Univ.UContext.instance ctx) + in + let args = List.map EConstr.of_constr args in + let lem = EConstr.mkConstU (cst, inst) in + let effs = Evd.concat_side_effects eff effs in + effs, sigma, lem, args, safe + +let get_goal_context pf i = + let p = get_proof pf in + Proof.get_goal_context_gen p i + +let get_current_goal_context pf = + let p = get_proof pf in + try Proof.get_goal_context_gen p 1 + with + | Proof.NoSuchGoal _ -> + (* spiwack: returning empty evar_map, since if there is no goal, + under focus, there is no accessible evar either. EJGA: this + seems strange, as we have pf *) + let env = Global.env () in + Evd.from_env env, env + +let get_current_context pf = + let p = get_proof pf in + Proof.get_proof_context p + +module Proof = struct + type nonrec t = t + let get_proof = get_proof + let get_proof_name = get_proof_name + let get_used_variables = get_used_variables + let get_universe_decl = get_universe_decl + let get_initial_euctx = get_initial_euctx + let map_proof = map_proof + let map_fold_proof = map_fold_proof + let map_fold_proof_endline = map_fold_proof_endline + let set_endline_tactic = set_endline_tactic + let set_used_variables = set_used_variables + let compact = compact_the_proof + let update_global_env = update_global_env + let get_open_goals = get_open_goals +end + +let declare_definition_scheme ~internal ~univs ~role ~name c = + let kind = Decls.(IsDefinition Scheme) in + let entry = pure_definition_entry ~univs c in + let kn, eff = declare_private_constant ~role ~kind ~name entry in + let () = if internal then () else definition_message name in + kn, eff + +let _ = Ind_tables.declare_definition_scheme := declare_definition_scheme +let _ = Abstract.declare_abstract := declare_abstract + +let declare_universe_context = DeclareUctx.declare_universe_context diff --git a/vernac/declare.mli b/vernac/declare.mli new file mode 100644 index 0000000000..e23e148ddc --- /dev/null +++ b/vernac/declare.mli @@ -0,0 +1,284 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \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 Names +open Constr +open Entries + +(** This module provides the official functions to declare new + variables, parameters, constants and inductive types in the global + environment. It also updates some accesory tables such as [Nametab] + (name resolution), [Impargs], and [Notations]. *) + +(** We provide two kind of fuctions: + + - one go functions, that will register a constant in one go, suited + for non-interactive definitions where the term is given. + + - two-phase [start/declare] functions which will create an + interactive proof, allow its modification, and saving when + complete. + + Internally, these functions mainly differ in that usually, the first + case doesn't require setting up the tactic engine. + + *) + +(** [Declare.Proof.t] Construction of constants using interactive proofs. *) +module Proof : sig + + type t + + (** XXX: These are internal and will go away from publis API once + lemmas is merged here *) + val get_proof : t -> Proof.t + val get_proof_name : t -> Names.Id.t + + (** XXX: These 3 are only used in lemmas *) + val get_used_variables : t -> Names.Id.Set.t option + val get_universe_decl : t -> UState.universe_decl + val get_initial_euctx : t -> UState.t + + val map_proof : (Proof.t -> Proof.t) -> t -> t + val map_fold_proof : (Proof.t -> Proof.t * 'a) -> t -> t * 'a + val map_fold_proof_endline : (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> t -> t * 'a + + (** Sets the tactic to be used when a tactic line is closed with [...] *) + val set_endline_tactic : Genarg.glob_generic_argument -> t -> t + + (** Sets the section variables assumed by the proof, returns its closure + * (w.r.t. type dependencies and let-ins covered by it) *) + val set_used_variables : t -> + Names.Id.t list -> Constr.named_context * t + + val compact : t -> t + + (** Update the proofs global environment after a side-effecting command + (e.g. a sublemma definition) has been run inside it. Assumes + there_are_pending_proofs. *) + val update_global_env : t -> t + + val get_open_goals : t -> int + +end + +type opacity_flag = Opaque | Transparent + +(** [start_proof ~name ~udecl ~poly sigma goals] starts a proof of + name [name] with goals [goals] (a list of pairs of environment and + conclusion); [poly] determines if the proof is universe + polymorphic. The proof is started in the evar map [sigma] (which + can typically contain universe constraints), and with universe + bindings [udecl]. *) +val start_proof + : name:Names.Id.t + -> udecl:UState.universe_decl + -> poly:bool + -> Evd.evar_map + -> (Environ.env * EConstr.types) list + -> Proof.t + +(** Like [start_proof] except that there may be dependencies between + initial goals. *) +val start_dependent_proof + : name:Names.Id.t + -> udecl:UState.universe_decl + -> poly:bool + -> Proofview.telescope + -> Proof.t + +(** Proof entries represent a proof that has been finished, but still + not registered with the kernel. + + XXX: Scheduled for removal from public API, don't rely on it *) +type 'a proof_entry = private { + proof_entry_body : 'a Entries.const_entry_body; + (* List of section variables *) + proof_entry_secctx : Id.Set.t option; + (* State id on which the completion of type checking is reported *) + proof_entry_feedback : Stateid.t option; + proof_entry_type : Constr.types option; + proof_entry_universes : Entries.universes_entry; + proof_entry_opaque : bool; + proof_entry_inline_code : bool; +} + +(** XXX: Scheduled for removal from public API, don't rely on it *) +type proof_object = private + { name : Names.Id.t + (** name of the proof *) + ; entries : Evd.side_effects proof_entry list + (** list of the proof terms (in a form suitable for definitions). *) + ; uctx: UState.t + (** universe state *) + } + +val close_proof : opaque:opacity_flag -> keep_body_ucst_separate:bool -> Proof.t -> proof_object + +(** Declaration of local constructions (Variable/Hypothesis/Local) *) + +(** XXX: Scheduled for removal from public API, don't rely on it *) +type variable_declaration = + | SectionLocalDef of Evd.side_effects proof_entry + | SectionLocalAssum of { typ:types; impl:Glob_term.binding_kind; } + +(** XXX: Scheduled for removal from public API, don't rely on it *) +type 'a constant_entry = + | DefinitionEntry of 'a proof_entry + | ParameterEntry of parameter_entry + | PrimitiveEntry of primitive_entry + +val declare_variable + : name:variable + -> kind:Decls.logical_kind + -> variable_declaration + -> unit + +(** Declaration of global constructions + i.e. Definition/Theorem/Axiom/Parameter/... + + XXX: Scheduled for removal from public API, use `DeclareDef` instead *) +val definition_entry + : ?fix_exn:Future.fix_exn + -> ?opaque:bool + -> ?inline:bool + -> ?feedback_id:Stateid.t + -> ?section_vars:Id.Set.t + -> ?types:types + -> ?univs:Entries.universes_entry + -> ?eff:Evd.side_effects + -> ?univsbody:Univ.ContextSet.t + (** Universe-constraints attached to the body-only, used in + vio-delayed opaque constants and private poly universes *) + -> constr + -> Evd.side_effects proof_entry + +type import_status = ImportDefaultBehavior | ImportNeedQualified + +(** [declare_constant id cd] declares a global declaration + (constant/parameter) with name [id] in the current section; it returns + the full path of the declaration + + internal specify if the constant has been created by the kernel or by the + user, and in the former case, if its errors should be silent + + XXX: Scheduled for removal from public API, use `DeclareDef` instead *) +val declare_constant + : ?local:import_status + -> name:Id.t + -> kind:Decls.logical_kind + -> Evd.side_effects constant_entry + -> Constant.t + +(** [inline_private_constants ~sideff ~uctx env ce] will inline the + constants in [ce]'s body and return the body plus the updated + [UState.t]. + + XXX: Scheduled for removal from public API, don't rely on it *) +val inline_private_constants + : uctx:UState.t + -> Environ.env + -> Evd.side_effects proof_entry + -> Constr.t * UState.t + +(** Declaration messages *) + +(** XXX: Scheduled for removal from public API, do not use *) +val definition_message : Id.t -> unit +val assumption_message : Id.t -> unit +val fixpoint_message : int array option -> Id.t list -> unit +val recursive_message : bool (** true = fixpoint *) -> + int array option -> Id.t list -> unit + +val check_exists : Id.t -> unit + +(* Used outside this module only in indschemes *) +exception AlreadyDeclared of (string option * Id.t) + +(** {6 For legacy support, do not use} *) + +module Internal : sig + + val map_entry_body : f:('a Entries.proof_output -> 'b Entries.proof_output) -> 'a proof_entry -> 'b proof_entry + val map_entry_type : f:(Constr.t option -> Constr.t option) -> 'a proof_entry -> 'a proof_entry + (* Overriding opacity is indeed really hacky *) + val set_opacity : opaque:bool -> 'a proof_entry -> 'a proof_entry + + (* TODO: This is only used in DeclareDef to forward the fix to + hooks, should eventually go away *) + val get_fix_exn : 'a proof_entry -> Future.fix_exn + + val shrink_entry : EConstr.named_context -> 'a proof_entry -> 'a proof_entry * Constr.constr list + + type constant_obj + + val objConstant : constant_obj Libobject.Dyn.tag + val objVariable : unit Libobject.Dyn.tag + +end + +(* Intermediate step necessary to delegate the future. + * Both access the current proof state. The former is supposed to be + * chained with a computation that completed the proof *) +type closed_proof_output + +(** Requires a complete proof. *) +val return_proof : Proof.t -> closed_proof_output + +(** An incomplete proof is allowed (no error), and a warn is given if + the proof is complete. *) +val return_partial_proof : Proof.t -> closed_proof_output +val close_future_proof : feedback_id:Stateid.t -> Proof.t -> closed_proof_output Future.computation -> proof_object + +(** [by tac] applies tactic [tac] to the 1st subgoal of the current + focused proof. + Returns [false] if an unsafe tactic has been used. *) +val by : unit Proofview.tactic -> Proof.t -> Proof.t * bool + +val build_by_tactic + : ?side_eff:bool + -> Environ.env + -> uctx:UState.t + -> poly:bool + -> typ:EConstr.types + -> unit Proofview.tactic + -> Constr.constr * Constr.types option * bool * UState.t + +(** {6 Helpers to obtain proof state when in an interactive proof } *) + +(** [get_goal_context n] returns the context of the [n]th subgoal of + the current focused proof or raises a [UserError] if there is no + focused proof or if there is no more subgoals *) + +val get_goal_context : Proof.t -> int -> Evd.evar_map * Environ.env + +(** [get_current_goal_context ()] works as [get_goal_context 1] *) +val get_current_goal_context : Proof.t -> Evd.evar_map * Environ.env + +(** [get_current_context ()] returns the context of the + current focused goal. If there is no focused goal but there + is a proof in progress, it returns the corresponding evar_map. + If there is no pending proof then it returns the current global + environment and empty evar_map. *) +val get_current_context : Proof.t -> Evd.evar_map * Environ.env + +(** Temporarily re-exported for 3rd party code; don't use *) +val build_constant_by_tactic : + name:Names.Id.t -> + ?opaque:opacity_flag -> + uctx:UState.t -> + sign:Environ.named_context_val -> + poly:bool -> + EConstr.types -> + unit Proofview.tactic -> + Evd.side_effects proof_entry * bool * UState.t + +val declare_universe_context : poly:bool -> Univ.ContextSet.t -> unit +[@@ocaml.deprecated "Use DeclareUctx.declare_universe_context"] diff --git a/vernac/declareDef.ml b/vernac/declareDef.ml index fc53abdcea..1809c2bc91 100644 --- a/vernac/declareDef.ml +++ b/vernac/declareDef.ml @@ -9,7 +9,6 @@ (************************************************************************) open Declare -open Impargs type locality = Discharge | Global of Declare.import_status @@ -34,41 +33,39 @@ module Hook = struct let make hook = CEphemeron.create hook - let call ?hook ?fix_exn x = - try Option.iter (fun hook -> CEphemeron.get hook x) hook - with e when CErrors.noncritical e -> - let e = Exninfo.capture e in - let e = Option.cata (fun fix -> fix e) e fix_exn in - Exninfo.iraise e + let call ?hook x = Option.iter (fun hook -> CEphemeron.get hook x) hook + end (* Locality stuff *) -let declare_definition ~name ~scope ~kind ?hook_data ~ubind ~impargs ce = - let fix_exn = Declare.Internal.get_fix_exn ce in - let should_suggest = ce.Declare.proof_entry_opaque && - Option.is_empty ce.Declare.proof_entry_secctx in +let declare_entry ~name ~scope ~kind ?hook ?(obls=[]) ~impargs ~uctx entry = + let should_suggest = entry.Declare.proof_entry_opaque && + Option.is_empty entry.Declare.proof_entry_secctx in + let ubind = UState.universe_binders uctx in let dref = match scope with | Discharge -> - let () = declare_variable ~name ~kind (SectionLocalDef ce) in + let () = declare_variable ~name ~kind (SectionLocalDef entry) in if should_suggest then Proof_using.suggest_variable (Global.env ()) name; Names.GlobRef.VarRef name | Global local -> - let kn = declare_constant ~name ~local ~kind (DefinitionEntry ce) in + let kn = declare_constant ~name ~local ~kind (DefinitionEntry entry) in let gr = Names.GlobRef.ConstRef kn in if should_suggest then Proof_using.suggest_constant (Global.env ()) kn; let () = DeclareUniv.declare_univ_binders gr ubind in gr in - let () = maybe_declare_manual_implicits false dref impargs in + let () = Impargs.maybe_declare_manual_implicits false dref impargs in let () = definition_message name in - begin - match hook_data with - | None -> () - | Some (hook, uctx, obls) -> - Hook.call ~fix_exn ~hook { Hook.S.uctx; obls; scope; dref } - end; + Option.iter (fun hook -> Hook.call ~hook { Hook.S.uctx; obls; scope; dref }) hook; dref +let declare_entry ~name ~scope ~kind ?hook ?obls ~impargs ~uctx entry = + try declare_entry ~name ~scope ~kind ?hook ?obls ~impargs ~uctx entry + with exn -> + let exn = Exninfo.capture exn in + let fix_exn = Declare.Internal.get_fix_exn entry in + Exninfo.iraise (fix_exn exn) + let mutual_make_bodies ~fixitems ~rec_declaration ~possible_indexes = match possible_indexes with | Some possible_indexes -> @@ -98,25 +95,24 @@ end let declare_mutually_recursive ~opaque ~scope ~kind ~poly ~uctx ~udecl ~ntns ~rec_declaration ~possible_indexes ?(restrict_ucontext=true) fixitems = let vars, fixdecls, indexes = mutual_make_bodies ~fixitems ~rec_declaration ~possible_indexes in - let ubind, univs = + let uctx, univs = (* XXX: Obligations don't do this, this seems like a bug? *) if restrict_ucontext then - let evd = Evd.from_ctx uctx in - let evd = Evd.restrict_universe_context evd vars in - let univs = Evd.check_univ_decl ~poly evd udecl in - Evd.universe_binders evd, univs + let uctx = UState.restrict uctx vars in + let univs = UState.check_univ_decl ~poly uctx udecl in + uctx, univs else let univs = UState.univ_entry ~poly uctx in - UnivNames.empty_binders, univs + uctx, univs in let csts = CList.map2 (fun Recthm.{ name; typ; impargs } body -> - let ce = Declare.definition_entry ~opaque ~types:typ ~univs body in - declare_definition ~name ~scope ~kind ~ubind ~impargs ce) + let entry = Declare.definition_entry ~opaque ~types:typ ~univs body in + declare_entry ~name ~scope ~kind ~impargs ~uctx entry) fixitems fixdecls in - let isfix = Option.is_empty possible_indexes in + let isfix = Option.has_some possible_indexes in let fixnames = List.map (fun { Recthm.name } -> name) fixitems in Declare.recursive_message isfix indexes fixnames; List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns; @@ -127,7 +123,7 @@ let warn_let_as_axiom = Pp.(fun id -> strbrk "Let definition" ++ spc () ++ Names.Id.print id ++ spc () ++ strbrk "declared as an axiom.") -let declare_assumption ?fix_exn ~name ~scope ~hook ~impargs ~uctx pe = +let declare_assumption ~name ~scope ~hook ~impargs ~uctx pe = let local = match scope with | Discharge -> warn_let_as_axiom name; Declare.ImportNeedQualified | Global local -> local @@ -139,26 +135,58 @@ let declare_assumption ?fix_exn ~name ~scope ~hook ~impargs ~uctx pe = let () = Impargs.maybe_declare_manual_implicits false dref impargs in let () = Declare.assumption_message name in let () = DeclareUniv.declare_univ_binders dref (UState.universe_binders uctx) in - let () = Hook.(call ?fix_exn ?hook { S.uctx; obls = []; scope; dref}) in + let () = Hook.(call ?hook { S.uctx; obls = []; scope; dref}) in dref +let declare_assumption ?fix_exn ~name ~scope ~hook ~impargs ~uctx pe = + try declare_assumption ~name ~scope ~hook ~impargs ~uctx pe + with exn -> + let exn = Exninfo.capture exn in + let exn = Option.cata (fun fix -> fix exn) exn fix_exn in + Exninfo.iraise exn + (* Preparing proof entries *) -let check_definition_evars ~allow_evars sigma = +let prepare_definition ?opaque ?inline ?fix_exn ~poly ~udecl ~types ~body sigma = let env = Global.env () in - if not allow_evars then Pretyping.check_evars_are_solved ~program_mode:false env sigma + Pretyping.check_evars_are_solved ~program_mode:false env sigma; + let sigma, (body, types) = Evarutil.finalize ~abort_on_undefined_evars:true + sigma (fun nf -> nf body, Option.map nf types) + in + let univs = Evd.check_univ_decl ~poly sigma udecl in + let entry = definition_entry ?fix_exn ?opaque ?inline ?types ~univs body in + let uctx = Evd.evar_universe_context sigma in + entry, uctx + +let declare_definition ~name ~scope ~kind ~opaque ~impargs ~udecl ?hook + ?obls ~poly ?inline ~types ~body ?fix_exn sigma = + let entry, uctx = prepare_definition ?fix_exn ~opaque ~poly ~udecl ~types ~body ?inline sigma in + declare_entry ~name ~scope ~kind ~impargs ?obls ?hook ~uctx entry -let prepare_definition ~allow_evars ?opaque ?inline ~poly ~udecl ~types ~body sigma = - check_definition_evars ~allow_evars sigma; - let sigma, (body, types) = Evarutil.finalize ~abort_on_undefined_evars:(not allow_evars) +let prepare_obligation ?opaque ?inline ~name ~poly ~udecl ~types ~body sigma = + let sigma, (body, types) = Evarutil.finalize ~abort_on_undefined_evars:false sigma (fun nf -> nf body, Option.map nf types) in let univs = Evd.check_univ_decl ~poly sigma udecl in - sigma, definition_entry ?opaque ?inline ?types ~univs body + let ce = definition_entry ?opaque ?inline ?types ~univs body in + let env = Global.env () in + let (c,ctx), sideff = Future.force ce.Declare.proof_entry_body in + assert(Safe_typing.is_empty_private_constants sideff.Evd.seff_private); + assert(Univ.ContextSet.is_empty ctx); + RetrieveObl.check_evars env sigma; + let c = EConstr.of_constr c in + let typ = match ce.Declare.proof_entry_type with + | Some t -> EConstr.of_constr t + | None -> Retyping.get_type_of env sigma c + in + let obls, _, c, cty = RetrieveObl.retrieve_obligations env name sigma 0 c typ in + let uctx = Evd.evar_universe_context sigma in + c, cty, uctx, obls -let prepare_parameter ~allow_evars ~poly ~udecl ~types sigma = - check_definition_evars ~allow_evars sigma; - let sigma, typ = Evarutil.finalize ~abort_on_undefined_evars:(not allow_evars) +let prepare_parameter ~poly ~udecl ~types sigma = + let env = Global.env () in + Pretyping.check_evars_are_solved ~program_mode:false env sigma; + let sigma, typ = Evarutil.finalize ~abort_on_undefined_evars:true sigma (fun nf -> nf types) in let univs = Evd.check_univ_decl ~poly sigma udecl in diff --git a/vernac/declareDef.mli b/vernac/declareDef.mli index 1d7fd3a3bf..3bc1e25f19 100644 --- a/vernac/declareDef.mli +++ b/vernac/declareDef.mli @@ -36,19 +36,44 @@ module Hook : sig end val make : (S.t -> unit) -> t - val call : ?hook:t -> ?fix_exn:Future.fix_exn -> S.t -> unit + val call : ?hook:t -> S.t -> unit end -val declare_definition +(** Declare an interactively-defined constant *) +val declare_entry : name:Id.t -> scope:locality -> kind:Decls.logical_kind - -> ?hook_data:(Hook.t * UState.t * (Id.t * Constr.t) list) - -> ubind:UnivNames.universe_binders + -> ?hook:Hook.t + -> ?obls:(Id.t * Constr.t) list -> impargs:Impargs.manual_implicits + -> uctx:UState.t -> Evd.side_effects Declare.proof_entry -> GlobRef.t +(** Declares a non-interactive constant; [body] and [types] will be + normalized w.r.t. the passed [evar_map] [sigma]. Universes should + be handled properly, including minimization and restriction. Note + that [sigma] is checked for unresolved evars, thus you should be + careful not to submit open terms or evar maps with stale, + unresolved existentials *) +val declare_definition + : name:Id.t + -> scope:locality + -> kind:Decls.logical_kind + -> opaque:bool + -> impargs:Impargs.manual_implicits + -> udecl:UState.universe_decl + -> ?hook:Hook.t + -> ?obls:(Id.t * Constr.t) list + -> poly:bool + -> ?inline:bool + -> types:EConstr.t option + -> body:EConstr.t + -> ?fix_exn:(Exninfo.iexn -> Exninfo.iexn) + -> Evd.evar_map + -> GlobRef.t + val declare_assumption : ?fix_exn:(Exninfo.iexn -> Exninfo.iexn) -> name:Id.t @@ -88,20 +113,19 @@ val declare_mutually_recursive -> Recthm.t list -> Names.GlobRef.t list -val prepare_definition - : allow_evars:bool - -> ?opaque:bool +val prepare_obligation + : ?opaque:bool -> ?inline:bool + -> name:Id.t -> poly:bool -> udecl:UState.universe_decl -> types:EConstr.t option -> body:EConstr.t -> Evd.evar_map - -> Evd.evar_map * Evd.side_effects Declare.proof_entry + -> Constr.constr * Constr.types * UState.t * RetrieveObl.obligation_info val prepare_parameter - : allow_evars:bool - -> poly:bool + : poly:bool -> udecl:UState.universe_decl -> types:EConstr.types -> Evd.evar_map diff --git a/vernac/declareInd.ml b/vernac/declareInd.ml index 2610f16d92..e22d63b811 100644 --- a/vernac/declareInd.ml +++ b/vernac/declareInd.ml @@ -49,9 +49,12 @@ let load_inductive i ((sp, kn), names) = let names = inductive_names sp kn names in List.iter (fun (sp, ref) -> Nametab.push (Nametab.Until i) sp ref ) names -let open_inductive i ((sp, kn), names) = +let open_inductive f i ((sp, kn), names) = let names = inductive_names sp kn names in - List.iter (fun (sp, ref) -> Nametab.push (Nametab.Exactly i) sp ref) names + List.iter (fun (sp, ref) -> + if Libobject.in_filter_ref ref f then + Nametab.push (Nametab.Exactly i) sp ref) + names let cache_inductive ((sp, kn), names) = let names = inductive_names sp kn names in @@ -93,38 +96,6 @@ let inPrim : (Projection.Repr.t * Constant.t) -> Libobject.obj = let declare_primitive_projection p c = Lib.add_anonymous_leaf (inPrim (p,c)) -let declare_one_projection univs (mind,_ as ind) ~proj_npars proj_arg label (term,types) = - let name = Label.to_id label in - let univs, u = match univs with - | Monomorphic_entry _ -> - (* Global constraints already defined through the inductive *) - Monomorphic_entry Univ.ContextSet.empty, Univ.Instance.empty - | Polymorphic_entry (nas, ctx) -> - Polymorphic_entry (nas, ctx), Univ.UContext.instance ctx - in - let term = Vars.subst_instance_constr u term in - let types = Vars.subst_instance_constr u types in - let entry = Declare.definition_entry ~types ~univs term in - let cst = Declare.declare_constant ~name ~kind:Decls.(IsDefinition StructureComponent) (Declare.DefinitionEntry entry) in - let p = Projection.Repr.make ind ~proj_npars ~proj_arg label in - declare_primitive_projection p cst - -let declare_projections univs mind = - let env = Global.env () in - let mib = Environ.lookup_mind mind env in - let open Declarations in - match mib.mind_record with - | PrimRecord info -> - let iter_ind i (_, labs, _, _) = - let ind = (mind, i) in - let projs = Inductiveops.compute_projections env ind in - CArray.iter2_i (declare_one_projection univs ind ~proj_npars:mib.mind_nparams) labs projs - in - let () = Array.iteri iter_ind info in - true - | FakeRecord -> false - | NotRecord -> false - let feedback_axiom () = Feedback.(feedback AddedAxiom) let is_unsafe_typing_flags () = @@ -146,7 +117,7 @@ let declare_mind mie = let (sp,kn as oname) = Lib.add_leaf id (inInductive { ind_names = names }) in if is_unsafe_typing_flags() then feedback_axiom (); let mind = Global.mind_of_delta_kn kn in - let isprim = declare_projections mie.mind_entry_universes mind in + let isprim = Inductive.is_primitive_record (Inductive.lookup_mind_specif (Global.env()) (mind,0)) in Impargs.declare_mib_implicits mind; declare_inductive_argument_scopes mind mie; oname, isprim diff --git a/vernac/declareInd.mli b/vernac/declareInd.mli index ae649634a5..05a1617329 100644 --- a/vernac/declareInd.mli +++ b/vernac/declareInd.mli @@ -30,3 +30,6 @@ type inductive_obj val objInductive : inductive_obj Libobject.Dyn.tag end + +val declare_primitive_projection : + Names.Projection.Repr.t -> Names.Constant.t -> unit diff --git a/vernac/declareObl.ml b/vernac/declareObl.ml index 98a9e4b9c9..bba3687256 100644 --- a/vernac/declareObl.ml +++ b/vernac/declareObl.ml @@ -362,34 +362,21 @@ let get_fix_exn, stm_get_fix_exn = Hook.make () let declare_definition prg = let varsubst = obligation_substitution true prg in - let body, typ = subst_prog varsubst prg in - let nf = - UnivSubst.nf_evars_and_universes_opt_subst - (fun x -> None) - (UState.subst prg.prg_ctx) - in - let opaque = prg.prg_opaque in + let sigma = Evd.from_ctx prg.prg_ctx in + let body, types = subst_prog varsubst prg in + let body, types = EConstr.(of_constr body, Some (of_constr types)) in + (* All these should be grouped into a struct a some point *) + let opaque, poly, udecl, hook = prg.prg_opaque, prg.prg_poly, prg.prg_univdecl, prg.prg_hook in + let name, scope, kind, impargs = prg.prg_name, prg.prg_scope, Decls.(IsDefinition prg.prg_kind), prg.prg_implicits in let fix_exn = Hook.get get_fix_exn () in - let typ = nf typ in - let body = nf body in - let obls = List.map (fun (id, (_, c)) -> (id, nf c)) varsubst in - let uvars = - Univ.LSet.union - (Vars.universes_of_constr typ) - (Vars.universes_of_constr body) - in - let uctx = UState.restrict prg.prg_ctx uvars in - let univs = - UState.check_univ_decl ~poly:prg.prg_poly uctx prg.prg_univdecl - in - let ce = Declare.definition_entry ~fix_exn ~opaque ~types:typ ~univs body in + let obls = List.map (fun (id, (_, c)) -> (id, c)) varsubst in + (* XXX: This is doing normalization twice *) let () = progmap_remove prg in - let ubind = UState.universe_binders uctx in - let hook_data = Option.map (fun hook -> hook, uctx, obls) prg.prg_hook in - DeclareDef.declare_definition - ~name:prg.prg_name ~scope:prg.prg_scope ~ubind - ~kind:Decls.(IsDefinition prg.prg_kind) ce - ~impargs:prg.prg_implicits ?hook_data + let kn = + DeclareDef.declare_definition ~name ~scope ~kind ~impargs ?hook ~obls + ~fix_exn ~opaque ~poly ~udecl ~types ~body sigma + in + kn let rec lam_index n t acc = match Constr.kind t with @@ -464,9 +451,8 @@ let declare_mutual_definition l = ~restrict_ucontext:false fixitems in (* Only for the first constant *) - let fix_exn = Hook.get get_fix_exn () in let dref = List.hd kns in - DeclareDef.Hook.(call ?hook:first.prg_hook ~fix_exn { S.uctx = first.prg_ctx; obls; scope; dref }); + DeclareDef.Hook.(call ?hook:first.prg_hook { S.uctx = first.prg_ctx; obls; scope; dref }); List.iter progmap_remove l; dref @@ -529,10 +515,6 @@ let obligation_terminator entries uctx { name; num; auto } = Inductiveops.control_only_guard (Global.env ()) sigma (EConstr.of_constr body); (* Declare the obligation ourselves and drop the hook *) let prg = CEphemeron.get (ProgMap.find name !from_prg) in - (* Ensure universes are substituted properly in body and type *) - let body = EConstr.to_constr sigma (EConstr.of_constr body) in - let ty = Option.map (fun x -> EConstr.to_constr sigma (EConstr.of_constr x)) ty in - let ctx = Evd.evar_universe_context sigma in let { obls; remaining=rem } = prg.prg_obligations in let obl = obls.(num) in let status = @@ -545,24 +527,24 @@ let obligation_terminator entries uctx { name; num; auto } = | (_, status), false -> status in let obl = { obl with obl_status = false, status } in - let ctx = - if prg.prg_poly then ctx - else UState.union prg.prg_ctx ctx + let uctx = + if prg.prg_poly then uctx + else UState.union prg.prg_ctx uctx in - let uctx = UState.univ_entry ~poly:prg.prg_poly ctx in - let (defined, obl) = declare_obligation prg obl body ty uctx in + let univs = UState.univ_entry ~poly:prg.prg_poly uctx in + let (defined, obl) = declare_obligation prg obl body ty univs in let prg_ctx = if prg.prg_poly then (* Polymorphic *) (* We merge the new universes and constraints of the polymorphic obligation with the existing ones *) - UState.union prg.prg_ctx ctx + UState.union prg.prg_ctx uctx else (* The first obligation, if defined, declares the univs of the constant, each subsequent obligation declares its own additional universes and constraints if any *) if defined then UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) - else ctx + else uctx in update_program_decl_on_defined prg obls num obl ~uctx:prg_ctx rem ~auto | _ -> diff --git a/vernac/declareUniv.ml b/vernac/declareUniv.ml index 300dfe6c35..89f3503f4d 100644 --- a/vernac/declareUniv.ml +++ b/vernac/declareUniv.ml @@ -56,7 +56,7 @@ let input_univ_names : universe_name_decl -> Libobject.obj = { (default_object "Global universe name state") with cache_function = cache_univ_names; load_function = load_univ_names; - open_function = open_univ_names; + open_function = simple_open open_univ_names; discharge_function = discharge_univ_names; subst_function = (fun (subst, a) -> (* Actually the name is generated once and for all. *) a); classify_function = (fun a -> Substitute a) } @@ -94,7 +94,7 @@ let do_universe ~poly l = in let src = if poly then BoundUniv else UnqualifiedUniv in let () = Lib.add_anonymous_leaf (input_univ_names (src, l)) in - Declare.declare_universe_context ~poly ctx + DeclareUctx.declare_universe_context ~poly ctx let do_constraint ~poly l = let open Univ in @@ -107,4 +107,4 @@ let do_constraint ~poly l = Constraint.empty l in let uctx = ContextSet.add_constraints constraints ContextSet.empty in - Declare.declare_universe_context ~poly uctx + DeclareUctx.declare_universe_context ~poly uctx diff --git a/vernac/declaremods.ml b/vernac/declaremods.ml index 4f527b73d0..50fa6052f6 100644 --- a/vernac/declaremods.ml +++ b/vernac/declaremods.ml @@ -81,6 +81,19 @@ module ModSubstObjs : let sobjs_no_functor (mbids,_) = List.is_empty mbids +let subst_filtered sub (f,mp) = + let f = match f with + | Unfiltered -> Unfiltered + | Names ns -> + let module NSet = Globnames.ExtRefSet in + let ns = + NSet.fold (fun n ns -> NSet.add (Globnames.subst_extended_reference sub n) ns) + ns NSet.empty + in + Names ns + in + f, subst_mp sub mp + let rec subst_aobjs sub = function | Objs o as objs -> let o' = subst_objects sub o in @@ -109,7 +122,7 @@ and subst_objects subst seg = let aobjs' = subst_aobjs subst aobjs in if aobjs' == aobjs then node else (id, IncludeObject aobjs') | ExportObject { mpl } -> - let mpl' = List.map (subst_mp subst) mpl in + let mpl' = List.Smart.map (subst_filtered subst) mpl in if mpl'==mpl then node else (id, ExportObject { mpl = mpl' }) | KeepObject _ -> assert false in @@ -285,86 +298,103 @@ and load_keep i ((sp,kn),kobjs) = (** {6 Implementation of Import and Export commands} *) -let mark_object obj (exports,acc) = - (exports, obj::acc) +let mark_object f obj (exports,acc) = + (exports, (f,obj)::acc) -let rec collect_module_objects mp acc = +let rec collect_module_objects (f,mp) acc = (* May raise Not_found for unknown module and for functors *) let modobjs = ModObjs.get mp in let prefix = modobjs.module_prefix in - let acc = collect_objects 1 prefix modobjs.module_keep_objects acc in - collect_objects 1 prefix modobjs.module_substituted_objects acc + let acc = collect_objects f 1 prefix modobjs.module_keep_objects acc in + collect_objects f 1 prefix modobjs.module_substituted_objects acc -and collect_object i (name, obj as o) acc = +and collect_object f i (name, obj as o) acc = match obj with - | ExportObject { mpl; _ } -> collect_export i mpl acc + | ExportObject { mpl } -> collect_export f i mpl acc | AtomicObject _ | IncludeObject _ | KeepObject _ - | ModuleObject _ | ModuleTypeObject _ -> mark_object o acc + | ModuleObject _ | ModuleTypeObject _ -> mark_object f o acc + +and collect_objects f i prefix objs acc = + List.fold_right (fun (id, obj) acc -> collect_object f i (Lib.make_oname prefix id, obj) acc) objs acc + +and collect_one_export f (f',mp) (exports,objs as acc) = + match filter_and f f' with + | None -> acc + | Some f -> + let exports' = MPmap.update mp (function + | None -> Some f + | Some f0 -> Some (filter_or f f0)) + exports + in + (* If the map doesn't change there is nothing new to export. -and collect_objects i prefix objs acc = - List.fold_right (fun (id, obj) acc -> collect_object i (Lib.make_oname prefix id, obj) acc) objs acc + It's possible that [filter_and] or [filter_or] mangled precise + filters such that we repeat uselessly, but the important + [Unfiltered] case is handled correctly. + *) + if exports == exports' then acc + else + collect_module_objects (f,mp) (exports', objs) -and collect_one_export mp (exports,objs as acc) = - if not (MPset.mem mp exports) then - collect_module_objects mp (MPset.add mp exports, objs) - else acc -and collect_export i mpl acc = +and collect_export f i mpl acc = if Int.equal i 1 then - List.fold_right collect_one_export mpl acc + List.fold_right (collect_one_export f) mpl acc else acc -let rec open_object i (name, obj) = +let open_modtype i ((sp,kn),_) = + let mp = mp_of_kn kn in + let mp' = + try Nametab.locate_modtype (qualid_of_path sp) + with Not_found -> + anomaly (pr_path sp ++ str " should already exist!"); + in + assert (ModPath.equal mp mp'); + Nametab.push_modtype (Nametab.Exactly i) sp mp + +let rec open_object f i (name, obj) = match obj with - | AtomicObject o -> Libobject.open_object i (name, o) + | AtomicObject o -> Libobject.open_object f i (name, o) | ModuleObject sobjs -> let dir = dir_of_sp (fst name) in let mp = mp_of_kn (snd name) in - open_module i dir mp sobjs + open_module f i dir mp sobjs | ModuleTypeObject sobjs -> open_modtype i (name, sobjs) - | IncludeObject aobjs -> open_include i (name, aobjs) - | ExportObject { mpl; _ } -> open_export i mpl - | KeepObject objs -> open_keep i (name, objs) + | IncludeObject aobjs -> open_include f i (name, aobjs) + | ExportObject { mpl } -> open_export f i mpl + | KeepObject objs -> open_keep f i (name, objs) -and open_module i obj_dir obj_mp sobjs = +and open_module f i obj_dir obj_mp sobjs = let prefix = Nametab.{ obj_dir ; obj_mp; } in let dirinfo = Nametab.GlobDirRef.DirModule prefix in consistency_checks true obj_dir dirinfo; - Nametab.push_dir (Nametab.Exactly i) obj_dir dirinfo; + (match f with + | Unfiltered -> Nametab.push_dir (Nametab.Exactly i) obj_dir dirinfo + | Names _ -> ()); (* If we're not a functor, let's iter on the internal components *) if sobjs_no_functor sobjs then begin let modobjs = ModObjs.get obj_mp in - open_objects (i+1) modobjs.module_prefix modobjs.module_substituted_objects + open_objects f (i+1) modobjs.module_prefix modobjs.module_substituted_objects end -and open_objects i prefix objs = - List.iter (fun (id, obj) -> open_object i (Lib.make_oname prefix id, obj)) objs - -and open_modtype i ((sp,kn),_) = - let mp = mp_of_kn kn in - let mp' = - try Nametab.locate_modtype (qualid_of_path sp) - with Not_found -> - anomaly (pr_path sp ++ str " should already exist!"); - in - assert (ModPath.equal mp mp'); - Nametab.push_modtype (Nametab.Exactly i) sp mp +and open_objects f i prefix objs = + List.iter (fun (id, obj) -> open_object f i (Lib.make_oname prefix id, obj)) objs -and open_include i ((sp,kn), aobjs) = +and open_include f i ((sp,kn), aobjs) = let obj_dir = Libnames.dirpath sp in let obj_mp = KerName.modpath kn in let prefix = Nametab.{ obj_dir; obj_mp; } in let o = expand_aobjs aobjs in - open_objects i prefix o + open_objects f i prefix o -and open_export i mpl = - let _,objs = collect_export i mpl (MPset.empty, []) in - List.iter (open_object 1) objs +and open_export f i mpl = + let _,objs = collect_export f i mpl (MPmap.empty, []) in + List.iter (fun (f,o) -> open_object f 1 o) objs -and open_keep i ((sp,kn),kobjs) = +and open_keep f i ((sp,kn),kobjs) = let obj_dir = dir_of_sp sp and obj_mp = mp_of_kn kn in let prefix = Nametab.{ obj_dir; obj_mp; } in - open_objects i prefix kobjs + open_objects f i prefix kobjs let rec cache_object (name, obj) = match obj with @@ -383,7 +413,7 @@ and cache_include ((sp,kn), aobjs) = let prefix = Nametab.{ obj_dir; obj_mp; } in let o = expand_aobjs aobjs in load_objects 1 prefix o; - open_objects 1 prefix o + open_objects Unfiltered 1 prefix o and cache_keep ((sp,kn),kobjs) = anomaly (Pp.str "This module should not be cached!") @@ -621,26 +651,28 @@ let mk_params_entry args = let mk_funct_type env args seb0 = List.fold_left - (fun seb (arg_id,arg_t,arg_inl) -> + (fun (seb,cst) (arg_id,arg_t,arg_inl) -> let mp = MPbound arg_id in - let arg_t = Mod_typing.translate_modtype env mp arg_inl ([],arg_t) in - MoreFunctor(arg_id,arg_t,seb)) + let arg_t, cst' = Mod_typing.translate_modtype env mp arg_inl ([],arg_t) in + MoreFunctor(arg_id,arg_t,seb), Univ.Constraint.union cst cst') seb0 args (** Prepare the module type list for check of subtypes *) let build_subtypes env mp args mtys = - let (cst, ans) = List.fold_left_map - (fun cst (m,ann) -> + let (ctx, ans) = List.fold_left_map + (fun ctx (m,ann) -> let inl = inl2intopt ann in - let mte, _, cst' = Modintern.interp_module_ast env Modintern.ModType m in - let env = Environ.push_context_set ~strict:true cst' env in - let cst = Univ.ContextSet.union cst cst' in - let mtb = Mod_typing.translate_modtype env mp inl ([],mte) in - cst, { mtb with mod_type = mk_funct_type env args mtb.mod_type }) + let mte, _, ctx' = Modintern.interp_module_ast env Modintern.ModType m in + let env = Environ.push_context_set ~strict:true ctx' env in + let ctx = Univ.ContextSet.union ctx ctx' in + let mtb, cst = Mod_typing.translate_modtype env mp inl ([],mte) in + let mod_type, cst = mk_funct_type env args (mtb.mod_type,cst) in + let ctx = Univ.ContextSet.add_constraints cst ctx in + ctx, { mtb with mod_type }) Univ.ContextSet.empty mtys in - (ans, cst) + (ans, ctx) (** {6 Current module information} @@ -673,23 +705,23 @@ module RawModOps = struct let start_module export id args res fs = let mp = Global.start_module id in - let arg_entries_r, cst = intern_args args in - let () = Global.push_context_set ~strict:true cst in + let arg_entries_r, ctx = intern_args args in + let () = Global.push_context_set ~strict:true ctx in let env = Global.env () in - let res_entry_o, subtyps, cst = match res with + let res_entry_o, subtyps, ctx = match res with | Enforce (res,ann) -> let inl = inl2intopt ann in - let (mte, _, cst) = Modintern.interp_module_ast env Modintern.ModType res in - let env = Environ.push_context_set ~strict:true cst env in + let (mte, _, ctx) = Modintern.interp_module_ast env Modintern.ModType res in + let env = Environ.push_context_set ~strict:true ctx env in (* We check immediately that mte is well-formed *) - let _, _, _, cst' = Mod_typing.translate_mse env None inl mte in - let cst = Univ.ContextSet.union cst cst' in - Some (mte, inl), [], cst + let _, _, _, cst = Mod_typing.translate_mse env None inl mte in + let ctx = Univ.ContextSet.add_constraints cst ctx in + Some (mte, inl), [], ctx | Check resl -> - let typs, cst = build_subtypes env mp arg_entries_r resl in - None, typs, cst + let typs, ctx = build_subtypes env mp arg_entries_r resl in + None, typs, ctx in - let () = Global.push_context_set ~strict:true cst in + let () = Global.push_context_set ~strict:true ctx in openmod_info := { cur_typ = res_entry_o; cur_typs = subtyps }; let prefix = Lib.start_module export id mp fs in Nametab.(push_dir (Until 1) (prefix.obj_dir) (GlobDirRef.DirOpenModule prefix)); @@ -733,37 +765,38 @@ let end_module () = mp +(* TODO cleanup push universes directly to global env *) let declare_module id args res mexpr_o fs = (* We simulate the beginning of an interactive module, then we adds the module parameters to the global env. *) let mp = Global.start_module id in - let arg_entries_r, cst = intern_args args in + let arg_entries_r, ctx = intern_args args in let params = mk_params_entry arg_entries_r in let env = Global.env () in - let env = Environ.push_context_set ~strict:true cst env in - let mty_entry_o, subs, inl_res, cst' = match res with + let env = Environ.push_context_set ~strict:true ctx env in + let mty_entry_o, subs, inl_res, ctx' = match res with | Enforce (mty,ann) -> let inl = inl2intopt ann in - let (mte, _, cst) = Modintern.interp_module_ast env Modintern.ModType mty in - let env = Environ.push_context_set ~strict:true cst env in + let (mte, _, ctx) = Modintern.interp_module_ast env Modintern.ModType mty in + let env = Environ.push_context_set ~strict:true ctx env in (* We check immediately that mte is well-formed *) - let _, _, _, cst' = Mod_typing.translate_mse env None inl mte in - let cst = Univ.ContextSet.union cst cst' in - Some mte, [], inl, cst + let _, _, _, cst = Mod_typing.translate_mse env None inl mte in + let ctx = Univ.ContextSet.add_constraints cst ctx in + Some mte, [], inl, ctx | Check mtys -> - let typs, cst = build_subtypes env mp arg_entries_r mtys in - None, typs, default_inline (), cst + let typs, ctx = build_subtypes env mp arg_entries_r mtys in + None, typs, default_inline (), ctx in - let env = Environ.push_context_set ~strict:true cst' env in - let cst = Univ.ContextSet.union cst cst' in - let mexpr_entry_o, inl_expr, cst' = match mexpr_o with + let env = Environ.push_context_set ~strict:true ctx' env in + let ctx = Univ.ContextSet.union ctx ctx' in + let mexpr_entry_o, inl_expr, ctx' = match mexpr_o with | None -> None, default_inline (), Univ.ContextSet.empty | Some (mexpr,ann) -> - let (mte, _, cst) = Modintern.interp_module_ast env Modintern.Module mexpr in - Some mte, inl2intopt ann, cst + let (mte, _, ctx) = Modintern.interp_module_ast env Modintern.Module mexpr in + Some mte, inl2intopt ann, ctx in - let env = Environ.push_context_set ~strict:true cst' env in - let cst = Univ.ContextSet.union cst cst' in + let env = Environ.push_context_set ~strict:true ctx' env in + let ctx = Univ.ContextSet.union ctx ctx' in let entry = match mexpr_entry_o, mty_entry_o with | None, None -> assert false (* No body, no type ... *) | None, Some typ -> MType (params, typ) @@ -782,7 +815,7 @@ let declare_module id args res mexpr_o fs = | None -> None | _ -> inl_res in - let () = Global.push_context_set ~strict:true cst in + let () = Global.push_context_set ~strict:true ctx in let mp_env,resolver = Global.add_module id entry inl in (* Name consistency check : kernel vs. library *) @@ -834,20 +867,20 @@ let declare_modtype id args mtys (mty,ann) fs = (* We simulate the beginning of an interactive module, then we adds the module parameters to the global env. *) let mp = Global.start_modtype id in - let arg_entries_r, cst = intern_args args in - let () = Global.push_context_set ~strict:true cst in + let arg_entries_r, ctx = intern_args args in + let () = Global.push_context_set ~strict:true ctx in let params = mk_params_entry arg_entries_r in let env = Global.env () in - let mte, _, cst = Modintern.interp_module_ast env Modintern.ModType mty in - let () = Global.push_context_set ~strict:true cst in + let mte, _, ctx = Modintern.interp_module_ast env Modintern.ModType mty in + let () = Global.push_context_set ~strict:true ctx in let env = Global.env () in (* We check immediately that mte is well-formed *) let _, _, _, cst = Mod_typing.translate_mse env None inl mte in - let () = Global.push_context_set ~strict:true cst in + let () = Global.push_context_set ~strict:true (Univ.LSet.empty,cst) in let env = Global.env () in let entry = params, mte in - let sub_mty_l, cst = build_subtypes env mp arg_entries_r mtys in - let () = Global.push_context_set ~strict:true cst in + let sub_mty_l, ctx = build_subtypes env mp arg_entries_r mtys in + let () = Global.push_context_set ~strict:true ctx in let env = Global.env () in let sobjs = get_functor_sobjs false env inl entry in let subst = map_mp (get_module_path (snd entry)) mp empty_delta_resolver in @@ -1023,12 +1056,12 @@ let end_library ?except ~output_native_objects dir = cenv,(substitute,keep),ast let import_modules ~export mpl = - let _,objs = List.fold_right collect_module_objects mpl (MPset.empty, []) in - List.iter (open_object 1) objs; + let _,objs = List.fold_right collect_module_objects mpl (MPmap.empty, []) in + List.iter (fun (f,o) -> open_object f 1 o) objs; if export then Lib.add_anonymous_entry (Lib.Leaf (ExportObject { mpl })) -let import_module ~export mp = - import_modules ~export [mp] +let import_module f ~export mp = + import_modules ~export [f,mp] (** {6 Iterators} *) @@ -1073,6 +1106,6 @@ let debug_print_modtab _ = let mod_ops = { - Printmod.import_module = import_module; + Printmod.import_module = import_module Unfiltered; process_module_binding = process_module_binding; } diff --git a/vernac/declaremods.mli b/vernac/declaremods.mli index e37299aad6..5e45957e83 100644 --- a/vernac/declaremods.mli +++ b/vernac/declaremods.mli @@ -97,11 +97,11 @@ val append_end_library_hook : (unit -> unit) -> unit or when [mp] corresponds to a functor. If [export] is [true], the module is also opened every time the module containing it is. *) -val import_module : export:bool -> ModPath.t -> unit +val import_module : Libobject.open_filter -> export:bool -> ModPath.t -> unit (** Same as [import_module] but for multiple modules, and more optimized than iterating [import_module]. *) -val import_modules : export:bool -> ModPath.t list -> unit +val import_modules : export:bool -> (Libobject.open_filter * ModPath.t) list -> unit (** Include *) diff --git a/vernac/g_proofs.mlg b/vernac/g_proofs.mlg index 247f80181a..e84fce5504 100644 --- a/vernac/g_proofs.mlg +++ b/vernac/g_proofs.mlg @@ -14,7 +14,7 @@ open Glob_term open Constrexpr open Vernacexpr open Hints -open Proof_global +open ComHints open Pcoq open Pcoq.Prim @@ -65,12 +65,12 @@ GRAMMAR EXTEND Gram | IDENT "Existential"; n = natural; c = constr_body -> { VernacSolveExistential (n,c) } | IDENT "Admitted" -> { VernacEndProof Admitted } - | IDENT "Qed" -> { VernacEndProof (Proved (Opaque,None)) } + | IDENT "Qed" -> { VernacEndProof (Proved (Declare.Opaque,None)) } | IDENT "Save"; id = identref -> - { VernacEndProof (Proved (Opaque, Some id)) } - | IDENT "Defined" -> { VernacEndProof (Proved (Transparent,None)) } + { VernacEndProof (Proved (Declare.Opaque, Some id)) } + | IDENT "Defined" -> { VernacEndProof (Proved (Declare.Transparent,None)) } | IDENT "Defined"; id=identref -> - { VernacEndProof (Proved (Transparent,Some id)) } + { VernacEndProof (Proved (Declare.Transparent,Some id)) } | IDENT "Restart" -> { VernacRestart } | IDENT "Undo" -> { VernacUndo 1 } | IDENT "Undo"; n = natural -> { VernacUndo n } diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index a8f1a49086..13145d3757 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -199,8 +199,8 @@ GRAMMAR EXTEND Gram VernacAssumption (stre, nl, bl) } | d = def_token; id = ident_decl; b = def_body -> { VernacDefinition (d, name_of_ident_decl id, b) } - | IDENT "Let"; id = identref; b = def_body -> - { VernacDefinition ((DoDischarge, Let), (lname_of_lident id, None), b) } + | IDENT "Let"; id = ident_decl; b = def_body -> + { VernacDefinition ((DoDischarge, Let), name_of_ident_decl id, b) } (* Gallina inductive declarations *) | f = finite_token; indl = LIST1 inductive_definition SEP "with" -> { VernacInductive (f, indl) } @@ -348,25 +348,11 @@ GRAMMAR EXTEND Gram (* Simple definitions *) def_body: [ [ bl = binders; ":="; red = reduce; c = lconstr -> - { if List.exists (function CLocalPattern _ -> true | _ -> false) bl - then - (* FIXME: "red" will be applied to types in bl and Cast with remain *) - let c = mkLambdaCN ~loc bl c in - DefineBody ([], red, c, None) - else - (match c with - | { CAst.v = CCast(c, CastConv t) } -> DefineBody (bl, red, c, Some t) - | _ -> DefineBody (bl, red, c, None)) } + { match c.CAst.v with + | CCast(c, Glob_term.CastConv t) -> DefineBody (bl, red, c, Some t) + | _ -> DefineBody (bl, red, c, None) } | bl = binders; ":"; t = lconstr; ":="; red = reduce; c = lconstr -> - { let ((bl, c), tyo) = - if List.exists (function CLocalPattern _ -> true | _ -> false) bl - then - (* FIXME: "red" will be applied to types in bl and Cast with remain *) - let c = CAst.make ~loc @@ CCast (c, CastConv t) in - (([],mkLambdaCN ~loc bl c), None) - else ((bl, c), Some t) - in - DefineBody (bl, red, c, tyo) } + { DefineBody (bl, red, c, Some t) } | bl = binders; ":"; t = lconstr -> { ProveBody (bl, t) } ] ] ; @@ -566,7 +552,6 @@ GRAMMAR EXTEND Gram { VernacDeclareModule (export, id, bl, mty) } (* Section beginning *) | IDENT "Section"; id = identref -> { VernacBeginSection id } - | IDENT "Chapter"; id = identref -> { VernacBeginSection id } (* This end a Section a Module or a Module Type *) | IDENT "End"; id = identref -> { VernacEndSegment id } @@ -581,14 +566,21 @@ GRAMMAR EXTEND Gram | IDENT "From" ; ns = global ; IDENT "Require"; export = export_token ; qidl = LIST1 global -> { VernacRequire (Some ns, export, qidl) } - | IDENT "Import"; qidl = LIST1 global -> { VernacImport (false,qidl) } - | IDENT "Export"; qidl = LIST1 global -> { VernacImport (true,qidl) } + | IDENT "Import"; qidl = LIST1 filtered_import -> { VernacImport (false,qidl) } + | IDENT "Export"; qidl = LIST1 filtered_import -> { VernacImport (true,qidl) } | IDENT "Include"; e = module_type_inl; l = LIST0 ext_module_expr -> { VernacInclude(e::l) } | IDENT "Include"; "Type"; e = module_type_inl; l = LIST0 ext_module_type -> { warn_deprecated_include_type ~loc (); VernacInclude(e::l) } ] ] ; + filtered_import: + [ [ m = global -> { (m, ImportAll) } + | m = global; "("; ns = LIST1 one_import_filter_name SEP ","; ")" -> { (m, ImportNames ns) } ] ] + ; + one_import_filter_name: + [ [ n = global; etc = OPT [ "("; ".."; ")" -> { () } ] -> { n, Option.has_some etc } ] ] + ; export_token: [ [ IDENT "Import" -> { Some false } | IDENT "Export" -> { Some true } @@ -709,17 +701,17 @@ GRAMMAR EXTEND Gram | IDENT "Canonical"; OPT [ IDENT "Structure" -> {()} ]; qid = global; ud = OPT [ u = OPT univ_decl; d = def_body -> { (u,d) } ] -> { match ud with | None -> - VernacCanonical CAst.(make ~loc @@ AN qid) + VernacCanonical CAst.(make ?loc:qid.CAst.loc @@ AN qid) | Some (u,d) -> let s = coerce_reference_to_id qid in - VernacDefinition ((NoDischarge,CanonicalStructure),((CAst.make (Name s)),u),d) } + VernacDefinition ((NoDischarge,CanonicalStructure),((CAst.make ?loc:qid.CAst.loc (Name s)),u),d) } | IDENT "Canonical"; OPT [ IDENT "Structure" -> {()} ]; ntn = by_notation -> { VernacCanonical CAst.(make ~loc @@ ByNotation ntn) } (* Coercions *) | IDENT "Coercion"; qid = global; u = OPT univ_decl; d = def_body -> { let s = coerce_reference_to_id qid in - VernacDefinition ((NoDischarge,Coercion),((CAst.make (Name s)),u),d) } + VernacDefinition ((NoDischarge,Coercion),((CAst.make ?loc:qid.CAst.loc (Name s)),u),d) } | IDENT "Identity"; IDENT "Coercion"; f = identref; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> { VernacIdentityCoercion (f, s, t) } @@ -946,23 +938,23 @@ GRAMMAR EXTEND Gram | IDENT "Print"; IDENT "Table"; table = option_table -> { VernacPrintOption table } - | IDENT "Add"; table = IDENT; field = IDENT; v = LIST1 option_ref_value + | IDENT "Add"; table = IDENT; field = IDENT; v = LIST1 table_value -> { VernacAddOption ([table;field], v) } (* A global value below will be hidden by a field above! *) (* In fact, we give priority to secondary tables *) (* No syntax for tertiary tables due to conflict *) (* (but they are unused anyway) *) - | IDENT "Add"; table = IDENT; v = LIST1 option_ref_value -> + | IDENT "Add"; table = IDENT; v = LIST1 table_value -> { VernacAddOption ([table], v) } - | IDENT "Test"; table = option_table; "for"; v = LIST1 option_ref_value + | IDENT "Test"; table = option_table; "for"; v = LIST1 table_value -> { VernacMemOption (table, v) } | IDENT "Test"; table = option_table -> { VernacPrintOption table } - | IDENT "Remove"; table = IDENT; field = IDENT; v= LIST1 option_ref_value + | IDENT "Remove"; table = IDENT; field = IDENT; v= LIST1 table_value -> { VernacRemoveOption ([table;field], v) } - | IDENT "Remove"; table = IDENT; v = LIST1 option_ref_value -> + | IDENT "Remove"; table = IDENT; v = LIST1 table_value -> { VernacRemoveOption ([table], v) } ]] ; query_command: (* TODO: rapprocher Eval et Check *) @@ -1055,9 +1047,9 @@ GRAMMAR EXTEND Gram | n = integer -> { OptionSetInt n } | s = STRING -> { OptionSetString s } ] ] ; - option_ref_value: - [ [ id = global -> { QualidRefValue id } - | s = STRING -> { StringRefValue s } ] ] + table_value: + [ [ id = global -> { Goptions.QualidRefValue id } + | s = STRING -> { Goptions.StringRefValue s } ] ] ; option_table: [ [ fl = LIST1 [ x = IDENT -> { x } ] -> { fl } ]] diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 5555a2c68e..41f2ab9c63 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -57,16 +57,16 @@ let contract3 env sigma a b c = match contract env sigma [a;b;c] with let contract4 env sigma a b c d = match contract env sigma [a;b;c;d] with | env, [a;b;c;d] -> (env,a,b,c),d | _ -> assert false -let contract1_vect env sigma a v = - match contract env sigma (a :: Array.to_list v) with - | env, a::l -> env,a,Array.of_list l +let contract1 env sigma a v = + match contract env sigma (a :: v) with + | env, a::l -> env,a,l | _ -> assert false let rec contract3' env sigma a b c = function | OccurCheck (evk,d) -> let x,d = contract4 env sigma a b c d in x,OccurCheck(evk, d) | NotClean ((evk,args),env',d) -> - let env',d,args = contract1_vect env' sigma d args in + let env',d,args = contract1 env' sigma d args in contract3 env sigma a b c,NotClean((evk,args),env',d) | ConversionFailed (env',t1,t2) -> let (env',t1,t2) = contract2 env' sigma t1 t2 in @@ -299,9 +299,9 @@ let explain_unification_error env sigma p1 p2 = function [str "cannot instantiate " ++ quote (pr_existential_key sigma evk) ++ strbrk " because " ++ pr_leconstr_env env sigma c ++ strbrk " is not in its scope" ++ - (if Array.is_empty args then mt() else + (if List.is_empty args then mt() else strbrk ": available arguments are " ++ - pr_sequence (pr_leconstr_env env sigma) (List.rev (Array.to_list args)))] + pr_sequence (pr_leconstr_env env sigma) (List.rev args))] | NotSameArgSize | NotSameHead | NoCanonicalStructure -> (* Error speaks from itself *) [] | ConversionFailed (env,t1,t2) -> @@ -729,9 +729,9 @@ let explain_undeclared_universe env sigma l = spc () ++ str "(maybe a bugged tactic)." let explain_disallowed_sprop () = - Pp.(strbrk "SProp not allowed, you need to " - ++ str "Set Allow StrictProp" - ++ strbrk " or to use the -allow-sprop command-line-flag.") + Pp.(strbrk "SProp is disallowed because the " + ++ str "\"Allow StrictProp\"" + ++ strbrk " flag is off.") let explain_bad_relevance env = strbrk "Bad relevance (maybe a bugged tactic)." diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index 7260b13ff6..6ffa88874b 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -91,12 +91,11 @@ let () = optwrite = (fun b -> rewriting_flag := b) } (* Util *) - let define ~poly name sigma c types = - let f = declare_constant ~kind:Decls.(IsDefinition Scheme) in let univs = Evd.univ_entry ~poly sigma in let entry = Declare.definition_entry ~univs ?types c in - let kn = f ~name (DefinitionEntry entry) in + let kind = Decls.(IsDefinition Scheme) in + let kn = declare_constant ~kind ~name (DefinitionEntry entry) in definition_message name; kn diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index e08d2ce117..b13e5bf653 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -27,15 +27,12 @@ module Proof_ending = struct | Regular | End_obligation of DeclareObl.obligation_qed_info | End_derive of { f : Id.t; name : Id.t } - | End_equations of { hook : Constant.t list -> Evd.evar_map -> unit - ; i : Id.t - ; types : (Environ.env * Evar.t * Evd.evar_info * EConstr.named_context * Evd.econstr) list - ; wits : EConstr.t list ref - (* wits are actually computed by the proof - engine by side-effect after creating the - proof! This is due to the start_dependent_proof API *) - ; sigma : Evd.evar_map - } + | End_equations of + { hook : Constant.t list -> Evd.evar_map -> unit + ; i : Id.t + ; types : (Environ.env * Evar.t * Evd.evar_info * EConstr.named_context * Evd.econstr) list + ; sigma : Evd.evar_map + } end @@ -43,22 +40,21 @@ module Info = struct type t = { hook : DeclareDef.Hook.t option - ; compute_guard : lemma_possible_guards - ; impargs : Impargs.manual_implicits ; proof_ending : Proof_ending.t CEphemeron.key (* This could be improved and the CEphemeron removed *) - ; other_thms : DeclareDef.Recthm.t list ; scope : DeclareDef.locality ; kind : Decls.logical_kind + (* thms and compute guard are specific only to start_lemma_with_initialization + regular terminator *) + ; thms : DeclareDef.Recthm.t list + ; compute_guard : lemma_possible_guards } let make ?hook ?(proof_ending=Proof_ending.Regular) ?(scope=DeclareDef.Global Declare.ImportDefaultBehavior) ?(kind=Decls.(IsProof Lemma)) () = { hook ; compute_guard = [] - ; impargs = [] ; proof_ending = CEphemeron.create proof_ending - ; other_thms = [] + ; thms = [] ; scope ; kind } @@ -66,14 +62,14 @@ end (* Proofs with a save constant function *) type t = - { proof : Proof_global.t + { proof : Declare.Proof.t ; info : Info.t } let pf_map f pf = { pf with proof = f pf.proof } let pf_fold f pf = f pf.proof -let set_endline_tactic t = pf_map (Proof_global.set_endline_tactic t) +let set_endline_tactic t = pf_map (Declare.Proof.set_endline_tactic t) (* To be removed *) module Internal = struct @@ -85,7 +81,7 @@ module Internal = struct end let by tac pf = - let proof, res = Pfedit.by tac pf.proof in + let proof, res = Declare.by tac pf.proof in { pf with proof }, res (************************************************************************) @@ -100,22 +96,34 @@ let initialize_named_context_for_proof () = let d = if Decls.variable_opacity id then NamedDecl.drop_body d else d in Environ.push_named_context_val d signv) sign Environ.empty_named_context_val +let add_first_thm ~info ~name ~typ ~impargs = + let thms = + { DeclareDef.Recthm.name + ; impargs + ; typ = EConstr.Unsafe.to_constr typ + ; args = [] } :: info.Info.thms + in + { info with Info.thms } + (* Starting a goal *) let start_lemma ~name ~poly ?(udecl=UState.default_univ_decl) - ?(info=Info.make ()) - sigma c = + ?(info=Info.make ()) ?(impargs=[]) sigma c = (* We remove the bodies of variables in the named context marked "opaque", this is a hack tho, see #10446 *) let sign = initialize_named_context_for_proof () in let goals = [ Global.env_of_context sign , c ] in - let proof = Proof_global.start_proof sigma ~name ~udecl ~poly goals in - { proof ; info } + let proof = Declare.start_proof sigma ~name ~udecl ~poly goals in + let info = add_first_thm ~info ~name ~typ:c ~impargs in + { proof; info } +(* Note that proofs opened by start_dependent lemma cannot be closed + by the regular terminators, thus we don't need to update the [thms] + field. We will capture this invariant by typing in the future *) let start_dependent_lemma ~name ~poly ?(udecl=UState.default_univ_decl) ?(info=Info.make ()) telescope = - let proof = Proof_global.start_dependent_proof ~name ~udecl ~poly telescope in + let proof = Declare.start_dependent_proof ~name ~udecl ~poly telescope in { proof; info } let rec_tac_initializer finite guard thms snl = @@ -153,18 +161,19 @@ let start_lemma_with_initialization ?hook ~poly ~scope ~kind ~udecl sigma recgua intro_tac (List.hd thms), [] in match thms with | [] -> CErrors.anomaly (Pp.str "No proof to start.") - | { DeclareDef.Recthm.name; typ; impargs; _}::other_thms -> + | { DeclareDef.Recthm.name; typ; impargs; _} :: thms -> let info = Info.{ hook - ; impargs ; compute_guard - ; other_thms ; proof_ending = CEphemeron.create Proof_ending.Regular + ; thms ; scope ; kind } in - let lemma = start_lemma ~name ~poly ~udecl ~info sigma (EConstr.of_constr typ) in - pf_map (Proof_global.map_proof (fun p -> + (* start_lemma has the responsibility to add (name, impargs, typ) + to thms, once Info.t is more refined this won't be necessary *) + let lemma = start_lemma ~name ~impargs ~poly ~udecl ~info sigma (EConstr.of_constr typ) in + pf_map (Declare.Proof.map_proof (fun p -> pi1 @@ Proof.run_tactic Global.(env ()) init_tac p)) lemma (************************************************************************) @@ -179,39 +188,19 @@ module MutualEntry : sig val declare_variable : info:Info.t -> uctx:UState.t - (* Only for the first constant, introduced by compat *) - -> ubind:UnivNames.universe_binders - -> name:Id.t -> Entries.parameter_entry -> Names.GlobRef.t list val declare_mutdef (* Common to all recthms *) : info:Info.t - -> ?fix_exn:(Exninfo.iexn -> Exninfo.iexn) -> uctx:UState.t - -> ?hook_data:DeclareDef.Hook.t * UState.t * (Names.Id.t * Constr.t) list - (* Only for the first constant, introduced by compat *) - -> ubind:UnivNames.universe_binders - -> name:Id.t -> Evd.side_effects Declare.proof_entry -> Names.GlobRef.t list end = struct - (* Body with the fix *) - type et = - | NoBody of Entries.parameter_entry - | Single of Evd.side_effects Declare.proof_entry - | Mutual of Evd.side_effects Declare.proof_entry - - type t = - { entry : et - ; info : Info.t - } - - (* XXX: Refactor this with the code in - [ComFixpoint.declare_fixpoint_generic] *) + (* XXX: Refactor this with the code in [DeclareDef.declare_mutdef] *) let guess_decreasing env possible_indexes ((body, ctx), eff) = let open Constr in match Constr.kind body with @@ -221,74 +210,55 @@ end = struct (mkFix ((indexes,0),fixdecls), ctx), eff | _ -> (body, ctx), eff - let adjust_guardness_conditions ~info const = - let entry = match info.Info.compute_guard with - | [] -> - (* Not a recursive statement *) - Single const - | possible_indexes -> - (* Try all combinations... not optimal *) - let env = Global.env() in - let pe = Declare.Internal.map_entry_body const - ~f:(guess_decreasing env possible_indexes) - in - Mutual pe - in { entry; info } - - let rec select_body i t = + let select_body i t = let open Constr in match Constr.kind t with | Fix ((nv,0),decls) -> mkFix ((nv,i),decls) | CoFix (0,decls) -> mkCoFix (i,decls) - | LetIn(na,t1,ty,t2) -> mkLetIn (na,t1,ty, select_body i t2) - | Lambda(na,ty,t) -> mkLambda(na,ty, select_body i t) - | App (t, args) -> mkApp (select_body i t, args) | _ -> CErrors.anomaly Pp.(str "Not a proof by induction: " ++ Termops.Internal.debug_print_constr (EConstr.of_constr t) ++ str ".") - let declare_mutdef ?fix_exn ~uctx ?hook_data ~ubind ~name ?typ ~impargs ~info mutpe i = - let { Info.hook; compute_guard; scope; kind; _ } = info in - match mutpe with - | NoBody pe -> - DeclareDef.declare_assumption ?fix_exn ~name ~scope ~hook ~impargs ~uctx pe - | Single pe -> - (* We'd like to do [assert (i = 0)] here, however this codepath - is used when declaring mutual cofixpoints *) - DeclareDef.declare_definition ~name ~scope ~kind ?hook_data ~ubind ~impargs pe - | Mutual pe -> - (* if typ = None , we don't touch the type; used in the base case *) - let pe = - match typ with - | None -> pe - | Some typ -> - Declare.Internal.map_entry_type pe ~f:(fun _ -> Some typ) - in - let pe = Declare.Internal.map_entry_body pe - ~f:(fun ((body, ctx), eff) -> (select_body i body, ctx), eff) in - DeclareDef.declare_definition ~name ~scope ~kind ?hook_data ~ubind ~impargs pe - - let declare_mutdef ?fix_exn ~uctx ?hook_data ~ubind ~name { entry; info } = - (* At some point make this a single iteration *) - (* At some point make this a single iteration *) - (* impargs here are special too, fixed in upcoming PRs *) - let impargs = info.Info.impargs in - let r = declare_mutdef ?fix_exn ~info ~ubind ?hook_data ~uctx ~name ~impargs entry 0 in - (* Before we used to do this, check if that's right *) - let ubind = UnivNames.empty_binders in - let rs = - List.map_i ( - fun i { DeclareDef.Recthm.name; typ; impargs } -> - declare_mutdef ?fix_exn ~name ~info ~ubind ?hook_data ~uctx ~typ ~impargs entry i) 1 info.Info.other_thms - in r :: rs - - let declare_variable ~info ~uctx ~ubind ~name pe = - declare_mutdef ~uctx ~ubind ~name { entry = NoBody pe; info } - - let declare_mutdef ~info ?fix_exn ~uctx ?hook_data ~ubind ~name const = - let mutpe = adjust_guardness_conditions ~info const in - declare_mutdef ?fix_exn ~uctx ?hook_data ~ubind ~name mutpe + let declare_mutdef ~uctx ~info pe i DeclareDef.Recthm.{ name; impargs; typ; _} = + let { Info.hook; scope; kind; compute_guard; _ } = info in + (* if i = 0 , we don't touch the type; this is for compat + but not clear it is the right thing to do. + *) + let pe, ubind = + if i > 0 && not (CList.is_empty compute_guard) + then Declare.Internal.map_entry_type pe ~f:(fun _ -> Some typ), UnivNames.empty_binders + else pe, UState.universe_binders uctx + in + (* We when compute_guard was [] in the previous step we should not + substitute the body *) + let pe = match compute_guard with + | [] -> pe + | _ -> + Declare.Internal.map_entry_body pe + ~f:(fun ((body, ctx), eff) -> (select_body i body, ctx), eff) + in + DeclareDef.declare_entry ~name ~scope ~kind ?hook ~impargs ~uctx pe + + let declare_mutdef ~info ~uctx const = + let pe = match info.Info.compute_guard with + | [] -> + (* Not a recursive statement *) + const + | possible_indexes -> + (* Try all combinations... not optimal *) + let env = Global.env() in + Declare.Internal.map_entry_body const + ~f:(guess_decreasing env possible_indexes) + in + List.map_i (declare_mutdef ~info ~uctx pe) 0 info.Info.thms + + let declare_variable ~info ~uctx pe = + let { Info.scope; hook } = info in + List.map_i ( + fun i { DeclareDef.Recthm.name; typ; impargs } -> + DeclareDef.declare_assumption ~name ~scope ~hook ~impargs ~uctx pe + ) 0 info.Info.thms end @@ -305,7 +275,7 @@ let get_keep_admitted_vars = let compute_proof_using_for_admitted proof typ pproofs = if not (get_keep_admitted_vars ()) then None - else match Proof_global.get_used_variables proof, pproofs with + else match Declare.Proof.get_used_variables proof, pproofs with | Some _ as x, _ -> x | None, pproof :: _ -> let env = Global.env () in @@ -316,64 +286,41 @@ let compute_proof_using_for_admitted proof typ pproofs = Some (Environ.really_needed env (Id.Set.union ids_typ ids_def)) | _ -> None -let finish_admitted ~name ~info ~uctx pe = - let ubind = UnivNames.empty_binders in - let _r : Names.GlobRef.t list = MutualEntry.declare_variable ~info ~uctx ~ubind ~name pe in +let finish_admitted ~info ~uctx pe = + let _r : Names.GlobRef.t list = MutualEntry.declare_variable ~info ~uctx pe in () let save_lemma_admitted ~(lemma : t) : unit = - let udecl = Proof_global.get_universe_decl lemma.proof in - let Proof.{ name; poly; entry } = Proof.data (Proof_global.get_proof lemma.proof) in + let udecl = Declare.Proof.get_universe_decl lemma.proof in + let Proof.{ poly; entry } = Proof.data (Declare.Proof.get_proof lemma.proof) in let typ = match Proofview.initial_goals entry with | [typ] -> snd typ | _ -> CErrors.anomaly ~label:"Lemmas.save_lemma_admitted" (Pp.str "more than one statement.") in let typ = EConstr.Unsafe.to_constr typ in - let proof = Proof_global.get_proof lemma.proof in + let proof = Declare.Proof.get_proof lemma.proof in let pproofs = Proof.partial_proof proof in let sec_vars = compute_proof_using_for_admitted lemma.proof typ pproofs in - let universes = Proof_global.get_initial_euctx lemma.proof in - let ctx = UState.check_univ_decl ~poly universes udecl in - finish_admitted ~name ~info:lemma.info ~uctx:universes (sec_vars, (typ, ctx), None) + let uctx = Declare.Proof.get_initial_euctx lemma.proof in + let univs = UState.check_univ_decl ~poly uctx udecl in + finish_admitted ~info:lemma.info ~uctx (sec_vars, (typ, univs), None) (************************************************************************) (* Saving a lemma-like constant *) (************************************************************************) -let default_thm_id = Id.of_string "Unnamed_thm" - -let check_anonymity id save_ident = - if not (String.equal (Nameops.atompart_of_id id) (Id.to_string (default_thm_id))) then - CErrors.user_err Pp.(str "This command can only be used for unnamed theorem.") - -let finish_proved idopt po info = - let open Proof_global in - let { Info.hook } = info in +let finish_proved po info = + let open Declare in match po with - | { name; entries=[const]; uctx; udecl } -> - let name = match idopt with - | None -> name - | Some { CAst.v = save_id } -> check_anonymity name save_id; save_id in - let fix_exn = Declare.Internal.get_fix_exn const in - let () = try - let hook_data = Option.map (fun hook -> hook, uctx, []) hook in - let ubind = UState.universe_binders uctx in - let _r : Names.GlobRef.t list = - MutualEntry.declare_mutdef ~info ~fix_exn ~uctx ?hook_data ~ubind ~name const - in () - with e when CErrors.noncritical e -> - let e = Exninfo.capture e in - Exninfo.iraise (fix_exn e) - in () + | { entries=[const]; uctx } -> + let _r : Names.GlobRef.t list = MutualEntry.declare_mutdef ~info ~uctx const in + () | _ -> CErrors.anomaly ~label:"finish_proved" Pp.(str "close_proof returned more than one proof term") -let finish_derived ~f ~name ~idopt ~entries = +let finish_derived ~f ~name ~entries = (* [f] and [name] correspond to the proof of [f] and of [suchthat], respectively. *) - if Option.has_some idopt then - CErrors.user_err Pp.(str "Cannot save a proof of Derive with an explicit name."); - let f_def, lemma_def = match entries with | [_;f_def;lemma_def] -> @@ -396,7 +343,7 @@ let finish_derived ~f ~name ~idopt ~entries = let lemma_pretype typ = match typ with | Some t -> Some (substf t) - | None -> assert false (* Proof_global always sets type here. *) + | None -> assert false (* Declare always sets type here. *) in (* The references of [f] are subsituted appropriately. *) let lemma_def = Declare.Internal.map_entry_type lemma_def ~f:lemma_pretype in @@ -406,11 +353,11 @@ let finish_derived ~f ~name ~idopt ~entries = let _ : Names.Constant.t = Declare.declare_constant ~name ~kind:Decls.(IsProof Proposition) lemma_def in () -let finish_proved_equations lid kind proof_obj hook i types wits sigma0 = +let finish_proved_equations ~kind ~hook i proof_obj types sigma0 = let obls = ref 1 in let sigma, recobls = - CList.fold_left2_map (fun sigma (wit, (evar_env, ev, evi, local_context, type_)) entry -> + CList.fold_left2_map (fun sigma (_evar_env, ev, _evi, local_context, _type) entry -> let id = match Evd.evar_ident ev sigma0 with | Some id -> id @@ -421,34 +368,51 @@ let finish_proved_equations lid kind proof_obj hook i types wits sigma0 = let sigma, app = Evarutil.new_global sigma (GlobRef.ConstRef cst) in let sigma = Evd.define ev (EConstr.applist (app, List.map EConstr.of_constr args)) sigma in sigma, cst) sigma0 - (CList.combine (List.rev !wits) types) proof_obj.Proof_global.entries + types proof_obj.Declare.entries in hook recobls sigma -let finalize_proof idopt proof_obj proof_info = - let open Proof_global in +let finalize_proof proof_obj proof_info = + let open Declare in let open Proof_ending in match CEphemeron.default proof_info.Info.proof_ending Regular with | Regular -> - finish_proved idopt proof_obj proof_info + finish_proved proof_obj proof_info | End_obligation oinfo -> DeclareObl.obligation_terminator proof_obj.entries proof_obj.uctx oinfo | End_derive { f ; name } -> - finish_derived ~f ~name ~idopt ~entries:proof_obj.entries - | End_equations { hook; i; types; wits; sigma } -> - finish_proved_equations idopt proof_info.Info.kind proof_obj hook i types wits sigma + finish_derived ~f ~name ~entries:proof_obj.entries + | End_equations { hook; i; types; sigma } -> + finish_proved_equations ~kind:proof_info.Info.kind ~hook i proof_obj types sigma + +let err_save_forbidden_in_place_of_qed () = + CErrors.user_err (Pp.str "Cannot use Save with more than one constant or in this proof mode") + +let process_idopt_for_save ~idopt info = + match idopt with + | None -> info + | Some { CAst.v = save_name } -> + (* Save foo was used; we override the info in the first theorem *) + let thms = + match info.Info.thms, CEphemeron.default info.Info.proof_ending Proof_ending.Regular with + | [ { DeclareDef.Recthm.name; _} as decl ], Proof_ending.Regular -> + [ { decl with DeclareDef.Recthm.name = save_name } ] + | _ -> + err_save_forbidden_in_place_of_qed () + in { info with Info.thms } let save_lemma_proved ~lemma ~opaque ~idopt = (* Env and sigma are just used for error printing in save_remaining_recthms *) - let proof_obj = Proof_global.close_proof ~opaque ~keep_body_ucst_separate:false (fun x -> x) lemma.proof in - finalize_proof idopt proof_obj lemma.info + let proof_obj = Declare.close_proof ~opaque ~keep_body_ucst_separate:false lemma.proof in + let proof_info = process_idopt_for_save ~idopt lemma.info in + finalize_proof proof_obj proof_info (***********************************************************************) (* Special case to close a lemma without forcing a proof *) (***********************************************************************) let save_lemma_admitted_delayed ~proof ~info = - let open Proof_global in - let { name; entries; uctx; udecl } = proof in + let open Declare in + let { entries; uctx } = proof in if List.length entries <> 1 then CErrors.user_err Pp.(str "Admitted does not support multiple statements"); let { Declare.proof_entry_secctx; proof_entry_type; proof_entry_universes } = List.hd entries in @@ -460,6 +424,14 @@ let save_lemma_admitted_delayed ~proof ~info = | Some typ -> typ in let ctx = UState.univ_entry ~poly uctx in let sec_vars = if get_keep_admitted_vars () then proof_entry_secctx else None in - finish_admitted ~name ~uctx ~info (sec_vars, (typ, ctx), None) - -let save_lemma_proved_delayed ~proof ~info ~idopt = finalize_proof idopt proof info + finish_admitted ~uctx ~info (sec_vars, (typ, ctx), None) + +let save_lemma_proved_delayed ~proof ~info ~idopt = + (* vio2vo calls this but with invalid info, we have to workaround + that to add the name to the info structure *) + if CList.is_empty info.Info.thms then + let info = add_first_thm ~info ~name:proof.Declare.name ~typ:EConstr.mkSet ~impargs:[] in + finalize_proof proof info + else + let info = process_idopt_for_save ~idopt info in + finalize_proof proof info diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index 6a1f8c09f3..bd2e87ac3a 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -19,10 +19,10 @@ type t val set_endline_tactic : Genarg.glob_generic_argument -> t -> t (** [set_endline_tactic tac lemma] set ending tactic for [lemma] *) -val pf_map : (Proof_global.t -> Proof_global.t) -> t -> t +val pf_map : (Declare.Proof.t -> Declare.Proof.t) -> t -> t (** [pf_map f l] map the underlying proof object *) -val pf_fold : (Proof_global.t -> 'a) -> t -> 'a +val pf_fold : (Declare.Proof.t -> 'a) -> t -> 'a (** [pf_fold f l] fold over the underlying proof object *) val by : unit Proofview.tactic -> t -> t * bool @@ -35,12 +35,12 @@ module Proof_ending : sig | Regular | End_obligation of DeclareObl.obligation_qed_info | End_derive of { f : Id.t; name : Id.t } - | End_equations of { hook : Constant.t list -> Evd.evar_map -> unit - ; i : Id.t - ; types : (Environ.env * Evar.t * Evd.evar_info * EConstr.named_context * Evd.econstr) list - ; wits : EConstr.t list ref - ; sigma : Evd.evar_map - } + | End_equations of + { hook : Constant.t list -> Evd.evar_map -> unit + ; i : Id.t + ; types : (Environ.env * Evar.t * Evd.evar_info * EConstr.named_context * Evd.econstr) list + ; sigma : Evd.evar_map + } end @@ -68,6 +68,7 @@ val start_lemma -> poly:bool -> ?udecl:UState.universe_decl -> ?info:Info.t + -> ?impargs:Impargs.manual_implicits -> Evd.evar_map -> EConstr.types -> t @@ -95,28 +96,26 @@ val start_lemma_with_initialization -> int list option -> t -val default_thm_id : Names.Id.t - (** {4 Saving proofs} *) val save_lemma_admitted : lemma:t -> unit val save_lemma_proved : lemma:t - -> opaque:Proof_global.opacity_flag + -> opaque:Declare.opacity_flag -> idopt:Names.lident option -> unit (** To be removed, don't use! *) module Internal : sig val get_info : t -> Info.t - (** Only needed due to the Proof_global compatibility layer. *) + (** Only needed due to the Declare compatibility layer. *) end (** Special cases for delayed proofs, in this case we must provide the proof information so the proof won't be forced. *) -val save_lemma_admitted_delayed : proof:Proof_global.proof_object -> info:Info.t -> unit +val save_lemma_admitted_delayed : proof:Declare.proof_object -> info:Info.t -> unit val save_lemma_proved_delayed - : proof:Proof_global.proof_object + : proof:Declare.proof_object -> info:Info.t -> idopt:Names.lident option -> unit diff --git a/vernac/library.ml b/vernac/library.ml index 7c629b08e7..85db501e84 100644 --- a/vernac/library.ml +++ b/vernac/library.ml @@ -20,11 +20,11 @@ open Libobject (*s Low-level interning/externing of libraries to files *) let raw_extern_library f = - System.raw_extern_state Coq_config.vo_magic_number f + ObjFile.open_out ~file:f let raw_intern_library f = System.with_magic_number_check - (System.raw_intern_state Coq_config.vo_magic_number) f + (fun file -> ObjFile.open_in ~file) f (************************************************************************) (** Serialized objects loaded on-the-fly *) @@ -35,7 +35,7 @@ module Delayed : sig type 'a delayed -val in_delayed : string -> in_channel -> 'a delayed * Digest.t +val in_delayed : string -> ObjFile.in_handle -> segment:string -> 'a delayed * Digest.t val fetch_delayed : 'a delayed -> 'a end = @@ -43,28 +43,32 @@ struct type 'a delayed = { del_file : string; - del_off : int; + del_off : int64; del_digest : Digest.t; } -let in_delayed f ch = - let pos = pos_in ch in - let _, digest = System.skip_in_segment f ch in - ({ del_file = f; del_digest = digest; del_off = pos; }, digest) +let in_delayed f ch ~segment = + let seg = ObjFile.get_segment ch ~segment in + let digest = seg.ObjFile.hash in + { del_file = f; del_digest = digest; del_off = seg.ObjFile.pos; }, digest (** Fetching a table of opaque terms at position [pos] in file [f], expecting to find first a copy of [digest]. *) let fetch_delayed del = let { del_digest = digest; del_file = f; del_off = pos; } = del in - try - let ch = raw_intern_library f in - let () = seek_in ch pos in - let obj, _, digest' = System.marshal_in_segment f ch in - let () = close_in ch in - if not (String.equal digest digest') then raise (Faulty f); - obj - with e when CErrors.noncritical e -> raise (Faulty f) + let ch = open_in_bin f in + let obj, digest' = + try + let () = LargeFile.seek_in ch pos in + let obj = System.marshal_in f ch in + let digest' = Digest.input ch in + obj, digest' + with e -> close_in ch; raise e + in + close_in ch; + if not (String.equal digest digest') then raise (Faulty f); + obj end @@ -92,7 +96,7 @@ type summary_disk = { type library_t = { library_name : compilation_unit_name; - library_data : library_disk delayed; + library_data : library_disk; library_deps : (compilation_unit_name * Safe_typing.vodigest) array; library_digests : Safe_typing.vodigest; library_extra_univs : Univ.ContextSet.t; @@ -155,11 +159,12 @@ let register_loaded_library m = let prefix = Nativecode.mod_uid_of_dirpath libname ^ "." in let f = prefix ^ "cmo" in let f = Dynlink.adapt_filename f in - if Coq_config.native_compiler then - Nativelib.link_library (Global.env()) ~prefix ~dirname ~basename:f + Nativelib.link_library (Global.env()) ~prefix ~dirname ~basename:f in let rec aux = function - | [] -> link (); [libname] + | [] -> + let () = if Flags.get_native_compiler () then link () in + [libname] | m'::_ as l when DirPath.equal m' libname -> l | m'::l' -> m' :: aux l' in libraries_loaded_list := aux !libraries_loaded_list; @@ -199,7 +204,7 @@ let access_table what tables dp i = with Faulty f -> user_err ~hdr:"Library.access_table" (str "The file " ++ str f ++ str " (bound to " ++ str dir_path ++ - str ") is inaccessible or corrupted,\ncannot load some " ++ + str ") is corrupted,\ncannot load some " ++ str what ++ str " in it.\n") in tables := DPmap.add dp (Fetched t) !tables; @@ -241,12 +246,11 @@ let mk_summary m = { let intern_from_file f = let ch = raw_intern_library f in - let (lsd : seg_sum), _, digest_lsd = System.marshal_in_segment f ch in - let ((lmd : seg_lib delayed), digest_lmd) = in_delayed f ch in - let (univs : seg_univ option), _, digest_u = System.marshal_in_segment f ch in - let _ = System.skip_in_segment f ch in - let ((del_opaque : seg_proofs delayed),_) = in_delayed f ch in - close_in ch; + let (lsd : seg_sum), digest_lsd = ObjFile.marshal_in_segment ch ~segment:"summary" in + let ((lmd : seg_lib), digest_lmd) = ObjFile.marshal_in_segment ch ~segment:"library" in + let (univs : seg_univ option), digest_u = ObjFile.marshal_in_segment ch ~segment:"universes" in + let ((del_opaque : seg_proofs delayed),_) = in_delayed f ch ~segment:"opaques" in + ObjFile.close_in ch; register_library_filename lsd.md_name f; add_opaque_table lsd.md_name (ToFetch del_opaque); let open Safe_typing in @@ -296,7 +300,7 @@ let rec_intern_library ~lib_resolver libs (dir, f) = let native_name_from_filename f = let ch = raw_intern_library f in - let (lmd : seg_sum), pos, digest_lmd = System.marshal_in_segment f ch in + let (lmd : seg_sum), digest_lmd = ObjFile.marshal_in_segment ch ~segment:"summary" in Nativecode.mod_uid_of_dirpath lmd.md_name (**********************************************************************) @@ -317,7 +321,7 @@ let native_name_from_filename f = *) let register_library m = - let l = fetch_delayed m.library_data in + let l = m.library_data in Declaremods.register_library m.library_name l.md_compiled @@ -334,7 +338,11 @@ let load_require _ (_,(needed,modl,_)) = List.iter register_library needed let open_require i (_,(_,modl,export)) = - Option.iter (fun export -> Declaremods.import_modules ~export @@ List.map (fun m -> MPfile m) modl) export + Option.iter (fun export -> + let mpl = List.map (fun m -> Unfiltered, MPfile m) modl in + (* TODO support filters in Require *) + Declaremods.import_modules ~export mpl) + export (* [needed] is the ordered list of libraries not already loaded *) let cache_require o = @@ -369,16 +377,17 @@ let require_library_from_dirpath ~lib_resolver modrefl export = let needed, contents = List.fold_left (rec_intern_library ~lib_resolver) ([], DPmap.empty) modrefl in let needed = List.rev_map (fun dir -> DPmap.find dir contents) needed in let modrefl = List.map fst modrefl in - if Lib.is_module_or_modtype () then - begin - warn_require_in_module (); - add_anonymous_leaf (in_require (needed,modrefl,None)); - Option.iter (fun export -> - List.iter (fun m -> Declaremods.import_module ~export (MPfile m)) modrefl) - export - end - else - add_anonymous_leaf (in_require (needed,modrefl,export)); + if Lib.is_module_or_modtype () then + begin + warn_require_in_module (); + add_anonymous_leaf (in_require (needed,modrefl,None)); + Option.iter (fun export -> + (* TODO import filters *) + List.iter (fun m -> Declaremods.import_module Unfiltered ~export (MPfile m)) modrefl) + export + end + else + add_anonymous_leaf (in_require (needed,modrefl,export)); () (************************************************************************) @@ -386,12 +395,12 @@ let require_library_from_dirpath ~lib_resolver modrefl export = let load_library_todo f = let ch = raw_intern_library f in - let (s0 : seg_sum), _, _ = System.marshal_in_segment f ch in - let (s1 : seg_lib), _, _ = System.marshal_in_segment f ch in - let (s2 : seg_univ option), _, _ = System.marshal_in_segment f ch in - let tasks, _, _ = System.marshal_in_segment f ch in - let (s4 : seg_proofs), _, _ = System.marshal_in_segment f ch in - close_in ch; + let (s0 : seg_sum), _ = ObjFile.marshal_in_segment ch ~segment:"summary" in + let (s1 : seg_lib), _ = ObjFile.marshal_in_segment ch ~segment:"library" in + let (s2 : seg_univ option), _ = ObjFile.marshal_in_segment ch ~segment:"universes" in + let tasks, _ = ObjFile.marshal_in_segment ch ~segment:"tasks" in + let (s4 : seg_proofs), _ = ObjFile.marshal_in_segment ch ~segment:"opaques" in + ObjFile.close_in ch; if tasks = None then user_err ~hdr:"restart" (str"not a .vio file"); if s2 = None then user_err ~hdr:"restart" (str"not a .vio file"); if snd (Option.get s2) then user_err ~hdr:"restart" (str"not a .vio file"); @@ -427,15 +436,15 @@ let error_recursively_dependent_library dir = let save_library_base f sum lib univs tasks proofs = let ch = raw_extern_library f in try - System.marshal_out_segment f ch (sum : seg_sum); - System.marshal_out_segment f ch (lib : seg_lib); - System.marshal_out_segment f ch (univs : seg_univ option); - System.marshal_out_segment f ch (tasks : 'tasks option); - System.marshal_out_segment f ch (proofs : seg_proofs); - close_out ch + ObjFile.marshal_out_segment ch ~segment:"summary" (sum : seg_sum); + ObjFile.marshal_out_segment ch ~segment:"library" (lib : seg_lib); + ObjFile.marshal_out_segment ch ~segment:"universes" (univs : seg_univ option); + ObjFile.marshal_out_segment ch ~segment:"tasks" (tasks : 'tasks option); + ObjFile.marshal_out_segment ch ~segment:"opaques" (proofs : seg_proofs); + ObjFile.close_out ch with reraise -> let reraise = Exninfo.capture reraise in - close_out ch; + ObjFile.close_out ch; Feedback.msg_warning (str "Removed file " ++ str f); Sys.remove f; Exninfo.iraise reraise diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 475d5c31f7..3b9c771b93 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -877,9 +877,12 @@ let subst_syntax_extension (subst, (local, (pa_sy,pp_sy))) = let classify_syntax_definition (local, _ as o) = if local then Dispose else Substitute o +let open_syntax_extension i o = + if Int.equal i 1 then cache_syntax_extension o + let inSyntaxExtension : syntax_extension_obj -> obj = declare_object {(default_object "SYNTAX-EXTENSION") with - open_function = (fun i o -> if Int.equal i 1 then cache_syntax_extension o); + open_function = simple_open open_syntax_extension; cache_function = cache_syntax_extension; subst_function = subst_syntax_extension; classify_function = classify_syntax_definition} @@ -1454,7 +1457,7 @@ let classify_notation nobj = let inNotation : notation_obj -> obj = declare_object {(default_object "NOTATION") with - open_function = open_notation; + open_function = simple_open open_notation; cache_function = cache_notation; subst_function = subst_notation; load_function = load_notation; @@ -1765,7 +1768,7 @@ let classify_scope_command (local, _, _ as o) = let inScopeCommand : locality_flag * scope_name * scope_command -> obj = declare_object {(default_object "DELIMITERS") with cache_function = cache_scope_command; - open_function = open_scope_command; + open_function = simple_open open_scope_command; load_function = load_scope_command; subst_function = subst_scope_command; classify_function = classify_scope_command} @@ -1831,7 +1834,7 @@ let classify_custom_entry (local,s as o) = let inCustomEntry : locality_flag * string -> obj = declare_object {(default_object "CUSTOM-ENTRIES") with cache_function = cache_custom_entry; - open_function = open_custom_entry; + open_function = simple_open open_custom_entry; load_function = load_custom_entry; subst_function = subst_custom_entry; classify_function = classify_custom_entry} diff --git a/vernac/obligations.ml b/vernac/obligations.ml index a29ba44907..060f069419 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -10,252 +10,16 @@ open Printf -(** - - Get types of existentials ; - - Flatten dependency tree (prefix order) ; - - Replace existentials by de Bruijn indices in term, applied to the right arguments ; - - Apply term prefixed by quantification on "existentials". -*) - -open Constr open Names open Pp open CErrors open Util -module NamedDecl = Context.Named.Declaration - (* For the records fields, opens should go away one these types are private *) open DeclareObl open DeclareObl.Obligation open DeclareObl.ProgramDecl -let succfix (depth, fixrels) = - (succ depth, List.map succ fixrels) - -let check_evars env evm = - Evar.Map.iter - (fun key evi -> - if Evd.is_obligation_evar evm key then () - else - let (loc,k) = Evd.evar_source key evm in - Pretype_errors.error_unsolvable_implicit ?loc env evm key None) - (Evd.undefined_map evm) - -type oblinfo = - { ev_name: int * Id.t; - ev_hyps: EConstr.named_context; - ev_status: bool * Evar_kinds.obligation_definition_status; - ev_chop: int option; - ev_src: Evar_kinds.t Loc.located; - ev_typ: types; - ev_tac: unit Proofview.tactic option; - ev_deps: Int.Set.t } - -(** Substitute evar references in t using de Bruijn indices, - where n binders were passed through. *) - -let subst_evar_constr evm evs n idf t = - let seen = ref Int.Set.empty in - let transparent = ref Id.Set.empty in - let evar_info id = List.assoc_f Evar.equal id evs in - let rec substrec (depth, fixrels) c = match EConstr.kind evm c with - | Evar (k, args) -> - let { ev_name = (id, idstr) ; - ev_hyps = hyps ; ev_chop = chop } = - try evar_info k - with Not_found -> - anomaly ~label:"eterm" (Pp.str "existential variable " ++ int (Evar.repr k) ++ str " not found.") - in - seen := Int.Set.add id !seen; - (* Evar arguments are created in inverse order, - and we must not apply to defined ones (i.e. LetIn's) - *) - let args = - let n = match chop with None -> 0 | Some c -> c in - let (l, r) = List.chop n (List.rev (Array.to_list args)) in - List.rev r - in - let args = - let rec aux hyps args acc = - let open Context.Named.Declaration in - match hyps, args with - (LocalAssum _ :: tlh), (c :: tla) -> - aux tlh tla ((substrec (depth, fixrels) c) :: acc) - | (LocalDef _ :: tlh), (_ :: tla) -> - aux tlh tla acc - | [], [] -> acc - | _, _ -> acc (*failwith "subst_evars: invalid argument"*) - in aux hyps args [] - in - if List.exists - (fun x -> match EConstr.kind evm x with - | Rel n -> Int.List.mem n fixrels - | _ -> false) args - then - transparent := Id.Set.add idstr !transparent; - EConstr.mkApp (idf idstr, Array.of_list args) - | Fix _ -> - EConstr.map_with_binders evm succfix substrec (depth, 1 :: fixrels) c - | _ -> EConstr.map_with_binders evm succfix substrec (depth, fixrels) c - in - let t' = substrec (0, []) t in - EConstr.to_constr evm t', !seen, !transparent - - -(** Substitute variable references in t using de Bruijn indices, - where n binders were passed through. *) -let subst_vars acc n t = - let var_index id = Util.List.index Id.equal id acc in - let rec substrec depth c = match Constr.kind c with - | Var v -> (try mkRel (depth + (var_index v)) with Not_found -> c) - | _ -> Constr.map_with_binders succ substrec depth c - in - substrec 0 t - -(** Rewrite type of an evar ([ H1 : t1, ... Hn : tn |- concl ]) - to a product : forall H1 : t1, ..., forall Hn : tn, concl. - Changes evars and hypothesis references to variable references. -*) -let etype_of_evar evm evs hyps concl = - let open Context.Named.Declaration in - let rec aux acc n = function - decl :: tl -> - let t', s, trans = subst_evar_constr evm evs n EConstr.mkVar (NamedDecl.get_type decl) in - let t'' = subst_vars acc 0 t' in - let rest, s', trans' = aux (NamedDecl.get_id decl :: acc) (succ n) tl in - let s' = Int.Set.union s s' in - let trans' = Id.Set.union trans trans' in - (match decl with - | LocalDef (id,c,_) -> - let c', s'', trans'' = subst_evar_constr evm evs n EConstr.mkVar c in - let c' = subst_vars acc 0 c' in - Term.mkNamedProd_or_LetIn (LocalDef (id, c', t'')) rest, - Int.Set.union s'' s', - Id.Set.union trans'' trans' - | LocalAssum (id,_) -> - Term.mkNamedProd_or_LetIn (LocalAssum (id, t'')) rest, s', trans') - | [] -> - let t', s, trans = subst_evar_constr evm evs n EConstr.mkVar concl in - subst_vars acc 0 t', s, trans - in aux [] 0 (List.rev hyps) - -let trunc_named_context n ctx = - let len = List.length ctx in - List.firstn (len - n) ctx - -let rec chop_product n t = - let pop t = Vars.lift (-1) t in - if Int.equal n 0 then Some t - else - match Constr.kind t with - | Prod (_, _, b) -> if Vars.noccurn 1 b then chop_product (pred n) (pop b) else None - | _ -> None - -let evar_dependencies evm oev = - let one_step deps = - Evar.Set.fold (fun ev s -> - let evi = Evd.find evm ev in - let deps' = Evd.evars_of_filtered_evar_info evm evi in - if Evar.Set.mem oev deps' then - invalid_arg ("Ill-formed evar map: cycle detected for evar " ^ Pp.string_of_ppcmds @@ Evar.print oev) - else Evar.Set.union deps' s) - deps deps - in - let rec aux deps = - let deps' = one_step deps in - if Evar.Set.equal deps deps' then deps - else aux deps' - in aux (Evar.Set.singleton oev) - -let move_after (id, ev, deps as obl) l = - let rec aux restdeps = function - | (id', _, _) as obl' :: tl -> - let restdeps' = Evar.Set.remove id' restdeps in - if Evar.Set.is_empty restdeps' then - obl' :: obl :: tl - else obl' :: aux restdeps' tl - | [] -> [obl] - in aux (Evar.Set.remove id deps) l - -let sort_dependencies evl = - let rec aux l found list = - match l with - | (id, ev, deps) as obl :: tl -> - let found' = Evar.Set.union found (Evar.Set.singleton id) in - if Evar.Set.subset deps found' then - aux tl found' (obl :: list) - else aux (move_after obl tl) found list - | [] -> List.rev list - in aux evl Evar.Set.empty [] - -let eterm_obligations env name evm fs ?status t ty = - (* 'Serialize' the evars *) - let nc = Environ.named_context env in - let nc_len = Context.Named.length nc in - let evm = Evarutil.nf_evar_map_undefined evm in - let evl = Evarutil.non_instantiated evm in - let evl = Evar.Map.bindings evl in - let evl = List.map (fun (id, ev) -> (id, ev, evar_dependencies evm id)) evl in - let sevl = sort_dependencies evl in - let evl = List.map (fun (id, ev, _) -> id, ev) sevl in - let evn = - let i = ref (-1) in - List.rev_map (fun (id, ev) -> incr i; - (id, (!i, Id.of_string - (Id.to_string name ^ "_obligation_" ^ string_of_int (succ !i))), - ev)) evl - in - let evts = - (* Remove existential variables in types and build the corresponding products *) - List.fold_right - (fun (id, (n, nstr), ev) l -> - let hyps = Evd.evar_filtered_context ev in - let hyps = trunc_named_context nc_len hyps in - let evtyp, deps, transp = etype_of_evar evm l hyps ev.Evd.evar_concl in - let evtyp, hyps, chop = - match chop_product fs evtyp with - | Some t -> t, trunc_named_context fs hyps, fs - | None -> evtyp, hyps, 0 - in - let loc, k = Evd.evar_source id evm in - let status = match k with - | Evar_kinds.QuestionMark { Evar_kinds.qm_obligation=o } -> o - | _ -> match status with - | Some o -> o - | None -> Evar_kinds.Define (not (Program.get_proofs_transparency ())) - in - let force_status, status, chop = match status with - | Evar_kinds.Define true as stat -> - if not (Int.equal chop fs) then true, Evar_kinds.Define false, None - else false, stat, Some chop - | s -> false, s, None - in - let info = { ev_name = (n, nstr); - ev_hyps = hyps; ev_status = force_status, status; ev_chop = chop; - ev_src = loc, k; ev_typ = evtyp ; ev_deps = deps; ev_tac = None } - in (id, info) :: l) - evn [] - in - let t', _, transparent = (* Substitute evar refs in the term by variables *) - subst_evar_constr evm evts 0 EConstr.mkVar t - in - let ty, _, _ = subst_evar_constr evm evts 0 EConstr.mkVar ty in - let evars = - List.map (fun (ev, info) -> - let { ev_name = (_, name); ev_status = force_status, status; - ev_src = src; ev_typ = typ; ev_deps = deps; ev_tac = tac } = info - in - let force_status, status = match status with - | Evar_kinds.Define true when Id.Set.mem name transparent -> - true, Evar_kinds.Define false - | _ -> force_status, status - in name, typ, src, (force_status, status), deps, tac) evts - in - let evnames = List.map (fun (ev, info) -> ev, snd info.ev_name) evts in - let evmap f c = pi1 (subst_evar_constr evm evts 0 f c) in - Array.of_list (List.rev evars), (evnames, evmap), t', ty - let pperror cmd = CErrors.user_err ~hdr:"Program" cmd let error s = pperror (str s) @@ -270,11 +34,6 @@ let explain_no_obligations = function Some ident -> str "No obligations for program " ++ Id.print ident | None -> str "No obligations remaining" -type obligation_info = - (Names.Id.t * types * Evar_kinds.t Loc.located * - (bool * Evar_kinds.obligation_definition_status) - * Int.Set.t * unit Proofview.tactic option) array - let assumption_message = Declare.assumption_message let default_tactic = ref (Proofview.tclUNIT ()) @@ -375,7 +134,7 @@ let solve_by_tac ?loc name evi t poly uctx = (* the status is dropped. *) let env = Global.env () in let body, types, _, uctx = - Pfedit.build_by_tactic env ~uctx ~poly ~typ:evi.evar_concl t in + Declare.build_by_tactic env ~uctx ~poly ~typ:evi.evar_concl t in Inductiveops.control_only_guard env (Evd.from_ctx uctx) (EConstr.of_constr body); Some (body, types, uctx) with @@ -571,12 +330,12 @@ let add_definition ~name ?term t ~uctx ?(udecl=UState.default_univ_decl) let add_mutual_definitions l ~uctx ?(udecl=UState.default_univ_decl) ?tactic ~poly ?(scope=DeclareDef.Global Declare.ImportDefaultBehavior) ?(kind=Decls.Definition) ?(reduce=reduce) ?hook ?(opaque = false) notations fixkind = - let deps = List.map (fun (n, b, t, imps, obls) -> n) l in + let deps = List.map (fun ({ DeclareDef.Recthm.name; _ }, _, _) -> name) l in List.iter - (fun (n, b, t, impargs, obls) -> - let prg = ProgramDecl.make ~opaque n ~udecl (Some b) t ~uctx deps (Some fixkind) + (fun ({ DeclareDef.Recthm.name; typ; impargs; _ }, b, obls) -> + let prg = ProgramDecl.make ~opaque name ~udecl (Some b) typ ~uctx deps (Some fixkind) notations obls ~impargs ~poly ~scope ~kind reduce ?hook - in progmap_add n (CEphemeron.create prg)) l; + in progmap_add name (CEphemeron.create prg)) l; let _defined = List.fold_left (fun finished x -> if finished then finished diff --git a/vernac/obligations.mli b/vernac/obligations.mli index 101958072a..f42d199e18 100644 --- a/vernac/obligations.mli +++ b/vernac/obligations.mli @@ -8,51 +8,73 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Environ open Constr -open Evd -open Names - -val check_evars : env -> evar_map -> unit - -val evar_dependencies : evar_map -> Evar.t -> Evar.Set.t -val sort_dependencies : (Evar.t * evar_info * Evar.Set.t) list -> (Evar.t * evar_info * Evar.Set.t) list - -(* ident, type, location, (opaque or transparent, expand or define), dependencies, tactic to solve it *) -type obligation_info = - (Id.t * types * Evar_kinds.t Loc.located * - (bool * Evar_kinds.obligation_definition_status) * Int.Set.t * unit Proofview.tactic option) array - -(* env, id, evars, number of function prototypes to try to clear from - evars contexts, object and type *) -val eterm_obligations - : env - -> Id.t - -> evar_map - -> int - -> ?status:Evar_kinds.obligation_definition_status - -> EConstr.constr - -> EConstr.types - -> obligation_info * - - (* Existential key, obl. name, type as product, location of the - original evar, associated tactic, status and dependencies as - indexes into the array *) - ((Evar.t * Id.t) list * ((Id.t -> EConstr.constr) -> EConstr.constr -> constr)) * - - (* Translations from existential identifiers to obligation - identifiers and for terms with existentials to closed terms, - given a translation from obligation identifiers to constrs, - new term, new type *) - constr * types + +(** Coq's Program mode support. This mode extends declarations of + constants and fixpoints with [Program Definition] and [Program + Fixpoint] to support incremental construction of terms using + delayed proofs, called "obligations" + + The mode also provides facilities for managing and auto-solving + sets of obligations. + + The basic code flow of programs/obligations is as follows: + + - [add_definition] / [add_mutual_definitions] are called from the + respective [Program] vernacular command interpretation; at this + point the only extra work we do is to prepare the new definition + [d] using [RetrieveObl], which consists in turning unsolved evars + into obligations. [d] is not sent to the kernel yet, as it is not + complete and cannot be typchecked, but saved in a special + data-structure. Auto-solving of obligations is tried at this stage + (see below) + + - [next_obligation] will retrieve the next obligation + ([RetrieveObl] sorts them by topological order) and will try to + solve it. When all obligations are solved, the original constant + [d] is grounded and sent to the kernel for addition to the global + environment. Auto-solving of obligations is also triggered on + obligation completion. + +{2} Solving of obligations: Solved obligations are stored as regular + global declarations in the global environment, usually with name + [constant_obligation_number] where [constant] is the original + [constant] and [number] is the corresponding (internal) number. + + Solving an obligation can trigger a bit of a complex cascaded + callback path; closing an obligation can indeed allow all other + obligations to be closed, which in turn may trigged the declaration + of the original constant. Care must be taken, as this can modify + [Global.env] in arbitrarily ways. Current code takes some care to + refresh the [env] in the proper boundaries, but the invariants + remain delicate. + +{2} Saving of obligations: as open obligations use the regular proof + mode, a `Qed` will call `Lemmas.save_lemma` first. For this reason + obligations code is split in two: this file, [Obligations], taking + care of the top-level vernac commands, and [DeclareObl], which is + called by `Lemmas` to close an obligation proof and eventually to + declare the top-level [Program]ed constant. + + There is little obligations-specific code in [DeclareObl], so + eventually that file should be integrated in the regular [Declare] + path, as it gains better support for "dependent_proofs". + + *) val default_tactic : unit Proofview.tactic ref -val add_definition - : name:Names.Id.t - -> ?term:constr -> types +(** Start a [Program Definition c] proof. [uctx] [udecl] [impargs] + [kind] [scope] [poly] etc... come from the interpretation of the + vernacular; `obligation_info` was generated by [RetrieveObl] It + will return whether all the obligations were solved; if so, it will + also register [c] with the kernel. *) +val add_definition : + name:Names.Id.t + -> ?term:constr + -> types -> uctx:UState.t - -> ?udecl:UState.universe_decl (* Universe binders and constraints *) + -> ?udecl:UState.universe_decl (** Universe binders and constraints *) -> ?impargs:Impargs.manual_implicits -> poly:bool -> ?scope:DeclareDef.locality @@ -61,52 +83,56 @@ val add_definition -> ?reduce:(constr -> constr) -> ?hook:DeclareDef.Hook.t -> ?opaque:bool - -> obligation_info + -> RetrieveObl.obligation_info -> DeclareObl.progress -val add_mutual_definitions - (* XXX: unify with MutualEntry *) - : (Names.Id.t * constr * types * Impargs.manual_implicits * obligation_info) list +(* XXX: unify with MutualEntry *) + +(** Start a [Program Fixpoint] declaration, similar to the above, + except it takes a list now. *) +val add_mutual_definitions : + (DeclareDef.Recthm.t * Constr.t * RetrieveObl.obligation_info) list -> uctx:UState.t - -> ?udecl:UState.universe_decl - (** Universe binders and constraints *) + -> ?udecl:UState.universe_decl (** Universe binders and constraints *) -> ?tactic:unit Proofview.tactic -> poly:bool -> ?scope:DeclareDef.locality -> ?kind:Decls.definition_object_kind -> ?reduce:(constr -> constr) - -> ?hook:DeclareDef.Hook.t -> ?opaque:bool + -> ?hook:DeclareDef.Hook.t + -> ?opaque:bool -> Vernacexpr.decl_notation list - -> DeclareObl.fixpoint_kind -> unit + -> DeclareObl.fixpoint_kind + -> unit -val obligation - : int * Names.Id.t option * Constrexpr.constr_expr option +(** Implementation of the [Obligation] command *) +val obligation : + int * Names.Id.t option * Constrexpr.constr_expr option -> Genarg.glob_generic_argument option -> Lemmas.t -val next_obligation - : Names.Id.t option - -> Genarg.glob_generic_argument option - -> Lemmas.t +(** Implementation of the [Next Obligation] command *) +val next_obligation : + Names.Id.t option -> Genarg.glob_generic_argument option -> Lemmas.t -val solve_obligations : Names.Id.t option -> unit Proofview.tactic option - -> DeclareObl.progress -(* Number of remaining obligations to be solved for this program *) +(** Implementation of the [Solve Obligation] command *) +val solve_obligations : + Names.Id.t option -> unit Proofview.tactic option -> DeclareObl.progress val solve_all_obligations : unit Proofview.tactic option -> unit -val try_solve_obligation : int -> Names.Id.t option -> unit Proofview.tactic option -> unit +(** Number of remaining obligations to be solved for this program *) +val try_solve_obligation : + int -> Names.Id.t option -> unit Proofview.tactic option -> unit -val try_solve_obligations : Names.Id.t option -> unit Proofview.tactic option -> unit +val try_solve_obligations : + Names.Id.t option -> unit Proofview.tactic option -> unit val show_obligations : ?msg:bool -> Names.Id.t option -> unit - val show_term : Names.Id.t option -> Pp.t - val admit_obligations : Names.Id.t option -> unit exception NoObligations of Names.Id.t option val explain_no_obligations : Names.Id.t option -> Pp.t - val check_program_libraries : unit -> unit diff --git a/vernac/pfedit.ml b/vernac/pfedit.ml new file mode 100644 index 0000000000..d6b9592176 --- /dev/null +++ b/vernac/pfedit.ml @@ -0,0 +1,9 @@ +(* Compat API / *) +let get_current_context = Declare.get_current_context +let solve = Proof.solve +let by = Declare.by +let refine_by_tactic = Proof.refine_by_tactic + +(* We don't want to export this anymore, but we do for now *) +let build_by_tactic = Declare.build_by_tactic +let build_constant_by_tactic = Declare.build_constant_by_tactic diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 054b60853f..f1aae239aa 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -86,7 +86,13 @@ open Pputils let pr_module = Libnames.pr_qualid - let pr_import_module = Libnames.pr_qualid + let pr_one_import_filter_name (q,etc) = + Libnames.pr_qualid q ++ if etc then str "(..)" else mt() + + let pr_import_module (m,f) = + Libnames.pr_qualid m ++ match f with + | ImportAll -> mt() + | ImportNames ns -> surround (prlist_with_sep pr_comma pr_one_import_filter_name ns) let sep_end = function | VernacBullet _ @@ -162,8 +168,8 @@ open Pputils keyword "Search" ++ spc() ++ prlist_with_sep spc pr_search sl ++ pr_in_out_modules b let pr_option_ref_value = function - | QualidRefValue id -> pr_qualid id - | StringRefValue s -> qs s + | Goptions.QualidRefValue id -> pr_qualid id + | Goptions.StringRefValue s -> qs s let pr_printoption table b = prlist_with_sep spc str table ++ @@ -179,7 +185,7 @@ open Pputils | [] -> mt() | _ as z -> str":" ++ spc() ++ prlist_with_sep sep str z - let pr_reference_or_constr pr_c = let open Hints in function + let pr_reference_or_constr pr_c = let open ComHints in function | HintsReference r -> pr_qualid r | HintsConstr c -> pr_c c @@ -196,6 +202,7 @@ open Pputils let opth = pr_opt_hintbases db in let pph = let open Hints in + let open ComHints in match h with | HintsResolve l -> keyword "Resolve " ++ prlist_with_sep sep @@ -785,7 +792,7 @@ let string_of_definition_object_kind = let open Decls in function return (keyword "Admitted") | VernacEndProof (Proved (opac,o)) -> return ( - let open Proof_global in + let open Declare in match o with | None -> (match opac with | Transparent -> keyword "Defined" diff --git a/vernac/proof_global.ml b/vernac/proof_global.ml new file mode 100644 index 0000000000..b6c07042e2 --- /dev/null +++ b/vernac/proof_global.ml @@ -0,0 +1,7 @@ +(* compatibility module; can be removed once we agree on the API *) + +type t = Declare.Proof.t +let map_proof = Declare.Proof.map_proof +let get_proof = Declare.Proof.get_proof + +type opacity_flag = Declare.opacity_flag = Opaque | Transparent diff --git a/vernac/pvernac.mli b/vernac/pvernac.mli index 4de12f5e3b..2b6beaf2e3 100644 --- a/vernac/pvernac.mli +++ b/vernac/pvernac.mli @@ -28,7 +28,7 @@ module Vernac_ : val command_entry : vernac_expr Entry.t val main_entry : vernac_control option Entry.t val red_expr : raw_red_expr Entry.t - val hint_info : Hints.hint_info_expr Entry.t + val hint_info : ComHints.hint_info_expr Entry.t end (* To be removed when the parser is made functional wrt the tactic diff --git a/vernac/record.ml b/vernac/record.ml index d974ead942..9fda98d08e 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -59,26 +59,37 @@ let () = optread = (fun () -> !typeclasses_unique); optwrite = (fun b -> typeclasses_unique := b); } -let interp_fields_evars env sigma impls_env nots l = - List.fold_left2 - (fun (env, sigma, uimpls, params, impls) no ({CAst.loc;v=i}, b, t) -> - let sigma, (t', impl) = interp_type_evars_impls ~program_mode:false env sigma ~impls t in - let r = Retyping.relevance_of_type env sigma t' in - let sigma, b' = - Option.cata (fun x -> on_snd (fun x -> Some (fst x)) @@ - interp_casted_constr_evars_impls ~program_mode:false env sigma ~impls x t') (sigma,None) b in - let impls = - match i with - | Anonymous -> impls - | Name id -> Id.Map.add id (compute_internalization_data env sigma Constrintern.Method t' impl) impls - in - let d = match b' with - | None -> LocalAssum (make_annot i r,t') - | Some b' -> LocalDef (make_annot i r,b',t') +let interp_fields_evars env sigma ~ninds ~nparams impls_env nots l = + let _, sigma, impls, newfs, _ = + List.fold_left2 + (fun (env, sigma, uimpls, params, impls) no ({CAst.loc;v=i}, b, t) -> + let sigma, (t', impl) = interp_type_evars_impls env sigma ~impls t in + let r = Retyping.relevance_of_type env sigma t' in + let sigma, b' = + Option.cata (fun x -> on_snd (fun x -> Some (fst x)) @@ + interp_casted_constr_evars_impls ~program_mode:false env sigma ~impls x t') (sigma,None) b in + let impls = + match i with + | Anonymous -> impls + | Name id -> Id.Map.add id (compute_internalization_data env sigma id Constrintern.Method t' impl) impls + in + let d = match b' with + | None -> LocalAssum (make_annot i r,t') + | Some b' -> LocalDef (make_annot i r,b',t') + in + List.iter (Metasyntax.set_notation_for_interpretation env impls) no; + (EConstr.push_rel d env, sigma, impl :: uimpls, d::params, impls)) + (env, sigma, [], [], impls_env) nots l + in + let _, sigma = Context.Rel.fold_outside ~init:(env,sigma) (fun f (env,sigma) -> + let sigma = RelDecl.fold_constr (fun c sigma -> + ComInductive.maybe_unify_params_in env sigma ~ninds ~nparams c) + f sigma in - List.iter (Metasyntax.set_notation_for_interpretation env impls) no; - (EConstr.push_rel d env, sigma, impl :: uimpls, d::params, impls)) - (env, sigma, [], [], impls_env) nots l + EConstr.push_rel f env, sigma) + newfs + in + sigma, (impls, newfs) let compute_constructor_level evars env l = List.fold_right (fun d (env, univ) -> @@ -103,7 +114,7 @@ let check_anonymous_type ind = | { CAst.v = CSort (Glob_term.UAnonymous {rigid=true}) } -> true | _ -> false -let typecheck_params_and_fields finite def poly pl ps records = +let typecheck_params_and_fields def poly pl ps records = let env0 = Global.env () in (* Special case elaboration for template-polymorphic inductives, lower bound on introduced universes is Prop so that we do not miss @@ -157,17 +168,15 @@ let typecheck_params_and_fields finite def poly pl ps records = let fold accu (id, _, _, _) arity r = EConstr.push_rel (LocalAssum (make_annot (Name id) r,arity)) accu in let env_ar = EConstr.push_rel_context newps (List.fold_left3 fold env0 records arities relevances) in - let assums = List.filter is_local_assum newps in let impls_env = - let params = List.map (RelDecl.get_name %> Name.get_id) assums in - let ty = Inductive (params, (finite != Declarations.BiFinite)) in let ids = List.map (fun (id, _, _, _) -> id) records in let imps = List.map (fun _ -> imps) arities in - compute_internalization_env env0 sigma ~impls:impls_env ty ids arities imps + compute_internalization_env env0 sigma ~impls:impls_env Inductive ids arities imps in + let ninds = List.length arities in + let nparams = List.length newps in let fold sigma (_, _, nots, fs) arity = - let _, sigma, impls, newfs, _ = interp_fields_evars env_ar sigma impls_env nots (binders_of_decls fs) in - (sigma, (impls, newfs)) + interp_fields_evars env_ar sigma ~ninds ~nparams impls_env nots (binders_of_decls fs) in let (sigma, data) = List.fold_left2_map fold sigma records arities in let sigma = @@ -311,67 +320,65 @@ let declare_projections indsp ctx ?(kind=Decls.StructureComponent) binder_name f let (_,_,kinds,sp_projs,_) = List.fold_left3 (fun (nfi,i,kinds,sp_projs,subst) flags decl impls -> - let fi = RelDecl.get_name decl in - let ti = RelDecl.get_type decl in - let (sp_projs,i,subst) = - match fi with - | Anonymous -> - (None::sp_projs,i,NoProjection fi::subst) - | Name fid -> try - let kn, term = - if is_local_assum decl && primitive then - let p = Projection.Repr.make indsp - ~proj_npars:mib.mind_nparams - ~proj_arg:i - (Label.of_id fid) - in - (* Already defined by declare_mind silently *) - let kn = Projection.Repr.constant p in - Declare.definition_message fid; - kn, mkProj (Projection.make p false,mkRel 1) - else - let ccl = subst_projection fid subst ti in - let body = match decl with - | LocalDef (_,ci,_) -> subst_projection fid subst ci - | LocalAssum ({binder_relevance=rci},_) -> - (* [ccl] is defined in context [params;x:rp] *) - (* [ccl'] is defined in context [params;x:rp;x:rp] *) - let ccl' = liftn 1 2 ccl in - let p = mkLambda (x, lift 1 rp, ccl') in - let branch = it_mkLambda_or_LetIn (mkRel nfi) lifted_fields in - let ci = Inductiveops.make_case_info env indsp rci LetStyle in - (* Record projections have no is *) - mkCase (ci, p, mkRel 1, [|branch|]) - in - let proj = - it_mkLambda_or_LetIn (mkLambda (x,rp,body)) paramdecls in - let projtyp = - it_mkProd_or_LetIn (mkProd (x,rp,ccl)) paramdecls in - try - let entry = Declare.definition_entry ~univs:ctx ~types:projtyp proj in - let kind = Decls.IsDefinition kind in - let kn = declare_constant ~name:fid ~kind (Declare.DefinitionEntry entry) in - let constr_fip = - let proj_args = (*Rel 1 refers to "x"*) paramargs@[mkRel 1] in - applist (mkConstU (kn,u),proj_args) - in - Declare.definition_message fid; - kn, constr_fip - with Type_errors.TypeError (ctx,te) -> - raise (NotDefinable (BadTypedProj (fid,ctx,te))) - in - let refi = GlobRef.ConstRef kn in - Impargs.maybe_declare_manual_implicits false refi impls; - if flags.pf_subclass then begin - let cl = ComCoercion.class_of_global (GlobRef.IndRef indsp) in - ComCoercion.try_add_new_coercion_with_source refi ~local:false ~poly ~source:cl - end; - let i = if is_local_assum decl then i+1 else i in - (Some kn::sp_projs, i, Projection term::subst) - with NotDefinable why -> - warning_or_error flags.pf_subclass indsp why; - (None::sp_projs,i,NoProjection fi::subst) in - (nfi - 1, i, { Recordops.pk_name = fi ; pk_true_proj = is_local_assum decl ; pk_canonical = flags.pf_canonical } :: kinds, sp_projs, subst)) + let fi = RelDecl.get_name decl in + let ti = RelDecl.get_type decl in + let (sp_projs,i,subst) = + match fi with + | Anonymous -> + (None::sp_projs,i,NoProjection fi::subst) + | Name fid -> + try + let ccl = subst_projection fid subst ti in + let body, p_opt = match decl with + | LocalDef (_,ci,_) -> subst_projection fid subst ci, None + | LocalAssum ({binder_relevance=rci},_) -> + (* [ccl] is defined in context [params;x:rp] *) + (* [ccl'] is defined in context [params;x:rp;x:rp] *) + if primitive then + let p = Projection.Repr.make indsp + ~proj_npars:mib.mind_nparams ~proj_arg:i (Label.of_id fid) in + mkProj (Projection.make p true, mkRel 1), Some p + else + let ccl' = liftn 1 2 ccl in + let p = mkLambda (x, lift 1 rp, ccl') in + let branch = it_mkLambda_or_LetIn (mkRel nfi) lifted_fields in + let ci = Inductiveops.make_case_info env indsp rci LetStyle in + (* Record projections have no is *) + mkCase (ci, p, mkRel 1, [|branch|]), None + in + let proj = it_mkLambda_or_LetIn (mkLambda (x,rp,body)) paramdecls in + let projtyp = it_mkProd_or_LetIn (mkProd (x,rp,ccl)) paramdecls in + let entry = Declare.definition_entry ~univs:ctx ~types:projtyp proj in + let kind = Decls.IsDefinition kind in + let kn = + try declare_constant ~name:fid ~kind (Declare.DefinitionEntry entry) + with Type_errors.TypeError (ctx,te) when not primitive -> + raise (NotDefinable (BadTypedProj (fid,ctx,te))) + in + Declare.definition_message fid; + let term = match p_opt with + | Some p -> + let _ = DeclareInd.declare_primitive_projection p kn in + mkProj (Projection.make p false,mkRel 1) + | None -> + let proj_args = (*Rel 1 refers to "x"*) paramargs@[mkRel 1] in + match decl with + | LocalDef (_,ci,_) when primitive -> body + | _ -> applist (mkConstU (kn,u),proj_args) + in + let refi = GlobRef.ConstRef kn in + Impargs.maybe_declare_manual_implicits false refi impls; + if flags.pf_subclass then begin + let cl = ComCoercion.class_of_global (GlobRef.IndRef indsp) in + ComCoercion.try_add_new_coercion_with_source refi ~local:false ~poly ~source:cl + end; + let i = if is_local_assum decl then i+1 else i in + (Some kn::sp_projs, i, Projection term::subst) + with NotDefinable why -> + warning_or_error flags.pf_subclass indsp why; + (None::sp_projs,i,NoProjection fi::subst) + in + (nfi - 1, i, { Recordops.pk_name = fi ; pk_true_proj = is_local_assum decl ; pk_canonical = flags.pf_canonical } :: kinds, sp_projs, subst)) (List.length fields,0,[],[],[]) flags (List.rev fields) (List.rev fieldimpls) in (kinds,sp_projs) @@ -702,7 +709,7 @@ let definition_structure udecl kind ~template ~cumulative ~poly finite records = let ps, data = extract_record_data records in let ubinders, univs, auto_template, params, implpars, data = States.with_state_protection (fun () -> - typecheck_params_and_fields finite (kind = Class true) poly udecl ps data) () in + typecheck_params_and_fields (kind = Class true) poly udecl ps data) () in let template = template, auto_template in match kind with | Class def -> diff --git a/vernac/retrieveObl.ml b/vernac/retrieveObl.ml new file mode 100644 index 0000000000..b8564037e0 --- /dev/null +++ b/vernac/retrieveObl.ml @@ -0,0 +1,296 @@ +(************************************************************************) +(* * 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 Names + +(** + - Get types of existentials ; + - Flatten dependency tree (prefix order) ; + - Replace existentials by de Bruijn indices in term, applied to the right arguments ; + - Apply term prefixed by quantification on "existentials". +*) + +let check_evars env evm = + Evar.Map.iter + (fun key evi -> + if Evd.is_obligation_evar evm key then () + else + let loc, k = Evd.evar_source key evm in + Pretype_errors.error_unsolvable_implicit ?loc env evm key None) + (Evd.undefined_map evm) + +type obligation_info = + ( Names.Id.t + * Constr.types + * Evar_kinds.t Loc.located + * (bool * Evar_kinds.obligation_definition_status) + * Int.Set.t + * unit Proofview.tactic option ) + array + +type oblinfo = + { ev_name : int * Id.t + ; ev_hyps : EConstr.named_context + ; ev_status : bool * Evar_kinds.obligation_definition_status + ; ev_chop : int option + ; ev_src : Evar_kinds.t Loc.located + ; ev_typ : Constr.types + ; ev_tac : unit Proofview.tactic option + ; ev_deps : Int.Set.t } + +(** Substitute evar references in t using de Bruijn indices, + where n binders were passed through. *) + +let succfix (depth, fixrels) = (succ depth, List.map succ fixrels) + +let subst_evar_constr evm evs n idf t = + let seen = ref Int.Set.empty in + let transparent = ref Id.Set.empty in + let evar_info id = CList.assoc_f Evar.equal id evs in + let rec substrec (depth, fixrels) c = + match EConstr.kind evm c with + | Constr.Evar (k, args) -> + let {ev_name = id, idstr; ev_hyps = hyps; ev_chop = chop} = + try evar_info k + with Not_found -> + CErrors.anomaly ~label:"eterm" + Pp.( + str "existential variable " + ++ int (Evar.repr k) + ++ str " not found.") + in + seen := Int.Set.add id !seen; + (* Evar arguments are created in inverse order, + and we must not apply to defined ones (i.e. LetIn's) + *) + let args = + let n = match chop with None -> 0 | Some c -> c in + let l, r = CList.chop n (List.rev args) in + List.rev r + in + let args = + let rec aux hyps args acc = + let open Context.Named.Declaration in + match (hyps, args) with + | LocalAssum _ :: tlh, c :: tla -> + aux tlh tla (substrec (depth, fixrels) c :: acc) + | LocalDef _ :: tlh, _ :: tla -> aux tlh tla acc + | [], [] -> acc + | _, _ -> acc + (*failwith "subst_evars: invalid argument"*) + in + aux hyps args [] + in + if + List.exists + (fun x -> + match EConstr.kind evm x with + | Constr.Rel n -> Int.List.mem n fixrels + | _ -> false) + args + then transparent := Id.Set.add idstr !transparent; + EConstr.mkApp (idf idstr, Array.of_list args) + | Constr.Fix _ -> + EConstr.map_with_binders evm succfix substrec (depth, 1 :: fixrels) c + | _ -> EConstr.map_with_binders evm succfix substrec (depth, fixrels) c + in + let t' = substrec (0, []) t in + (EConstr.to_constr evm t', !seen, !transparent) + +(** Substitute variable references in t using de Bruijn indices, + where n binders were passed through. *) +let subst_vars acc n t = + let var_index id = Util.List.index Id.equal id acc in + let rec substrec depth c = + match Constr.kind c with + | Constr.Var v -> ( + try Constr.mkRel (depth + var_index v) with Not_found -> c ) + | _ -> Constr.map_with_binders succ substrec depth c + in + substrec 0 t + +(** Rewrite type of an evar ([ H1 : t1, ... Hn : tn |- concl ]) + to a product : forall H1 : t1, ..., forall Hn : tn, concl. + Changes evars and hypothesis references to variable references. +*) +let etype_of_evar evm evs hyps concl = + let open Context.Named.Declaration in + let rec aux acc n = function + | decl :: tl -> ( + let t', s, trans = + subst_evar_constr evm evs n EConstr.mkVar + (Context.Named.Declaration.get_type decl) + in + let t'' = subst_vars acc 0 t' in + let rest, s', trans' = + aux (Context.Named.Declaration.get_id decl :: acc) (succ n) tl + in + let s' = Int.Set.union s s' in + let trans' = Id.Set.union trans trans' in + match decl with + | LocalDef (id, c, _) -> + let c', s'', trans'' = subst_evar_constr evm evs n EConstr.mkVar c in + let c' = subst_vars acc 0 c' in + ( Term.mkNamedProd_or_LetIn (LocalDef (id, c', t'')) rest + , Int.Set.union s'' s' + , Id.Set.union trans'' trans' ) + | LocalAssum (id, _) -> + (Term.mkNamedProd_or_LetIn (LocalAssum (id, t'')) rest, s', trans') ) + | [] -> + let t', s, trans = subst_evar_constr evm evs n EConstr.mkVar concl in + (subst_vars acc 0 t', s, trans) + in + aux [] 0 (List.rev hyps) + +let trunc_named_context n ctx = + let len = List.length ctx in + CList.firstn (len - n) ctx + +let rec chop_product n t = + let pop t = Vars.lift (-1) t in + if Int.equal n 0 then Some t + else + match Constr.kind t with + | Constr.Prod (_, _, b) -> + if Vars.noccurn 1 b then chop_product (pred n) (pop b) else None + | _ -> None + +let evar_dependencies evm oev = + let one_step deps = + Evar.Set.fold + (fun ev s -> + let evi = Evd.find evm ev in + let deps' = Evd.evars_of_filtered_evar_info evm evi in + if Evar.Set.mem oev deps' then + invalid_arg + ( "Ill-formed evar map: cycle detected for evar " + ^ Pp.string_of_ppcmds @@ Evar.print oev ) + else Evar.Set.union deps' s) + deps deps + in + let rec aux deps = + let deps' = one_step deps in + if Evar.Set.equal deps deps' then deps else aux deps' + in + aux (Evar.Set.singleton oev) + +let move_after ((id, ev, deps) as obl) l = + let rec aux restdeps = function + | ((id', _, _) as obl') :: tl -> + let restdeps' = Evar.Set.remove id' restdeps in + if Evar.Set.is_empty restdeps' then obl' :: obl :: tl + else obl' :: aux restdeps' tl + | [] -> [obl] + in + aux (Evar.Set.remove id deps) l + +let sort_dependencies evl = + let rec aux l found list = + match l with + | ((id, ev, deps) as obl) :: tl -> + let found' = Evar.Set.union found (Evar.Set.singleton id) in + if Evar.Set.subset deps found' then aux tl found' (obl :: list) + else aux (move_after obl tl) found list + | [] -> List.rev list + in + aux evl Evar.Set.empty [] + +let retrieve_obligations env name evm fs ?status t ty = + (* 'Serialize' the evars *) + let nc = Environ.named_context env in + let nc_len = Context.Named.length nc in + let evm = Evarutil.nf_evar_map_undefined evm in + let evl = Evarutil.non_instantiated evm in + let evl = Evar.Map.bindings evl in + let evl = List.map (fun (id, ev) -> (id, ev, evar_dependencies evm id)) evl in + let sevl = sort_dependencies evl in + let evl = List.map (fun (id, ev, _) -> (id, ev)) sevl in + let evn = + let i = ref (-1) in + List.rev_map + (fun (id, ev) -> + incr i; + ( id + , ( !i + , Id.of_string + (Id.to_string name ^ "_obligation_" ^ string_of_int (succ !i)) ) + , ev )) + evl + in + let evts = + (* Remove existential variables in types and build the corresponding products *) + List.fold_right + (fun (id, (n, nstr), ev) l -> + let hyps = Evd.evar_filtered_context ev in + let hyps = trunc_named_context nc_len hyps in + let evtyp, deps, transp = etype_of_evar evm l hyps ev.Evd.evar_concl in + let evtyp, hyps, chop = + match chop_product fs evtyp with + | Some t -> (t, trunc_named_context fs hyps, fs) + | None -> (evtyp, hyps, 0) + in + let loc, k = Evd.evar_source id evm in + let status = + match k with + | Evar_kinds.QuestionMark {Evar_kinds.qm_obligation = o} -> o + | _ -> ( + match status with + | Some o -> o + | None -> + Evar_kinds.Define (not (Program.get_proofs_transparency ())) ) + in + let force_status, status, chop = + match status with + | Evar_kinds.Define true as stat -> + if not (Int.equal chop fs) then (true, Evar_kinds.Define false, None) + else (false, stat, Some chop) + | s -> (false, s, None) + in + let info = + { ev_name = (n, nstr) + ; ev_hyps = hyps + ; ev_status = (force_status, status) + ; ev_chop = chop + ; ev_src = (loc, k) + ; ev_typ = evtyp + ; ev_deps = deps + ; ev_tac = None } + in + (id, info) :: l) + evn [] + in + let t', _, transparent = + (* Substitute evar refs in the term by variables *) + subst_evar_constr evm evts 0 EConstr.mkVar t + in + let ty, _, _ = subst_evar_constr evm evts 0 EConstr.mkVar ty in + let evars = + List.map + (fun (ev, info) -> + let { ev_name = _, name + ; ev_status = force_status, status + ; ev_src = src + ; ev_typ = typ + ; ev_deps = deps + ; ev_tac = tac } = + info + in + let force_status, status = + match status with + | Evar_kinds.Define true when Id.Set.mem name transparent -> + (true, Evar_kinds.Define false) + | _ -> (force_status, status) + in + (name, typ, src, (force_status, status), deps, tac)) + evts + in + let evnames = List.map (fun (ev, info) -> (ev, snd info.ev_name)) evts in + let evmap f c = Util.pi1 (subst_evar_constr evm evts 0 f c) in + (Array.of_list (List.rev evars), (evnames, evmap), t', ty) diff --git a/vernac/retrieveObl.mli b/vernac/retrieveObl.mli new file mode 100644 index 0000000000..c9c45bd889 --- /dev/null +++ b/vernac/retrieveObl.mli @@ -0,0 +1,46 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +val check_evars : Environ.env -> Evd.evar_map -> unit + +type obligation_info = + ( Names.Id.t + * Constr.types + * Evar_kinds.t Loc.located + * (bool * Evar_kinds.obligation_definition_status) + * Int.Set.t + * unit Proofview.tactic option ) + array +(** ident, type, location of the original evar, (opaque or + transparent, expand or define), dependencies as indexes into the + array, tactic to solve it *) + +val retrieve_obligations : + Environ.env + -> Names.Id.t + -> Evd.evar_map + -> int + -> ?status:Evar_kinds.obligation_definition_status + -> EConstr.t + -> EConstr.types + -> obligation_info + * ( (Evar.t * Names.Id.t) list + * ((Names.Id.t -> EConstr.t) -> EConstr.t -> Constr.t) ) + * Constr.t + * Constr.t +(** [retrieve_obligations env id sigma fs ?status body type] returns + [obls, (evnames, evmap), nbody, ntype] a list of obligations built + from evars in [body, type]. + + [fs] is the number of function prototypes to try to clear from + evars contexts. [evnames, evmap) is the list of names / + substitution functions used to program with holes. This is not used + in Coq, but in the equations plugin; [evnames] is actually + redundant with the information contained in [obls] *) diff --git a/vernac/search.ml b/vernac/search.ml index 68a30b4231..8b54b696f2 100644 --- a/vernac/search.ml +++ b/vernac/search.ml @@ -61,7 +61,7 @@ let iter_named_context_name_type f = let get_current_or_goal_context ?pstate glnum = match pstate with | None -> let env = Global.env () in Evd.(from_env env, env) - | Some p -> Pfedit.get_goal_context p glnum + | Some p -> Declare.get_goal_context p glnum (* General search over hypothesis of a goal *) let iter_hypothesis ?pstate glnum (fn : GlobRef.t -> env -> constr -> unit) = diff --git a/vernac/search.mli b/vernac/search.mli index 6dbbff3a8c..d3b8444b5f 100644 --- a/vernac/search.mli +++ b/vernac/search.mli @@ -38,13 +38,13 @@ val search_filter : glob_search_about_item -> filter_function goal and the global environment for things matching [pattern] and satisfying module exclude/include clauses of [modinout]. *) -val search_by_head : ?pstate:Proof_global.t -> int option -> constr_pattern -> DirPath.t list * bool +val search_by_head : ?pstate:Declare.Proof.t -> int option -> constr_pattern -> DirPath.t list * bool -> display_function -> unit -val search_rewrite : ?pstate:Proof_global.t -> int option -> constr_pattern -> DirPath.t list * bool +val search_rewrite : ?pstate:Declare.Proof.t -> int option -> constr_pattern -> DirPath.t list * bool -> display_function -> unit -val search_pattern : ?pstate:Proof_global.t -> int option -> constr_pattern -> DirPath.t list * bool +val search_pattern : ?pstate:Declare.Proof.t -> int option -> constr_pattern -> DirPath.t list * bool -> display_function -> unit -val search : ?pstate:Proof_global.t -> int option -> (bool * glob_search_about_item) list +val search : ?pstate:Declare.Proof.t -> int option -> (bool * glob_search_about_item) list -> DirPath.t list * bool -> display_function -> unit type search_constraint = @@ -65,12 +65,12 @@ type 'a coq_object = { coq_object_object : 'a; } -val interface_search : ?pstate:Proof_global.t -> ?glnum:int -> (search_constraint * bool) list -> +val interface_search : ?pstate:Declare.Proof.t -> ?glnum:int -> (search_constraint * bool) list -> constr coq_object list (** {6 Generic search function} *) -val generic_search : ?pstate:Proof_global.t -> int option -> display_function -> unit +val generic_search : ?pstate:Declare.Proof.t -> int option -> display_function -> unit (** This function iterates over all hypothesis of the goal numbered [glnum] (if present) and all known declarations. *) diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index 6e398d87ca..6d5d16d94a 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -9,11 +9,14 @@ Himsg Locality Egramml Vernacextend +Declare +ComHints Ppvernac Proof_using Egramcoq Metasyntax DeclareUniv +RetrieveObl DeclareDef DeclareObl Canonical @@ -43,3 +46,5 @@ ComArguments Vernacentries Vernacstate Vernacinterp +Proof_global +Pfedit diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 963b5f2084..df39c617d3 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -34,12 +34,12 @@ let (f_interp_redexp, interp_redexp_hook) = Hook.make () let get_current_or_global_context ~pstate = match pstate with | None -> let env = Global.env () in Evd.(from_env env, env) - | Some p -> Pfedit.get_current_context p + | Some p -> Declare.get_current_context p let get_goal_or_global_context ~pstate glnum = match pstate with | None -> let env = Global.env () in Evd.(from_env env, env) - | Some p -> Pfedit.get_goal_context p glnum + | Some p -> Declare.get_goal_context p glnum let cl_of_qualid = function | FunClass -> Coercionops.CL_FUN @@ -94,13 +94,13 @@ let show_proof ~pstate = (* spiwack: this would probably be cooler with a bit of polishing. *) try let pstate = Option.get pstate in - let p = Proof_global.get_proof pstate in - let sigma, env = Pfedit.get_current_context pstate in + let p = Declare.Proof.get_proof pstate in + let sigma, env = Declare.get_current_context pstate in let pprf = Proof.partial_proof p in Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf (* We print nothing if there are no goals left *) with - | Pfedit.NoSuchGoal + | Proof.NoSuchGoal _ | Option.IsNone -> user_err (str "No goals to show.") @@ -476,7 +476,7 @@ let program_inference_hook env sigma ev = then None else let c, _, _, ctx = - Pfedit.build_by_tactic ~poly:false env ~uctx:(Evd.evar_universe_context sigma) ~typ:concl tac + Declare.build_by_tactic ~poly:false env ~uctx:(Evd.evar_universe_context sigma) ~typ:concl tac in Some (Evd.set_universe_context sigma ctx, EConstr.of_constr c) with @@ -486,11 +486,14 @@ let program_inference_hook env sigma ev = let start_lemma_com ~program_mode ~poly ~scope ~kind ?hook thms = let env0 = Global.env () in + let flags = Pretyping.{ all_no_fail_flags with program_mode } in let decl = fst (List.hd thms) in let evd, udecl = Constrexpr_ops.interp_univ_decl_opt env0 (snd decl) in let evd, thms = List.fold_left_map (fun evd ((id, _), (bl, t)) -> - let evd, (impls, ((env, ctx), imps)) = Constrintern.interp_context_evars ~program_mode env0 evd bl in - let evd, (t', imps') = Constrintern.interp_type_evars_impls ~program_mode ~impls env evd t in + let evd, (impls, ((env, ctx), imps)) = + Constrintern.interp_context_evars ~program_mode env0 evd bl + in + let evd, (t', imps') = Constrintern.interp_type_evars_impls ~flags ~impls env evd t in let flags = Pretyping.{ all_and_fail_flags with program_mode } in let inference_hook = if program_mode then Some program_inference_hook else None in let evd = Pretyping.solve_remaining_evars ?hook:inference_hook flags env evd in @@ -527,8 +530,10 @@ let vernac_definition_hook ~canonical_instance ~local ~poly = let open Decls in Some (DeclareDef.Hook.(make (fun { S.dref } -> Canonical.declare_canonical_structure dref))) | _ -> None +let default_thm_id = Id.of_string "Unnamed_thm" + let fresh_name_for_anonymous_theorem () = - Namegen.next_global_ident_away Lemmas.default_thm_id Id.Set.empty + Namegen.next_global_ident_away default_thm_id Id.Set.empty let vernac_definition_name lid local = let lid = @@ -565,7 +570,9 @@ let vernac_definition ~atts (discharge, kind) (lid, pl) bl red_option c typ_opt let env = Global.env () in let sigma = Evd.from_env env in Some (snd (Hook.get f_interp_redexp env sigma r)) in - ComDefinition.do_definition ~program_mode ~name:name.v + let do_definition = + ComDefinition.(if program_mode then do_definition_program else do_definition) in + do_definition ~name:name.v ~poly:atts.polymorphic ~scope ~kind pl bl red_option c typ_opt ?hook (* NB: pstate argument to use combinators easily *) @@ -586,7 +593,7 @@ let vernac_exact_proof ~lemma c = (* spiwack: for simplicity I do not enforce that "Proof proof_term" is called only at the beginning of a proof. *) let lemma, status = Lemmas.by (Tactics.exact_proof c) lemma in - let () = Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Opaque ~idopt:None in + let () = Lemmas.save_lemma_proved ~lemma ~opaque:Declare.Opaque ~idopt:None in if not status then Feedback.feedback Feedback.AddedAxiom let vernac_assumption ~atts discharge kind l nl = @@ -865,12 +872,62 @@ let vernac_constraint ~poly l = (**********************) (* Modules *) +let add_subnames_of ns full_n n = + let open GlobRef in + let module NSet = Globnames.ExtRefSet in + let add1 r ns = NSet.add (Globnames.TrueGlobal r) ns in + match n with + | Globnames.SynDef _ | Globnames.TrueGlobal (ConstRef _ | ConstructRef _ | VarRef _) -> + CErrors.user_err Pp.(str "Only inductive types can be used with Import (...).") + | Globnames.TrueGlobal (IndRef (mind,i)) -> + let open Declarations in + let dp = Libnames.dirpath full_n in + let mib = Global.lookup_mind mind in + let mip = mib.mind_packets.(i) in + let ns = add1 (IndRef (mind,i)) ns in + let ns = Array.fold_left_i (fun j ns _ -> add1 (ConstructRef ((mind,i),j+1)) ns) + ns mip.mind_consnames + in + List.fold_left (fun ns f -> + let s = Indrec.elimination_suffix f in + let n_elim = Id.of_string (Id.to_string mip.mind_typename ^ s) in + match Nametab.extended_global_of_path (Libnames.make_path dp n_elim) with + | exception Not_found -> ns + | n_elim -> NSet.add n_elim ns) + ns Sorts.all_families + +let interp_filter_in m = function + | ImportAll -> Libobject.Unfiltered + | ImportNames ns -> + let module NSet = Globnames.ExtRefSet in + let dp_m = Nametab.dirpath_of_module m in + let ns = + List.fold_left (fun ns (n,etc) -> + let full_n = + let dp_n,n = repr_qualid n in + make_path (append_dirpath dp_m dp_n) n + in + let n = try Nametab.extended_global_of_path full_n + with Not_found -> + CErrors.user_err + Pp.(str "Cannot find name " ++ pr_qualid n ++ spc() ++ + str "in module " ++ pr_qualid (Nametab.shortest_qualid_of_module m)) + in + let ns = NSet.add n ns in + if etc then add_subnames_of ns full_n n else ns) + NSet.empty ns + in + Libobject.Names ns + let vernac_import export refl = - let import_mod qid = - try Declaremods.import_module ~export @@ Nametab.locate_module qid - with Not_found -> - CErrors.user_err Pp.(str "Cannot find module " ++ pr_qualid qid) - in + let import_mod (qid,f) = + let m = try Nametab.locate_module qid + with Not_found -> + CErrors.user_err Pp.(str "Cannot find module " ++ pr_qualid qid) + in + let f = interp_filter_in m f in + Declaremods.import_module f ~export m + in List.iter import_mod refl let vernac_declare_module export {loc;v=id} binders_ast mty_ast = @@ -886,7 +943,7 @@ let vernac_declare_module export {loc;v=id} binders_ast mty_ast = let mp = Declaremods.declare_module id binders_ast (Declaremods.Enforce mty_ast) [] in Dumpglob.dump_moddef ?loc mp "mod"; Flags.if_verbose Feedback.msg_info (str "Module " ++ Id.print id ++ str " is declared"); - Option.iter (fun export -> vernac_import export [qualid_of_ident id]) export + Option.iter (fun export -> vernac_import export [qualid_of_ident id, ImportAll]) export let vernac_define_module export {loc;v=id} (binders_ast : module_binder list) mty_ast_o mexpr_ast_l = (* We check the state of the system (in section, in module type) @@ -907,7 +964,7 @@ let vernac_define_module export {loc;v=id} (binders_ast : module_binder list) mt List.iter (fun (export,id) -> Option.iter - (fun export -> vernac_import export [qualid_of_ident id]) export + (fun export -> vernac_import export [qualid_of_ident id, ImportAll]) export ) argsexport | _::_ -> let binders_ast = List.map @@ -922,14 +979,14 @@ let vernac_define_module export {loc;v=id} (binders_ast : module_binder list) mt Dumpglob.dump_moddef ?loc mp "mod"; Flags.if_verbose Feedback.msg_info (str "Module " ++ Id.print id ++ str " is defined"); - Option.iter (fun export -> vernac_import export [qualid_of_ident id]) + Option.iter (fun export -> vernac_import export [qualid_of_ident id, ImportAll]) export let vernac_end_module export {loc;v=id} = let mp = Declaremods.end_module () in Dumpglob.dump_modref ?loc mp "mod"; Flags.if_verbose Feedback.msg_info (str "Module " ++ Id.print id ++ str " is defined"); - Option.iter (fun export -> vernac_import export [qualid_of_ident ?loc id]) export + Option.iter (fun export -> vernac_import export [qualid_of_ident ?loc id, ImportAll]) export let vernac_declare_module_type {loc;v=id} binders_ast mty_sign mty_ast_l = if Global.sections_are_opened () then @@ -950,7 +1007,7 @@ let vernac_declare_module_type {loc;v=id} binders_ast mty_sign mty_ast_l = List.iter (fun (export,id) -> Option.iter - (fun export -> vernac_import export [qualid_of_ident ?loc id]) export + (fun export -> vernac_import export [qualid_of_ident ?loc id, ImportAll]) export ) argsexport | _ :: _ -> @@ -1110,7 +1167,7 @@ let focus_command_cond = Proof.no_cond command_focus all tactics fail if there are no further goals to prove. *) let vernac_solve_existential ~pstate n com = - Proof_global.map_proof (fun p -> + Declare.Proof.map_proof (fun p -> let intern env sigma = Constrintern.intern_constr env sigma com in Proof.V82.instantiate_evar (Global.env ()) n intern p) pstate @@ -1118,12 +1175,12 @@ let vernac_set_end_tac ~pstate tac = let env = Genintern.empty_glob_sign (Global.env ()) in let _, tac = Genintern.generic_intern env tac in (* TO DO verifier s'il faut pas mettre exist s | TacId s ici*) - Proof_global.set_endline_tactic tac pstate + Declare.Proof.set_endline_tactic tac pstate -let vernac_set_used_variables ~pstate e : Proof_global.t = +let vernac_set_used_variables ~pstate e : Declare.Proof.t = let env = Global.env () in let initial_goals pf = Proofview.initial_goals Proof.(data pf).Proof.entry in - let tys = List.map snd (initial_goals (Proof_global.get_proof pstate)) in + let tys = List.map snd (initial_goals (Declare.Proof.get_proof pstate)) in let tys = List.map EConstr.Unsafe.to_constr tys in let l = Proof_using.process_expr env e tys in let vars = Environ.named_context env in @@ -1132,7 +1189,7 @@ let vernac_set_used_variables ~pstate e : Proof_global.t = user_err ~hdr:"vernac_set_used_variables" (str "Unknown variable: " ++ Id.print id)) l; - let _, pstate = Proof_global.set_used_variables pstate l in + let _, pstate = Declare.Proof.set_used_variables pstate l in pstate (*****************************) @@ -1218,7 +1275,7 @@ let vernac_hints ~atts dbnames h = "This command does not support the export attribute in sections."); | OptDefault | OptLocal -> () in - Hints.add_hints ~locality dbnames (Hints.interp_hints ~poly h) + Hints.add_hints ~locality dbnames (ComHints.interp_hints ~poly h) let vernac_syntactic_definition ~atts lid x only_parsing = let module_local, deprecation = Attributes.(parse Notations.(module_locality ++ deprecation) atts) in @@ -1244,16 +1301,26 @@ let vernac_generalizable ~local = let local = Option.default true local in Implicit_quantifiers.declare_generalizable ~local +let allow_sprop_opt_name = ["Allow";"StrictProp"] +let cumul_sprop_opt_name = ["Cumulative";"StrictProp"] + let () = declare_bool_option { optdepr = false; - optkey = ["Allow";"StrictProp"]; + optkey = allow_sprop_opt_name; optread = (fun () -> Global.sprop_allowed()); optwrite = Global.set_allow_sprop } let () = declare_bool_option { optdepr = false; + optkey = cumul_sprop_opt_name; + optread = Global.is_cumulative_sprop; + optwrite = Global.set_cumulative_sprop } + +let () = + declare_bool_option + { optdepr = false; optkey = ["Silent"]; optread = (fun () -> !Flags.quiet); optwrite = ((:=) Flags.quiet) } @@ -1429,41 +1496,20 @@ let () = optwrite = CWarnings.set_flags } let () = - declare_string_option - { optdepr = false; - optkey = ["NativeCompute"; "Profile"; "Filename"]; - optread = Nativenorm.get_profile_filename; - optwrite = Nativenorm.set_profile_filename } - -let () = - declare_bool_option - { optdepr = false; - optkey = ["NativeCompute"; "Profiling"]; - optread = Nativenorm.get_profiling_enabled; - optwrite = Nativenorm.set_profiling_enabled } - -let () = - declare_bool_option - { optdepr = false; - optkey = ["NativeCompute"; "Timing"]; - optread = Nativenorm.get_timing_enabled; - optwrite = Nativenorm.set_timing_enabled } - -let _ = declare_bool_option { optdepr = false; optkey = ["Guard"; "Checking"]; optread = (fun () -> (Global.typing_flags ()).Declarations.check_guarded); optwrite = (fun b -> Global.set_check_guarded b) } -let _ = +let () = declare_bool_option { optdepr = false; optkey = ["Positivity"; "Checking"]; optread = (fun () -> (Global.typing_flags ()).Declarations.check_positive); optwrite = (fun b -> Global.set_check_positive b) } -let _ = +let () = declare_bool_option { optdepr = false; optkey = ["Universe"; "Checking"]; @@ -1516,26 +1562,11 @@ let vernac_set_option ~locality table v = match v with vernac_set_option0 ~locality table v | _ -> vernac_set_option0 ~locality table v -let vernac_add_option key lv = - let f = function - | StringRefValue s -> (get_string_table key).add (Global.env()) s - | QualidRefValue locqid -> (get_ref_table key).add (Global.env()) locqid - in - try List.iter f lv with Not_found -> error_undeclared_key key +let vernac_add_option = iter_table { aux = fun table -> table.add } -let vernac_remove_option key lv = - let f = function - | StringRefValue s -> (get_string_table key).remove (Global.env()) s - | QualidRefValue locqid -> (get_ref_table key).remove (Global.env()) locqid - in - try List.iter f lv with Not_found -> error_undeclared_key key +let vernac_remove_option = iter_table { aux = fun table -> table.remove } -let vernac_mem_option key lv = - let f = function - | StringRefValue s -> (get_string_table key).mem (Global.env()) s - | QualidRefValue locqid -> (get_ref_table key).mem (Global.env()) locqid - in - try List.iter f lv with Not_found -> error_undeclared_key key +let vernac_mem_option = iter_table { aux = fun table -> table.mem } let vernac_print_option key = try (get_ref_table key).print () @@ -1551,8 +1582,8 @@ let get_current_context_of_args ~pstate = let env = Global.env () in Evd.(from_env env, env) | Some lemma -> function - | Some n -> Pfedit.get_goal_context lemma n - | None -> Pfedit.get_current_context lemma + | Some n -> Declare.get_goal_context lemma n + | None -> Declare.get_current_context lemma let query_command_selector ?loc = function | None -> None @@ -1617,7 +1648,7 @@ let vernac_global_check c = let get_nth_goal ~pstate n = - let pf = Proof_global.get_proof pstate in + let pf = Declare.Proof.get_proof pstate in let Proof.{goals;sigma} = Proof.data pf in let gl = {Evd.it=List.nth goals (n-1) ; sigma = sigma; } in gl @@ -1652,7 +1683,7 @@ let print_about_hyp_globs ~pstate ?loc ref_or_by_not udecl glopt = let natureofid = match decl with | LocalAssum _ -> "Hypothesis" | LocalDef (_,bdy,_) ->"Constant (let in)" in - let sigma, env = Pfedit.get_current_context pstate in + let sigma, env = Declare.get_current_context pstate in v 0 (Id.print id ++ str":" ++ pr_econstr_env env sigma (NamedDecl.get_type decl) ++ fnl() ++ fnl() ++ str natureofid ++ str " of the goal context.") with (* fallback to globals *) @@ -1696,7 +1727,8 @@ let vernac_print ~pstate ~atts = | PrintHintGoal -> begin match pstate with | Some pstate -> - Hints.pr_applicable_hint pstate + let pf = Declare.Proof.get_proof pstate in + Hints.pr_applicable_hint pf | None -> str "No proof in progress" end @@ -1855,7 +1887,7 @@ let vernac_register qid r = (* Proof management *) let vernac_focus ~pstate gln = - Proof_global.map_proof (fun p -> + Declare.Proof.map_proof (fun p -> match gln with | None -> Proof.focus focus_command_cond () 1 p | Some 0 -> @@ -1866,13 +1898,13 @@ let vernac_focus ~pstate gln = (* Unfocuses one step in the focus stack. *) let vernac_unfocus ~pstate = - Proof_global.map_proof + Declare.Proof.map_proof (fun p -> Proof.unfocus command_focus p ()) pstate (* Checks that a proof is fully unfocused. Raises an error if not. *) let vernac_unfocused ~pstate = - let p = Proof_global.get_proof pstate in + let p = Declare.Proof.get_proof pstate in if Proof.unfocused p then str"The proof is indeed fully unfocused." else @@ -1885,7 +1917,7 @@ let subproof_kind = Proof.new_focus_kind () let subproof_cond = Proof.done_cond subproof_kind let vernac_subproof gln ~pstate = - Proof_global.map_proof (fun p -> + Declare.Proof.map_proof (fun p -> match gln with | None -> Proof.focus subproof_cond () 1 p | Some (Goal_select.SelectNth n) -> Proof.focus subproof_cond () n p @@ -1895,12 +1927,12 @@ let vernac_subproof gln ~pstate = pstate let vernac_end_subproof ~pstate = - Proof_global.map_proof (fun p -> + Declare.Proof.map_proof (fun p -> Proof.unfocus subproof_kind p ()) pstate let vernac_bullet (bullet : Proof_bullet.t) ~pstate = - Proof_global.map_proof (fun p -> + Declare.Proof.map_proof (fun p -> Proof_bullet.put p bullet) pstate (* Stack is needed due to show proof names, should deprecate / remove @@ -1917,7 +1949,7 @@ let vernac_show ~pstate = end (* Show functions that require a proof state *) | Some pstate -> - let proof = Proof_global.get_proof pstate in + let proof = Declare.Proof.get_proof pstate in begin function | ShowGoal goalref -> begin match goalref with @@ -1929,14 +1961,14 @@ let vernac_show ~pstate = | ShowUniverses -> show_universes ~proof (* Deprecate *) | ShowProofNames -> - Id.print (Proof_global.get_proof_name pstate) + Id.print (Declare.Proof.get_proof_name pstate) | ShowIntros all -> show_intro ~proof all | ShowProof -> show_proof ~pstate:(Some pstate) | ShowMatch id -> show_match id end let vernac_check_guard ~pstate = - let pts = Proof_global.get_proof pstate in + let pts = Declare.Proof.get_proof pstate in let pfterm = List.hd (Proof.partial_proof pts) in let message = try diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index f5cf9702cd..cf233248d7 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -24,3 +24,6 @@ val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Genredexpr.raw_red_expr (** Miscellaneous stuff *) val command_focus : unit Proof.focus_kind + +val allow_sprop_opt_name : string list +val cumul_sprop_opt_name : string list diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index d6e7a3947a..b65a0da1cc 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -101,7 +101,14 @@ type verbose_flag = bool (* true = Verbose; false = Silent *) type coercion_flag = bool (* true = AddCoercion false = NoCoercion *) type instance_flag = bool option (* Some true = Backward instance; Some false = Forward instance, None = NoInstance *) + type export_flag = bool (* true = Export; false = Import *) + +type one_import_filter_name = qualid * bool (* import inductive components *) +type import_filter_expr = + | ImportAll + | ImportNames of one_import_filter_name list + type onlyparsing_flag = { onlyparsing : bool } (* Some v = Parse only; None = Print also. If v<>Current, it contains the name of the coq version @@ -114,10 +121,6 @@ type option_setting = | OptionSetInt of int | OptionSetString of string -type option_ref_value = - | StringRefValue of string - | QualidRefValue of qualid - (** Identifier and optional list of bound universes and constraints. *) type sort_expr = Sorts.family @@ -195,7 +198,7 @@ type syntax_modifier = type proof_end = | Admitted (* name in `Save ident` when closing goal *) - | Proved of Proof_global.opacity_flag * lident option + | Proved of Declare.opacity_flag * lident option type scheme = | InductionScheme of bool * qualid or_by_notation * sort_expr @@ -320,7 +323,7 @@ type nonrec vernac_expr = | VernacEndSegment of lident | VernacRequire of qualid option * export_flag option * qualid list - | VernacImport of export_flag * qualid list + | VernacImport of export_flag * (qualid * import_filter_expr) list | VernacCanonical of qualid or_by_notation | VernacCoercion of qualid or_by_notation * class_rawexpr * class_rawexpr @@ -333,18 +336,18 @@ type nonrec vernac_expr = local_binder_expr list * (* binders *) constr_expr * (* type *) (bool * constr_expr) option * (* body (bool=true when using {}) *) - Hints.hint_info_expr + ComHints.hint_info_expr | VernacDeclareInstance of ident_decl * (* name *) local_binder_expr list * (* binders *) constr_expr * (* type *) - Hints.hint_info_expr + ComHints.hint_info_expr | VernacContext of local_binder_expr list | VernacExistingInstance of - (qualid * Hints.hint_info_expr) list (* instances names, priorities and patterns *) + (qualid * ComHints.hint_info_expr) list (* instances names, priorities and patterns *) | VernacExistingClass of qualid (* inductive or definition name *) @@ -384,7 +387,7 @@ type nonrec vernac_expr = (* Commands *) | VernacCreateHintDb of string * bool | VernacRemoveHints of string list * qualid list - | VernacHints of string list * Hints.hints_expr + | VernacHints of string list * ComHints.hints_expr | VernacSyntacticDefinition of lident * (Id.t list * constr_expr) * onlyparsing_flag @@ -399,9 +402,9 @@ type nonrec vernac_expr = | VernacSetStrategy of (Conv_oracle.level * qualid or_by_notation list) list | VernacSetOption of bool (* Export modifier? *) * Goptions.option_name * option_setting - | VernacAddOption of Goptions.option_name * option_ref_value list - | VernacRemoveOption of Goptions.option_name * option_ref_value list - | VernacMemOption of Goptions.option_name * option_ref_value list + | VernacAddOption of Goptions.option_name * Goptions.table_value list + | VernacRemoveOption of Goptions.option_name * Goptions.table_value list + | VernacMemOption of Goptions.option_name * Goptions.table_value list | VernacPrintOption of Goptions.option_name | VernacCheckMayEval of Genredexpr.raw_red_expr option * Goal_select.t option * constr_expr | VernacGlobalCheck of constr_expr diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index 1920c276af..d772f274a2 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -57,9 +57,9 @@ type typed_vernac = | VtNoProof of (unit -> unit) | VtCloseProof of (lemma:Lemmas.t -> unit) | VtOpenProof of (unit -> Lemmas.t) - | VtModifyProof of (pstate:Proof_global.t -> Proof_global.t) - | VtReadProofOpt of (pstate:Proof_global.t option -> unit) - | VtReadProof of (pstate:Proof_global.t -> unit) + | VtModifyProof of (pstate:Declare.Proof.t -> Declare.Proof.t) + | VtReadProofOpt of (pstate:Declare.Proof.t option -> unit) + | VtReadProof of (pstate:Declare.Proof.t -> unit) type vernac_command = atts:Attributes.vernac_flags -> typed_vernac diff --git a/vernac/vernacextend.mli b/vernac/vernacextend.mli index 0d0ebc1086..58c267080a 100644 --- a/vernac/vernacextend.mli +++ b/vernac/vernacextend.mli @@ -75,9 +75,9 @@ type typed_vernac = | VtNoProof of (unit -> unit) | VtCloseProof of (lemma:Lemmas.t -> unit) | VtOpenProof of (unit -> Lemmas.t) - | VtModifyProof of (pstate:Proof_global.t -> Proof_global.t) - | VtReadProofOpt of (pstate:Proof_global.t option -> unit) - | VtReadProof of (pstate:Proof_global.t -> unit) + | VtModifyProof of (pstate:Declare.Proof.t -> Declare.Proof.t) + | VtReadProofOpt of (pstate:Declare.Proof.t option -> unit) + | VtReadProof of (pstate:Declare.Proof.t -> unit) type vernac_command = atts:Attributes.vernac_flags -> typed_vernac diff --git a/vernac/vernacinterp.ml b/vernac/vernacinterp.ml index 15a19c06c2..19d41c4770 100644 --- a/vernac/vernacinterp.ml +++ b/vernac/vernacinterp.ml @@ -51,24 +51,17 @@ let interp_typed_vernac c ~stack = (* 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 proof_mode_opt_name = ["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 +let get_default_proof_mode = + Goptions.declare_interpreted_string_option_and_ref + ~depr:false + ~key:proof_mode_opt_name + ~value:(Pvernac.register_proof_mode "Noedit" Pvernac.Vernac_.noedit_mode) + (fun name -> 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; - optkey = proof_mode_opt_name; - optread = get_default_proof_mode_opt; - optwrite = set_default_proof_mode_opt; - } + | None -> CErrors.user_err Pp.(str (Format.sprintf "No proof mode named \"%s\"." name))) + Pvernac.proof_mode_to_string (** A global default timeout, controlled by option "Set Default Timeout n". Use "Unset Default Timeout" to deactivate it (or set it to 0). *) @@ -216,7 +209,7 @@ and interp_control ~st ({ CAst.v = cmd } as vernac) = let before_univs = Global.universes () in let pstack = interp_expr ~atts:cmd.attrs ~st cmd.expr in if before_univs == Global.universes () then pstack - else Option.map (Vernacstate.LemmaStack.map_top_pstate ~f:Proof_global.update_global_env) pstack) + else Option.map (Vernacstate.LemmaStack.map_top_pstate ~f:Declare.Proof.update_global_env) pstack) ~st (* XXX: This won't properly set the proof mode, as of today, it is @@ -258,7 +251,7 @@ let interp_gen ~verbosely ~st ~interp_fn cmd = try vernac_timeout (fun st -> let v_mod = if verbosely then Flags.verbosely else Flags.silently in let ontop = v_mod (interp_fn ~st) cmd in - Vernacstate.Proof_global.set ontop [@ocaml.warning "-3"]; + Vernacstate.Declare.set ontop [@ocaml.warning "-3"]; Vernacstate.freeze_interp_state ~marshallable:false ) st with exn -> diff --git a/vernac/vernacinterp.mli b/vernac/vernacinterp.mli index 9f5bfb46ee..e3e708e87d 100644 --- a/vernac/vernacinterp.mli +++ b/vernac/vernacinterp.mli @@ -14,7 +14,7 @@ val interp : ?verbosely:bool -> st:Vernacstate.t -> Vernacexpr.vernac_control -> (** Execute a Qed but with a proof_object which may contain a delayed proof and won't be forced *) val interp_qed_delayed_proof - : proof:Proof_global.proof_object + : proof:Declare.proof_object -> info:Lemmas.Info.t -> st:Vernacstate.t -> control:Vernacexpr.control_flag list diff --git a/vernac/vernacstate.ml b/vernac/vernacstate.ml index 6846826bfa..0fca1e9078 100644 --- a/vernac/vernacstate.ml +++ b/vernac/vernacstate.ml @@ -45,7 +45,7 @@ module LemmaStack = struct | Some (l,ls) -> a, (l :: ls) let get_all_proof_names (pf : t) = - let prj x = Lemmas.pf_fold Proof_global.get_proof x in + let prj x = Lemmas.pf_fold Declare.Proof.get_proof x in let (pn, pns) = map Proof.(function pf -> (data (prj pf)).name) pf in pn :: pns @@ -105,7 +105,7 @@ let make_shallow st = } (* Compatibility module *) -module Proof_global = struct +module Declare = struct let get () = !s_lemmas let set x = s_lemmas := x @@ -126,7 +126,7 @@ module Proof_global = struct end open Lemmas - open Proof_global + open Declare let cc f = match !s_lemmas with | None -> raise NoCurrentProof @@ -145,39 +145,40 @@ module Proof_global = struct | Some x -> s_lemmas := Some (LemmaStack.map_top_pstate ~f x) let there_are_pending_proofs () = !s_lemmas <> None - let get_open_goals () = cc get_open_goals + let get_open_goals () = cc Proof.get_open_goals - let give_me_the_proof_opt () = Option.map (LemmaStack.with_top_pstate ~f:get_proof) !s_lemmas - let give_me_the_proof () = cc get_proof - let get_current_proof_name () = cc get_proof_name + let give_me_the_proof_opt () = Option.map (LemmaStack.with_top_pstate ~f:Proof.get_proof) !s_lemmas + let give_me_the_proof () = cc Proof.get_proof + let get_current_proof_name () = cc Proof.get_proof_name - let map_proof f = dd (map_proof f) + let map_proof f = dd (Proof.map_proof f) let with_current_proof f = match !s_lemmas with | None -> raise NoCurrentProof | Some stack -> - let pf, res = LemmaStack.with_top_pstate stack ~f:(map_fold_proof_endline f) in + let pf, res = LemmaStack.with_top_pstate stack ~f:(Proof.map_fold_proof_endline f) in let stack = LemmaStack.map_top_pstate stack ~f:(fun _ -> pf) in s_lemmas := Some stack; res - type closed_proof = Proof_global.proof_object * Lemmas.Info.t + type closed_proof = Declare.proof_object * Lemmas.Info.t - let return_proof ?allow_partial () = cc (return_proof ?allow_partial) + let return_proof () = cc return_proof + let return_partial_proof () = cc return_partial_proof - let close_future_proof ~opaque ~feedback_id pf = - cc_lemma (fun pt -> pf_fold (fun st -> close_future_proof ~opaque ~feedback_id st pf) pt, - Internal.get_info pt) + let close_future_proof ~feedback_id pf = + cc_lemma (fun pt -> pf_fold (fun st -> close_future_proof ~feedback_id st pf) pt, + Lemmas.Internal.get_info pt) - let close_proof ~opaque ~keep_body_ucst_separate f = - cc_lemma (fun pt -> pf_fold ((close_proof ~opaque ~keep_body_ucst_separate f)) pt, - Internal.get_info pt) + let close_proof ~opaque ~keep_body_ucst_separate = + cc_lemma (fun pt -> pf_fold ((close_proof ~opaque ~keep_body_ucst_separate)) pt, + Lemmas.Internal.get_info pt) let discard_all () = s_lemmas := None - let update_global_env () = dd (update_global_env) + let update_global_env () = dd (Proof.update_global_env) - let get_current_context () = cc Pfedit.get_current_context + let get_current_context () = cc Declare.get_current_context let get_all_proof_names () = try cc_stack LemmaStack.get_all_proof_names diff --git a/vernac/vernacstate.mli b/vernac/vernacstate.mli index 7607f8373a..fb6d8b6db6 100644 --- a/vernac/vernacstate.mli +++ b/vernac/vernacstate.mli @@ -25,8 +25,8 @@ module LemmaStack : sig val pop : t -> Lemmas.t * t option val push : t option -> Lemmas.t -> t - val map_top_pstate : f:(Proof_global.t -> Proof_global.t) -> t -> t - val with_top_pstate : t -> f:(Proof_global.t -> 'a ) -> 'a + val map_top_pstate : f:(Declare.Proof.t -> Declare.Proof.t) -> t -> t + val with_top_pstate : t -> f:(Declare.Proof.t -> 'a ) -> 'a end @@ -50,7 +50,7 @@ val make_shallow : t -> t val invalidate_cache : unit -> unit (* Compatibility module: Do Not Use *) -module Proof_global : sig +module Declare : sig exception NoCurrentProof @@ -65,16 +65,16 @@ module Proof_global : sig val with_current_proof : (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> 'a - val return_proof : ?allow_partial:bool -> unit -> Proof_global.closed_proof_output + val return_proof : unit -> Declare.closed_proof_output + val return_partial_proof : unit -> Declare.closed_proof_output - type closed_proof = Proof_global.proof_object * Lemmas.Info.t + type closed_proof = Declare.proof_object * Lemmas.Info.t val close_future_proof : - opaque:Proof_global.opacity_flag -> feedback_id:Stateid.t -> - Proof_global.closed_proof_output Future.computation -> closed_proof + Declare.closed_proof_output Future.computation -> closed_proof - val close_proof : opaque:Proof_global.opacity_flag -> keep_body_ucst_separate:bool -> Future.fix_exn -> closed_proof + val close_proof : opaque:Declare.opacity_flag -> keep_body_ucst_separate:bool -> closed_proof val discard_all : unit -> unit val update_global_env : unit -> unit @@ -89,7 +89,7 @@ module Proof_global : sig val get : unit -> LemmaStack.t option val set : LemmaStack.t option -> unit - val get_pstate : unit -> Proof_global.t option + val get_pstate : unit -> Declare.Proof.t option val freeze : marshallable:bool -> LemmaStack.t option val unfreeze : LemmaStack.t -> unit |