diff options
312 files changed, 5310 insertions, 4632 deletions
diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index 6c6e4bdfcb..a7c0846e35 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -6,126 +6,101 @@ /.github/ @coq/contributing-process-maintainers /CONTRIBUTING.md @coq/contributing-process-maintainers +/dev/doc/shield-icon.png @coq/contributing-process-maintainers /dev/doc/release-process.md @coq/contributing-process-maintainers -/dev/doc/MERGING.md @coq/pushers -# This ensures that all members of the @coq/pushers -# team are notified when the merging doc changes. - ########## Build system ########## -/Makefile* @gares -/dev/tools/make_git_revision.sh @gares +/Makefile* @coq/legacy-build-maintainers +/dev/tools/make_git_revision.sh @coq/legacy-build-maintainers -/configure* @ejgallego +/configure* @coq/legacy-build-maintainers @coq/build-maintainers -/META.coq.in @ejgallego +/META.coq.in @coq/legacy-build-maintainers -/dev/build/windows @MSoegtropIMC -# Secondary maintainer @maximedenes +/dev/build/windows @coq/windows-build-maintainers ########## CI infrastructure ########## -/dev/ci/ @coq/ci-maintainers -/.travis.yml @coq/ci-maintainers -/.gitlab-ci.yml @coq/ci-maintainers -/Makefile.ci @coq/ci-maintainers -/dev/ci/nix @coq/nix-maintainers +/dev/ci/ @coq/ci-maintainers +/.travis.yml @coq/ci-maintainers +/.gitlab-ci.yml @coq/ci-maintainers +/azure-pipelines.yml @coq/ci-maintainers +/Makefile.ci @coq/ci-maintainers + +/dev/ci/nix @coq/nix-maintainers +*.nix @coq/nix-maintainers /dev/ci/user-overlays/*.sh @ghost # Trick to avoid getting review requests # each time someone adds an overlay -/dev/ci/*.bat @coq/ci-maintainers - -*.nix @coq/nix-maintainers - -azure-pipelines.yml @coq/ci-maintainers -/dev/ci/azure* @coq/ci-maintainers - ########## Documentation ########## -/README.md @Zimmi48 -# Secondary maintainer @maximedenes +/README.md @coq/doc-maintainers +/INSTALL.md @coq/doc-maintainers -/INSTALL* @Zimmi48 -# Secondary maintainer @maximedenes +/CODE_OF_CONDUCT.md @coq/code-of-conduct-team -/CODE_OF_CONDUCT.md @Zimmi48 -# Secondary maintainer @mattam82 +/doc/ @coq/doc-maintainers +/Makefile.doc @coq/doc-maintainers -/dev/doc/ @Zimmi48 -# Secondary maintainer @maximedenes +/dev/doc/ @coq/doc-maintainers +/doc/changelog/*/*.rst @ghost /dev/doc/changes.md @ghost # Trick to avoid getting review requests -# each time someone modifies the dev changelog - -/doc/ @coq/doc-maintainers -/Makefile.doc @coq/doc-maintainers +# each time someone modifies the changelog -/man/ @silene -# Secondary maintainer @maximedenes +/man/ @coq/doc-maintainers -/doc/plugin_tutorial/ @coq/plugin-tutorial-maintainers +/doc/plugin_tutorial/ @coq/plugin-tutorial-maintainers ########## Coqchk ########## -/checker/ @ppedrot -/test-suite/coqchk/ @ppedrot -# Secondary maintainers @maximedenes +/checker/ @coq/kernel-maintainers +/test-suite/coqchk/ @coq/kernel-maintainers ########## Coq lib ########## -/clib/ @ppedrot -/test-suite/unit-tests/clib/ @ppedrot -# Secondary maintainer @ejgallego - -/lib/ @ejgallego -# Secondary maintainer @ppedrot - -/lib/cWarnings.* @maximedenes -# Secondary maintainer @ejgallego +/clib/ @coq/lib-maintainers +/test-suite/unit-tests/clib/ @coq/lib-maintainers +/lib/ @coq/lib-maintainers ########## Proof engine ########## -/engine/ @ppedrot -# Secondary maintainer @aspiwack +/engine/ @coq/engine-maintainers -/engine/universes.* @SkySkimmer -/engine/univops.* @SkySkimmer -/engine/uState.* @SkySkimmer -# Secondary maintainer @mattam82 +/engine/univ* @coq/universes-maintainers +/engine/uState.* @coq/universes-maintainers ########## CoqIDE ########## -/ide/ @ppedrot -/test-suite/ide/ @ppedrot -# Secondary maintainers @gares @herbelin +/ide/ @coq/coqide-maintainers +/ide/protocol/ @coq/stm-maintainers +/test-suite/ide/ @coq/stm-maintainers -########## Interpretation ########## +########## Desugaring ########## -/interp/ @herbelin -# Secondary maintainer @ejgallego +/interp/ @coq/extensible-syntax-maintainers ########## Kernel ########## -/kernel/ @maximedenes -# Secondary maintainers @barras @ppedrot +/kernel/ @coq/kernel-maintainers -/kernel/byterun/ @maximedenes -# Secondary maintainer @silene +/kernel/byterun/ @coq/vm-native-maintainers +/kernel/native* @coq/vm-native-maintainers +/kernel/vm* @coq/vm-native-maintainers +/kernel/vconv.* @coq/vm-native-maintainers -/kernel/sorts.* @SkySkimmer -/kernel/uGraph.* @SkySkimmer -/kernel/univ.* @SkySkimmer -# Secondary maintainer @mattam82 +/kernel/sorts.* @coq/universes-maintainers +/kernel/uGraph.* @coq/universes-maintainers +/kernel/univ.* @coq/universes-maintainers ########## Library ########## -/library/ @silene -# Secondary maintainer @gares +/library/ @coq/library-maintainers ########## Parser ########## @@ -135,33 +110,26 @@ azure-pipelines.yml @coq/ci-maintainers ########## Plugins ########## -/plugins/btauto/ @ppedrot -# Secondary maintainer @herbelin +/plugins/btauto/ @coq/btauto-maintainers -/plugins/cc/ @PierreCorbineau -# Secondary maintainer @herbelin +/plugins/cc/ @coq/cc-maintainers -/plugins/derive/ @aspiwack -# Secondary maintainer @ppedrot +/plugins/derive/ @coq/derive-maintainers -/plugins/extraction/ @maximedenes +/plugins/extraction/ @coq/extraction-maintainers -/plugins/firstorder/ @PierreCorbineau -# Secondary maintainer @herbelin +/plugins/firstorder/ @coq/firstorder-maintainers -/plugins/funind/ @forestjulien -# Secondary maintainer @Matafou +/plugins/funind/ @coq/funind-maintainers -/plugins/ltac/ @ppedrot -# Secondary maintainer @herbelin +/plugins/ltac/ @coq/ltac-maintainers /plugins/micromega/ @coq/micromega-maintainers /test-suite/micromega/ @coq/micromega-maintainers -/plugins/nsatz/ @thery -# Secondary maintainer @ppedrot +/plugins/nsatz/ @coq/nsatz-maintainers -/plugins/setoid_ring/ @coq/ring-maintainers +/plugins/setoid_ring/ @coq/ring-maintainers /plugins/ssrmatching/ @coq/ssreflect-maintainers /plugins/ssr/ @coq/ssreflect-maintainers @@ -169,190 +137,101 @@ azure-pipelines.yml @coq/ci-maintainers /plugins/syntax/ @coq/parsing-maintainers -/plugins/rtauto/ @PierreCorbineau -# Secondary maintainer @herbelin +/plugins/rtauto/ @coq/rtauto-maintainers -/user-contrib/Ltac2 @ppedrot +/user-contrib/Ltac2 @coq/ltac2-maintainers ########## Pretyper ########## -/pretyping/ @mattam82 -# Secondary maintainer @gares +/pretyping/ @coq/pretyper-maintainers -/pretyping/vnorm.* @maximedenes -/pretyping/nativenorm.* @maximedenes -# Secondary maintainer @ppedrot +/pretyping/vnorm.* @coq/vm-native-maintainers +/pretyping/nativenorm.* @coq/vm-native-maintainers ########## Pretty printer ########## -/printing/ @herbelin -# Secondary maintainer @mattam82 +/printing/ @coq/extensible-syntax-maintainers ########## Proof infrastructure ########## -/proofs/ @ppedrot -# Secondary maintainer @Zimmi48 +/proofs/ @coq/engine-maintainers ########## STM ########## -/stm/ @gares -/test-suite/interactive/ @gares -/test-suite/stm/ @gares -/test-suite/vio/ @gares -# Secondary maintainer @ejgallego +/stm/ @coq/stm-maintainers +/test-suite/interactive/ @coq/stm-maintainers +/test-suite/stm/ @coq/stm-maintainers +/test-suite/vio/ @coq/stm-maintainers ########## Tactics ########## -/tactics/ @ppedrot -# Secondary maintainer @mattam82 +/tactics/ @coq/tactics-maintainers -/tactics/class_tactics.* @mattam82 -/test-suite/typeclasses/ @mattam82 -# Secondary maintainer @ppedrot +/tactics/class_tactics.* @coq/typeclasses-maintainers +/test-suite/typeclasses/ @coq/typeclasses-maintainers ########## Standard library ########## -/theories/Arith/ @herbelin - -/theories/Bool/ @herbelin - -/theories/Classes/ @mattam82 -# Secondary maintainer @herbelin - -/theories/FSets/ @herbelin - -/theories/Init/ @ppedrot - -/theories/Lists/ @ppedrot - -/theories/Logic/ @herbelin -# Secondary maintainer @ppedrot - -/theories/MSets/ @herbelin - -/theories/NArith/ @herbelin - -/theories/Numbers/ @herbelin - -/theories/PArith/ @herbelin - -/theories/Program/ @mattam82 -# Secondary maintainer @herbelin - -/theories/QArith/ @herbelin - -/theories/Reals/ @coq/reals-library-maintainers +/theories/ @coq/stdlib-maintainers -/theories/Relations/ @mattam82 -# Secondary maintainer @ppedrot +/theories/Classes/ @coq/typeclasses-maintainers -/theories/Setoids/ @mattam82 -# Secondary maintainer @ppedrot +/theories/Reals/ @coq/reals-library-maintainers -/theories/Sets/ @herbelin - -/theories/Sorting/ @herbelin - -/theories/Strings/ @herbelin - -/theories/Structures/ @herbelin - -/theories/Unicode/ @herbelin - -/theories/Wellfounded/ @mattam82 - -/theories/ZArith/ @herbelin - -/theories/Compat/ @JasonGross -# Secondary maintainer @Zimmi48 - -/theories/Vectors/ @herbelin +/theories/Compat/ @coq/compat-maintainers ########## Tools ########## -/tools/coqdoc/ @silene -/test-suite/coqdoc/ @silene -# Secondary maintainer @mattam82 +/tools/coqdoc/ @coq/coqdoc-maintainers +/test-suite/coqdoc/ @coq/coqdoc-maintainers +/tools/coqwc* @coq/coqdoc-maintainers +/test-suite/coqwc/ @coq/coqdoc-maintainers -/tools/coq_makefile* @gares -/tools/CoqMakefile* @gares -/test-suite/coq-makefile/ @gares -# Secondary maintainer @silene +/tools/coq_makefile* @coq/coq-makefile-maintainers +/tools/CoqMakefile* @coq/coq-makefile-maintainers +/test-suite/coq-makefile/ @coq/coq-makefile-maintainers -/tools/coqdep* @ppedrot -# Secondary maintainer @maximedenes +/tools/TimeFileMaker.py @coq/coq-makefile-maintainers +/tools/make-*-tim*.py @coq/coq-makefile-maintainers -/tools/coq_tex* @silene -# Secondary maintainer @gares +/tools/coqdep* @coq/legacy-build-maintainers @coq/build-maintainers -/tools/coqwc* @silene -/test-suite/coqwc/ @silene +/tools/coq_tex* @silene # Secondary maintainer @gares -/tools/TimeFileMaker.py @JasonGross -/tools/make-both-single-timing-files.py @JasonGross -/tools/make-both-time-files.py @JasonGross -/tools/make-one-time-file.py @JasonGross - ########## Toplevel ########## -/toplevel/ @ejgallego -# Secondary maintainer @gares +/toplevel/ @coq/toplevel-maintainers +/topbin/ @coq/toplevel-maintainers ########## Vernacular ########## -/vernac/ @mattam82 -# Secondary maintainer @maximedenes +/vernac/ @coq/vernac-maintainers -/vernac/metasyntax.* @coq/parsing-maintainers +/vernac/metasyntax.* @coq/parsing-maintainers -########## Test suite ########## +/vernac/classes.* @coq/typeclasses-maintainers -/test-suite/Makefile @gares -/test-suite/_CoqProject @gares -/test-suite/README.md @gares -# Secondary maintainer @SkySkimmer +########## Test suite ########## -/test-suite/report.sh @SkySkimmer +/test-suite/Makefile @coq/test-suite-maintainers +/test-suite/README.md @coq/test-suite-maintainers +/test-suite/report.sh @coq/test-suite-maintainers +/test-suite/unit-tests/src/ @coq/test-suite-maintainers /test-suite/complexity/ @herbelin -/test-suite/unit-tests/src/ @jfehrle -# Secondary maintainer @SkySkimmer - -/test-suite/success/Compat*.v @JasonGross +/test-suite/success/Compat*.v @coq/compat-maintainers ########## Developer tools ########## -/dev/tools/backport-pr.sh @Zimmi48 -# Secondary maintainer @maximedenes - -/dev/tools/change-header @herbelin - -/dev/tools/check-eof-newline.sh @SkySkimmer - -/dev/tools/coqdev.el @SkySkimmer - -/dev/tools/github-check-prs.py @SkySkimmer - -/dev/tools/make-changelog.sh @SkySkimmer -# Secondary maintainer @Zimmi48 - -/dev/tools/merge-pr.sh @maximedenes -# Secondary maintainer @gares - -/dev/tools/pre-commit @SkySkimmer - -/dev/tools/check-owners*.sh @SkySkimmer -# Secondary maintainer @maximedenes +/dev/tools/ @coq/dev-tools-maintainers -/dev/tools/update-compat.py @JasonGross -/test-suite/tools/update-compat/ @JasonGross -# Secondary maintainer @Zimmi48 +/dev/tools/update-compat.py @coq/compat-maintainers +/test-suite/tools/update-compat/ @coq/compat-maintainers ########## Dune ########## -/.ocamlinit @ejgallego -*dune* @ejgallego -*.opam @ejgallego -# Secondary maintainer @Zimmi48 +/.ocamlinit @coq/build-maintainers +*dune* @coq/build-maintainers +*.opam @coq/build-maintainers diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 956d74c8c1..73b979c6a3 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -62,6 +62,7 @@ before_script: # TODO figure out how to build doc for installed Coq .build-template: stage: stage-1 + interruptible: true artifacts: name: "$CI_JOB_NAME" paths: @@ -98,6 +99,7 @@ before_script: # Template for building Coq + stdlib, typical use: overload the switch .dune-template: stage: stage-1 + interruptible: true dependencies: [] script: - set -e @@ -117,6 +119,7 @@ before_script: .dune-ci-template: stage: stage-2 + interruptible: true needs: - build:edge+flambda:dune:dev dependencies: @@ -143,6 +146,7 @@ before_script: .doc-template: stage: stage-2 + interruptible: true dependencies: - not-a-real-job script: @@ -158,6 +162,7 @@ before_script: # set dependencies when using .test-suite-template: stage: stage-2 + interruptible: true dependencies: - not-a-real-job script: @@ -179,6 +184,7 @@ before_script: # set dependencies when using .validate-template: stage: stage-2 + interruptible: true dependencies: - not-a-real-job script: @@ -195,6 +201,7 @@ before_script: .ci-template: stage: stage-2 + interruptible: true script: - set -e - echo 'start:coq.test' @@ -218,6 +225,7 @@ before_script: .windows-template: stage: stage-1 + interruptible: true artifacts: name: "%CI_JOB_NAME%" paths: @@ -226,7 +234,7 @@ before_script: expire_in: 1 week dependencies: [] tags: - - windows + - windows-inria before_script: [] script: - call dev/ci/gitlab.bat @@ -320,6 +328,7 @@ lint: pkg:opam: stage: stage-1 + interruptible: true # OPAM will build out-of-tree so no point in importing artifacts dependencies: [] script: @@ -336,6 +345,7 @@ pkg:opam: .nix-template: image: nixorg/nix:latest # Minimal NixOS image which doesn't even contain git + interruptible: true stage: stage-1 variables: # By default we use coq.cachix.org as an extra substituter but this can be overridden @@ -578,6 +588,8 @@ library:ci-bedrock2: name: "$CI_JOB_NAME" paths: - _build_ci + variables: + NJOBS: "1" library:ci-color: extends: .ci-template-flambda @@ -737,6 +749,9 @@ plugin:plugin-tutorial: plugin:ci-quickchick: extends: .ci-template-flambda +plugin:ci-reduction_effects: + extends: .ci-template + plugin:ci-relation_algebra: extends: .ci-template diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index f7661743a2..a0139e422d 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -42,6 +42,7 @@ well. - [Becoming a maintainer](#becoming-a-maintainer) - [Reviewing pull requests](#reviewing-pull-requests) - [Merging pull requests](#merging-pull-requests) + - [Additional notes for pull request reviewers and assignees](#additional-notes-for-pull-request-reviewers-and-assignees) - [Core development team](#core-development-team) - [Release management](#release-management) - [Packaging Coq](#packaging-coq) @@ -56,6 +57,7 @@ well. - [Git documentation, tips and tricks](#git-documentation-tips-and-tricks) - [GitHub documentation, tips and tricks](#github-documentation-tips-and-tricks) - [GitLab documentation, tips and tricks](#gitlab-documentation-tips-and-tricks) + - [Merge script dependencies](#merge-script-dependencies) - [Coqbot](#coqbot) - [Online forum and chat to talk to developers](#online-forum-and-chat-to-talk-to-developers) - [Coq remote working groups](#coq-remote-working-groups) @@ -430,7 +432,7 @@ and merge when it is the case (you can ping them if the PR is ready from your side but nothing happens for a few days). After your PR is accepted and merged, it may get backported to a -stable branch if appropriate, and will eventually make it to a +release branch if appropriate, and will eventually make it to a release. You do not have to worry about this, it is the role of the assignee and the release manager to do so (see Section [Release management](#release-management)). The milestone should give you an @@ -736,28 +738,65 @@ spending time in vain. ### Merging pull requests ### -Our [CODEOWNERS][] file associates a team of maintainers, or a -principal and secondary maintainers, to each component. They will be -responsible for self-assigning and merging PRs (they didn't co-author) -that change this component. When several components are changed in -significant ways, at least a maintainer (other than the PR author) -must approve the PR for each affected component before it can be -merged, and one of them has to assign the PR, and merge it when it is -time. Before merging, the assignee must also select a milestone for -the PR (see also Section [Release management](#release-management)). - -If you feel knowledgeable enough to maintain a component, and have a -good track record of contributing to it, we would be happy to have you -join one of the maintainer teams. - -The merging process is described in more details in [this -document][MERGING]. - -The people with merging powers (either because listed as a principal -or secondary maintainer in [CODEOWNERS][], or because member of a -maintainer team), are the members of the **@coq/pushers** team -([member list][coq-pushers] only visible to the Coq organization -members because of a limitation of GitHub). +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. + +The PR assignee is responsible for making sure that all the proposed +changes have been reviewed by relevant maintainers, that change +requests have been implemented, that CI is passing, and eventually +will be the one who merges the PR. + +*If you have already frequently contributed to a component, we would +be happy to have you join one of the maintainer teams.* + +The complete list of maintainer teams is available [here][coq-pushers] +(link only accessible to people who are already members of the Coq +organization, because of a limitation of GitHub). + +#### Additional notes for pull request reviewers and assignees #### + +- NEVER USE GITHUB'S MERGE BUTTON. Instead, we provide a script + [`dev/tools/merge-pr.sh`][merge-pr] which you should use to merge a + PR (requires having configured gpg with git). In the future, we + will also support merging through a command to **@coqbot**. + +- PR authors or co-authors cannot review, self-assign, or merge the PR + they contributed to. However, reviewers may push small fixes to the + PR branch to facilitate the PR integration. + +- Only PRs targetting the `master` branch can be merged by a + maintainer. For PRs targetting a release branch, the assignee + should always be the RM. + +- Before merging, the assignee must also select a milestone for the PR + (see also Section [Release management](#release-management)). + +- To know which files you are a maintainer of, you can look for black + shields icons in the "Files changed" tab. Alternatively, you may + use the [`dev/tools/check-owners-pr.sh`][check-owners] script for + the same purpose. + +  + +- Sometimes, it is a good practice to announce the intent to merge one + or several days in advance when unsure that everyone had a chance to + voice their opinion, or to finish reviewing the PR. + +- When a PR has [overlays][user-overlays], then: + + - the overlays that are backward-compatible (normally the case for + overlays fixing Coq code) should have been merged *before* the PR + can be merged; + + - the overlays that are not backward-compatible (normally only the + case for overlays fixing OCaml code) should be merged *just after* + the PR has been merged (and thus the assignee should ping the + maintainers of the affected projects to ask them to merge the + overlays). ### Core development team ### @@ -783,23 +822,23 @@ on the wiki. Development of new features, refactorings, deprecations and clean-ups always happens on `master`. Stabilization starts by branching -(creating a new stable `v...` branch from the current `master`), which +(creating a new `v...` release branch from the current `master`), which marks the beginning of a feature freeze (new features will continue to be merged into `master` but won't make it for the upcoming major release, but only for the next one). -After branching, most changes are introduced in the stable branch by a +After branching, most changes are introduced in the release branch by a backporting process. PR authors and assignee can signal a desire to have a PR backported by selecting an appropriate milestone. Most of the time, the choice of milestone is between two options: the next major version that has yet to branch from `master`, or the next -version (beta, final, or patch-level release) of the active stable +version (beta, final, or patch-level release) of the active release branch. In the end, it is the RM who decides whether to follow or not the recommendation of the PR assignee, and who backports PRs to the -stable branch. +release branch. -Very specific changes that are only relevant for the stable branch and -not for the `master` branch can result in a PR targetting the stable +Very specific changes that are only relevant for the release branch and +not for the `master` branch can result in a PR targetting the release branch instead of `master`. In this case, the RM is the only one who can merge the PR, and they may even do so if they are the author of the PR. Examples of such PRs include bug fixes to a feature that has @@ -808,13 +847,13 @@ number in preparation for the next release. Some automation is in place to help the RM in their task: a GitHub project is created at branching time to manage PRs to backport; when a -PR is merged in a milestone corresponding to the stable branch, our +PR is merged in a milestone corresponding to the release branch, our bot will add this PR in a "Request inclusion" column in this project; the RM can browse through the list of PRs waiting to be backported in this column, possibly reject some of them by simply removing the PR from the column (in which case, the bot will update the PR milestone), and proceed to backport others; when a backported PR is pushed to the -stable branch, the bot moves the PR from the "Request inclusion" +release branch, the bot moves the PR from the "Request inclusion" column to a "Shipped" column. More information about the RM tasks can be found in the [release @@ -914,6 +953,16 @@ procedure. We also have a benchmarking infrastructure, which is documented [on the wiki][jenkins-doc]. +##### Restarting failed jobs ##### + +When CI has a few failures which look spurious, restarting the +corresponding jobs is a good way to ensure this was indeed the case. +You can restart jobs on Azure from the "Checks" tab on GitHub. To +restart a job on GitLab CI, you should sign into GitLab (this can be +done using a GitHub account); if you are part of the [Coq organization +on GitLab](https://gitlab.com/coq), you should see a "Retry" button; +otherwise, send a request to join the organization. + #### Code owners, issue and pull request templates #### These files can be found in the [`.github`](.github) directory. The @@ -1029,6 +1078,22 @@ restart failing CI jobs. GitLab too has [extensive documentation][GitLab-doc], in particular on configuring CI. +#### Merge script dependencies #### + +The merge script passes option `-S` to `git merge` to ensure merge +commits are signed. Consequently, it depends on the GnuPG command +utility being installed and a GPG key being available. Here is a +short documentation on how to use GPG, git & GitHub: +https://help.github.com/articles/signing-commits-with-gpg/. + +The script depends on a few other utilities. If you are a Nix user, +the simplest way of getting them is to run `nix-shell` first. + +**Note for homebrew (MacOS) users:** it has been reported that +installing GnuPG is not out of the box. Installing explicitly +`pinentry-mac` seems important for typing of passphrase to work +correctly (see also this [Stack Overflow Q-and-A][pinentry-mac]). + #### Coqbot #### Our bot sources can be found at <https://github.com/coq/bot>. Its @@ -1069,6 +1134,7 @@ can be found [on the wiki][wiki-CUDW]. [add-contributor]: https://github.com/orgs/coq/teams/contributors/members?add=true [api-doc]: https://coq.github.io/doc/master/api/ [CEP]: https://github.com/coq/ceps +[check-owners]: dev/tools/check-owners-pr.sh [CI-README-developers]: dev/ci/README-developers.md [CI-README-users]: dev/ci/README-users.md [Code-of-Conduct]: CODE_OF_CONDUCT.md @@ -1084,7 +1150,7 @@ can be found [on the wiki][wiki-CUDW]. [Coq-documentation]: https://coq.inria.fr/documentation [Coq-issue-tracker]: https://github.com/coq/coq/issues [Coq-package-index]: https://coq.inria.fr/packages -[coq-pushers]: https://github.com/orgs/coq/teams/pushers/members +[coq-pushers]: https://github.com/orgs/coq/teams/pushers/teams [coq-repository]: https://github.com/coq/coq [Coq-website-repository]: https://github.com/coq/www [debugging-doc]: dev/doc/debugging.md @@ -1118,7 +1184,7 @@ can be found [on the wiki][wiki-CUDW]. [jenkins-doc]: https://github.com/coq/coq/wiki/Jenkins-(automated-benchmarking) [kind-documentation]: https://github.com/coq/coq/issues?q=is%3Aopen+is%3Aissue+label%3A%22kind%3A+documentation%22 [master-doc]: https://coq.github.io/doc/master/refman/ -[MERGING]: dev/doc/MERGING.md +[merge-pr]: dev/tools/merge-pr.sh [needs-benchmarking]: https://github.com/coq/coq/labels/needs%3A%20benchmarking [needs-changelog]: https://github.com/coq/coq/labels/needs%3A%20changelog%20entry [needs-documentation]: https://github.com/coq/coq/labels/needs%3A%20documentation @@ -1133,6 +1199,7 @@ can be found [on the wiki][wiki-CUDW]. [Octobox]: http://octobox.io/ [old-style-guide]: dev/doc/style.txt [other-standard-libraries]: https://github.com/coq/stdlib2/wiki/Other-%22standard%22-libraries +[pinentry-mac]: https://stackoverflow.com/questions/39494631/gpg-failed-to-sign-the-data-fatal-failed-to-write-commit-object-git-2-10-0 [plugin-tutorial]: doc/plugin_tutorial [ProofGeneral-issues]: https://github.com/ProofGeneral/PG/issues [Reddit]: https://www.reddit.com/r/Coq/ diff --git a/META.coq.in b/META.coq.in index 49bdea6d9c..377dbd9b7e 100644 --- a/META.coq.in +++ b/META.coq.in @@ -561,4 +561,19 @@ package "plugins" ( plugin(byte) = "ssreflect_plugin.cmo" plugin(native) = "ssreflect_plugin.cmxs" ) + + package "ltac2" ( + + description = "Coq Ltac2 Plugin" + version = "8.12" + + requires = "coq.plugins.ltac" + directory = "../user-contrib/Ltac2" + + archive(byte) = "ltac2_plugin.cmo" + archive(native) = "ltac2_plugin.cmx" + + plugin(byte) = "ltac2_plugin.cmo" + plugin(native) = "ltac2_plugin.cmxs" + ) ) diff --git a/Makefile.build b/Makefile.build index 5b879220d0..a8ae040f8e 100644 --- a/Makefile.build +++ b/Makefile.build @@ -840,7 +840,7 @@ theories/Init/%.vo theories/Init/%.glob: theories/Init/%.v $(VO_TOOLS_DEP) theories/Init/%.vio: theories/Init/%.v $(VO_TOOLS_DEP) $(SHOW)'COQC -quick -noinit $<' - $(HIDE)$(BOOTCOQC) $< -noinit -R theories Coq -quick -noglob + $(HIDE)$(BOOTCOQC) $< -noinit -R theories Coq -vio -noglob # The general rule for building .vo files : @@ -855,8 +855,8 @@ ifdef VALIDATE endif %.vio: %.v theories/Init/Prelude.vio $(VO_TOOLS_DEP) - $(SHOW)'COQC -quick $<' - $(HIDE)$(BOOTCOQC) $< -quick -noglob + $(SHOW)'COQC -vio $<' + $(HIDE)$(BOOTCOQC) $< -vio -noglob %.v.timing.diff: %.v.before-timing %.v.after-timing $(SHOW)PYTHON TIMING-DIFF $< diff --git a/Makefile.ci b/Makefile.ci index 8315c16c64..4fc0e69748 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -38,6 +38,7 @@ CI_TARGETS= \ ci-paramcoq \ ci-perennial \ ci-quickchick \ + ci-reduction_effects \ ci-relation_algebra \ ci-rewriter \ ci-sf \ diff --git a/Makefile.doc b/Makefile.doc index 125a4b33d5..50c4acb416 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -129,6 +129,8 @@ doc/unreleased.rst: $(wildcard doc/changelog/00-title.rst doc/changelog/*/*.rst) # Standard library ###################################################################### +DOCLIBS=-R theories Coq -R plugins Coq -Q user-contrib/Ltac2 Ltac2 + ### Standard library (browsable html format) ifdef QUICK @@ -139,7 +141,7 @@ endif - rm -rf doc/stdlib/html $(MKDIR) doc/stdlib/html $(COQDOC) -q -d doc/stdlib/html --with-header doc/common/styles/html/$(HTMLSTYLE)/header.html --with-footer doc/common/styles/html/$(HTMLSTYLE)/footer.html --multi-index --html -g \ - -R theories Coq -R plugins Coq $(VFILES) + $(DOCLIBS) $(VFILES) mv doc/stdlib/html/index.html doc/stdlib/html/genindex.html doc/stdlib/index-list.html: doc/stdlib/index-list.html.template doc/stdlib/make-library-index @@ -178,12 +180,12 @@ doc/stdlib/FullLibrary.tex: doc/stdlib/Library.tex ifdef QUICK doc/stdlib/FullLibrary.coqdoc.tex: $(COQDOC) -q -boot --gallina --body-only --latex --stdout --utf8 \ - -R theories Coq -R plugins Coq $(VFILES) > $@ + $(DOCLIBS) $(VFILES) > $@ sed -i.tmp -e 's///g' $@ && rm $@.tmp else doc/stdlib/FullLibrary.coqdoc.tex: $(COQDOC) $(ALLVO) $(COQDOC) -q -boot --gallina --body-only --latex --stdout --utf8 \ - -R theories Coq -R plugins Coq $(VFILES) > $@ + $(DOCLIBS) $(VFILES) > $@ sed -i.tmp -e 's///g' $@ && rm $@.tmp endif diff --git a/Makefile.dune b/Makefile.dune index bafb40d55f..b433ed1b94 100644 --- a/Makefile.dune +++ b/Makefile.dune @@ -6,7 +6,7 @@ .PHONY: quickbyte quickopt quickide # Partial / quick developer targets .PHONY: refman-html stdlib-html apidoc # Documentation targets .PHONY: test-suite release # Accessory targets -.PHONY: ocheck ireport clean # Maintenance targets +.PHONY: fmt ocheck ireport clean # Maintenance targets # use DUNEOPT=--display=short for a more verbose build # DUNEOPT=--display=short @@ -36,6 +36,7 @@ help: @echo " - apidoc: build ML API documentation" @echo " - release: build Coq in release mode" @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" @@ -100,6 +101,9 @@ apidoc: voboot release: voboot dune build $(DUNEOPT) -p coq +fmt: voboot + dune build @fmt + ocheck: voboot dune build $(DUNEOPT) @install --workspace=dev/dune-workspace.all diff --git a/Makefile.vofiles b/Makefile.vofiles index b6e0cd0a08..fe7ca7c36f 100644 --- a/Makefile.vofiles +++ b/Makefile.vofiles @@ -31,9 +31,9 @@ ALLMODS:=$(call vo_to_mod,$(ALLVO:.$(VO)=.vo)) # Converting a stdlib filename into native compiler filenames # Used for install targets -vo_to_cm = $(foreach vo,$(1),$(dir $(vo)).coq-native/$(subst /,_,$(patsubst user-contrib/%, N%, $(patsubst theories/%,NCoq_%,$(patsubst plugins/%,NCoq_%,$(vo:.$(VO)=.cm*)))))) +vo_to_cm = $(foreach vo,$(1),$(dir $(vo)).coq-native/$(subst /,_,$(patsubst user-contrib/%,N%, $(patsubst theories/%,NCoq_%,$(patsubst plugins/%,NCoq_%,$(vo:.$(VO)=.cm*)))))) -vo_to_obj = $(foreach vo,$(1),$(dir $(vo)).coq-native/$(subst /,_,$(patsubst user-contrib/%, N%, $(patsubst theories/%,NCoq_%,$(patsubst plugins/%,NCoq_%,$(vo:.$(VO)=.o)))))) +vo_to_obj = $(foreach vo,$(1),$(dir $(vo)).coq-native/$(subst /,_,$(patsubst user-contrib/%,N%, $(patsubst theories/%,NCoq_%,$(patsubst plugins/%,NCoq_%,$(vo:.$(VO)=.o)))))) ifdef QUICK GLOBFILES:= @@ -31,6 +31,9 @@ environment for semi-interactive development of machine-checked proofs. [![Homebrew package][homebrew-badge]][homebrew-link] [![nixpkgs unstable package][nixpkgs-badge]][nixpkgs-link] +[![Docker Hub package][dockerhub-badge]][dockerhub-link] +[![latest dockerized version][coqorg-badge]][coqorg-link] + [repology-badge]: https://repology.org/badge/latest-versions/coq.svg [repology-link]: https://repology.org/metapackage/coq/versions @@ -52,6 +55,12 @@ environment for semi-interactive development of machine-checked proofs. [nixpkgs-badge]: https://repology.org/badge/version-for-repo/nix_unstable/coq.svg [nixpkgs-link]: https://nixos.org/nixos/packages.html#coq +[dockerhub-badge]: https://img.shields.io/docker/automated/coqorg/coq.svg +[dockerhub-link]: https://hub.docker.com/r/coqorg/coq "Automated build on Docker Hub" + +[coqorg-badge]: https://images.microbadger.com/badges/version/coqorg/coq.svg +[coqorg-link]: https://github.com/coq-community/docker-coq/wiki#docker-coq-images "Docker images of Coq" + Download the pre-built packages of the [latest release][] for Windows and macOS; read the [help page][opam-using] on how to install Coq with OPAM; or refer to the [`INSTALL.md`](INSTALL.md) file for the procedure to install from source. diff --git a/azure-pipelines.yml b/azure-pipelines.yml index 31dcae0f82..aba2b05037 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -19,7 +19,7 @@ jobs: 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 python2 -P python3 + 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:\=/% diff --git a/checker/check.ml b/checker/check.ml index ffb2928d55..4ac5c56732 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -294,14 +294,22 @@ type intern_mode = Rec | Root | Dep (* Rec = standard, Root = -norec, Dep = depe (* Dependency graph *) let depgraph = ref LibraryMap.empty -let marshal_in_segment f ch = - try - let stop = input_binary_int ch in - let v = Analyze.instantiate (Analyze.parse_channel ch) in - let digest = Digest.input ch in +let marshal_in_segment ~validate ~value f ch = + if validate then + let v, stop, digest = + try + let stop = input_binary_int ch in + let v = Analyze.parse_channel ch in + let digest = Digest.input ch in + v, stop, digest + with _ -> + user_err (str "Corrupted file " ++ quote (str f)) + in + let () = Validate.validate ~debug:!Flags.debug value v in + let v = Analyze.instantiate v in Obj.obj v, stop, digest - with _ -> - user_err (str "Corrupted file " ++ quote (str f)) + else + System.marshal_in_segment f ch let skip_in_segment f ch = try @@ -312,30 +320,26 @@ let skip_in_segment f ch = with _ -> user_err (str "Corrupted file " ++ quote (str f)) -let marshal_or_skip ~intern_mode f ch = - if intern_mode <> Dep then - let v, pos, digest = marshal_in_segment f ch in +let marshal_or_skip ~validate ~value f ch = + if validate then + let v, pos, digest = marshal_in_segment ~validate ~value f ch in Some v, pos, digest else let pos, digest = skip_in_segment f ch in None, pos, digest let intern_from_file ~intern_mode (dir, f) = - let validate a b c = if intern_mode <> Dep then Validate.validate a b c in + let validate = intern_mode <> Dep in Flags.if_verbose chk_pp (str"[intern "++str f++str" ..."); let (sd,md,table,opaque_csts,digest) = try - let marshal_in_segment f ch = if intern_mode <> Dep - then marshal_in_segment f ch - else System.marshal_in_segment f ch - in let ch = System.with_magic_number_check raw_intern_library f in - let (sd:summary_disk), _, digest = marshal_in_segment f ch in - let (md:library_disk), _, digest = marshal_in_segment f ch in - let (opaque_csts:seg_univ option), _, udg = marshal_in_segment f ch in - let (tasks:'a option), _, _ = marshal_in_segment f ch 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 ~intern_mode f ch in + marshal_or_skip ~validate ~value:Values.v_opaquetable f ch in (* Verification of the final checksum *) let () = close_in ch in let ch = open_in_bin f in @@ -354,12 +358,7 @@ let intern_from_file ~intern_mode (dir, f) = user_err ~hdr:"intern_from_file" (str "The file "++str f++str " is still a .vio")) opaque_csts; - validate !Flags.debug Values.v_univopaques opaque_csts; end; - (* Verification of the unmarshalled values *) - validate !Flags.debug Values.v_libsum sd; - validate !Flags.debug Values.v_lib md; - validate !Flags.debug Values.(Opt v_opaquetable) table; Flags.if_verbose chk_pp (str" done]" ++ fnl ()); let digest = if opaque_csts <> None then Safe_typing.Dvivo (digest,udg) diff --git a/checker/checkInductive.ml b/checker/checkInductive.ml index 06ee4fcc7a..a2cf44389e 100644 --- a/checker/checkInductive.ml +++ b/checker/checkInductive.ml @@ -73,7 +73,7 @@ let check_arity env ar1 ar2 = match ar1, ar2 with List.equal (Option.equal Univ.Level.equal) ar.template_param_levels template_param_levels && UGraph.check_leq (universes env) template_level ar.template_level (* template_level is inferred by indtypes, so functor application can produce a smaller one *) - | (RegularArity _ | TemplateArity _), _ -> false + | (RegularArity _ | TemplateArity _), _ -> assert false let check_kelim k1 k2 = Sorts.family_leq k1 k2 @@ -139,16 +139,22 @@ let check_inductive env mind mb = let entry = to_entry mb in let { mind_packets; mind_record; mind_finite; mind_ntypes; mind_hyps; mind_nparams; mind_nparams_rec; mind_params_ctxt; - mind_universes; mind_variance; + mind_universes; mind_variance; mind_sec_variance; 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 - Indtypes.check_inductive env mind entry + 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; + check_template = mb_flags.check_template; + conv_oracle = mb_flags.conv_oracle; + } + env + in + Indtypes.check_inductive env ~sec_univs:None mind entry in let check = check mind in @@ -165,7 +171,9 @@ let check_inductive env mind mb = check "mind_params_ctxt" (Context.Rel.equal Constr.equal mb.mind_params_ctxt mind_params_ctxt); ignore mind_universes; (* Indtypes did the necessary checking *) - ignore mind_variance; (* Indtypes did the necessary checking *) + check "mind_variance" (Option.equal (Array.equal Univ.Variance.equal) + mb.mind_variance mind_variance); + check "mind_sec_variance" (Option.is_empty mind_sec_variance); ignore mind_private; (* passed through Indtypes *) ignore mind_typing_flags; diff --git a/checker/check_stat.ml b/checker/check_stat.ml index a67945ae94..d115744707 100644 --- a/checker/check_stat.ml +++ b/checker/check_stat.ml @@ -56,6 +56,9 @@ let pr_nonpositive env = let inds = fold_inductives (fun c cb acc -> if not cb.mind_typing_flags.check_positive then MutInd.to_string c :: acc else acc) env [] in pr_assumptions "Inductives whose positivity is assumed" inds +let pr_unsafe_template env = + let inds = fold_inductives (fun c cb acc -> if not cb.mind_typing_flags.check_template then MutInd.to_string c :: acc else acc) env [] in + pr_assumptions "Inductives using unchecked template polymorphism" inds let print_context env = if !output_context then begin @@ -67,7 +70,8 @@ let print_context env = str "* " ++ hov 0 (pr_axioms env ++ fnl()) ++ fnl() ++ str "* " ++ hov 0 (pr_type_in_type env ++ fnl()) ++ fnl() ++ str "* " ++ hov 0 (pr_unguarded env ++ fnl()) ++ fnl() ++ - str "* " ++ hov 0 (pr_nonpositive env))) + str "* " ++ hov 0 (pr_nonpositive env ++ fnl()) ++ fnl() ++ + str "* " ++ hov 0 (pr_unsafe_template env))) end let stats env = diff --git a/checker/validate.ml b/checker/validate.ml index 070a112bb6..6ffc43394b 100644 --- a/checker/validate.ml +++ b/checker/validate.ml @@ -8,32 +8,39 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open Analyze + (* This module defines validation functions to ensure an imported value (using input_value) has the correct structure. *) -let rec pr_obj_rec o = - if Obj.is_int o then - Format.print_int(Obj.magic o) - else if Obj.is_block o then - let t = Obj.tag o in - if t > Obj.no_scan_tag then - if t = Obj.string_tag then - Format.print_string ("\""^String.escaped(Obj.magic o)^"\"") - else - Format.print_string "?" - else - (let n = Obj.size o in - Format.print_string ("#"^string_of_int t^"("); - Format.open_hvbox 0; - for i = 0 to n-1 do - pr_obj_rec (Obj.field o i); - if i<>n-1 then (Format.print_string ","; Format.print_cut()) - done; - Format.close_box(); - Format.print_string ")") - else Format.print_string "?" - -let pr_obj o = pr_obj_rec o; Format.print_newline() +let rec pr_obj_rec mem o = match o with +| Int i -> + Format.print_int i +| Ptr p -> + let v = LargeArray.get mem p in + begin match v with + | Struct (tag, data) -> + let n = Array.length data in + Format.print_string ("#"^string_of_int tag^"("); + Format.open_hvbox 0; + for i = 0 to n-1 do + pr_obj_rec mem (Array.get data i); + if i<>n-1 then (Format.print_string ","; Format.print_cut()) + done; + Format.close_box(); + Format.print_string ")" + | String s -> + Format.print_string ("\""^String.escaped s^"\"") + | Int64 _ + | Float64 _ -> + Format.print_string "?" + end +| Atm tag -> + Format.print_string ("#"^string_of_int tag^"()"); +| Fun addr -> + Format.printf "fun@%x" addr + +let pr_obj mem o = pr_obj_rec mem o; Format.print_newline() (**************************************************************************) (* Obj low-level validators *) @@ -48,63 +55,115 @@ type error_context = error_frame list let mt_ec : error_context = [] let (/) (ctx:error_context) s : error_context = s::ctx -exception ValidObjError of string * error_context * Obj.t -let fail ctx o s = raise (ValidObjError(s,ctx,o)) +exception ValidObjError of string * error_context * data +let fail _mem ctx o s = raise (ValidObjError(s,ctx,o)) + +let is_block mem o = match o with +| Ptr _ | Atm _ -> true +| Fun _ | Int _ -> false + +let is_int _mem o = match o with +| Int _ -> true +| Fun _ | Ptr _ | Atm _ -> false + +let is_int64 mem o = match o with +| Int _ | Fun _ | Atm _ -> false +| Ptr p -> + match LargeArray.get mem p with + | Int64 _ -> true + | Float64 _ | Struct _ | String _ -> false + +let is_float64 mem o = match o with +| Int _ | Fun _ | Atm _ -> false +| Ptr p -> + match LargeArray.get mem p with + | Float64 _ -> true + | Int64 _ | Struct _ | String _ -> false + +let get_int _mem = function +| Int i -> i +| Fun _ | Ptr _ | Atm _ -> assert false + +let tag mem o = match o with +| Atm tag -> tag +| Fun _ -> Obj.out_of_heap_tag +| Int _ -> Obj.int_tag +| Ptr p -> + match LargeArray.get mem p with + | Struct (tag, _) -> tag + | String _ -> Obj.string_tag + | Float64 _ -> Obj.double_tag + | Int64 _ -> Obj.custom_tag + +let size mem o = match o with +| Atm _ -> 0 +| Fun _ | Int _ -> assert false +| Ptr p -> + match LargeArray.get mem p with + | Struct (tag, blk) -> Array.length blk + | String _ | Float64 _ | Int64 _ -> assert false + +let field mem o i = match o with +| Atm _ | Fun _ | Int _ -> assert false +| Ptr p -> + match LargeArray.get mem p with + | Struct (tag, blk) -> Array.get blk i + | String _ | Float64 _ | Int64 _ -> assert false (* Check that object o is a block with tag t *) -let val_tag t ctx o = - if Obj.is_block o && Obj.tag o = t then () - else fail ctx o ("expected tag "^string_of_int t) - -let val_block ctx o = - if Obj.is_block o then - (if Obj.tag o > Obj.no_scan_tag then - fail ctx o "block: found no scan tag") - else fail ctx o "expected block obj" - -let val_dyn ctx o = - let fail () = fail ctx o "expected a Dyn.t" in - if not (Obj.is_block o) then fail () - else if not (Obj.size o = 2) then fail () - else if not (Obj.tag (Obj.field o 0) = Obj.int_tag) then fail () +let val_tag t mem ctx o = + if is_block mem o && tag mem o = t then () + else fail mem ctx o ("expected tag "^string_of_int t) + +let val_block mem ctx o = + if is_block mem o then + (if tag mem o > Obj.no_scan_tag then + fail mem ctx o "block: found no scan tag") + else fail mem ctx o "expected block obj" + +let val_dyn mem ctx o = + let fail () = fail mem ctx o "expected a Dyn.t" in + if not (is_block mem o) then fail () + else if not (size mem o = 2) then fail () + else if not (tag mem (field mem o 0) = Obj.int_tag) then fail () else () open Values -let rec val_gen v ctx o = match v with - | Tuple (name,vs) -> val_tuple ~name vs ctx o - | Sum (name,cc,vv) -> val_sum name cc vv ctx o - | Array v -> val_array v ctx o - | List v0 -> val_sum "list" 1 [|[|Annot ("elem",v0);v|]|] ctx o - | Opt v -> val_sum "option" 1 [|[|v|]|] ctx o - | Int -> if not (Obj.is_int o) then fail ctx o "expected an int" +let rec val_gen v mem ctx o = match v with + | Tuple (name,vs) -> val_tuple ~name vs mem ctx o + | Sum (name,cc,vv) -> val_sum name cc vv mem ctx o + | Array v -> val_array v mem ctx o + | List v0 -> val_sum "list" 1 [|[|Annot ("elem",v0);v|]|] mem ctx o + | Opt v -> val_sum "option" 1 [|[|v|]|] mem ctx o + | Int -> if not (is_int mem o) then fail mem ctx o "expected an int" | String -> - (try val_tag Obj.string_tag ctx o - with Failure _ -> fail ctx o "expected a string") + (try val_tag Obj.string_tag mem ctx o + with Failure _ -> fail mem ctx o "expected a string") | Any -> () - | Fail s -> fail ctx o ("unexpected object " ^ s) - | Annot (s,v) -> val_gen v (ctx/CtxAnnot s) o - | Dyn -> val_dyn ctx o - | Proxy { contents = v } -> val_gen v ctx o - | Uint63 -> val_uint63 ctx o - | Float64 -> val_float64 ctx o + | Fail s -> fail mem ctx o ("unexpected object " ^ s) + | Annot (s,v) -> val_gen v mem (ctx/CtxAnnot s) o + | Dyn -> val_dyn mem ctx o + | Proxy { contents = v } -> val_gen v mem ctx o + | Int64 -> val_int64 mem ctx o + | Float64 -> val_float64 mem ctx o (* Check that an object is a tuple (or a record). vs is an array of value representation for each field. Its size corresponds to the expected size of the object. *) -and val_tuple ?name vs ctx o = +and val_tuple ?name vs mem ctx o = let ctx = match name with | Some n -> ctx/CtxType n | _ -> ctx in let n = Array.length vs in let val_fld i v = - val_gen v (ctx/(CtxField i)) (Obj.field o i) in - val_block ctx o; - if Obj.size o = n then Array.iteri val_fld vs + val_gen v mem (ctx/(CtxField i)) (field mem o i) in + val_block mem ctx o; + if size mem o = n then Array.iteri val_fld vs else - fail ctx o - ("tuple size: found "^string_of_int (Obj.size o)^ + fail mem ctx o + ("tuple size: found "^string_of_int (size mem o)^ ", expected "^string_of_int n) (* Check that the object is either a constant constructor of tag < cc, @@ -113,35 +172,35 @@ and val_tuple ?name vs ctx o = The size of vv corresponds to the number of non-constant constructors, and the size of vv.(i) is the expected arity of the i-th non-constant constructor. *) -and val_sum name cc vv ctx o = +and val_sum name cc vv mem ctx o = let ctx = ctx/CtxType name in - if Obj.is_block o then - (val_block ctx o; + if is_block mem o then + (val_block mem ctx o; let n = Array.length vv in - let i = Obj.tag o in + let i = tag mem o in let ctx' = if n=1 then ctx else ctx/CtxTag i in - if i < n then val_tuple vv.(i) ctx' o - else fail ctx' o ("sum: unexpected tag")) - else if Obj.is_int o then - let (n:int) = Obj.magic o in + if i < n then val_tuple vv.(i) mem ctx' o + else fail mem ctx' o ("sum: unexpected tag")) + else if is_int mem o then + let (n:int) = get_int mem o in (if n<0 || n>=cc then - fail ctx o ("bad constant constructor "^string_of_int n)) - else fail ctx o "not a sum" + fail mem ctx o ("bad constant constructor "^string_of_int n)) + else fail mem ctx o "not a sum" (* Check the o is an array of values satisfying f. *) -and val_array v ctx o = - val_block (ctx/CtxType "array") o; - for i = 0 to Obj.size o - 1 do - val_gen v ctx (Obj.field o i) +and val_array v mem ctx o = + val_block mem (ctx/CtxType "array") o; + for i = 0 to size mem o - 1 do + val_gen v mem ctx (field mem o i) done -and val_uint63 ctx o = - if not (Uint63.is_uint63 o) then - fail ctx o "not a 63-bit unsigned integer" +and val_int64 mem ctx o = + if not (is_int64 mem o) then + fail mem ctx o "not a 63-bit unsigned integer" -and val_float64 ctx o = - if not (Float64.is_float64 o) then - fail ctx o "not a 64-bit float" +and val_float64 mem ctx o = + if not (is_float64 mem o) then + fail mem ctx o "not a 64-bit float" let print_frame = function | CtxType t -> t @@ -149,12 +208,11 @@ let print_frame = function | CtxField i -> Printf.sprintf "fld=%i" i | CtxTag i -> Printf.sprintf "tag=%i" i -let validate debug v x = - let o = Obj.repr x in - try val_gen v mt_ec o +let validate ~debug 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 obj); + 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 fbcea3121b..584ea6ed95 100644 --- a/checker/validate.mli +++ b/checker/validate.mli @@ -8,4 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -val validate : bool -> Values.value -> 'a -> unit +open Analyze + +val validate : debug:bool -> Values.value -> data * obj LargeArray.t -> unit diff --git a/checker/values.ml b/checker/values.ml index 56321a27ff..fff166f27b 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -34,7 +34,7 @@ type value = | Dyn | Proxy of value ref - | Uint63 + | Int64 | Float64 let fix (f : value -> value) : value = @@ -129,6 +129,9 @@ let v_cast = v_enum "cast_kind" 4 let v_proj_repr = v_tuple "projection_repr" [|v_ind;Int;Int;v_id|] let v_proj = v_tuple "projection" [|v_proj_repr; v_bool|] +let v_uint63 = + if Sys.word_size == 64 then Int else Int64 + let rec v_constr = Sum ("constr",0,[| [|Int|]; (* Rel *) @@ -148,7 +151,7 @@ let rec v_constr = [|v_fix|]; (* Fix *) [|v_cofix|]; (* CoFix *) [|v_proj;v_constr|]; (* Proj *) - [|Uint63|]; (* Int *) + [|v_uint63|]; (* Int *) [|Float64|] (* Int *) |]) @@ -299,6 +302,7 @@ let v_ind_pack = v_tuple "mutual_inductive_body" v_rctxt; v_univs; (* universes *) Opt (Array v_variance); + Opt (Array v_variance); Opt v_bool; v_typing_flags|] diff --git a/checker/values.mli b/checker/values.mli index ec3b91d5dd..15d307ee29 100644 --- a/checker/values.mli +++ b/checker/values.mli @@ -38,7 +38,7 @@ type value = | Proxy of value ref (** Same as the inner value, used to define recursive types *) - | Uint63 + | Int64 | Float64 (** NB: List and Opt have their own constructors to make it easy to diff --git a/checker/votour.ml b/checker/votour.ml index 9adcc874ac..452809f7bb 100644 --- a/checker/votour.ml +++ b/checker/votour.ml @@ -157,7 +157,7 @@ let rec get_name ?(extra=false) = function |Annot (s,v) -> s^"/"^get_name ~extra v |Dyn -> "<dynamic>" | Proxy v -> get_name ~extra !v - | Uint63 -> "Uint63" + | Int64 -> "Int64" | Float64 -> "Float64" (** For tuples, its quite handy to display the inner 1st string (if any). @@ -263,7 +263,7 @@ let rec get_children v o pos = match v with end |Fail s -> raise Forbidden | Proxy v -> get_children !v o pos - | Uint63 -> raise Exit + | Int64 -> raise Exit | Float64 -> raise Exit let get_children v o pos = diff --git a/clib/backtrace.ml b/clib/backtrace.ml deleted file mode 100644 index 81803a81a5..0000000000 --- a/clib/backtrace.ml +++ /dev/null @@ -1,119 +0,0 @@ -(************************************************************************) -(* * 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) *) -(************************************************************************) -[@@@ocaml.warning "-37"] - -type raw_frame = -| Known_location of bool (* is_raise *) - * string (* filename *) - * int (* line number *) - * int (* start char *) - * int (* end char *) -| Unknown_location of bool (*is_raise*) - -type location = { - loc_filename : string; - loc_line : int; - loc_start : int; - loc_end : int; -} - -type frame = { frame_location : location option; frame_raised : bool; } - -external get_exception_backtrace: unit -> raw_frame array option - = "caml_get_exception_backtrace" - -type t = raw_frame array list -(** List of partial raw stack frames, in reverse order *) - -let empty = [] - -let of_raw = function -| Unknown_location r -> - { frame_location = None; frame_raised = r; } -| Known_location (r, file, line, st, en) -> - let loc = { - loc_filename = file; - loc_line = line; - loc_start = st; - loc_end = en; - } in - { frame_location = Some loc; frame_raised = r; } - -let rec repr_aux accu = function -| [] -> accu -| fragment :: stack -> - let len = Array.length fragment in - let rec append accu i = - if i = len then accu - else append (of_raw fragment.(i) :: accu) (succ i) - in - repr_aux (append accu 0) stack - -let repr bt = repr_aux [] (List.rev bt) - -let push stack = match get_exception_backtrace () with -| None -> [] -| Some frames -> frames :: stack - -(** Utilities *) - -let print_frame frame = - let raise = if frame.frame_raised then "raise" else "frame" in - match frame.frame_location with - | None -> Printf.sprintf "%s @ unknown" raise - | Some loc -> - Printf.sprintf "%s @ file \"%s\", line %d, characters %d-%d" - raise loc.loc_filename loc.loc_line loc.loc_start loc.loc_end - -(** Exception manipulation *) - -let backtrace : t Exninfo.t = Exninfo.make () - -let is_recording = ref false - -let record_backtrace b = - let () = Printexc.record_backtrace b in - is_recording := b - -let get_backtrace e = - Exninfo.get e backtrace - -let add_backtrace e = - if !is_recording then - (* This must be the first function call, otherwise the stack may be - destroyed *) - let current = get_exception_backtrace () in - let info = Exninfo.info e in - begin match current with - | None -> (e, info) - | Some fragment -> - let bt = match get_backtrace info with - | None -> [] - | Some bt -> bt - in - let bt = fragment :: bt in - (e, Exninfo.add info backtrace bt) - end - else - let info = Exninfo.info e in - (e, info) - -let app_backtrace ~src ~dst = - if !is_recording then - match get_backtrace src with - | None -> dst - | Some bt -> - match get_backtrace dst with - | None -> - Exninfo.add dst backtrace bt - | Some nbt -> - let bt = bt @ nbt in - Exninfo.add dst backtrace bt - else dst diff --git a/clib/backtrace.mli b/clib/backtrace.mli deleted file mode 100644 index 55c60e5483..0000000000 --- a/clib/backtrace.mli +++ /dev/null @@ -1,98 +0,0 @@ -(************************************************************************) -(* * 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) *) -(************************************************************************) - -(** * Low-level management of OCaml backtraces. - - Currently, OCaml manages its backtraces in a very imperative way. That is to - say, it only keeps track of the stack destroyed by the last raised exception. - So we have to be very careful when using this module not to do silly things. - - Basically, you need to manually handle the reraising of exceptions. In order - to do so, each time the backtrace is lost, you must [push] the stack fragment. - This essentially occurs whenever a [with] handler is crossed. - -*) - -(** {5 Backtrace information} *) - -type location = { - loc_filename : string; - loc_line : int; - loc_start : int; - loc_end : int; -} -(** OCaml debugging information for function calls. *) - -type frame = { frame_location : location option; frame_raised : bool; } -(** A frame contains two informations: its optional physical location, and - whether it raised the exception or let it pass through. *) - -type t -(** Type of backtraces. They're essentially stack of frames. *) - -val empty : t -(** Empty frame stack. *) - -val push : t -> t -(** Add the current backtrace information to a given backtrace. *) - -val repr : t -> frame list -(** Represent a backtrace as a list of frames. Leftmost element is the outermost - call. *) - -(** {5 Utilities} *) - -val print_frame : frame -> string -(** Represent a frame. *) - -(** {5 Exception handling} *) - -val record_backtrace : bool -> unit -(** Whether to activate the backtrace recording mechanism. Note that it will - only work whenever the program was compiled with the [debug] flag. *) - -val get_backtrace : Exninfo.info -> t option -(** Retrieve the optional backtrace coming with the exception. *) - -val add_backtrace : exn -> Exninfo.iexn -(** Add the current backtrace information to the given exception. - - The intended use case is of the form: {[ - - try foo - with - | Bar -> bar - | err -> let err = add_backtrace err in baz - - ]} - - WARNING: any intermediate code between the [with] and the handler may - modify the backtrace. Yes, that includes [when] clauses. Ideally, what you - should do is something like: {[ - - try foo - with err -> - let err = add_backtrace err in - match err with - | Bar -> bar - | err -> baz - - ]} - - I admit that's a bit heavy, but there is not much to do... - -*) - -val app_backtrace : src:Exninfo.info -> dst:Exninfo.info -> Exninfo.info -(** Append the backtrace from [src] to [dst]. The returned exception is [dst] - except for its backtrace information. This is targeted at container - exceptions, that is, exceptions that contain exceptions. This way, one can - transfer the backtrace from the container to the underlying exception, as if - the latter was the one originally raised. *) diff --git a/clib/cArray.ml b/clib/cArray.ml index be59ae57d0..0f57204cc1 100644 --- a/clib/cArray.ml +++ b/clib/cArray.ml @@ -392,18 +392,30 @@ let iter2_i f v1 v2 = let () = if not (Int.equal len2 len1) then invalid_arg "Array.iter2" in for i = 0 to len1 - 1 do f i (uget v1 i) (uget v2 i) done -let pure_functional = false +let map_right f a = + let l = length a in + if l = 0 then [||] else begin + let r = Array.make l (f (unsafe_get a (l-1))) in + for i = l-2 downto 0 do + unsafe_set r i (f (unsafe_get a i)) + done; + r + end + +let map2_right f a b = + let l = length a in + if l <> length b then invalid_arg "CArray.map2_right: length mismatch"; + if l = 0 then [||] else begin + let r = Array.make l (f (unsafe_get a (l-1)) (unsafe_get b (l-1))) in + for i = l-2 downto 0 do + unsafe_set r i (f (unsafe_get a i) (unsafe_get b i)) + done; + r + end let fold_right_map f v e = -if pure_functional then - let (l,e) = - Array.fold_right - (fun x (l,e) -> let (y,e) = f x e in (y::l,e)) - v ([],e) in - (Array.of_list l,e) -else let e' = ref e in - let v' = Array.map (fun x -> let (y,e) = f x !e' in e' := e; y) v in + let v' = map_right (fun x -> let (y,e) = f x !e' in e' := e; y) v in (v',!e') let fold_left_map f e v = @@ -414,7 +426,7 @@ let fold_left_map f e v = let fold_right2_map f v1 v2 e = let e' = ref e in let v' = - map2 (fun x1 x2 -> let (y,e) = f x1 x2 !e' in e' := e; y) v1 v2 + map2_right (fun x1 x2 -> let (y,e) = f x1 x2 !e' in e' := e; y) v1 v2 in (v',!e') diff --git a/clib/cArray.mli b/clib/cArray.mli index f94af26515..94390a369f 100644 --- a/clib/cArray.mli +++ b/clib/cArray.mli @@ -107,7 +107,7 @@ sig (** Same than [fold_left2_map] but passing the index of the array *) val fold_right2_map : ('a -> 'b -> 'c -> 'd * 'c) -> 'a array -> 'b array -> 'c -> 'd array * 'c - (** Same with two arrays, folding on the left *) + (** Same with two arrays, folding on the right *) val distinct : 'a array -> bool (** Return [true] if every element of the array is unique (for default diff --git a/clib/cEphemeron.ml b/clib/cEphemeron.ml index a2a6933e36..78aa8266e4 100644 --- a/clib/cEphemeron.ml +++ b/clib/cEphemeron.ml @@ -103,8 +103,4 @@ let default (typ, boxkey) default = try (EHashtbl.find values boxkey).get typ with Not_found -> default -let iter_opt (typ, boxkey) f = - try f ((EHashtbl.find values boxkey).get typ) - with Not_found -> () - let clean () = EHashtbl.clean values diff --git a/clib/cEphemeron.mli b/clib/cEphemeron.mli index 4c10a3d66f..e567e9b2c5 100644 --- a/clib/cEphemeron.mli +++ b/clib/cEphemeron.mli @@ -43,12 +43,12 @@ type 'a key val create : 'a -> 'a key -(* May raise InvalidKey *) exception InvalidKey + val get : 'a key -> 'a +(** May raise InvalidKey *) -(* These never fail. *) val default : 'a key -> 'a -> 'a -val iter_opt : 'a key -> ('a -> unit) -> unit +(** Never fails. *) val clean : unit -> unit diff --git a/clib/cUnix.ml b/clib/cUnix.ml index c5f6bebb8e..6e3ad59b1f 100644 --- a/clib/cUnix.ml +++ b/clib/cUnix.ml @@ -140,3 +140,20 @@ let same_file f1 = Unix.Unix_error _ -> false) with Unix.Unix_error _ -> (fun _ -> false) + +(* Copied from ocaml filename.ml *) +let prng = lazy(Random.State.make_self_init ()) + +let temp_file_name temp_dir prefix suffix = + let rnd = (Random.State.bits (Lazy.force prng)) land 0xFFFFFF in + Filename.concat temp_dir (Printf.sprintf "%s%06x%s" prefix rnd suffix) + +let mktemp_dir ?(temp_dir=Filename.get_temp_dir_name()) prefix suffix = + let rec try_name counter = + let name = temp_file_name temp_dir prefix suffix in + match Unix.mkdir name 0o700 with + | () -> name + | exception (Sys_error _ as e) -> + if counter >= 1000 then raise e else try_name (counter + 1) + in + try_name 0 diff --git a/clib/cUnix.mli b/clib/cUnix.mli index 17574b3c42..55d307c724 100644 --- a/clib/cUnix.mli +++ b/clib/cUnix.mli @@ -65,3 +65,5 @@ val waitpid_non_intr : int -> Unix.process_status (** Check if two file names refer to the same (existing) file *) val same_file : string -> string -> bool +(** Like [Stdlib.Filename.temp_file] but producing a directory. *) +val mktemp_dir : ?temp_dir:string -> string -> string -> string diff --git a/clib/exninfo.ml b/clib/exninfo.ml index 34f76a2edd..ee998c2f17 100644 --- a/clib/exninfo.ml +++ b/clib/exninfo.ml @@ -57,12 +57,29 @@ let rec find_and_remove_assoc (i : int) = function if rem == ans then (r, l) else (r, (j, v) :: ans) -let iraise e = +type backtrace = Printexc.raw_backtrace +let backtrace_to_string = Printexc.raw_backtrace_to_string + +let backtrace_info : backtrace t = make () + +let is_recording = ref false + +let record_backtrace b = + let () = Printexc.record_backtrace b in + is_recording := b + +let get_backtrace e = get e backtrace_info + +let iraise (e,i) = let () = Mutex.lock lock in let id = Thread.id (Thread.self ()) in - let () = current := (id, e) :: remove_assoc id !current in + let () = current := (id, (e,i)) :: remove_assoc id !current in let () = Mutex.unlock lock in - raise (fst e) + match get i backtrace_info with + | None -> + raise e + | Some bt -> + Printexc.raise_with_backtrace e bt let raise ?info e = match info with | None -> @@ -72,11 +89,7 @@ let raise ?info e = match info with let () = Mutex.unlock lock in raise e | Some i -> - let () = Mutex.lock lock in - let id = Thread.id (Thread.self ()) in - let () = current := (id, (e, i)) :: remove_assoc id !current in - let () = Mutex.unlock lock in - raise e + iraise (e,i) let find_and_remove () = let () = Mutex.lock lock in @@ -104,3 +117,13 @@ let info e = (* Mismatch: the raised exception is not the one stored, either because the previous raise was not instrumented, or because something went wrong. *) Store.empty + +let capture e = + if !is_recording then + (* This must be the first function call, otherwise the stack may be + destroyed *) + let bt = Printexc.get_raw_backtrace () in + let info = info e in + e, add info backtrace_info bt + else + e, info e diff --git a/clib/exninfo.mli b/clib/exninfo.mli index 30803e3e6a..36cc44cf82 100644 --- a/clib/exninfo.mli +++ b/clib/exninfo.mli @@ -34,6 +34,49 @@ val get : info -> 'a t -> 'a option val info : exn -> info (** Retrieve the information of the last exception raised. *) +type backtrace + +val get_backtrace : info -> backtrace option +(** [get_backtrace info] does get the backtrace associated to info *) + +val backtrace_to_string : backtrace -> string +(** [backtrace_to_string info] does get the backtrace associated to info *) + +val record_backtrace : bool -> unit + +val capture : exn -> iexn +(** Add the current backtrace information to the given exception. + + The intended use case is of the form: {[ + + try foo + with + | Bar -> bar + | exn -> + let exn = Exninfo.capture err in + baz + + ]} + + where [baz] should re-raise using [iraise] below. + + WARNING: any intermediate code between the [with] and the handler may + modify the backtrace. Yes, that includes [when] clauses. Ideally, what you + should do is something like: {[ + + try foo + with exn -> + let exn = Exninfo.capture exn in + match err with + | Bar -> bar + | err -> baz + + ]} + + I admit that's a bit heavy, but there is not much to do... + +*) + val iraise : iexn -> 'a (** Raise the given enriched exception. *) @@ -29,7 +29,6 @@ depends: [ build: [ [ "./configure" "-prefix" prefix "-native-compiler" "no" ] - [ "dune" "build" "@vodeps" ] - [ "dune" "exec" "coq_dune" "_build/default/.vfiles.d" ] + [ "make" "-f" "Makefile.dune" "voboot" ] [ "dune" "build" "-p" name "-j" jobs ] ] diff --git a/default.nix b/default.nix index ee4a6046ea..174e199014 100644 --- a/default.nix +++ b/default.nix @@ -41,9 +41,7 @@ stdenv.mkDerivation rec { buildInputs = [ hostname - python2 # update-compat.py python3 time # coq-makefile timing tools - dune ] ++ (with ocamlPackages; [ ocaml findlib num ]) ++ optionals buildIde [ @@ -68,6 +66,7 @@ stdenv.mkDerivation rec { [ jq curl gitFull gnupg ] # Dependencies of the merging script ++ (with ocamlPackages; [ merlin ocp-indent ocp-index utop ocamlformat ]) # Dev tools ++ [ graphviz ] # Useful for STM debugging + ++ [ dune_2 ] # Maybe the next build system ); src = @@ -112,7 +111,7 @@ stdenv.mkDerivation rec { setupHook = writeText "setupHook.sh" " addCoqPath () { if test -d \"$1/lib/coq/${coq-version}/user-contrib\"; then - export COQPATH=\"$COQPATH\${COQPATH:+:}$1/lib/coq/${coq-version}/user-contrib/\" + export COQPATH=\"\${COQPATH-}\${COQPATH:+:}$1/lib/coq/${coq-version}/user-contrib/\" fi } diff --git a/dev/base_include b/dev/base_include index 4841db8953..96a867475d 100644 --- a/dev/base_include +++ b/dev/base_include @@ -60,11 +60,11 @@ open Cases open Pattern open Patternops open Cbv -open Classops +open Coercionops open Arguments_renaming open Pretyping open Cbv -open Classops +open Coercionops open Clenv open Clenvtac open Constr_matching @@ -134,7 +134,7 @@ open Tacticals open Tactics open Eqschemes -open Class +open ComCoercion open ComDefinition open Indschemes open Ind_tables diff --git a/dev/build/windows/MakeCoq_MinGW.bat b/dev/build/windows/MakeCoq_MinGW.bat index c75acb0560..577ce35aae 100755 --- a/dev/build/windows/MakeCoq_MinGW.bat +++ b/dev/build/windows/MakeCoq_MinGW.bat @@ -420,6 +420,7 @@ copy "%BATCHDIR%\configure_profile.sh" "%CYGWIN_INSTALLDIR_WFMT%\var\tmp" || GOT ECHO ========== BUILD COQ ==========
MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build"
+RMDIR /S /Q "%CYGWIN_INSTALLDIR_WFMT%\build\patches"
MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build\patches"
COPY "%BATCHDIR%\makecoq_mingw.sh" "%CYGWIN_INSTALLDIR_WFMT%\build" || GOTO ErrorExit
diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index b1c752ba60..859b3e3166 100755 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -921,69 +921,6 @@ function make_gtk_sourceview3 { build_conf_make_inst https://download.gnome.org/sources/gtksourceview/3.24 gtksourceview-3.24.11 tar.xz make_arch_pkg_config } -##### FLEXDLL FLEXLINK ##### - -# Note: there is a circular dependency between flexlink and ocaml (resolved in Ocaml 4.03.) -# For MinGW it is not even possible to first build an Ocaml without flexlink support, -# Because Makefile.nt doesn't support this. So we have to use a binary flexlink. -# One could of cause do a bootstrap run ... - -# Install flexdll objects - -function install_flexdll { - cp flexdll.h "$PREFIXMINGW/include" - if [ "$TARGET_ARCH" == "i686-w64-mingw32" ]; then - cp flexdll*_mingw.o "/usr/$TARGET_ARCH/bin" - cp flexdll*_mingw.o "$PREFIXOCAML/bin" - elif [ "$TARGET_ARCH" == "x86_64-w64-mingw32" ]; then - cp flexdll*_mingw64.o "/usr/$TARGET_ARCH/bin" - cp flexdll*_mingw64.o "$PREFIXOCAML/bin" - else - echo "Unknown target architecture" - return 1 - fi -} - -# Install flexlink - -function install_flexlink { - cp flexlink.exe "/usr/$TARGET_ARCH/bin" - - cp flexlink.exe "$PREFIXOCAML/bin" -} - -# Get binary flexdll flexlink for building OCaml -# An alternative is to first build an OCaml without shared library support and build flexlink with it - -function get_flex_dll_link_bin { - if build_prep https://github.com/alainfrisch/flexdll/releases/download/0.37/ flexdll-bin-0.37 zip 1 ; then - install_flexdll - install_flexlink - build_post - fi -} - -# Build flexdll and flexlink from sources after building OCaml - -function make_flex_dll_link { - if build_prep https://github.com/alainfrisch/flexdll/archive 0.37 tar.gz 1 flexdll-0.37 ; then - if [ "$TARGET_ARCH" == "i686-w64-mingw32" ]; then - # shellcheck disable=SC2086 - log1 make $MAKE_OPT build_mingw flexlink.exe - elif [ "$TARGET_ARCH" == "x86_64-w64-mingw32" ]; then - # shellcheck disable=SC2086 - log1 make $MAKE_OPT build_mingw64 flexlink.exe - else - echo "Unknown target architecture" - return 1 - fi - install_flexdll - install_flexlink - log2 make clean - build_post - fi -} - ##### LN replacement ##### # Note: this does support symlinks, but symlinks require special user rights on Windows. @@ -1016,39 +953,22 @@ function make_arch_pkg_config { ##### OCAML ##### function make_ocaml { - get_flex_dll_link_bin - if build_prep https://github.com/ocaml/ocaml/archive 4.07.1 tar.gz 1 ocaml-4.07.1 ; then - # See README.win32.adoc - cp config/m-nt.h byterun/caml/m.h - cp config/s-nt.h byterun/caml/s.h - if [ "$TARGET_ARCH" == "i686-w64-mingw32" ]; then - cp config/Makefile.mingw config/Makefile - elif [ "$TARGET_ARCH" == "x86_64-w64-mingw32" ]; then - cp config/Makefile.mingw64 config/Makefile - else - echo "Unknown target architecture" - return 1 - fi + if build_prep https://github.com/ocaml/ocaml/archive 4.08.1 tar.gz 1 ocaml-4.08.1 ; then + # see https://github.com/ocaml/ocaml/blob/4.08/README.win32.adoc - # Prefix is fixed in make file - replace it with the real one - # TODO: this might not work if PREFIX contains spaces - sed -i "s|^PREFIX=.*|PREFIX=$PREFIXOCAML|" config/Makefile + # get flexdll sources into folder ./flexdll + get_expand_source_tar https://github.com/alainfrisch/flexdll/archive 0.37 tar.gz 1 flexdll-0.37 flexdll # We don't want to mess up Coq's directory structure so put the OCaml library in a separate folder - # If we refer to the make variable ${PREFIX} below, camlp5 ends up having the wrong path: - # D:\bin\coq64_buildtest_abs_ocaml4\bin>ocamlc -where => D:/bin/coq64_buildtest_abs_ocaml4/libocaml - # D:\bin\coq64_buildtest_abs_ocaml4\bin>camlp4 -where => ${PREFIX}/libocaml\camlp4 - # So we put an explicit path in there - sed -i "s|^LIBDIR=.*|LIBDIR=$PREFIXOCAML/libocaml|" config/Makefile - - # Note: ocaml doesn't support -j 8, so don't pass MAKE_OPT - # I verified that 4.02.3 still doesn't support parallel build - log2 make world -f Makefile.nt - log2 make bootstrap -f Makefile.nt - log2 make opt -f Makefile.nt - log2 make opt.opt -f Makefile.nt - log2 make install -f Makefile.nt - # TODO log2 make clean -f Makefile.nt Temporarily disabled for ocamlbuild development + logn configure ./configure --build=i686-pc-cygwin --host="$TARGET_ARCH" --prefix="$PREFIXOCAML" --libdir="$PREFIXOCAML/libocaml" + + log2 make flexdll $MAKE_OPT + # Note the next command might change after 4.09.x to just make + # see https://github.com/ocaml/ocaml/blob/4.09/README.win32.adoc + # compare to https://github.com/ocaml/ocaml/blob/4.10/README.win32.adoc + log2 make world.opt $MAKE_OPT + log2 make flexlink.opt $MAKE_OPT + log2 make install $MAKE_OPT # Move license files and other into into special folder if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then @@ -1065,7 +985,6 @@ function make_ocaml { build_post fi - make_flex_dll_link } ##### OCAML EXTRA TOOLS ##### @@ -1099,7 +1018,7 @@ function make_num { function make_ocamlbuild { make_ocaml - if build_prep https://github.com/ocaml/ocamlbuild/archive 0.12.0 tar.gz 1 ocamlbuild-0.12.0; then + if build_prep https://github.com/ocaml/ocamlbuild/archive 0.14.0 tar.gz 1 ocamlbuild-0.14.0; then log2 make configure OCAML_NATIVE=true OCAMLBUILD_PREFIX=$PREFIXOCAML OCAMLBUILD_BINDIR=$PREFIXOCAML/bin OCAMLBUILD_LIBDIR=$PREFIXOCAML/lib log1 make $MAKE_OPT log2 make install @@ -1112,6 +1031,7 @@ function make_ocamlbuild { function make_findlib { make_ocaml make_ocamlbuild + # Note: latest is 1.8.1 but http://projects.camlcity.org/projects/dl/findlib-1.8.1/doc/README says this is for OCaml 4.09 if build_prep https://opam.ocaml.org/1.2.2/archives ocamlfind.1.8.0+opam tar.gz 1 ; then logn configure ./configure -bindir "$PREFIXOCAML\\bin" -sitelib "$PREFIXOCAML\\libocaml\\site-lib" -config "$PREFIXOCAML\\etc\\findlib.conf" # Note: findlib doesn't support -j 8, so don't pass MAKE_OPT diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 87122e0fb5..7342bc72e7 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -97,8 +97,11 @@ ######################################################################## # Coquelicot ######################################################################## -: "${coquelicot_CI_REF:=master}" -: "${coquelicot_CI_GITURL:=https://gitlab.inria.fr/coquelicot/coquelicot}" +# Modified until https://gitlab.inria.fr/coquelicot/coquelicot/merge_requests/2 is merged +: "${coquelicot_CI_REF:=fix-rlist-import}" +: "${coquelicot_CI_GITURL:=https://gitlab.inria.fr/pedrot/coquelicot}" +# : "${coquelicot_CI_REF:=master}" +# : "${coquelicot_CI_GITURL:=https://gitlab.inria.fr/coquelicot/coquelicot}" : "${coquelicot_CI_ARCHIVEURL:=${coquelicot_CI_GITURL}/-/archive}" ######################################################################## @@ -209,7 +212,7 @@ ######################################################################## # bedrock2 ######################################################################## -: "${bedrock2_CI_REF:=master}" +: "${bedrock2_CI_REF:=tested}" : "${bedrock2_CI_GITURL:=https://github.com/mit-plv/bedrock2}" : "${bedrock2_CI_ARCHIVEURL:=${bedrock2_CI_GITURL}/archive}" @@ -256,6 +259,13 @@ : "${quickchick_CI_ARCHIVEURL:=${quickchick_CI_GITURL}/archive}" ######################################################################## +# reduction-effects +######################################################################## +: "${reduction_effects_CI_REF:=master}" +: "${reduction_effects_CI_GITURL:=https://github.com/coq-community/reduction-effects}" +: "${reduction_effects_CI_ARCHIVEURL:=${reduction_effects_CI_GITURL}/archive}" + +######################################################################## # menhirlib ######################################################################## : "${menhirlib_CI_REF:=master}" diff --git a/dev/ci/ci-reduction_effects.sh b/dev/ci/ci-reduction_effects.sh new file mode 100755 index 0000000000..6b6de3fa2f --- /dev/null +++ b/dev/ci/ci-reduction_effects.sh @@ -0,0 +1,8 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +. "${ci_dir}/ci-common.sh" + +git_download reduction_effects + +( cd "${CI_BUILD_DIR}/reduction_effects" && make && make test && make install) diff --git a/dev/ci/ci-sf.sh b/dev/ci/ci-sf.sh index 2b1d2298f2..b9d6215e60 100755 --- a/dev/ci/ci-sf.sh +++ b/dev/ci/ci-sf.sh @@ -4,7 +4,10 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" CIRCLE_SF_TOKEN=00127070c10f5f09574b050e4f08e924764680d2 -data=$(wget https://circleci.com/api/v1.1/project/gh/DeepSpec/sfdev/latest/artifacts?circle-token=${CIRCLE_SF_TOKEN} -O -) + +# "latest" is disabled due to lack of build credits upstream, thus artifacts fail +# data=$(wget https://circleci.com/api/v1.1/project/gh/DeepSpec/sfdev/latest/artifacts?circle-token=${CIRCLE_SF_TOKEN} -O -) +data=$(wget https://circleci.com/api/v1.1/project/gh/DeepSpec/sfdev/1411/artifacts?circle-token=${CIRCLE_SF_TOKEN} -O -) mkdir -p "${CI_BUILD_DIR}" && cd "${CI_BUILD_DIR}" diff --git a/dev/ci/nix/default.nix b/dev/ci/nix/default.nix index a9cc91170f..f08a08531f 100644 --- a/dev/ci/nix/default.nix +++ b/dev/ci/nix/default.nix @@ -60,9 +60,23 @@ let iris = (coqPackages.iris.override { inherit coq stdpp; }) let unicoq = callPackage ./unicoq { inherit coq; }; in +let StructTact = coqPackages.StructTact.overrideAttrs (o: { + src = fetchTarball "https://github.com/uwplse/StructTact/tarball/master"; + }); in + +let Cheerios = (coqPackages.Cheerios.override { inherit StructTact; }) + .overrideAttrs (o: { + src = fetchTarball "https://github.com/uwplse/cheerios/tarball/master"; + }); in + +let Verdi = (coqPackages.Verdi.override { inherit Cheerios ssreflect; }) + .overrideAttrs (o: { + src = fetchTarball "https://github.com/uwplse/verdi/tarball/master"; + }); in + let callPackage = newScope { inherit coq bignums coq-ext-lib coqprime corn iris math-classes - mathcomp simple-io ssreflect stdpp unicoq; + mathcomp simple-io ssreflect stdpp unicoq Verdi; }; in # Environments for building CI libraries with this Coq @@ -89,6 +103,7 @@ let projects = { mtac2 = callPackage ./mtac2.nix {}; oddorder = callPackage ./oddorder.nix {}; quickchick = callPackage ./quickchick.nix {}; + verdi-raft = callPackage ./verdi-raft.nix {}; VST = callPackage ./VST.nix {}; }; in diff --git a/dev/ci/nix/fiat_crypto.nix b/dev/ci/nix/fiat_crypto.nix index 0f0ee91387..1105fba7a6 100644 --- a/dev/ci/nix/fiat_crypto.nix +++ b/dev/ci/nix/fiat_crypto.nix @@ -1,6 +1,6 @@ -{ coqprime }: +{ ocamlPackages }: { - coqBuildInputs = [ coqprime ]; + buildInputs = with ocamlPackages; [ ocaml findlib ]; configure = "git submodule update --init --recursive && ulimit -s 32768"; - make = "make new-pipeline c-files"; + make = "make c-files printlite lite && make -j 1 coq"; } diff --git a/dev/ci/nix/verdi-raft.nix b/dev/ci/nix/verdi-raft.nix new file mode 100644 index 0000000000..6a98f4ef47 --- /dev/null +++ b/dev/ci/nix/verdi-raft.nix @@ -0,0 +1,5 @@ +{ Verdi }: +{ + coqBuildInputs = [ Verdi ]; + configure = "./configure"; +} diff --git a/dev/ci/user-overlays/11293-ppedrot-rename-class-files.sh b/dev/ci/user-overlays/11293-ppedrot-rename-class-files.sh new file mode 100644 index 0000000000..a95170a455 --- /dev/null +++ b/dev/ci/user-overlays/11293-ppedrot-rename-class-files.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "11293" ] || [ "$CI_BRANCH" = "rename-class-files" ]; then + + elpi_CI_REF=rename-class-files + elpi_CI_GITURL=https://github.com/ppedrot/coq-elpi + + mtac2_CI_REF=rename-class-files + mtac2_CI_GITURL=https://github.com/ppedrot/Mtac2 + +fi diff --git a/dev/ci/user-overlays/11338-ppedrot-rm-global-uses-evd.sh b/dev/ci/user-overlays/11338-ppedrot-rm-global-uses-evd.sh new file mode 100644 index 0000000000..f41271804a --- /dev/null +++ b/dev/ci/user-overlays/11338-ppedrot-rm-global-uses-evd.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "11338" ] || [ "$CI_BRANCH" = "rm-global-uses-evd" ]; then + + unicoq_CI_REF=rm-global-uses-evd + unicoq_CI_GITURL=https://github.com/ppedrot/unicoq + + equations_CI_REF=rm-global-uses-evd + equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations + +fi diff --git a/dev/ci/user-overlays/11368-trailing-implicit-error.sh b/dev/ci/user-overlays/11368-trailing-implicit-error.sh new file mode 100644 index 0000000000..a125337dd9 --- /dev/null +++ b/dev/ci/user-overlays/11368-trailing-implicit-error.sh @@ -0,0 +1,33 @@ +if [ "$CI_PULL_REQUEST" = "11368" ] || [ "$CI_BRANCH" = "trailing_implicit_error" ]; then + + mathcomp_CI_REF=non_maximal_implicit + mathcomp_CI_GITURL=https://github.com/SimonBoulier/math-comp + + oddorder_CI_REF=non_maximal_implicit + oddorder_CI_GITURL=https://github.com/SimonBoulier/odd-order + + stdlib2_CI_REF=non_maximal_implicit + stdlib2_CI_GITURL=https://github.com/SimonBoulier/stdlib2 + + coq_dpdgraph_CI_REF=non_maximal_implicit + coq_dpdgraph_CI_GITURL=https://github.com/SimonBoulier/coq-dpdgraph + + vst_CI_REF=non_maximal_implicit + vst_CI_GITURL=https://github.com/SimonBoulier/VST + + equations_CI_REF=non_maximal_implicit + equations_CI_GITURL=https://github.com/SimonBoulier/Coq-Equations + + mtac2_CI_REF=non_maximal_implicit + mtac2_CI_GITURL=https://github.com/SimonBoulier/Mtac2 + + relation_algebra_CI_REF=non_maximal_implicit + relation_algebra_CI_GITURL=https://github.com/SimonBoulier/relation-algebra + + fiat_parsers_CI_REF=non_maximal_implicit + fiat_parsers_CI_GITURL=https://github.com/SimonBoulier/fiat + + Corn_CI_REF=non_maximal_implicit + Corn_CI_GITURL=https://github.com/SimonBoulier/corn + +fi diff --git a/dev/doc/MERGING.md b/dev/doc/MERGING.md deleted file mode 100644 index 66f5a96802..0000000000 --- a/dev/doc/MERGING.md +++ /dev/null @@ -1,177 +0,0 @@ -# Merging changes in Coq - -This document describes how patches, submitted as pull requests (PRs) on the -`master` branch, should be merged into the main repository -(https://github.com/coq/coq). - -## Code owners - -The [CODEOWNERS](../../.github/CODEOWNERS) file defines owners for each part of -the code. Sometime there is one principal maintainer and one or several -secondary maintainer(s). Sometimes, it is a team of code owners and all of its -members act as principal maintainers for the component. - -When a PR is submitted, GitHub will automatically ask the principal -maintainer (or the code owner team) for a review. If the PR touches several -parts, all the corresponding owners will be asked for a review. - -Maintainers are never assigned as reviewer on their own PRs. - -If a principal maintainer submits a PR or is a co-author of a PR that is -submitted and this PR changes the component they own, they must request a -review from a secondary maintainer. They can also delegate the review if they -know they are not available to do it. - -## Reviewing - -When maintainers receive a review request, they are expected to: - -* Put their name in the assignee field, if they are in charge of the component - that is the main target of the patch (or if they are the only maintainer asked - to review the PR). -* Review the PR, approve it or request changes. -* If they are the assignee, check if all reviewers approved the PR. If not, - regularly ping the author (if changes should be implemented) or the reviewers - (if reviews are missing). The assignee ensures that any requests for more - discussion have been granted. When the discussion has converged and ALL - REVIEWERS(*) have approved the PR, the assignee is expected to follow the merging - process described below. - -To know what files you are a code owner of in a large PR, you can run -`dev/tools/check-owners-pr.sh xxxx`. Results are unfortunately imperfect. - -When a PR received lots of comments or if the PR has not been opened for long -and the assignee thinks that some other developers might want to comment, -it is recommended that they announce their intention to merge and wait a full -working day (or more if deemed useful) before the actual merge, as a sort of -last call for comments. - -In all cases, maintainers can delegate reviews to the other maintainers, -except if it would lead to a maintainer reviewing their own patch. - -A maintainer is expected to be reasonably reactive, but no specific timeframe is -given for reviewing. - -When none of the maintainers have commented nor self-assigned a PR in a delay -of five working days, any maintainer of another component who feels comfortable -reviewing the PR can assign it to themselves. To prevent misunderstandings, -maintainers should not hesitate to announce in advance when they shall be -unavailable for more than five working days. - -(*) In case a component is touched in a trivial way (adding/removing one file in -a `Makefile`, etc), or by applying a systematic refactoring process (global -renaming for instance) that has been reviewed globally, the assignee can -say in a comment they think a review is not required from every code owner and -proceed with the merge. - -### Breaking changes - -If the PR breaks compatibility of some external projects in CI, then fixes to -those external projects should have been prepared (cf. the relevant sub-section -in the [CI README](../ci/README.md#Breaking-changes) and the PR can be tested -with these fixes thanks to ["overlays"](../ci/user-overlays/README.md). - -Moreover the PR author *must* add an entry to the [unreleased -changelog](../../doc/changelog/README.md) or to the -[`dev/doc/changes.md`](changes.md) file. - -If overlays are missing, ask the author to prepare them and label the PR with -the [needs: overlay](https://github.com/coq/coq/labels/needs%3A%20overlay) label. - -When fixes are ready, there are two cases to consider: - -- For patches that are backward compatible (best scenario), you should get the - external project maintainers to integrate them before merging the PR. -- For patches that are not backward compatible (which is often the case when - patching plugins after an update to the Coq API), you can proceed to merge - the PR and then notify the external project maintainers they can merge the - patch. - -## Merging - -Once all reviewers approved the PR, the assignee is expected to check that CI -completed without relevant failures, and that the PR comes with appropriate -documentation and test cases. If not, they should leave a comment on the PR and -put the appropriate label. Otherwise, they are expected to merge the PR using the -[merge script](../tools/merge-pr.sh). - -When CI has a few failures which look spurious, restarting the corresponding -jobs is a good way of ensuring this was indeed the case. -To restart a job on AppVeyor, you should connect using your GitHub -account; being part of the Coq organization on GitHub should give you the -permission to do so. -To restart a job on GitLab CI, you should sign into GitLab (this can be done -using a GitHub account); if you are part of the -[Coq organization on GitLab](https://gitlab.com/coq), you should see a "Retry" -button; otherwise, send a request to join the organization. - -When the PR has conflicts, the assignee can either: -- ask the author to rebase the branch, fixing the conflicts -- warn the author that they are going to rebase the branch, and push to the - branch directly - -In both cases, CI should be run again. - -In some rare cases (e.g. the conflicts are in the `CHANGES.md` file and the PR -is not a candidate for backporting), it is ok to fix -the conflicts in the merge commit (following the same steps as below), and push -to `master` directly. DON'T USE the GitHub interface to fix these conflicts. - -To merge the PR proceed in the following way -``` -$ git checkout master -$ git pull -$ dev/tools/merge-pr.sh XXXX -$ git push upstream -``` -where `XXXX` is the number of the PR to be merged and `upstream` is the name -of your remote pointing to `git@github.com:coq/coq.git`. -Note that you are only supposed to merge PRs into `master`. PRs should rarely -target the stable branch, but when it is the case they are the responsibility -of the release manager. - -This script conducts various checks before proceeding to merge. Don't bypass them -without a good reason to, and in that case, write a comment in the PR thread to -explain the reason. - -Maintainers MUST NOT merge their own patches. - -DON'T USE the GitHub interface for merging, since it will prevent the automated -backport script from operating properly, generates bad commit messages, and a -messy history when there are conflicts. - -### Merge script dependencies - -The merge script passes option `-S` to `git merge` to ensure merge commits -are signed. Consequently, it depends on the GnuPG command utility being -installed and a GPG key being available. Here is a short documentation on -how to use GPG, git & GitHub: https://help.github.com/articles/signing-commits-with-gpg/. - -The script depends on a few other utilities. If you are a Nix user, the -simplest way of getting them is to run `nix-shell` first. - -**Note for homebrew (MacOS) users:** it has been reported that installing GnuPG -is not out of the box. Installing explicitly "pinentry-mac" seems important for -typing of passphrase to work correctly (see also this -[Stack Overflow Q-and-A](https://stackoverflow.com/questions/39494631/gpg-failed-to-sign-the-data-fatal-failed-to-write-commit-object-git-2-10-0)). - -## Addendum for organization admins - -### Adding a new code owner individual - -If someone is added to the [`CODEOWNERS`](../../.github/CODEOWNERS) file and -they did not have merging rights before, they should also be added to the -**@coq/pushers** team. You may do so using -[this link](https://github.com/orgs/coq/teams/pushers/members?add=true). - -Before adding someone to the **@coq/pushers** team, you should ensure that they -have read the present merging documentation, and explicitly tell them not to -use the merging button on the GitHub web interface. - -### Adding a new code owner team - -Go to [that page](https://github.com/orgs/coq/teams/pushers/teams) and click on -the green "Add a team" button. Use a "-maintainer" suffix for the name of your -team. You may then add new members to this team (you don't need to add them to -the **@coq/pushers** team first as this will be done automatically because the -team you created is a sub-team of **@coq/pushers**). diff --git a/dev/doc/build-system.dune.md b/dev/doc/build-system.dune.md index 37c6e2f619..cd35064b18 100644 --- a/dev/doc/build-system.dune.md +++ b/dev/doc/build-system.dune.md @@ -108,24 +108,44 @@ automatically. You can use `ocamldebug` with Dune; after a build, do: ``` -dune exec -- dev/dune-dbg /path/to/foo.v +dune exec -- dev/dune-dbg coqc foo.v (ocd) source dune_db ``` -or +to start `coqc.byte foo.v`, other targets are `{checker,coqide,coqtop}`: ``` -dune exec -- dev/dune-dbg checker Foo +dune exec -- dev/dune-dbg checker foo.vo (ocd) source dune_db ``` -for the checker. Unfortunately, dependency handling here is not fully -refined, so you need to build enough of Coq once to use this target -[it will then correctly compute the deps and rebuild if you call the -script again] This will be fixed in the future. +Unfortunately, dependency handling here is not fully refined, so you +need to build enough of Coq once to use this target [it will then +correctly compute the deps and rebuild if you call the script again] +This will be fixed in the future. For running in emacs, use `coqdev-ocamldebug` from `coqdev.el`. +**Note**: If you are using OCaml >= 4.08 you need to use + +``` +(ocd) source dune_db_408 +``` + +or + +``` +(ocd) source dune_db_409 +``` + +depending on your OCaml version. This is due to several factors: + +- OCaml >= 4.08 doesn't allow doubly-linking modules, however `source` + is not re entrant and seems to doubly-load in the default setup, see + https://github.com/coq/coq/issues/8952 +- OCaml >= 4.09 comes with `dynlink` already linked in so we need to + modify the list of modules loaded. + ## Dropping from coqtop: After doing `make -f Makefile.dune voboot`, the following commands should work: diff --git a/dev/doc/changes.md b/dev/doc/changes.md index 04b20c6889..3bc92e6aee 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -2,6 +2,13 @@ ### ML API +Exception handling: + +- Coq's custom `Backtrace` module has been removed in favor of OCaml's + native backtrace implementation. Please use the functions in + `Exninfo.capture` and `iraise` when re-raising inside an exception + handler. + Printers: - Functions such as Printer.pr_lconstr_goal_style_env have been diff --git a/dev/doc/critical-bugs b/dev/doc/critical-bugs index 67becb251a..3260040248 100644 --- a/dev/doc/critical-bugs +++ b/dev/doc/critical-bugs @@ -158,7 +158,7 @@ Universes component: universe polymorphism, asynchronous proofs summary: universe constraints erroneously discarded when forcing an asynchronous proof containing delayed monomorphic constraints inside a universe polymorphic section introduced: between 8.4 and 8.5 by merging the asynchronous proofs feature branch and universe polymorphism one - impacted released: V8.5-V8.10 + impacted released versions: V8.5-V8.10 impacted development branches: none impacted coqchk versions: immune fixed in: PR#10664 @@ -167,6 +167,19 @@ Universes GH issue number: none risk: unlikely to be triggered in interactive mode, not present in batch mode (i.e. coqc) + component: algebraic universes + summary: Set+2 was incorrectly simplified to Set+1 + introduced: V8.10 (with the SProp commit 75508769762372043387c67a9abe94e8f940e80a) + impacted released versions: V8.10.0 V8.10.1 V8.10.2 + impacted coqchk versions: same + fixed in: PR#11422 + found by: Gilbert + exploit: see PR (custom application of Hurkens to get around the refreshing at elaboration) + GH issue number: see PR + risk: unlikely to be triggered through the vernacular (the system "refreshes" algebraic + universes such that +2 increments do not appear), mild risk from plugins which manipulate + algebraic universes. + Primitive projections component: primitive projections, guard condition @@ -255,6 +268,18 @@ Conversion machines GH issue number: #9925 risk: + component: "virtual machine" (compilation to bytecode ran by a C-interpreter) + summary: broken long multiplication primitive integer emulation layer on 32 bits + introduced: e43b176 + impacted released versions: 8.10.0, 8.10.1, 8.10.2 + impacted development branches: 8.11 + impacted coqchk versions: none (no virtual machine in coqchk) + fixed in: 4e176a7 + found by: Soegtrop, Melquiond + exploit: test-suite/bugs/closed/bug_11321.v + GH issue number: #11321 + risk: critical, as any BigN computation on 32-bit architectures is wrong + component: "native" conversion machine (translation to OCaml which compiles to native code) summary: translation of identifier from Coq to OCaml was not bijective, leading to identify True and False introduced: V8.5 diff --git a/dev/doc/release-process.md b/dev/doc/release-process.md index 1c486b024d..ba68501e04 100644 --- a/dev/doc/release-process.md +++ b/dev/doc/release-process.md @@ -75,7 +75,8 @@ in time. - [ ] Pin the versions of libraries and plugins in `dev/ci/ci-basic-overlays.sh` to use commit hashes or tag (or, if it exists, a branch dedicated to compatibility with the corresponding - Coq branch). + Coq branch). You can use the `dev/tools/pin-ci.sh` script to do this + semi-automatically. - [ ] Remove all remaining unmerged feature PRs from the beta milestone. - [ ] Start a new project to track PR backporting. The project should have a "Request X.X+beta1 inclusion" column for the PRs that were diff --git a/dev/doc/shield-icon.png b/dev/doc/shield-icon.png Binary files differnew file mode 100644 index 0000000000..629e51a819 --- /dev/null +++ b/dev/doc/shield-icon.png diff --git a/dev/doc/xml-protocol.md b/dev/doc/xml-protocol.md index 0fc0a413ba..fca7b77fc2 100644 --- a/dev/doc/xml-protocol.md +++ b/dev/doc/xml-protocol.md @@ -1,12 +1,11 @@ # Coq XML Protocol This document is based on documentation originally written by CJ Bell -for his [vscoq](https://github.com/siegebell/vscoq/) project. +for his [vscoq](https://github.com/coq-community/vscoq/) project. Here, the aim is to provide a "hands on" description of the XML protocol that coqtop and IDEs use to communicate. The protocol first appeared -with Coq 8.5, and is used by CoqIDE. It will also be used in upcoming -versions of Proof General. +with Coq 8.5, and is used by CoqIDE, [vscoq](https://github.com/coq-community/vscoq/), and other user interfaces. A somewhat out-of-date description of the async state machine is [documented here](https://github.com/ejgallego/jscoq/blob/v8.10/etc/notes/coq-notes.md). @@ -13,6 +13,8 @@ ../checker/coqchk.bc ../topbin/coqc_bin.bc ../ide/coqide_main.bc - ; This is not enough as the call to `ocamlfind` will fail :/ + %{lib:coq.plugins.ltac:ltac_plugin.cma} + ; This is not enough, the call to `ocamlfind` may fail if the + ; META file is not yet in place :/ top_printers.cma) (action (copy dune-dbg.in dune-dbg))) diff --git a/dev/dune-dbg.in b/dev/dune-dbg.in index 1382f4d1b6..498f167eb1 100755 --- a/dev/dune-dbg.in +++ b/dev/dune-dbg.in @@ -7,11 +7,21 @@ case $1 in exe=_build/default/checker/coqchk.bc ;; coqide) + shift exe=_build/default/ide/coqide_main.bc ;; - *) + coqc) + shift exe=_build/default/topbin/coqc_bin.bc ;; + coqtop) + shift + exe=_build/default/topbin/coqtop_byte_bin.bc + ;; + *) + echo "First argument must be one of {coqc,coqtop,checker,coqide}" + exit 1 + ;; esac emacs="${INSIDE_EMACS:+-emacs}" diff --git a/dev/dune_db_408 b/dev/dune_db_408 new file mode 100644 index 0000000000..3bf13da62d --- /dev/null +++ b/dev/dune_db_408 @@ -0,0 +1,25 @@ +load_printer threads.cma +load_printer str.cma +load_printer config.cma +load_printer clib.cma +load_printer dynlink.cma +load_printer lib.cma +load_printer gramlib.cma +load_printer byterun.cma +load_printer kernel.cma +load_printer library.cma +load_printer engine.cma +load_printer pretyping.cma +load_printer interp.cma +load_printer proofs.cma +load_printer parsing.cma +load_printer printing.cma +load_printer tactics.cma +load_printer vernac.cma +load_printer stm.cma +load_printer toplevel.cma + +load_printer ltac_plugin.cma +load_printer top_printers.cma + +source top_printers.dbg diff --git a/dev/dune_db_409 b/dev/dune_db_409 new file mode 100644 index 0000000000..1267fd5393 --- /dev/null +++ b/dev/dune_db_409 @@ -0,0 +1,24 @@ +load_printer threads.cma +load_printer str.cma +load_printer config.cma +load_printer clib.cma +load_printer lib.cma +load_printer gramlib.cma +load_printer byterun.cma +load_printer kernel.cma +load_printer library.cma +load_printer engine.cma +load_printer pretyping.cma +load_printer interp.cma +load_printer proofs.cma +load_printer parsing.cma +load_printer printing.cma +load_printer tactics.cma +load_printer vernac.cma +load_printer stm.cma +load_printer toplevel.cma + +load_printer ltac_plugin.cma +load_printer top_printers.cma + +source top_printers.dbg diff --git a/dev/lint-repository.sh b/dev/lint-repository.sh index 224601bbce..553696410c 100755 --- a/dev/lint-repository.sh +++ b/dev/lint-repository.sh @@ -33,6 +33,6 @@ echo Checking overlays dev/tools/check-overlays.sh || CODE=1 echo Checking ocamlformat -dune build @fmt || CODE=1 +make -f Makefile.dune fmt || CODE=1 exit $CODE diff --git a/dev/nixpkgs.nix b/dev/nixpkgs.nix index 677377f868..54baaee1fe 100644 --- a/dev/nixpkgs.nix +++ b/dev/nixpkgs.nix @@ -1,4 +1,4 @@ import (fetchTarball { - url = "https://github.com/NixOS/nixpkgs/archive/f4ad230f90ef312695adc26f256036203e9c70af.tar.gz"; - sha256 = "0cdd275dz3q51sknn7s087js81zvaj5riz8f29id6j6chnyikzjq"; + url = "https://github.com/NixOS/nixpkgs/archive/8da81465c19fca393a3b17004c743e4d82a98e4f.tar.gz"; + sha256 = "1f3s27nrssfk413pszjhbs70wpap43bbjx2pf4zq5x2c1kd72l6y"; }) diff --git a/dev/tools/merge-pr.sh b/dev/tools/merge-pr.sh index c0a3eeb11c..a888998ebf 100755 --- a/dev/tools/merge-pr.sh +++ b/dev/tools/merge-pr.sh @@ -137,7 +137,8 @@ if [ "$LOCAL_BRANCH_COMMIT" != "$UPSTREAM_COMMIT" ]; then else error "Local branch is not up-to-date with ${REMOTE}." error "Pull before merging." - ask_confirmation + # This check should never be bypassed. + exit 1 fi fi diff --git a/dev/tools/pin-ci.sh b/dev/tools/pin-ci.sh new file mode 100755 index 0000000000..dbf54d7f0a --- /dev/null +++ b/dev/tools/pin-ci.sh @@ -0,0 +1,46 @@ +#!/usr/bin/env bash + +# Use this script to pin the commit used by the developments tracked by the CI + +OVERLAYS="./dev/ci/ci-basic-overlay.sh" + +process_development() { + local DEV=$1 + local REPO_VAR="${DEV}_CI_GITURL" + local REPO=${!REPO_VAR} + local BRANCH_VAR="${DEV}_CI_REF" + local BRANCH=${!BRANCH_VAR} + if [[ -z "$BRANCH" ]] + then + echo "$DEV has no branch set, skipping" + return 0 + fi + if [[ $BRANCH =~ ^[a-f0-9]{40}$ ]] + then + echo "$DEV is already set to hash $BRANCH, skipping" + return 0 + fi + echo "Resolving $DEV as $BRANCH from $REPO" + local HASH=$(git ls-remote --heads $REPO $BRANCH | cut -f 1) + if [[ -z "$HASH" ]] + then + echo "Could not resolve reference $BRANCH for $DEV (something went wrong), skipping" + return 0 + fi + read -p "Expand $DEV from $BRANCH to $HASH? [y/N] " -n 1 -r + echo + if [[ $REPLY =~ ^[Yy]$ ]]; then + # use -i.bak to be compatible with MacOS; see, e.g., https://stackoverflow.com/a/7573438/377022 + sed -i.bak -e "s/$BRANCH_VAR:=$BRANCH/$BRANCH_VAR:=$HASH/" $OVERLAYS + fi +} + +# Execute the script to set the overlay variables +. $OVERLAYS + +# Find all variables declared in the base overlay of the form *_CI_GITURL +for REPO_VAR in $(compgen -A variable | grep _CI_GITURL) +do + DEV=${REPO_VAR%_CI_GITURL} + process_development $DEV +done diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 92db2cc78b..f640a33773 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -47,7 +47,7 @@ let ppmind kn = pp(MutInd.debug_print kn) let ppind (kn,i) = pp(MutInd.debug_print kn ++ str"," ++int i) let ppsp sp = pp(pr_path sp) let ppqualid qid = pp(pr_qualid qid) -let ppclindex cl = pp(Classops.pr_cl_index cl) +let ppclindex cl = pp(Coercionops.pr_cl_index cl) let ppscheme k = pp (Ind_tables.pr_scheme_kind k) let prrecarg = function diff --git a/dev/top_printers.mli b/dev/top_printers.mli index 5a2144f996..133326523b 100644 --- a/dev/top_printers.mli +++ b/dev/top_printers.mli @@ -29,7 +29,7 @@ val ppind : Names.inductive -> unit val ppsp : Libnames.full_path -> unit val ppqualid : Libnames.qualid -> unit -val ppclindex : Classops.cl_index -> unit +val ppclindex : Coercionops.cl_index -> unit val ppscheme : 'a Ind_tables.scheme_kind -> unit diff --git a/doc/changelog/02-specification-language/10657-minim-toset-flex.rst b/doc/changelog/02-specification-language/10657-minim-toset-flex.rst deleted file mode 100644 index 8983e162fb..0000000000 --- a/doc/changelog/02-specification-language/10657-minim-toset-flex.rst +++ /dev/null @@ -1,3 +0,0 @@ -- Changed heuristics for universe minimization to :g:`Set`: only - minimize flexible universes (`#10657 <https://github.com/coq/coq/pull/10657>`_, - by Gaëtan Gilbert with help from Maxime Dénès and Matthieu Sozeau). diff --git a/doc/changelog/02-specification-language/11368-trailing_implicit_error.rst b/doc/changelog/02-specification-language/11368-trailing_implicit_error.rst new file mode 100644 index 0000000000..a7ffde31fc --- /dev/null +++ b/doc/changelog/02-specification-language/11368-trailing_implicit_error.rst @@ -0,0 +1,6 @@ +- **Changed:** + The warning raised when a trailing implicit is declared to be non maximally + inserted (with the command cmd:`Arguments <Arguments (implicits)>`) has been turned into an error. + This was deprecated since Coq 8.10. + (`#11368 <https://github.com/coq/coq/pull/11368>`_, + by SimonBoulier). diff --git a/doc/changelog/03-notations/11276-master+fix10750.rst b/doc/changelog/03-notations/11276-master+fix10750.rst deleted file mode 100644 index a1b8594f5f..0000000000 --- a/doc/changelog/03-notations/11276-master+fix10750.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Fixed:** - :cmd:`Print Visibility` was failing in the presence of only-printing notations - (`#11276 <https://github.com/coq/coq/pull/11276>`_, - by Hugo Herbelin, fixing `#10750 <https://github.com/coq/coq/pull/10750>`_). diff --git a/doc/changelog/03-notations/11311-custom-entries-recursive.rst b/doc/changelog/03-notations/11311-custom-entries-recursive.rst deleted file mode 100644 index ae9888512d..0000000000 --- a/doc/changelog/03-notations/11311-custom-entries-recursive.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Fixed:** - Recursive notations with custom entries were incorrectly parsing `constr` - instead of custom grammars (`#11311 <https://github.com/coq/coq/pull/11311>`_ - by Maxime Dénès, fixes `#9532 <https://github.com/coq/coq/pull/9532>`_, - `#9490 <https://github.com/coq/coq/pull/9490>`_). diff --git a/doc/changelog/04-tactics/10760-more-rapply.rst b/doc/changelog/04-tactics/10760-more-rapply.rst new file mode 100644 index 0000000000..2815f8af8a --- /dev/null +++ b/doc/changelog/04-tactics/10760-more-rapply.rst @@ -0,0 +1,7 @@ +- The tactic :tacn:`rapply` in :g:`Coq.Program.Tactics` now handles + arbitrary numbers of underscores and takes in a :g:`uconstr`. In + rare cases where users were relying on :tacn:`rapply` inserting + exactly 15 underscores and no more, due to the lemma having a + completely unspecified codomain (and thus allowing for any number of + underscores), the tactic will now instead loop. (`#10760 + <https://github.com/coq/coq/pull/10760>`_, by Jason Gross) diff --git a/doc/changelog/04-tactics/10762-notypeclasses-refine.rst b/doc/changelog/04-tactics/10762-notypeclasses-refine.rst deleted file mode 100644 index 2fef75dc7f..0000000000 --- a/doc/changelog/04-tactics/10762-notypeclasses-refine.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Changed:** - The tactics :tacn:`eapply`, :tacn:`refine` and its variants no - longer allows shelved goals to be solved by typeclass resolution. - (`#10762 <https://github.com/coq/coq/pull/10762>`_, by Matthieu Sozeau). diff --git a/doc/changelog/04-tactics/11023-nativecompute-timing.rst b/doc/changelog/04-tactics/11023-nativecompute-timing.rst new file mode 100644 index 0000000000..2afa3990ac --- /dev/null +++ b/doc/changelog/04-tactics/11023-nativecompute-timing.rst @@ -0,0 +1,7 @@ +- 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/11203-fix-time-printing.rst b/doc/changelog/04-tactics/11203-fix-time-printing.rst deleted file mode 100644 index cdfd2b228e..0000000000 --- a/doc/changelog/04-tactics/11203-fix-time-printing.rst +++ /dev/null @@ -1,4 +0,0 @@ -- The optional string argument to :tacn:`time` is now properly quoted - under :cmd:`Print Ltac` (`#11203 - <https://github.com/coq/coq/pull/11203>`_, fixes `#10971 - <https://github.com/coq/coq/issues/10971>`_, by Jason Gross) diff --git a/doc/changelog/04-tactics/11263-micromega-fix.rst b/doc/changelog/04-tactics/11263-micromega-fix.rst deleted file mode 100644 index ebfb6c19b1..0000000000 --- a/doc/changelog/04-tactics/11263-micromega-fix.rst +++ /dev/null @@ -1,6 +0,0 @@ -- **Fixed** - Efficiency regression introduced by PR `#9725 <https://github.com/coq/coq/pull/9725>`_. - (`#11263 <https://github.com/coq/coq/pull/11263>`_, - fixes `#11063 <https://github.com/coq/coq/issues/11063>`_, - and `#11242 <https://github.com/coq/coq/issues/11242>`_, - and `#11270 <https://github.com/coq/coq/issues/11270>`_, by Frédéric Besson). diff --git a/doc/changelog/04-tactics/11288-omega+depr.rst b/doc/changelog/04-tactics/11288-omega+depr.rst new file mode 100644 index 0000000000..2832e6db61 --- /dev/null +++ b/doc/changelog/04-tactics/11288-omega+depr.rst @@ -0,0 +1,6 @@ +- **Removed:** + The undocumented ``omega with`` tactic variant has been removed, + using ``lia`` is the recommended replacement, tho the old semantics + of ``omega with *`` can be recovered with ``zify; omega`` + (`#11288 <https://github.com/coq/coq/pull/11288>`_, + by Emilio Jesus Gallego Arias). diff --git a/doc/changelog/04-tactics/11362-micromega-fix-11191.rst b/doc/changelog/04-tactics/11362-micromega-fix-11191.rst new file mode 100644 index 0000000000..5ecd46bced --- /dev/null +++ b/doc/changelog/04-tactics/11362-micromega-fix-11191.rst @@ -0,0 +1,5 @@ +- **Fixed:** + Regression of ``lia`` due to more powerful ``zify`` + (`#11362 <https://github.com/coq/coq/pull/11362>`_, + fixes `#11191 <https://github.com/coq/coq/issues/11191>`_, + by Frédéric Besson). diff --git a/doc/changelog/04-tactics/11370-zify-elim-let.rst b/doc/changelog/04-tactics/11370-zify-elim-let.rst new file mode 100644 index 0000000000..4eb2732106 --- /dev/null +++ b/doc/changelog/04-tactics/11370-zify-elim-let.rst @@ -0,0 +1,3 @@ +- **Changed** + Improve the efficiency of `PreOmega.elim_let` using an iterator implemented in OCaml. + (`#11370 <https://github.com/coq/coq/pull/11370>`_, by Frédéric Besson). diff --git a/doc/changelog/05-tactic-language/11241-master+bug-cofix-with-8.10.rst b/doc/changelog/05-tactic-language/11241-master+bug-cofix-with-8.10.rst deleted file mode 100644 index 462ba4a7b1..0000000000 --- a/doc/changelog/05-tactic-language/11241-master+bug-cofix-with-8.10.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Fixed:** - Syntax of tactic `cofix ... with ...` was broken from Coq 8.10. - (`#11241 <https://github.com/coq/coq/pull/11241>`_, - by Hugo Herbelin). diff --git a/doc/changelog/07-commands-and-options/10747-canonical-better-message.rst b/doc/changelog/07-commands-and-options/10747-canonical-better-message.rst new file mode 100644 index 0000000000..e73be9c642 --- /dev/null +++ b/doc/changelog/07-commands-and-options/10747-canonical-better-message.rst @@ -0,0 +1,5 @@ +- **Changed:** + The :cmd:`Print Canonical Projections` command now can take constants and + prints only the unification rules that involve or are synthesized from given + constants (`#10747 <https://github.com/coq/coq/pull/10747>`_, + by Kazuhiko Sakaguchi). diff --git a/doc/changelog/07-commands-and-options/11164-let-cs.rst b/doc/changelog/07-commands-and-options/11164-let-cs.rst new file mode 100644 index 0000000000..b9ecd140e7 --- /dev/null +++ b/doc/changelog/07-commands-and-options/11164-let-cs.rst @@ -0,0 +1 @@ +- A section variable introduces with :g:`Let` can be declared as a :g:`Canonical Structure` (`#11164 <https://github.com/coq/coq/pull/11164>`_, by Enrico Tassi). diff --git a/doc/changelog/07-commands-and-options/11409-mltop+deprecate_use.rst b/doc/changelog/07-commands-and-options/11409-mltop+deprecate_use.rst new file mode 100644 index 0000000000..db433ad64c --- /dev/null +++ b/doc/changelog/07-commands-and-options/11409-mltop+deprecate_use.rst @@ -0,0 +1,5 @@ +- **Removed:** + The `-load-ml-source` and `-load-ml-object` command line options + have been removed; their use was very limited, you can achieve the same adding + additional object files in the linking step or using a plugin. + (`#11409 <https://github.com/coq/coq/pull/11409>`_, by Emilio Jesus Gallego Arias). diff --git a/doc/changelog/08-tools/11255-master+fix11254-coqtop-version.rst b/doc/changelog/08-tools/11255-master+fix11254-coqtop-version.rst deleted file mode 100644 index ecc134748d..0000000000 --- a/doc/changelog/08-tools/11255-master+fix11254-coqtop-version.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Fixed:** - ``coqtop --version`` was broken when called in the middle of an installation process - (`#11255 <https://github.com/coq/coq/pull/11255>`_, by Hugo Herbelin, fixing - `#11254 <https://github.com/coq/coq/pull/11254>`_). diff --git a/doc/changelog/09-coqide/11415-remove-ide-revert-all-buffers.rst b/doc/changelog/09-coqide/11415-remove-ide-revert-all-buffers.rst new file mode 100644 index 0000000000..cb92945b8b --- /dev/null +++ b/doc/changelog/09-coqide/11415-remove-ide-revert-all-buffers.rst @@ -0,0 +1,4 @@ +- **Removed:** + Removed the "Revert all buffers" command from CoqIDE which had been broken for a long time + (`#11415 <https://github.com/coq/coq/pull/11415>`_, + by Pierre-Marie Pédrot). diff --git a/doc/changelog/11-infrastructure-and-dependencies/11227-date.rst b/doc/changelog/11-infrastructure-and-dependencies/11227-date.rst deleted file mode 100644 index 5c08e2b0ea..0000000000 --- a/doc/changelog/11-infrastructure-and-dependencies/11227-date.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Added:** - Build date can now be overriden by setting the `SOURCE_DATE_EPOCH` - environment variable - (`#11227 <https://github.com/coq/coq/pull/11227>`_, - by Bernhard M. Wiedemann). diff --git a/doc/changelog/11-infrastructure-and-dependencies/11245-bye+py2.rst b/doc/changelog/11-infrastructure-and-dependencies/11245-bye+py2.rst new file mode 100644 index 0000000000..03c2ccc1d2 --- /dev/null +++ b/doc/changelog/11-infrastructure-and-dependencies/11245-bye+py2.rst @@ -0,0 +1,4 @@ +- **Removed:** + Python 2 is not longer required in any part of the codebase. + (`#11245 <https://github.com/coq/coq/pull/11245>`_, + by Emilio Jesus Gallego Arias). diff --git a/doc/changelog/12-misc/10486-native-string-extraction.rst b/doc/changelog/12-misc/10486-native-string-extraction.rst new file mode 100644 index 0000000000..c6778403d4 --- /dev/null +++ b/doc/changelog/12-misc/10486-native-string-extraction.rst @@ -0,0 +1,7 @@ +- **Added:** + Support for better extraction of strings in OCaml and Haskell: + `ExtOcamlNativeString` provides bindings from the Coq `String` type to + the OCaml `string` type, and string literals can be extracted to literals, + both in OCaml and Haskell. (`#10486 + <https://github.com/coq/coq/pull/10486>`_, by Xavier Leroy, with help from + Maxime Dénès, review by Hugo Herbelin). diff --git a/doc/sphinx/README.rst b/doc/sphinx/README.rst index 549598b187..a34b2d5195 100644 --- a/doc/sphinx/README.rst +++ b/doc/sphinx/README.rst @@ -143,22 +143,24 @@ Here is the list of all objects of the Coq domain (The symbol :black_nib: indica application of a tactic. ``.. prodn::`` A grammar production. - This is useful if you intend to document individual grammar productions. - Otherwise, use Sphinx's `production lists + Use ``.. prodn`` to document grammar productions instead of Sphinx + `production lists <http://www.sphinx-doc.org/en/stable/markup/para.html#directive-productionlist>`_. - Unlike ``.. productionlist``\ s, this directive accepts notation syntax. - - - Usage:: - - .. prodn:: token += production - .. prodn:: token ::= production + prodn displays multiple productions together with alignment similar to ``.. productionlist``, + however unlike ``.. productionlist``\ s, this directive accepts notation syntax. Example:: - .. prodn:: term += let: @pattern := @term in @term .. prodn:: occ_switch ::= { {? {| + | - } } {* @num } } + term += let: @pattern := @term in @term + | second_production + + The first line defines "occ_switch", which must be unique in the document. The second + references and expands the definition of "term", whose main definition is elsewhere + in the document. The third form is for continuing the + definition of a nonterminal when it has multiple productions. It leaves the first + column in the output blank. ``.. table::`` :black_nib: A Coq table, i.e. a setting that is a set of values. Example:: diff --git a/doc/sphinx/_static/coqnotations.sty b/doc/sphinx/_static/coqnotations.sty index 3548b8754c..3dfe4db439 100644 --- a/doc/sphinx/_static/coqnotations.sty +++ b/doc/sphinx/_static/coqnotations.sty @@ -67,11 +67,26 @@ \newcssclass{notation-sup}{\nsup{#1}} \newcssclass{notation-sub}{\nsub{#1}} -\newcssclass{notation}{\nnotation{#1}} +\newcssclass{notation}{\nnotation{\textbf{#1}}} \newcssclass{repeat}{\nrepeat{#1}} \newcssclass{repeat-wrapper}{\nwrapper{#1}} +\newcssclass{repeat-wrapper-with-sub}{\nwrapper{#1}} \newcssclass{hole}{\nhole{#1}} \newcssclass{alternative}{\nalternative{\nbox{#1}}{0pt}} \newcssclass{alternative-block}{#1} \newcssclass{repeated-alternative}{\nalternative{#1}{\nboxsep}} \newcssclass{alternative-separator}{\quad\naltsep{}\quad} +\newcssclass{prodn-table}{% + \begin{savenotes} + \sphinxattablestart + \begin{tabulary}{\linewidth}[t]{lLL} + #1 + \end{tabulary} + \par + \sphinxattableend + \end{savenotes}} +% latex puts targets 1 line below where they should be; prodn-target corrects for this +\newcssclass{prodn-target}{\raisebox{\dimexpr \nscriptsize \relax}{#1}} +\newcssclass{prodn-cell-nonterminal}{#1 &} +\newcssclass{prodn-cell-op}{#1 &} +\newcssclass{prodn-cell-production}{#1\\} diff --git a/doc/sphinx/_static/notations.css b/doc/sphinx/_static/notations.css index 4a5fa0b328..3806ba6ee6 100644 --- a/doc/sphinx/_static/notations.css +++ b/doc/sphinx/_static/notations.css @@ -10,6 +10,7 @@ .notation { /* font-family: "Ubuntu Mono", "Consolas", monospace; */ white-space: pre-wrap; + font-weight: bold; } .notation .notation-sup { @@ -85,7 +86,8 @@ padding-right: 0.6em; /* Space for the left half of the sub- and sup-scripts */ } -.notation .repeat-wrapper { +.notation .repeat-wrapper, +.notation .repeat-wrapper-with-sub { display: inline-block; position: relative; margin-right: 0.4em; /* Space for the right half of the sub- and sup-scripts */ @@ -165,10 +167,52 @@ /* Overrides */ /*************/ -.rst-content table.docutils td, .rst-content table.docutils th { - padding: 8px; /* Reduce horizontal padding */ - border-left: none; - border-right: none; +.prodn-table { + display: table; + margin: 1.5em 0px; + vertical-align: baseline; + font-weight: bold; +} + +.prodn-column-group { + display: table-column-group; +} + +.prodn-column { + display: table-column; +} + +.prodn-row-group { + display: table-row-group; +} + +.prodn-row { + display: table-row; +} + +.prodn-cell-nonterminal, +.prodn-cell-op, +.prodn-cell-production +{ + display: table-cell; +} + +.prodn-cell-nonterminal { + padding-right: 0.49em; +} + +.prodn-cell-op { + padding-right: 0.90em; + font-weight: normal; +} + +.prodn-table .notation > .repeat-wrapper { + margin-top: 0.28em; +} + +.prodn-table .notation > .repeat-wrapper-with-sub { + margin-top: 0.28em; + margin-bottom: 0.28em; } /* We can't display nested blocks otherwise */ diff --git a/doc/sphinx/addendum/extended-pattern-matching.rst b/doc/sphinx/addendum/extended-pattern-matching.rst index 45b3f6f161..15f42591ce 100644 --- a/doc/sphinx/addendum/extended-pattern-matching.rst +++ b/doc/sphinx/addendum/extended-pattern-matching.rst @@ -192,7 +192,7 @@ Disjunctive patterns -------------------- Multiple patterns that share the same right-hand-side can be -factorized using the notation :n:`{+| @patterns_comma}`. For +factorized using the notation :n:`{+| {+, @pattern } }`. For instance, :g:`max` can be rewritten as follows: .. coqtop:: in reset diff --git a/doc/sphinx/addendum/extraction.rst b/doc/sphinx/addendum/extraction.rst index 7136cc28d1..d909f98956 100644 --- a/doc/sphinx/addendum/extraction.rst +++ b/doc/sphinx/addendum/extraction.rst @@ -313,14 +313,21 @@ The system also provides a mechanism to specify ML terms for inductive types and constructors. For instance, the user may want to use the ML native boolean type instead of the |Coq| one. The syntax is the following: -.. cmd:: Extract Inductive @qualid => @string [ {+ @string } ] +.. cmd:: Extract Inductive @qualid => @string__1 [ {+ @string } ] Give an ML extraction for the given inductive type. You must specify - extractions for the type itself (first :token:`string`) and all its - constructors (all the :token:`string` between square brackets). In this form, + extractions for the type itself (:n:`@string__1`) and all its + constructors (all the :n:`@string` between square brackets). In this form, the ML extraction must be an ML inductive datatype, and the native pattern matching of the language will be used. + When :n:`@string__1` matches the name of the type of characters or strings + (``char`` and ``string`` for OCaml, ``Prelude.Char`` and ``Prelude.String`` + for Haskell), extraction of literals is handled in a specialized way, so as + to generate literals in the target language. This feature requires the type + designated by :n:`@qualid` to be registered as the standard char or string type, + using the :cmd:`Register` command. + .. cmdv:: Extract Inductive @qualid => @string [ {+ @string } ] @string Same as before, with a final extra :token:`string` that indicates how to diff --git a/doc/sphinx/addendum/omega.rst b/doc/sphinx/addendum/omega.rst index 650a444a16..daca43e65e 100644 --- a/doc/sphinx/addendum/omega.rst +++ b/doc/sphinx/addendum/omega.rst @@ -5,6 +5,27 @@ Omega: a solver for quantifier-free problems in Presburger Arithmetic :Author: Pierre Crégut +.. 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`. + + Note that replacing :tacn:`omega` with :tacn:`lia` can break + non-robust proof scripts which rely on incompleteness bugs of + :tacn:`omega` (e.g. using the pattern :g:`; try omega`). + Description of ``omega`` ------------------------ diff --git a/doc/sphinx/addendum/parallel-proof-processing.rst b/doc/sphinx/addendum/parallel-proof-processing.rst index 35729d852d..7a50748c51 100644 --- a/doc/sphinx/addendum/parallel-proof-processing.rst +++ b/doc/sphinx/addendum/parallel-proof-processing.rst @@ -154,6 +154,18 @@ to a worker process. The threshold can be configured with Batch mode --------------- + .. warning:: + + The ``-vio`` flag is subsumed, for most practical usage, by the + the more recent ``-vos`` flag. See :ref:`compiled-interfaces`. + + .. warning:: + + When working with ``.vio`` files, do not use the ``-vos`` option at + the same time, otherwise stale files might get loaded when executing + a ``Require``. Indeed, the loading of a nonempty ``.vos`` file is + assigned higher priority than the loading of a ``.vio`` file. + When |Coq| is used as a batch compiler by running ``coqc``, it produces a ``.vo`` file for each ``.v`` file. A ``.vo`` file contains, among other things, theorem statements and proofs. Hence to produce a .vo |Coq| @@ -161,10 +173,10 @@ need to process all the proofs of the ``.v`` file. The asynchronous processing of proofs can decouple the generation of a compiled file (like the ``.vo`` one) that can be loaded by ``Require`` from the -generation and checking of the proof objects. The ``-quick`` flag can be +generation and checking of the proof objects. The ``-vio`` flag can be passed to ``coqc`` to produce, quickly, ``.vio`` files. Alternatively, when using a Makefile produced by ``coq_makefile``, -the ``quick`` target can be used to compile all files using the ``-quick`` flag. +the ``vio`` target can be used to compile all files using the ``-vio`` flag. A ``.vio`` file can be loaded using ``Require`` exactly as a ``.vo`` file but proofs will not be available (the Print command produces an error). @@ -173,7 +185,7 @@ inconsistencies might go unnoticed. A ``.vio`` file does not contain proof objects, but proof tasks, i.e. what a worker process can transform into a proof object. -Compiling a set of files with the ``-quick`` flag allows one to work, +Compiling a set of files with the ``-vio`` flag allows one to work, interactively, on any file without waiting for all the proofs to be checked. diff --git a/doc/sphinx/addendum/universe-polymorphism.rst b/doc/sphinx/addendum/universe-polymorphism.rst index 7adb25cbd6..f9cc25959c 100644 --- a/doc/sphinx/addendum/universe-polymorphism.rst +++ b/doc/sphinx/addendum/universe-polymorphism.rst @@ -529,8 +529,8 @@ sections, except in the following ways: Polymorphic Universe i. Fail Constraint i = i. - This includes constraints implictly declared by commands such as - :cmd:`Variable`, which may as a such need to be used with universe + This includes constraints implicitly declared by commands such as + :cmd:`Variable`, which may need to be used with universe polymorphism activated (locally by attribute or globally by option): .. coqtop:: all diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 1d0c937792..6d9979a704 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -50,23 +50,28 @@ __ 811RefineInstance_ __ 811SSRUnderOver_ __ 811Reals_ -The ``dev/doc/critical-bugs`` file documents the known critical bugs of |Coq| -and affected releases. See the `Changes in 8.11+beta1`_ section for the -detailed list of changes, including potentially breaking changes marked with -**Changed**. +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>`). + +The ``dev/doc/critical-bugs`` file documents the known critical bugs +of |Coq| and affected releases. See the `Changes in 8.11+beta1`_ +section and following sections for the detailed list of changes, +including potentially breaking changes marked with **Changed**. + +Coq's documentation is available at https://coq.github.io/doc/v8.11/api (documentation of +the ML API), https://coq.github.io/doc/v8.11/refman (reference +manual), and https://coq.github.io/doc/v8.11/stdlib (documentation of +the standard library). Maxime Dénès, Emilio Jesús Gallego Arias, Gaëtan Gilbert, Michael -Soegtrop, Théo Zimmermann worked on maintaining and improving the +Soegtrop and Théo Zimmermann worked on maintaining and improving the continuous integration system and package building infrastructure. -Coq's documentation is available at https://coq.github.io/doc/V8.11+beta1/api (documentation of -the ML API), https://coq.github.io/doc/V8.11+beta1/refman (reference -manual), and https://coq.github.io/doc/V8.11+beta1/stdlib (documentation of -the standard library). - The OPAM repository for |Coq| packages has been maintained by -Karl Palmskog, Matthieu Sozeau, Enrico Tassi with contributions -from many users. A list of packages is available at +Guillaume Claret, Karl Palmskog, Matthieu Sozeau and Enrico Tassi with +contributions from many users. A list of packages is available at https://coq.inria.fr/opam/www/. The 61 contributors to this version are Michael D. Adams, Guillaume @@ -350,11 +355,8 @@ Changes in 8.11+beta1 `iff`. Now, it is also performed for any relation `R1` which has a ``RewriteRelation`` instance (a `RelationClasses.Reflexive` instance being also needed so :tacn:`over` can discharge the ``'Under[ _ ]`` - goal by instantiating the hidden evar.) Also, it is now possible to - manipulate `Under_rel _ R1 (f1 i) (?f2 i)` subgoals directly if `R1` - is a `PreOrder` relation or so, thanks to extra instances proving - that `Under_rel` preserves the properties of the `R1` relation. - These two features generalizing support for setoid-like relations is + goal by instantiating the hidden evar.) + This feature generalizing support for setoid-like relations is enabled as soon as we do both ``Require Import ssreflect.`` and ``Require Setoid.`` Finally, a rewrite rule ``UnderE`` has been added if one wants to "unprotect" the evar, and instantiate it @@ -512,6 +514,133 @@ Changes in 8.11+beta1 (`#10471 <https://github.com/coq/coq/pull/10471>`_, by Emilio Jesús Gallego Arias). +Changes in 8.11.0 +~~~~~~~~~~~~~~~~~ + +**Kernel** + +- **Changed:** the native compilation (:tacn:`native_compute`) now + creates a directory to contain temporary files instead of putting + them in the root of the system temporary directory (`#11081 + <https://github.com/coq/coq/pull/11081>`_, by Gaëtan Gilbert). +- **Fixed:** `#11360 <https://github.com/issues/11360>`_. + Broken section closing when a template polymorphic inductive type depends on + a section variable through its parameters (`#11361 + <https://github.com/coq/coq/pull/11361>`_, by Gaëtan Gilbert). +- **Fixed:** The type of :g:`Set+1` would be computed to be itself, + leading to a proof of False (`#11422 + <https://github.com/coq/coq/pull/11422>`_, by Gaëtan Gilbert). + +**Specification language, type inference** + +- **Changed:** Heuristics for universe minimization to :g:`Set`: only + minimize flexible universes (`#10657 <https://github.com/coq/coq/pull/10657>`_, + by Gaëtan Gilbert with help from Maxime Dénès and Matthieu Sozeau). +- **Fixed:** + A dependency was missing when looking for default clauses in the + algorithm for printing pattern matching clauses (`#11233 + <https://github.com/coq/coq/pull/11233>`_, by Hugo Herbelin, fixing + `#11231 <https://github.com/coq/coq/pull/11231>`_, reported by Barry + Jay). + +**Notations** + +- **Fixed:** + :cmd:`Print Visibility` was failing in the presence of only-printing notations + (`#11276 <https://github.com/coq/coq/pull/11276>`_, + by Hugo Herbelin, fixing `#10750 <https://github.com/coq/coq/pull/10750>`_). +- **Fixed:** + Recursive notations with custom entries were incorrectly parsing `constr` + instead of custom grammars (`#11311 <https://github.com/coq/coq/pull/11311>`_ + by Maxime Dénès, fixes `#9532 <https://github.com/coq/coq/pull/9532>`_, + `#9490 <https://github.com/coq/coq/pull/9490>`_). + +**Tactics** + +- **Changed:** + The tactics :tacn:`eapply`, :tacn:`refine` and variants no + longer allow shelved goals to be solved by typeclass resolution + (`#10762 <https://github.com/coq/coq/pull/10762>`_, by Matthieu Sozeau). +- **Fixed:** The optional string argument to :tacn:`time` is now + properly quoted under :cmd:`Print Ltac` (`#11203 + <https://github.com/coq/coq/pull/11203>`_, fixes `#10971 + <https://github.com/coq/coq/issues/10971>`_, by Jason Gross) +- **Fixed:** + Efficiency regression of :tacn:`lia` introduced in 8.10 + by PR `#9725 <https://github.com/coq/coq/pull/9725>`_ + (`#11263 <https://github.com/coq/coq/pull/11263>`_, + fixes `#11063 <https://github.com/coq/coq/issues/11063>`_, + and `#11242 <https://github.com/coq/coq/issues/11242>`_, + and `#11270 <https://github.com/coq/coq/issues/11270>`_, by Frédéric Besson). +- **Deprecated:** + The undocumented ``omega with`` tactic variant has been deprecated. + Using :tacn:`lia` is the recommended replacement, though the old semantics + of ``omega with *`` can be recovered with ``zify; omega`` + (`#11337 <https://github.com/coq/coq/pull/11337>`_, + by Emilio Jesus Gallego Arias). +- **Fixed** + For compatibility reasons, in 8.11, :tacn:`zify` does not support :g:`Z.pow_pos` by default. + It can be enabled by explicitly loading the module :g:`ZifyPow` + (`#11430 <https://github.com/coq/coq/pull/11430>`_ by Frédéric Besson + fixes `#11191 <https://github.com/coq/coq/issues/11191>`_). + +**Tactic language** + +- **Fixed:** + Syntax of tactic `cofix ... with ...` was broken since Coq 8.10 + (`#11241 <https://github.com/coq/coq/pull/11241>`_, + by Hugo Herbelin). + +**Commands and options** + +- **Deprecated:** The `-load-ml-source` and `-load-ml-object` command + line options have been deprecated; their use was very limited, you + can achieve the same by adding object files in the linking step or + by using a plugin (`#11428 + <https://github.com/coq/coq/pull/11428>`_, by Emilio Jesus Gallego + Arias). + +**Tools** + +- **Fixed:** + ``coqtop --version`` was broken when called in the middle of an installation process + (`#11255 <https://github.com/coq/coq/pull/11255>`_, by Hugo Herbelin, fixing + `#11254 <https://github.com/coq/coq/pull/11254>`_). +- **Deprecated:** The ``-quick`` command is renamed to ``-vio``, for + consistency with the new ``-vos`` and ``-vok`` flags. Usage of + ``-quick`` is now deprecated (`#11280 + <https://github.com/coq/coq/pull/11280>`_, by Arthur Charguéraud). +- **Fixed:** + ``coq_makefile`` does not break when using the ``CAMLPKGS`` variable + together with an unpacked (``mllib``) plugin (`#11357 + <https://github.com/coq/coq/pull/11357>`_, by Gaëtan Gilbert). +- **Fixed:** + ``coqdoc`` with option ``-g`` (Gallina only) now correctly prints + commands with attributes (`#11394 <https://github.com/coq/coq/pull/11394>`_, + fixes `#11353 <https://github.com/coq/coq/issues/11353>`_, + by Karl Palmskog). + +**CoqIDE** + +- **Changed:** CoqIDE now uses the GtkSourceView native implementation + of the autocomplete mechanism (`#11400 + <https://github.com/coq/coq/pull/11400>`_, by Pierre-Marie Pédrot). + +**Standard library** + +- **Removed:** Export of module :g:`RList` in :g:`Ranalysis` and + :g:`Ranalysis_reg`. Module :g:`RList` is still there but must be + imported explicitly where required (`#11396 + <https://github.com/coq/coq/pull/11396>`_, by Michael Soegtrop). + +**Infrastructure and dependencies** + +- **Added:** + Build date can now be overridden by setting the `SOURCE_DATE_EPOCH` + environment variable + (`#11227 <https://github.com/coq/coq/pull/11227>`_, + by Bernhard M. Wiedemann). + Version 8.10 ------------ diff --git a/doc/sphinx/introduction.rst b/doc/sphinx/introduction.rst index bcdf3277ad..1424b4f3e1 100644 --- a/doc/sphinx/introduction.rst +++ b/doc/sphinx/introduction.rst @@ -60,7 +60,7 @@ Nonetheless, the manual has some structure that is explained below. of the formalism. Chapter :ref:`themodulesystem` describes the module system. -- The second part describes the proof engine. It is divided in six +- The second part describes the proof engine. It is divided into several chapters. Chapter :ref:`vernacularcommands` presents all commands (we call them *vernacular commands*) that are not directly related to interactive proving: requests to the environment, complete or partial @@ -68,8 +68,10 @@ Nonetheless, the manual has some structure that is explained below. proofs, do multiple proofs in parallel is explained in Chapter :ref:`proofhandling`. In Chapter :ref:`tactics`, all commands that realize one or more steps of the proof are presented: we call them - *tactics*. The language to combine these tactics into complex proof - strategies is given in Chapter :ref:`ltac`. Examples of tactics + *tactics*. The legacy language to combine these tactics into complex proof + strategies is given in Chapter :ref:`ltac`. The currently experimental + language that will eventually replace Ltac is presented in + Chapter :ref:`ltac2`. Examples of tactics are described in Chapter :ref:`detailedexamplesoftactics`. Finally, the |SSR| proof language is presented in Chapter :ref:`thessreflectprooflanguage`. diff --git a/doc/sphinx/language/coq-library.rst b/doc/sphinx/language/coq-library.rst index cad5e4e67e..80f209fcf1 100644 --- a/doc/sphinx/language/coq-library.rst +++ b/doc/sphinx/language/coq-library.rst @@ -95,25 +95,23 @@ Logic The basic library of |Coq| comes with the definitions of standard (intuitionistic) logical connectives (they are defined as inductive constructions). They are equipped with an appealing syntax enriching the -subclass :token:`form` of the syntactic class :token:`term`. The syntax of -:token:`form` is shown below: - -.. /!\ Please keep the blanks in the lines below, experimentally they produce - a nice last column. Or even better, find a proper way to do this! - -.. productionlist:: - form : True (True) - : False (False) - : ~ `form` (not) - : `form` /\ `form` (and) - : `form` \/ `form` (or) - : `form` -> `form` (primitive implication) - : `form` <-> `form` (iff) - : forall `ident` : `type`, `form` (primitive for all) - : exists `ident` [: `specif`], `form` (ex) - : exists2 `ident` [: `specif`], `form` & `form` (ex2) - : `term` = `term` (eq) - : `term` = `term` :> `specif` (eq) +subclass :token:`form` of the syntactic class :token:`term`. The constructs +for :production:`form` are: + +============================================== ======= +True True +False False +:n:`~ @form` not +:n:`@form /\ @form` and +:n:`@form \/ @form` or +:n:`@form -> @form` primitive implication +:n:`@form <-> @form` iff +:n:`forall @ident : @type, @form` primitive for all +:n:`exists @ident {? @specif}, @form` ex +:n:`exists2 @ident {? @specif}, @form & @form` ex2 +:n:`@term = @term` eq +:n:`@term = @term :> @specif` eq +============================================== ======= .. note:: @@ -281,19 +279,20 @@ In the basic library, we find in ``Datatypes.v`` the definition of the basic data-types of programming, defined as inductive constructions over the sort ``Set``. Some of them come with a special syntax shown below (this syntax table is common with -the next section :ref:`specification`): - -.. productionlist:: - specif : `specif` * `specif` (prod) - : `specif` + `specif` (sum) - : `specif` + { `specif` } (sumor) - : { `specif` } + { `specif` } (sumbool) - : { `ident` : `specif` | `form` } (sig) - : { `ident` : `specif` | `form` & `form` } (sig2) - : { `ident` : `specif` & `specif` } (sigT) - : { `ident` : `specif` & `specif` & `specif` } (sigT2) - term : (`term`, `term`) (pair) - +the next section :ref:`specification`). The constructs for :production:`specif` are: + +============================================= ======= +:n:`@specif * @specif` prod +:n:`@specif + @specif` sum +:n:`@specif + { @specif }` sumor +:n:`{ @specif } + { @specif }` sumbool +:n:`{ @ident : @specif | @form }` sig +:n:`{ @ident : @specif | @form & @form }` sig2 +:n:`{ @ident : @specif & @specif }` sigT +:n:`{ @ident : @specif & @specif & @specif }` sigT2 +============================================= ======= + +The notation for pairs (elements of type prod) is: :n:`(@term, @term)` Programming +++++++++++ diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index 8caa289a47..510e271951 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -155,19 +155,19 @@ available: .. _record_projections_grammar: - .. insertgram term_projection term_projection + .. insertprodn term_projection term_projection - .. productionlist:: coq - term_projection : `term0` .( `qualid` `args_opt` ) - : `term0` .( @ `qualid` `term1_list_opt` ) + .. 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:`@term.(@qualid)` is equivalent to :n:`@qualid @term`, -the syntax :n:`@term.(@qualid {+ @arg })` to :n:`@qualid {+ @arg } @term`. -and the syntax :n:`@term.(@@qualid {+ @term })` to :n:`@@qualid {+ @term } @term`. -In each case, :token:`term` is the object projected and the +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. @@ -1629,8 +1629,8 @@ 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 but will become implicit for the constructors of the -inductive only, not the inductive type itself. For example: +definition and will become implicit for the inductive type and the constructors. +For example: .. coqtop:: all @@ -1728,11 +1728,11 @@ Declaring Implicit Arguments To know which are the implicit arguments of an object, use the command :cmd:`Print Implicit` (see :ref:`displaying-implicit-args`). -.. warn:: Argument number @num is a trailing implicit so must be maximal. +.. exn:: Argument @ident is a trailing implicit, so it can't be declared non maximal. Please use %{ %} instead of [ ]. For instance in - .. coqtop:: all warn + .. coqtop:: all fail Arguments prod _ [_]. @@ -1878,27 +1878,16 @@ Controlling the insertion of implicit arguments not followed by explicit argumen Explicit applications ~~~~~~~~~~~~~~~~~~~~~ -In presence of non-strict or contextual argument, or in presence of +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 give explicitly certain implicit arguments of an -application. The syntax for this is :n:`(@ident := @term)` where :token:`ident` is the -name of the implicit argument and term is its corresponding explicit -term. Alternatively, one can locally deactivate the hiding of implicit -arguments of a function by using the notation :n:`@qualid {+ @term }`. -This syntax extension is given in the following grammar: +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`. -.. _explicit_app_grammar: - - .. productionlist:: explicit_apps - term : @ `qualid` `term` … `term` - : @ `qualid` - : `qualid` `argument` … `argument` - argument : `term` - : (`ident` := `term`) - - Syntax for explicitly giving implicit arguments - -.. example:: (continued) +.. example:: Syntax for explicitly giving implicit arguments (continued) .. coqtop:: all @@ -1994,6 +1983,8 @@ Deactivation of implicit arguments for parsing to be given as if no arguments were implicit. By symmetry, this also affects printing. +.. _canonical-structure-declaration: + Canonical structures ~~~~~~~~~~~~~~~~~~~~ @@ -2004,6 +1995,7 @@ value. The complete documentation of canonical structures can be found in :ref:`canonicalstructures`; here only a simple example is given. .. cmd:: {? Local | #[local] } Canonical {? Structure } @qualid + :name: Canonical Structure This command declares :token:`qualid` as a canonical instance of a structure (a record). When the :g:`#[local]` attribute is given the effect @@ -2075,11 +2067,13 @@ in :ref:`canonicalstructures`; here only a simple example is given. This is equivalent to a regular definition of :token:`ident` followed by the declaration :n:`Canonical @ident`. -.. cmd:: Print Canonical Projections +.. cmd:: Print Canonical Projections {* @ident} 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. + 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:: @@ -2089,10 +2083,15 @@ in :ref:`canonicalstructures`; here only a simple example is given. Print Canonical Projections. + .. coqtop:: all + + Print Canonical Projections nat. + .. note:: - The last line would not show up if the corresponding projection (namely - :g:`Prf_equiv`) were annotated as not canonical, as described above. + 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 ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2312,17 +2311,13 @@ Printing universes Existential variables --------------------- -.. insertgram term_evar evar_binding +.. insertprodn term_evar evar_binding -.. productionlist:: coq - term_evar : ?[ `ident` ] - : ?[ ?`ident` ] - : ?`ident` `evar_bindings_opt` - evar_bindings_opt : @{ `evar_bindings_semi` } - : `empty` - evar_bindings_semi : `evar_bindings_semi` ; `evar_binding` - : `evar_binding` - evar_binding : `ident` := `term` +.. prodn:: + term_evar ::= ?[ @ident ] + | ?[ ?@ident ] + | ?@ident {? @%{ {+; @evar_binding } %} } + evar_binding ::= @ident := @term |Coq| terms can include existential variables which represents unknown subterms to eventually be replaced by actual subterms. @@ -2555,3 +2550,8 @@ the context to help inferring the types of the remaining arguments. 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 3cc101d06b..d591718b17 100644 --- a/doc/sphinx/language/gallina-specification-language.rst +++ b/doc/sphinx/language/gallina-specification-language.rst @@ -16,27 +16,27 @@ In Coq, logical objects are typed to ensure their logical correctness. The rules implemented by the typing algorithm are described in Chapter :ref:`calculusofinductiveconstructions`. -About the grammars in the manual -================================ +.. About the grammars in the manual + ================================ -Grammars are presented in Backus-Naur form (BNF). Terminal symbols are -set in black ``typewriter font``. In addition, there are special notations for -regular expressions. + Grammars are presented in Backus-Naur form (BNF). Terminal symbols are + set in black ``typewriter font``. In addition, there are special notations for + regular expressions. -An expression enclosed in square brackets ``[…]`` means at most one -occurrence of this expression (this corresponds to an optional -component). + An expression enclosed in square brackets ``[…]`` means at most one + occurrence of this expression (this corresponds to an optional + component). -The notation “``entry sep … sep entry``” stands for a non empty sequence -of expressions parsed by entry and separated by the literal “``sep``” [1]_. + The notation “``entry sep … sep entry``” stands for a non empty sequence + of expressions parsed by entry and separated by the literal “``sep``” [1]_. -Similarly, the notation “``entry … entry``” stands for a non empty -sequence of expressions parsed by the “``entry``” entry, without any -separator between. + Similarly, the notation “``entry … entry``” stands for a non empty + sequence of expressions parsed by the “``entry``” entry, without any + separator between. -At the end, the notation “``[entry sep … sep entry]``” stands for a -possibly empty sequence of expressions parsed by the “``entry``” entry, -separated by the literal “``sep``”. + At the end, the notation “``[entry sep … sep entry]``” stands for a + possibly empty sequence of expressions parsed by the “``entry``” entry, + separated by the literal “``sep``”. .. _lexical-conventions: @@ -58,10 +58,12 @@ Identifiers recognized by the following grammar (except that the string ``_`` is reserved; it is not a valid identifier): - .. productionlist:: coq - ident : `first_letter`[`subsequent_letter`…`subsequent_letter`] - first_letter : a..z ∣ A..Z ∣ _ ∣ `unicode_letter` - subsequent_letter : `first_letter` ∣ 0..9 ∣ ' ∣ `unicode_id_part` + .. insertprodn ident subsequent_letter + + .. prodn:: + ident ::= @first_letter {* @subsequent_letter } + first_letter ::= {| a .. z | A .. Z | _ | @unicode_letter } + subsequent_letter ::= {| @first_letter | @digit | ' | @unicode_id_part } All characters are meaningful. In particular, identifiers are case-sensitive. :production:`unicode_letter` non-exhaustively includes Latin, @@ -77,13 +79,13 @@ Numerals integer. Underscores embedded in the digits are ignored, for example ``1_000_000`` is the same as ``1000000``. - .. productionlist:: coq - numeral : `num`[. `num`][`exp`[`sign`]`num`] - int : [-]`num` - num : `digit`…`digit` - digit : 0..9 - exp : e | E - sign : + | - + .. insertprodn numeral digit + + .. prodn:: + numeral ::= {+ @digit } {? . {+ @digit } } {? {| e | E } {? {| + | - } } {+ @digit } } + int ::= {? - } {+ @digit } + num ::= {+ @digit } + digit ::= 0 .. 9 Strings Strings begin and end with ``"`` (double quote). Use ``""`` to represent @@ -139,50 +141,39 @@ presentation of Cic is given in Chapter :ref:`calculusofinductiveconstructions`. are given in Chapter :ref:`extensionsofgallina`. How to customize the syntax is described in Chapter :ref:`syntaxextensionsandinterpretationscopes`. -.. insertgram term binders_opt - -.. productionlist:: coq - term : forall `open_binders` , `term` - : fun `open_binders` => `term` - : `term_let` - : if `term` `as_return_type_opt` then `term` else `term` - : `term_fix` - : `term100` - term100 : `term_cast` - : `term10` - term10 : `term1` `args` - : @ `qualid` `universe_annot_opt` `term1_list_opt` - : `term1` - args : `args` `arg` - : `arg` - arg : ( `ident` := `term` ) - : `term1` - term1_list_opt : `term1_list_opt` `term1` - : `empty` - empty : - term1 : `term_projection` - : `term0` % `ident` - : `term0` - args_opt : `args` - : `empty` - term0 : `qualid` `universe_annot_opt` - : `sort` - : `numeral` - : `string` - : _ - : `term_evar` - : `term_match` - : ( `term` ) - : {| `fields_def` |} - : `{ `term` } - : `( `term` ) - : ltac : ( `ltac_expr` ) - fields_def : `field_def` ; `fields_def` - : `field_def` - : `empty` - field_def : `qualid` `binders_opt` := `term` - binders_opt : `binders` - : `empty` +.. insertprodn term field_def + +.. prodn:: + term ::= forall @open_binders , @term + | fun @open_binders => @term + | @term_let + | if @term {? {? as @name } return @term100 } then @term else @term + | @term_fix + | @term_cofix + | @term100 + term100 ::= @term_cast + | @term10 + term10 ::= @term1 {+ @arg } + | @ @qualid {? @univ_annot } {* @term1 } + | @term1 + arg ::= ( @ident := @term ) + | @term1 + term1 ::= @term_projection + | @term0 % @ident + | @term0 + term0 ::= @qualid {? @univ_annot } + | @sort + | @numeral + | @string + | _ + | @term_evar + | @term_match + | ( @term ) + | %{%| {* @field_def } %|%} + | `%{ @term %} + | `( @term ) + | ltac : ( @ltac_expr ) + field_def ::= @qualid {* @binder } := @term Types ----- @@ -196,12 +187,11 @@ of types inside the syntactic class :token:`term`. Qualified identifiers and simple identifiers -------------------------------------------- -.. insertgram qualid field +.. insertprodn qualid field_ident -.. productionlist:: coq - qualid : `qualid` `field` - : `ident` - field : .`ident` +.. prodn:: + qualid ::= @ident {* @field_ident } + field_ident ::= .@ident *Qualified identifiers* (:token:`qualid`) denote *global constants* (definitions, lemmas, theorems, remarks or facts), *global variables* @@ -210,7 +200,7 @@ types*. *Simple identifiers* (or shortly :token:`ident`) are a syntactic subset of qualified identifiers. Identifiers may also denote *local variables*, while qualified identifiers do not. -Field identifiers, written :token:`field`, are identifiers prefixed by +Field identifiers, written :token:`field_ident`, are identifiers prefixed by `.` (dot) with no blank between the dot and the identifier. @@ -237,34 +227,27 @@ numbers (see :ref:`datatypes`). Sorts ----- -.. insertgram sort universe_level - -.. productionlist:: coq - sort : Set - : Prop - : SProp - : Type - : Type @{ _ } - : Type @{ `universe` } - universe : max ( `universe_exprs_comma` ) - : `universe_expr` - universe_exprs_comma : `universe_exprs_comma` , `universe_expr` - : `universe_expr` - universe_expr : `universe_name` `universe_increment_opt` - universe_name : `qualid` - : Set - : Prop - universe_increment_opt : + `num` - : `empty` - universe_annot_opt : @{ `universe_levels_opt` } - : `empty` - universe_levels_opt : `universe_levels_opt` `universe_level` - : `empty` - universe_level : Set - : Prop - : Type - : _ - : `qualid` +.. insertprodn sort univ_annot + +.. prodn:: + sort ::= Set + | Prop + | SProp + | Type + | Type @%{ _ %} + | Type @%{ @universe %} + universe ::= max ( {+, @universe_expr } ) + | @universe_expr + universe_expr ::= @universe_name {? + @num } + universe_name ::= @qualid + | Set + | Prop + universe_level ::= Set + | Prop + | Type + | _ + | @qualid + univ_annot ::= @%{ {* @universe_level } %} There are four sorts :g:`SProp`, :g:`Prop`, :g:`Set` and :g:`Type`. @@ -272,12 +255,12 @@ There are four sorts :g:`SProp`, :g:`Prop`, :g:`Set` and :g:`Type`. propositions* (also called *strict propositions*). - :g:`Prop` is the universe of *logical propositions*. The logical propositions - themselves are typing the proofs. We denote propositions by :production:`form`. + themselves are typing the proofs. We denote propositions by :token:`form`. This constitutes a semantic subclass of the syntactic class :token:`term`. - :g:`Set` is the universe of *program types* or *specifications*. The specifications themselves are typing the programs. We denote - specifications by :production:`specif`. This constitutes a semantic subclass of + specifications by :token:`specif`. This constitutes a semantic subclass of the syntactic class :token:`term`. - :g:`Type` is the type of sorts. @@ -289,34 +272,24 @@ More on sorts can be found in Section :ref:`sorts`. Binders ------- -.. insertgram open_binders exclam_opt - -.. productionlist:: coq - open_binders : `names` : `term` - : `binders` - names : `names` `name` - : `name` - name : _ - : `ident` - binders : `binders` `binder` - : `binder` - binder : `name` - : ( `names` : `term` ) - : ( `name` `colon_term_opt` := `term` ) - : { `name` } - : { `names` `colon_term_opt` } - : `( `typeclass_constraints_comma` ) - : `{ `typeclass_constraints_comma` } - : ' `pattern0` - : ( `name` : `term` | `term` ) - typeclass_constraints_comma : `typeclass_constraints_comma` , `typeclass_constraint` - : `typeclass_constraint` - typeclass_constraint : `exclam_opt` `term` - : { `name` } : `exclam_opt` `term` - : `name` : `exclam_opt` `term` - exclam_opt : ! - : `empty` - +.. insertprodn open_binders typeclass_constraint + +.. prodn:: + open_binders ::= {+ @name } : @term + | {+ @binder } + name ::= _ + | @ident + binder ::= @name + | ( {+ @name } : @term ) + | ( @name {? : @term } := @term ) + | %{ {+ @name } {? : @term } %} + | `( {+, @typeclass_constraint } ) + | `%{ {+, @typeclass_constraint } %} + | ' @pattern0 + | ( @name : @term %| @term ) + typeclass_constraint ::= {? ! } @term + | %{ @name %} : {? ! } @term + | @name : {? ! } @term Various constructions such as :g:`fun`, :g:`forall`, :g:`fix` and :g:`cofix` *bind* variables. A binding is represented by an identifier. If the binding @@ -335,7 +308,7 @@ variable can be introduced at the same time. It is also possible to give the type of the variable as follows: :n:`(@ident : @type := @term)`. -Lists of :token:`binder` are allowed. In the case of :g:`fun` and :g:`forall`, +Lists of :token:`binder`\s are allowed. In the case of :g:`fun` and :g:`forall`, it is intended that at least one binder of the list is an assumption otherwise fun and forall gets identical. Moreover, parentheses can be omitted in the case of a single sequence of bindings sharing the same type (e.g.: @@ -354,11 +327,8 @@ function on type :g:`A`). The keyword :g:`fun` can be followed by several binders as given in Section :ref:`binders`. Functions over several variables are equivalent to an iteration of one-variable functions. For instance the expression -“fun :token:`ident`\ :math:`_{1}` … :token:`ident`\ :math:`_{n}` -: :token:`type` => :token:`term`” -denotes the same function as “ fun :token:`ident`\ -:math:`_{1}` : :token:`type` => … -fun :token:`ident`\ :math:`_{n}` : :token:`type` => :token:`term`”. If +:n:`fun {+ @ident__i } : @type => @term` +denotes the same function as :n:`{+ fun @ident__i : @type => } @term`. If a let-binder occurs in the list of binders, it is expanded to a let-in definition (see Section :ref:`let-in`). @@ -389,15 +359,14 @@ the propositional implication and function types. Applications ------------ -The expression :token:`term`\ :math:`_0` :token:`term`\ :math:`_1` denotes the -application of :token:`term`\ :math:`_0` to :token:`term`\ :math:`_1`. +The expression :n:`@term__fun @term` denotes the application of +:n:`@term__fun` (which is expected to have a function type) to +:token:`term`. -The expression :token:`term`\ :math:`_0` :token:`term`\ :math:`_1` ... -:token:`term`\ :math:`_n` denotes the application of the term -:token:`term`\ :math:`_0` to the arguments :token:`term`\ :math:`_1` ... then -:token:`term`\ :math:`_n`. It is equivalent to ( … ( :token:`term`\ :math:`_0` -:token:`term`\ :math:`_1` ) … ) :token:`term`\ :math:`_n` : associativity is to the -left. +The expression :n:`@term__fun {+ @term__i }` denotes the application +of the term :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. The notation :n:`(@ident := @term)` for arguments is used for making explicit the value of implicit arguments (see @@ -411,13 +380,13 @@ Section :ref:`explicit-applications`). Type cast --------- -.. insertgram term_cast term_cast +.. insertprodn term_cast term_cast -.. productionlist:: coq - term_cast : `term10` <: `term` - : `term10` <<: `term` - : `term10` : `term` - : `term10` :> +.. prodn:: + term_cast ::= @term10 <: @term + | @term10 <<: @term + | @term10 : @term + | @term10 :> The expression :n:`@term : @type` is a type cast expression. It enforces the type of :token:`term` to be :token:`type`. @@ -444,21 +413,14 @@ guess the missing piece of information. Let-in definitions ------------------ -.. insertgram term_let names_comma +.. insertprodn term_let term_let -.. productionlist:: coq - term_let : let `name` `colon_term_opt` := `term` in `term` - : let `name` `binders` `colon_term_opt` := `term` in `term` - : let `single_fix` in `term` - : let `names_tuple` `as_return_type_opt` := `term` in `term` - : let ' `pattern` := `term` `return_type_opt` in `term` - : let ' `pattern` in `pattern` := `term` `return_type` in `term` - colon_term_opt : : `term` - : `empty` - names_tuple : ( `names_comma` ) - : () - names_comma : `names_comma` , `name` - : `name` +.. prodn:: + term_let ::= let @name {? : @term } := @term in @term + | let @name {+ @binder } {? : @term } := @term in @term + | let ( {*, @name } ) {? {? as @name } return @term100 } := @term in @term + | let ' @pattern := @term {? return @term100 } in @term + | let ' @pattern in @pattern := @term return @term100 in @term :n:`let @ident := @term in @term’` denotes the local binding of :token:`term` to the variable @@ -471,57 +433,25 @@ stands for :n:`let @ident := fun {+ @binder} => @term in @term’`. Definition by cases: match -------------------------- -.. insertgram term_match record_pattern - -.. productionlist:: coq - term_match : match `case_items_comma` `return_type_opt` with `or_opt` `eqns_or_opt` end - case_items_comma : `case_items_comma` , `case_item` - : `case_item` - return_type_opt : `return_type` - : `empty` - as_return_type_opt : `as_name_opt` `return_type` - : `empty` - return_type : return `term100` - case_item : `term100` `as_name_opt` `in_opt` - as_name_opt : as `name` - : `empty` - in_opt : in `pattern` - : `empty` - or_opt : | - : `empty` - eqns_or_opt : `eqns_or` - : `empty` - eqns_or : `eqns_or` | `eqn` - : `eqn` - eqn : `patterns_comma_list_or` => `term` - patterns_comma_list_or : `patterns_comma_list_or` | `patterns_comma` - : `patterns_comma` - patterns_comma : `patterns_comma` , `pattern` - : `pattern` - pattern : `pattern10` : `term` - : `pattern10` - pattern10 : `pattern1` as `name` - : `pattern1_list` - : @ `qualid` `pattern1_list_opt` - : `pattern1` - pattern1_list : `pattern1_list` `pattern1` - : `pattern1` - pattern1_list_opt : `pattern1_list` - : `empty` - pattern1 : `pattern0` % `ident` - : `pattern0` - pattern0 : `qualid` - : {| `record_patterns_opt` |} - : _ - : ( `patterns_or` ) - : `numeral` - : `string` - patterns_or : `patterns_or` | `pattern` - : `pattern` - record_patterns_opt : `record_patterns_opt` ; `record_pattern` - : `record_pattern` - : `empty` - record_pattern : `qualid` := `pattern` +.. insertprodn term_match pattern0 + +.. prodn:: + term_match ::= match {+, @case_item } {? return @term100 } with {? %| } {*| @eqn } end + case_item ::= @term100 {? as @name } {? in @pattern } + eqn ::= {+| {+, @pattern } } => @term + pattern ::= @pattern10 : @term + | @pattern10 + pattern10 ::= @pattern1 as @name + | @pattern1 {* @pattern1 } + | @ @qualid {* @pattern1 } + pattern1 ::= @pattern0 % @ident + | @pattern0 + pattern0 ::= @qualid + | %{%| {* @qualid := @pattern } %|%} + | _ + | ( {+| @pattern } ) + | @numeral + | @string Objects of inductive types can be destructured by a case-analysis construction called *pattern matching* expression. A pattern matching @@ -531,31 +461,30 @@ to apply specific treatments accordingly. This paragraph describes the basic form of pattern matching. See Section :ref:`Mult-match` and Chapter :ref:`extendedpatternmatching` for the description of the general form. The basic form of pattern matching is characterized -by a single :token:`case_item` expression, a :token:`patterns_comma` restricted to a +by a single :token:`case_item` expression, an :token:`eqn` restricted to a single :token:`pattern` and :token:`pattern` restricted to the form :n:`@qualid {* @ident}`. -The expression match ":token:`term`:math:`_0` :token:`return_type_opt` with -:token:`pattern`:math:`_1` => :token:`term`:math:`_1` :math:`|` … :math:`|` -:token:`pattern`:math:`_n` => :token:`term`:math:`_n` end" denotes a -*pattern matching* over the term :token:`term`:math:`_0` (expected to be -of an inductive type :math:`I`). The terms :token:`term`:math:`_1`\ …\ -:token:`term`:math:`_n` are the *branches* of the pattern matching -expression. Each of :token:`pattern`:math:`_i` has a form :token:`qualid` -:token:`ident` where :token:`qualid` must denote a constructor. There should be +The expression +:n:`match @term {? return @term100 } with {+| @pattern__i => @term__i } end` denotes a +*pattern matching* over the term :n:`@term` (expected to be +of an inductive type :math:`I`). The :n:`@term__i` +are the *branches* of the pattern matching +expression. Each :n:`@pattern__i` has the form :n:`@qualid @ident` +where :n:`@qualid` must denote a constructor. There should be exactly one branch for every constructor of :math:`I`. -The :token:`return_type_opt` expresses the type returned by the whole match +The :n:`return @term100` clause gives the type returned by the whole match expression. There are several cases. In the *non dependent* case, all -branches have the same type, and the :token:`return_type_opt` is the common type of -branches. In this case, :token:`return_type_opt` can usually be omitted as it can be -inferred from the type of the branches [2]_. +branches have the same type, and the :n:`return @term100` specifies that type. +In this case, :n:`return @term100` can usually be omitted as it can be +inferred from the type of the branches [1]_. In the *dependent* case, there are three subcases. In the first subcase, the type in each branch may depend on the exact value being matched in the branch. In this case, the whole pattern matching itself depends on the term being matched. This dependency of the term being matched in the -return type is expressed with an “as :token:`ident`” clause where :token:`ident` +return type is expressed with an :n:`@ident` clause where :token:`ident` is dependent in the return type. For instance, in the following example: .. coqtop:: in @@ -604,19 +533,19 @@ type of each branch can depend on the type dependencies specific to the branch and the whole pattern matching expression has a type determined by the specific dependencies in the type of the term being matched. This dependency of the return type in the annotations of the inductive type -is expressed using a “:g:`in` :math:`I` :g:`_ … _` :token:`pattern`:math:`_1` … -:token:`pattern`:math:`_n`” clause, where +is expressed with a clause in the form +:n:`in @qualid {+ _ } {+ @pattern }`, where -- :math:`I` is the inductive type of the term being matched; +- :token:`qualid` is the inductive type of the term being matched; -- the :g:`_` are matching the parameters of the inductive type: the +- the holes :n:`_` match the parameters of the inductive type: the return type is not dependent on them. -- the :token:`pattern`:math:`_i` are matching the annotations of the +- each :n:`@pattern` matches the annotations of the inductive type: the return type is dependent on them -- in the basic case which we describe below, each :token:`pattern`:math:`_i` - is a name :token:`ident`:math:`_i`; see :ref:`match-in-patterns` for the +- in the basic case which we describe below, each :n:`@pattern` + is a name :n:`@ident`; see :ref:`match-in-patterns` for the general case For instance, in the following example: @@ -651,27 +580,18 @@ Sections :ref:`if-then-else` and :ref:`irrefutable-patterns`). Recursive and co-recursive functions: fix and cofix --------------------------------------------------- -.. insertgram term_fix term1_extended_opt +.. insertprodn term_fix term1_extended + +.. prodn:: + term_fix ::= let fix @fix_body in @term + | fix @fix_body {? {+ with @fix_body } for @ident } + fix_body ::= @ident {* @binder } {? @fixannot } {? : @term } := @term + fixannot ::= %{ struct @ident %} + | %{ wf @term1_extended @ident %} + | %{ measure @term1_extended {? @ident } {? @term1_extended } %} + term1_extended ::= @term1 + | @ @qualid {? @univ_annot } -.. productionlist:: coq - term_fix : `single_fix` - : `single_fix` with `fix_bodies` for `ident` - single_fix : fix `fix_body` - : cofix `fix_body` - fix_bodies : `fix_bodies` with `fix_body` - : `fix_body` - fix_body : `ident` `binders_opt` `fixannot_opt` `colon_term_opt` := `term` - fixannot_opt : `fixannot` - : `empty` - fixannot : { struct `ident` } - : { wf `term1_extended` `ident` } - : { measure `term1_extended` `ident_opt` `term1_extended_opt` } - term1_extended : `term1` - : @ `qualid` `universe_annot_opt` - ident_opt : `ident` - : `empty` - term1_extended_opt : `term1_extended` - : `empty` The expression “``fix`` :token:`ident`:math:`_1` :token:`binder`:math:`_1` ``:`` :token:`type`:math:`_1` ``:=`` :token:`term`:math:`_1` ``with … with`` @@ -681,6 +601,17 @@ The expression “``fix`` :token:`ident`:math:`_1` :token:`binder`:math:`_1` ``: recursion. It is the local counterpart of the :cmd:`Fixpoint` command. When :math:`n=1`, the “``for`` :token:`ident`:math:`_i`” clause is omitted. +The association of a single fixpoint and a local definition have a special +syntax: :n:`let fix @ident @binders := @term in` stands for +:n:`let @ident := fix @ident @binders := @term in`. The same applies for co-fixpoints. + +.. insertprodn term_cofix cofix_body + +.. prodn:: + term_cofix ::= let cofix @cofix_body in @term + | cofix @cofix_body {? {+ with @cofix_body } for @ident } + cofix_body ::= @ident {* @binder } {? : @term } := @term + The expression “``cofix`` :token:`ident`:math:`_1` :token:`binder`:math:`_1` ``:`` :token:`type`:math:`_1` ``with … with`` :token:`ident`:math:`_n` :token:`binder`:math:`_n` : :token:`type`:math:`_n` ``for`` :token:`ident`:math:`_i`” denotes the @@ -688,10 +619,6 @@ The expression “``cofix`` :token:`ident`:math:`_1` :token:`binder`:math:`_1` ` co-recursion. It is the local counterpart of the :cmd:`CoFixpoint` command. When :math:`n=1`, the “``for`` :token:`ident`:math:`_i`” clause is omitted. -The association of a single fixpoint and a local definition have a special -syntax: :n:`let fix @ident @binders := @term in` stands for -:n:`let @ident := fix @ident @binders := @term in`. The same applies for co-fixpoints. - .. _vernacular: The Vernacular @@ -715,6 +642,8 @@ The Vernacular : ( `ident` … `ident` : `term` ) … ( `ident` … `ident` : `term` ) definition : [Local] Definition `ident` [`binders`] [: `term`] := `term` . : Let `ident` [`binders`] [: `term`] := `term` . + binders : binders binder + : binder inductive : Inductive `ind_body` with … with `ind_body` . : CoInductive `ind_body` with … with `ind_body` . ind_body : `ident` [`binders`] : `term` := @@ -1545,7 +1474,7 @@ Chapter :ref:`Tactics`. The basic assertion command is: The name you provided is already defined. You have then to choose another name. - .. exn:: Nested proofs are not allowed unless you turn the :flag:`Nested Proofs Allowed` flag on. + .. exn:: Nested proofs are not allowed unless you turn the Nested Proofs Allowed flag on. You are asserting a new statement while already being in proof editing mode. This feature, called nested proofs, is disabled by default. @@ -1691,6 +1620,17 @@ variety of commands: :n:`@string__1` is the actual notation, :n:`@string__2` is the version number, :n:`@string__3` is the note. +``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. + + This attirbute can take the value ``false`` when decorating a record field + declaration with the effect of preventing the field from being involved in + the inference of canonical instances. + + See also :ref:`canonical-structure-declaration`. + .. example:: .. coqtop:: all reset warn @@ -1715,10 +1655,5 @@ variety of commands: command with some attribute it does not understand. .. [1] - This is similar to the expression “*entry* :math:`\{` sep *entry* - :math:`\}`” in standard BNF, or “*entry* :math:`(` sep *entry* - :math:`)`\ \*” in the syntax of regular expressions. - -.. [2] Except if the inductive type is empty in which case there is no equation that can be used to infer the return type. diff --git a/doc/sphinx/practical-tools/coq-commands.rst b/doc/sphinx/practical-tools/coq-commands.rst index d4a61425e1..98d222e317 100644 --- a/doc/sphinx/practical-tools/coq-commands.rst +++ b/doc/sphinx/practical-tools/coq-commands.rst @@ -157,8 +157,6 @@ and ``coqtop``, unless stated otherwise: loading the default resource file from the standard configuration directories. :-q: Do not to load the default resource file. -:-load-ml-source *file*: Load the OCaml source file *file*. -:-load-ml-object *file*: Load the OCaml object file *file*. :-l *file*, -load-vernac-source *file*: Load and execute the |Coq| script from *file.v*. :-lv *file*, -load-vernac-source-verbose *file*: Load and execute the @@ -253,6 +251,7 @@ and ``coqtop``, unless stated otherwise: :-h, --help: Print a short usage and exit. +.. _compiled-interfaces: Compiled interfaces (produced using ``-vos``) ---------------------------------------------- diff --git a/doc/sphinx/proof-engine/ltac2.rst b/doc/sphinx/proof-engine/ltac2.rst index cfdc70d50e..b722b1af74 100644 --- a/doc/sphinx/proof-engine/ltac2.rst +++ b/doc/sphinx/proof-engine/ltac2.rst @@ -1,12 +1,12 @@ .. _ltac2: +Ltac2 +===== + .. coqtop:: none From Ltac2 Require Import Ltac2. -Ltac2 -===== - The Ltac tactic language is probably one of the ingredients of the success of Coq, yet it is at the same time its Achilles' heel. Indeed, Ltac: @@ -940,6 +940,13 @@ below will fail immediately and won't print anything. In any case, the value returned by the fully applied quotation is an unspecified dummy Ltac1 closure and should not be further used. +Switching between Ltac languages +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We recommend using the :opt:`Default Proof Mode` option to switch between tactic +languages with a proof-based granularity. This allows to incrementally port +the proof scripts. + Transition from Ltac1 --------------------- diff --git a/doc/sphinx/proof-engine/proof-handling.rst b/doc/sphinx/proof-engine/proof-handling.rst index 6884b6e998..b1734b3f19 100644 --- a/doc/sphinx/proof-engine/proof-handling.rst +++ b/doc/sphinx/proof-engine/proof-handling.rst @@ -265,6 +265,35 @@ Name a set of section hypotheses for ``Proof using`` has remaining uninstantiated existential variables. It takes every uninstantiated existential variable and turns it into a goal. +Proof modes +``````````` + +When entering proof mode through commands such as :cmd:`Goal` and :cmd:`Proof`, +|Coq| picks by default the |Ltac| mode. Nonetheless, there exist other proof modes +shipped in the standard |Coq| installation, and furthermore some plugins define +their own proof modes. The default proof mode used when opening a proof can +be changed using the following option. + +.. opt:: Default Proof Mode @string + :name: Default Proof Mode + + Select the proof mode to use when starting a proof. Depending on the proof + mode, various syntactic constructs are allowed when writing an interactive + proof. The possible option values are listed below. + + - "Classic": this is the default. It activates the |Ltac| language to interact + with the proof, and also allows vernacular commands. + + - "Noedit": this proof mode only allows vernacular commands. No tactic + language is activated at all. This is the default when the prelude is not + loaded, e.g. through the `-noinit` option for `coqc`. + + - "Ltac2": this proof mode is made available when requiring the Ltac2 + library, and is set to be the default when it is imported. It allows + to use the Ltac2 language, as well as vernacular commands. + + - Some external plugins also define their own proof mode, which can be + activated via this command. Navigation in the proof tree -------------------------------- @@ -490,6 +519,13 @@ The following example script illustrates all these features: You just finished a goal focused by ``{``, you must unfocus it with ``}``. +Mandatory Bullets +````````````````` + +Using :opt:`Default Goal Selector` with the ``!`` selector forces +tactic scripts to keep focus to exactly one goal (e.g. using bullets) +or use explicit goal selectors. + Set Bullet Behavior ``````````````````` .. opt:: Bullet Behavior {| "None" | "Strict Subproofs" } diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 878118c48a..36a5916868 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -688,6 +688,28 @@ Applying theorems instantiate (see :ref:`Existential-Variables`). The instantiation is intended to be found later in the proof. + .. tacv:: rapply @term + :name: rapply + + The tactic :tacn:`rapply` behaves like :tacn:`eapply` but it + uses the proof engine of :tacn:`refine` for dealing with + existential variables, holes, and conversion problems. This may + result in slightly different behavior regarding which conversion + problems are solvable. However, like :tacn:`apply` but unlike + :tacn:`eapply`, :tacn:`rapply` will fail if there are any holes + which remain in :n:`@term` itself after typechecking and + typeclass resolution but before unification with the goal. More + technically, :n:`@term` is first parsed as a + :production:`constr` rather than as a :production:`uconstr` or + :production:`open_constr` before being applied to the goal. Note + that :tacn:`rapply` prefers to instantiate as many hypotheses of + :n:`@term` as possible. As a result, if it is possible to apply + :n:`@term` to arbitrarily many arguments without getting a type + error, :tacn:`rapply` will loop. + + Note that you need to :n:`Require Import Coq.Program.Tactics` to + make use of :tacn:`rapply`. + .. tacv:: simple apply @term. This behaves like :tacn:`apply` but it reasons modulo conversion only on subterms @@ -3091,6 +3113,12 @@ the conversion in hypotheses :n:`{+ @ident}`. compilation cost is higher, so it is worth using only for intensive computations. + .. 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. + .. flag:: NativeCompute Profiling On Linux, if you have the ``perf`` profiler installed, this flag makes diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index 89b24ea8a3..a38c26c2b3 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -1200,7 +1200,7 @@ Controlling the locality of commands + Commands whose default behavior is to extend their effect outside sections but not outside modules when they occur in a section and to extend their effect outside the module or library file they occur in - when no section contains them.For these commands, the Local modifier + when no section contains them. For these commands, the Local modifier limits the effect to the current section or module while the Global modifier extends the effect outside the module even when the command occurs in a section. The :cmd:`Set` and :cmd:`Unset` commands belong to this diff --git a/doc/stdlib/dune b/doc/stdlib/dune index 7fe2493fbf..828caecabc 100644 --- a/doc/stdlib/dune +++ b/doc/stdlib/dune @@ -5,7 +5,8 @@ (deps make-library-index index-list.html.template hidden-files (source_tree %{project_root}/theories) - (source_tree %{project_root}/plugins)) + (source_tree %{project_root}/plugins) + (source_tree %{project_root}/user-contrib)) (action (chdir %{project_root} ; On windows run will fail @@ -17,6 +18,7 @@ ; This will be replaced soon by `theories/**/*.v` soon, thanks to rgrinberg (source_tree %{project_root}/theories) (source_tree %{project_root}/plugins) + (source_tree %{project_root}/user-contrib) (:header %{project_root}/doc/common/styles/html/coqremote/header.html) (:footer %{project_root}/doc/common/styles/html/coqremote/footer.html) ; For .glob files, should be gone when Coq Dune is smarter. @@ -24,7 +26,7 @@ (action (progn (run mkdir -p html) - (bash "%{bin:coqdoc} -q -d html --with-header %{header} --with-footer %{footer} --multi-index --html -g -R %{project_root}/theories Coq -R %{project_root}/plugins Coq $(find %{project_root}/theories %{project_root}/plugins -name *.v)") + (bash "%{bin:coqdoc} -q -d html --with-header %{header} --with-footer %{footer} --multi-index --html -g -R %{project_root}/theories Coq -R %{project_root}/plugins Coq -Q %{project_root}/user-contrib/Ltac2 Ltac2 $(find %{project_root}/theories %{project_root}/plugins %{project_root}/user-contrib -name *.v)") (run mv html/index.html html/genindex.html) (with-stdout-to _index.html diff --git a/doc/stdlib/hidden-files b/doc/stdlib/hidden-files index b816ef6210..dbc3a42ee9 100644 --- a/doc/stdlib/hidden-files +++ b/doc/stdlib/hidden-files @@ -12,12 +12,14 @@ plugins/extraction/ExtrHaskellZInteger.v plugins/extraction/ExtrHaskellZNum.v plugins/extraction/ExtrOcamlBasic.v plugins/extraction/ExtrOcamlBigIntConv.v +plugins/extraction/ExtrOcamlChar.v plugins/extraction/ExtrOCamlInt63.v plugins/extraction/ExtrOCamlFloats.v plugins/extraction/ExtrOcamlIntConv.v plugins/extraction/ExtrOcamlNatBigInt.v plugins/extraction/ExtrOcamlNatInt.v plugins/extraction/ExtrOcamlString.v +plugins/extraction/ExtrOcamlNativeString.v plugins/extraction/ExtrOcamlZBigInt.v plugins/extraction/ExtrOcamlZInt.v plugins/extraction/Extraction.v diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index ac611926b3..5e13214a1a 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -626,6 +626,31 @@ through the <tt>Require Import</tt> command.</p> plugins/ssr/ssrfun.v </dd> + <dt> <b>Ltac2</b>: + The Ltac2 tactic programming language + </dt> + <dd> + user-contrib/Ltac2/Ltac2.v + user-contrib/Ltac2/Array.v + user-contrib/Ltac2/Bool.v + user-contrib/Ltac2/Char.v + user-contrib/Ltac2/Constr.v + user-contrib/Ltac2/Control.v + user-contrib/Ltac2/Env.v + user-contrib/Ltac2/Fresh.v + user-contrib/Ltac2/Ident.v + user-contrib/Ltac2/Init.v + user-contrib/Ltac2/Int.v + user-contrib/Ltac2/List.v + user-contrib/Ltac2/Ltac1.v + user-contrib/Ltac2/Message.v + user-contrib/Ltac2/Notations.v + user-contrib/Ltac2/Option.v + user-contrib/Ltac2/Pattern.v + user-contrib/Ltac2/Std.v + user-contrib/Ltac2/String.v + </dd> + <dt> <b>Unicode</b>: Unicode-based notations </dt> diff --git a/doc/stdlib/make-library-index b/doc/stdlib/make-library-index index bea6f24098..732f15b78a 100755 --- a/doc/stdlib/make-library-index +++ b/doc/stdlib/make-library-index @@ -1,4 +1,4 @@ -#!/bin/sh +#!/usr/bin/env bash # Instantiate links to library files in index template @@ -8,9 +8,14 @@ HIDDEN=$2 cp -f $FILE.template tmp echo -n "Building file index-list.prehtml... " -LIBDIRS=`find theories/* plugins/* -type d ! -name .coq-native` +LIBDIRS=`find theories/* plugins/* user-contrib/* -type d ! -name .coq-native` for k in $LIBDIRS; do + if [[ $k =~ "user-contrib" ]]; then + BASE_PREFIX="" + else + BASE_PREFIX="Coq." + fi d=`basename $k` ls $k | grep -q \.v'$' if [ $? = 0 ]; then @@ -26,7 +31,7 @@ for k in $LIBDIRS; do echo Error: $FILE and $HIDDEN both mention $k/$b.v; exit 1 else p=`echo $k | sed 's:^[^/]*/::' | sed 's:/:.:g'` - sed -e "s:$k/$b.v:<a href=\"Coq.$p.$b.html\">$b</a>:g" tmp > tmp2 + sed -e "s:$k/$b.v:<a href=\"$BASE_PREFIX$p.$b.html\">$b</a>:g" tmp > tmp2 mv -f tmp2 tmp fi else diff --git a/doc/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index eff70bdac5..1f9178f4b6 100644 --- a/doc/tools/coqrst/coqdomain.py +++ b/doc/tools/coqrst/coqdomain.py @@ -403,55 +403,60 @@ class TableObject(NotationObject): class ProductionObject(CoqObject): r"""A grammar production. - This is useful if you intend to document individual grammar productions. - Otherwise, use Sphinx's `production lists + Use ``.. prodn`` to document grammar productions instead of Sphinx + `production lists <http://www.sphinx-doc.org/en/stable/markup/para.html#directive-productionlist>`_. - Unlike ``.. productionlist``\ s, this directive accepts notation syntax. - - - Usage:: - - .. prodn:: token += production - .. prodn:: token ::= production + prodn displays multiple productions together with alignment similar to ``.. productionlist``, + however unlike ``.. productionlist``\ s, this directive accepts notation syntax. Example:: - .. prodn:: term += let: @pattern := @term in @term .. prodn:: occ_switch ::= { {? {| + | - } } {* @num } } + term += let: @pattern := @term in @term + | second_production + + The first line defines "occ_switch", which must be unique in the document. The second + references and expands the definition of "term", whose main definition is elsewhere + in the document. The third form is for continuing the + definition of a nonterminal when it has multiple productions. It leaves the first + column in the output blank. """ subdomain = "prodn" #annotation = "Grammar production" + # handle_signature is called for each line of input in the prodn:: + # 'signatures' accumulates them in order to combine the lines into a single table: + signatures = None + def _render_signature(self, signature, signode): raise NotImplementedError(self) SIG_ERROR = ("{}: Invalid syntax in ``.. prodn::`` directive" + "\nExpected ``name ::= ...`` or ``name += ...``" - + " (e.g. ``pattern += constr:(@ident)``)") + + " (e.g. ``pattern += constr:(@ident)``)\n" + + " in `{}`") def handle_signature(self, signature, signode): - nsplits = 2 - parts = signature.split(maxsplit=nsplits) - if len(parts) != 3: - loc = os.path.basename(get_node_location(signode)) - raise ExtensionError(ProductionObject.SIG_ERROR.format(loc)) - - lhs, op, rhs = (part.strip() for part in parts) - if op not in ["::=", "+="]: - loc = os.path.basename(get_node_location(signode)) - raise ExtensionError(ProductionObject.SIG_ERROR.format(loc)) - - self._render_annotation(signode) - - lhs_op = '{} {} '.format(lhs, op) - lhs_node = nodes.literal(lhs_op, lhs_op) - - position = self.state_machine.get_source_and_line(self.lineno) - rhs_node = notation_to_sphinx(rhs, *position) - signode += addnodes.desc_name(signature, '', lhs_node, rhs_node) + parts = signature.split(maxsplit=1) + if parts[0].strip() == "|" and len(parts) == 2: + lhs = "" + op = "|" + rhs = parts[1].strip() + else: + nsplits = 2 + parts = signature.split(maxsplit=nsplits) + if len(parts) != 3: + loc = os.path.basename(get_node_location(signode)) + raise ExtensionError(ProductionObject.SIG_ERROR.format(loc, signature)) + else: + lhs, op, rhs = (part.strip() for part in parts) + if op not in ["::=", "+="]: + loc = os.path.basename(get_node_location(signode)) + raise ExtensionError(ProductionObject.SIG_ERROR.format(loc, signature)) + self.signatures.append((lhs, op, rhs)) return ('token', lhs) if op == '::=' else None def _add_index_entry(self, name, target): @@ -468,6 +473,49 @@ class ProductionObject(CoqObject): self._warn_if_duplicate_name(objects, name) objects[name] = env.docname, targetid + def run(self): + self.signatures = [] + indexnode = super().run()[0] # makes calls to handle_signature + + table = nodes.inline(classes=['prodn-table']) + tgroup = nodes.inline(classes=['prodn-column-group']) + for i in range(3): + tgroup += nodes.inline(classes=['prodn-column']) + table += tgroup + tbody = nodes.inline(classes=['prodn-row-group']) + table += tbody + + # create rows + for signature in self.signatures: + lhs, op, rhs = signature + position = self.state_machine.get_source_and_line(self.lineno) + + row = nodes.inline(classes=['prodn-row']) + entry = nodes.inline(classes=['prodn-cell-nonterminal']) + if lhs != "": + target_name = 'grammar-token-' + lhs + target = nodes.target('', '', ids=[target_name], names=[target_name]) + # putting prodn-target on the target node won't appear in the tex file + inline = nodes.inline(classes=['prodn-target']) + inline += target + entry += inline + entry += notation_to_sphinx('@'+lhs, *position) + else: + entry += nodes.literal('', '') + row += entry + + entry = nodes.inline(classes=['prodn-cell-op']) + entry += nodes.literal(op, op) + row += entry + + entry = nodes.inline(classes=['prodn-cell-production']) + entry += notation_to_sphinx(rhs, *position) + row += entry + + tbody += row + + return [indexnode, table] # only this node goes into the doc + class ExceptionObject(NotationObject): """An error raised by a Coq command or tactic. diff --git a/doc/tools/coqrst/notations/TacticNotations.g b/doc/tools/coqrst/notations/TacticNotations.g index 905b52525a..f9cf26a21e 100644 --- a/doc/tools/coqrst/notations/TacticNotations.g +++ b/doc/tools/coqrst/notations/TacticNotations.g @@ -42,7 +42,8 @@ LALT: '{|'; LGROUP: '{+' | '{*' | '{?'; LBRACE: '{'; RBRACE: '}'; -ESCAPED: '%{' | '%}' | '%|'; +// todo: need a cleaner way to escape the 3-character strings here +ESCAPED: '%{' | '%}' | '%|' | '`%{' | '@%{'; PIPE: '|'; ATOM: '@' | '_' | ~[@_{}| ]+; ID: '@' ('_'? [a-zA-Z0-9])+; diff --git a/doc/tools/coqrst/notations/TacticNotationsLexer.py b/doc/tools/coqrst/notations/TacticNotationsLexer.py index e3a115e32a..7bda849010 100644 --- a/doc/tools/coqrst/notations/TacticNotationsLexer.py +++ b/doc/tools/coqrst/notations/TacticNotationsLexer.py @@ -8,33 +8,35 @@ import sys def serializedATN(): with StringIO() as buf: buf.write("\3\u608b\ua72a\u8133\ub9ed\u417c\u3be7\u7786\u5964\2\f") - buf.write("M\b\1\4\2\t\2\4\3\t\3\4\4\t\4\4\5\t\5\4\6\t\6\4\7\t\7") + buf.write("S\b\1\4\2\t\2\4\3\t\3\4\4\t\4\4\5\t\5\4\6\t\6\4\7\t\7") buf.write("\4\b\t\b\4\t\t\t\4\n\t\n\4\13\t\13\3\2\3\2\3\2\3\3\3\3") buf.write("\3\3\3\3\3\3\3\3\5\3!\n\3\3\4\3\4\3\5\3\5\3\6\3\6\3\6") - buf.write("\3\6\3\6\3\6\5\6-\n\6\3\7\3\7\3\b\3\b\6\b\63\n\b\r\b\16") - buf.write("\b\64\5\b\67\n\b\3\t\3\t\5\t;\n\t\3\t\6\t>\n\t\r\t\16") - buf.write("\t?\3\n\3\n\3\n\6\nE\n\n\r\n\16\nF\3\13\6\13J\n\13\r\13") - buf.write("\16\13K\2\2\f\3\3\5\4\7\5\t\6\13\7\r\b\17\t\21\n\23\13") - buf.write("\25\f\3\2\5\4\2BBaa\6\2\"\"BBaa}\177\5\2\62;C\\c|\2V\2") - buf.write("\3\3\2\2\2\2\5\3\2\2\2\2\7\3\2\2\2\2\t\3\2\2\2\2\13\3") - buf.write("\2\2\2\2\r\3\2\2\2\2\17\3\2\2\2\2\21\3\2\2\2\2\23\3\2") - buf.write("\2\2\2\25\3\2\2\2\3\27\3\2\2\2\5 \3\2\2\2\7\"\3\2\2\2") - buf.write("\t$\3\2\2\2\13,\3\2\2\2\r.\3\2\2\2\17\66\3\2\2\2\218\3") - buf.write("\2\2\2\23A\3\2\2\2\25I\3\2\2\2\27\30\7}\2\2\30\31\7~\2") - buf.write("\2\31\4\3\2\2\2\32\33\7}\2\2\33!\7-\2\2\34\35\7}\2\2\35") - buf.write("!\7,\2\2\36\37\7}\2\2\37!\7A\2\2 \32\3\2\2\2 \34\3\2\2") - buf.write("\2 \36\3\2\2\2!\6\3\2\2\2\"#\7}\2\2#\b\3\2\2\2$%\7\177") - buf.write("\2\2%\n\3\2\2\2&\'\7\'\2\2\'-\7}\2\2()\7\'\2\2)-\7\177") - buf.write("\2\2*+\7\'\2\2+-\7~\2\2,&\3\2\2\2,(\3\2\2\2,*\3\2\2\2") - buf.write("-\f\3\2\2\2./\7~\2\2/\16\3\2\2\2\60\67\t\2\2\2\61\63\n") - buf.write("\3\2\2\62\61\3\2\2\2\63\64\3\2\2\2\64\62\3\2\2\2\64\65") - buf.write("\3\2\2\2\65\67\3\2\2\2\66\60\3\2\2\2\66\62\3\2\2\2\67") - buf.write("\20\3\2\2\28=\7B\2\29;\7a\2\2:9\3\2\2\2:;\3\2\2\2;<\3") - buf.write("\2\2\2<>\t\4\2\2=:\3\2\2\2>?\3\2\2\2?=\3\2\2\2?@\3\2\2") - buf.write("\2@\22\3\2\2\2AB\7a\2\2BD\7a\2\2CE\t\4\2\2DC\3\2\2\2E") - buf.write("F\3\2\2\2FD\3\2\2\2FG\3\2\2\2G\24\3\2\2\2HJ\7\"\2\2IH") - buf.write("\3\2\2\2JK\3\2\2\2KI\3\2\2\2KL\3\2\2\2L\26\3\2\2\2\13") - buf.write("\2 ,\64\66:?FK\2") + buf.write("\3\6\3\6\3\6\3\6\3\6\3\6\3\6\3\6\3\6\5\6\63\n\6\3\7\3") + buf.write("\7\3\b\3\b\6\b9\n\b\r\b\16\b:\5\b=\n\b\3\t\3\t\5\tA\n") + buf.write("\t\3\t\6\tD\n\t\r\t\16\tE\3\n\3\n\3\n\6\nK\n\n\r\n\16") + buf.write("\nL\3\13\6\13P\n\13\r\13\16\13Q\2\2\f\3\3\5\4\7\5\t\6") + buf.write("\13\7\r\b\17\t\21\n\23\13\25\f\3\2\5\4\2BBaa\6\2\"\"B") + buf.write("Baa}\177\5\2\62;C\\c|\2^\2\3\3\2\2\2\2\5\3\2\2\2\2\7\3") + buf.write("\2\2\2\2\t\3\2\2\2\2\13\3\2\2\2\2\r\3\2\2\2\2\17\3\2\2") + buf.write("\2\2\21\3\2\2\2\2\23\3\2\2\2\2\25\3\2\2\2\3\27\3\2\2\2") + buf.write("\5 \3\2\2\2\7\"\3\2\2\2\t$\3\2\2\2\13\62\3\2\2\2\r\64") + buf.write("\3\2\2\2\17<\3\2\2\2\21>\3\2\2\2\23G\3\2\2\2\25O\3\2\2") + buf.write("\2\27\30\7}\2\2\30\31\7~\2\2\31\4\3\2\2\2\32\33\7}\2\2") + buf.write("\33!\7-\2\2\34\35\7}\2\2\35!\7,\2\2\36\37\7}\2\2\37!\7") + buf.write("A\2\2 \32\3\2\2\2 \34\3\2\2\2 \36\3\2\2\2!\6\3\2\2\2\"") + buf.write("#\7}\2\2#\b\3\2\2\2$%\7\177\2\2%\n\3\2\2\2&\'\7\'\2\2") + buf.write("\'\63\7}\2\2()\7\'\2\2)\63\7\177\2\2*+\7\'\2\2+\63\7~") + buf.write("\2\2,-\7b\2\2-.\7\'\2\2.\63\7}\2\2/\60\7B\2\2\60\61\7") + buf.write("\'\2\2\61\63\7}\2\2\62&\3\2\2\2\62(\3\2\2\2\62*\3\2\2") + buf.write("\2\62,\3\2\2\2\62/\3\2\2\2\63\f\3\2\2\2\64\65\7~\2\2\65") + buf.write("\16\3\2\2\2\66=\t\2\2\2\679\n\3\2\28\67\3\2\2\29:\3\2") + buf.write("\2\2:8\3\2\2\2:;\3\2\2\2;=\3\2\2\2<\66\3\2\2\2<8\3\2\2") + buf.write("\2=\20\3\2\2\2>C\7B\2\2?A\7a\2\2@?\3\2\2\2@A\3\2\2\2A") + buf.write("B\3\2\2\2BD\t\4\2\2C@\3\2\2\2DE\3\2\2\2EC\3\2\2\2EF\3") + buf.write("\2\2\2F\22\3\2\2\2GH\7a\2\2HJ\7a\2\2IK\t\4\2\2JI\3\2\2") + buf.write("\2KL\3\2\2\2LJ\3\2\2\2LM\3\2\2\2M\24\3\2\2\2NP\7\"\2\2") + buf.write("ON\3\2\2\2PQ\3\2\2\2QO\3\2\2\2QR\3\2\2\2R\26\3\2\2\2\13") + buf.write("\2 \62:<@ELQ\2") return buf.getvalue() diff --git a/doc/tools/coqrst/notations/fontsupport.py b/doc/tools/coqrst/notations/fontsupport.py index f0df7f1c01..c3ba2c1301 100755 --- a/doc/tools/coqrst/notations/fontsupport.py +++ b/doc/tools/coqrst/notations/fontsupport.py @@ -1,4 +1,5 @@ #!/usr/bin/env python2 +# -*- coding: utf-8 -*- ########################################################################## ## # The Coq Proof Assistant / The Coq Development Team ## ## v # INRIA, CNRS and contributors - Copyright 1999-2019 ## diff --git a/doc/tools/coqrst/notations/html.py b/doc/tools/coqrst/notations/html.py index d9c5383774..1136ee4997 100644 --- a/doc/tools/coqrst/notations/html.py +++ b/doc/tools/coqrst/notations/html.py @@ -61,7 +61,7 @@ class TacticNotationsToHTMLVisitor(TacticNotationsVisitor): tags.sub(sub.getText()[1:]) def visitEscaped(self, ctx:TacticNotationsParser.EscapedContext): - tags.span(ctx.ESCAPED().getText()[1:]) + tags.span(ctx.ESCAPED().getText().replace("%", "")) def visitWhitespace(self, ctx:TacticNotationsParser.WhitespaceContext): text(" ") diff --git a/doc/tools/coqrst/notations/plain.py b/doc/tools/coqrst/notations/plain.py index 93a7ec4683..23996b0d63 100644 --- a/doc/tools/coqrst/notations/plain.py +++ b/doc/tools/coqrst/notations/plain.py @@ -53,7 +53,7 @@ class TacticNotationsToDotsVisitor(TacticNotationsVisitor): self.buffer.write("‘{}’".format(ctx.ID().getText()[1:])) def visitEscaped(self, ctx:TacticNotationsParser.EscapedContext): - self.buffer.write(ctx.ESCAPED().getText()[1:]) + self.buffer.write(ctx.ESCAPED().getText().replace("%", "")) def visitWhitespace(self, ctx:TacticNotationsParser.WhitespaceContext): self.buffer.write(" ") diff --git a/doc/tools/coqrst/notations/sphinx.py b/doc/tools/coqrst/notations/sphinx.py index 4ca0a2ef83..ab18d136b8 100644 --- a/doc/tools/coqrst/notations/sphinx.py +++ b/doc/tools/coqrst/notations/sphinx.py @@ -45,7 +45,11 @@ class TacticNotationsToSphinxVisitor(TacticNotationsVisitor): def visitRepeat(self, ctx:TacticNotationsParser.RepeatContext): # Uses inline nodes instead of subscript and superscript to ensure that # we get the right customization hooks at the LaTeX level - wrapper = nodes.inline('', '', classes=['repeat-wrapper']) + separator = ctx.ATOM() or ctx.PIPE() + # I wanted to have 2 independent classes "repeat-wrapper" and "with-sub" here, + # but that breaks the latex build (invalid .tex file) + classes = 'repeat-wrapper-with-sub' if separator else 'repeat-wrapper' + wrapper = nodes.inline('', '', classes=[classes]) children = self.visitChildren(ctx) if len(children) == 1 and self.is_alternative(children[0]): @@ -58,7 +62,6 @@ class TacticNotationsToSphinxVisitor(TacticNotationsVisitor): repeat_marker = ctx.LGROUP().getText()[1] wrapper += nodes.inline(repeat_marker, repeat_marker, classes=['notation-sup']) - separator = ctx.ATOM() or ctx.PIPE() if separator: sep = separator.getText() wrapper += nodes.inline(sep, sep, classes=['notation-sub']) @@ -72,10 +75,33 @@ class TacticNotationsToSphinxVisitor(TacticNotationsVisitor): sp += nodes.Text("}") return [sp] + def escape(self, atom): + node = nodes.inline("","") + while atom != "": + if atom[0] == "'": + node += nodes.raw("\\textquotesingle{}", "\\textquotesingle{}", format="latex") + atom = atom[1:] + elif atom[0] == "`": + node += nodes.raw("\\`{}", "\\`{}", format="latex") + atom = atom[1:] + else: + index_ap = atom.find("'") + index_bt = atom.find("`") + if index_ap == -1: + index = index_bt + elif index_bt == -1: + index = index_ap + else: + index = min(index_ap, index_bt) + lit = atom if index == -1 else atom[:index] + node += nodes.inline(lit, lit) + atom = atom[len(lit):] + return node + def visitAtomic(self, ctx:TacticNotationsParser.AtomicContext): atom = ctx.ATOM().getText() sub = ctx.SUB() - node = nodes.inline(atom, atom) + node = self.escape(atom) if sub: sub_index = sub.getText()[2:] @@ -101,7 +127,7 @@ class TacticNotationsToSphinxVisitor(TacticNotationsVisitor): def visitEscaped(self, ctx:TacticNotationsParser.EscapedContext): escaped = ctx.ESCAPED().getText() - return [nodes.inline(escaped, escaped[1:])] + return [self.escape(escaped.replace("%", ""))] def visitWhitespace(self, ctx:TacticNotationsParser.WhitespaceContext): return [nodes.Text(" ")] diff --git a/doc/tools/docgram/README.md b/doc/tools/docgram/README.md index a0a1809133..182532e413 100644 --- a/doc/tools/docgram/README.md +++ b/doc/tools/docgram/README.md @@ -194,14 +194,15 @@ to the grammar. ### `.rst` file updates -`doc_grammar` updates `.rst` files when it sees the following 3 lines +`doc_grammar` updates `.rst` files where it sees the following 3 lines ``` -.. insertgram <start> <end> -.. productionlist:: XXX +.. insertprodn <start> <end> + +.. prodn:: ``` -The end of the existing `productionlist` is recognized by a blank line. +The end of the existing `prodn` is recognized by a blank line. ### Other details diff --git a/doc/tools/docgram/common.edit_mlg b/doc/tools/docgram/common.edit_mlg index 06b49a0a18..9c1827f5b7 100644 --- a/doc/tools/docgram/common.edit_mlg +++ b/doc/tools/docgram/common.edit_mlg @@ -65,6 +65,7 @@ DELETE: [ | test_lpar_idnum_coloneq | test_nospace_pipe_closedcurly | test_show_goal +| ensure_fixannot (* SSR *) (* | ssr_null_entry *) @@ -101,18 +102,8 @@ hyp: [ | var ] -empty: [ -| -] - -or_opt: [ -| "|" -| empty -] - ltac_expr_opt: [ -| tactic_expr5 -| empty +| OPT tactic_expr5 ] ltac_expr_opt_list_or: [ @@ -124,7 +115,7 @@ tactic_then_gen: [ | EDIT ADD_OPT tactic_expr5 "|" tactic_then_gen | EDIT ADD_OPT tactic_expr5 ".." tactic_then_last | REPLACE OPT tactic_expr5 ".." tactic_then_last -| WITH ltac_expr_opt ".." or_opt ltac_expr_opt_list_or +| WITH ltac_expr_opt ".." OPT "|" ltac_expr_opt_list_or ] ltac_expr_opt_list_or: [ @@ -144,24 +135,23 @@ fullyqualid: [ | qualid ] - -field: [ | DELETENT ] - -field: [ +field_ident: [ | "." ident ] basequalid: [ | REPLACE ident fields -| WITH qualid field +| WITH ident LIST0 field_ident +| DELETE ident ] +field: [ | DELETENT ] fields: [ | DELETENT ] dirpath: [ | REPLACE ident LIST0 field | WITH ident -| dirpath field +| dirpath field_ident ] binders: [ @@ -172,45 +162,37 @@ lconstr: [ | DELETE l_constr ] -let_type_cstr: [ -| DELETE OPT [ ":" lconstr ] -| rec_type_cstr +type_cstr: [ +| REPLACE ":" lconstr +| WITH OPT ( ":" lconstr ) +| DELETE (* empty *) ] -as_name_opt: [ -| "as" name -| empty +let_type_cstr: [ +| DELETE OPT [ ":" lconstr ] +| type_cstr ] (* rename here because we want to use "return_type" for something else *) RENAME: [ -| return_type as_return_type_opt -] - -as_return_type_opt: [ -| REPLACE OPT [ OPT [ "as" name ] case_type ] -| WITH as_name_opt case_type -| empty +| return_type as_return_type ] case_item: [ | REPLACE operconstr100 OPT [ "as" name ] OPT [ "in" pattern200 ] -| WITH operconstr100 as_name_opt OPT [ "in" pattern200 ] -] - -as_dirpath: [ -| DELETE OPT [ "as" dirpath ] -| "as" dirpath -| empty +| WITH operconstr100 OPT ("as" name) OPT [ "in" pattern200 ] ] binder_constr: [ | MOVETO term_let "let" name binders let_type_cstr ":=" operconstr200 "in" operconstr200 -| MOVETO term_let "let" single_fix "in" operconstr200 -| MOVETO term_let "let" [ "(" LIST0 name SEP "," ")" | "()" ] as_return_type_opt ":=" operconstr200 "in" operconstr200 +| MOVETO term_fix "let" "fix" fix_decl "in" operconstr200 +| MOVETO term_cofix "let" "cofix" cofix_decl "in" operconstr200 +| MOVETO term_let "let" [ "(" LIST0 name SEP "," ")" | "()" ] as_return_type ":=" operconstr200 "in" operconstr200 | MOVETO term_let "let" "'" pattern200 ":=" operconstr200 "in" operconstr200 | MOVETO term_let "let" "'" pattern200 ":=" operconstr200 case_type "in" operconstr200 | MOVETO term_let "let" "'" pattern200 "in" pattern200 ":=" operconstr200 case_type "in" operconstr200 +| MOVETO term_fix "fix" fix_decls +| MOVETO term_cofix "cofix" cofix_decls ] term_let: [ @@ -218,8 +200,8 @@ term_let: [ | WITH "let" name let_type_cstr ":=" operconstr200 "in" operconstr200 | "let" name LIST1 binder let_type_cstr ":=" operconstr200 "in" operconstr200 (* Don't need to document that "( )" is equivalent to "()" *) -| REPLACE "let" [ "(" LIST0 name SEP "," ")" | "()" ] as_return_type_opt ":=" operconstr200 "in" operconstr200 -| WITH "let" [ "(" LIST1 name SEP "," ")" | "()" ] as_return_type_opt ":=" operconstr200 "in" operconstr200 +| REPLACE "let" [ "(" LIST0 name SEP "," ")" | "()" ] as_return_type ":=" operconstr200 "in" operconstr200 +| WITH "let" "(" LIST0 name SEP "," ")" as_return_type ":=" operconstr200 "in" operconstr200 | REPLACE "let" "'" pattern200 ":=" operconstr200 "in" operconstr200 | WITH "let" "'" pattern200 ":=" operconstr200 OPT case_type "in" operconstr200 | DELETE "let" "'" pattern200 ":=" operconstr200 case_type "in" operconstr200 @@ -228,6 +210,8 @@ term_let: [ atomic_constr: [ (* @Zimmi48: "string" used only for notations, but keep to be consistent with patterns *) (* | DELETE string *) +| REPLACE global univ_instance +| WITH global OPT univ_instance | REPLACE "?" "[" ident "]" | WITH "?[" ident "]" | MOVETO term_evar "?[" ident "]" @@ -253,6 +237,8 @@ operconstr10: [ (* fixme: add in as a prodn somewhere *) | MOVETO dangling_pattern_extension_rule "@" pattern_identref LIST1 identref | DELETE dangling_pattern_extension_rule +| REPLACE "@" global univ_instance LIST0 operconstr9 +| WITH "@" global OPT univ_instance LIST0 operconstr9 ] operconstr9: [ @@ -260,64 +246,45 @@ operconstr9: [ | DELETE ".." operconstr0 ".." ] -arg_list: [ -| arg_list appl_arg -| appl_arg -] - -arg_list_opt: [ -| arg_list -| empty -] - operconstr1: [ | REPLACE operconstr0 ".(" global LIST0 appl_arg ")" -| WITH operconstr0 ".(" global arg_list_opt ")" -| MOVETO term_projection operconstr0 ".(" global arg_list_opt ")" +| WITH operconstr0 ".(" global LIST0 appl_arg ")" +| MOVETO term_projection operconstr0 ".(" global LIST0 appl_arg ")" | MOVETO term_projection operconstr0 ".(" "@" global LIST0 ( operconstr9 ) ")" ] operconstr0: [ (* @Zimmi48: This rule is a hack, according to Hugo, and should not be shown in the manual. *) | DELETE "{" binder_constr "}" +| REPLACE "{|" record_declaration bar_cbrace +| WITH "{|" LIST0 field_def bar_cbrace ] -single_fix: [ -| DELETE fix_kw fix_decl -| "fix" fix_decl -| "cofix" fix_decl +fix_decls: [ +| DELETE fix_decl +| REPLACE fix_decl "with" LIST1 fix_decl SEP "with" "for" identref +| WITH fix_decl OPT ( LIST1 ("with" fix_decl) "for" identref ) ] -fix_kw: [ | DELETENT ] +cofix_decls: [ +| DELETE cofix_decl +| REPLACE cofix_decl "with" LIST1 cofix_decl SEP "with" "for" identref +| WITH cofix_decl OPT ( LIST1 ( "with" cofix_decl ) "for" identref ) +] -binders_fixannot: [ -(* -| REPLACE impl_name_head impl_ident_tail binders_fixannot -| WITH impl_name_head impl_ident_tail "}" binders_fixannot -*) -(* Omit this complex detail. See https://github.com/coq/coq/pull/10614#discussion_r344118146 *) -| DELETE impl_name_head impl_ident_tail binders_fixannot +fields_def: [ +| REPLACE field_def ";" fields_def +| WITH LIST1 field_def SEP ";" +| DELETE field_def +] -| DELETE fixannot +binders_fixannot: [ | DELETE binder binders_fixannot +| DELETE fixannot | DELETE (* empty *) - | LIST0 binder OPT fixannot ] -impl_ident_tail: [ -| DELETENT -(* -| REPLACE "}" -| WITH empty -| REPLACE LIST1 name ":" lconstr "}" -| WITH LIST1 name ":" lconstr -| REPLACE LIST1 name "}" -| WITH LIST1 name -| REPLACE ":" lconstr "}" -| WITH ":" lconstr -*) -] of_type_with_opt_coercion: [ | DELETE ":>" ">" @@ -347,18 +314,28 @@ closed_binder: [ | DELETE "(" name ":" lconstr ")" | DELETE "(" name ":=" lconstr ")" + | REPLACE "(" name ":" lconstr ":=" lconstr ")" -| WITH "(" name rec_type_cstr ":=" lconstr ")" +| WITH "(" name type_cstr ":=" lconstr ")" +| DELETE "{" name "}" | DELETE "{" name LIST1 name "}" | REPLACE "{" name LIST1 name ":" lconstr "}" -| WITH "{" LIST1 name rec_type_cstr "}" +| WITH "{" LIST1 name type_cstr "}" | DELETE "{" name ":" lconstr "}" ] +name_colon: [ +| name ":" +] + typeclass_constraint: [ | EDIT ADD_OPT "!" operconstr200 +| REPLACE "{" name "}" ":" [ "!" | ] operconstr200 +| WITH "{" name "}" ":" OPT "!" operconstr200 +| REPLACE name_colon [ "!" | ] operconstr200 +| WITH name_colon OPT "!" operconstr200 ] (* ?? From the grammar, Prim.name seems to be only "_" but ident is also accepted "*) @@ -376,62 +353,54 @@ DELETE: [ | orient_rw ] -pattern1_list: [ -| pattern1_list pattern1 -| pattern1 -] - -pattern1_list_opt: [ -| pattern1_list -| empty -] - pattern10: [ | REPLACE pattern1 LIST1 pattern1 -| WITH LIST1 pattern1 -| REPLACE "@" reference LIST0 pattern1 -| WITH "@" reference pattern1_list_opt +| WITH pattern1 LIST0 pattern1 +| DELETE pattern1 ] pattern0: [ | REPLACE "(" pattern200 ")" | WITH "(" LIST1 pattern200 SEP "|" ")" | DELETE "(" pattern200 "|" LIST1 pattern200 SEP "|" ")" +| REPLACE "{|" record_patterns bar_cbrace +| WITH "{|" LIST0 record_pattern bar_cbrace ] -patterns_comma: [ -| patterns_comma "," pattern100 -| pattern100 -] - -patterns_comma_list_or: [ -| patterns_comma_list_or "|" patterns_comma -| patterns_comma +DELETE: [ +| record_patterns ] eqn: [ | REPLACE LIST1 mult_pattern SEP "|" "=>" lconstr -| WITH patterns_comma_list_or "=>" lconstr +| WITH LIST1 [ LIST1 pattern100 SEP "," ] SEP "|" "=>" lconstr ] -record_patterns: [ -| REPLACE record_pattern ";" record_patterns -| WITH record_patterns ";" record_pattern +universe_increment: [ +| REPLACE "+" natural +| WITH OPT ( "+" natural ) +| DELETE (* empty *) ] -(* todo: binders should be binders_opt *) - +evar_instance: [ +| REPLACE "@{" LIST1 inst SEP ";" "}" +| WITH OPT ( "@{" LIST1 inst SEP ";" "}" ) +| DELETE (* empty *) +] -(* lexer stuff *) -bigint: [ -| DELETE NUMERAL -| num +univ_instance: [ +| DELETE (* empty *) ] -ident: [ -| DELETENT +constr: [ +| REPLACE "@" global univ_instance +| WITH "@" global OPT univ_instance ] +(* todo: binders should be binders_opt *) + + +(* lexer stuff *) IDENT: [ | ident ] @@ -445,11 +414,45 @@ LEFTQMARK: [ | "?" ] +digit: [ +| "0" ".." "9" +] + +num: [ +| LIST1 digit +] + natural: [ | DELETENT ] natural: [ | num (* todo: or should it be "nat"? *) ] +numeral: [ +| LIST1 digit OPT ("." LIST1 digit) OPT [ [ "e" | "E" ] OPT [ "+" | "-" ] LIST1 digit ] +] + +int: [ +| OPT "-" LIST1 digit +] + +bigint: [ +| DELETE NUMERAL +| num +] + +first_letter: [ +| [ "a" ".." "z" | "A" ".." "Z" | "_" | unicode_letter ] +] + +subsequent_letter: [ +| [ first_letter | digit | "'" | unicode_id_part ] +] + +ident: [ +| DELETE IDENT +| first_letter LIST0 subsequent_letter +] + NUMERAL: [ | numeral ] @@ -467,10 +470,6 @@ STRING: [ (* added productions *) -name_colon: [ -| name ":" -] - command_entry: [ | noedit_mode ] @@ -528,12 +527,6 @@ simple_tactic: [ | WITH "eintros" intropatterns ] -intropatterns: [ -| DELETE LIST0 intropattern -| intropatterns intropattern -| empty -] - (* todo: don't use DELETENT for this *) ne_intropatterns: [ | DELETENT ] @@ -594,7 +587,6 @@ SPLICE: [ | reference | bar_cbrace | lconstr -| impl_name_head (* | ast_closure_term @@ -665,6 +657,15 @@ SPLICE: [ | name_colon | closed_binder | binders_fixannot +| as_return_type +| case_type +| fields_def +| universe_increment +| type_cstr +| record_pattern +| evar_instance +| fix_decls +| cofix_decls ] RENAME: [ @@ -703,20 +704,13 @@ RENAME: [ | BULLET bullet | nat_or_var num_or_var | fix_decl fix_body -| instance universe_annot_opt -| rec_type_cstr colon_term_opt -| fix_constr term_fix +| cofix_decl cofix_body | constr term1_extended -| case_type return_type | appl_arg arg -| record_patterns record_patterns_opt -| universe_increment universe_increment_opt | rec_definition fix_definition | corec_definition cofix_definition -| record_field_instance field_def -| record_fields_instance fields_def -| evar_instance evar_bindings_opt | inst evar_binding +| univ_instance univ_annot ] diff --git a/doc/tools/docgram/doc_grammar.ml b/doc/tools/docgram/doc_grammar.ml index 70976e705e..b50c427742 100644 --- a/doc/tools/docgram/doc_grammar.ml +++ b/doc/tools/docgram/doc_grammar.ml @@ -49,7 +49,7 @@ let default_args = { } let start_symbols = ["vernac_toplevel"] -let tokens = [ "bullet"; "ident"; "int"; "num"; "numeral"; "string" ] +let tokens = [ "bullet"; "string"; "unicode_id_part"; "unicode_letter" ] (* translated symbols *) @@ -148,8 +148,10 @@ module DocGram = struct let g_add_prod_after g ins_after nt prod = let prods = try NTMap.find nt !g.map with Not_found -> [] in - (* todo: add check for duplicates *) - g_add_after g ~update:true ins_after nt (prods @ [prod]) + if prods <> [] then + g_update_prods g nt (prods @ [prod]) + else + g_add_after g ~update:true ins_after nt [prod] (* replace the map and order *) let g_reorder g map order = @@ -237,7 +239,17 @@ and prod_to_str ?(plist=false) prod = let rec output_prodn = function - | Sterm s -> let s = if List.mem s ["{"; "{|"; "|"; "}"] then "%" ^ s else s in + | Sterm s -> + let s = match s with + | "|}" -> "%|%}" + | "{|" -> "%{%|" + | "`{" -> "`%{" + | "@{" -> "@%{" + | "{" + | "}" + | "|" -> "%" ^ s + | _ -> s + in sprintf "%s" s | Snterm s -> sprintf "@%s" s | Slist1 sym -> sprintf "{+ %s }" (output_prodn sym) @@ -266,7 +278,14 @@ and output_sep sep = | Sterm s -> sprintf "%s" s (* avoid escaping separator *) | _ -> output_prodn sep -and prod_to_prodn prod = String.concat " " (List.map output_prodn prod) +and prod_to_prodn_r prod = + match prod with + | Sterm s :: Snterm "ident" :: tl when List.mem s ["?"; "."] -> + (sprintf "%s@ident" s) :: (prod_to_prodn_r tl) + | p :: tl -> (output_prodn p) :: (prod_to_prodn_r tl) + | [] -> [] + +and prod_to_prodn prod = String.concat " " (prod_to_prodn_r prod) let pr_prods nt prods = (* duplicative *) Printf.printf "%s: [\n" nt; @@ -304,11 +323,11 @@ let print_in_order out g fmt nt_order hide = fprintf out "%s%s\n" pfx str) prods; | `PRODN -> - fprintf out "\n%s:\n" nt; - List.iter (fun prod -> + fprintf out "\n%s:\n%s " nt nt; + List.iteri (fun i prod -> let str = prod_to_prodn prod in - let pfx = if str = "" then "" else " " in - fprintf out "%s%s\n" pfx str) + let op = if i = 0 then "::=" else "+=" in + fprintf out "%s %s\n" op str) prods; with Not_found -> error "Missing nt '%s' in print_in_order\n" nt) nt_order @@ -458,8 +477,10 @@ let ematch prod edit = -> ematchr [psym] [sym] && ematchr [psep] [sep] | (Sparen psyml, Sparen syml) -> ematchr psyml syml - | (Sprod psymll, Sprod symll) - -> List.fold_left (&&) true (List.map2 ematchr psymll symll) + | (Sprod psymll, Sprod symll) -> + if List.compare_lengths psymll symll != 0 then false + else + List.fold_left (&&) true (List.map2 ematchr psymll symll) | _, _ -> phd = hd in m && ematchr ptl tl @@ -691,17 +712,22 @@ let rec edit_prod g top edit_map prod = | _ -> [Snterm binding] with Not_found -> [sym0] in + let maybe_wrap syms = + match syms with + | s :: [] -> List.hd syms + | s -> Sparen (List.rev syms) + in let rec edit_symbol sym0 = match sym0 with | Sterm s -> [sym0] | Snterm s -> edit_nt edit_map sym0 s - | Slist1 sym -> [Slist1 (List.hd (edit_symbol sym))] + | Slist1 sym -> [Slist1 (maybe_wrap (edit_symbol sym))] (* you'll get a run-time failure deleting a SEP symbol *) - | Slist1sep (sym, sep) -> [Slist1sep (List.hd (edit_symbol sym), (List.hd (edit_symbol sep)))] - | Slist0 sym -> [Slist0 (List.hd (edit_symbol sym))] - | Slist0sep (sym, sep) -> [Slist0sep (List.hd (edit_symbol sym), (List.hd (edit_symbol sep)))] - | Sopt sym -> [Sopt (List.hd (edit_symbol sym))] + | Slist1sep (sym, sep) -> [Slist1sep (maybe_wrap (edit_symbol sym), (List.hd (edit_symbol sep)))] + | Slist0 sym -> [Slist0 (maybe_wrap (edit_symbol sym))] + | Slist0sep (sym, sep) -> [Slist0sep (maybe_wrap (edit_symbol sym), (List.hd (edit_symbol sep)))] + | Sopt sym -> [Sopt (maybe_wrap (edit_symbol sym))] | Sparen slist -> [Sparen (List.hd (edit_prod g false edit_map slist))] | Sprod slistlist -> let (_, prods) = edit_rule g edit_map "" slistlist in [Sprod prods] @@ -1079,7 +1105,9 @@ let apply_edit_file g edits = g_add_prod_after g (Some nt) nt2 oprod; let prods' = (try let posn = find_first oprod prods nt in - let prods = insert_after posn [[Snterm nt2]] prods in (* insert new prod *) + let prods = if List.mem [Snterm nt2] prods then prods + else insert_after posn [[Snterm nt2]] prods (* insert new prod *) + in remove_prod oprod prods nt (* remove orig prod *) with Not_found -> prods) in @@ -1091,6 +1119,7 @@ let apply_edit_file g edits = aux tl (edit_single_prod g oprod prods nt) add_nt | (Snterm "REPLACE" :: oprod) :: (Snterm "WITH" :: rprod) :: tl -> report_undef_nts g rprod ""; + (* todo: check result not already present *) let prods' = (try let posn = find_first oprod prods nt in let prods = insert_after posn [rprod] prods in (* insert new prod *) @@ -1580,7 +1609,7 @@ let process_rst g file args seen tac_prods cmd_prods = line in (* todo: maybe pass end_index? *) - let output_insertgram start_index end_ indent is_coq_group = + let output_insertprodn start_index end_ indent = let rec copy_prods list = match list with | [] -> () @@ -1590,21 +1619,21 @@ let process_rst g file args seen tac_prods cmd_prods = warn "%s line %d: '%s' already included at %s line %d\n" file !linenum nt prev_file prev_linenum; with Not_found -> - if is_coq_group then - seen := { !seen with nts = (NTMap.add nt (file, !linenum) !seen.nts)} ); + seen := { !seen with nts = (NTMap.add nt (file, !linenum) !seen.nts)} ); let prods = NTMap.find nt !g.map in List.iteri (fun i prod -> - let rhs = String.trim (sprintf ": %s" (prod_to_str ~plist:true prod)) in - fprintf new_rst "%s %s %s\n" indent (if i = 0 then nt else String.make (String.length nt) ' ') rhs) + let rhs = String.trim (prod_to_prodn prod) in + let sep = if i = 0 then " ::=" else "|" in + fprintf new_rst "%s %s%s %s\n" indent (if i = 0 then nt else "") sep rhs) prods; if nt <> end_ then copy_prods tl in copy_prods (nthcdr start_index !g.order) in - let process_insertgram line rhs = + let process_insertprodn line rhs = if not (Str.string_match ig_args_regex rhs 0) then - error "%s line %d: bad arguments '%s' for 'insertgram'\n" file !linenum rhs + error "%s line %d: bad arguments '%s' for 'insertprodn'\n" file !linenum rhs else begin let start = Str.matched_group 1 rhs in let end_ = Str.matched_group 2 rhs in @@ -1624,19 +1653,18 @@ let process_rst g file args seen tac_prods cmd_prods = try let line2 = getline() in if not (Str.string_match blank_regex line2 0) then - error "%s line %d: expecting a blank line after 'insertgram'\n" file !linenum + error "%s line %d: expecting a blank line after 'insertprodn'\n" file !linenum else begin let line3 = getline() in - if not (Str.string_match dir_regex line3 0) || (Str.matched_group 2 line3) <> "productionlist::" then - error "%s line %d: expecting 'productionlist' after 'insertgram'\n" file !linenum + if not (Str.string_match dir_regex line3 0) || (Str.matched_group 2 line3) <> "prodn::" then + error "%s line %d: expecting 'prodn' after 'insertprodn'\n" file !linenum else begin let indent = Str.matched_group 1 line3 in - let is_coq_group = ("coq" = String.trim (Str.matched_group 3 line3)) in let rec skip_to_end () = let endline = getline() in if Str.string_match end_prodlist_regex endline 0 then begin fprintf new_rst "%s\n\n%s\n" line line3; - output_insertgram start_index end_ indent is_coq_group; + output_insertprodn start_index end_ indent; fprintf new_rst "%s\n" endline end else skip_to_end () @@ -1657,9 +1685,9 @@ let process_rst g file args seen tac_prods cmd_prods = let dir = Str.matched_group 2 line in let rhs = String.trim (Str.matched_group 3 line) in match dir with - | "productionlist::" -> + | "prodn::" -> if rhs = "coq" then - warn "%s line %d: Missing 'insertgram' before 'productionlist:: coq'\n" file !linenum; + warn "%s line %d: Missing 'insertprodn' before 'prodn:: coq'\n" file !linenum; fprintf new_rst "%s\n" line; | "tacn::" when args.check_tacs -> if not (StringSet.mem rhs tac_prods) then @@ -1675,8 +1703,8 @@ let process_rst g file args seen tac_prods cmd_prods = warn "%s line %d: Repeated command: '%s'\n" file !linenum rhs; seen := { !seen with cmds = (NTMap.add rhs (file, !linenum) !seen.cmds)}; fprintf new_rst "%s\n" line - | "insertgram" -> - process_insertgram line rhs + | "insertprodn" -> + process_insertprodn line rhs | _ -> fprintf new_rst "%s\n" line end else fprintf new_rst "%s\n" line; diff --git a/doc/tools/docgram/fullGrammar b/doc/tools/docgram/fullGrammar index ebaeb392a5..e12589bb89 100644 --- a/doc/tools/docgram/fullGrammar +++ b/doc/tools/docgram/fullGrammar @@ -64,7 +64,7 @@ lconstr: [ constr: [ | operconstr8 -| "@" global instance +| "@" global univ_instance ] operconstr200: [ @@ -90,7 +90,7 @@ operconstr90: [ operconstr10: [ | operconstr9 LIST1 appl_arg -| "@" global instance LIST0 operconstr9 +| "@" global univ_instance LIST0 operconstr9 | "@" pattern_identref LIST1 identref | operconstr9 ] @@ -123,16 +123,16 @@ operconstr0: [ ] record_declaration: [ -| record_fields_instance +| fields_def ] -record_fields_instance: [ -| record_field_instance ";" record_fields_instance -| record_field_instance +fields_def: [ +| field_def ";" fields_def +| field_def | ] -record_field_instance: [ +field_def: [ | global binders ":=" lconstr ] @@ -140,13 +140,15 @@ binder_constr: [ | "forall" open_binders "," operconstr200 | "fun" open_binders "=>" operconstr200 | "let" name binders let_type_cstr ":=" operconstr200 "in" operconstr200 -| "let" single_fix "in" operconstr200 +| "let" "fix" fix_decl "in" operconstr200 +| "let" "cofix" cofix_decl "in" operconstr200 | "let" [ "(" LIST0 name SEP "," ")" | "()" ] return_type ":=" operconstr200 "in" operconstr200 | "let" "'" pattern200 ":=" operconstr200 "in" operconstr200 | "let" "'" pattern200 ":=" operconstr200 case_type "in" operconstr200 | "let" "'" pattern200 "in" pattern200 ":=" operconstr200 case_type "in" operconstr200 | "if" operconstr200 return_type "then" operconstr200 "else" operconstr200 -| fix_constr +| "fix" fix_decls +| "cofix" cofix_decls ] appl_arg: [ @@ -155,7 +157,7 @@ appl_arg: [ ] atomic_constr: [ -| global instance +| global univ_instance | sort | NUMERAL | string @@ -174,7 +176,7 @@ evar_instance: [ | ] -instance: [ +univ_instance: [ | "@{" LIST0 universe_level "}" | ] @@ -187,22 +189,22 @@ universe_level: [ | global ] -fix_constr: [ -| single_fix -| single_fix "with" LIST1 fix_decl SEP "with" "for" identref +fix_decls: [ +| fix_decl +| fix_decl "with" LIST1 fix_decl SEP "with" "for" identref ] -single_fix: [ -| fix_kw fix_decl +cofix_decls: [ +| cofix_decl +| cofix_decl "with" LIST1 cofix_decl SEP "with" "for" identref ] -fix_kw: [ -| "fix" -| "cofix" +fix_decl: [ +| identref binders_fixannot type_cstr ":=" operconstr200 ] -fix_decl: [ -| identref binders_fixannot let_type_cstr ":=" operconstr200 +cofix_decl: [ +| identref binders type_cstr ":=" operconstr200 ] match_constr: [ @@ -282,26 +284,14 @@ pattern0: [ | string ] -impl_ident_tail: [ -| "}" -| LIST1 name ":" lconstr "}" -| LIST1 name "}" -| ":" lconstr "}" -] - fixannot: [ | "{" "struct" identref "}" | "{" "wf" constr identref "}" | "{" "measure" constr OPT identref OPT constr "}" ] -impl_name_head: [ -| impl_ident_head -] - binders_fixannot: [ -| impl_name_head impl_ident_tail binders_fixannot -| fixannot +| ensure_fixannot fixannot | binder binders_fixannot | ] @@ -344,6 +334,11 @@ typeclass_constraint: [ | operconstr200 ] +type_cstr: [ +| ":" lconstr +| +] + let_type_cstr: [ | OPT [ ":" lconstr ] ] @@ -514,9 +509,6 @@ command: [ | "Add" "LoadPath" ne_string as_dirpath | "Add" "Rec" "LoadPath" ne_string as_dirpath | "Remove" "LoadPath" ne_string -| "AddPath" ne_string "as" as_dirpath -| "AddRecPath" ne_string "as" as_dirpath -| "DelPath" ne_string | "Type" lconstr | "Print" printable | "Print" smart_global OPT univ_name_list @@ -963,16 +955,11 @@ opt_coercion: [ ] rec_definition: [ -| ident_decl binders_fixannot rec_type_cstr OPT [ ":=" lconstr ] decl_notation +| ident_decl binders_fixannot type_cstr OPT [ ":=" lconstr ] decl_notation ] corec_definition: [ -| ident_decl binders rec_type_cstr OPT [ ":=" lconstr ] decl_notation -] - -rec_type_cstr: [ -| ":" lconstr -| +| ident_decl binders type_cstr OPT [ ":=" lconstr ] decl_notation ] scheme: [ @@ -994,7 +981,6 @@ record_field: [ record_fields: [ | record_field ";" record_fields -| record_field ";" | record_field | ] @@ -1395,7 +1381,6 @@ syntax: [ only_parsing: [ | "(" "only" "parsing" ")" -| "(" "compat" STRING ")" | ] @@ -1413,7 +1398,6 @@ syntax_modifier: [ | "no" "associativity" | "only" "printing" | "only" "parsing" -| "compat" STRING | "format" STRING OPT STRING | IDENT; "," LIST1 IDENT SEP "," "at" level | IDENT; "at" level diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index 545ccde03a..63e0ca129c 100644 --- a/doc/tools/docgram/orderedGrammar +++ b/doc/tools/docgram/orderedGrammar @@ -8,30 +8,15 @@ vernac_toplevel: [ | "Quit" "." | "BackTo" num "." | "Show" "Goal" num "at" num "." -| "Show" "Proof" "Diffs" removed_opt "." +| "Show" "Proof" "Diffs" OPT "removed" "." | vernac_control ] -removed_opt: [ -| "removed" -| empty -] - tactic_mode: [ -| toplevel_selector_opt query_command -| toplevel_selector_opt "{" -| toplevel_selector_opt ltac_info_opt ltac_expr ltac_use_default -| "par" ":" ltac_info_opt ltac_expr ltac_use_default -] - -toplevel_selector_opt: [ -| toplevel_selector -| empty -] - -ltac_info_opt: [ -| "Info" num -| empty +| OPT toplevel_selector query_command +| OPT toplevel_selector "{" +| OPT toplevel_selector OPT ( "Info" num ) ltac_expr ltac_use_default +| "par" ":" OPT ( "Info" num ) ltac_expr ltac_use_default ] ltac_use_default: [ @@ -44,15 +29,16 @@ vernac_control: [ | "Redirect" string vernac_control | "Timeout" num vernac_control | "Fail" vernac_control -| quoted_attributes_list_opt vernac +| LIST0 ( "#[" LIST0 attribute SEP "," "]" ) vernac ] term: [ | "forall" open_binders "," term | "fun" open_binders "=>" term | term_let -| "if" term as_return_type_opt "then" term "else" term +| "if" term OPT [ OPT [ "as" name ] "return" term100 ] "then" term "else" term | term_fix +| term_cofix | term100 ] @@ -62,43 +48,24 @@ term100: [ ] term10: [ -| term1 args -| "@" qualid universe_annot_opt term1_list_opt +| term1 LIST1 arg +| "@" qualid OPT univ_annot LIST0 term1 | term1 ] -args: [ -| args arg -| arg -] - arg: [ | "(" ident ":=" term ")" | term1 ] -term1_list_opt: [ -| term1_list_opt term1 -| empty -] - -empty: [ -| -] - term1: [ | term_projection | term0 "%" ident | term0 ] -args_opt: [ -| args -| empty -] - term0: [ -| qualid universe_annot_opt +| qualid OPT univ_annot | sort | numeral | string @@ -106,46 +73,25 @@ term0: [ | term_evar | term_match | "(" term ")" -| "{|" fields_def "|}" +| "{|" LIST0 field_def "|}" | "`{" term "}" | "`(" term ")" | "ltac" ":" "(" ltac_expr ")" ] -fields_def: [ -| field_def ";" fields_def -| field_def -| empty -] - field_def: [ -| qualid binders_opt ":=" term -] - -binders_opt: [ -| binders -| empty +| qualid LIST0 binder ":=" term ] term_projection: [ -| term0 ".(" qualid args_opt ")" -| term0 ".(" "@" qualid term1_list_opt ")" +| term0 ".(" qualid LIST0 arg ")" +| term0 ".(" "@" qualid LIST0 ( term1 ) ")" ] term_evar: [ | "?[" ident "]" | "?[" "?" ident "]" -| "?" ident evar_bindings_opt -] - -evar_bindings_opt: [ -| "@{" evar_bindings_semi "}" -| empty -] - -evar_bindings_semi: [ -| evar_bindings_semi ";" evar_binding -| evar_binding +| "?" ident OPT ( "@{" LIST1 evar_binding SEP ";" "}" ) ] evar_binding: [ @@ -153,42 +99,26 @@ evar_binding: [ ] dangling_pattern_extension_rule: [ -| "@" "?" ident ident_list -] - -ident_list: [ -| ident_list ident -| ident +| "@" "?" ident LIST1 ident ] record_fields: [ | record_field ";" record_fields -| record_field ";" | record_field -| empty +| ] record_field: [ -| quoted_attributes_list_opt record_binder num_opt2 decl_notation +| LIST0 ( "#[" LIST0 attribute SEP "," "]" ) record_binder OPT [ "|" num ] decl_notation ] decl_notation: [ -| "where" one_decl_notation_list -| empty -] - -one_decl_notation_list: [ -| one_decl_notation_list "and" one_decl_notation -| one_decl_notation +| "where" LIST1 one_decl_notation SEP "and" +| ] one_decl_notation: [ -| string ":=" term1_extended ident_opt3 -] - -ident_opt3: [ -| ":" ident -| empty +| string ":=" term1_extended OPT [ ":" ident ] ] record_binder: [ @@ -197,9 +127,9 @@ record_binder: [ ] record_binder_body: [ -| binders_opt of_type_with_opt_coercion term -| binders_opt of_type_with_opt_coercion term ":=" term -| binders_opt ":=" term +| LIST0 binder of_type_with_opt_coercion term +| LIST0 binder of_type_with_opt_coercion term ":=" term +| LIST0 binder ":=" term ] of_type_with_opt_coercion: [ @@ -208,43 +138,50 @@ of_type_with_opt_coercion: [ | ":" ] -num_opt2: [ -| "|" num -| empty +attribute: [ +| ident attribute_value ] -quoted_attributes_list_opt: [ -| quoted_attributes_list_opt "#[" attribute_list_comma_opt "]" -| empty +attribute_value: [ +| "=" string +| "(" LIST0 attribute SEP "," ")" +| ] -attribute_list_comma_opt: [ -| attribute_list_comma -| empty +qualid: [ +| ident LIST0 field_ident ] -attribute_list_comma: [ -| attribute_list_comma "," attribute -| attribute +field_ident: [ +| "." ident ] -attribute: [ -| ident attribute_value +numeral: [ +| LIST1 digit OPT ( "." LIST1 digit ) OPT [ [ "e" | "E" ] OPT [ "+" | "-" ] LIST1 digit ] ] -attribute_value: [ -| "=" string -| "(" attribute_list_comma_opt ")" -| empty +int: [ +| OPT "-" LIST1 digit ] -qualid: [ -| qualid field -| ident +num: [ +| LIST1 digit ] -field: [ -| "." ident +digit: [ +| "0" ".." "9" +] + +ident: [ +| first_letter LIST0 subsequent_letter +] + +first_letter: [ +| [ "a" ".." "z" | "A" ".." "Z" | "_" | unicode_letter ] +] + +subsequent_letter: [ +| [ first_letter | digit | "'" | unicode_id_part ] ] sort: [ @@ -257,17 +194,12 @@ sort: [ ] universe: [ -| "max" "(" universe_exprs_comma ")" -| universe_expr -] - -universe_exprs_comma: [ -| universe_exprs_comma "," universe_expr +| "max" "(" LIST1 universe_expr SEP "," ")" | universe_expr ] universe_expr: [ -| universe_name universe_increment_opt +| universe_name OPT ( "+" num ) ] universe_name: [ @@ -276,21 +208,6 @@ universe_name: [ | "Prop" ] -universe_increment_opt: [ -| "+" num -| empty -] - -universe_annot_opt: [ -| "@{" universe_levels_opt "}" -| empty -] - -universe_levels_opt: [ -| universe_levels_opt universe_level -| empty -] - universe_level: [ | "Set" | "Prop" @@ -299,83 +216,50 @@ universe_level: [ | qualid ] -term_fix: [ -| single_fix -| single_fix "with" fix_bodies "for" ident -] - -single_fix: [ -| "fix" fix_body -| "cofix" fix_body +univ_annot: [ +| "@{" LIST0 universe_level "}" ] -fix_bodies: [ -| fix_bodies "with" fix_body -| fix_body +term_fix: [ +| "let" "fix" fix_body "in" term +| "fix" fix_body OPT ( LIST1 ( "with" fix_body ) "for" ident ) ] fix_body: [ -| ident binders_opt fixannot_opt colon_term_opt ":=" term -] - -fixannot_opt: [ -| fixannot -| empty +| ident LIST0 binder OPT fixannot OPT ( ":" term ) ":=" term ] fixannot: [ | "{" "struct" ident "}" | "{" "wf" term1_extended ident "}" -| "{" "measure" term1_extended ident_opt term1_extended_opt "}" +| "{" "measure" term1_extended OPT ident OPT term1_extended "}" ] term1_extended: [ | term1 -| "@" qualid universe_annot_opt +| "@" qualid OPT univ_annot ] -ident_opt: [ -| ident -| empty +term_cofix: [ +| "let" "cofix" cofix_body "in" term +| "cofix" cofix_body OPT ( LIST1 ( "with" cofix_body ) "for" ident ) ] -term1_extended_opt: [ -| term1_extended -| empty +cofix_body: [ +| ident LIST0 binder OPT ( ":" term ) ":=" term ] term_let: [ -| "let" name colon_term_opt ":=" term "in" term -| "let" name binders colon_term_opt ":=" term "in" term -| "let" single_fix "in" term -| "let" names_tuple as_return_type_opt ":=" term "in" term -| "let" "'" pattern ":=" term return_type_opt "in" term -| "let" "'" pattern "in" pattern ":=" term return_type "in" term -] - -colon_term_opt: [ -| ":" term -| empty -] - -names_tuple: [ -| "(" names_comma ")" -| "()" -] - -names_comma: [ -| names_comma "," name -| name +| "let" name OPT ( ":" term ) ":=" term "in" term +| "let" name LIST1 binder OPT ( ":" term ) ":=" term "in" term +| "let" "(" LIST0 name SEP "," ")" OPT [ OPT [ "as" name ] "return" term100 ] ":=" term "in" term +| "let" "'" pattern ":=" term OPT ( "return" term100 ) "in" term +| "let" "'" pattern "in" pattern ":=" term "return" term100 "in" term ] open_binders: [ -| names ":" term -| binders -] - -names: [ -| names name -| name +| LIST1 name ":" term +| LIST1 binder ] name: [ @@ -383,37 +267,21 @@ name: [ | ident ] -binders: [ -| binders binder -| binder -] - binder: [ | name -| "(" names ":" term ")" -| "(" name colon_term_opt ":=" term ")" -| "{" name "}" -| "{" names colon_term_opt "}" -| "`(" typeclass_constraints_comma ")" -| "`{" typeclass_constraints_comma "}" +| "(" LIST1 name ":" term ")" +| "(" name OPT ( ":" term ) ":=" term ")" +| "{" LIST1 name OPT ( ":" term ) "}" +| "`(" LIST1 typeclass_constraint SEP "," ")" +| "`{" LIST1 typeclass_constraint SEP "," "}" | "'" pattern0 | "(" name ":" term "|" term ")" ] -typeclass_constraints_comma: [ -| typeclass_constraints_comma "," typeclass_constraint -| typeclass_constraint -] - typeclass_constraint: [ -| exclam_opt term -| "{" name "}" ":" exclam_opt term -| name ":" exclam_opt term -] - -exclam_opt: [ -| "!" -| empty +| OPT "!" term +| "{" name "}" ":" OPT "!" term +| name ":" OPT "!" term ] term_cast: [ @@ -424,69 +292,15 @@ term_cast: [ ] term_match: [ -| "match" case_items_comma return_type_opt "with" or_opt eqns_or_opt "end" -] - -case_items_comma: [ -| case_items_comma "," case_item -| case_item -] - -return_type_opt: [ -| return_type -| empty -] - -as_return_type_opt: [ -| as_name_opt return_type -| empty -] - -return_type: [ -| "return" term100 +| "match" LIST1 case_item SEP "," OPT ( "return" term100 ) "with" OPT "|" LIST0 eqn SEP "|" "end" ] case_item: [ -| term100 as_name_opt in_opt -] - -as_name_opt: [ -| "as" name -| empty -] - -in_opt: [ -| "in" pattern -| empty -] - -or_opt: [ -| "|" -| empty -] - -eqns_or_opt: [ -| eqns_or -| empty -] - -eqns_or: [ -| eqns_or "|" eqn -| eqn +| term100 OPT ( "as" name ) OPT [ "in" pattern ] ] eqn: [ -| patterns_comma_list_or "=>" term -] - -patterns_comma_list_or: [ -| patterns_comma_list_or "|" patterns_comma -| patterns_comma -] - -patterns_comma: [ -| patterns_comma "," pattern -| pattern +| LIST1 [ LIST1 pattern SEP "," ] SEP "|" "=>" term ] pattern: [ @@ -496,19 +310,8 @@ pattern: [ pattern10: [ | pattern1 "as" name -| pattern1_list -| "@" qualid pattern1_list_opt -| pattern1 -] - -pattern1_list: [ -| pattern1_list pattern1 -| pattern1 -] - -pattern1_list_opt: [ -| pattern1_list -| empty +| pattern1 LIST0 pattern1 +| "@" qualid LIST0 pattern1 ] pattern1: [ @@ -518,28 +321,13 @@ pattern1: [ pattern0: [ | qualid -| "{|" record_patterns_opt "|}" +| "{|" LIST0 ( qualid ":=" pattern ) "|}" | "_" -| "(" patterns_or ")" +| "(" LIST1 pattern SEP "|" ")" | numeral | string ] -patterns_or: [ -| patterns_or "|" pattern -| pattern -] - -record_patterns_opt: [ -| record_patterns_opt ";" record_pattern -| record_pattern -| empty -] - -record_pattern: [ -| qualid ":=" pattern -] - vernac: [ | "Local" vernac_poly | "Global" vernac_poly @@ -571,78 +359,28 @@ subprf: [ ] gallina: [ -| thm_token ident_decl binders_opt ":" term with_list_opt +| thm_token ident_decl LIST0 binder ":" term LIST0 [ "with" ident_decl LIST0 binder ":" term ] | assumption_token inline assum_list | assumptions_token inline assum_list | def_token ident_decl def_body | "Let" ident def_body -| cumulativity_token_opt private_token finite_token inductive_definition_list -| "Fixpoint" fix_definition_list -| "Let" "Fixpoint" fix_definition_list -| "CoFixpoint" cofix_definition_list -| "Let" "CoFixpoint" cofix_definition_list -| "Scheme" scheme_list -| "Combined" "Scheme" ident "from" ident_list_comma +| OPT cumulativity_token private_token finite_token LIST1 inductive_definition SEP "with" +| "Fixpoint" LIST1 fix_definition SEP "with" +| "Let" "Fixpoint" LIST1 fix_definition SEP "with" +| "CoFixpoint" LIST1 cofix_definition SEP "with" +| "Let" "CoFixpoint" LIST1 cofix_definition SEP "with" +| "Scheme" LIST1 scheme SEP "with" +| "Combined" "Scheme" ident "from" LIST1 ident SEP "," | "Register" qualid "as" qualid | "Register" "Inline" qualid -| "Primitive" ident term_opt ":=" register_token -| "Universe" ident_list -| "Universes" ident_list -| "Constraint" univ_constraint_list_comma -] - -term_opt: [ -| ":" term -| empty -] - -univ_constraint_list_comma: [ -| univ_constraint_list_comma "," univ_constraint -| univ_constraint -] - -with_list_opt: [ -| with_list_opt "with" ident_decl binders_opt ":" term -| empty -] - -cumulativity_token_opt: [ -| cumulativity_token -| empty -] - -inductive_definition_list: [ -| inductive_definition_list "with" inductive_definition -| inductive_definition -] - -fix_definition_list: [ -| fix_definition_list "with" fix_definition -| fix_definition +| "Primitive" ident OPT [ ":" term ] ":=" register_token +| "Universe" LIST1 ident +| "Universes" LIST1 ident +| "Constraint" LIST1 univ_constraint SEP "," ] fix_definition: [ -| ident_decl binders_opt fixannot_opt colon_term_opt term_opt2 decl_notation -] - -term_opt2: [ -| ":=" term -| empty -] - -cofix_definition_list: [ -| cofix_definition_list "with" cofix_definition -| cofix_definition -] - -scheme_list: [ -| scheme_list "with" scheme -| scheme -] - -ident_list_comma: [ -| ident_list_comma "," ident -| ident +| ident_decl LIST0 binder OPT fixannot OPT ( ":" term ) OPT [ ":=" term ] decl_notation ] register_token: [ @@ -731,21 +469,15 @@ assumptions_token: [ inline: [ | "Inline" "(" num ")" | "Inline" -| empty +| ] univ_constraint: [ -| universe_name lt_alt universe_name -] - -lt_alt: [ -| "<" -| "=" -| "<=" +| universe_name [ "<" | "=" | "<=" ] universe_name ] ident_decl: [ -| ident univ_decl_opt +| ident OPT ( "@{" LIST0 ident [ "+" | ] [ "|" LIST0 univ_constraint SEP "," [ "+" | ] "}" | [ "}" | "|}" ] ] ) ] finite_token: [ @@ -764,46 +496,41 @@ cumulativity_token: [ private_token: [ | "Private" -| empty +| ] def_body: [ -| binders_opt ":=" reduce term -| binders_opt ":" term ":=" reduce term -| binders_opt ":" term +| LIST0 binder ":=" reduce term +| LIST0 binder ":" term ":=" reduce term +| LIST0 binder ":" term ] reduce: [ | "Eval" red_expr "in" -| empty +| ] red_expr: [ | "red" | "hnf" -| "simpl" delta_flag ref_or_pattern_occ_opt +| "simpl" delta_flag OPT ref_or_pattern_occ | "cbv" strategy_flag | "cbn" strategy_flag | "lazy" strategy_flag | "compute" delta_flag -| "vm_compute" ref_or_pattern_occ_opt -| "native_compute" ref_or_pattern_occ_opt -| "unfold" unfold_occ_list_comma -| "fold" term1_extended_list -| "pattern" pattern_occ_list_comma +| "vm_compute" OPT ref_or_pattern_occ +| "native_compute" OPT ref_or_pattern_occ +| "unfold" LIST1 unfold_occ SEP "," +| "fold" LIST1 term1_extended +| "pattern" LIST1 pattern_occ SEP "," | ident ] strategy_flag: [ -| red_flags_list +| LIST1 red_flags | delta_flag ] -red_flags_list: [ -| red_flags_list red_flags -| red_flags -] - red_flags: [ | "beta" | "iota" @@ -815,14 +542,9 @@ red_flags: [ ] delta_flag: [ -| "-" "[" smart_global_list "]" -| "[" smart_global_list "]" -| empty -] - -ref_or_pattern_occ_opt: [ -| ref_or_pattern_occ -| empty +| "-" "[" LIST1 smart_global "]" +| "[" LIST1 smart_global "]" +| ] ref_or_pattern_occ: [ @@ -830,83 +552,48 @@ ref_or_pattern_occ: [ | term1_extended occs ] -unfold_occ_list_comma: [ -| unfold_occ_list_comma "," unfold_occ -| unfold_occ -] - unfold_occ: [ | smart_global occs ] -pattern_occ_list_comma: [ -| pattern_occ_list_comma "," pattern_occ -| pattern_occ -] - opt_constructors_or_fields: [ | ":=" constructor_list_or_record_decl -| empty +| ] inductive_definition: [ -| opt_coercion ident_decl binders_opt term_opt opt_constructors_or_fields decl_notation +| opt_coercion ident_decl LIST0 binder OPT [ ":" term ] opt_constructors_or_fields decl_notation ] opt_coercion: [ | ">" -| empty +| ] constructor_list_or_record_decl: [ -| "|" constructor_list_or -| ident constructor_type "|" constructor_list_or_opt +| "|" LIST1 constructor SEP "|" +| ident constructor_type "|" LIST0 constructor SEP "|" | ident constructor_type | ident "{" record_fields "}" | "{" record_fields "}" -| empty -] - -constructor_list_or: [ -| constructor_list_or "|" constructor -| constructor -] - -constructor_list_or_opt: [ -| constructor_list_or -| empty +| ] assum_list: [ -| assum_coe_list +| LIST1 assum_coe | simple_assum_coe ] -assum_coe_list: [ -| assum_coe_list assum_coe -| assum_coe -] - assum_coe: [ | "(" simple_assum_coe ")" ] simple_assum_coe: [ -| ident_decl_list of_type_with_opt_coercion term -] - -ident_decl_list: [ -| ident_decl_list ident_decl -| ident_decl +| LIST1 ident_decl of_type_with_opt_coercion term ] constructor_type: [ -| binders_opt of_type_with_opt_coercion_opt -] - -of_type_with_opt_coercion_opt: [ -| of_type_with_opt_coercion term -| empty +| LIST0 binder [ of_type_with_opt_coercion term | ] ] constructor: [ @@ -914,7 +601,7 @@ constructor: [ ] cofix_definition: [ -| ident_decl binders_opt colon_term_opt term_opt2 decl_notation +| ident_decl LIST0 binder OPT ( ":" term ) OPT [ ":=" term ] decl_notation ] scheme: [ @@ -943,67 +630,47 @@ smart_global: [ ] by_notation: [ -| string ident_opt2 -] - -ident_opt2: [ -| "%" ident -| empty +| string OPT [ "%" ident ] ] gallina_ext: [ -| "Module" export_token ident module_binder_list_opt of_module_type is_module_expr -| "Module" "Type" ident module_binder_list_opt module_type_inl_list_opt is_module_type -| "Declare" "Module" export_token ident module_binder_list_opt ":" module_type_inl +| "Module" export_token ident LIST0 ( "(" export_token LIST1 ident ":" module_type_inl ")" ) of_module_type is_module_expr +| "Module" "Type" ident LIST0 ( "(" export_token LIST1 ident ":" module_type_inl ")" ) LIST0 ( "<:" module_type_inl ) is_module_type +| "Declare" "Module" export_token ident LIST0 ( "(" export_token LIST1 ident ":" module_type_inl ")" ) ":" module_type_inl | "Section" ident | "Chapter" ident | "End" ident | "Collection" ident ":=" section_subset_expr -| "Require" export_token qualid_list -| "From" qualid "Require" export_token qualid_list -| "Import" qualid_list -| "Export" qualid_list -| "Include" module_type_inl module_expr_inl_list_opt -| "Include" "Type" module_type_inl module_type_inl_list_opt -| "Transparent" smart_global_list -| "Opaque" smart_global_list -| "Strategy" strategy_level_list -| "Canonical" Structure_opt qualid univ_decl_opt2 -| "Canonical" Structure_opt by_notation -| "Coercion" qualid univ_decl_opt def_body +| "Require" export_token LIST1 qualid +| "From" qualid "Require" export_token LIST1 qualid +| "Import" LIST1 qualid +| "Export" LIST1 qualid +| "Include" module_type_inl LIST0 ( "<+" module_expr_inl ) +| "Include" "Type" module_type_inl LIST0 ( "<+" module_type_inl ) +| "Transparent" LIST1 smart_global +| "Opaque" LIST1 smart_global +| "Strategy" LIST1 [ strategy_level "[" LIST1 smart_global "]" ] +| "Canonical" OPT "Structure" qualid OPT [ OPT ( "@{" LIST0 ident [ "+" | ] [ "|" LIST0 univ_constraint SEP "," [ "+" | ] "}" | [ "}" | "|}" ] ] ) def_body ] +| "Canonical" OPT "Structure" by_notation +| "Coercion" qualid OPT ( "@{" LIST0 ident [ "+" | ] [ "|" LIST0 univ_constraint SEP "," [ "+" | ] "}" | [ "}" | "|}" ] ] ) def_body | "Identity" "Coercion" ident ":" class_rawexpr ">->" class_rawexpr | "Coercion" qualid ":" class_rawexpr ">->" class_rawexpr | "Coercion" by_notation ":" class_rawexpr ">->" class_rawexpr -| "Context" binders -| "Instance" instance_name ":" term hint_info fields_def_opt +| "Context" LIST1 binder +| "Instance" instance_name ":" term hint_info [ ":=" "{" [ LIST1 field_def SEP ";" | ] "}" | ":=" term | ] | "Existing" "Instance" qualid hint_info -| "Existing" "Instances" qualid_list num_opt2 +| "Existing" "Instances" LIST1 qualid OPT [ "|" num ] | "Existing" "Class" qualid -| "Arguments" smart_global argument_spec_block_list_opt more_implicits_block_opt arguments_modifier_opt +| "Arguments" smart_global LIST0 argument_spec_block OPT [ "," LIST1 [ LIST0 more_implicits_block ] SEP "," ] OPT [ ":" LIST1 arguments_modifier SEP "," ] | "Implicit" "Type" reserv_list | "Implicit" "Types" reserv_list -| "Generalizable" All_alt -| "Export" "Set" ident_list option_setting -| "Export" "Unset" ident_list -] - -smart_global_list: [ -| smart_global_list smart_global -| smart_global -] - -num_opt: [ -| num -| empty -] - -qualid_list: [ -| qualid_list qualid -| qualid +| "Generalizable" [ "All" "Variables" | "No" "Variables" | [ "Variable" | "Variables" ] LIST1 ident ] +| "Export" "Set" LIST1 ident option_setting +| "Export" "Unset" LIST1 ident ] option_setting: [ -| empty +| | int | string ] @@ -1015,132 +682,35 @@ class_rawexpr: [ ] hint_info: [ -| "|" num_opt term1_extended_opt -| empty -] - -module_binder_list_opt: [ -| module_binder_list_opt "(" export_token ident_list ":" module_type_inl ")" -| empty -] - -module_type_inl_list_opt: [ -| module_type_inl_list_opt module_type_inl -| empty -] - -module_expr_inl_list_opt: [ -| module_expr_inl_list_opt module_expr_inl -| empty -] - -strategy_level_list: [ -| strategy_level_list strategy_level "[" smart_global_list "]" -| strategy_level "[" smart_global_list "]" -] - -fields_def_opt: [ -| ":=" "{" fields_def "}" -| ":=" term -| empty -] - -argument_spec_block_list_opt: [ -| argument_spec_block_list_opt argument_spec_block -| empty -] - -more_implicits_block_opt: [ -| "," more_implicits_block_list_comma -| empty -] - -more_implicits_block_list_comma: [ -| more_implicits_block_list_comma "," more_implicits_block_list_opt -| more_implicits_block_list_opt -] - -arguments_modifier_opt: [ -| ":" arguments_modifier_list_comma -| empty -] - -arguments_modifier_list_comma: [ -| arguments_modifier_list_comma "," arguments_modifier -| arguments_modifier -] - -All_alt: [ -| "All" "Variables" -| "No" "Variables" -| Variable_alt ident_list -] - -Variable_alt: [ -| "Variable" -| "Variables" -] - -more_implicits_block_list_opt: [ -| more_implicits_block_list_opt more_implicits_block -| empty -] - -univ_decl_opt2: [ -| univ_decl_opt def_body -| empty -] - -univ_decl_opt: [ -| "@{" ident_list_opt plus_opt univ_constraint_alt -| empty -] - -plus_opt: [ -| "+" -| empty -] - -univ_constraint_alt: [ -| "|" univ_constraint_list_comma_opt plus_opt "}" -| rbrace_alt -] - -univ_constraint_list_comma_opt: [ -| univ_constraint_list_comma -| empty -] - -rbrace_alt: [ -| "}" -| "|}" +| "|" OPT num OPT term1_extended +| ] export_token: [ | "Import" | "Export" -| empty +| ] of_module_type: [ | ":" module_type_inl -| module_type_inl_list_opt +| LIST0 ( "<:" module_type_inl ) ] is_module_type: [ -| ":=" module_type_inl module_type_inl_list_opt -| empty +| ":=" module_type_inl LIST0 ( "<+" module_type_inl ) +| ] is_module_expr: [ -| ":=" module_expr_inl module_expr_inl_list_opt -| empty +| ":=" module_expr_inl LIST0 ( "<+" module_expr_inl ) +| ] functor_app_annot: [ | "[" "inline" "at" "level" num "]" | "[" "no" "inline" "]" -| empty +| ] module_expr_inl: [ @@ -1171,33 +741,23 @@ module_type: [ ] with_declaration: [ -| "Definition" qualid univ_decl_opt ":=" term +| "Definition" qualid OPT ( "@{" LIST0 ident [ "+" | ] [ "|" LIST0 univ_constraint SEP "," [ "+" | ] "}" | [ "}" | "|}" ] ] ) ":=" term | "Module" qualid ":=" qualid ] argument_spec_block: [ -| exclam_opt name scope_delimiter_opt +| OPT "!" name OPT ( "%" ident ) | "/" | "&" -| "(" scope_delimiter_list ")" scope_delimiter_opt -| "[" scope_delimiter_list "]" scope_delimiter_opt -| "{" scope_delimiter_list "}" scope_delimiter_opt -] - -scope_delimiter_opt: [ -| "%" ident -| empty -] - -scope_delimiter_list: [ -| scope_delimiter_list scope_delimiter_opt -| scope_delimiter_opt +| "(" LIST1 ( OPT "!" name OPT ( "%" ident ) ) ")" OPT ( "%" ident ) +| "[" LIST1 ( OPT "!" name OPT ( "%" ident ) ) "]" OPT ( "%" ident ) +| "{" LIST1 ( OPT "!" name OPT ( "%" ident ) ) "}" OPT ( "%" ident ) ] more_implicits_block: [ | name -| "[" names "]" -| "{" names "}" +| "[" LIST1 name "]" +| "{" LIST1 name "}" ] strategy_level: [ @@ -1208,26 +768,21 @@ strategy_level: [ ] instance_name: [ -| ident_decl binders_opt -| empty +| ident_decl LIST0 binder +| ] reserv_list: [ -| reserv_tuple_list +| LIST1 reserv_tuple | simple_reserv ] -reserv_tuple_list: [ -| reserv_tuple_list reserv_tuple -| reserv_tuple -] - reserv_tuple: [ | "(" simple_reserv ")" ] simple_reserv: [ -| ident_list ":" term +| LIST1 ident ":" term ] arguments_modifier: [ @@ -1244,46 +799,36 @@ arguments_modifier: [ | "clear" "implicits" "and" "scopes" ] -Structure_opt: [ -| "Structure" -| empty -] - command: [ | "Goal" term -| "Comments" comment_list_opt -| "Declare" "Instance" ident_decl binders_opt ":" term hint_info | "Declare" "Scope" ident | "Pwd" | "Cd" | "Cd" string -| "Load" Verbose_opt string_alt -| "Declare" "ML" "Module" string_list +| "Load" [ "Verbose" | ] [ string | ident ] +| "Declare" "ML" "Module" LIST1 string | "Locate" locatable | "Add" "LoadPath" string as_dirpath | "Add" "Rec" "LoadPath" string as_dirpath | "Remove" "LoadPath" string -| "AddPath" string "as" as_dirpath -| "AddRecPath" string "as" as_dirpath -| "DelPath" string | "Type" term | "Print" printable -| "Print" smart_global univ_name_list_opt +| "Print" smart_global OPT ( "@{" LIST0 name "}" ) | "Print" "Module" "Type" qualid | "Print" "Module" qualid | "Print" "Namespace" dirpath | "Inspect" num | "Add" "ML" "Path" string | "Add" "Rec" "ML" "Path" string -| "Set" ident_list option_setting -| "Unset" ident_list -| "Print" "Table" ident_list -| "Add" ident ident option_ref_value_list -| "Add" ident option_ref_value_list -| "Test" ident_list "for" option_ref_value_list -| "Test" ident_list -| "Remove" ident ident option_ref_value_list -| "Remove" ident option_ref_value_list +| "Set" LIST1 ident option_setting +| "Unset" LIST1 ident +| "Print" "Table" LIST1 ident +| "Add" ident ident LIST1 option_ref_value +| "Add" ident LIST1 option_ref_value +| "Test" LIST1 ident "for" LIST1 option_ref_value +| "Test" LIST1 ident +| "Remove" ident ident LIST1 option_ref_value +| "Remove" ident LIST1 option_ref_value | "Write" "State" ident | "Write" "State" string | "Restore" "State" ident @@ -1328,9 +873,11 @@ command: [ | "Show" "Intros" | "Show" "Match" qualid | "Guarded" -| "Create" "HintDb" ident discriminated_opt -| "Remove" "Hints" qualid_list opt_hintbases +| "Create" "HintDb" ident [ "discriminated" | ] +| "Remove" "Hints" LIST1 qualid opt_hintbases | "Hint" hint opt_hintbases +| "Comments" LIST0 comment +| "Declare" "Instance" ident_decl LIST0 binder ":" term hint_info | "Obligation" int "of" ident ":" term withtac | "Obligation" int "of" ident withtac | "Obligation" int ":" term withtac @@ -1360,20 +907,20 @@ command: [ | "Add" "Relation" term1_extended term1_extended "reflexivity" "proved" "by" term1_extended "transitivity" "proved" "by" term1_extended "as" ident | "Add" "Relation" term1_extended term1_extended "reflexivity" "proved" "by" term1_extended "symmetry" "proved" "by" term1_extended "transitivity" "proved" "by" term1_extended "as" ident | "Add" "Relation" term1_extended term1_extended "transitivity" "proved" "by" term1_extended "as" ident -| "Add" "Parametric" "Relation" binders_opt ":" term1_extended term1_extended "reflexivity" "proved" "by" term1_extended "symmetry" "proved" "by" term1_extended "as" ident -| "Add" "Parametric" "Relation" binders_opt ":" term1_extended term1_extended "reflexivity" "proved" "by" term1_extended "as" ident -| "Add" "Parametric" "Relation" binders_opt ":" term1_extended term1_extended "as" ident -| "Add" "Parametric" "Relation" binders_opt ":" term1_extended term1_extended "symmetry" "proved" "by" term1_extended "as" ident -| "Add" "Parametric" "Relation" binders_opt ":" term1_extended term1_extended "symmetry" "proved" "by" term1_extended "transitivity" "proved" "by" term1_extended "as" ident -| "Add" "Parametric" "Relation" binders_opt ":" term1_extended term1_extended "reflexivity" "proved" "by" term1_extended "transitivity" "proved" "by" term1_extended "as" ident -| "Add" "Parametric" "Relation" binders_opt ":" term1_extended term1_extended "reflexivity" "proved" "by" term1_extended "symmetry" "proved" "by" term1_extended "transitivity" "proved" "by" term1_extended "as" ident -| "Add" "Parametric" "Relation" binders_opt ":" term1_extended term1_extended "transitivity" "proved" "by" term1_extended "as" ident +| "Add" "Parametric" "Relation" LIST0 binder ":" term1_extended term1_extended "reflexivity" "proved" "by" term1_extended "symmetry" "proved" "by" term1_extended "as" ident +| "Add" "Parametric" "Relation" LIST0 binder ":" term1_extended term1_extended "reflexivity" "proved" "by" term1_extended "as" ident +| "Add" "Parametric" "Relation" LIST0 binder ":" term1_extended term1_extended "as" ident +| "Add" "Parametric" "Relation" LIST0 binder ":" term1_extended term1_extended "symmetry" "proved" "by" term1_extended "as" ident +| "Add" "Parametric" "Relation" LIST0 binder ":" term1_extended term1_extended "symmetry" "proved" "by" term1_extended "transitivity" "proved" "by" term1_extended "as" ident +| "Add" "Parametric" "Relation" LIST0 binder ":" term1_extended term1_extended "reflexivity" "proved" "by" term1_extended "transitivity" "proved" "by" term1_extended "as" ident +| "Add" "Parametric" "Relation" LIST0 binder ":" term1_extended term1_extended "reflexivity" "proved" "by" term1_extended "symmetry" "proved" "by" term1_extended "transitivity" "proved" "by" term1_extended "as" ident +| "Add" "Parametric" "Relation" LIST0 binder ":" term1_extended term1_extended "transitivity" "proved" "by" term1_extended "as" ident | "Add" "Setoid" term1_extended term1_extended term1_extended "as" ident -| "Add" "Parametric" "Setoid" binders_opt ":" term1_extended term1_extended term1_extended "as" ident +| "Add" "Parametric" "Setoid" LIST0 binder ":" term1_extended term1_extended term1_extended "as" ident | "Add" "Morphism" term1_extended ":" ident | "Declare" "Morphism" term1_extended ":" ident | "Add" "Morphism" term1_extended "with" "signature" term "as" ident -| "Add" "Parametric" "Morphism" binders_opt ":" term1_extended "with" "signature" term "as" ident +| "Add" "Parametric" "Morphism" LIST0 binder ":" term1_extended "with" "signature" term "as" ident | "Grab" "Existential" "Variables" | "Unshelve" | "Declare" "Equivalent" "Keys" term1_extended term1_extended @@ -1401,49 +948,49 @@ command: [ | "Show" "Zify" "CstOp" (* micromega plugin *) | "Show" "Zify" "BinRel" (* micromega plugin *) | "Show" "Zify" "Spec" (* micromega plugin *) -| "Add" "Ring" ident ":" term1_extended ring_mods_opt (* setoid_ring plugin *) +| "Add" "Ring" ident ":" term1_extended OPT ( "(" LIST1 ring_mod SEP "," ")" ) (* setoid_ring plugin *) | "Hint" "Cut" "[" hints_path "]" opthints -| "Typeclasses" "Transparent" qualid_list_opt -| "Typeclasses" "Opaque" qualid_list_opt -| "Typeclasses" "eauto" ":=" debug eauto_search_strategy int_opt +| "Typeclasses" "Transparent" LIST0 qualid +| "Typeclasses" "Opaque" LIST0 qualid +| "Typeclasses" "eauto" ":=" debug eauto_search_strategy OPT int +| "Proof" "with" ltac_expr OPT [ "using" section_subset_expr ] +| "Proof" "using" section_subset_expr OPT [ "with" ltac_expr ] +| "Tactic" "Notation" OPT ( "(" "at" "level" num ")" ) LIST1 ltac_production_item ":=" ltac_expr | "Print" "Rewrite" "HintDb" ident -| "Proof" "with" ltac_expr using_opt -| "Proof" "using" section_subset_expr with_opt -| "Tactic" "Notation" ltac_tactic_level_opt ltac_production_item_list ":=" ltac_expr | "Print" "Ltac" qualid | "Locate" "Ltac" qualid -| "Ltac" tacdef_body_list +| "Ltac" LIST1 tacdef_body SEP "with" | "Print" "Ltac" "Signatures" | "Set" "Firstorder" "Solver" ltac_expr | "Print" "Firstorder" "Solver" +| "Function" LIST1 fix_definition SEP "with" (* funind plugin *) +| "Functional" "Scheme" LIST1 fun_scheme_arg SEP "with" (* funind plugin *) | "Extraction" qualid (* extraction plugin *) -| "Recursive" "Extraction" qualid_list (* extraction plugin *) -| "Extraction" string qualid_list (* extraction plugin *) -| "Extraction" "TestCompile" qualid_list (* extraction plugin *) -| "Separate" "Extraction" qualid_list (* extraction plugin *) +| "Recursive" "Extraction" LIST1 qualid (* extraction plugin *) +| "Extraction" string LIST1 qualid (* extraction plugin *) +| "Extraction" "TestCompile" LIST1 qualid (* extraction plugin *) +| "Separate" "Extraction" LIST1 qualid (* extraction plugin *) | "Extraction" "Library" ident (* extraction plugin *) | "Recursive" "Extraction" "Library" ident (* extraction plugin *) | "Extraction" "Language" language (* extraction plugin *) -| "Extraction" "Inline" qualid_list (* extraction plugin *) -| "Extraction" "NoInline" qualid_list (* extraction plugin *) +| "Extraction" "Inline" LIST1 qualid (* extraction plugin *) +| "Extraction" "NoInline" LIST1 qualid (* extraction plugin *) | "Print" "Extraction" "Inline" (* extraction plugin *) | "Reset" "Extraction" "Inline" (* extraction plugin *) -| "Extraction" "Implicit" qualid "[" int_or_id_list_opt "]" (* extraction plugin *) -| "Extraction" "Blacklist" ident_list (* extraction plugin *) +| "Extraction" "Implicit" qualid "[" LIST0 int_or_id "]" (* extraction plugin *) +| "Extraction" "Blacklist" LIST1 ident (* extraction plugin *) | "Print" "Extraction" "Blacklist" (* extraction plugin *) | "Reset" "Extraction" "Blacklist" (* extraction plugin *) -| "Extract" "Constant" qualid string_list_opt "=>" mlname (* extraction plugin *) +| "Extract" "Constant" qualid LIST0 string "=>" mlname (* extraction plugin *) | "Extract" "Inlined" "Constant" qualid "=>" mlname (* extraction plugin *) -| "Extract" "Inductive" qualid "=>" mlname "[" mlname_list_opt "]" string_opt (* extraction plugin *) +| "Extract" "Inductive" qualid "=>" mlname "[" LIST0 mlname "]" OPT string (* extraction plugin *) | "Show" "Extraction" (* extraction plugin *) -| "Function" fix_definition_list (* funind plugin *) -| "Functional" "Scheme" fun_scheme_arg_list (* funind plugin *) | "Functional" "Case" fun_scheme_arg (* funind plugin *) | "Generate" "graph" "for" qualid (* funind plugin *) -| "Hint" "Rewrite" orient term1_extended_list ":" ident_list_opt -| "Hint" "Rewrite" orient term1_extended_list "using" ltac_expr ":" ident_list_opt -| "Hint" "Rewrite" orient term1_extended_list -| "Hint" "Rewrite" orient term1_extended_list "using" ltac_expr +| "Hint" "Rewrite" orient LIST1 term1_extended ":" LIST0 ident +| "Hint" "Rewrite" orient LIST1 term1_extended "using" ltac_expr ":" LIST0 ident +| "Hint" "Rewrite" orient LIST1 term1_extended +| "Hint" "Rewrite" orient LIST1 term1_extended "using" ltac_expr | "Derive" "Inversion_clear" ident "with" term1_extended "Sort" sort_family | "Derive" "Inversion_clear" ident "with" term1_extended | "Derive" "Inversion" ident "with" term1_extended "Sort" sort_family @@ -1453,7 +1000,7 @@ command: [ | "Declare" "Left" "Step" term1_extended | "Declare" "Right" "Step" term1_extended | "Print" "Rings" (* setoid_ring plugin *) -| "Add" "Field" ident ":" term1_extended field_mods_opt (* setoid_ring plugin *) +| "Add" "Field" ident ":" term1_extended OPT ( "(" LIST1 field_mod SEP "," ")" ) (* setoid_ring plugin *) | "Print" "Fields" (* setoid_ring plugin *) | "Numeral" "Notation" qualid qualid qualid ":" ident numnotoption | "String" "Notation" qualid qualid qualid ":" ident @@ -1462,31 +1009,11 @@ command: [ orient: [ | "->" | "<-" -| empty -] - -string_opt: [ -| string -| empty -] - -qualid_list_opt: [ -| qualid_list_opt qualid -| empty -] - -univ_name_list_opt: [ -| "@{" name_list_opt "}" -| empty -] - -name_list_opt: [ -| name_list_opt name -| empty +| ] section_subset_expr: [ -| starredidentref_list_opt +| LIST0 starredidentref | ssexpr ] @@ -1503,17 +1030,12 @@ ssexpr50: [ ssexpr0: [ | starredidentref -| "(" starredidentref_list_opt ")" -| "(" starredidentref_list_opt ")" "*" +| "(" LIST0 starredidentref ")" +| "(" LIST0 starredidentref ")" "*" | "(" ssexpr ")" | "(" ssexpr ")" "*" ] -starredidentref_list_opt: [ -| starredidentref_list_opt starredidentref -| empty -] - starredidentref: [ | ident | ident "*" @@ -1521,43 +1043,13 @@ starredidentref: [ | "Type" "*" ] -int_opt: [ -| int -| empty -] - -using_opt: [ -| "using" section_subset_expr -| empty -] - -with_opt: [ -| "with" ltac_expr -| empty -] - -ltac_tactic_level_opt: [ -| "(" "at" "level" num ")" -| empty -] - -ltac_production_item_list: [ -| ltac_production_item_list ltac_production_item -| ltac_production_item -] - -tacdef_body_list: [ -| tacdef_body_list "with" tacdef_body -| tacdef_body -] - printable: [ -| "Term" smart_global univ_name_list_opt +| "Term" smart_global OPT ( "@{" LIST0 name "}" ) | "All" | "Section" qualid | "Grammar" ident | "Custom" "Grammar" ident -| "LoadPath" dirpath_opt +| "LoadPath" OPT dirpath | "Modules" | "Libraries" | "ML" "Path" @@ -1579,9 +1071,9 @@ printable: [ | "HintDb" ident | "Scopes" | "Scope" ident -| "Visibility" ident_opt +| "Visibility" OPT ident | "Implicit" smart_global -| Sorted_opt "Universes" printunivs_subgraph_opt string_opt +| [ "Sorted" | ] "Universes" OPT ( "Subgraph" "(" LIST0 qualid ")" ) OPT string | "Assumptions" smart_global | "Opaque" "Dependencies" smart_global | "Transparent" "Dependencies" smart_global @@ -1591,84 +1083,9 @@ printable: [ | "Registered" ] -dirpath_opt: [ -| dirpath -| empty -] - dirpath: [ | ident -| dirpath field -] - -Sorted_opt: [ -| "Sorted" -| empty -] - -printunivs_subgraph_opt: [ -| "Subgraph" "(" qualid_list_opt ")" -| empty -] - -comment_list_opt: [ -| comment_list_opt comment -| empty -] - -Verbose_opt: [ -| "Verbose" -| empty -] - -string_alt: [ -| string -| ident -] - -string_list: [ -| string_list string -| string -] - -option_ref_value_list: [ -| option_ref_value_list option_ref_value -| option_ref_value -] - -discriminated_opt: [ -| "discriminated" -| empty -] - -string_list_opt: [ -| string_list_opt string -| empty -] - -mlname_list_opt: [ -| mlname_list_opt mlname -| empty -] - -fun_scheme_arg_list: [ -| fun_scheme_arg_list "with" fun_scheme_arg -| fun_scheme_arg -] - -term1_extended_list: [ -| term1_extended_list term1_extended -| term1_extended -] - -ring_mods_opt: [ -| "(" ring_mod_list_comma ")" (* setoid_ring plugin *) -| empty -] - -field_mods_opt: [ -| "(" field_mod_list_comma ")" (* setoid_ring plugin *) -| empty +| dirpath field_ident ] locatable: [ @@ -1685,8 +1102,7 @@ option_ref_value: [ ] as_dirpath: [ -| "as" dirpath -| empty +| OPT [ "as" dirpath ] ] comment: [ @@ -1701,25 +1117,20 @@ reference_or_constr: [ ] hint: [ -| "Resolve" reference_or_constr_list hint_info -| "Resolve" "->" qualid_list num_opt -| "Resolve" "<-" qualid_list num_opt -| "Immediate" reference_or_constr_list +| "Resolve" LIST1 reference_or_constr hint_info +| "Resolve" "->" LIST1 qualid OPT num +| "Resolve" "<-" LIST1 qualid OPT num +| "Immediate" LIST1 reference_or_constr | "Variables" "Transparent" | "Variables" "Opaque" | "Constants" "Transparent" | "Constants" "Opaque" -| "Transparent" qualid_list -| "Opaque" qualid_list -| "Mode" qualid plus_list -| "Unfold" qualid_list -| "Constructors" qualid_list -| "Extern" num term1_extended_opt "=>" ltac_expr -] - -reference_or_constr_list: [ -| reference_or_constr_list reference_or_constr -| reference_or_constr +| "Transparent" LIST1 qualid +| "Opaque" LIST1 qualid +| "Mode" qualid LIST1 [ "+" | "!" | "-" ] +| "Unfold" LIST1 qualid +| "Constructors" LIST1 qualid +| "Extern" num OPT term1_extended "=>" ltac_expr ] constr_body: [ @@ -1727,20 +1138,9 @@ constr_body: [ | ":" term ":=" term ] -plus_list: [ -| plus_list plus_alt -| plus_alt -] - -plus_alt: [ -| "+" -| "!" -| "-" -] - withtac: [ | "with" ltac_expr -| empty +| ] ltac_def_kind: [ @@ -1749,23 +1149,18 @@ ltac_def_kind: [ ] tacdef_body: [ -| qualid fun_var_list ltac_def_kind ltac_expr +| qualid LIST1 fun_var ltac_def_kind ltac_expr | qualid ltac_def_kind ltac_expr ] ltac_production_item: [ | string -| ident "(" ident ltac_production_sep_opt ")" +| ident "(" ident OPT ( "," string ) ")" | ident ] -ltac_production_sep_opt: [ -| "," string -| empty -] - numnotoption: [ -| empty +| | "(" "warning" "after" num ")" | "(" "abstract" "after" num ")" ] @@ -1797,44 +1192,34 @@ ring_mod: [ | "abstract" (* setoid_ring plugin *) | "morphism" term1_extended (* setoid_ring plugin *) | "constants" "[" ltac_expr "]" (* setoid_ring plugin *) -| "closed" "[" qualid_list "]" (* setoid_ring plugin *) +| "closed" "[" LIST1 qualid "]" (* setoid_ring plugin *) | "preprocess" "[" ltac_expr "]" (* setoid_ring plugin *) | "postprocess" "[" ltac_expr "]" (* setoid_ring plugin *) | "setoid" term1_extended term1_extended (* setoid_ring plugin *) | "sign" term1_extended (* setoid_ring plugin *) -| "power" term1_extended "[" qualid_list "]" (* setoid_ring plugin *) +| "power" term1_extended "[" LIST1 qualid "]" (* setoid_ring plugin *) | "power_tac" term1_extended "[" ltac_expr "]" (* setoid_ring plugin *) | "div" term1_extended (* setoid_ring plugin *) ] -ring_mod_list_comma: [ -| ring_mod_list_comma "," ring_mod -| ring_mod -] - field_mod: [ | ring_mod (* setoid_ring plugin *) | "completeness" term1_extended (* setoid_ring plugin *) ] -field_mod_list_comma: [ -| field_mod_list_comma "," field_mod -| field_mod -] - debug: [ | "debug" -| empty +| ] eauto_search_strategy: [ | "(bfs)" | "(dfs)" -| empty +| ] hints_path_atom: [ -| qualid_list +| LIST1 qualid | "_" ] @@ -1849,62 +1234,52 @@ hints_path: [ ] opthints: [ -| ":" ident_list -| empty +| ":" LIST1 ident +| ] opt_hintbases: [ -| empty -| ":" ident_list -] - -int_or_id_list_opt: [ -| int_or_id_list_opt int_or_id -| empty +| +| ":" LIST1 ident ] query_command: [ | "Eval" red_expr "in" term "." | "Compute" term "." | "Check" term "." -| "About" smart_global univ_name_list_opt "." +| "About" smart_global OPT ( "@{" LIST0 name "}" ) "." | "SearchHead" term1_extended in_or_out_modules "." | "SearchPattern" term1_extended in_or_out_modules "." | "SearchRewrite" term1_extended in_or_out_modules "." | "Search" searchabout_query searchabout_queries "." | "SearchAbout" searchabout_query searchabout_queries "." -| "SearchAbout" "[" searchabout_query_list "]" in_or_out_modules "." +| "SearchAbout" "[" LIST1 searchabout_query "]" in_or_out_modules "." ] ne_in_or_out_modules: [ -| "inside" qualid_list -| "outside" qualid_list +| "inside" LIST1 qualid +| "outside" LIST1 qualid ] in_or_out_modules: [ | ne_in_or_out_modules -| empty +| ] positive_search_mark: [ | "-" -| empty +| ] searchabout_query: [ -| positive_search_mark string scope_delimiter_opt +| positive_search_mark string OPT ( "%" ident ) | positive_search_mark term1_extended ] searchabout_queries: [ | ne_in_or_out_modules | searchabout_query searchabout_queries -| empty -] - -searchabout_query_list: [ -| searchabout_query_list searchabout_query -| searchabout_query +| ] syntax: [ @@ -1912,34 +1287,18 @@ syntax: [ | "Close" "Scope" ident | "Delimit" "Scope" ident "with" ident | "Undelimit" "Scope" ident -| "Bind" "Scope" ident "with" class_rawexpr_list -| "Infix" string ":=" term1_extended syntax_modifier_opt ident_opt3 -| "Notation" ident ident_list_opt ":=" term1_extended only_parsing -| "Notation" string ":=" term1_extended syntax_modifier_opt ident_opt3 +| "Bind" "Scope" ident "with" LIST1 class_rawexpr +| "Infix" string ":=" term1_extended [ "(" LIST1 syntax_modifier SEP "," ")" | ] OPT [ ":" ident ] +| "Notation" ident LIST0 ident ":=" term1_extended only_parsing +| "Notation" string ":=" term1_extended [ "(" LIST1 syntax_modifier SEP "," ")" | ] OPT [ ":" ident ] | "Format" "Notation" string string string -| "Reserved" "Infix" string syntax_modifier_opt -| "Reserved" "Notation" string syntax_modifier_opt -] - -class_rawexpr_list: [ -| class_rawexpr_list class_rawexpr -| class_rawexpr -] - -syntax_modifier_opt: [ -| "(" syntax_modifier_list_comma ")" -| empty -] - -syntax_modifier_list_comma: [ -| syntax_modifier_list_comma "," syntax_modifier -| syntax_modifier +| "Reserved" "Infix" string [ "(" LIST1 syntax_modifier SEP "," ")" | ] +| "Reserved" "Notation" string [ "(" LIST1 syntax_modifier SEP "," ")" | ] ] only_parsing: [ | "(" "only" "parsing" ")" -| "(" "compat" string ")" -| empty +| ] level: [ @@ -1956,9 +1315,8 @@ syntax_modifier: [ | "no" "associativity" | "only" "printing" | "only" "parsing" -| "compat" string -| "format" string string_opt -| ident "," ident_list_comma "at" level +| "format" string OPT string +| ident "," LIST1 ident SEP "," "at" level | ident "at" level | ident "at" level constr_as_binder_kind | ident constr_as_binder_kind @@ -1971,23 +1329,13 @@ syntax_extension_type: [ | "bigint" | "binder" | "constr" -| "constr" level_opt constr_as_binder_kind_opt +| "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 level_opt constr_as_binder_kind_opt -] - -level_opt: [ -| level -| empty -] - -constr_as_binder_kind_opt: [ -| constr_as_binder_kind -| empty +| "custom" ident OPT ( "at" level ) OPT constr_as_binder_kind ] constr_as_binder_kind: [ @@ -2032,9 +1380,9 @@ simple_tactic: [ | "split" "with" bindings | "esplit" "with" bindings | "exists" -| "exists" bindings_list_comma +| "exists" LIST1 bindings SEP "," | "eexists" -| "eexists" bindings_list_comma +| "eexists" LIST1 bindings SEP "," | "intros" "until" quantified_hypothesis | "intro" | "intro" ident @@ -2050,17 +1398,17 @@ simple_tactic: [ | "move" ident "at" "bottom" | "move" ident "after" ident | "move" ident "before" ident -| "rename" rename_list_comma -| "revert" ident_list +| "rename" LIST1 rename SEP "," +| "revert" LIST1 ident | "simple" "induction" quantified_hypothesis | "simple" "destruct" quantified_hypothesis | "double" "induction" quantified_hypothesis quantified_hypothesis | "admit" | "fix" ident num | "cofix" ident -| "clear" ident_list_opt -| "clear" "-" ident_list -| "clearbody" ident_list +| "clear" LIST0 ident +| "clear" "-" LIST1 ident +| "clearbody" LIST1 ident | "generalize" "dependent" term1_extended | "replace" term1_extended "with" term1_extended clause_dft_concl by_arg_tac | "replace" "->" term1_extended clause_dft_concl @@ -2078,10 +1426,10 @@ simple_tactic: [ | "injection" destruction_arg | "einjection" | "einjection" destruction_arg -| "injection" "as" simple_intropattern_list_opt -| "injection" destruction_arg "as" simple_intropattern_list_opt -| "einjection" "as" simple_intropattern_list_opt -| "einjection" destruction_arg "as" simple_intropattern_list_opt +| "injection" "as" LIST0 simple_intropattern +| "injection" destruction_arg "as" LIST0 simple_intropattern +| "einjection" "as" LIST0 simple_intropattern +| "einjection" destruction_arg "as" LIST0 simple_intropattern | "simple" "injection" | "simple" "injection" destruction_arg | "dependent" "rewrite" orient term1_extended @@ -2091,11 +1439,11 @@ simple_tactic: [ | "decompose" "sum" term1_extended | "decompose" "record" term1_extended | "absurd" term1_extended -| "contradiction" constr_with_bindings_opt -| "autorewrite" "with" ident_list clause_dft_concl -| "autorewrite" "with" ident_list clause_dft_concl "using" ltac_expr -| "autorewrite" "*" "with" ident_list clause_dft_concl -| "autorewrite" "*" "with" ident_list clause_dft_concl "using" ltac_expr +| "contradiction" OPT constr_with_bindings +| "autorewrite" "with" LIST1 ident clause_dft_concl +| "autorewrite" "with" LIST1 ident clause_dft_concl "using" ltac_expr +| "autorewrite" "*" "with" LIST1 ident clause_dft_concl +| "autorewrite" "*" "with" LIST1 ident clause_dft_concl "using" ltac_expr | "rewrite" "*" orient term1_extended "in" ident "at" occurrences by_arg_tac | "rewrite" "*" orient term1_extended "at" occurrences "in" ident by_arg_tac | "rewrite" "*" orient term1_extended "in" ident by_arg_tac @@ -2106,7 +1454,7 @@ simple_tactic: [ | "notypeclasses" "refine" term1_extended | "simple" "notypeclasses" "refine" term1_extended | "solve_constraints" -| "subst" ident_list +| "subst" LIST1 ident | "subst" | "simple" "subst" | "evar" "(" ident ":" term ")" @@ -2150,7 +1498,7 @@ simple_tactic: [ | "swap" int_or_var int_or_var | "revgoals" | "guard" int_or_var comparison int_or_var -| "decompose" "[" term1_extended_list "]" term1_extended +| "decompose" "[" LIST1 term1_extended "]" term1_extended | "optimize_heap" | "start" "ltac" "profiling" | "stop" "ltac" "profiling" @@ -2158,32 +1506,32 @@ simple_tactic: [ | "show" "ltac" "profile" | "show" "ltac" "profile" "cutoff" int | "show" "ltac" "profile" string -| "restart_timer" string_opt -| "finish_timing" string_opt -| "finish_timing" "(" string ")" string_opt +| "restart_timer" OPT string +| "finish_timing" OPT string +| "finish_timing" "(" string ")" OPT string | "eassumption" | "eexact" term1_extended | "trivial" auto_using hintbases | "info_trivial" auto_using hintbases | "debug" "trivial" auto_using hintbases -| "auto" int_or_var_opt auto_using hintbases -| "info_auto" int_or_var_opt auto_using hintbases -| "debug" "auto" int_or_var_opt auto_using hintbases -| "prolog" "[" term1_extended_list_opt "]" int_or_var -| "eauto" int_or_var_opt int_or_var_opt auto_using hintbases -| "new" "auto" int_or_var_opt auto_using hintbases -| "debug" "eauto" int_or_var_opt int_or_var_opt auto_using hintbases -| "info_eauto" int_or_var_opt int_or_var_opt auto_using hintbases -| "dfs" "eauto" int_or_var_opt auto_using hintbases +| "auto" OPT int_or_var auto_using hintbases +| "info_auto" OPT int_or_var auto_using hintbases +| "debug" "auto" OPT int_or_var auto_using hintbases +| "prolog" "[" LIST0 term1_extended "]" int_or_var +| "eauto" OPT int_or_var OPT int_or_var auto_using hintbases +| "new" "auto" OPT int_or_var auto_using hintbases +| "debug" "eauto" OPT int_or_var OPT int_or_var auto_using hintbases +| "info_eauto" OPT int_or_var OPT int_or_var auto_using hintbases +| "dfs" "eauto" OPT int_or_var auto_using hintbases | "autounfold" hintbases clause_dft_concl | "autounfold_one" hintbases "in" ident | "autounfold_one" hintbases | "unify" term1_extended term1_extended | "unify" term1_extended term1_extended "with" ident | "convert_concl_no_check" term1_extended -| "typeclasses" "eauto" "bfs" int_or_var_opt "with" ident_list -| "typeclasses" "eauto" int_or_var_opt "with" ident_list -| "typeclasses" "eauto" int_or_var_opt +| "typeclasses" "eauto" "bfs" OPT int_or_var "with" LIST1 ident +| "typeclasses" "eauto" OPT int_or_var "with" LIST1 ident +| "typeclasses" "eauto" OPT int_or_var | "head_of_constr" ident term1_extended | "not_evar" term1_extended | "is_ground" term1_extended @@ -2209,16 +1557,16 @@ simple_tactic: [ | "rewrite_strat" rewstrategy "in" ident | "intros" intropattern_list_opt | "eintros" intropattern_list_opt -| "apply" constr_with_bindings_arg_list_comma in_hyp_as -| "eapply" constr_with_bindings_arg_list_comma in_hyp_as -| "simple" "apply" constr_with_bindings_arg_list_comma in_hyp_as -| "simple" "eapply" constr_with_bindings_arg_list_comma in_hyp_as -| "elim" constr_with_bindings_arg eliminator_opt -| "eelim" constr_with_bindings_arg eliminator_opt +| "apply" LIST1 constr_with_bindings_arg SEP "," in_hyp_as +| "eapply" LIST1 constr_with_bindings_arg SEP "," in_hyp_as +| "simple" "apply" LIST1 constr_with_bindings_arg SEP "," in_hyp_as +| "simple" "eapply" LIST1 constr_with_bindings_arg SEP "," in_hyp_as +| "elim" constr_with_bindings_arg OPT ( "using" constr_with_bindings ) +| "eelim" constr_with_bindings_arg OPT ( "using" constr_with_bindings ) | "case" induction_clause_list | "ecase" induction_clause_list -| "fix" ident num "with" fixdecl_list -| "cofix" ident "with" cofixdecl_list +| "fix" ident num "with" LIST1 fixdecl +| "cofix" ident "with" LIST1 cofixdecl | "pose" bindings_with_parameters | "pose" term1_extended as_name | "epose" bindings_with_parameters @@ -2242,47 +1590,47 @@ simple_tactic: [ | "enough" term1_extended as_ipat by_tactic | "eenough" term1_extended as_ipat by_tactic | "generalize" term1_extended -| "generalize" term1_extended term1_extended_list -| "generalize" term1_extended occs as_name pattern_occ_list_opt +| "generalize" term1_extended LIST1 term1_extended +| "generalize" term1_extended occs as_name LIST0 [ "," pattern_occ as_name ] | "induction" induction_clause_list | "einduction" induction_clause_list | "destruct" induction_clause_list | "edestruct" induction_clause_list -| "rewrite" oriented_rewriter_list_comma clause_dft_concl by_tactic -| "erewrite" oriented_rewriter_list_comma clause_dft_concl by_tactic -| "dependent" simple_alt quantified_hypothesis as_or_and_ipat with_opt2 +| "rewrite" LIST1 oriented_rewriter SEP "," clause_dft_concl by_tactic +| "erewrite" LIST1 oriented_rewriter SEP "," clause_dft_concl by_tactic +| "dependent" [ "simple" "inversion" | "inversion" | "inversion_clear" ] quantified_hypothesis as_or_and_ipat OPT [ "with" term1_extended ] | "simple" "inversion" quantified_hypothesis as_or_and_ipat in_hyp_list | "inversion" quantified_hypothesis as_or_and_ipat in_hyp_list | "inversion_clear" quantified_hypothesis as_or_and_ipat in_hyp_list | "inversion" quantified_hypothesis "using" term1_extended in_hyp_list | "red" clause_dft_concl | "hnf" clause_dft_concl -| "simpl" delta_flag ref_or_pattern_occ_opt clause_dft_concl +| "simpl" delta_flag OPT ref_or_pattern_occ clause_dft_concl | "cbv" strategy_flag clause_dft_concl | "cbn" strategy_flag clause_dft_concl | "lazy" strategy_flag clause_dft_concl | "compute" delta_flag clause_dft_concl -| "vm_compute" ref_or_pattern_occ_opt clause_dft_concl -| "native_compute" ref_or_pattern_occ_opt clause_dft_concl -| "unfold" unfold_occ_list_comma clause_dft_concl -| "fold" term1_extended_list clause_dft_concl -| "pattern" pattern_occ_list_comma clause_dft_concl +| "vm_compute" OPT ref_or_pattern_occ clause_dft_concl +| "native_compute" OPT ref_or_pattern_occ clause_dft_concl +| "unfold" LIST1 unfold_occ SEP "," clause_dft_concl +| "fold" LIST1 term1_extended clause_dft_concl +| "pattern" LIST1 pattern_occ SEP "," clause_dft_concl | "change" conversion clause_dft_concl | "change_no_check" conversion clause_dft_concl | "btauto" | "rtauto" | "congruence" | "congruence" int -| "congruence" "with" term1_extended_list -| "congruence" int "with" term1_extended_list +| "congruence" "with" LIST1 term1_extended +| "congruence" int "with" LIST1 term1_extended | "f_equal" -| "firstorder" ltac_expr_opt firstorder_using -| "firstorder" ltac_expr_opt "with" ident_list -| "firstorder" ltac_expr_opt firstorder_using "with" ident_list -| "gintuition" ltac_expr_opt -| "functional" "inversion" quantified_hypothesis qualid_opt (* funind plugin *) -| "functional" "induction" term1_extended_list fun_ind_using with_names (* funind plugin *) -| "soft" "functional" "induction" term1_extended_list fun_ind_using with_names (* funind plugin *) +| "firstorder" OPT ltac_expr firstorder_using +| "firstorder" OPT ltac_expr "with" LIST1 ident +| "firstorder" OPT ltac_expr firstorder_using "with" LIST1 ident +| "gintuition" OPT ltac_expr +| "functional" "inversion" quantified_hypothesis OPT qualid (* funind plugin *) +| "functional" "induction" LIST1 term1_extended fun_ind_using with_names (* funind plugin *) +| "soft" "functional" "induction" LIST1 term1_extended fun_ind_using with_names (* funind plugin *) | "myred" (* micromega plugin *) | "psatz_Z" int_or_var ltac_expr (* micromega plugin *) | "psatz_Z" ltac_expr (* micromega plugin *) @@ -2304,12 +1652,12 @@ simple_tactic: [ | "saturate" (* micromega plugin *) | "nsatz_compute" term1_extended (* nsatz plugin *) | "omega" (* omega plugin *) -| "omega" "with" ident_list (* omega plugin *) +| "omega" "with" LIST1 ident (* omega plugin *) | "omega" "with" "*" (* omega plugin *) | "protect_fv" string "in" ident (* setoid_ring plugin *) | "protect_fv" string (* setoid_ring plugin *) -| "ring_lookup" ltac_expr0 "[" term1_extended_list_opt "]" term1_extended_list (* setoid_ring plugin *) -| "field_lookup" ltac_expr "[" term1_extended_list_opt "]" term1_extended_list (* setoid_ring plugin *) +| "ring_lookup" ltac_expr0 "[" LIST0 term1_extended "]" LIST1 term1_extended (* setoid_ring plugin *) +| "field_lookup" ltac_expr "[" LIST0 term1_extended "]" LIST1 term1_extended (* setoid_ring plugin *) ] int_or_var: [ @@ -2317,13 +1665,8 @@ int_or_var: [ | ident ] -constr_with_bindings_opt: [ -| constr_with_bindings -| empty -] - hloc: [ -| empty +| | "in" "|-" "*" | "in" ident | "in" "(" "Type" "of" ident ")" @@ -2338,30 +1681,25 @@ rename: [ by_arg_tac: [ | "by" ltac_expr3 -| empty +| ] in_clause: [ | in_clause | "*" occs | "*" "|-" concl_occ -| hypident_occ_list_comma_opt "|-" concl_occ -| hypident_occ_list_comma_opt +| LIST0 hypident_occ SEP "," "|-" concl_occ +| LIST0 hypident_occ SEP "," ] occs: [ | "at" occs_nums -| empty -] - -hypident_occ_list_comma_opt: [ -| hypident_occ_list_comma -| empty +| ] as_ipat: [ | "as" simple_intropattern -| empty +| ] or_and_intropattern_loc: [ @@ -2371,40 +1709,35 @@ or_and_intropattern_loc: [ as_or_and_ipat: [ | "as" or_and_intropattern_loc -| empty +| ] eqn_ipat: [ | "eqn" ":" naming_intropattern | "_eqn" ":" naming_intropattern | "_eqn" -| empty +| ] as_name: [ | "as" ident -| empty +| ] by_tactic: [ | "by" ltac_expr3 -| empty +| ] rewriter: [ | "!" constr_with_bindings_arg -| qmark_alt constr_with_bindings_arg +| [ "?" | "?" ] constr_with_bindings_arg | num "!" constr_with_bindings_arg -| num qmark_alt constr_with_bindings_arg +| num [ "?" | "?" ] constr_with_bindings_arg | num constr_with_bindings_arg | constr_with_bindings_arg ] -qmark_alt: [ -| "?" -| "?" -] - oriented_rewriter: [ | orient rewriter ] @@ -2414,53 +1747,22 @@ induction_clause: [ ] induction_clause_list: [ -| induction_clause_list_comma eliminator_opt opt_clause -] - -induction_clause_list_comma: [ -| induction_clause_list_comma "," induction_clause -| induction_clause -] - -eliminator_opt: [ -| "using" constr_with_bindings -| empty +| LIST1 induction_clause SEP "," OPT ( "using" constr_with_bindings ) opt_clause ] auto_using: [ -| "using" term1_extended_list_comma -| empty -] - -term1_extended_list_comma: [ -| term1_extended_list_comma "," term1_extended -| term1_extended +| "using" LIST1 term1_extended SEP "," +| ] intropattern_list_opt: [ -| intropattern_list_opt intropattern -| empty +| LIST0 intropattern ] or_and_intropattern: [ | "[" intropattern_or_list_or "]" -| "(" simple_intropattern_list_comma_opt ")" -| "(" simple_intropattern "&" simple_intropattern_list_ ")" -] - -simple_intropattern_list_comma_opt: [ -| simple_intropattern_list_comma -| empty -] - -simple_intropattern_list_comma: [ -| simple_intropattern_list_comma "," simple_intropattern -| simple_intropattern -] - -simple_intropattern_list_: [ -| simple_intropattern_list_ "&" simple_intropattern -| simple_intropattern +| "(" LIST0 simple_intropattern SEP "," ")" +| "(" simple_intropattern "&" LIST1 simple_intropattern SEP "&" ")" ] intropattern_or_list_or: [ @@ -2468,11 +1770,6 @@ intropattern_or_list_or: [ | intropattern_list_opt ] -simple_intropattern_list_opt: [ -| simple_intropattern_list_opt simple_intropattern -| empty -] - equality_intropattern: [ | "->" | "<-" @@ -2492,12 +1789,7 @@ intropattern: [ ] simple_intropattern: [ -| simple_intropattern_closed term0_list_opt -] - -term0_list_opt: [ -| term0_list_opt "%" term0 -| empty +| simple_intropattern_closed LIST0 [ "%" term0 ] ] simple_intropattern_closed: [ @@ -2513,65 +1805,14 @@ simple_binding: [ ] bindings: [ -| simple_binding_list -| term1_extended_list -] - -simple_binding_list: [ -| simple_binding_list simple_binding -| simple_binding -] - -constr_with_bindings_arg_list_comma: [ -| constr_with_bindings_arg_list_comma "," constr_with_bindings_arg -| constr_with_bindings_arg -] - -fixdecl_list: [ -| fixdecl_list fixdecl -| fixdecl -] - -cofixdecl_list: [ -| cofixdecl_list cofixdecl -| cofixdecl -] - -pattern_occ_list_opt: [ -| pattern_occ_list_opt "," pattern_occ as_name -| empty +| LIST1 simple_binding +| LIST1 term1_extended ] pattern_occ: [ | term1_extended occs ] -oriented_rewriter_list_comma: [ -| oriented_rewriter_list_comma "," oriented_rewriter -| oriented_rewriter -] - -simple_alt: [ -| "simple" "inversion" -| "inversion" -| "inversion_clear" -] - -with_opt2: [ -| "with" term1_extended -| empty -] - -bindings_list_comma: [ -| bindings_list_comma "," bindings -| bindings -] - -rename_list_comma: [ -| rename_list_comma "," rename -| rename -] - comparison: [ | "=" | "<" @@ -2582,22 +1823,12 @@ comparison: [ hintbases: [ | "with" "*" -| "with" ident_list -| empty -] - -qualid_opt: [ -| qualid -| empty +| "with" LIST1 ident +| ] bindings_with_parameters: [ -| "(" ident simple_binder_list_opt ":=" term ")" -] - -simple_binder_list_opt: [ -| simple_binder_list_opt simple_binder -| empty +| "(" ident LIST0 simple_binder ":=" term ")" ] hypident: [ @@ -2613,23 +1844,23 @@ hypident_occ: [ clause_dft_concl: [ | "in" in_clause | occs -| empty +| ] clause_dft_all: [ | "in" in_clause -| empty +| ] opt_clause: [ | "in" in_clause | "at" occs_nums -| empty +| ] occs_nums: [ -| num_or_var_list -| "-" num_or_var int_or_var_list_opt +| LIST1 num_or_var +| "-" num_or_var LIST0 int_or_var ] num_or_var: [ @@ -2637,47 +1868,37 @@ num_or_var: [ | ident ] -int_or_var_list_opt: [ -| int_or_var_list_opt int_or_var -| empty -] - -num_or_var_list: [ -| num_or_var_list num_or_var -| num_or_var -] - concl_occ: [ | "*" occs -| empty +| ] in_hyp_list: [ -| "in" ident_list -| empty +| "in" LIST1 ident +| ] in_hyp_as: [ | "in" ident as_ipat -| empty +| ] simple_binder: [ | name -| "(" names ":" term ")" +| "(" LIST1 name ":" term ")" ] fixdecl: [ -| "(" ident simple_binder_list_opt struct_annot ":" term ")" +| "(" ident LIST0 simple_binder struct_annot ":" term ")" ] struct_annot: [ | "{" "struct" name "}" -| empty +| ] cofixdecl: [ -| "(" ident simple_binder_list_opt ":" term ")" +| "(" ident LIST0 simple_binder ":" term ")" ] constr_with_bindings: [ @@ -2686,7 +1907,7 @@ constr_with_bindings: [ with_bindings: [ | "with" bindings -| empty +| ] destruction_arg: [ @@ -2713,36 +1934,26 @@ conversion: [ firstorder_using: [ | "using" qualid -| "using" qualid "," qualid_list_comma -| "using" qualid qualid qualid_list_opt -| empty -] - -qualid_list_comma: [ -| qualid_list_comma "," qualid -| qualid +| "using" qualid "," LIST1 qualid SEP "," +| "using" qualid qualid LIST0 qualid +| ] fun_ind_using: [ | "using" constr_with_bindings (* funind plugin *) -| empty (* funind plugin *) +| (* funind plugin *) ] with_names: [ | "as" simple_intropattern (* funind plugin *) -| empty (* funind plugin *) +| (* funind plugin *) ] occurrences: [ -| int_list +| LIST1 int | ident ] -int_list: [ -| int_list int -| int -] - rewstrategy: [ | term1_extended | "<-" term1_extended @@ -2764,51 +1975,31 @@ rewstrategy: [ | "choice" rewstrategy rewstrategy | "old_hints" ident | "hints" ident -| "terms" term1_extended_list_opt +| "terms" LIST0 term1_extended | "eval" red_expr | "fold" term1_extended ] -hypident_occ_list_comma: [ -| hypident_occ_list_comma "," hypident_occ -| hypident_occ -] - ltac_expr: [ | binder_tactic | ltac_expr4 ] binder_tactic: [ -| "fun" fun_var_list "=>" ltac_expr -| "let" rec_opt let_clause_list "in" ltac_expr +| "fun" LIST1 fun_var "=>" ltac_expr +| "let" [ "rec" | ] LIST1 let_clause SEP "with" "in" ltac_expr | "info" ltac_expr ] -fun_var_list: [ -| fun_var_list fun_var -| fun_var -] - fun_var: [ | ident | "_" ] -rec_opt: [ -| "rec" -| empty -] - -let_clause_list: [ -| let_clause_list "with" let_clause -| let_clause -] - let_clause: [ | ident ":=" ltac_expr | "_" ":=" ltac_expr -| ident fun_var_list ":=" ltac_expr +| ident LIST1 fun_var ":=" ltac_expr ] ltac_expr4: [ @@ -2820,27 +2011,28 @@ ltac_expr4: [ ] multi_goal_tactics: [ -| ltac_expr_opt "|" multi_goal_tactics -| ltac_expr_opt ".." or_opt ltac_expr_opt_list_or +| OPT ltac_expr "|" multi_goal_tactics +| ltac_expr_opt ".." OPT "|" ltac_expr_opt_list_or | ltac_expr -| empty +| ] ltac_expr_opt: [ -| ltac_expr -| empty +| OPT ltac_expr ] ltac_expr_opt_list_or: [ | ltac_expr_opt_list_or "|" ltac_expr_opt | ltac_expr_opt +| ltac_expr_opt_list_or "|" OPT ltac_expr +| OPT ltac_expr ] ltac_expr3: [ | "try" ltac_expr3 | "do" int_or_var ltac_expr3 | "timeout" int_or_var ltac_expr3 -| "time" string_opt ltac_expr3 +| "time" OPT string ltac_expr3 | "repeat" ltac_expr3 | "progress" ltac_expr3 | "once" ltac_expr3 @@ -2863,48 +2055,23 @@ ltac_expr2: [ ltac_expr1: [ | ltac_match_term +| "first" "[" LIST0 ltac_expr SEP "|" "]" +| "solve" "[" LIST0 ltac_expr SEP "|" "]" +| "idtac" LIST0 message_token +| failkw [ int_or_var | ] LIST0 message_token | ltac_match_goal -| "first" "[" ltac_expr_list_or_opt "]" -| "solve" "[" ltac_expr_list_or_opt "]" -| "idtac" message_token_list_opt -| failkw int_or_var_opt message_token_list_opt | simple_tactic | tactic_arg -| qualid tactic_arg_compat_list_opt +| qualid LIST0 tactic_arg_compat | ltac_expr0 ] -ltac_expr_list_or_opt: [ -| ltac_expr_list_or -| empty -] - -ltac_expr_list_or: [ -| ltac_expr_list_or "|" ltac_expr -| ltac_expr -] - -message_token_list_opt: [ -| message_token_list_opt message_token -| empty -] - message_token: [ | ident | string | int ] -int_or_var_opt: [ -| int_or_var -| empty -] - -term1_extended_list_opt: [ -| term1_extended_list_opt term1_extended -| empty -] - failkw: [ | "fail" | "gfail" @@ -2914,26 +2081,16 @@ tactic_arg: [ | "eval" red_expr "in" term | "context" ident "[" term "]" | "type" "of" term -| "fresh" fresh_id_list_opt +| "fresh" LIST0 fresh_id | "type_term" term1_extended | "numgoals" ] -fresh_id_list_opt: [ -| fresh_id_list_opt fresh_id -| empty -] - fresh_id: [ | string | qualid ] -tactic_arg_compat_list_opt: [ -| tactic_arg_compat_list_opt tactic_arg_compat -| empty -] - tactic_arg_compat: [ | tactic_arg | term @@ -2963,22 +2120,17 @@ only_selector: [ ] selector: [ -| range_selector_list_comma +| LIST1 range_selector SEP "," | "[" ident "]" ] -range_selector_list_comma: [ -| range_selector_list_comma "," range_selector -| range_selector -] - range_selector: [ | num "-" num | num ] ltac_match_term: [ -| match_key ltac_expr "with" or_opt match_rule_list_or "end" +| match_key ltac_expr "with" OPT "|" LIST1 match_rule SEP "|" "end" ] match_key: [ @@ -2987,67 +2139,27 @@ match_key: [ | "lazymatch" ] -match_rule_list_or: [ -| match_rule_list_or "|" match_rule -| match_rule -] - match_rule: [ -| match_pattern_alt "=>" ltac_expr -] - -match_pattern_alt: [ -| match_pattern -| "_" +| [ match_pattern | "_" ] "=>" ltac_expr ] match_pattern: [ -| "context" ident_opt "[" term "]" +| "context" OPT ident "[" term "]" | term ] ltac_match_goal: [ -| match_key reverse_opt "goal" "with" or_opt match_context_rule_list_or "end" -] - -reverse_opt: [ -| "reverse" -| empty -] - -match_context_rule_list_or: [ -| match_context_rule_list_or "|" match_context_rule -| match_context_rule +| match_key OPT "reverse" "goal" "with" OPT "|" LIST1 match_context_rule SEP "|" "end" ] match_context_rule: [ -| match_hyp_list_comma_opt "|-" match_pattern "=>" ltac_expr -| "[" match_hyp_list_comma_opt "|-" match_pattern "]" "=>" ltac_expr +| LIST0 match_hyp SEP "," "|-" match_pattern "=>" ltac_expr +| "[" LIST0 match_hyp SEP "," "|-" match_pattern "]" "=>" ltac_expr | "_" "=>" ltac_expr ] -match_hyp_list_comma_opt: [ -| match_hyp_list_comma -| empty -] - -match_hyp_list_comma: [ -| match_hyp_list_comma "," match_hyp -| match_hyp -] - match_hyp: [ | name ":" match_pattern -| name ":=" match_pattern_opt match_pattern -] - -match_pattern_opt: [ -| "[" match_pattern "]" ":" -| empty -] - -ident_list_opt: [ -| ident_list_opt ident -| empty +| name ":=" OPT ( "[" match_pattern "]" ":" ) match_pattern ] diff --git a/doc/tools/docgram/productionlist.edit_mlg b/doc/tools/docgram/productionlist.edit_mlg index 42d94e76bb..8170b71e7a 100644 --- a/doc/tools/docgram/productionlist.edit_mlg +++ b/doc/tools/docgram/productionlist.edit_mlg @@ -13,32 +13,6 @@ DOC_GRAMMAR -EXPAND: [ | ] - -RENAME: [ -| name_alt names_tuple -| binder_list binders -| binder_list_opt binders_opt -| typeclass_constraint_list_comma typeclass_constraints_comma -| universe_expr_list_comma universe_exprs_comma -| universe_level_list_opt universe_levels_opt -| name_list names -| name_list_comma names_comma -| case_item_list_comma case_items_comma -| eqn_list_or_opt eqns_or_opt -| eqn_list_or eqns_or -| pattern_list_or patterns_or -| fix_body_list fix_bodies -| arg_list args -| arg_list_opt args_opt -| evar_binding_list_semi evar_bindings_semi -] - -binders_opt: [ -| REPLACE binders_opt binder -| WITH binders -] - (* this is here because they're inside _opt generated by EXPAND *) SPLICE: [ | ltac_info diff --git a/engine/evd.ml b/engine/evd.ml index 94868d9bdd..70f58163fd 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -200,13 +200,14 @@ let evar_filtered_hyps evi = match Filter.repr (evar_filter evi) with in make_hyps filter (evar_context evi) -let evar_env evi = Global.env_of_context evi.evar_hyps +let evar_env env evi = + Environ.reset_with_named_context evi.evar_hyps env -let evar_filtered_env evi = match Filter.repr (evar_filter evi) with -| None -> evar_env evi +let evar_filtered_env env evi = match Filter.repr (evar_filter evi) with +| None -> evar_env env evi | Some filter -> let rec make_env filter ctxt = match filter, ctxt with - | [], [] -> reset_context (Global.env ()) + | [], [] -> reset_context env | false :: filter, _ :: ctxt -> make_env filter ctxt | true :: filter, decl :: ctxt -> let env = make_env filter ctxt in @@ -901,14 +902,14 @@ let make_nonalgebraic_variable evd u = let fresh_sort_in_family ?loc ?(rigid=univ_flexible) evd s = with_context_set ?loc rigid evd (UnivGen.fresh_sort_in_family s) -let fresh_constant_instance ?loc env evd c = - with_context_set ?loc univ_flexible evd (UnivGen.fresh_constant_instance env c) +let fresh_constant_instance ?loc ?(rigid=univ_flexible) env evd c = + with_context_set ?loc rigid evd (UnivGen.fresh_constant_instance env c) -let fresh_inductive_instance ?loc env evd i = - with_context_set ?loc univ_flexible evd (UnivGen.fresh_inductive_instance env i) +let fresh_inductive_instance ?loc ?(rigid=univ_flexible) env evd i = + with_context_set ?loc rigid evd (UnivGen.fresh_inductive_instance env i) -let fresh_constructor_instance ?loc env evd c = - with_context_set ?loc univ_flexible evd (UnivGen.fresh_constructor_instance env c) +let fresh_constructor_instance ?loc ?(rigid=univ_flexible) env evd c = + with_context_set ?loc rigid evd (UnivGen.fresh_constructor_instance env c) let fresh_global ?loc ?(rigid=univ_flexible) ?names env evd gr = with_context_set ?loc rigid evd (UnivGen.fresh_global_instance ?loc ?names env gr) diff --git a/engine/evd.mli b/engine/evd.mli index 7876e9a48f..82e1003a65 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -125,8 +125,8 @@ val evar_filtered_hyps : evar_info -> named_context_val val evar_body : evar_info -> evar_body val evar_candidates : evar_info -> constr list option val evar_filter : evar_info -> Filter.t -val evar_env : evar_info -> env -val evar_filtered_env : evar_info -> env +val evar_env : env -> evar_info -> env +val evar_filtered_env : env -> evar_info -> env val map_evar_body : (econstr -> econstr) -> evar_body -> evar_body val map_evar_info : (econstr -> econstr) -> evar_info -> evar_info @@ -653,10 +653,14 @@ val update_sigma_env : evar_map -> env -> evar_map (** Polymorphic universes *) -val fresh_sort_in_family : ?loc:Loc.t -> ?rigid:rigid -> evar_map -> Sorts.family -> evar_map * Sorts.t -val fresh_constant_instance : ?loc:Loc.t -> env -> evar_map -> Constant.t -> evar_map * pconstant -val fresh_inductive_instance : ?loc:Loc.t -> env -> evar_map -> inductive -> evar_map * pinductive -val fresh_constructor_instance : ?loc:Loc.t -> env -> evar_map -> constructor -> evar_map * pconstructor +val fresh_sort_in_family : ?loc:Loc.t -> ?rigid:rigid + -> evar_map -> Sorts.family -> evar_map * Sorts.t +val fresh_constant_instance : ?loc:Loc.t -> ?rigid:rigid + -> env -> evar_map -> Constant.t -> evar_map * pconstant +val fresh_inductive_instance : ?loc:Loc.t -> ?rigid:rigid + -> env -> evar_map -> inductive -> evar_map * pinductive +val fresh_constructor_instance : ?loc:Loc.t -> ?rigid:rigid + -> env -> evar_map -> constructor -> evar_map * pconstructor val fresh_global : ?loc:Loc.t -> ?rigid:rigid -> ?names:Univ.Instance.t -> env -> evar_map -> GlobRef.t -> evar_map * econstr diff --git a/engine/proofview.ml b/engine/proofview.ml index 6f8e668e4e..16be96454e 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -1039,9 +1039,9 @@ let (>>=) = tclBIND (** {6 Goal-dependent tactics} *) -let goal_env evars gl = +let goal_env env evars gl = let evi = Evd.find evars gl in - Evd.evar_filtered_env evi + Evd.evar_filtered_env env evi let goal_nf_evar sigma gl = let evi = Evd.find sigma gl in @@ -1256,9 +1256,10 @@ module V82 = struct let of_tactic t gls = try + let env = Global.env () in let init = { shelf = []; solution = gls.Evd.sigma ; comb = [with_empty_state gls.Evd.it] } in let name, poly = Names.Id.of_string "legacy_pe", false in - let (_,final,_,_) = apply ~name ~poly (goal_env gls.Evd.sigma gls.Evd.it) t init in + let (_,final,_,_) = apply ~name ~poly (goal_env env gls.Evd.sigma gls.Evd.it) t init in { Evd.sigma = final.solution ; it = CList.map drop_state final.comb } with Logic_monad.TacticFailure e as src -> let (_, info) = CErrors.push src in diff --git a/engine/univGen.ml b/engine/univGen.ml index 1fe09270ba..b270f9dc0b 100644 --- a/engine/univGen.ml +++ b/engine/univGen.ml @@ -48,8 +48,6 @@ let fresh_instance_from ?loc ctx = function (** Fresh universe polymorphic construction *) -open Globnames - let fresh_global_instance ?loc ?names env gr = let auctx = Environ.universes_of_global env gr in let u, ctx = fresh_instance_from ?loc auctx names in @@ -78,10 +76,6 @@ let constr_of_monomorphic_global gr = Pp.(str "globalization of polymorphic reference " ++ Nametab.pr_global_env Id.Set.empty gr ++ str " would forget universes.") -let fresh_global_or_constr_instance env = function - | IsConstr c -> c, ContextSet.empty - | IsGlobal gr -> fresh_global_instance env gr - let fresh_sort_in_family = function | InSProp -> Sorts.sprop, ContextSet.empty | InProp -> Sorts.prop, ContextSet.empty diff --git a/engine/univGen.mli b/engine/univGen.mli index 1b351c61c4..bbde9d4e30 100644 --- a/engine/univGen.mli +++ b/engine/univGen.mli @@ -46,9 +46,6 @@ val fresh_constructor_instance : env -> constructor -> val fresh_global_instance : ?loc:Loc.t -> ?names:Univ.Instance.t -> env -> GlobRef.t -> constr in_universe_context_set -val fresh_global_or_constr_instance : env -> Globnames.global_reference_or_constr -> - constr in_universe_context_set - (** Get fresh variables for the universe context. Useful to make tactics that manipulate constrs in universe contexts polymorphic. *) val fresh_universe_context_set_instance : ContextSet.t -> diff --git a/ide/coqide.ml b/ide/coqide.ml index fc30690544..e0347d3c5f 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -618,7 +618,7 @@ let printopts_callback opts v = let get_current_word term = (* First look to find if autocompleting *) - match term.script#complete_popup#proposal with + match term.script#proposal with | Some p -> p | None -> (* Then look at the current selected word *) @@ -996,8 +996,6 @@ let build_ui () = item "Save" ~callback:(File.save ~parent:w) ~stock:`SAVE ~tooltip:"Save current buffer"; item "Save as" ~label:"S_ave as" ~stock:`SAVE_AS ~callback:(File.saveas ~parent:w); item "Save all" ~label:"Sa_ve all" ~callback:File.saveall; - item "Revert all buffers" ~label:"_Revert all buffers" - ~callback:(File.revert_all ~parent:w) ~stock:`REVERT_TO_SAVED; item "Close buffer" ~label:"_Close buffer" ~stock:`CLOSE ~callback:(File.close_buffer ~parent:w) ~tooltip:"Close current buffer"; item "Print..." ~label:"_Print..." @@ -1368,7 +1366,7 @@ let read_coqide_args argv = |"-debug"::args -> Minilib.debug := true; Flags.debug := true; - Backtrace.record_backtrace true; + Exninfo.record_backtrace true; filter_coqtop coqtop project_files bindings_files ("-debug"::out) args |"-coqtop-flags" :: flags :: args-> Coq.ideslave_coqtop_flags := Some flags; diff --git a/ide/coqide_ui.ml b/ide/coqide_ui.ml index f056af6703..59dd9c0e4c 100644 --- a/ide/coqide_ui.ml +++ b/ide/coqide_ui.ml @@ -36,7 +36,6 @@ let init () = \n <menuitem action='Save' />\ \n <menuitem action='Save as' />\ \n <menuitem action='Save all' />\ -\n <menuitem action='Revert all buffers' />\ \n <menuitem action='Close buffer' />\ \n <menuitem action='Print...' />\ \n <menu action='Export to'>\ diff --git a/ide/preferences.ml b/ide/preferences.ml index 4ee5669877..d3cf08e90e 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -388,6 +388,9 @@ let window_height = let auto_complete = new preference ~name:["auto_complete"] ~init:false ~repr:Repr.(bool) +let auto_complete_delay = + new preference ~name:["auto_complete_delay"] ~init:250 ~repr:Repr.(int) + let stop_before = new preference ~name:["stop_before"] ~init:true ~repr:Repr.(bool) @@ -831,10 +834,26 @@ let configure ?(apply=(fun () -> ())) parent = let but = GButton.check_button ~label:text ~active ~packing:box#pack () in ignore (but#connect#toggled ~callback:(fun () -> pref#set but#active)) in + let spin text ~min ~max (pref : int preference) = + let box = GPack.hbox ~packing:box#pack () in + let but = GEdit.spin_button + ~numeric:true ~update_policy:`IF_VALID ~digits:0 + ~packing:box#pack () + in + let _ = GMisc.label ~text:"Delay (ms)" ~packing:box#pack () in + let () = but#adjustment#set_bounds + ~lower:(float_of_int min) ~upper:(float_of_int max) + ~step_incr:1. + () + in + let () = but#set_value (float_of_int pref#get) in + ignore (but#connect#value_changed ~callback:(fun () -> pref#set but#value_as_int)) + in let () = button "Dynamic word wrap" dynamic_word_wrap in let () = button "Show line number" show_line_number in let () = button "Auto indentation" auto_indent in let () = button "Auto completion" auto_complete in + let () = spin "Auto completion delay" ~min:0 ~max:5000 auto_complete_delay in let () = button "Show spaces" show_spaces in let () = button "Show right margin" show_right_margin in let () = button "Show progress bar" show_progress_bar in diff --git a/ide/preferences.mli b/ide/preferences.mli index 4b04326cec..7b43079b4f 100644 --- a/ide/preferences.mli +++ b/ide/preferences.mli @@ -82,6 +82,7 @@ val show_toolbar : bool preference val window_width : int preference val window_height : int preference val auto_complete : bool preference +val auto_complete_delay : int preference val stop_before : bool preference val reset_on_tab_switch : bool preference val line_ending : line_ending preference diff --git a/ide/wg_Completion.ml b/ide/wg_Completion.ml index ac6712909e..396939cfcc 100644 --- a/ide/wg_Completion.ml +++ b/ide/wg_Completion.ml @@ -69,387 +69,101 @@ let is_substring s1 s2 = if !break then len2 - len1 else -1 -class type complete_model_signals = - object ('a) - method after : 'a - method disconnect : GtkSignal.id -> unit - method start_completion : callback:(int -> unit) -> GtkSignal.id - method update_completion : callback:(int * string * Proposals.t -> unit) -> GtkSignal.id - method end_completion : callback:(unit -> unit) -> GtkSignal.id - end - -let complete_model_signals - (start_s : int GUtil.signal) - (update_s : (int * string * Proposals.t) GUtil.signal) - (end_s : unit GUtil.signal) : complete_model_signals = -let signals = [ - start_s#disconnect; - update_s#disconnect; - end_s#disconnect; -] in -object (self : 'a) - inherit GUtil.ml_signals signals - method start_completion = start_s#connect ~after - method update_completion = update_s#connect ~after - method end_completion = end_s#connect ~after -end - -class complete_model coqtop (buffer : GText.buffer) = - let cols = new GTree.column_list in - let column = cols#add Gobject.Data.string in - let store = GTree.list_store cols in - let filtered_store = GTree.model_filter store in - let start_completion_signal = new GUtil.signal () in - let update_completion_signal = new GUtil.signal () in - let end_completion_signal = new GUtil.signal () in -object (self) - - val signals = complete_model_signals - start_completion_signal update_completion_signal end_completion_signal - val mutable active = false - val mutable auto_complete_length = 3 - (* this variable prevents CoqIDE from autocompleting when we have deleted something *) - val mutable is_auto_completing = false - (* this mutex ensure that CoqIDE will not try to autocomplete twice *) - val mutable cache = (-1, "", Proposals.empty) - val mutable insert_offset = -1 - val mutable current_completion = ("", Proposals.empty) - val mutable lock_auto_completing = true +class completion_provider coqtop = + let self_provider = ref None in + let active = ref true in + let provider = object (self) - method connect = signals + val mutable auto_complete_length = 3 + val mutable cache = (-1, "", Proposals.empty) + val mutable insert_offset = -1 - method active = active + method name = "" - method set_active b = active <- b + method icon = None - method private handle_insert iter s = - (* we're inserting, so we may autocomplete *) - is_auto_completing <- true + method private update_proposals pref = + let (_, _, props) = cache in + let filter prop = 0 <= is_substring pref prop in + let props = Proposals.filter filter props in + props - method private handle_delete ~start ~stop = - (* disable autocomplete *) - is_auto_completing <- false - - method store = filtered_store - - method column = column - - method handle_proposal path = - let row = filtered_store#get_iter path in - let proposal = filtered_store#get ~row ~column in - let (start_offset, _, _) = cache in - (* [iter] might be invalid now, get a new one to please gtk *) - let iter = buffer#get_iter `INSERT in - (* We cancel completion when the buffer has changed recently *) - if iter#offset = insert_offset then begin - let suffix = - let len1 = String.length proposal in - let len2 = insert_offset - start_offset in - String.sub proposal len2 (len1 - len2) + method private add_proposals ctx props = + let mk text = + let item = GSourceView3.source_completion_item ~text ~label:text () in + (item :> GSourceView3.source_completion_proposal) in - buffer#begin_user_action (); - ignore (buffer#insert_interactive ~iter suffix); - buffer#end_user_action (); - end - - method private init_proposals pref props = - let () = store#clear () in - let iter prop = - let iter = store#append () in - store#set ~row:iter ~column prop - in - let () = current_completion <- (pref, props) in - Proposals.iter iter props - - method private update_proposals pref = - let (_, _, props) = cache in - let filter prop = 0 <= is_substring pref prop in - let props = Proposals.filter filter props in - let () = current_completion <- (pref, props) in - let () = filtered_store#refilter () in - props - - method private do_auto_complete k = - let iter = buffer#get_iter `INSERT in - let () = insert_offset <- iter#offset in - let log = Printf.sprintf "Completion at offset: %i" insert_offset in - let () = Minilib.log log in - let prefix = - if Gtk_parsing.ends_word iter then - let start = Gtk_parsing.find_word_start iter in - let w = buffer#get_text ~start ~stop:iter () in - if String.length w >= auto_complete_length then Some (w, start) - else None - else None - in - match prefix with - | Some (w, start) -> + let props = List.map mk (Proposals.elements props) in + ctx#add_proposals (Option.get !self_provider) props true + + method populate ctx = + let iter = ctx#iter in + let buffer = new GText.buffer iter#buffer in + let start = Gtk_parsing.find_word_start iter in + let w = start#get_text ~stop:iter in let () = Minilib.log ("Completion of prefix: '" ^ w ^ "'") in let (off, prefix, props) = cache in let start_offset = start#offset in (* check whether we have the last request in cache *) if (start_offset = off) && (0 <= is_substring prefix w) then let props = self#update_proposals w in - let () = update_completion_signal#call (start_offset, w, props) in - k () + self#add_proposals ctx props else - let () = start_completion_signal#call start_offset in + let cancel = ref false in + let _ = ctx#connect#cancelled ~callback:(fun () -> cancel := true) in let update props = let () = cache <- (start_offset, w, props) in - let () = self#init_proposals w props in - update_completion_signal#call (start_offset, w, props) + if not !cancel then self#add_proposals ctx props in (* If not in the cache, we recompute it: first syntactic *) let synt = get_syntactic_completion buffer w Proposals.empty in (* Then semantic *) - let next prop = - let () = update prop in - Coq.lift k + let next props = + update props; + Coq.return () in let query = Coq.bind (get_semantic_completion w synt) next in (* If coqtop is computing, do the syntactic completion altogether *) - let occupied () = - let () = update synt in - k () - in + let occupied () = update synt in Coq.try_grab coqtop query occupied - | None -> end_completion_signal#call (); k () - - method private may_auto_complete () = - if active && is_auto_completing && lock_auto_completing then begin - let () = lock_auto_completing <- false in - let unlock () = lock_auto_completing <- true in - self#do_auto_complete unlock - end - - initializer - let filter_prop model row = - let (_, props) = current_completion in - let prop = store#get ~row ~column in - Proposals.mem prop props - in - let () = filtered_store#set_visible_func filter_prop in - (* Install auto-completion *) - ignore (buffer#connect#insert_text ~callback:self#handle_insert); - ignore (buffer#connect#delete_range ~callback:self#handle_delete); - ignore (buffer#connect#after#end_user_action ~callback:self#may_auto_complete); - -end - -class complete_popup (model : complete_model) (view : GText.view) = - let obj = GWindow.window ~kind:`POPUP ~show:false () in - let frame = GBin.scrolled_window - ~hpolicy:`NEVER ~vpolicy:`NEVER - ~shadow_type:`OUT ~packing:obj#add () - in -(* let frame = GBin.frame ~shadow_type:`OUT ~packing:obj#add () in *) - let data = GTree.view - ~vadjustment:frame#vadjustment ~hadjustment:frame#hadjustment - ~rules_hint:true ~headers_visible:false - ~model:model#store ~packing:frame#add () - in - let renderer = GTree.cell_renderer_text [], ["text", model#column] in - let col = GTree.view_column ~renderer () in - let _ = data#append_column col in - let () = col#set_sizing `AUTOSIZE in - let page_size = 16 in - -object (self) - - method coerce = view#coerce - - method private refresh_style () = - let (renderer, _) = renderer in - let font = Pango.Font.from_string Preferences.text_font#get in - renderer#set_properties [`FONT_DESC font; `XPAD 10] - - method private coordinates pos = - (* Toplevel position w.r.t. screen *) - let (x, y) = Gdk.Window.get_position view#misc#toplevel#misc#window in - (* Position of view w.r.t. window *) - let (ux, uy) = Gdk.Window.get_position view#misc#window in - (* Relative buffer position to view *) - let (dx, dy) = view#window_to_buffer_coords ~tag:`WIDGET ~x:0 ~y:0 in - (* Iter position *) - let iter = view#buffer#get_iter pos in - let coords = view#get_iter_location iter in - let lx = Gdk.Rectangle.x coords in - let ly = Gdk.Rectangle.y coords in - let w = Gdk.Rectangle.width coords in - let h = Gdk.Rectangle.height coords in - (* Absolute position *) - (x + lx + ux - dx, y + ly + uy - dy, w, h) - - method private select_any f = - let sel = data#selection#get_selected_rows in - let path = match sel with - | [] -> - begin match model#store#get_iter_first with - | None -> None - | Some iter -> Some (model#store#get_path iter) - end - | path :: _ -> Some path - in - match path with - | None -> () - | Some path -> - let path = f path in - let _ = data#selection#select_path path in - data#scroll_to_cell ~align:(0.,0.) path col - - method private select_previous () = - let prev path = - let copy = GTree.Path.copy path in - if GTree.Path.prev path then path - else copy - in - self#select_any prev - - method private select_next () = - let next path = - let () = GTree.Path.next path in - path - in - self#select_any next - method private select_previous_page () = - let rec up i path = - if i = 0 then path - else - let copy = GTree.Path.copy path in - let has_prev = GTree.Path.prev path in - if has_prev then up (pred i) path - else copy - in - self#select_any (up page_size) + method matched ctx = + if !active then + let iter = ctx#iter in + let () = insert_offset <- iter#offset in + let log = Printf.sprintf "Completion at offset: %i" insert_offset in + let () = Minilib.log log in + if Gtk_parsing.ends_word iter#backward_char then + let start = Gtk_parsing.find_word_start iter in + iter#offset - start#offset >= auto_complete_length + else false + else false - method private select_next_page () = - let rec down i path = - if i = 0 then path - else - let copy = GTree.Path.copy path in - let iter = model#store#get_iter path in - let has_next = model#store#iter_next iter in - if has_next then down (pred i) (model#store#get_path iter) - else copy - in - self#select_any (down page_size) + method activation = [`INTERACTIVE; `USER_REQUESTED] - method private select_first () = - let rec up path = - let copy = GTree.Path.copy path in - let has_prev = GTree.Path.prev path in - if has_prev then up path - else copy - in - self#select_any up + method info_widget proposal = None - method private select_last () = - let rec down path = - let copy = GTree.Path.copy path in - let iter = model#store#get_iter path in - let has_next = model#store#iter_next iter in - if has_next then down (model#store#get_path iter) - else copy - in - self#select_any down + method update_info proposal info = () - method private select_enter () = - let sel = data#selection#get_selected_rows in - match sel with - | [] -> () - | path :: _ -> - let () = model#handle_proposal path in - self#hide () + method start_iter ctx proposal iter = false - method proposal = - let sel = data#selection#get_selected_rows in - if obj#misc#visible then match sel with - | [] -> None - | path :: _ -> - let row = model#store#get_iter path in - let column = model#column in - let proposal = model#store#get ~row ~column in - Some proposal - else None + method activate_proposal proposal iter = false - method private manage_scrollbar () = - (* HACK: we don't have access to the treeview size because of the lack of - LablGTK binding for certain functions, so we bypass it by approximating - it through the size of the proposals *) - let height = match model#store#get_iter_first with - | None -> -1 - | Some iter -> - let path = model#store#get_path iter in - let area = data#get_cell_area ~path ~col () in - let height = Gdk.Rectangle.height area in - let height = page_size * height in - height - in - let len = ref 0 in - let () = model#store#foreach (fun _ _ -> incr len; false) in - if !len > page_size then - let () = frame#set_vpolicy `ALWAYS in - data#misc#set_size_request ~height () - else - data#misc#set_size_request ~height:(-1) () + method interactive_delay = (-1) - method private refresh () = - let () = frame#set_vpolicy `NEVER in - let () = self#select_first () in - let () = obj#misc#show () in - let () = self#manage_scrollbar () in - obj#resize ~width:1 ~height:1 + method priority = 0 - method private start_callback off = - let (x, y, w, h) = self#coordinates (`OFFSET off) in - let () = obj#move ~x ~y:(y + 3 * h / 2) in - () + end in + let provider = GSourceView3.source_completion_provider provider in + object (self) - method private update_callback (off, word, props) = - if Proposals.is_empty props then self#hide () - else if Proposals.mem word props then self#hide () - else self#refresh () + inherit GSourceView3.source_completion_provider provider#as_source_completion_provider - method private end_callback () = - obj#misc#hide () + method active = !active - method private hide () = self#end_callback () + method set_active b = active := b - initializer - let move_cb _ _ ~extend = self#hide () in - let key_cb ev = - let eval cb = cb (); true in - let ev_key = GdkEvent.Key.keyval ev in - if obj#misc#visible then - if ev_key = GdkKeysyms._Up then eval self#select_previous - else if ev_key = GdkKeysyms._Down then eval self#select_next - else if ev_key = GdkKeysyms._Tab then eval self#select_enter - else if ev_key = GdkKeysyms._Return then eval self#select_enter - else if ev_key = GdkKeysyms._Escape then eval self#hide - else if ev_key = GdkKeysyms._Page_Down then eval self#select_next_page - else if ev_key = GdkKeysyms._Page_Up then eval self#select_previous_page - else if ev_key = GdkKeysyms._Home then eval self#select_first - else if ev_key = GdkKeysyms._End then eval self#select_last - else false - else false - in - (* Style handling *) - let _ = view#misc#connect#style_set ~callback:self#refresh_style in - let _ = self#refresh_style () in - let _ = data#set_resize_mode `PARENT in - let _ = frame#set_resize_mode `PARENT in - (* Callback to model *) - let _ = model#connect#start_completion ~callback:self#start_callback in - let _ = model#connect#update_completion ~callback:self#update_callback in - let _ = model#connect#end_completion ~callback:self#end_callback in - (* Popup interaction *) - let _ = view#event#connect#key_press ~callback:key_cb in - (* Hiding the popup when necessary*) - let _ = view#misc#connect#hide ~callback:obj#misc#hide in - let _ = view#event#connect#button_press ~callback:(fun _ -> self#hide (); false) in - let _ = view#connect#move_cursor ~callback:move_cb in - let _ = view#event#connect#focus_out ~callback:(fun _ -> self#hide (); false) in - () + initializer + self_provider := Some (self :> GSourceView3.source_completion_provider) -end + end diff --git a/ide/wg_Completion.mli b/ide/wg_Completion.mli index ac9e6cd94f..020fe26cfb 100644 --- a/ide/wg_Completion.mli +++ b/ide/wg_Completion.mli @@ -10,27 +10,9 @@ module Proposals : sig type t end -class type complete_model_signals = - object ('a) - method after : 'a - method disconnect : GtkSignal.id -> unit - method start_completion : callback:(int -> unit) -> GtkSignal.id - method update_completion : callback:(int * string * Proposals.t -> unit) -> GtkSignal.id - method end_completion : callback:(unit -> unit) -> GtkSignal.id - end - -class complete_model : Coq.coqtop -> GText.buffer -> +class completion_provider : Coq.coqtop -> object + inherit GSourceView3.source_completion_provider method active : bool - method connect : complete_model_signals method set_active : bool -> unit - method store : GTree.model_filter - method column : string GTree.column - method handle_proposal : Gtk.tree_path -> unit -end - -class complete_popup : complete_model -> GText.view -> -object - method coerce : GObj.widget - method proposal : string option end diff --git a/ide/wg_ScriptView.ml b/ide/wg_ScriptView.ml index 769ce61ee1..b7a35d7e94 100644 --- a/ide/wg_ScriptView.ml +++ b/ide/wg_ScriptView.ml @@ -287,18 +287,17 @@ end class script_view (tv : source_view) (ct : Coq.coqtop) = let view = new GSourceView3.source_view (Gobject.unsafe_cast tv) in -let completion = new Wg_Completion.complete_model ct view#buffer in -let popup = new Wg_Completion.complete_popup completion (view :> GText.view) in +let provider = new Wg_Completion.completion_provider ct in object (self) inherit GSourceView3.source_view (Gobject.unsafe_cast tv) val undo_manager = new undo_manager view#buffer - method auto_complete = completion#active + method auto_complete = provider#active method set_auto_complete flag = - completion#set_active flag + provider#set_active flag method recenter_insert = self#scroll_to_mark @@ -448,7 +447,7 @@ object (self) self#buffer#delete_mark (`MARK insert_mark) - method complete_popup = popup + method proposal : string option = None (* FIXME *) method undo = undo_manager#undo method redo = undo_manager#redo @@ -527,10 +526,15 @@ object (self) stick spaces_instead_of_tabs self self#set_insert_spaces_instead_of_tabs; stick tab_length self self#set_tab_width; stick auto_complete self self#set_auto_complete; + stick auto_complete_delay self (fun d -> self#completion#set_auto_complete_delay d); let cb ft = self#misc#modify_font (GPango.font_description_from_string ft) in stick text_font self cb; + let () = self#completion#set_accelerators 0 in + let () = self#completion#set_show_headers false in + let _ = self#completion#add_provider (provider :> GSourceView3.source_completion_provider) in + () end diff --git a/ide/wg_ScriptView.mli b/ide/wg_ScriptView.mli index 91c8e758a5..4b6591e063 100644 --- a/ide/wg_ScriptView.mli +++ b/ide/wg_ScriptView.mli @@ -28,7 +28,7 @@ object method uncomment : unit -> unit method apply_unicode_binding : unit -> unit method recenter_insert : unit - method complete_popup : Wg_Completion.complete_popup + method proposal : string option end val script_view : Coq.coqtop -> diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 28f4f5aed6..cc0c1e4602 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -678,7 +678,7 @@ let remove_one_coercion inctx c = try match match_coercion_app c with | Some (loc,r,pars,args) when not (!Flags.raw_print || !print_coercions) -> let nargs = List.length args in - (match Classops.hide_coercion r with + (match Coercionops.hide_coercion r with | Some n when (n - pars) < nargs && (inctx || (n - pars)+1 < nargs) -> (* We skip the coercion *) let l = List.skipn (n - pars) args in diff --git a/interp/impargs.ml b/interp/impargs.ml index df28b32f81..e2c732809a 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -646,11 +646,9 @@ let maybe_declare_manual_implicits local ref ?enriching l = if List.exists (fun x -> x.CAst.v <> None) l then declare_manual_implicits local ref ?enriching l -(* TODO: either turn these warnings on and document them, or handle these cases sensibly *) -let warn_set_maximal_deprecated = - CWarnings.create ~name:"set-maximal-deprecated" ~category:"deprecated" - (fun i -> strbrk ("Argument number " ^ string_of_int i ^ " is a trailing implicit so must be maximal")) +let msg_trailing_implicit id = + user_err (strbrk ("Argument " ^ Names.Id.to_string id ^ " is a trailing implicit, so it can't be declared non maximal. Please use { } instead of [ ].")) type implicit_kind = Implicit | MaximallyImplicit | NotImplicit @@ -662,7 +660,7 @@ let compute_implicit_statuses autoimps l = | Name id :: autoimps, Implicit :: manualimps -> let imps' = aux (i+1) (autoimps, manualimps) in let max = set_maximality imps' false in - if max then warn_set_maximal_deprecated i; + if max then msg_trailing_implicit id; Some (ExplByName id, Manual, (max, true)) :: imps' | Anonymous :: _, (Implicit | MaximallyImplicit) :: _ -> user_err ~hdr:"set_implicits" diff --git a/interp/notation.ml b/interp/notation.ml index 5dc1658824..93969f3718 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -1430,7 +1430,7 @@ let isNVar_or_NHole = function NVar _ | NHole _ -> true | _ -> false (**********************************************************************) (* Mapping classes to scopes *) -open Classops +open Coercionops type scope_class = cl_typ diff --git a/interp/notation.mli b/interp/notation.mli index 864e500d56..ea5125f7ec 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -271,7 +271,7 @@ val compute_type_scope : Evd.evar_map -> EConstr.types -> scope_name option (** Get the current scope bound to Sortclass, if it exists *) val current_type_scope_name : unit -> scope_name option -val scope_class_of_class : Classops.cl_typ -> scope_class +val scope_class_of_class : Coercionops.cl_typ -> scope_class (** Building notation key *) diff --git a/kernel/cooking.ml b/kernel/cooking.ml index 261a3510d6..cebbfe4986 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -144,11 +144,11 @@ let abstract_context hyps = in Context.Named.fold_outside fold hyps ~init:([], []) -let abstract_constant_type t (hyps, subst) = +let abstract_as_type t (hyps, subst) = let t = Vars.subst_vars subst t in List.fold_left (fun c d -> mkProd_wo_LetIn d c) t hyps -let abstract_constant_body c (hyps, subst) = +let abstract_as_body c (hyps, subst) = let c = Vars.subst_vars subst c in it_mkLambda_or_LetIn c hyps @@ -192,8 +192,7 @@ let discharge_abstract_universe_context subst abs_ctx auctx = let auctx = Univ.subst_univs_level_abstract_universe_context substf auctx in subst, (AUContext.union abs_ctx auctx) -let lift_univs cb subst auctx0 = - match cb.const_universes with +let lift_univs subst auctx0 = function | Monomorphic ctx -> assert (AUContext.is_empty auctx0); subst, (Monomorphic ctx) @@ -219,7 +218,7 @@ let cook_constr { Opaqueproof.modlist ; abstract } (c, priv) = let expmod = expmod_constr_subst cache modlist usubst in let hyps = Context.Named.map expmod abstract in let hyps = abstract_context hyps in - let c = abstract_constant_body (expmod c) hyps in + let c = abstract_as_body (expmod c) hyps in (c, priv) let cook_constr infos c = @@ -230,11 +229,11 @@ let cook_constant { from = cb; info } = let { Opaqueproof.modlist; abstract } = info in let cache = RefTable.create 13 in let abstract, usubst, abs_ctx = abstract in - let usubst, univs = lift_univs cb usubst abs_ctx in + let usubst, univs = lift_univs usubst abs_ctx cb.const_universes in let expmod = expmod_constr_subst cache modlist usubst in let hyps0 = Context.Named.map expmod abstract in let hyps = abstract_context hyps0 in - let map c = abstract_constant_body (expmod c) hyps in + let map c = abstract_as_body (expmod c) hyps in let body = match cb.const_body with | Undef _ as x -> x | Def cs -> Def (Mod_subst.from_val (map (Mod_subst.force_constr cs))) @@ -243,7 +242,7 @@ let cook_constant { from = cb; info } = | Primitive _ -> CErrors.anomaly (Pp.str "Primitives cannot be cooked") in let const_hyps = Id.Set.diff (Context.Named.to_vars cb.const_hyps) (Context.Named.to_vars hyps0) in - let typ = abstract_constant_type (expmod cb.const_type) hyps in + let typ = abstract_as_type (expmod cb.const_type) hyps in { cook_body = body; cook_type = typ; @@ -259,104 +258,160 @@ let cook_constant { from = cb; info } = (********************************) (* Discharging mutual inductive *) -(* Replace - - Var(y1)..Var(yq):C1..Cq |- Ij:Bj - Var(y1)..Var(yq):C1..Cq; I1..Ip:B1..Bp |- ci : Ti - - by - - |- Ij: (y1..yq:C1..Cq)Bj - I1..Ip:(B1 y1..yq)..(Bp y1..yq) |- ci : (y1..yq:C1..Cq)Ti[Ij:=(Ij y1..yq)] -*) - -let it_mkNamedProd_wo_LetIn b d = - List.fold_left (fun c d -> mkNamedProd_wo_LetIn d c) b d - -let abstract_inductive decls nparamdecls inds = - let open Entries in - let ntyp = List.length inds in - let ndecls = Context.Named.length decls in - let args = Context.Named.to_instance mkVar (List.rev decls) in - let args = Array.of_list args in - let subs = List.init ntyp (fun k -> lift ndecls (mkApp(mkRel (k+1),args))) in - let inds' = - List.map - (function (tname,arity,template,cnames,lc) -> - let lc' = List.map (Vars.substl subs) lc in - let lc'' = List.map (fun b -> it_mkNamedProd_wo_LetIn b decls) lc' in - let arity' = it_mkNamedProd_wo_LetIn arity decls in - (tname,arity',template,cnames,lc'')) - inds in - let nparamdecls' = nparamdecls + Array.length args in -(* To be sure to be the same as before, should probably be moved to cook_inductive *) - let params' = let (_,arity,_,_,_) = List.hd inds' in - let (params,_) = decompose_prod_n_assum nparamdecls' arity in - params +let template_level_of_var ~template_check d = + (* When [template_check], a universe from a section variable may not + be in the universes from the inductive (it must be pre-declared) + so always [None]. *) + if template_check then None + else + let c = Term.strip_prod_assum (RelDecl.get_type d) in + match kind c with + | Sort (Type u) -> Univ.Universe.level u + | _ -> None + +let it_mkProd_wo_LetIn = List.fold_left (fun c d -> mkProd_wo_LetIn d c) + +let abstract_rel_ctx (section_decls,subst) ctx = + (* Dealing with substitutions between contexts is too annoying, so + we reify [ctx] into a big [forall] term and work on that. *) + let t = it_mkProd_or_LetIn mkProp ctx in + let t = Vars.subst_vars subst t in + let t = it_mkProd_wo_LetIn t section_decls in + let ctx, t = decompose_prod_assum t in + assert (Constr.equal t mkProp); + ctx + +let abstract_lc ~ntypes expmod (newparams,subst) c = + let args = Array.rev_of_list (CList.map_filter (fun d -> + if RelDecl.is_local_def d then None + else match RelDecl.get_name d with + | Anonymous -> assert false + | Name id -> Some (mkVar id)) + newparams) in - let ind'' = - List.map - (fun (a,arity,template,c,lc) -> - let _, short_arity = decompose_prod_n_assum nparamdecls' arity in - let shortlc = - List.map (fun c -> snd (decompose_prod_n_assum nparamdecls' c)) lc in - { mind_entry_typename = a; - mind_entry_arity = short_arity; - mind_entry_template = template; - mind_entry_consnames = c; - mind_entry_lc = shortlc }) - inds' - in (params',ind'') - -let refresh_polymorphic_type_of_inductive (_,mip) = - match mip.mind_arity with - | RegularArity s -> s.mind_user_arity, false - | TemplateArity ar -> - let ctx = List.rev mip.mind_arity_ctxt in - mkArity (List.rev ctx, Sorts.sort_of_univ ar.template_level), true + let diff = List.length newparams in + let subs = List.init ntypes (fun k -> + lift diff (mkApp (mkRel (k+1), args))) + in + let c = Vars.substl subs c in + let c = Vars.subst_vars subst (expmod c) in + let c = it_mkProd_wo_LetIn c newparams in + c + +let abstract_projection ~params expmod hyps t = + let t = it_mkProd_or_LetIn t params in + let t = mkArrowR mkProp t in (* dummy type standing in for the inductive *) + let t = abstract_as_type (expmod t) hyps in + let _, t = decompose_prod_n_assum (List.length params + 1 + Context.Rel.nhyps (fst hyps)) t in + t + +let cook_one_ind ~template_check ~ntypes + (section_decls,_ as hyps) expmod mip = + let mind_arity = match mip.mind_arity with + | RegularArity {mind_user_arity=arity;mind_sort=sort} -> + let arity = abstract_as_type (expmod arity) hyps in + let sort = destSort (expmod (mkSort sort)) in + RegularArity {mind_user_arity=arity; mind_sort=sort} + | TemplateArity {template_param_levels=levels;template_level} -> + let sec_levels = CList.map_filter (fun d -> + if RelDecl.is_local_assum d then Some (template_level_of_var ~template_check d) + else None) + section_decls + in + let levels = List.rev_append sec_levels levels in + TemplateArity {template_param_levels=levels;template_level} + in + let mind_arity_ctxt = + let ctx = Context.Rel.map expmod mip.mind_arity_ctxt in + abstract_rel_ctx hyps ctx + in + let mind_user_lc = + Array.map (abstract_lc ~ntypes expmod hyps) + mip.mind_user_lc + in + let mind_nf_lc = Array.map (fun (ctx,t) -> + let lc = it_mkProd_or_LetIn t ctx in + let lc = abstract_lc ~ntypes expmod hyps lc in + decompose_prod_assum lc) + mip.mind_nf_lc + in + { mind_typename = mip.mind_typename; + mind_arity_ctxt; + mind_arity; + mind_consnames = mip.mind_consnames; + mind_user_lc; + mind_nrealargs = mip.mind_nrealargs; + mind_nrealdecls = mip.mind_nrealdecls; + mind_kelim = mip.mind_kelim; + mind_nf_lc; + mind_consnrealargs = mip.mind_consnrealargs; + mind_consnrealdecls = mip.mind_consnrealdecls; + mind_recargs = mip.mind_recargs; (* TODO is this correct? checker should tell us. *) + mind_relevance = mip.mind_relevance; + mind_nb_constant = mip.mind_nb_constant; + mind_nb_args = mip.mind_nb_args; + mind_reloc_tbl = mip.mind_reloc_tbl; + } let cook_inductive { Opaqueproof.modlist; abstract } mib = - let open Entries in let (section_decls, subst, abs_uctx) = abstract in - let nparamdecls = Context.Rel.length mib.mind_params_ctxt in - let subst, ind_univs = - match mib.mind_universes with - | Monomorphic ctx -> Univ.empty_level_subst, Monomorphic_entry ctx - | Polymorphic auctx -> - let subst, auctx = discharge_abstract_universe_context subst abs_uctx auctx in - let subst = Univ.make_instance_subst subst in - let nas = Univ.AUContext.names auctx in - let auctx = Univ.AUContext.repr auctx in - subst, Polymorphic_entry (nas, auctx) - in + let subst, mind_universes = lift_univs subst abs_uctx mib.mind_universes in let cache = RefTable.create 13 in - let discharge c = Vars.subst_univs_level_constr subst (expmod_constr cache modlist c) in - let inds = - Array.map_to_list - (fun mip -> - let ty, template = refresh_polymorphic_type_of_inductive (mib,mip) in - let arity = discharge ty in - let lc = Array.map discharge mip.mind_user_lc in - (mip.mind_typename, - arity, template, - Array.to_list mip.mind_consnames, - Array.to_list lc)) - mib.mind_packets in - let section_decls' = Context.Named.map discharge section_decls in - let (params',inds') = abstract_inductive section_decls' nparamdecls inds in - let record = match mib.mind_record with - | PrimRecord info -> - Some (Some (Array.map (fun (x,_,_,_) -> x) info)) - | FakeRecord -> Some None - | NotRecord -> None + let expmod = expmod_constr_subst cache modlist subst in + let section_decls = Context.Named.map expmod section_decls in + let removed_vars = Context.Named.to_vars section_decls in + let section_decls, _ as hyps = abstract_context section_decls in + let nnewparams = Context.Rel.nhyps section_decls in + let template_check = mib.mind_typing_flags.check_template in + let mind_params_ctxt = + let ctx = Context.Rel.map expmod mib.mind_params_ctxt in + abstract_rel_ctx hyps ctx + in + let ntypes = mib.mind_ntypes in + let mind_packets = + Array.map (cook_one_ind ~template_check ~ntypes hyps expmod) + mib.mind_packets in - { mind_entry_record = record; - mind_entry_finite = mib.mind_finite; - mind_entry_params = params'; - mind_entry_inds = inds'; - mind_entry_private = mib.mind_private; - mind_entry_cumulative = Option.has_some mib.mind_variance; - mind_entry_universes = ind_univs + let mind_record = match mib.mind_record with + | NotRecord -> NotRecord + | FakeRecord -> FakeRecord + | PrimRecord data -> + let data = Array.map (fun (id,projs,relevances,tys) -> + let tys = Array.map (abstract_projection ~params:mib.mind_params_ctxt expmod hyps) tys in + (id,projs,relevances,tys)) + data + in + PrimRecord data + in + let mind_hyps = + List.filter (fun d -> not (Id.Set.mem (NamedDecl.get_id d) removed_vars)) + mib.mind_hyps + in + let mind_variance, mind_sec_variance = + match mib.mind_variance, mib.mind_sec_variance with + | None, None -> None, None + | None, Some _ | Some _, None -> assert false + | Some variance, Some sec_variance -> + let sec_variance, newvariance = + Array.chop (Array.length sec_variance - AUContext.size abs_uctx) + sec_variance + in + Some (Array.append newvariance variance), Some sec_variance + in + { + mind_packets; + mind_record; + mind_finite = mib.mind_finite; + mind_ntypes = mib.mind_ntypes; + mind_hyps; + mind_nparams = mib.mind_nparams + nnewparams; + mind_nparams_rec = mib.mind_nparams_rec + nnewparams; + mind_params_ctxt; + mind_universes; + mind_variance; + mind_sec_variance; + mind_private = mib.mind_private; + mind_typing_flags = mib.mind_typing_flags; } let expmod_constr modlist c = expmod_constr (RefTable.create 13) modlist c diff --git a/kernel/cooking.mli b/kernel/cooking.mli index 83a8b9edfc..c2d47735ec 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -31,7 +31,7 @@ val cook_constr : Opaqueproof.cooking_info list -> (constr * unit Opaqueproof.delayed_universes) -> (constr * unit Opaqueproof.delayed_universes) val cook_inductive : - Opaqueproof.cooking_info -> mutual_inductive_body -> Entries.mutual_inductive_entry + Opaqueproof.cooking_info -> mutual_inductive_body -> mutual_inductive_body (** {6 Utility functions used in module [Discharge]. } *) diff --git a/kernel/declarations.ml b/kernel/declarations.ml index 9fd10b32e6..0b6e59bd5e 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -223,6 +223,11 @@ type mutual_inductive_body = { mind_variance : Univ.Variance.t array option; (** Variance info, [None] when non-cumulative. *) + mind_sec_variance : Univ.Variance.t array option; + (** Variance info for section polymorphic universes. [None] + outside sections. The final variance once all sections are + discharged is [mind_sec_variance ++ mind_variance]. *) + mind_private : bool option; (** allow pattern-matching: Some true ok, Some false blocked *) mind_typing_flags : typing_flags; (** typing flags at the time of the inductive creation *) diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 35185b6a5e..27e3f84464 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -248,6 +248,7 @@ let subst_mind_body sub mib = mind_packets = Array.Smart.map (subst_mind_packet sub) mib.mind_packets ; mind_universes = mib.mind_universes; mind_variance = mib.mind_variance; + mind_sec_variance = mib.mind_sec_variance; mind_private = mib.mind_private; mind_typing_flags = mib.mind_typing_flags; } diff --git a/kernel/indTyping.ml b/kernel/indTyping.ml index d9ccf81619..591cd050a5 100644 --- a/kernel/indTyping.ml +++ b/kernel/indTyping.ml @@ -197,16 +197,14 @@ let unbounded_from_below u cstrs = is u_k and is contributing. *) let template_polymorphic_univs ~template_check ~ctor_levels uctx paramsctxt concl = let check_level l = - if Univ.LSet.mem l (Univ.ContextSet.levels uctx) && - unbounded_from_below l (Univ.ContextSet.constraints uctx) && - not (Univ.LSet.mem l ctor_levels) then - Some l - else None + Univ.LSet.mem l (Univ.ContextSet.levels uctx) && + unbounded_from_below l (Univ.ContextSet.constraints uctx) && + not (Univ.LSet.mem l ctor_levels) in let univs = Univ.Universe.levels concl in let univs = if template_check then - Univ.LSet.filter (fun l -> Option.has_some (check_level l) || Univ.Level.is_prop l) univs + Univ.LSet.filter (fun l -> check_level l || Univ.Level.is_prop l) univs else univs (* Doesn't check the universes can be generalized *) in let fold acc = function @@ -278,7 +276,7 @@ let abstract_packets ~template_check univs usubst params ((arity,lc),(indices,sp let kelim = allowed_sorts univ_info in (arity,lc), (indices,splayed_lc), kelim -let typecheck_inductive env (mie:mutual_inductive_entry) = +let typecheck_inductive env ~sec_univs (mie:mutual_inductive_entry) = let () = match mie.mind_entry_inds with | [] -> CErrors.anomaly Pp.(str "empty inductive types declaration.") | _ -> () @@ -337,8 +335,19 @@ let typecheck_inductive env (mie:mutual_inductive_entry) = data, Some None in - (* TODO pass only the needed bits *) - let variance = InferCumulativity.infer_inductive env mie in + let variance = if not mie.mind_entry_cumulative then None + else match mie.mind_entry_universes with + | Monomorphic_entry _ -> + CErrors.user_err Pp.(str "Inductive cannot be both monomorphic and universe cumulative.") + | Polymorphic_entry (_,uctx) -> + let univs = Instance.to_array @@ UContext.instance uctx in + let univs = match sec_univs with + | None -> univs + | Some sec_univs -> Array.append sec_univs univs + in + let variances = InferCumulativity.infer_inductive ~env_params univs mie.mind_entry_inds in + Some variances + in (* Abstract universes *) let usubst, univs = Declareops.abstract_universes mie.mind_entry_universes in diff --git a/kernel/indTyping.mli b/kernel/indTyping.mli index 5c04e860a2..8dea8f046d 100644 --- a/kernel/indTyping.mli +++ b/kernel/indTyping.mli @@ -17,6 +17,7 @@ open Declarations - environment with inductives + parameters in rel context - abstracted universes - checked variance info + (variance for section universes is at the beginning of the array) - record entry (checked to be OK) - parameters - for each inductive, @@ -24,9 +25,11 @@ open Declarations * (indices * splayed constructor types) (both without params) * top allowed elimination *) -val typecheck_inductive : env -> mutual_inductive_entry -> - env - * universes * Univ.Variance.t array option +val typecheck_inductive : env -> sec_univs:Univ.Level.t array option + -> mutual_inductive_entry + -> env + * universes + * Univ.Variance.t array option * Names.Id.t array option option * Constr.rel_context * ((inductive_arity * Constr.types array) * diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 750ac86908..3771454db5 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -379,17 +379,25 @@ let check_positivity ~chkpos kn names env_ar_par paramsctxt finite inds = (************************************************************************) (* Build the inductive packet *) -let repair_arity indices = function - | RegularArity ar -> ar.mind_user_arity - | TemplateArity ar -> mkArity (indices,Sorts.sort_of_univ ar.template_level) +let fold_arity f acc params arity indices = match arity with + | RegularArity ar -> f acc ar.mind_user_arity + | TemplateArity _ -> + let fold_ctx acc ctx = + List.fold_left (fun acc d -> + Context.Rel.Declaration.fold_constr (fun c acc -> f acc c) d acc) + acc + ctx + in + fold_ctx (fold_ctx acc params) indices -let fold_inductive_blocks f = +let fold_inductive_blocks f acc params inds = Array.fold_left (fun acc ((arity,lc),(indices,_),_) -> - f (Array.fold_left f acc lc) (repair_arity indices arity)) + fold_arity f (Array.fold_left f acc lc) params arity indices) + acc inds -let used_section_variables env inds = +let used_section_variables env params inds = let fold l c = Id.Set.union (Environ.global_vars_set env c) l in - let ids = fold_inductive_blocks fold Id.Set.empty inds in + let ids = fold_inductive_blocks fold Id.Set.empty params inds in keep_hyps env ids let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) @@ -458,10 +466,11 @@ let compute_projections (kn, i as ind) mib = Array.of_list (List.rev rs), Array.of_list (List.rev pbs) -let build_inductive env names prv univs variance paramsctxt kn isrecord isfinite inds nmr recargs = +let build_inductive env ~sec_univs names prv univs variance + paramsctxt kn isrecord isfinite inds nmr recargs = let ntypes = Array.length inds in (* Compute the set of used section variables *) - let hyps = used_section_variables env inds in + let hyps = used_section_variables env paramsctxt inds in let nparamargs = Context.Rel.nhyps paramsctxt in (* Check one inductive *) let build_one_packet (id,cnames) ((arity,lc),(indices,splayed_lc),kelim) recarg = @@ -479,18 +488,17 @@ let build_inductive env names prv univs variance paramsctxt kn isrecord isfinite in (* Assigning VM tags to constructors *) let nconst, nblock = ref 0, ref 0 in - let transf num = - let arity = List.length (dest_subterms recarg).(num) in - if Int.equal arity 0 then - let p = (!nconst, 0) in - incr nconst; p - else - let p = (!nblock + 1, arity) in - incr nblock; p - (* les tag des constructeur constant commence a 0, - les tag des constructeur non constant a 1 (0 => accumulator) *) + let transf arity = + if Int.equal arity 0 then + let p = (!nconst, 0) in + incr nconst; p + else + let p = (!nblock + 1, arity) in + incr nblock; p + (* les tag des constructeur constant commence a 0, + les tag des constructeur non constant a 1 (0 => accumulator) *) in - let rtbl = Array.init (List.length cnames) transf in + let rtbl = Array.map transf consnrealargs in (* Build the inductive packet *) { mind_typename = id; mind_arity = arity; @@ -510,6 +518,15 @@ let build_inductive env names prv univs variance paramsctxt kn isrecord isfinite mind_reloc_tbl = rtbl; } in let packets = Array.map3 build_one_packet names inds recargs in + let variance, sec_variance = match variance with + | None -> None, None + | Some variance -> match sec_univs with + | None -> Some variance, None + | Some sec_univs -> + let nsec = Array.length sec_univs in + Some (Array.sub variance nsec (Array.length variance - nsec)), + Some (Array.sub variance 0 nsec) + in let mib = (* Build the mutual inductive *) { mind_record = NotRecord; @@ -522,6 +539,7 @@ let build_inductive env names prv univs variance paramsctxt kn isrecord isfinite mind_packets = packets; mind_universes = univs; mind_variance = variance; + mind_sec_variance = sec_variance; mind_private = prv; mind_typing_flags = Environ.typing_flags env; } @@ -542,9 +560,11 @@ let build_inductive env names prv univs variance paramsctxt kn isrecord isfinite (************************************************************************) (************************************************************************) -let check_inductive env kn mie = +let check_inductive env ~sec_univs kn mie = (* First type-check the inductive definition *) - let (env_ar_par, univs, variance, record, paramsctxt, inds) = IndTyping.typecheck_inductive env mie in + let (env_ar_par, univs, variance, record, paramsctxt, inds) = + IndTyping.typecheck_inductive env ~sec_univs mie + in (* Then check positivity conditions *) let chkpos = (Environ.typing_flags env).check_positive in let names = Array.map_of_list (fun entry -> entry.mind_entry_typename, entry.mind_entry_consnames) @@ -555,6 +575,6 @@ let check_inductive env kn mie = (Array.map (fun ((_,lc),(indices,_),_) -> Context.Rel.nhyps indices,lc) inds) in (* Build the inductive packets *) - build_inductive env names mie.mind_entry_private univs variance + build_inductive env ~sec_univs names mie.mind_entry_private univs variance paramsctxt kn record mie.mind_entry_finite inds nmr recargs diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli index 240ba4e2bb..9b54e8b878 100644 --- a/kernel/indtypes.mli +++ b/kernel/indtypes.mli @@ -14,4 +14,5 @@ open Environ open Entries (** Check an inductive. *) -val check_inductive : env -> MutInd.t -> mutual_inductive_entry -> mutual_inductive_body +val check_inductive : env -> sec_univs:Univ.Level.t array option + -> MutInd.t -> mutual_inductive_entry -> mutual_inductive_body diff --git a/kernel/inferCumulativity.ml b/kernel/inferCumulativity.ml index 77abe6b410..211c909241 100644 --- a/kernel/inferCumulativity.ml +++ b/kernel/inferCumulativity.ml @@ -188,15 +188,12 @@ let infer_arity_constructor is_arity env variances arcn = open Entries -let infer_inductive_core env params entries uctx = - let uarray = Instance.to_array @@ UContext.instance uctx in - if Array.is_empty uarray then raise TrivialVariance; - let env = Environ.push_context uctx env in +let infer_inductive_core env univs entries = + if Array.is_empty univs then raise TrivialVariance; let variances = Array.fold_left (fun variances u -> LMap.add u IrrelevantI variances) - LMap.empty uarray + LMap.empty univs in - let env, _ = Typeops.check_context env params in let variances = List.fold_left (fun variances entry -> let variances = infer_arity_constructor true env variances entry.mind_entry_arity @@ -210,17 +207,8 @@ let infer_inductive_core env params entries uctx = | exception Not_found -> Invariant | IrrelevantI -> Irrelevant | CovariantI -> Covariant) - uarray - -let infer_inductive env mie = - let open Entries in - let params = mie.mind_entry_params in - let entries = mie.mind_entry_inds in - if not mie.mind_entry_cumulative then None - else - let uctx = match mie.mind_entry_universes with - | Monomorphic_entry _ -> assert false - | Polymorphic_entry (_,uctx) -> uctx - in - try Some (infer_inductive_core env params entries uctx) - with TrivialVariance -> Some (Array.make (UContext.size uctx) Invariant) + univs + +let infer_inductive ~env_params univs entries = + try infer_inductive_core env_params univs entries + with TrivialVariance -> Array.make (Array.length univs) Invariant diff --git a/kernel/inferCumulativity.mli b/kernel/inferCumulativity.mli index 2bddfe21e2..a8f593c7f9 100644 --- a/kernel/inferCumulativity.mli +++ b/kernel/inferCumulativity.mli @@ -8,5 +8,14 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -val infer_inductive : Environ.env -> Entries.mutual_inductive_entry -> - Univ.Variance.t array option +val infer_inductive + : env_params:Environ.env + (** Environment containing the polymorphic universes and the + parameters. *) + -> Univ.Level.t array + (** Universes whose cumulativity we want to infer. *) + -> Entries.one_inductive_entry list + (** The inductive block data we want to infer cumulativity for. + NB: we ignore the template bool and the names, only the terms + are used. *) + -> Univ.Variance.t array diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml index 1cef729916..a62b51e8aa 100644 --- a/kernel/nativelib.ml +++ b/kernel/nativelib.ml @@ -27,15 +27,35 @@ let open_header = List.map mk_open open_header (* Directory where compiled files are stored *) let output_dir = ".coq-native" -(* Extension of genereted ml files, stored for debugging purposes *) +(* Extension of generated ml files, stored for debugging purposes *) let source_ext = ".native" let ( / ) = Filename.concat -(* We have to delay evaluation of include_dirs because coqlib cannot be guessed -until flags have been properly initialized *) +(* Directory for temporary files for the conversion and normalisation + (as opposed to compiling the library itself, which uses [output_dir]). *) +let my_temp_dir = lazy (CUnix.mktemp_dir "Coq_native" "") + +let () = at_exit (fun () -> + if 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); + Unix.rmdir d + with e -> + Feedback.msg_warning + Pp.(str "Native compile: failed to cleanup: " ++ + str(Printexc.to_string e) ++ fnl())) + +(* We have to delay evaluation of include_dirs because coqlib cannot + be guessed until flags have been properly initialized. It also lets + us avoid forcing [my_temp_dir] if we don't need it (eg stdlib file + without native compute or native conv uses). *) let include_dirs () = - [Filename.get_temp_dir_name (); Envars.coqlib () / "kernel"; Envars.coqlib () / "library"] + let base = [Envars.coqlib () / "kernel"; Envars.coqlib () / "library"] in + if Lazy.is_val my_temp_dir + then (Lazy.force my_temp_dir) :: base + else base (* Pointer to the function linking an ML object into coq's toplevel *) let load_obj = ref (fun _x -> () : string -> unit) @@ -44,7 +64,8 @@ let rt1 = ref (dummy_value ()) let rt2 = ref (dummy_value ()) let get_ml_filename () = - let filename = Filename.temp_file "Coq_native" source_ext in + let temp_dir = Lazy.force my_temp_dir in + let filename = Filename.temp_file ~temp_dir "Coq_native" source_ext in let prefix = Filename.chop_extension (Filename.basename filename) ^ "." in filename, prefix diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index ee101400d6..f6f2058c13 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -908,14 +908,19 @@ let check_mind mie lab = (* The label and the first inductive type name should match *) assert (Id.equal (Label.to_id lab) oie.mind_entry_typename) +let add_checked_mind kn mib senv = + let mib = + match mib.mind_hyps with [] -> Declareops.hcons_mind mib | _ -> mib + in + add_field (MutInd.label kn,SFBmind mib) (I kn) senv + let add_mind l mie senv = let () = check_mind mie l in let kn = MutInd.make2 senv.modpath l in - let mib = Indtypes.check_inductive senv.env kn mie in - let mib = - match mib.mind_hyps with [] -> Declareops.hcons_mind mib | _ -> mib + let sec_univs = Option.map Section.all_poly_univs senv.sections in - kn, add_field (l,SFBmind mib) (I kn) senv + let mib = Indtypes.check_inductive senv.env ~sec_univs kn mie in + kn, add_checked_mind kn mib senv (** Insertion of module types *) @@ -1014,9 +1019,8 @@ let close_section senv = add_constant_aux senv (kn, cb) | `Inductive (ind, mib) -> let info = cooking_info (Section.segment_of_inductive env0 ind sections0) in - let mie = Cooking.cook_inductive info mib in - let _, senv = add_mind (MutInd.label ind) mie senv in - senv + let mib = Cooking.cook_inductive info mib in + add_checked_mind ind mib senv in List.fold_left fold senv redo diff --git a/kernel/section.ml b/kernel/section.ml index 603ef5d006..6fa0543b23 100644 --- a/kernel/section.ml +++ b/kernel/section.ml @@ -28,6 +28,8 @@ type 'a t = { sec_mono_universes : ContextSet.t; sec_poly_universes : Name.t array * UContext.t; (** Universes local to the section *) + all_poly_univs : Univ.Level.t array; + (** All polymorphic universes, including from previous sections. *) has_poly_univs : bool; (** Are there polymorphic universes or constraints, including in previous sections. *) sec_entries : section_entry list; @@ -41,6 +43,8 @@ let rec depth sec = 1 + match sec.sec_prev with None -> 0 | Some prev -> depth p let has_poly_univs sec = sec.has_poly_univs +let all_poly_univs sec = sec.all_poly_univs + let find_emap e (cmap, imap) = match e with | SecDefinition con -> Cmap.find con cmap | SecInductive ind -> Mindmap.find ind imap @@ -57,7 +61,10 @@ let push_context (nas, ctx) sec = else let (snas, sctx) = sec.sec_poly_universes in let sec_poly_universes = (Array.append snas nas, UContext.union sctx ctx) in - { sec with sec_poly_universes; has_poly_univs = true } + let all_poly_univs = + Array.append sec.all_poly_univs (Instance.to_array @@ UContext.instance ctx) + in + { sec with sec_poly_universes; all_poly_univs; has_poly_univs = true } let rec is_polymorphic_univ u sec = let (_, uctx) = sec.sec_poly_universes in @@ -81,6 +88,7 @@ let open_section ~custom sec_prev = sec_context = 0; sec_mono_universes = ContextSet.empty; sec_poly_universes = ([||], UContext.empty); + all_poly_univs = Option.cata (fun sec -> sec.all_poly_univs) [| |] sec_prev; has_poly_univs = Option.cata has_poly_univs false sec_prev; sec_entries = []; sec_data = (Cmap.empty, Mindmap.empty); diff --git a/kernel/section.mli b/kernel/section.mli index fbd3d8254e..37d0dab317 100644 --- a/kernel/section.mli +++ b/kernel/section.mli @@ -57,6 +57,14 @@ val push_inductive : poly:bool -> MutInd.t -> 'a t -> 'a t (** {6 Retrieving section data} *) +val all_poly_univs : 'a t -> Univ.Level.t array +(** Returns all polymorphic universes, including those from previous + sections. Earlier sections are earlier in the array. + + NB: even if the array is empty there may be polymorphic + constraints about monomorphic universes, which prevent declaring + monomorphic globals. *) + type abstr_info = private { abstr_ctx : Constr.named_context; (** Section variables of this prefix *) diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index 33336079bb..4d15ce741c 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -128,7 +128,7 @@ let enforce_leq_alg u v g = | exception (UniverseInconsistency _ as e) -> Inr e) in (* max(us) <= max(vs) <-> forall u in us, exists v in vs, u <= v *) - let c = Universe.map (fun u -> Universe.map (fun v -> (u,v)) v) u in + let c = List.map (fun u -> List.map (fun v -> (u,v)) (Universe.repr v)) (Universe.repr u) in let c = List.cartesians enforce_one (Inl (Constraint.empty,g)) c in (* We pick a best constraint: smallest number of constraints, not an error if possible. *) let order x y = match x, y with diff --git a/kernel/uint63_31.ml b/kernel/uint63_31.ml index e38389ca13..445166f6af 100644 --- a/kernel/uint63_31.ml +++ b/kernel/uint63_31.ml @@ -15,8 +15,8 @@ let _ = assert (Sys.word_size = 32) let uint_size = 63 -let maxuint63 = Int64.of_string "0x7FFFFFFFFFFFFFFF" -let maxuint31 = Int64.of_string "0x7FFFFFFF" +let maxuint63 = 0x7FFF_FFFF_FFFF_FFFFL +let maxuint31 = 0x7FFF_FFFFL let zero = Int64.zero let one = Int64.one @@ -118,27 +118,30 @@ let div21 xh xl y = let div21 xh xl y = if Int64.compare y xh <= 0 then zero, zero else div21 xh xl y - (* exact multiplication *) +(* exact multiplication *) let mulc x y = - let lx = ref (Int64.logand x maxuint31) in - let ly = ref (Int64.logand y maxuint31) in + let lx = Int64.logand x maxuint31 in + let ly = Int64.logand y maxuint31 in let hx = Int64.shift_right x 31 in let hy = Int64.shift_right y 31 in - let hr = ref (Int64.mul hx hy) in - let lr = ref (Int64.logor (Int64.mul !lx !ly) (Int64.shift_left !hr 62)) in - hr := (Int64.shift_right_logical !hr 1); - lx := Int64.mul !lx hy; - ly := Int64.mul hx !ly; - hr := Int64.logor !hr (Int64.add (Int64.shift_right !lx 32) (Int64.shift_right !ly 32)); - lr := Int64.add !lr (Int64.shift_left !lx 31); - hr := Int64.add !hr (Int64.shift_right_logical !lr 63); - lr := Int64.add (Int64.shift_left !ly 31) (mask63 !lr); - hr := Int64.add !hr (Int64.shift_right_logical !lr 63); - if Int64.logand !lr Int64.min_int <> 0L - then Int64.(sub !hr one, mask63 !lr) - else (!hr, !lr) - -let equal x y = mask63 x = mask63 y + (* compute the median products *) + let s = Int64.add (Int64.mul lx hy) (Int64.mul hx ly) in + (* s fits on 64 bits, split it into a 33-bit high part and a 31-bit low part *) + let lr = Int64.shift_left (Int64.logand s maxuint31) 31 in + let hr = Int64.shift_right_logical s 31 in + (* add the outer products *) + let lr = Int64.add (Int64.mul lx ly) lr in + let hr = Int64.add (Int64.mul hx hy) hr in + (* hr fits on 64 bits, since the final result fits on 126 bits *) + (* now x * y = hr * 2^62 + lr and lr < 2^63 *) + let lr = Int64.add lr (Int64.shift_left (Int64.logand hr 1L) 62) in + let hr = Int64.shift_right_logical hr 1 in + (* now x * y = hr * 2^63 + lr, but lr might be too large *) + if Int64.logand lr Int64.min_int <> 0L + then Int64.add hr 1L, mask63 lr + else hr, lr + +let equal (x : t) y = x = y let compare x y = Int64.compare x y diff --git a/kernel/univ.ml b/kernel/univ.ml index 0029ff96d5..94f7076c02 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -42,6 +42,8 @@ struct let make dp i = (DirPath.hcons dp,i) + let repr x : t = x + let equal (d, i) (d', i') = DirPath.equal d d' && Int.equal i i' let hash (d,i) = Hashset.Combine.combine i (DirPath.hash d) @@ -320,8 +322,9 @@ struct if u == v then 0 else let (x, n) = u and (x', n') = v in - if Int.equal n n' then Level.compare x x' - else n - n' + let c = Int.compare n n' in + if Int.equal 0 c then Level.compare x x' + else c let sprop = hcons (Level.sprop, 0) let prop = hcons (Level.prop, 0) @@ -345,8 +348,8 @@ struct (Level.is_prop u && not (Level.is_sprop v)) else false - let successor (u,n) = - if Level.is_small u then type1 + let successor (u,n as e) = + if is_small e then type1 else (u, n + 1) let addn k (u,n as x) = @@ -427,6 +430,10 @@ struct let hcons = Hashcons.recursive_hcons Huniv.generate Huniv.hcons Expr.hcons + module Self = struct type nonrec t = t let compare = compare end + module Map = CMap.Make(Self) + module Set = CSet.Make(Self) + let make l = tip (Expr.make l) let tip x = tip x @@ -524,15 +531,10 @@ struct Used to type the products. *) let sup x y = merge_univs x y - let empty = [] - let exists = List.exists let for_all = List.for_all - - let smart_map = List.Smart.map - - let map = List.map + let repr x : t = x end type universe = Universe.t @@ -550,8 +552,6 @@ let pr_uni = Universe.pr let sup = Universe.sup let super = Universe.super -open Universe - let universe_level = Universe.level @@ -576,7 +576,7 @@ type univ_inconsistency = constraint_type * universe * universe * explanation La exception UniverseInconsistency of univ_inconsistency let error_inconsistency o u v p = - raise (UniverseInconsistency (o,make u,make v,p)) + raise (UniverseInconsistency (o,Universe.make u,Universe.make v,p)) (* Constraints and sets of constraints. *) @@ -677,7 +677,7 @@ let enforce_eq u v c = let constraint_add_leq v u c = (* We just discard trivial constraints like u<=u *) - if Expr.equal v u then c + if Universe.Expr.equal v u then c else match v, u with | (x,n), (y,m) -> @@ -695,13 +695,13 @@ let constraint_add_leq v u c = else if Level.is_small x then c (* Prop,Set <= u+S k, trivial *) else Constraint.add (x,Le,y) c (* u <= v implies u <= v+k *) -let check_univ_leq_one u v = Universe.exists (Expr.leq u) v +let check_univ_leq_one u v = Universe.exists (Universe.Expr.leq u) v let check_univ_leq u v = Universe.for_all (fun u -> check_univ_leq_one u v) u let enforce_leq u v c = - match is_sprop u, is_sprop v with + match Universe.is_sprop u, Universe.is_sprop v with | true, true -> c | true, false | false, true -> raise (UniverseInconsistency (Le, u, v, None)) @@ -755,6 +755,10 @@ struct | Invariant, _ | _, Invariant -> Invariant | Covariant, Covariant -> Covariant + let equal a b = match a,b with + | Irrelevant, Irrelevant | Covariant, Covariant | Invariant, Invariant -> true + | (Irrelevant | Covariant | Invariant), _ -> false + let check_subtype x y = match x, y with | (Irrelevant | Covariant | Invariant), Irrelevant -> true | Irrelevant, Covariant -> false @@ -921,7 +925,7 @@ let subst_instance_instance s i = let subst_instance_universe s u = let f x = Universe.Expr.map (fun u -> subst_instance_level s u) x in - let u' = Universe.smart_map f u in + let u' = List.Smart.map f u in if u == u' then u else Universe.sort u' @@ -1104,7 +1108,7 @@ let subst_univs_level_level subst l = let subst_univs_level_universe subst u = let f x = Universe.Expr.map (fun u -> subst_univs_level_level subst u) x in - let u' = Universe.smart_map f u in + let u' = List.Smart.map f u in if u == u' then u else Universe.sort u' @@ -1146,7 +1150,7 @@ let subst_univs_universe fn ul = if CList.is_empty subst then ul else let substs = - List.fold_left Universe.merge_univs Universe.empty subst + List.fold_left Universe.merge_univs [] subst in List.fold_left (fun acc u -> Universe.merge_univs acc (Universe.tip u)) substs nosubst diff --git a/kernel/univ.mli b/kernel/univ.mli index ccb5c80cbf..94e57b9efc 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -16,6 +16,7 @@ sig type t val make : Names.DirPath.t -> int -> t + val repr : t -> Names.DirPath.t * int val equal : t -> t -> bool val hash : t -> int val compare : t -> t -> int @@ -138,8 +139,10 @@ sig val exists : (Level.t * int -> bool) -> t -> bool val for_all : (Level.t * int -> bool) -> t -> bool + val repr : t -> (Level.t * int) list - val map : (Level.t * int -> 'a) -> t -> 'a list + module Set : CSet.S with type elt = t + module Map : CMap.ExtS with type key = t and module Set := Set end @@ -263,6 +266,8 @@ sig val pr : t -> Pp.t + val equal : t -> t -> bool + end (** {6 Universe instances} *) @@ -320,7 +325,7 @@ val in_punivs : 'a -> 'a puniverses val eq_puniverses : ('a -> 'a -> bool) -> 'a puniverses -> 'a puniverses -> bool (** A vector of universe levels with universe Constraint.t, - representiong local universe variables and associated Constraint.t *) + representing local universe variables and associated Constraint.t *) module UContext : sig diff --git a/lib/cErrors.ml b/lib/cErrors.ml index b9735d0579..9f496f5845 100644 --- a/lib/cErrors.ml +++ b/lib/cErrors.ml @@ -12,7 +12,7 @@ open Pp (** Aliases *) -let push = Backtrace.add_backtrace +let push = Exninfo.capture (* Errors *) @@ -51,12 +51,10 @@ let raw_anomaly e = match e with | _ -> str "Uncaught exception " ++ str (Printexc.to_string e) ++ str "." -let print_backtrace e = match Backtrace.get_backtrace e with +let print_backtrace e = match Exninfo.get_backtrace e with | None -> mt () | Some bt -> - let bt = Backtrace.repr bt in - let pr_frame f = str (Backtrace.print_frame f) in - let bt = prlist_with_sep fnl pr_frame bt in + let bt = str (Exninfo.backtrace_to_string bt) in fnl () ++ hov 0 bt let print_anomaly askreport e = diff --git a/lib/control.ml b/lib/control.ml index 7d54838df8..e67e88ee95 100644 --- a/lib/control.ml +++ b/lib/control.ml @@ -38,7 +38,7 @@ let unix_timeout n f x e = restore_timeout (); res with e -> - let e = Backtrace.add_backtrace e in + let e = Exninfo.capture e in restore_timeout (); Exninfo.iraise e @@ -76,7 +76,7 @@ let windows_timeout n f x e = else raise e | e -> let () = killed := true in - let e = Backtrace.add_backtrace e in + let e = Exninfo.capture e in Exninfo.iraise e type timeout = { timeout : 'a 'b. int -> ('a -> 'b) -> 'a -> exn -> 'b } @@ -102,7 +102,7 @@ let protect_sigalrm f x = | true, Sys.Signal_handle f -> f Sys.sigalrm; res | _, _ -> res with e -> - let e = Backtrace.add_backtrace e in + let e = Exninfo.capture e in Sys.set_signal Sys.sigalrm old_handler; Exninfo.iraise e with Invalid_argument _ -> (* This happens on Windows, as handling SIGALRM does not seem supported *) diff --git a/lib/flags.ml b/lib/flags.ml index b87ba46634..ad48024761 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -19,7 +19,7 @@ let with_modified_ref ?(restore=true) r nf f x = if restore || pre == !r then r := old_ref; res with reraise -> - let reraise = Backtrace.add_backtrace reraise in + let reraise = Exninfo.capture reraise in r := old_ref; Exninfo.iraise reraise @@ -37,7 +37,7 @@ let with_options ol f x = let r = f x in let () = List.iter2 (:=) ol vl in r with reraise -> - let reraise = Backtrace.add_backtrace reraise in + let reraise = Exninfo.capture reraise in let () = List.iter2 (:=) ol vl in Exninfo.iraise reraise diff --git a/lib/future.ml b/lib/future.ml index d3ea538549..5cccd2038d 100644 --- a/lib/future.ml +++ b/lib/future.ml @@ -12,13 +12,13 @@ let not_ready_msg = ref (fun name -> Pp.strbrk("The value you are asking for ("^name^") is not ready yet. "^ "Please wait or pass "^ "the \"-async-proofs off\" option to CoqIDE to disable "^ - "asynchronous script processing and don't pass \"-quick\" to "^ + "asynchronous script processing and don't pass \"-vio\" to "^ "coqc.")) let not_here_msg = ref (fun name -> Pp.strbrk("The value you are asking for ("^name^") is not available "^ "in this process. If you really need this, pass "^ "the \"-async-proofs off\" option to CoqIDE to disable "^ - "asynchronous script processing and don't pass \"-quick\" to "^ + "asynchronous script processing and don't pass \"-vio\" to "^ "coqc.")) let customize_not_ready_msg f = not_ready_msg := f @@ -203,7 +203,7 @@ let pp_with ft pp = in try pp_cmd pp with reraise -> - let reraise = Backtrace.add_backtrace reraise in + let reraise = Exninfo.capture reraise in let () = Format.pp_print_flush ft () in Exninfo.iraise reraise diff --git a/library/globnames.ml b/library/globnames.ml index acb05f9ac0..63cb2c69bd 100644 --- a/library/globnames.ml +++ b/library/globnames.ml @@ -123,7 +123,3 @@ module ExtRefOrdered = struct | SynDef kn -> combinesmall 2 (KerName.hash kn) end - -type global_reference_or_constr = - | IsGlobal of GlobRef.t - | IsConstr of constr diff --git a/library/globnames.mli b/library/globnames.mli index 48cbb11b66..d61cdd2b64 100644 --- a/library/globnames.mli +++ b/library/globnames.mli @@ -59,7 +59,3 @@ module ExtRefOrdered : sig val equal : t -> t -> bool val hash : t -> int end - -type global_reference_or_constr = - | IsGlobal of GlobRef.t - | IsConstr of constr diff --git a/library/lib.ml b/library/lib.ml index 9cce9b92ad..7f96adeecf 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -500,7 +500,7 @@ let close_section () = type frozen = lib_state -let freeze ~marshallable = !lib_state +let freeze () = !lib_state let unfreeze st = lib_state := st diff --git a/library/lib.mli b/library/lib.mli index 0d03046dc2..1fe72389f6 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -151,7 +151,7 @@ val close_section : unit -> unit type frozen -val freeze : marshallable:bool -> frozen +val freeze : unit -> frozen val unfreeze : frozen -> unit (** Keep only the libobject structure, not the objects themselves *) diff --git a/library/states.ml b/library/states.ml index 0be153d96a..90303a2a5c 100644 --- a/library/states.ml +++ b/library/states.ml @@ -18,7 +18,7 @@ let replace_summary (lib,_) st = lib, st let replace_lib (_,st) lib = lib, st let freeze ~marshallable = - (Lib.freeze ~marshallable, Summary.freeze_summaries ~marshallable) + (Lib.freeze (), Summary.freeze_summaries ~marshallable) let unfreeze (fl,fs) = Lib.unfreeze fl; diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 734dd8ee8a..26afdcb9d5 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -533,6 +533,7 @@ let extend_entry_command (type a) (type b) (tag : (a, b) entry_command) (g : a) try EntryDataMap.find tag !camlp5_entries with Not_found -> EntryData.Ex String.Map.empty in + let () = assert (not @@ String.Map.mem name old) in let entries = String.Map.add name e old in camlp5_entries := EntryDataMap.add tag (EntryData.Ex entries) !camlp5_entries in diff --git a/plugins/extraction/ExtrOcamlChar.v b/plugins/extraction/ExtrOcamlChar.v new file mode 100644 index 0000000000..1e68365dd3 --- /dev/null +++ b/plugins/extraction/ExtrOcamlChar.v @@ -0,0 +1,45 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* Extraction to Ocaml : extract ascii to OCaml's char type *) + +Require Coq.extraction.Extraction. + +Require Import Ascii String Coq.Strings.Byte. + +Extract Inductive ascii => char +[ +"(* If this appears, you're using Ascii internals. Please don't *) + (fun (b0,b1,b2,b3,b4,b5,b6,b7) -> + let f b i = if b then 1 lsl i else 0 in + Char.chr (f b0 0 + f b1 1 + f b2 2 + f b3 3 + f b4 4 + f b5 5 + f b6 6 + f b7 7))" +] +"(* If this appears, you're using Ascii internals. Please don't *) + (fun f c -> + let n = Char.code c in + let h i = (n land (1 lsl i)) <> 0 in + f (h 0) (h 1) (h 2) (h 3) (h 4) (h 5) (h 6) (h 7))". + +Extract Constant zero => "'\000'". +Extract Constant one => "'\001'". +Extract Constant shift => + "fun b c -> Char.chr (((Char.code c) lsl 1) land 255 + if b then 1 else 0)". + +Extract Inlined Constant ascii_dec => "(=)". +Extract Inlined Constant Ascii.eqb => "(=)". + +(* python -c 'print(" ".join(r""" "%s" """.strip() % (r"'"'\''"'" if chr(i) == "'"'"'" else repr(""" "" """.strip()) if chr(i) == """ " """.strip() else repr(chr(i))) for i in range(256)))' # " to satisfy Coq's comment parser *) +Extract Inductive byte => char +["'\x00'" "'\x01'" "'\x02'" "'\x03'" "'\x04'" "'\x05'" "'\x06'" "'\x07'" "'\x08'" "'\t'" "'\n'" "'\x0b'" "'\x0c'" "'\r'" "'\x0e'" "'\x0f'" "'\x10'" "'\x11'" "'\x12'" "'\x13'" "'\x14'" "'\x15'" "'\x16'" "'\x17'" "'\x18'" "'\x19'" "'\x1a'" "'\x1b'" "'\x1c'" "'\x1d'" "'\x1e'" "'\x1f'" "' '" "'!'" "'""'" "'#'" "'$'" "'%'" "'&'" "'\''" "'('" "')'" "'*'" "'+'" "','" "'-'" "'.'" "'/'" "'0'" "'1'" "'2'" "'3'" "'4'" "'5'" "'6'" "'7'" "'8'" "'9'" "':'" "';'" "'<'" "'='" "'>'" "'?'" "'@'" "'A'" "'B'" "'C'" "'D'" "'E'" "'F'" "'G'" "'H'" "'I'" "'J'" "'K'" "'L'" "'M'" "'N'" "'O'" "'P'" "'Q'" "'R'" "'S'" "'T'" "'U'" "'V'" "'W'" "'X'" "'Y'" "'Z'" "'['" "'\\'" "']'" "'^'" "'_'" "'`'" "'a'" "'b'" "'c'" "'d'" "'e'" "'f'" "'g'" "'h'" "'i'" "'j'" "'k'" "'l'" "'m'" "'n'" "'o'" "'p'" "'q'" "'r'" "'s'" "'t'" "'u'" "'v'" "'w'" "'x'" "'y'" "'z'" "'{'" "'|'" "'}'" "'~'" "'\x7f'" "'\x80'" "'\x81'" "'\x82'" "'\x83'" "'\x84'" "'\x85'" "'\x86'" "'\x87'" "'\x88'" "'\x89'" "'\x8a'" "'\x8b'" "'\x8c'" "'\x8d'" "'\x8e'" "'\x8f'" "'\x90'" "'\x91'" "'\x92'" "'\x93'" "'\x94'" "'\x95'" "'\x96'" "'\x97'" "'\x98'" "'\x99'" "'\x9a'" "'\x9b'" "'\x9c'" "'\x9d'" "'\x9e'" "'\x9f'" "'\xa0'" "'\xa1'" "'\xa2'" "'\xa3'" "'\xa4'" "'\xa5'" "'\xa6'" "'\xa7'" "'\xa8'" "'\xa9'" "'\xaa'" "'\xab'" "'\xac'" "'\xad'" "'\xae'" "'\xaf'" "'\xb0'" "'\xb1'" "'\xb2'" "'\xb3'" "'\xb4'" "'\xb5'" "'\xb6'" "'\xb7'" "'\xb8'" "'\xb9'" "'\xba'" "'\xbb'" "'\xbc'" "'\xbd'" "'\xbe'" "'\xbf'" "'\xc0'" "'\xc1'" "'\xc2'" "'\xc3'" "'\xc4'" "'\xc5'" "'\xc6'" "'\xc7'" "'\xc8'" "'\xc9'" "'\xca'" "'\xcb'" "'\xcc'" "'\xcd'" "'\xce'" "'\xcf'" "'\xd0'" "'\xd1'" "'\xd2'" "'\xd3'" "'\xd4'" "'\xd5'" "'\xd6'" "'\xd7'" "'\xd8'" "'\xd9'" "'\xda'" "'\xdb'" "'\xdc'" "'\xdd'" "'\xde'" "'\xdf'" "'\xe0'" "'\xe1'" "'\xe2'" "'\xe3'" "'\xe4'" "'\xe5'" "'\xe6'" "'\xe7'" "'\xe8'" "'\xe9'" "'\xea'" "'\xeb'" "'\xec'" "'\xed'" "'\xee'" "'\xef'" "'\xf0'" "'\xf1'" "'\xf2'" "'\xf3'" "'\xf4'" "'\xf5'" "'\xf6'" "'\xf7'" "'\xf8'" "'\xf9'" "'\xfa'" "'\xfb'" "'\xfc'" "'\xfd'" "'\xfe'" "'\xff'"]. + +Extract Inlined Constant Byte.eqb => "(=)". +Extract Inlined Constant Byte.byte_eq_dec => "(=)". +Extract Inlined Constant Ascii.ascii_of_byte => "(fun x -> x)". +Extract Inlined Constant Ascii.byte_of_ascii => "(fun x -> x)". diff --git a/plugins/extraction/ExtrOcamlNativeString.v b/plugins/extraction/ExtrOcamlNativeString.v new file mode 100644 index 0000000000..ec3da1e444 --- /dev/null +++ b/plugins/extraction/ExtrOcamlNativeString.v @@ -0,0 +1,87 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* Extraction to Ocaml : extract ascii to OCaml's char type + and string to OCaml's string type. *) + +Require Coq.extraction.Extraction. + +Require Import Ascii String Coq.Strings.Byte. +Require Export ExtrOcamlChar. + +(* python -c 'print(" ".join(r""" "%s" """.strip() % (r"'"'\''"'" if chr(i) == "'"'"'" else repr(""" "" """.strip()) if chr(i) == """ " """.strip() else repr(chr(i))) for i in range(256)))' # " to satisfy Coq's comment parser *) +Extract Inductive byte => char +["'\x00'" "'\x01'" "'\x02'" "'\x03'" "'\x04'" "'\x05'" "'\x06'" "'\x07'" "'\x08'" "'\t'" "'\n'" "'\x0b'" "'\x0c'" "'\r'" "'\x0e'" "'\x0f'" "'\x10'" "'\x11'" "'\x12'" "'\x13'" "'\x14'" "'\x15'" "'\x16'" "'\x17'" "'\x18'" "'\x19'" "'\x1a'" "'\x1b'" "'\x1c'" "'\x1d'" "'\x1e'" "'\x1f'" "' '" "'!'" "'""'" "'#'" "'$'" "'%'" "'&'" "'\''" "'('" "')'" "'*'" "'+'" "','" "'-'" "'.'" "'/'" "'0'" "'1'" "'2'" "'3'" "'4'" "'5'" "'6'" "'7'" "'8'" "'9'" "':'" "';'" "'<'" "'='" "'>'" "'?'" "'@'" "'A'" "'B'" "'C'" "'D'" "'E'" "'F'" "'G'" "'H'" "'I'" "'J'" "'K'" "'L'" "'M'" "'N'" "'O'" "'P'" "'Q'" "'R'" "'S'" "'T'" "'U'" "'V'" "'W'" "'X'" "'Y'" "'Z'" "'['" "'\\'" "']'" "'^'" "'_'" "'`'" "'a'" "'b'" "'c'" "'d'" "'e'" "'f'" "'g'" "'h'" "'i'" "'j'" "'k'" "'l'" "'m'" "'n'" "'o'" "'p'" "'q'" "'r'" "'s'" "'t'" "'u'" "'v'" "'w'" "'x'" "'y'" "'z'" "'{'" "'|'" "'}'" "'~'" "'\x7f'" "'\x80'" "'\x81'" "'\x82'" "'\x83'" "'\x84'" "'\x85'" "'\x86'" "'\x87'" "'\x88'" "'\x89'" "'\x8a'" "'\x8b'" "'\x8c'" "'\x8d'" "'\x8e'" "'\x8f'" "'\x90'" "'\x91'" "'\x92'" "'\x93'" "'\x94'" "'\x95'" "'\x96'" "'\x97'" "'\x98'" "'\x99'" "'\x9a'" "'\x9b'" "'\x9c'" "'\x9d'" "'\x9e'" "'\x9f'" "'\xa0'" "'\xa1'" "'\xa2'" "'\xa3'" "'\xa4'" "'\xa5'" "'\xa6'" "'\xa7'" "'\xa8'" "'\xa9'" "'\xaa'" "'\xab'" "'\xac'" "'\xad'" "'\xae'" "'\xaf'" "'\xb0'" "'\xb1'" "'\xb2'" "'\xb3'" "'\xb4'" "'\xb5'" "'\xb6'" "'\xb7'" "'\xb8'" "'\xb9'" "'\xba'" "'\xbb'" "'\xbc'" "'\xbd'" "'\xbe'" "'\xbf'" "'\xc0'" "'\xc1'" "'\xc2'" "'\xc3'" "'\xc4'" "'\xc5'" "'\xc6'" "'\xc7'" "'\xc8'" "'\xc9'" "'\xca'" "'\xcb'" "'\xcc'" "'\xcd'" "'\xce'" "'\xcf'" "'\xd0'" "'\xd1'" "'\xd2'" "'\xd3'" "'\xd4'" "'\xd5'" "'\xd6'" "'\xd7'" "'\xd8'" "'\xd9'" "'\xda'" "'\xdb'" "'\xdc'" "'\xdd'" "'\xde'" "'\xdf'" "'\xe0'" "'\xe1'" "'\xe2'" "'\xe3'" "'\xe4'" "'\xe5'" "'\xe6'" "'\xe7'" "'\xe8'" "'\xe9'" "'\xea'" "'\xeb'" "'\xec'" "'\xed'" "'\xee'" "'\xef'" "'\xf0'" "'\xf1'" "'\xf2'" "'\xf3'" "'\xf4'" "'\xf5'" "'\xf6'" "'\xf7'" "'\xf8'" "'\xf9'" "'\xfa'" "'\xfb'" "'\xfc'" "'\xfd'" "'\xfe'" "'\xff'"]. + +Extract Inlined Constant Byte.eqb => "(=)". +Extract Inlined Constant Byte.byte_eq_dec => "(=)". +Extract Inlined Constant Ascii.ascii_of_byte => "(fun x -> x)". +Extract Inlined Constant Ascii.byte_of_ascii => "(fun x -> x)". + +(* This differs from ExtrOcamlString.v: the latter extracts "string" + to "char list", and we extract "string" to "string" *) + +Extract Inductive string => "string" +[ +(* EmptyString *) +"(* If this appears, you're using String internals. Please don't *) + """" +" +(* String *) +"(* If this appears, you're using String internals. Please don't *) + (fun (c, s) -> String.make 1 c ^ s) +" +] +"(* If this appears, you're using String internals. Please don't *) + (fun f0 f1 s -> + let l = String.length s in + if l = 0 then f0 else f1 (String.get s 0) (String.sub s 1 (l-1))) +". + +Extract Inlined Constant String.string_dec => "(=)". +Extract Inlined Constant String.eqb => "(=)". +Extract Inlined Constant String.append => "(^)". +Extract Inlined Constant String.concat => "String.concat". +Extract Inlined Constant String.prefix => + "(fun s1 s2 -> + let l1 = String.length s1 and l2 = String.length s2 in + l1 <= l2 && String.sub s2 0 l1 = s1)". +Extract Inlined Constant String.string_of_list_ascii => + "(fun l -> + let a = Array.of_list l in + String.init (Array.length a) (fun i -> a.(i)))". +Extract Inlined Constant String.list_ascii_of_string => + "(fun s -> + Array.to_list (Array.init (String.length s) (fun i -> s.[i])))". +Extract Inlined Constant String.string_of_list_byte => + "(fun l -> + let a = Array.of_list l in + String.init (Array.length a) (fun i -> a.(i)))". +Extract Inlined Constant String.list_byte_of_string => + "(fun s -> + Array.to_list (Array.init (String.length s) (fun i -> s.[i])))". + +(* Other operations in module String (at the time of this writing): + String.length + String.get + String.substring + String.index + String.findex + They all use type "nat". If we know that "nat" extracts + to O | S of nat, we can provide OCaml implementations + for these functions that work directly on OCaml's strings. + However "nat" could be extracted to other OCaml types... +*) + +(* +Definition test := "ceci est un test"%string. + +Recursive Extraction test Ascii.zero Ascii.one. +*) diff --git a/plugins/extraction/ExtrOcamlString.v b/plugins/extraction/ExtrOcamlString.v index 6265a67577..18c5ed3fe4 100644 --- a/plugins/extraction/ExtrOcamlString.v +++ b/plugins/extraction/ExtrOcamlString.v @@ -13,43 +13,6 @@ Require Coq.extraction.Extraction. Require Import Ascii String Coq.Strings.Byte. - -Extract Inductive ascii => char -[ -"(* If this appears, you're using Ascii internals. Please don't *) - (fun (b0,b1,b2,b3,b4,b5,b6,b7) -> - let f b i = if b then 1 lsl i else 0 in - Char.chr (f b0 0 + f b1 1 + f b2 2 + f b3 3 + f b4 4 + f b5 5 + f b6 6 + f b7 7))" -] -"(* If this appears, you're using Ascii internals. Please don't *) - (fun f c -> - let n = Char.code c in - let h i = (n land (1 lsl i)) <> 0 in - f (h 0) (h 1) (h 2) (h 3) (h 4) (h 5) (h 6) (h 7))". - -Extract Constant zero => "'\000'". -Extract Constant one => "'\001'". -Extract Constant shift => - "fun b c -> Char.chr (((Char.code c) lsl 1) land 255 + if b then 1 else 0)". - -Extract Inlined Constant ascii_dec => "(=)". -Extract Inlined Constant Ascii.eqb => "(=)". +Require Export ExtrOcamlChar. Extract Inductive string => "char list" [ "[]" "(::)" ]. - -(* python -c 'print(" ".join(r""" "%s" """.strip() % (r"'"'\''"'" if chr(i) == "'"'"'" else repr(""" "" """.strip()) if chr(i) == """ " """.strip() else repr(chr(i))) for i in range(256)))' # " to satisfy Coq's comment parser *) -Extract Inductive byte => char -["'\x00'" "'\x01'" "'\x02'" "'\x03'" "'\x04'" "'\x05'" "'\x06'" "'\x07'" "'\x08'" "'\t'" "'\n'" "'\x0b'" "'\x0c'" "'\r'" "'\x0e'" "'\x0f'" "'\x10'" "'\x11'" "'\x12'" "'\x13'" "'\x14'" "'\x15'" "'\x16'" "'\x17'" "'\x18'" "'\x19'" "'\x1a'" "'\x1b'" "'\x1c'" "'\x1d'" "'\x1e'" "'\x1f'" "' '" "'!'" "'""'" "'#'" "'$'" "'%'" "'&'" "'\''" "'('" "')'" "'*'" "'+'" "','" "'-'" "'.'" "'/'" "'0'" "'1'" "'2'" "'3'" "'4'" "'5'" "'6'" "'7'" "'8'" "'9'" "':'" "';'" "'<'" "'='" "'>'" "'?'" "'@'" "'A'" "'B'" "'C'" "'D'" "'E'" "'F'" "'G'" "'H'" "'I'" "'J'" "'K'" "'L'" "'M'" "'N'" "'O'" "'P'" "'Q'" "'R'" "'S'" "'T'" "'U'" "'V'" "'W'" "'X'" "'Y'" "'Z'" "'['" "'\\'" "']'" "'^'" "'_'" "'`'" "'a'" "'b'" "'c'" "'d'" "'e'" "'f'" "'g'" "'h'" "'i'" "'j'" "'k'" "'l'" "'m'" "'n'" "'o'" "'p'" "'q'" "'r'" "'s'" "'t'" "'u'" "'v'" "'w'" "'x'" "'y'" "'z'" "'{'" "'|'" "'}'" "'~'" "'\x7f'" "'\x80'" "'\x81'" "'\x82'" "'\x83'" "'\x84'" "'\x85'" "'\x86'" "'\x87'" "'\x88'" "'\x89'" "'\x8a'" "'\x8b'" "'\x8c'" "'\x8d'" "'\x8e'" "'\x8f'" "'\x90'" "'\x91'" "'\x92'" "'\x93'" "'\x94'" "'\x95'" "'\x96'" "'\x97'" "'\x98'" "'\x99'" "'\x9a'" "'\x9b'" "'\x9c'" "'\x9d'" "'\x9e'" "'\x9f'" "'\xa0'" "'\xa1'" "'\xa2'" "'\xa3'" "'\xa4'" "'\xa5'" "'\xa6'" "'\xa7'" "'\xa8'" "'\xa9'" "'\xaa'" "'\xab'" "'\xac'" "'\xad'" "'\xae'" "'\xaf'" "'\xb0'" "'\xb1'" "'\xb2'" "'\xb3'" "'\xb4'" "'\xb5'" "'\xb6'" "'\xb7'" "'\xb8'" "'\xb9'" "'\xba'" "'\xbb'" "'\xbc'" "'\xbd'" "'\xbe'" "'\xbf'" "'\xc0'" "'\xc1'" "'\xc2'" "'\xc3'" "'\xc4'" "'\xc5'" "'\xc6'" "'\xc7'" "'\xc8'" "'\xc9'" "'\xca'" "'\xcb'" "'\xcc'" "'\xcd'" "'\xce'" "'\xcf'" "'\xd0'" "'\xd1'" "'\xd2'" "'\xd3'" "'\xd4'" "'\xd5'" "'\xd6'" "'\xd7'" "'\xd8'" "'\xd9'" "'\xda'" "'\xdb'" "'\xdc'" "'\xdd'" "'\xde'" "'\xdf'" "'\xe0'" "'\xe1'" "'\xe2'" "'\xe3'" "'\xe4'" "'\xe5'" "'\xe6'" "'\xe7'" "'\xe8'" "'\xe9'" "'\xea'" "'\xeb'" "'\xec'" "'\xed'" "'\xee'" "'\xef'" "'\xf0'" "'\xf1'" "'\xf2'" "'\xf3'" "'\xf4'" "'\xf5'" "'\xf6'" "'\xf7'" "'\xf8'" "'\xf9'" "'\xfa'" "'\xfb'" "'\xfc'" "'\xfd'" "'\xfe'" "'\xff'"]. - -Extract Inlined Constant Byte.eqb => "(=)". -Extract Inlined Constant Byte.byte_eq_dec => "(=)". -Extract Inlined Constant Ascii.ascii_of_byte => "(fun x -> x)". -Extract Inlined Constant Ascii.byte_of_ascii => "(fun x -> x)". - -(* -Definition test := "ceci est un test"%string. -Definition test2 := List.map (option_map Byte.to_nat) (List.map Byte.of_nat (List.seq 0 256)). -Definition test3 := List.map ascii_of_nat (List.seq 0 256). - -Recursive Extraction test Ascii.zero Ascii.one test2 test3 byte_rect. -*) diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml index 2f3f42c5f6..29da12de40 100644 --- a/plugins/extraction/common.ml +++ b/plugins/extraction/common.ml @@ -14,7 +14,6 @@ open Names open ModPath open Namegen open Nameops -open Libnames open Table open Miniml open Mlutil @@ -616,10 +615,15 @@ let pp_module mp = [Extract Inductive ascii => char] has been declared, then the constants are directly turned into chars *) -let mk_ind path s = - MutInd.make2 (MPfile (dirpath_of_string path)) (Label.make s) +let ascii_type_name = "core.ascii.type" +let ascii_constructor_name = "core.ascii.ascii" -let ind_ascii = mk_ind "Coq.Strings.Ascii" "ascii" +let is_ascii_registered () = + Coqlib.has_ref ascii_type_name + && Coqlib.has_ref ascii_constructor_name + +let ascii_type_ref () = Coqlib.lib_ref ascii_type_name +let ascii_constructor_ref () = Coqlib.lib_ref ascii_constructor_name let check_extract_ascii () = try @@ -628,15 +632,18 @@ let check_extract_ascii () = | Haskell -> "Prelude.Char" | _ -> raise Not_found in - String.equal (find_custom (GlobRef.IndRef (ind_ascii, 0))) (char_type) + String.equal (find_custom @@ ascii_type_ref ()) (char_type) with Not_found -> false let is_list_cons l = List.for_all (function MLcons (_,GlobRef.ConstructRef(_,_),[]) -> true | _ -> false) l let is_native_char = function - | MLcons(_,GlobRef.ConstructRef ((kn,0),1),l) -> - MutInd.equal kn ind_ascii && check_extract_ascii () && is_list_cons l + | MLcons(_,gr,l) -> + is_ascii_registered () + && GlobRef.equal gr (ascii_constructor_ref ()) + && check_extract_ascii () + && is_list_cons l | _ -> false let get_native_char c = @@ -649,3 +656,84 @@ let get_native_char c = Char.chr (cumul l) let pp_native_char c = str ("'"^Char.escaped (get_native_char c)^"'") + +(** Special hack for constants of type String.string : if an + [Extract Inductive string => string] has been declared, then + the constants are directly turned into string literals *) + +let string_type_name = "core.string.type" +let empty_string_name = "core.string.empty" +let string_constructor_name = "core.string.string" + +let is_string_registered () = + Coqlib.has_ref string_type_name + && Coqlib.has_ref empty_string_name + && Coqlib.has_ref string_constructor_name + +let string_type_ref () = Coqlib.lib_ref string_type_name +let empty_string_ref () = Coqlib.lib_ref empty_string_name +let string_constructor_ref () = Coqlib.lib_ref string_constructor_name + +let check_extract_string () = + try + let string_type = match lang () with + | Ocaml -> "string" + | Haskell -> "Prelude.String" + | _ -> raise Not_found + in + String.equal (find_custom @@ string_type_ref ()) string_type + with Not_found -> false + +(* The argument is known to be of type Coq.Strings.String.string. + Check that it is built from constructors EmptyString and String + with constant ascii arguments. *) + +let rec is_native_string_rec empty_string_ref string_constructor_ref = function + (* "EmptyString" constructor *) + | MLcons(_, gr, []) -> GlobRef.equal gr empty_string_ref + (* "String" constructor *) + | MLcons(_, gr, [hd; tl]) -> + GlobRef.equal gr string_constructor_ref + && is_native_char hd + && is_native_string_rec empty_string_ref string_constructor_ref tl + (* others *) + | _ -> false + +(* Here we first check that the argument is the type registered as + core.string.type and that extraction to native strings was + requested. Then we check every character via + [is_native_string_rec]. *) + +let is_native_string c = + match c with + | MLcons(_, GlobRef.ConstructRef(ind, j), l) -> + is_string_registered () + && GlobRef.equal (GlobRef.IndRef ind) (string_type_ref ()) + && check_extract_string () + && is_native_string_rec (empty_string_ref ()) (string_constructor_ref ()) c + | _ -> false + +(* Extract the underlying string. *) + +let get_native_string c = + let buf = Buffer.create 64 in + let rec get = function + (* "EmptyString" constructor *) + | MLcons(_, gr, []) when GlobRef.equal gr (empty_string_ref ()) -> + Buffer.contents buf + (* "String" constructor *) + | MLcons(_, gr, [hd; tl]) when GlobRef.equal gr (string_constructor_ref ()) -> + Buffer.add_char buf (get_native_char hd); + get tl + (* others *) + | _ -> assert false + in get c + +(* Printing the underlying string. *) + +let pp_native_string c = + str ("\"" ^ String.escaped (get_native_string c) ^ "\"") + +(* Registered sig type *) + +let sig_type_ref () = Coqlib.lib_ref "core.sig.type" diff --git a/plugins/extraction/common.mli b/plugins/extraction/common.mli index e4e9c4c527..9dbc09dd06 100644 --- a/plugins/extraction/common.mli +++ b/plugins/extraction/common.mli @@ -70,10 +70,6 @@ val reset_renaming_tables : reset_kind -> unit val set_keywords : Id.Set.t -> unit -(** For instance: [mk_ind "Coq.Init.Datatypes" "nat"] *) - -val mk_ind : string -> string -> MutInd.t - (** Special hack for constants of type Ascii.ascii : if an [Extract Inductive ascii => char] has been declared, then the constants are directly turned into chars *) @@ -81,3 +77,14 @@ val mk_ind : string -> string -> MutInd.t val is_native_char : ml_ast -> bool val get_native_char : ml_ast -> char val pp_native_char : ml_ast -> Pp.t + +(** Special hack for constants of type String.string : if an + [Extract Inductive string => string] has been declared, then + the constants are directly turned into string literals *) + +val is_native_string : ml_ast -> bool +val get_native_string : ml_ast -> string +val pp_native_string : ml_ast -> Pp.t + +(* Registered sig type *) +val sig_type_ref : unit -> GlobRef.t diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml index f0053ba6b5..eef050efbd 100644 --- a/plugins/extraction/haskell.ml +++ b/plugins/extraction/haskell.ml @@ -109,8 +109,8 @@ let rec pp_type par vl t = (try Id.print (List.nth vl (pred i)) with Failure _ -> (str "a" ++ int i)) | Tglob (r,[]) -> pp_global Type r - | Tglob (GlobRef.IndRef(kn,0),l) - when not (keep_singleton ()) && MutInd.equal kn (mk_ind "Coq.Init.Specif" "sig") -> + | Tglob (gr,l) + when not (keep_singleton ()) && GlobRef.equal gr (sig_type_ref ()) -> pp_type true vl (List.hd l) | Tglob (r,l) -> pp_par par @@ -171,6 +171,7 @@ let rec pp_expr par env args = assert (List.is_empty args); begin match a with | _ when is_native_char c -> pp_native_char c + | _ when is_native_string c -> pp_native_string c | [] -> pp_global Cons r | [a] -> pp_par par (pp_global Cons r ++ spc () ++ pp_expr true env [] a) diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index 66429833b9..97cad87825 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -165,8 +165,8 @@ let pp_type par vl t = | Tglob (r,[a1;a2]) when is_infix r -> pp_par par (pp_rec true a1 ++ str (get_infix r) ++ pp_rec true a2) | Tglob (r,[]) -> pp_global Type r - | Tglob (GlobRef.IndRef(kn,0),l) - when not (keep_singleton ()) && MutInd.equal kn (mk_ind "Coq.Init.Specif" "sig") -> + | Tglob (gr,l) + when not (keep_singleton ()) && GlobRef.equal gr (sig_type_ref ()) -> pp_tuple_light pp_rec l | Tglob (r,l) -> pp_tuple_light pp_rec l ++ spc () ++ pp_global Type r @@ -249,6 +249,7 @@ let rec pp_expr par env args = assert (List.is_empty args); begin match a with | _ when is_native_char c -> pp_native_char c + | _ when is_native_string c -> pp_native_string c | [a1;a2] when is_infix r -> let pp = pp_expr true env [] in pp_par par (pp a1 ++ str (get_infix r) ++ pp a2) diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index 2f26226f4e..4e7482d4af 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -18,11 +18,11 @@ open Tacticals.New let update_flags ()= let open TransparentState in - let f accu coe = match coe.Classops.coe_value with + let f accu coe = match coe.Coercionops.coe_value with | Names.GlobRef.ConstRef kn -> { accu with tr_cst = Names.Cpred.remove kn accu.tr_cst } | _ -> accu in - let flags = List.fold_left f TransparentState.full (Classops.coercions ()) in + let flags = List.fold_left f TransparentState.full (Coercionops.coercions ()) in red_flags:= CClosure.RedFlags.red_add_transparent CClosure.betaiotazeta diff --git a/plugins/ltac/evar_tactics.ml b/plugins/ltac/evar_tactics.ml index c87eb7c3c9..3ea4974a87 100644 --- a/plugins/ltac/evar_tactics.ml +++ b/plugins/ltac/evar_tactics.ml @@ -26,9 +26,9 @@ module NamedDecl = Context.Named.Declaration (* The instantiate tactic *) -let instantiate_evar evk (ist,rawc) sigma = +let instantiate_evar evk (ist,rawc) env sigma = let evi = Evd.find sigma evk in - let filtered = Evd.evar_filtered_env evi in + let filtered = Evd.evar_filtered_env env evi in let constrvars = Tacinterp.extract_ltac_constr_values ist filtered in let lvar = { ltac_constrs = constrvars; @@ -36,7 +36,7 @@ let instantiate_evar evk (ist,rawc) sigma = ltac_idents = Names.Id.Map.empty; ltac_genargs = ist.Geninterp.lfun; } in - let sigma' = w_refine (evk,evi) (lvar ,rawc) sigma in + let sigma' = w_refine (evk,evi) (lvar ,rawc) env sigma in tclEVARS sigma' let evar_list sigma c = @@ -48,6 +48,7 @@ let evar_list sigma c = let instantiate_tac n c ido = Proofview.V82.tactic begin fun gl -> + let env = Global.env () in let sigma = gl.sigma in let evl = match ido with @@ -69,16 +70,17 @@ let instantiate_tac n c ido = user_err Pp.(str "Not enough uninstantiated existential variables."); if n <= 0 then user_err Pp.(str "Incorrect existential variable index."); let evk,_ = List.nth evl (n-1) in - instantiate_evar evk c sigma gl + instantiate_evar evk c env sigma gl end let instantiate_tac_by_name id c = Proofview.V82.tactic begin fun gl -> + let env = Global.env () in let sigma = gl.sigma in let evk = try Evd.evar_key id sigma with Not_found -> user_err Pp.(str "Unknown existential variable.") in - instantiate_evar evk c sigma gl + instantiate_evar evk c env sigma gl end let let_evar name typ = diff --git a/plugins/micromega/Zify.v b/plugins/micromega/Zify.v index 785a53fafa..18cd196148 100644 --- a/plugins/micromega/Zify.v +++ b/plugins/micromega/Zify.v @@ -87,4 +87,4 @@ Ltac applySpec S := (** [zify_post_hook] is there to be redefined. *) Ltac zify_post_hook := idtac. -Ltac zify := zify_op ; (iter_specs applySpec) ; zify_post_hook. +Ltac zify := zify_op ; (zify_iter_specs applySpec) ; zify_post_hook. diff --git a/plugins/micromega/ZifyInst.v b/plugins/micromega/ZifyInst.v index 97f6fe0613..edfb5a2a94 100644 --- a/plugins/micromega/ZifyInst.v +++ b/plugins/micromega/ZifyInst.v @@ -523,3 +523,22 @@ Instance SatProdPos : Saturate Z.mul := SatOk := Z.mul_pos_pos |}. Add Saturate SatProdPos. + +Lemma pow_pos_strict : + forall a b, + 0 < a -> 0 < b -> 0 < a ^ b. +Proof. + intros. + apply Z.pow_pos_nonneg; auto. + apply Z.lt_le_incl;auto. +Qed. + + +Instance SatPowPos : Saturate Z.pow := + {| + PArg1 := fun x => 0 < x; + PArg2 := fun y => 0 < y; + PRes := fun r => 0 < r; + SatOk := pow_pos_strict + |}. +Add Saturate SatPowPos. diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index cb15274736..61234145e1 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -395,50 +395,40 @@ let saturate_by_linear_equalities sys = output_sys sys output_sys sys'; sys' -(* let saturate_linear_equality_non_linear sys0 = - let (l,_) = extract_all (is_substitution false) sys0 in - let rec elim l acc = - match l with - | [] -> acc - | (v,pc)::l' -> - let nc = saturate (non_linear_pivot sys0 pc v) (sys0@acc) in - elim l' (nc@acc) in - elim l [] - *) - -let bounded_vars (sys : WithProof.t list) = - let l = fst (extract_all (fun ((p, o), prf) -> LinPoly.is_variable p) sys) in - List.fold_left (fun acc (i, wp) -> IMap.add i wp acc) IMap.empty l - -let rec power n p = if n = 1 then p else WithProof.product p (power (n - 1) p) - -let bound_monomial mp m = - if Monomial.is_var m || Monomial.is_const m then None - else - try - Some - (Monomial.fold - (fun v i acc -> - let wp = IMap.find v mp in - WithProof.product (power i wp) acc) - m (WithProof.const (Int 1))) - with Not_found -> None - let bound_monomials (sys : WithProof.t list) = - let mp = bounded_vars sys in - let m = + let l = + extract_all + (fun ((p, o), _) -> + match LinPoly.get_bound p with + | None -> None + | Some Vect.Bound.{cst; var; coeff} -> + Some (Monomial.degree (LinPoly.MonT.retrieve var))) + sys + in + let deg = + List.fold_left (fun acc ((p, o), _) -> max acc (LinPoly.degree p)) 0 sys + in + let vars = List.fold_left - (fun acc ((p, _), _) -> - Vect.fold - (fun acc v _ -> - let m = LinPoly.MonT.retrieve v in - match bound_monomial mp m with - | None -> acc - | Some r -> IMap.add v r acc) - acc p) - IMap.empty sys + (fun acc ((p, o), _) -> ISet.union (LinPoly.monomials p) acc) + ISet.empty sys + in + let bounds = + saturate_bin + (fun (i1, w1) (i2, w2) -> + if i1 + i2 > deg then None + else + match WithProof.mul_bound w1 w2 with + | None -> None + | Some b -> Some (i1 + i2, b)) + (fst l) + in + let has_mon (_, ((p, o), _)) = + match LinPoly.get_bound p with + | None -> false + | Some Vect.Bound.{cst; var; coeff} -> ISet.mem var vars in - IMap.fold (fun _ e acc -> e :: acc) m [] + List.map snd (List.filter has_mon bounds) @ snd l let develop_constraints prfdepth n_spec sys = LinPoly.MonT.clear (); diff --git a/plugins/micromega/g_zify.mlg b/plugins/micromega/g_zify.mlg index 66f263c0b1..2b5fac32a2 100644 --- a/plugins/micromega/g_zify.mlg +++ b/plugins/micromega/g_zify.mlg @@ -34,12 +34,13 @@ VERNAC COMMAND EXTEND DECLAREINJECTION CLASSIFIED AS SIDEFF END TACTIC EXTEND ITER -| [ "iter_specs" tactic(t)] -> { Zify.iter_specs t } +| [ "zify_iter_specs" tactic(t)] -> { Zify.iter_specs t } END TACTIC EXTEND TRANS | [ "zify_op" ] -> { Zify.zify_tac } -| [ "saturate" ] -> { Zify.saturate } +| [ "zify_saturate" ] -> { Zify.saturate } +| [ "zify_iter_let" tactic(t)] -> { Zify.iter_let t } END VERNAC COMMAND EXTEND ZifyPrint CLASSIFIED AS SIDEFF diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml index 03f042647c..160b492d3d 100644 --- a/plugins/micromega/mutils.ml +++ b/plugins/micromega/mutils.ml @@ -140,6 +140,25 @@ let saturate p f sys = Printexc.print_backtrace stdout; raise x +let saturate_bin (f : 'a -> 'a -> 'a option) (l : 'a list) = + let rec map_with acc e l = + match l with + | [] -> acc + | e' :: l' -> ( + match f e e' with + | None -> map_with acc e l' + | Some r -> map_with (r :: acc) e l' ) + in + let rec map2_with acc l' = + match l' with [] -> acc | e' :: l' -> map2_with (map_with acc e' l) l' + in + let rec iterate acc l' = + match map2_with [] l' with + | [] -> List.rev_append l' acc + | res -> iterate (List.rev_append l' acc) res + in + iterate [] l + open Num open Big_int diff --git a/plugins/micromega/mutils.mli b/plugins/micromega/mutils.mli index ef8d154b13..5dcaf3be44 100644 --- a/plugins/micromega/mutils.mli +++ b/plugins/micromega/mutils.mli @@ -116,6 +116,7 @@ val simplify : ('a -> 'a option) -> 'a list -> 'a list option val saturate : ('a -> 'b option) -> ('b * 'a -> 'a -> 'a option) -> 'a list -> 'a list +val saturate_bin : ('a -> 'a -> 'a option) -> 'a list -> 'a list val generate : ('a -> 'b option) -> 'a list -> 'b list val app_funs : ('a -> 'b option) list -> 'a -> 'b option val command : string -> string array -> 'a -> 'b diff --git a/plugins/micromega/polynomial.ml b/plugins/micromega/polynomial.ml index a4f9b60b14..b20213979b 100644 --- a/plugins/micromega/polynomial.ml +++ b/plugins/micromega/polynomial.ml @@ -379,6 +379,8 @@ module LinPoly = struct else acc) [] l + let get_bound p = Vect.Bound.of_vect p + let min_list (l : int list) = match l with [] -> None | e :: l -> Some (List.fold_left min e l) @@ -892,8 +894,9 @@ module WithProof = struct if Vect.is_null r && n >/ Int 0 then ((LinPoly.product p p1, o1), ProofFormat.mul_cst_proof n prf1) else ( - Printf.printf "mult_error %a [*] %a\n" LinPoly.pp p output - ((p1, o1), prf1); + if debug then + Printf.printf "mult_error %a [*] %a\n" LinPoly.pp p output + ((p1, o1), prf1); raise InvalidProof ) let cutting_plane ((p, o), prf) = @@ -1027,6 +1030,31 @@ module WithProof = struct else None in saturate select gen sys0 + + open Vect.Bound + + let mul_bound w1 w2 = + let (p1, o1), prf1 = w1 in + let (p2, o2), prf2 = w2 in + match (LinPoly.get_bound p1, LinPoly.get_bound p2) with + | None, _ | _, None -> None + | ( Some {cst = c1; var = v1; coeff = c1'} + , Some {cst = c2; var = v2; coeff = c2'} ) -> ( + let good_coeff b o = + match o with + | Eq -> Some (minus_num b) + | _ -> if b <=/ Int 0 then Some (minus_num b) else None + in + match (good_coeff c1 o2, good_coeff c2 o1) with + | None, _ | _, None -> None + | Some c1, Some c2 -> + let ext_mult c w = + if c =/ Int 0 then zero else mult (LinPoly.constant c) w + in + Some + (addition + (addition (product w1 w2) (ext_mult c1 w2)) + (ext_mult c2 w1)) ) end (* Local Variables: *) diff --git a/plugins/micromega/polynomial.mli b/plugins/micromega/polynomial.mli index 7e905ac69b..4b56b037e0 100644 --- a/plugins/micromega/polynomial.mli +++ b/plugins/micromega/polynomial.mli @@ -224,6 +224,8 @@ module LinPoly : sig p is linear in x i.e x does not occur in b and a is a constant such that [pred a] *) + val get_bound : t -> Vect.Bound.t option + val product : t -> t -> t (** [product p q] @return the product of the polynomial [p*q] *) @@ -372,4 +374,5 @@ module WithProof : sig val saturate_subst : bool -> t list -> t list val is_substitution : bool -> t -> var option + val mul_bound : t -> t -> t option end diff --git a/plugins/micromega/zify.ml b/plugins/micromega/zify.ml index 5d8ae83853..e71c89b4db 100644 --- a/plugins/micromega/zify.ml +++ b/plugins/micromega/zify.ml @@ -965,6 +965,43 @@ let trans_concl t = let tclTHENOpt e tac tac' = match e with None -> tac' | Some e' -> Tacticals.New.tclTHEN (tac e') tac' +let assert_inj t = + init_cache (); + Proofview.Goal.enter (fun gl -> + let env = Tacmach.New.pf_env gl in + let evd = Tacmach.New.project gl in + try + ignore (get_injection env evd t); + Tacticals.New.tclIDTAC + with Not_found -> + Tacticals.New.tclFAIL 0 (Pp.str " InjTyp does not exist")) + +let do_let tac (h : Constr.named_declaration) = + match h with + | Context.Named.Declaration.LocalAssum _ -> Tacticals.New.tclIDTAC + | Context.Named.Declaration.LocalDef (id, t, ty) -> + Proofview.Goal.enter (fun gl -> + let env = Tacmach.New.pf_env gl in + let evd = Tacmach.New.project gl in + try + ignore (get_injection env evd (EConstr.of_constr ty)); + tac id.Context.binder_name t ty + with Not_found -> Tacticals.New.tclIDTAC) + +let iter_let tac = + Proofview.Goal.enter (fun gl -> + let env = Tacmach.New.pf_env gl in + let sign = Environ.named_context env in + Tacticals.New.tclMAP (do_let tac) sign) + +let iter_let (tac : Ltac_plugin.Tacinterp.Value.t) = + init_cache (); + iter_let (fun (id : Names.Id.t) (t : Constr.types) (ty : Constr.types) -> + Ltac_plugin.Tacinterp.Value.apply tac + [ Ltac_plugin.Tacinterp.Value.of_constr (EConstr.mkVar id) + ; Ltac_plugin.Tacinterp.Value.of_constr (EConstr.of_constr t) + ; Ltac_plugin.Tacinterp.Value.of_constr (EConstr.of_constr ty) ]) + let zify_tac = Proofview.Goal.enter (fun gl -> Coqlib.check_required_library ["Coq"; "micromega"; "ZifyClasses"]; diff --git a/plugins/micromega/zify.mli b/plugins/micromega/zify.mli index 9e3cf5d24c..4930a845c9 100644 --- a/plugins/micromega/zify.mli +++ b/plugins/micromega/zify.mli @@ -27,3 +27,5 @@ module Saturate : S val zify_tac : unit Proofview.tactic val saturate : unit Proofview.tactic val iter_specs : Ltac_plugin.Tacinterp.Value.t -> unit Proofview.tactic +val assert_inj : EConstr.constr -> unit Proofview.tactic +val iter_let : Ltac_plugin.Tacinterp.Value.t -> unit Proofview.tactic diff --git a/plugins/omega/PreOmega.v b/plugins/omega/PreOmega.v index f5d53cbbf3..34533670f8 100644 --- a/plugins/omega/PreOmega.v +++ b/plugins/omega/PreOmega.v @@ -573,27 +573,16 @@ Ltac zify_N := repeat zify_N_rel; repeat zify_N_op; unfold Z_of_N' in *. Require Import ZifyClasses ZifyInst. Require Zify. - -(** [is_inj T] returns true iff the type T has an injection *) -Ltac is_inj T := - match T with - | _ => let x := constr:(_ : InjTyp T _ ) in true - | _ => false - end. - (* [elim_let] replaces a let binding (x := e : t) by an equation (x = e) if t is an injected type *) -Ltac elim_let := - repeat - match goal with - | x := ?t : ?ty |- _ => - let b := is_inj ty in - match b with - | true => let h := fresh "heq_" x in pose proof (eq_refl : x = t) as h; clearbody x - end - end. +Ltac elim_binding x t ty := + let h := fresh "heq_" x in + pose proof (@eq_refl ty x : @eq ty x t) as h; + try clearbody x. + +Ltac elim_let := zify_iter_let elim_binding. Ltac zify := intros ; elim_let ; - Zify.zify ; ZifyInst.saturate. + Zify.zify ; ZifyInst.zify_saturate. diff --git a/plugins/omega/g_omega.mlg b/plugins/omega/g_omega.mlg index 84964a7bd2..7c653b223e 100644 --- a/plugins/omega/g_omega.mlg +++ b/plugins/omega/g_omega.mlg @@ -21,40 +21,9 @@ DECLARE PLUGIN "omega_plugin" { open Ltac_plugin -open Names -open Coq_omega -open Stdarg - -let eval_tactic name = - let dp = DirPath.make (List.map Id.of_string ["PreOmega"; "omega"; "Coq"]) in - let kn = KerName.make (ModPath.MPfile dp) (Label.make name) in - let tac = Tacenv.interp_ltac kn in - Tacinterp.eval_tactic tac - -let omega_tactic l = - let tacs = List.map - (function - | "nat" -> eval_tactic "zify_nat" - | "positive" -> eval_tactic "zify_positive" - | "N" -> eval_tactic "zify_N" - | "Z" -> eval_tactic "zify_op" - | s -> CErrors.user_err Pp.(str ("No Omega knowledge base for type "^s))) - (Util.List.sort_uniquize String.compare l) - in - Tacticals.New.tclTHEN - (Tacticals.New.tclREPEAT (Tacticals.New.tclTHENLIST tacs)) - (omega_solver) } TACTIC EXTEND omega -| [ "omega" ] -> { omega_tactic [] } +| [ "omega" ] -> { Coq_omega.omega_solver } END - -TACTIC EXTEND omega' -| [ "omega" "with" ne_ident_list(l) ] -> - { omega_tactic (List.map Names.Id.to_string l) } -| [ "omega" "with" "*" ] -> - { Tacticals.New.tclTHEN (eval_tactic "zify") (omega_tactic []) } -END - diff --git a/plugins/ssr/ssrsetoid.v b/plugins/ssr/ssrsetoid.v index 609c9d5ab8..7c5cd135fe 100644 --- a/plugins/ssr/ssrsetoid.v +++ b/plugins/ssr/ssrsetoid.v @@ -18,9 +18,7 @@ than [eq] or [iff], e.g. a [RewriteRelation], by doing: [Require Import ssreflect. Require Setoid.] - This file's instances have priority 12 > other stdlib instances - and each [Under_rel] instance comes with a [Hint Cut] directive - (otherwise Ring_polynom.v won't compile because of unbounded search). + This file's instances have priority 12 > other stdlib instances. (Note: this file could be skipped when porting [under] to stdlib2.) *) @@ -38,85 +36,3 @@ Instance compat_Reflexive : RelationClasses.Reflexive R -> ssrclasses.Reflexive R | 12. Proof. now trivial. Qed. - -(** Add instances so that ['Under[ F i ]] terms, - that is, [Under_rel T R (F i) (?G i)] terms, - can be manipulated with rewrite/setoid_rewrite with lemmas on [R]. - Note that this requires that [R] is a [Prop] relation, otherwise - a [bool] relation may need to be "lifted": see the [TestPreOrder] - section in test-suite/ssr/under.v *) - -Instance Under_subrelation {A} (R : relation A) : subrelation R (Under_rel _ R) | 12. -Proof. now rewrite Under_relE. Qed. - -(* see also Morphisms.trans_co_eq_inv_impl_morphism *) - -Instance Under_Reflexive {A} (R : relation A) : - RelationClasses.Reflexive R -> - RelationClasses.Reflexive (Under_rel.Under_rel A R) | 12. -Proof. now rewrite Under_rel.Under_relE. Qed. - -Hint Cut [_* Under_Reflexive Under_Reflexive] : typeclass_instances. - -(* These instances are a bit off-topic given that (Under_rel A R) will - typically be reflexive, to be able to trigger the [over] terminator - -Instance under_Irreflexive {A} (R : relation A) : - RelationClasses.Irreflexive R -> - RelationClasses.Irreflexive (Under_rel.Under_rel A R) | 12. -Proof. now rewrite Under_rel.Under_relE. Qed. - -Hint Cut [_* Under_Irreflexive Under_Irreflexive] : typeclass_instances. - -Instance under_Asymmetric {A} (R : relation A) : - RelationClasses.Asymmetric R -> - RelationClasses.Asymmetric (Under_rel.Under_rel A R) | 12. -Proof. now rewrite Under_rel.Under_relE. Qed. - -Hint Cut [_* Under_Asymmetric Under_Asymmetric] : typeclass_instances. - -Instance under_StrictOrder {A} (R : relation A) : - RelationClasses.StrictOrder R -> - RelationClasses.StrictOrder (Under_rel.Under_rel A R) | 12. -Proof. now rewrite Under_rel.Under_relE. Qed. - -Hint Cut [_* Under_Strictorder Under_Strictorder] : typeclass_instances. - *) - -Instance Under_Symmetric {A} (R : relation A) : - RelationClasses.Symmetric R -> - RelationClasses.Symmetric (Under_rel.Under_rel A R) | 12. -Proof. now rewrite Under_rel.Under_relE. Qed. - -Hint Cut [_* Under_Symmetric Under_Symmetric] : typeclass_instances. - -Instance Under_Transitive {A} (R : relation A) : - RelationClasses.Transitive R -> - RelationClasses.Transitive (Under_rel.Under_rel A R) | 12. -Proof. now rewrite Under_rel.Under_relE. Qed. - -Hint Cut [_* Under_Transitive Under_Transitive] : typeclass_instances. - -Instance Under_PreOrder {A} (R : relation A) : - RelationClasses.PreOrder R -> - RelationClasses.PreOrder (Under_rel.Under_rel A R) | 12. -Proof. now rewrite Under_rel.Under_relE. Qed. - -Hint Cut [_* Under_PreOrder Under_PreOrder] : typeclass_instances. - -Instance Under_PER {A} (R : relation A) : - RelationClasses.PER R -> - RelationClasses.PER (Under_rel.Under_rel A R) | 12. -Proof. now rewrite Under_rel.Under_relE. Qed. - -Hint Cut [_* Under_PER Under_PER] : typeclass_instances. - -Instance Under_Equivalence {A} (R : relation A) : - RelationClasses.Equivalence R -> - RelationClasses.Equivalence (Under_rel.Under_rel A R) | 12. -Proof. now rewrite Under_rel.Under_relE. Qed. - -Hint Cut [_* Under_Equivalence Under_Equivalence] : typeclass_instances. - -(* Don't handle Antisymmetric and PartialOrder classes for now, - as these classes depend on two relation symbols... *) diff --git a/plugins/ssr/ssrvernac.mlg b/plugins/ssr/ssrvernac.mlg index 9f6fe0e651..d8dbf2f3dc 100644 --- a/plugins/ssr/ssrvernac.mlg +++ b/plugins/ssr/ssrvernac.mlg @@ -370,14 +370,14 @@ let coerce_search_pattern_to_sort hpat = let filter_head, coe_path = try let _, cp = - Classops.lookup_path_to_sort_from (push_rels_assum dc env) sigma ht in + Coercionops.lookup_path_to_sort_from (push_rels_assum dc env) sigma ht in warn (); true, cp with _ -> false, [] in let coerce hp coe_index = - let coe_ref = coe_index.Classops.coe_value in + let coe_ref = coe_index.Coercionops.coe_value in try - let n_imps = Option.get (Classops.hide_coercion coe_ref) in + let n_imps = Option.get (Coercionops.hide_coercion coe_ref) in mkPApp (Pattern.PRef coe_ref) n_imps [|hp|] with Not_found | Option.IsNone -> errorstrm (str "need explicit coercion " ++ pr_global coe_ref ++ spc () diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 70c1077106..f6fbdaa958 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -164,7 +164,7 @@ let rawnum_of_r c = match DAst.get c with let s, i = if is_pos_or_zero i then SPlus, i else SMinus, neg i in let i = Bigint.to_string i in let se = if is_gr md glob_Rdiv then "-" else "" in - let e = se ^ Bigint.to_string e in + let e = "e" ^ se ^ Bigint.to_string e in s, { NumTok.int = i; frac = ""; exp = e } | _ -> raise Non_closed_number end diff --git a/pretyping/cases.ml b/pretyping/cases.ml index aa6ec1c941..cbd04a76ad 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -436,7 +436,7 @@ let adjust_tomatch_to_pattern ~program_mode sigma pb ((current,typ),deps,dep) = | exception Evarconv.UnableToUnify _ -> sigma, current | sigma -> sigma, current else - let sigma, j = Coercion.inh_conv_coerce_to ?loc ~program_mode true !!(pb.env) sigma (make_judge current typ) indt in + let sigma, j, _trace = Coercion.inh_conv_coerce_to ?loc ~program_mode true !!(pb.env) sigma (make_judge current typ) indt in sigma, j.uj_val in sigma, (current, try_find_ind !!(pb.env) sigma indt names)) @@ -1955,8 +1955,12 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = let inh_conv_coerce_to_tycon ?loc ~program_mode env sigma j tycon = match tycon with - | Some p -> Coercion.inh_conv_coerce_to ?loc ~program_mode true env sigma - ~flags:(default_flags_of TransparentState.full) j p + | Some p -> + let (evd,v,_trace) = + Coercion.inh_conv_coerce_to ?loc ~program_mode true env sigma + ~flags:(default_flags_of TransparentState.full) j p + in + (evd,v) | None -> sigma, j (* We put the tycon inside the arity signature, possibly discovering dependencies. *) diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index f0e73bdb29..3c7f9a8f00 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -27,7 +27,7 @@ open EConstr open Vars open Reductionops open Pretype_errors -open Classops +open Coercionops open Evarutil open Evarconv open Evd @@ -136,20 +136,6 @@ let lift_args n sign = in liftrec (List.length sign) sign -let mu env evdref t = - let rec aux v = - let v' = hnf env !evdref v in - match disc_subset !evdref v' with - | Some (u, p) -> - let f, ct = aux u in - let p = hnf_nodelta env !evdref p in - (Some (fun x -> - app_opt env evdref - f (papp evdref sig_proj1 [| u; p; x |])), - ct) - | None -> (None, v) - in aux t - let coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr) : (EConstr.constr -> EConstr.constr) option = @@ -367,36 +353,97 @@ let saturate_evd env evd = Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~split:true ~fail:false env evd +type coercion_trace = + | IdCoe + | PrimProjCoe of { + proj : Projection.Repr.t; + args : econstr list; + previous : coercion_trace; + } + | Coe of { + head : econstr; + args : econstr list; + previous : coercion_trace; + } + | ProdCoe of { na : Name.t binder_annot; ty : econstr; dom : coercion_trace; body : coercion_trace } + +let empty_coercion_trace = IdCoe + +(* similar to iterated apply_coercion_args *) +let rec reapply_coercions sigma trace c = match trace with + | IdCoe -> c + | PrimProjCoe { proj; args; previous } -> + let c = reapply_coercions sigma previous c in + let args = args@[c] in + let head, args = match args with [] -> assert false | hd :: tl -> hd, tl in + applist (mkProj (Projection.make proj false, head), args) + | Coe {head; args; previous} -> + let c = reapply_coercions sigma previous c in + let args = args@[c] in + applist (head, args) + | ProdCoe { na; ty; dom; body } -> + let x = reapply_coercions sigma dom (mkRel 1) in + let c = beta_applist sigma (lift 1 c, [x]) in + let c = reapply_coercions sigma body c in + mkLambda (na, ty, c) + (* Apply coercion path from p to hj; raise NoCoercion if not applicable *) let apply_coercion env sigma p hj typ_cl = - let j,t,evd = + let j,t,trace,evd = List.fold_left - (fun (ja,typ_cl,sigma) i -> + (fun (ja,typ_cl,trace,sigma) i -> let isid = i.coe_is_identity in let isproj = i.coe_is_projection in let sigma, c = new_global sigma i.coe_value in let typ = Retyping.get_type_of env sigma c in let fv = make_judge c typ in - let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in - let sigma, jres = - apply_coercion_args env sigma true isproj argl fv + let argl = class_args_of env sigma typ_cl in + let trace = + if isid then trace + else match isproj with + | None -> Coe {head=fv.uj_val;args=argl;previous=trace} + | Some proj -> + let args = List.skipn (Projection.Repr.npars proj) argl in + PrimProjCoe {proj; args; previous=trace } in - (if isid then + let argl = argl@[ja.uj_val] in + let sigma, jres = apply_coercion_args env sigma true isproj argl fv in + let jres = + if isid then { uj_val = ja.uj_val; uj_type = jres.uj_type } else - jres), - jres.uj_type,sigma) - (hj,typ_cl,sigma) p - in evd, j + jres + in + jres, jres.uj_type, trace, sigma) + (hj,typ_cl,IdCoe,sigma) p + in evd, j, trace + +let mu env evdref t = + let rec aux v = + let v' = hnf env !evdref v in + match disc_subset !evdref v' with + | Some (u, p) -> + let f, ct, trace = aux u in + let p = hnf_nodelta env !evdref p in + let p1 = delayed_force sig_proj1 in + let evd, p1 = Evarutil.new_global !evdref p1 in + evdref := evd; + (Some (fun x -> + app_opt env evdref + f (mkApp (p1, [| u; p; x |]))), + ct, + Coe {head=p1; args=[u;p]; previous=trace}) + | None -> (None, v, IdCoe) + in aux t (* Try to coerce to a funclass; raise NoCoercion if not possible *) let inh_app_fun_core ~program_mode env evd j = let t = whd_all env evd j.uj_type in match EConstr.kind evd t with - | Prod _ -> (evd,j) + | Prod _ -> (evd,j,IdCoe) | Evar ev -> let (evd',t) = Evardefine.define_evar_as_product env evd ev in - (evd',{ uj_val = j.uj_val; uj_type = t }) + (evd',{ uj_val = j.uj_val; uj_type = t },IdCoe) | _ -> try let t,p = lookup_path_to_fun_from env evd j.uj_type in @@ -405,11 +452,11 @@ let inh_app_fun_core ~program_mode env evd j = if program_mode then try let evdref = ref evd in - let coercef, t = mu env evdref t in + let coercef, t, trace = mu env evdref t in let res = { uj_val = app_opt env evdref coercef j.uj_val; uj_type = t } in - (!evdref, res) + (!evdref, res, trace) with NoSubtacCoercion | NoCoercion -> - (evd,j) + (evd,j,IdCoe) else raise NoCoercion (* Try to coerce to a funclass; returns [j] if no coercion is applicable *) @@ -417,10 +464,10 @@ let inh_app_fun ~program_mode resolve_tc env evd j = try inh_app_fun_core ~program_mode env evd j with | NoCoercion when not resolve_tc - || not (get_use_typeclasses_for_conversion ()) -> (evd, j) + || not (get_use_typeclasses_for_conversion ()) -> (evd, j, IdCoe) | NoCoercion -> try inh_app_fun_core ~program_mode env (saturate_evd env evd) j - with NoCoercion -> (evd, j) + with NoCoercion -> (evd, j, IdCoe) let type_judgment env sigma j = match EConstr.kind sigma (whd_all env sigma j.uj_type) with @@ -430,7 +477,7 @@ let type_judgment env sigma j = let inh_tosort_force ?loc env evd j = try let t,p = lookup_path_to_sort_from env evd j.uj_type in - let evd,j1 = apply_coercion env evd p j t in + let evd,j1,_trace = apply_coercion env evd p j t in let j2 = Environ.on_judgment_type (whd_evar evd) j1 in (evd,type_judgment env evd j2) with Not_found | NoCoercion -> @@ -449,7 +496,7 @@ let inh_coerce_to_sort ?loc env evd j = let inh_coerce_to_base ?loc ~program_mode env evd j = if program_mode then let evdref = ref evd in - let ct, typ' = mu env evdref j.uj_type in + let ct, typ', trace = mu env evdref j.uj_type in let res = { uj_val = (app_coercion env evdref ct j.uj_val); uj_type = typ' } @@ -459,7 +506,7 @@ let inh_coerce_to_base ?loc ~program_mode env evd j = let inh_coerce_to_prod ?loc ~program_mode env evd t = if program_mode then let evdref = ref evd in - let _, typ' = mu env evdref t in + let _, typ', _trace = mu env evdref t in !evdref, typ' else (evd, t) @@ -468,24 +515,24 @@ let inh_coerce_to_fail flags env evd rigidonly v t c1 = then raise NoCoercion else - let evd, v', t' = + let evd, v', t', trace = try let t2,t1,p = lookup_path_between env evd (t,c1) in - let evd,j = + let evd,j,trace = apply_coercion env evd p {uj_val = v; uj_type = t} t2 in - evd, j.uj_val, j.uj_type + evd, j.uj_val, j.uj_type, trace with Not_found -> raise NoCoercion in - try (unify_leq_delay ~flags env evd t' c1, v') + try (unify_leq_delay ~flags env evd t' c1, v', trace) with UnableToUnify _ -> raise NoCoercion let default_flags_of env = default_flags_of TransparentState.full let rec inh_conv_coerce_to_fail ?loc env evd ?(flags=default_flags_of env) rigidonly v t c1 = - try (unify_leq_delay ~flags env evd t c1, v) + try (unify_leq_delay ~flags env evd t c1, v, IdCoe) with UnableToUnify (best_failed_evd,e) -> try inh_coerce_to_fail flags env evd rigidonly v t c1 with NoCoercion -> @@ -505,24 +552,27 @@ let rec inh_conv_coerce_to_fail ?loc env evd ?(flags=default_flags_of env) rigid | na -> na) name in let open Context.Rel.Declaration in let env1 = push_rel (LocalAssum (name,u1)) env in - let (evd', v1) = + let (evd', v1, trace1) = inh_conv_coerce_to_fail ?loc env1 evd rigidonly (mkRel 1) (lift 1 u1) (lift 1 t1) in let v2 = beta_applist evd' (lift 1 v,[v1]) in let t2 = Retyping.get_type_of env1 evd' v2 in - let (evd'',v2') = inh_conv_coerce_to_fail ?loc env1 evd' rigidonly v2 t2 u2 in - (evd'', mkLambda (name, u1, v2')) + let (evd'',v2',trace2) = inh_conv_coerce_to_fail ?loc env1 evd' rigidonly v2 t2 u2 in + let trace = ProdCoe { na=name; ty=u1; dom=trace1; body=trace2 } in + (evd'', mkLambda (name, u1, v2'), trace) | _ -> raise (NoCoercionNoUnifier (best_failed_evd,e)) (* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *) let inh_conv_coerce_to_gen ?loc ~program_mode resolve_tc rigidonly flags env evd cj t = - let (evd', val') = + let (evd', val', otrace) = try - inh_conv_coerce_to_fail ?loc env evd ~flags rigidonly cj.uj_val cj.uj_type t + let (evd', val', trace) = inh_conv_coerce_to_fail ?loc env evd ~flags rigidonly cj.uj_val cj.uj_type t in + (evd', val', Some trace) with NoCoercionNoUnifier (best_failed_evd,e) -> try if program_mode then - coerce_itf ?loc env evd cj.uj_val cj.uj_type t + let (evd', val') = coerce_itf ?loc env evd cj.uj_val cj.uj_type t in + (evd', val', None) else raise NoSubtacCoercion with | NoSubtacCoercion when not resolve_tc || not (get_use_typeclasses_for_conversion ()) -> @@ -533,11 +583,12 @@ let inh_conv_coerce_to_gen ?loc ~program_mode resolve_tc rigidonly flags env evd if evd' == evd then error_actual_type ?loc env best_failed_evd cj t e else - inh_conv_coerce_to_fail ?loc env evd' rigidonly cj.uj_val cj.uj_type t + let (evd', val', trace) = inh_conv_coerce_to_fail ?loc env evd' rigidonly cj.uj_val cj.uj_type t in + (evd', val', Some trace) with NoCoercionNoUnifier (_evd,_error) -> error_actual_type ?loc env best_failed_evd cj t e in - (evd',{ uj_val = val'; uj_type = t }) + (evd',{ uj_val = val'; uj_type = t },otrace) let inh_conv_coerce_to ?loc ~program_mode resolve_tc env evd ?(flags=default_flags_of env) = inh_conv_coerce_to_gen ?loc ~program_mode resolve_tc false flags env evd diff --git a/pretyping/coercion.mli b/pretyping/coercion.mli index fe93a26f4f..b92f3709cc 100644 --- a/pretyping/coercion.mli +++ b/pretyping/coercion.mli @@ -16,13 +16,19 @@ open Glob_term (** {6 Coercions. } *) +type coercion_trace + +val empty_coercion_trace : coercion_trace + +val reapply_coercions : evar_map -> coercion_trace -> EConstr.t -> EConstr.t + (** [inh_app_fun resolve_tc env isevars j] coerces [j] to a function; i.e. it inserts a coercion into [j], if needed, in such a way it gets as type a product; it returns [j] if no coercion is applicable. resolve_tc=false disables resolving type classes (as the last resort before failing) *) val inh_app_fun : program_mode:bool -> bool -> - env -> evar_map -> unsafe_judgment -> evar_map * unsafe_judgment + env -> evar_map -> unsafe_judgment -> evar_map * unsafe_judgment * coercion_trace (** [inh_coerce_to_sort env isevars j] coerces [j] to a type; i.e. it inserts a coercion into [j], if needed, in such a way it gets as @@ -48,11 +54,11 @@ val inh_coerce_to_prod : ?loc:Loc.t -> program_mode:bool -> val inh_conv_coerce_to : ?loc:Loc.t -> program_mode:bool -> bool -> env -> evar_map -> ?flags:Evarconv.unify_flags -> - unsafe_judgment -> types -> evar_map * unsafe_judgment + unsafe_judgment -> types -> evar_map * unsafe_judgment * coercion_trace option val inh_conv_coerce_rigid_to : ?loc:Loc.t -> program_mode:bool ->bool -> env -> evar_map -> ?flags:Evarconv.unify_flags -> - unsafe_judgment -> types -> evar_map * unsafe_judgment + unsafe_judgment -> types -> evar_map * unsafe_judgment * coercion_trace option (** [inh_pattern_coerce_to loc env isevars pat ind1 ind2] coerces the Cases pattern [pat] typed in [ind1] into a pattern typed in [ind2]; diff --git a/pretyping/classops.ml b/pretyping/coercionops.ml index 16021b66f8..16021b66f8 100644 --- a/pretyping/classops.ml +++ b/pretyping/coercionops.ml diff --git a/pretyping/classops.mli b/pretyping/coercionops.mli index 9f633843eb..9f633843eb 100644 --- a/pretyping/classops.mli +++ b/pretyping/coercionops.mli diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 862865bd90..b042437a22 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -455,7 +455,9 @@ let rec decomp_branch tags nal flags (avoid,env as e) sigma c = (avoid', add_name_opt na' body t env) sigma c let rec build_tree na isgoal e sigma ci cl = - let mkpat n rhs pl = DAst.make @@ PatCstr((ci.ci_ind,n+1),pl,update_name sigma na rhs) in + let mkpat n rhs pl = + let na = update_name sigma na rhs in + na, DAst.make @@ PatCstr((ci.ci_ind,n+1),pl,na) in let cnl = ci.ci_pp_info.cstr_tags in List.flatten (List.init (Array.length cl) @@ -485,7 +487,9 @@ and align_tree nal isgoal (e,c as rhs) sigma = match nal with and contract_branch isgoal e sigma (cdn,mkpat,rhs) = let nal,rhs = decomp_branch cdn [] isgoal e sigma rhs in let mat = align_tree nal isgoal rhs sigma in - List.map (fun (ids,hd,rhs) -> ids,mkpat rhs hd,rhs) mat + List.map (fun (ids,hd,rhs) -> + let na, pat = mkpat rhs hd in + (Nameops.Name.fold_right Id.Set.add na ids, pat, rhs)) mat (**********************************************************************) (* Transform internal representation of pattern-matching into list of *) @@ -692,7 +696,7 @@ let detype_universe sigma u = if Univ.Level.is_set l then GSet else GType (hack_qualid_of_univ_level sigma l) in (s, n) in - Univ.Universe.map fn u + List.map fn (Univ.Universe.repr u) let detype_sort sigma = function | SProp -> UNamed [GSProp,0] diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 2130d4ce90..3bd52088c7 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -1337,8 +1337,8 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = try let evi = Evd.find_undefined evd evk in let evi = nf_evar_info evd evi in - let env_evar_unf = evar_env evi in - let env_evar = evar_filtered_env evi in + let env_evar_unf = evar_env env_rhs evi in + 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 @@ -1473,16 +1473,16 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = | Some [t] -> if not (noccur_evar env_rhs evd ev (EConstr.of_constr t)) then raise (TypingFailed evd); - instantiate_evar evar_unify flags evd ev (EConstr.of_constr t) + instantiate_evar evar_unify flags env_rhs evd ev (EConstr.of_constr t) | Some l when abstract = Abstraction.Abstract && List.exists (fun c -> isVarId evd id (EConstr.of_constr c)) l -> - instantiate_evar evar_unify flags evd ev vid + instantiate_evar evar_unify flags env_rhs evd ev vid | _ -> evd) with e -> user_err (Pp.str "Cannot find an instance") else ((if !debug_ho_unification then let evi = Evd.find evd evk in - let env = Evd.evar_env evi in + let env = Evd.evar_env env_rhs evi in Feedback.msg_debug Pp.(str"evar is defined: " ++ int (Evar.repr evk) ++ spc () ++ prc env evd (match evar_body evi with Evar_defined c -> c @@ -1498,7 +1498,7 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = (if !debug_ho_unification then begin let evi = Evd.find evd evk in - let evenv = evar_env evi in + let evenv = evar_env env_rhs evi in let body = match evar_body evi with Evar_empty -> assert false | Evar_defined c -> c in Feedback.msg_debug Pp.(str"evar was defined already as: " ++ prc evenv evd body) end; @@ -1506,7 +1506,7 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = else try let evi = Evd.find_undefined evd evk in - let evenv = evar_env evi in + let evenv = evar_env env_rhs evi in let rhs' = nf_evar evd rhs' in if !debug_ho_unification then Feedback.msg_debug Pp.(str"abstracted type before second solve_evars: " ++ @@ -1517,7 +1517,7 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = 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 evd evk rhs' + Evarsolve.instantiate_evar evar_unify flags env_rhs evd evk rhs' with IllTypedInstance _ -> raise (TypingFailed evd) in let evd = abstract_free_holes evd subst in @@ -1664,7 +1664,7 @@ let max_undefined_with_candidates evd = with MaxUndefined ans -> Some ans -let rec solve_unconstrained_evars_with_candidates flags evd = +let rec solve_unconstrained_evars_with_candidates flags env evd = (* max_undefined is supposed to return the most recent, hence possibly most dependent evar *) match max_undefined_with_candidates evd with @@ -1675,9 +1675,9 @@ let rec solve_unconstrained_evars_with_candidates flags evd = | a::l -> (* In case of variables, most recent ones come first *) try - let evd = instantiate_evar evar_unify flags evd evk a in + let evd = instantiate_evar evar_unify flags env evd evk a in match reconsider_unif_constraints evar_unify flags evd with - | Success evd -> solve_unconstrained_evars_with_candidates flags evd + | Success evd -> solve_unconstrained_evars_with_candidates flags env evd | UnifFailure _ -> aux l with | IllTypedInstance _ -> aux l @@ -1685,7 +1685,7 @@ let rec solve_unconstrained_evars_with_candidates flags evd = (* Expected invariant: most dependent solutions come first *) (* so as to favor progress when used with the refine tactics *) let evd = aux l in - solve_unconstrained_evars_with_candidates flags evd + solve_unconstrained_evars_with_candidates flags env evd let solve_unconstrained_impossible_cases env evd = Evd.fold_undefined (fun evk ev_info evd' -> @@ -1695,18 +1695,18 @@ let solve_unconstrained_impossible_cases env evd = let evd' = Evd.merge_context_set Evd.univ_flexible_alg ?loc evd' ctx in let ty = j_type j in let flags = default_flags env in - instantiate_evar evar_unify flags evd' evk ty + instantiate_evar evar_unify flags env evd' evk ty | _ -> evd') evd evd let solve_unif_constraints_with_heuristics env ?(flags=default_flags env) ?(with_ho=false) evd = - let evd = solve_unconstrained_evars_with_candidates flags evd in + let evd = solve_unconstrained_evars_with_candidates flags env evd in let rec aux evd pbs progress stuck = match pbs with | (pbty,env,t1,t2 as pb) :: pbs -> (match apply_conversion_problem_heuristic flags env evd with_ho pbty t1 t2 with | Success evd' -> - let evd' = solve_unconstrained_evars_with_candidates flags evd' in + let evd' = solve_unconstrained_evars_with_candidates flags env evd' in let (evd', rest) = extract_all_conv_pbs evd' in begin match rest with | [] -> aux evd' pbs true stuck diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index aebdd14396..c580d44237 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -76,7 +76,7 @@ let idx = Namegen.default_dependent_ident let define_pure_evar_as_product env evd evk = let open Context.Named.Declaration in let evi = Evd.find_undefined evd evk in - let evenv = evar_env evi in + let evenv = evar_env env evi in let id = next_ident_away idx (Environ.ids_of_named_context_val evi.evar_hyps) in let concl = Reductionops.whd_all evenv evd evi.evar_concl in let s = destSort evd concl in @@ -129,7 +129,7 @@ let define_evar_as_product env evd (evk,args) = let define_pure_evar_as_lambda env evd evk = let open Context.Named.Declaration in let evi = Evd.find_undefined evd evk in - let evenv = evar_env evi in + let evenv = evar_env env evi in let typ = Reductionops.whd_all evenv evd (evar_concl evi) in let evd1,(na,dom,rng) = match EConstr.kind evd typ with | Prod (na,dom,rng) -> (evd,(na,dom,rng)) @@ -170,7 +170,7 @@ let rec evar_absorb_arguments env evd (evk,args as ev) = function let define_evar_as_sort env evd (ev,args) = let evd, s = new_sort_variable univ_rigid evd in let evi = Evd.find_undefined evd ev in - let concl = Reductionops.whd_all (evar_env evi) evd evi.evar_concl in + let concl = Reductionops.whd_all (evar_env env evi) evd evi.evar_concl in let sort = destSort evd concl in let evd' = Evd.define ev (mkSort s) evd in Evd.set_leq_sort env evd' (Sorts.super s) (ESorts.kind evd' sort), s diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 5a23525fb0..b54a713a16 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -764,9 +764,9 @@ let restrict_upon_filter evd evk p args = let len = Array.length args in Filter.restrict_upon oldfullfilter len (fun i -> p (Array.unsafe_get args i)) -let check_evar_instance unify flags evd evk1 body = +let check_evar_instance unify flags env evd evk1 body = let evi = Evd.find evd evk1 in - let evenv = evar_env evi in + let evenv = evar_env env evi in (* FIXME: The body might be ill-typed when this is called from w_merge *) (* This happens in practice, cf MathClasses build failure on 2013-3-15 *) let ty = @@ -915,7 +915,7 @@ let rec find_solution_type evarenv = function let rec do_projection_effects unify flags define_fun env ty evd = function | ProjectVar -> evd | ProjectEvar ((evk,argsv),evi,id,p) -> - let evd = check_evar_instance unify flags evd evk (mkVar id) in + let evd = check_evar_instance unify flags env evd evk (mkVar id) in let evd = Evd.define evk (EConstr.mkVar id) evd in (* TODO: simplify constraints involving evk *) let evd = do_projection_effects unify flags define_fun env ty evd p in @@ -1284,7 +1284,7 @@ let solve_evar_evar_l2r force f unify flags env evd aliases pbty ev1 (evk2,_ as update_evar_info evk2 (fst (destEvar evd' body)) evd' else evd' in - check_evar_instance unify flags evd' evk2 body + check_evar_instance unify flags env evd' evk2 body with EvarSolvedOnTheFly (evd,c) -> f env evd pbty ev2 c @@ -1329,12 +1329,12 @@ let solve_evar_evar ?(force=false) f unify flags env evd pbty (evk1,args1 as ev1 try (* ?X : Π Δ. Type i = ?Y : Π Δ'. Type j. The body of ?X and ?Y just has to be of type Π Δ. Type k for some k <= i, j. *) - let evienv = Evd.evar_env evi in + let evienv = Evd.evar_env env evi in let concl1 = EConstr.Unsafe.to_constr evi.evar_concl in let ctx1, i = Reduction.dest_arity evienv concl1 in let ctx1 = List.map (fun c -> map_rel_decl EConstr.of_constr c) ctx1 in let evi2 = Evd.find evd evk2 in - let evi2env = Evd.evar_env evi2 in + let evi2env = Evd.evar_env env evi2 in let concl2 = EConstr.Unsafe.to_constr evi2.evar_concl in let ctx2, j = Reduction.dest_arity evi2env concl2 in let ctx2 = List.map (fun c -> map_rel_decl EConstr.of_constr c) ctx2 in @@ -1418,7 +1418,7 @@ let solve_candidates unify flags env evd (evk,argsv) rhs = (* time and the evar been solved by the filtering process *) if Evd.is_undefined evd evk then let evd' = Evd.define evk c evd in - check_evar_instance unify flags evd' evk c + check_evar_instance unify flags env evd' evk c else evd | l when List.length l < List.length l' -> let candidates = List.map fst l in @@ -1442,11 +1442,11 @@ let occur_evar_upto_types sigma n c = in try occur_rec c; false with Occur -> true -let instantiate_evar unify flags evd evk body = +let instantiate_evar unify flags env evd evk body = (* Check instance freezing the evar to be defined, as checking could involve the same evar definition problem again otherwise *) let flags = { flags with frozen_evars = Evar.Set.add evk flags.frozen_evars } in - let evd' = check_evar_instance unify flags evd evk body in + let evd' = check_evar_instance unify flags env evd evk body in Evd.define evk body evd' (* We try to instantiate the evar assuming the body won't depend @@ -1508,7 +1508,7 @@ let rec invert_definition unify flags choose imitate_defs raise (NotEnoughInformationToProgress sols); (* No unique projection but still restrict to where it is possible *) (* materializing is necessary, but is restricting useful? *) - let ty = find_solution_type (evar_filtered_env evi) sols in + let ty = find_solution_type (evar_filtered_env env evi) sols in let ty' = instantiate_evar_array evi ty argsv in let (evd,evar,(evk',argsv' as ev')) = materialize_evar (evar_define unify flags ~choose) env !evdref 0 ev ty' in @@ -1571,7 +1571,7 @@ let rec invert_definition unify flags choose imitate_defs try let evd,body = project_evar_on_evar false unify flags env' evd aliases 0 None ev'' ev' in let evd = Evd.define evk' body evd in - check_evar_instance unify flags evd evk' body + check_evar_instance unify flags env' evd evk' body with | EvarSolvedOnTheFly _ -> assert false (* ev has no candidates *) | CannotProject (evd,ev'') -> @@ -1638,7 +1638,7 @@ let rec invert_definition unify flags choose imitate_defs else let t' = imitate (env,0) rhs in if !progress then - (recheck_applications unify flags (evar_env evi) evdref t'; t') + (recheck_applications unify flags (evar_env env evi) evdref t'; t') else t' in (!evdref,body) @@ -1670,7 +1670,7 @@ and evar_define unify flags ?(choose=false) ?(imitate_defs=true) env evd pbty (e if occur_evar_upto_types evd' evk body then raise (OccurCheckIn (evd',body)); (* needed only if an inferred type *) let evd', body = refresh_universes pbty env evd' body in - instantiate_evar unify flags evd' evk body + instantiate_evar unify flags env evd' evk body with | NotEnoughInformationToProgress sols -> postpone_non_unique_projection env evd pbty ev sols rhs diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli index 908adac7e4..74aee9da59 100644 --- a/pretyping/evarsolve.mli +++ b/pretyping/evarsolve.mli @@ -77,7 +77,7 @@ type conversion_check = unify_flags -> unification_kind -> - [c] does not contain any Meta(_) *) -val instantiate_evar : unifier -> unify_flags -> evar_map -> +val instantiate_evar : unifier -> unify_flags -> env -> evar_map -> Evar.t -> constr -> evar_map (** [evar_define choose env ev c] try to instantiate [ev] with [c] (typed in [env]), @@ -125,7 +125,7 @@ exception IllTypedInstance of env * types * types (* May raise IllTypedInstance if types are not convertible *) val check_evar_instance : unifier -> unify_flags -> - evar_map -> Evar.t -> constr -> evar_map + env -> evar_map -> Evar.t -> constr -> evar_map val remove_instance_local_defs : evar_map -> Evar.t -> 'a array -> 'a list diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 2db674d397..97fffbd7c8 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -26,6 +26,10 @@ open Context.Rel.Declaration exception Find_at of int +(* timing *) + +let timing_enabled = ref false + (* profiling *) let profiling_enabled = ref false @@ -79,6 +83,12 @@ let get_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 @@ -496,19 +506,23 @@ let native_norm env sigma c ty = 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 fn = Nativelib.compile ml_filename code ~profile:profile in - if !Flags.debug then Feedback.msg_debug (Pp.str "Running norm ..."); + let tc1 = Sys.time () 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 Nativelib.call_linker ~fatal:true env ~prefix fn (Some upd); let t1 = Sys.time () in if profile then stop_profiler profiler_pid; - let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in - if !Flags.debug then Feedback.msg_debug (Pp.str time_info); + 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 "Reification done in %.5f@." (t2 -. t1) in - if !Flags.debug then Feedback.msg_debug (Pp.str time_info); + 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 let native_conv_generic pb sigma t = diff --git a/pretyping/nativenorm.mli b/pretyping/nativenorm.mli index 02de034fcb..458fe70e2c 100644 --- a/pretyping/nativenorm.mli +++ b/pretyping/nativenorm.mli @@ -20,6 +20,9 @@ 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 diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 0364e1b61f..bf61d44a10 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -361,7 +361,7 @@ let adjust_evar_source sigma na c = (* coerce to tycon if any *) let inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma j = function - | None -> sigma, j + | None -> sigma, j, Some Coercion.empty_coercion_trace | Some t -> Coercion.inh_conv_coerce_to ?loc ~program_mode resolve_tc !!env sigma j t @@ -604,16 +604,18 @@ let pretype_instance self ~program_mode ~poly resolve_tc env sigma loc hyps evk module Default = struct + let discard_trace (sigma,t,otrace) = sigma, t + let pretype_ref self (ref, u) = fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> let sigma, t_ref = pretype_ref ?loc sigma env ref u in - inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma t_ref tycon + discard_trace @@ inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma t_ref tycon let pretype_var self id = fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> let pretype tycon env sigma t = eval_pretyper self ~program_mode ~poly resolve_tc tycon env sigma t in let sigma, t_id = pretype_id (fun e r t -> pretype tycon e r t) loc env sigma id in - inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma t_id tycon + discard_trace @@ inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma t_id tycon let pretype_evar self (id, inst) ?loc ~program_mode ~poly resolve_tc tycon env sigma = (* Ne faudrait-il pas s'assurer que hyps est bien un @@ -626,7 +628,7 @@ struct let sigma, args = pretype_instance self ~program_mode ~poly resolve_tc env sigma loc hyps evk inst in let c = mkEvar (evk, args) in let j = Retyping.get_judgment_of !!env sigma c in - inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma j tycon + discard_trace @@ inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma j tycon let pretype_patvar self kind ?loc ~program_mode ~poly resolve_tc tycon env sigma = let sigma, ty = @@ -757,12 +759,12 @@ struct iraise (e, info)); make_judge (mkCoFix cofix) ftys.(i) in - inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma fixj tycon + discard_trace @@ inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma fixj tycon let pretype_sort self s = fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> let sigma, j = pretype_sort ?loc sigma s in - inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma j tycon + discard_trace @@ inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma j tycon let pretype_app self (f, args) = fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> @@ -771,12 +773,15 @@ struct let floc = loc_of_glob_constr f in let length = List.length args in let nargs_before_bidi = + if Option.is_empty tycon then length + (* We apply bidirectionality hints only if an expected type is specified *) + else (* if `f` is a global, we retrieve bidirectionality hints *) - try - let (gr,_) = destRef sigma fj.uj_val in - Option.default length @@ GlobRef.Map.find_opt gr !bidi_hints - with DestKO -> - length + try + let (gr,_) = destRef sigma fj.uj_val in + Option.default length @@ GlobRef.Map.find_opt gr !bidi_hints + with DestKO -> + length in let candargs = (* Bidirectional typechecking hint: @@ -813,24 +818,38 @@ struct else fun f v -> applist (f, [v]) | _ -> fun _ f v -> applist (f, [v]) in - let rec apply_rec env sigma n resj candargs bidiargs = function - | [] -> sigma, resj, List.rev bidiargs + let refresh_template env sigma resj = + (* Special case for inductive type applications that must be + refreshed right away. *) + match EConstr.kind sigma resj.uj_val with + | App (f,args) -> + if Termops.is_template_polymorphic_ind !!env sigma f then + let c = mkApp (f, args) in + let sigma, c = Evarsolve.refresh_universes (Some true) !!env sigma c in + let t = Retyping.get_type_of !!env sigma c in + sigma, make_judge c (* use this for keeping evars: resj.uj_val *) t + else sigma, resj + | _ -> sigma, resj + in + let rec apply_rec env sigma n resj resj_before_bidi candargs bidiargs = function + | [] -> sigma, resj, resj_before_bidi, List.rev bidiargs | c::rest -> let bidi = n >= nargs_before_bidi in let argloc = loc_of_glob_constr c in - let sigma, resj = Coercion.inh_app_fun ~program_mode resolve_tc !!env sigma resj in + let sigma, resj, trace = Coercion.inh_app_fun ~program_mode resolve_tc !!env sigma resj in let resty = whd_all !!env sigma resj.uj_type in match EConstr.kind sigma resty with | Prod (na,c1,c2) -> - let tycon = Some c1 in let (sigma, hj), bidiargs = - if bidi && Option.has_some tycon then + if bidi then (* We want to get some typing information from the context before typing the argument, so we replace it by an existential variable *) let sigma, c_hole = new_evar env sigma ~src:(loc,Evar_kinds.InternalHole) c1 in - (sigma, make_judge c_hole c1), (c_hole, c) :: bidiargs - else pretype tycon env sigma c, bidiargs + (sigma, make_judge c_hole c1), (c_hole, c, trace) :: bidiargs + else + let tycon = Some c1 in + pretype tycon env sigma c, bidiargs in let sigma, candargs, ujval = match candargs with @@ -845,29 +864,18 @@ struct in let sigma, ujval = adjust_evar_source sigma na.binder_name ujval in let value, typ = app_f n (j_val resj) ujval, subst1 ujval c2 in - let j = { uj_val = value; uj_type = typ } in - apply_rec env sigma (n+1) j candargs bidiargs rest + let resj = { uj_val = value; uj_type = typ } in + let resj_before_bidi = if bidi then resj_before_bidi else resj in + apply_rec env sigma (n+1) resj resj_before_bidi candargs bidiargs rest | _ -> let sigma, hj = pretype empty_tycon env sigma c in error_cant_apply_not_functional ?loc:(Loc.merge_opt floc argloc) !!env sigma resj [|hj|] in - let sigma, resj, bidiargs = apply_rec env sigma 0 fj candargs [] args in - let sigma, resj = - match EConstr.kind sigma resj.uj_val with - | App (f,args) -> - if Termops.is_template_polymorphic_ind !!env sigma f then - (* Special case for inductive type applications that must be - refreshed right away. *) - let c = mkApp (f, args) in - let sigma, c = Evarsolve.refresh_universes (Some true) !!env sigma c in - let t = Retyping.get_type_of !!env sigma c in - sigma, make_judge c (* use this for keeping evars: resj.uj_val *) t - else sigma, resj - | _ -> sigma, resj - in - let sigma, t = inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma resj tycon in - let refine_arg sigma (newarg,origarg) = + let sigma, resj, resj_before_bidi, bidiargs = apply_rec env sigma 0 fj fj candargs [] args in + let sigma, resj = refresh_template env sigma resj in + let sigma, resj, otrace = inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma resj tycon in + let refine_arg n (sigma,t) (newarg,origarg,trace) = (* Refine an argument (originally `origarg`) represented by an evar (`newarg`) to use typing information from the context *) (* Recover the expected type of the argument *) @@ -876,12 +884,25 @@ struct let sigma, j = pretype (Some ty) env sigma origarg in (* Unify the (possibly refined) existential variable with the (typechecked) original value *) - Evarconv.unify_delay !!env sigma newarg (j_val j) + let sigma = Evarconv.unify_delay !!env sigma newarg (j_val j) in + sigma, app_f n (Coercion.reapply_coercions sigma trace t) (j_val j) in (* We now refine any arguments whose typing was delayed for bidirectionality *) - let sigma = List.fold_left refine_arg sigma bidiargs in - (sigma, t) + let t = resj_before_bidi.uj_val in + let sigma, t = List.fold_left_i refine_arg nargs_before_bidi (sigma,t) bidiargs in + (* If we did not get a coercion trace (e.g. with `Program` coercions, we + replaced user-provided arguments with inferred ones. Otherwise, we apply + the coercion trace to the user-provided arguments. *) + let resj = + match otrace with + | None -> resj + | Some trace -> + let resj = { resj with uj_val = t } in + let sigma, resj = refresh_template env sigma resj in + { resj with uj_val = Coercion.reapply_coercions sigma trace t } + in + (sigma, resj) let pretype_lambda self (name, bk, c1, c2) = fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> @@ -903,7 +924,7 @@ struct let sigma, j' = eval_pretyper self ~program_mode ~poly resolve_tc rng env' sigma c2 in let name = get_name var' in let resj = judge_of_abstraction !!env (orelse_name name name'.binder_name) j j' in - inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma resj tycon + discard_trace @@ inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma resj tycon let pretype_prod self (name, bk, c1, c2) = fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> @@ -929,7 +950,7 @@ struct let (e, info) = CErrors.push e in let info = Option.cata (Loc.add_loc info) info loc in iraise (e, info) in - inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma resj tycon + discard_trace @@ inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma resj tycon let pretype_letin self (name, c1, t, c2) = fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> @@ -1122,7 +1143,7 @@ struct mkCase (ci, pred, cj.uj_val, [|b1;b2|]) in let cj = { uj_val = v; uj_type = p } in - inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma cj tycon + discard_trace @@ inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma cj tycon let pretype_cast self (c, k) = fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> @@ -1165,7 +1186,7 @@ struct in let v = mkCast (cj.uj_val, k, tval) in sigma, { uj_val = v; uj_type = tval } - in inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma cj tycon + in discard_trace @@ inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma cj tycon let pretype_int self i = fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> @@ -1174,7 +1195,7 @@ struct with Invalid_argument _ -> user_err ?loc ~hdr:"pretype" (str "Type of int63 should be registered first.") in - inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma resj tycon + discard_trace @@ inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma resj tycon let pretype_float self f = fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> @@ -1183,7 +1204,7 @@ struct with Invalid_argument _ -> user_err ?loc ~hdr:"pretype" (str "Type of float should be registered first.") in - inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma resj tycon + discard_trace @@ inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma resj tycon (* [pretype_type valcon env sigma c] coerces [c] into a type *) let pretype_type self c ?loc ~program_mode ~poly resolve_tc valcon (env : GlobEnv.t) sigma = match DAst.get c with @@ -1326,7 +1347,7 @@ let understand_ltac flags env sigma lvar kind c = (sigma, c) let path_convertible env sigma i p q = - let open Classops in + let open Coercionops in let mkGRef ref = DAst.make @@ Glob_term.GRef(ref,None) in let mkGVar id = DAst.make @@ Glob_term.GVar(id) in let mkGApp(rt,rtl) = DAst.make @@ Glob_term.GApp(rt,rtl) in @@ -1379,4 +1400,4 @@ let path_convertible env sigma i p q = let _ = Evarconv.unify_delay env sigma tp tq in true with Evarconv.UnableToUnify _ | PretypeError _ -> false -let _ = Classops.install_path_comparator path_convertible +let _ = Coercionops.install_path_comparator path_convertible diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib index 7e140f4399..07154d4e03 100644 --- a/pretyping/pretyping.mllib +++ b/pretyping/pretyping.mllib @@ -26,7 +26,7 @@ Constr_matching Tacred Typeclasses_errors Typeclasses -Classops +Coercionops Program Coercion Detyping diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 5b416a99f9..3b918b5396 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -19,7 +19,6 @@ open CErrors open Util open Pp open Names -open Globnames open Constr open Mod_subst open Reductionops @@ -80,7 +79,7 @@ let subst_structure subst (id, kl, projs as obj) = (Option.Smart.map (subst_constant subst)) projs in - let id' = subst_constructor subst id in + let id' = Globnames.subst_constructor subst id in if projs' == projs && id' == id then obj else (id',kl,projs') @@ -114,7 +113,7 @@ let find_primitive_projection c = (* the effective components of a structure and the projections of the *) (* structure *) -(* Table des definitions "object" : pour chaque object c, +(* Table of "object" definitions: for each object c, c := [x1:B1]...[xk:Bk](Build_R a1...am t1...t_n) @@ -127,16 +126,19 @@ let find_primitive_projection c = that maps the pair (Li,ci) to the following data + o_ORIGIN = c (the constant name which this conversion rule is + synthesized from) o_DEF = c o_TABS = B1...Bk o_INJ = Some n (when ci is a reference to the parameter xi) - o_PARAMS = a1...am - o_NARAMS = m + o_TPARAMS = a1...am + o_NPARAMS = m o_TCOMP = ui1...uir *) type obj_typ = { + o_ORIGIN : GlobRef.t; o_DEF : constr; o_CTX : Univ.AUContext.t; o_INJ : int option; (* position of trivial argument if any *) @@ -187,13 +189,13 @@ let rec cs_pattern_of_constr env t = let _, params = Inductive.find_rectype env ty in Const_cs (GlobRef.ConstRef (Projection.constant p)), None, params @ [c] | Sort s -> Sort_cs (Sorts.family s), None, [] - | _ -> Const_cs (global_of_constr t) , None, [] + | _ -> Const_cs (Globnames.global_of_constr t) , None, [] let warn_projection_no_head_constant = CWarnings.create ~name:"projection-no-head-constant" ~category:"typechecker" - (fun (sign,env,t,con,proji_sp) -> + (fun (sign,env,t,ref,proji_sp) -> let env = Termops.push_rels_assum sign env in - let con_pp = Nametab.pr_global_env Id.Set.empty (GlobRef.ConstRef con) in + let con_pp = Nametab.pr_global_env Id.Set.empty ref in let proji_sp_pp = Nametab.pr_global_env Id.Set.empty (GlobRef.ConstRef proji_sp) in let term_pp = Termops.Internal.print_constr_env env (Evd.from_env env) (EConstr.of_constr t) in strbrk "Projection value has no head constant: " @@ -201,11 +203,17 @@ let warn_projection_no_head_constant = ++ con_pp ++ str " of " ++ proji_sp_pp ++ strbrk ", ignoring it.") (* Intended to always succeed *) -let compute_canonical_projections env ~warn (con,ind) = - let o_CTX = Environ.constant_context env con in - let u = Univ.make_abstract_instance o_CTX in - let o_DEF = mkConstU (con, u) in - let c = Environ.constant_value_in env (con,u) in +let compute_canonical_projections env ~warn (gref,ind) = + let o_CTX = Environ.universes_of_global env gref in + let o_DEF, c = + match gref with + | GlobRef.ConstRef con -> + let u = Univ.make_abstract_instance o_CTX in + mkConstU (con, u), Environ.constant_value_in env (con,u) + | GlobRef.VarRef id -> + mkVar id, Option.get (Environ.named_body id env) + | GlobRef.ConstructRef _ | GlobRef.IndRef _ -> assert false + in let sign,t = Reductionops.splay_lam env (Evd.from_env env) (EConstr.of_constr c) in let sign = List.map (on_snd EConstr.Unsafe.to_constr) sign in let t = EConstr.Unsafe.to_constr t in @@ -224,10 +232,10 @@ let compute_canonical_projections env ~warn (con,ind) = match cs_pattern_of_constr nenv t with | patt, o_INJ, o_TCOMPS -> ((GlobRef.ConstRef proji_sp, (patt, t)), - { o_DEF ; o_CTX ; o_INJ ; o_TABS ; o_TPARAMS ; o_NPARAMS ; o_TCOMPS }) + { o_ORIGIN = gref ; o_DEF ; o_CTX ; o_INJ ; o_TABS ; o_TPARAMS ; o_NPARAMS ; o_TCOMPS }) :: acc | exception Not_found -> - if warn then warn_projection_no_head_constant (sign, env, t, con, proji_sp); + if warn then warn_projection_no_head_constant (sign, env, t, gref, proji_sp); acc ) acc spopt else acc @@ -263,12 +271,17 @@ let register_canonical_structure ~warn env sigma o = warn_redundant_canonical_projection (hd_val, prj, new_can_s, old_can_s) ) -let subst_canonical_structure subst (cst,ind as obj) = +type cs = GlobRef.t * inductive + +let subst_canonical_structure subst (gref,ind as obj) = (* invariant: cst is an evaluable reference. Thus we can take *) (* the first component of subst_con. *) - let cst' = subst_constant subst cst in - let ind' = subst_ind subst ind in - if cst' == cst && ind' == ind then obj else (cst',ind') + match gref with + | GlobRef.ConstRef cst -> + let cst' = subst_constant subst cst in + let ind' = subst_ind subst ind in + if cst' == cst && ind' == ind then obj else (GlobRef.ConstRef cst',ind') + | _ -> assert false (*s High-level declaration of a canonical structure *) @@ -279,15 +292,20 @@ let error_not_structure ref description = description)) let check_and_decompose_canonical_structure env sigma ref = - let sp = + let vc = match ref with - GlobRef.ConstRef sp -> sp - | _ -> error_not_structure ref (str "Expected an instance of a record or structure.") + | GlobRef.ConstRef sp -> + let u = Univ.make_abstract_instance (Environ.constant_context env sp) in + begin match Environ.constant_opt_value_in env (sp, u) with + | Some vc -> vc + | None -> error_not_structure ref (str "Could not find its value in the global environment.") end + | GlobRef.VarRef id -> + begin match Environ.named_body id env with + | Some b -> b + | None -> error_not_structure ref (str "Could not find its value in the global environment.") end + | GlobRef.IndRef _ | GlobRef.ConstructRef _ -> + error_not_structure ref (str "Expected an instance of a record or structure.") in - let u = Univ.make_abstract_instance (Environ.constant_context env sp) in - let vc = match Environ.constant_opt_value_in env (sp, u) with - | Some vc -> vc - | None -> error_not_structure ref (str "Could not find its value in the global environment.") in let body = snd (splay_lam env sigma (EConstr.of_constr vc)) in let body = EConstr.Unsafe.to_constr body in let f,args = match kind body with @@ -305,7 +323,7 @@ let check_and_decompose_canonical_structure env sigma ref = let ntrue_projs = List.count (fun { pk_true_proj } -> pk_true_proj) s.s_PROJKIND in if s.s_EXPECTEDPARAM + ntrue_projs > Array.length args then error_not_structure ref (str "Got too few arguments to the record or structure constructor."); - (sp,indsp) + (ref,indsp) let lookup_canonical_conversion (proj,pat) = assoc_pat pat (GlobRef.Map.find proj !object_table) diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index e8b0d771aa..fd156adc2c 100644 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -73,6 +73,7 @@ type cs_pattern = | Default_cs type obj_typ = { + o_ORIGIN : GlobRef.t; o_DEF : constr; o_CTX : Univ.AUContext.t; o_INJ : int option; (** position of trivial argument *) @@ -86,13 +87,15 @@ val cs_pattern_of_constr : Environ.env -> constr -> cs_pattern * int option * co val pr_cs_pattern : cs_pattern -> Pp.t +type cs = GlobRef.t * inductive + val lookup_canonical_conversion : (GlobRef.t * cs_pattern) -> constr * obj_typ val register_canonical_structure : warn:bool -> Environ.env -> Evd.evar_map -> - Constant.t * inductive -> unit -val subst_canonical_structure : Mod_subst.substitution -> Constant.t * inductive -> Constant.t * inductive + cs -> unit +val subst_canonical_structure : Mod_subst.substitution -> cs -> cs val is_open_canonical_projection : Environ.env -> Evd.evar_map -> Reductionops.state -> bool val canonical_projections : unit -> ((GlobRef.t * cs_pattern) * obj_typ) list -val check_and_decompose_canonical_structure : Environ.env -> Evd.evar_map -> GlobRef.t -> Constant.t * inductive +val check_and_decompose_canonical_structure : Environ.env -> Evd.evar_map -> GlobRef.t -> cs diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 48d5fac321..6486435ca2 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -1290,7 +1290,7 @@ let is_mimick_head sigma ts f = let try_to_coerce env evd c cty tycon = let j = make_judge c cty in - let (evd',j') = inh_conv_coerce_rigid_to ~program_mode:false true env evd j tycon in + let (evd',j',_trace) = inh_conv_coerce_rigid_to ~program_mode:false true env evd j tycon in let evd' = Evarconv.solve_unif_constraints_with_heuristics env evd' in let evd' = Evd.map_metas_fvalue (fun c -> nf_evar evd' c) evd' in (evd',j'.uj_val) diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 2da163b8ee..b55a41471a 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -275,7 +275,7 @@ let tag_var = tag Tag.variable pr_reference r, latom | CPatOr pl -> - let pp = pr_patt mt (lpator,Any) in + let pp p = hov 0 (pr_patt mt (lpator,Any) p) in surround (hov 0 (prlist_with_sep pr_spcbar pp pl)), lpator | CPatNotation ((_,"( _ )"),([p],[]),[]) -> @@ -304,7 +304,8 @@ let tag_var = tag Tag.variable spc() ++ hov 4 (pr_with_comments ?loc (str "| " ++ - hov 0 (prlist_with_sep pr_spcbar (prlist_with_sep sep_v (pr_patt ltop)) pl + hov 0 (prlist_with_sep pr_spcbar + (fun p -> hov 0 (prlist_with_sep sep_v (pr_patt ltop) p)) pl ++ str " =>") ++ pr_sep_com spc (pr ltop) rhs)) diff --git a/printing/printer.ml b/printing/printer.ml index bb54f587fd..97e0528939 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -490,8 +490,8 @@ let pr_concl n ?(diffs=false) ?og_s sigma g = header ++ str " is:" ++ cut () ++ str" " ++ pc (* display evar type: a context and a type *) -let pr_evgl_sign sigma evi = - let env = evar_env evi in +let pr_evgl_sign env sigma evi = + let env = evar_env env evi in let ps = pr_named_context_of env sigma in let _, l = match Filter.repr (evar_filter evi) with | None -> [], [] @@ -517,7 +517,8 @@ let pr_evgl_sign sigma evi = (* Print an existential variable *) let pr_evar sigma (evk, evi) = - let pegl = pr_evgl_sign sigma evi in + let env = Global.env () in + let pegl = pr_evgl_sign env sigma evi in hov 0 (pr_existential_key sigma evk ++ str " : " ++ pegl) (* Print an enumerated list of existential variables *) diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 58c0f7db53..e466992721 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -678,7 +678,7 @@ let define_with_type sigma env ev c = let t = Retyping.get_type_of env sigma ev in let ty = Retyping.get_type_of env sigma c in let j = Environ.make_judge c ty in - let (sigma, j) = Coercion.inh_conv_coerce_to ~program_mode:false true env sigma j t in + let (sigma, j, _trace) = Coercion.inh_conv_coerce_to ~program_mode:false true env sigma j t in let (ev, _) = destEvar sigma ev in let sigma = Evd.define ev j.Environ.uj_val sigma in sigma diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index 59918ab2f9..8297b11585 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -44,10 +44,10 @@ let define_and_solve_constraints evk c env evd = | Success evd -> evd | UnifFailure _ -> user_err Pp.(str "Instance does not satisfy the constraints.") -let w_refine (evk,evi) (ltac_var,rawc) sigma = +let w_refine (evk,evi) (ltac_var,rawc) env sigma = if Evd.is_defined sigma evk then user_err Pp.(str "Instantiate called on already-defined evar"); - let env = Evd.evar_filtered_env evi in + let env = Evd.evar_filtered_env env evi in let sigma',typed_c = let flags = { Pretyping.use_typeclasses = true; diff --git a/proofs/evar_refiner.mli b/proofs/evar_refiner.mli index 8f3ac7ed25..a618bf1c94 100644 --- a/proofs/evar_refiner.mli +++ b/proofs/evar_refiner.mli @@ -17,4 +17,4 @@ open Ltac_pretype type glob_constr_ltac_closure = ltac_var_map * glob_constr val w_refine : Evar.t * evar_info -> - glob_constr_ltac_closure -> evar_map -> evar_map + glob_constr_ltac_closure -> Environ.env -> evar_map -> evar_map diff --git a/proofs/goal.ml b/proofs/goal.ml index 426fba7f63..4759c0860f 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -31,8 +31,9 @@ module V82 = struct (* Old style env primitive *) let env evars gl = + let env = Global.env () in let evi = Evd.find evars gl in - Evd.evar_filtered_env evi + Evd.evar_filtered_env env evi (* Old style hyps primitive *) let hyps evars gl = diff --git a/proofs/proof.ml b/proofs/proof.ml index e9f93d0c8f..5ab4409f8b 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -434,10 +434,10 @@ module V82 = struct else CList.nth evl (n-1) in - let env = Evd.evar_filtered_env evi in + let env = Evd.evar_filtered_env env evi in let rawc = intern env sigma in let ltac_vars = Glob_ops.empty_lvar in - let sigma = Evar_refiner.w_refine (evk, evi) (ltac_vars, rawc) sigma in + let sigma = Evar_refiner.w_refine (evk, evi) (ltac_vars, rawc) env sigma in Proofview.Unsafe.tclEVARS sigma end in let { name; poly } = pr in diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index 909804d0c9..fd689602df 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -138,7 +138,7 @@ 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" - | "-load-ml-object" | "-load-ml-source" | "-require" | "-w" | "-color" | "-init-file" + | "-require" | "-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/stm.ml b/stm/stm.ml index eff2403eca..4c539684e3 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -2362,7 +2362,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = let st = Summary.remove_from_summary st Util.(pi1 summary_pstate) in let st = Summary.remove_from_summary st Util.(pi2 summary_pstate) in let st = Summary.remove_from_summary st Util.(pi3 summary_pstate) in - st, Lib.freeze ~marshallable:false in + st, Lib.freeze () in let inject_non_pstate (s,l) = Summary.unfreeze_summaries ~partial:true s; Lib.unfreeze l; update_global_env () diff --git a/tactics/declare.ml b/tactics/declare.ml index 133b26a99d..c7581fb0e0 100644 --- a/tactics/declare.ml +++ b/tactics/declare.ml @@ -366,7 +366,7 @@ let objVariable : unit Libobject.Dyn.tag = let inVariable v = Libobject.Dyn.Easy.inj v objVariable let declare_variable ~name ~kind d = - (* Constr raisonne sur les noms courts *) + (* Variables are distinguished by only short names *) if Decls.variable_exists name then raise (AlreadyDeclared (None, name)); diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml index d6fda00ad8..6cdb24965d 100644 --- a/tactics/elimschemes.ml +++ b/tactics/elimschemes.ml @@ -49,14 +49,14 @@ let optimize_non_type_induction_scheme kind dep sort ind = let sigma = Evd.minimize_universes sigma in (Evarutil.nf_evars_universes sigma c', Evd.evar_universe_context sigma) else - let sigma, pind = Evd.fresh_inductive_instance env sigma ind in + 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) let build_induction_scheme_in_type dep sort ind = let env = Global.env () in let sigma = Evd.from_env env in - let sigma, pind = Evd.fresh_inductive_instance env sigma ind in + 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 diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 9258a75461..f6f7c71dfd 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -2977,6 +2977,13 @@ let quantify lconstr = (* Modifying/Adding an hypothesis *) +(* This applies (f i) to all elements of ctxt where the debrujn i is + free (so it is lifted at each level). *) +let rec map_rel_context_lift f env i (ctxt:EConstr.rel_context):EConstr.rel_context = + match ctxt with + | [] -> ctxt + | decl::ctxt' -> f i decl :: map_rel_context_lift f env (i+1) ctxt' + (* Instantiating some arguments (whatever their position) of an hypothesis or any term, leaving other arguments quantified. If operating on an hypothesis of the goal, the new hypothesis replaces it. @@ -2993,16 +3000,17 @@ let quantify lconstr = solve, ui are a mix of inferred args and yi. The overall effect is to remove from H as much quantification as possible given lbind. *) + let specialize (c,lbind) ipat = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in - let sigma, term = + let typ_of_c = Retyping.get_type_of env sigma c in + let sigma, term, typ = if lbind == NoBindings then - sigma, c + sigma, c, typ_of_c else (* ***** SOLVING ARGS ******* *) - let typ_of_c = Retyping.get_type_of env sigma c in (* If the term is lambda then we put a letin to put avoid interaction between the term and the bindings. *) let c = match EConstr.kind sigma c with @@ -3028,38 +3036,53 @@ let specialize (c,lbind) ipat = | _ -> x in (* We grab names used in product to remember them at re-abstracting phase *) let typ_of_c_hd = pf_get_type_of gl thd in - let lprod, concl = decompose_prod_assum sigma typ_of_c_hd in + let (lprod:rel_context), concl = decompose_prod_assum sigma typ_of_c_hd in (* lprd = initial products (including letins). l(tstack initially) = the same products after unification vs lbind (some metas remain) args: accumulator : args to apply to hd: inferred args + metas reabstracted *) - let rec rebuild_lambdas sigma lprd args hd l = + let rec rebuild sigma concl (lprd:rel_context) (accargs:EConstr.t list) + (accprods:rel_context) hd (l:EConstr.t list) = + let open Context.Rel.Declaration in match lprd , l with - | _, [] -> sigma,applist (hd, (List.map (nf_evar sigma) args)) - | Context.Rel.Declaration.LocalAssum(nme,_)::lp' , t::l' when occur_meta sigma t -> + | _, [] -> sigma + , applist (hd, (List.map (nf_evar sigma) (List.rev accargs))) + , EConstr.it_mkProd_or_LetIn concl accprods + | (LocalAssum(nme,_) as assum)::lp' , t::l' when occur_meta sigma t -> (* nme has not been resolved, let us re-abstract it. Same name but type updated by instantiation of other args. *) let sigma,new_typ_of_t = Typing.type_of clause.env sigma t in let r = Retyping.relevance_of_type env sigma new_typ_of_t in - let liftedargs = List.map liftrel args in (* lifting rels in the accumulator args *) - let sigma,hd' = rebuild_lambdas sigma lp' (liftedargs@[mkRel 1 ]) hd l' in + let liftedargs = List.map liftrel accargs in + let sigma,hd',prods = + rebuild sigma concl lp' (mkRel 1 ::liftedargs) (assum::accprods) hd l' in (* replace meta variable by the abstracted variable *) let hd'' = subst_term sigma t hd' in - (* lambda expansion *) - sigma,mkLambda ({nme with binder_relevance=r},new_typ_of_t,hd'') - | Context.Rel.Declaration.LocalAssum _::lp' , t::l' -> - let sigma,hd' = rebuild_lambdas sigma lp' (args@[t]) hd l' in - sigma,hd' - | Context.Rel.Declaration.LocalDef _::lp' , _ -> - (* letins have been reduced in l and should anyway not - correspond to an arg, we ignore them. *) - let sigma,hd' = rebuild_lambdas sigma lp' args hd l in - sigma,hd' + (* we reabstract the non solved argument *) + sigma,mkLambda ({nme with binder_relevance=r},new_typ_of_t,hd''),prods + | (LocalAssum (nme,tnme))::lp' , t::l' -> + (* thie arg was solved, we update thing accordingly *) + (* we replace in lprod the arg by rel 1 *) + let substlp' = (* rel 1 must be lifted along the context *) + map_rel_context_lift (fun i x -> map_constr (replace_term sigma (mkRel i) t) x) + env 1 lp' in + (* Then we lift every rel above the just removed arg *) + let updatedlp' = + map_rel_context_lift (fun i x -> map_constr (liftn (-1) i) x) env 1 substlp' in + (* We replace also the term in the conclusion, its rel index is the + length of the list lprd (remaining products before concl) *) + let concl'' = replace_term sigma (mkRel (List.length lprd)) t concl in + (* we also lift in concl the index above the arg *) + let concl' = liftn (-1) (List.length lprd) concl'' in + rebuild sigma concl' updatedlp' (t::accargs) accprods hd l' + | LocalDef _ as assum::lp' , _ -> + (* letins have been reduced in l and should anyway not correspond to an arg, we + ignore them, but we remember them in accprod, so that they remain in the type. *) + rebuild sigma concl lp' accargs (assum::accprods) hd l | _ ,_ -> assert false in - let sigma,hd = rebuild_lambdas sigma (List.rev lprod) [] thd tstack in - Evd.clear_metas sigma, hd + let sigma,hd,newtype = rebuild sigma concl (List.rev lprod) [] [] thd tstack in + Evd.clear_metas sigma, hd, newtype in - let typ = Retyping.get_type_of env sigma term in let tac = match EConstr.kind sigma (fst(EConstr.decompose_app sigma (snd(EConstr.decompose_lam_assum sigma c)))) with | Var id when Id.List.mem id (Tacmach.New.pf_ids_of_hyps gl) -> diff --git a/test-suite/Makefile b/test-suite/Makefile index b3a633e528..265c2eafa7 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -530,14 +530,16 @@ $(addsuffix .log,$(wildcard complexity/*.v)): %.v.log: %.v $(PREREQUISITELOG) $(HIDE){ \ echo $(call log_intro,$<); \ true "extract effective user time"; \ - res=`$(coqc_interactive) "$<" $(call get_coq_prog_args,"$<") 2>&1 | sed -n -e "s/Finished transaction in .*(\([0-9]*\.[0-9]*\)u.*)/\1/p" | head -1 | sed "s/\r//g"`; \ + res=`$(coqc_interactive) "$<" $(call get_coq_prog_args,"$<") 2>&1 | sed -n -e "s/Finished .*transaction in .*(\([0-9]*\.[0-9]*\)u.*)/\1/p" | head -1 | sed "s/\r//g"`; \ R=$$?; times; \ if [ $$R != 0 ]; then \ echo $(log_failure); \ echo " $<...Error! (should be accepted)" ; \ + $(FAIL); \ elif [ "$$res" = "" ]; then \ echo $(log_failure); \ echo " $<...Error! (couldn't find a time measure)"; \ + $(FAIL); \ else \ true "express effective time in centiseconds"; \ resorig="$$res"; \ @@ -641,7 +643,7 @@ vio: $(patsubst %.v,%.vio.log,$(wildcard vio/*.v)) %.vio.log:%.v @echo "TEST $<" $(HIDE){ \ - $(coqc) -quick -R vio vio $* 2>&1 && \ + $(coqc) -vio -R vio vio $* 2>&1 && \ $(coqc) -R vio vio -vio2vo $*.vio 2>&1 && \ $(coqchk) -R vio vio -norec $(subst /,.,$*) 2>&1; \ if [ $$? = 0 ]; then \ diff --git a/test-suite/bugs/bug_11140.v b/test-suite/bugs/bug_11140.v new file mode 100644 index 0000000000..ca806ea324 --- /dev/null +++ b/test-suite/bugs/bug_11140.v @@ -0,0 +1,11 @@ +Axiom T : nat -> Prop. +Axiom f : forall x, T x. +Arguments f & x. + +Lemma test : (f (1 + _) : T 2) = f 2. +match goal with +| |- (f (1 + 1) = f 2) => idtac +| |- (f 2 = f 2) => fail (* Issue 11140 *) +| |- _ => fail +end. +Abort. diff --git a/test-suite/bugs/closed/bug_11133.v b/test-suite/bugs/closed/bug_11133.v new file mode 100644 index 0000000000..87f15a4a19 --- /dev/null +++ b/test-suite/bugs/closed/bug_11133.v @@ -0,0 +1,18 @@ +Module Type Universe. +Parameter U : nat. +End Universe. + +Module Univ_prop (Univ : Universe). +Include Univ. +End Univ_prop. + +Module Monad (Univ : Universe). +Module UP := (Univ_prop Univ). +End Monad. + +Module Rules (Univ:Universe). +Module MP := Monad Univ. +Include MP. +Import UP. +Definition M := UP.U. (* anomaly here *) +End Rules. diff --git a/test-suite/bugs/closed/bug_11168.v b/test-suite/bugs/closed/bug_11168.v new file mode 100644 index 0000000000..6e109e33e6 --- /dev/null +++ b/test-suite/bugs/closed/bug_11168.v @@ -0,0 +1,5 @@ +Axiom f : forall T, T. +Arguments f &. +Check f _ _. +Check f (_ -> _) _. +Check f (forall x, _) _. diff --git a/test-suite/bugs/closed/bug_11321.v b/test-suite/bugs/closed/bug_11321.v new file mode 100644 index 0000000000..ce95280fb1 --- /dev/null +++ b/test-suite/bugs/closed/bug_11321.v @@ -0,0 +1,10 @@ +Require Import Cyclic63. + +Goal False. +Proof. +assert (4294967296 *c 2147483648 = WW 2 0)%int63 as H. + vm_cast_no_check (@eq_refl (zn2z int) (WW 2 0)%int63). +generalize (f_equal (zn2z_to_Z wB to_Z) H). +now rewrite mulc_WW_spec. +Fail Qed. +Abort. diff --git a/test-suite/bugs/closed/bug_11360.v b/test-suite/bugs/closed/bug_11360.v new file mode 100644 index 0000000000..d8bc4a9f02 --- /dev/null +++ b/test-suite/bugs/closed/bug_11360.v @@ -0,0 +1,6 @@ +Section S. + Variable (A:Type). + #[universes(template)] + Inductive bar (d:A) := . +End S. +Check bar nat 0. diff --git a/test-suite/bugs/closed/bug_11421.v b/test-suite/bugs/closed/bug_11421.v new file mode 100644 index 0000000000..8ddf05c888 --- /dev/null +++ b/test-suite/bugs/closed/bug_11421.v @@ -0,0 +1 @@ +Fail Definition plus1_plus1 : Type@{Set+1} := Type@{Set+1}. diff --git a/test-suite/bugs/closed/bug_2729.v b/test-suite/bugs/closed/bug_2729.v index ff08bdc6bb..52cc34beb3 100644 --- a/test-suite/bugs/closed/bug_2729.v +++ b/test-suite/bugs/closed/bug_2729.v @@ -82,7 +82,7 @@ Inductive SequenceBase (pu : PatchUniverse) (p : pu_type from mid) (qs : SequenceBase pu mid to), SequenceBase pu from to. -Arguments Nil [pu cxt]. +Arguments Nil {pu cxt}. Arguments Cons [pu from mid to]. Program Fixpoint insertBase {pu : PatchUniverse} diff --git a/test-suite/complexity/injection.v b/test-suite/complexity/injection.v index 298a07c1c4..7022987096 100644 --- a/test-suite/complexity/injection.v +++ b/test-suite/complexity/injection.v @@ -47,7 +47,7 @@ Parameter mkJoinmap : forall (key: Type) (t: Type) (j: joinable t), joinmap key j. Parameter ADMIT: forall p: Prop, p. -Arguments ADMIT [p]. +Arguments ADMIT {p}. Module Share. Parameter jb : joinable bool. diff --git a/test-suite/coq-makefile/findlib-package-unpacked/Makefile.local b/test-suite/coq-makefile/findlib-package-unpacked/Makefile.local new file mode 100644 index 0000000000..0f4a7d9954 --- /dev/null +++ b/test-suite/coq-makefile/findlib-package-unpacked/Makefile.local @@ -0,0 +1 @@ +CAMLPKGS += -package foo diff --git a/test-suite/coq-makefile/findlib-package-unpacked/_CoqProject b/test-suite/coq-makefile/findlib-package-unpacked/_CoqProject new file mode 100644 index 0000000000..cbdb43f842 --- /dev/null +++ b/test-suite/coq-makefile/findlib-package-unpacked/_CoqProject @@ -0,0 +1,10 @@ +-R src test +-R theories test +-I src + +src/test_plugin.mllib +src/test.mlg +src/test.mli +src/test_aux.ml +src/test_aux.mli +theories/test.v diff --git a/test-suite/coq-makefile/findlib-package-unpacked/findlib/foo/META b/test-suite/coq-makefile/findlib-package-unpacked/findlib/foo/META new file mode 100644 index 0000000000..ff5f1c7c96 --- /dev/null +++ b/test-suite/coq-makefile/findlib-package-unpacked/findlib/foo/META @@ -0,0 +1,4 @@ +archive(byte)="foo.cma" +archive(native)="foo.cmxa" +linkopts="-linkall" +requires="str" diff --git a/test-suite/coq-makefile/findlib-package-unpacked/findlib/foo/Makefile b/test-suite/coq-makefile/findlib-package-unpacked/findlib/foo/Makefile new file mode 100644 index 0000000000..1615bfd067 --- /dev/null +++ b/test-suite/coq-makefile/findlib-package-unpacked/findlib/foo/Makefile @@ -0,0 +1,14 @@ +-include ../../Makefile.conf + +CO="$(COQMF_OCAMLFIND)" opt +CB="$(COQMF_OCAMLFIND)" ocamlc + +all: + $(CO) -c foolib.ml + $(CO) -a foolib.cmx -o foo.cmxa + $(CB) -c foolib.ml + $(CB) -a foolib.cmo -o foo.cma + $(CB) -c foo.mli # empty .mli file, to be understood + +clean: + rm -f *.cmo *.cma *.cmx *.cmxa *.cmi *.o *.a diff --git a/test-suite/coq-makefile/findlib-package-unpacked/findlib/foo/foo.mli b/test-suite/coq-makefile/findlib-package-unpacked/findlib/foo/foo.mli new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/test-suite/coq-makefile/findlib-package-unpacked/findlib/foo/foo.mli diff --git a/test-suite/coq-makefile/findlib-package-unpacked/findlib/foo/foolib.ml b/test-suite/coq-makefile/findlib-package-unpacked/findlib/foo/foolib.ml new file mode 100644 index 0000000000..81306fb89b --- /dev/null +++ b/test-suite/coq-makefile/findlib-package-unpacked/findlib/foo/foolib.ml @@ -0,0 +1,2 @@ +let foo () = + assert(Str.search_forward (Str.regexp "foo") "barfoobar" 0 = 3) diff --git a/test-suite/coq-makefile/findlib-package-unpacked/run.sh b/test-suite/coq-makefile/findlib-package-unpacked/run.sh new file mode 100755 index 0000000000..e53a7ed0f7 --- /dev/null +++ b/test-suite/coq-makefile/findlib-package-unpacked/run.sh @@ -0,0 +1,20 @@ +#!/usr/bin/env bash + +. ../template/init.sh +mv src/test_plugin.mlpack src/test_plugin.mllib + +echo "let () = Foolib.foo ();;" >> src/test_aux.ml +export OCAMLPATH=$OCAMLPATH:$PWD/findlib +if which cygpath 2>/dev/null; then + # the only way I found to pass OCAMLPATH on win is to have it contain + # only one entry + OCAMLPATH=$(cygpath -w "$PWD"/findlib) + export OCAMLPATH +fi +make -C findlib/foo clean +coq_makefile -f _CoqProject -o Makefile +cat Makefile.conf +cat Makefile.local +make -C findlib/foo +make +make byte diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/run.sh b/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/run.sh index e1f17725dc..13e484b852 100755 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/run.sh +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/run.sh @@ -5,20 +5,14 @@ set -e cd "$(dirname "${BASH_SOURCE[0]}")" -python2 "$COQLIB"/tools/make-one-time-file.py time-of-build.log.in time-of-build-pretty.log2 || exit $? -python3 "$COQLIB"/tools/make-one-time-file.py time-of-build.log.in time-of-build-pretty.log3 || exit $? +"$COQLIB"/tools/make-one-time-file.py time-of-build.log.in time-of-build-pretty.log || exit $? -diff -u time-of-build-pretty.log.expected time-of-build-pretty.log2 || exit $? -diff -u time-of-build-pretty.log.expected time-of-build-pretty.log3 || exit $? +diff -u time-of-build-pretty.log.expected time-of-build-pretty.log || exit $? -cat time-of-build.log.in | python2 "$COQLIB"/tools/make-one-time-file.py - time-of-build-pretty.log2 || exit $? -cat time-of-build.log.in | python3 "$COQLIB"/tools/make-one-time-file.py - time-of-build-pretty.log3 || exit $? +cat time-of-build.log.in | "$COQLIB"/tools/make-one-time-file.py - time-of-build-pretty.log || exit $? -diff -u time-of-build-pretty.log.expected time-of-build-pretty.log2 || exit $? -diff -u time-of-build-pretty.log.expected time-of-build-pretty.log3 || exit $? +diff -u time-of-build-pretty.log.expected time-of-build-pretty.log || exit $? -(python2 "$COQLIB"/tools/make-one-time-file.py time-of-build.log.in - || exit $?) > time-of-build-pretty.log2 -(python3 "$COQLIB"/tools/make-one-time-file.py time-of-build.log.in - || exit $?) > time-of-build-pretty.log3 +("$COQLIB"/tools/make-one-time-file.py time-of-build.log.in - || exit $?) > time-of-build-pretty.log -diff -u time-of-build-pretty.log.expected time-of-build-pretty.log2 || exit $? -diff -u time-of-build-pretty.log.expected time-of-build-pretty.log3 || exit $? +diff -u time-of-build-pretty.log.expected time-of-build-pretty.log || exit $? 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 9f3b648aa3..cfacf738a3 100755 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/run.sh +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/run.sh @@ -9,3 +9,4 @@ export COQLIB ./001-correct-diff-sorting-order/run.sh ./002-single-file-sorting/run.sh +./003-non-utf8/run.sh diff --git a/test-suite/coqdoc/bug11353.html.out b/test-suite/coqdoc/bug11353.html.out new file mode 100644 index 0000000000..0b4b4b6e37 --- /dev/null +++ b/test-suite/coqdoc/bug11353.html.out @@ -0,0 +1,39 @@ +<!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.bug11353</title> +</head> + +<body> + +<div id="page"> + +<div id="header"> +</div> + +<div id="main"> + +<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/> + +<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/> +</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/bug11353.tex.out b/test-suite/coqdoc/bug11353.tex.out new file mode 100644 index 0000000000..a6478682d8 --- /dev/null +++ b/test-suite/coqdoc/bug11353.tex.out @@ -0,0 +1,34 @@ +\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.bug11353}{Library }{Coqdoc.bug11353} + +\begin{coqdoccode} +\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 +\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 +\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 +\coqdocemptyline +\coqdocnoindent +\#[\coqdocvar{local}]\coqdockw{Definition} \coqdef{Coqdoc.bug11353.b}{b}{\coqdocdefinition{b}} := 1.\coqdoceol +\end{coqdoccode} +\end{document} diff --git a/test-suite/coqdoc/bug11353.v b/test-suite/coqdoc/bug11353.v new file mode 100644 index 0000000000..b68902c8cc --- /dev/null +++ b/test-suite/coqdoc/bug11353.v @@ -0,0 +1,7 @@ +(* -*- coq-prog-args: ("-g") -*- *) +Definition a := 0. #[ (* templatize *) universes( template) ] +Inductive mysum (A B:Type) : Type := + | myinl : A -> mysum A B + | myinr : B -> mysum A B. + +#[local]Definition b := 1. diff --git a/test-suite/failure/Template.v b/test-suite/failure/Template.v index 75b2a56169..fbd9c8bcba 100644 --- a/test-suite/failure/Template.v +++ b/test-suite/failure/Template.v @@ -1,4 +1,4 @@ -(* + Module TestUnsetTemplateCheck. Unset Template Check. @@ -15,18 +15,14 @@ Module TestUnsetTemplateCheck. (* Can only succeed if no template check is performed *) Check myind True : Prop. - Print Assumptions myind. - (* - Axioms: - myind is template polymorphic on all its universe parameters. - *) About myind. -(* -myind : Type@{Top.60} -> Type@{Top.60} -myind is assumed template universe polymorphic on Top.60 -Argument scope is [type_scope] -Expands to: Inductive Top.TestUnsetTemplateCheck.myind -*) + (* test discharge puts things in the right order (by using the + checker on the result) *) + Section S. + + Variables (A:Type) (a:A). + Inductive bb (B:Type) := BB : forall a', a = a' -> B -> bb B. + End S. + End TestUnsetTemplateCheck. -*) diff --git a/test-suite/micromega/bug_11191a.v b/test-suite/micromega/bug_11191a.v new file mode 100644 index 0000000000..57c1d7d52f --- /dev/null +++ b/test-suite/micromega/bug_11191a.v @@ -0,0 +1,6 @@ +Require Import ZArith Lia. + +Goal forall p n, (0 < Z.pos (p ^ n))%Z. + intros. + lia. +Qed. diff --git a/test-suite/micromega/bug_11191b.v b/test-suite/micromega/bug_11191b.v new file mode 100644 index 0000000000..007470c5b3 --- /dev/null +++ b/test-suite/micromega/bug_11191b.v @@ -0,0 +1,6 @@ +Require Import ZArith Lia. + +Goal forall p, (0 < Z.pos (p ^ 2))%Z. + intros. + lia. +Qed. diff --git a/test-suite/misc/quick-include.sh b/test-suite/misc/quick-include.sh index 96bdee2fc2..e60fb48bca 100755 --- a/test-suite/misc/quick-include.sh +++ b/test-suite/misc/quick-include.sh @@ -1,5 +1,5 @@ #!/bin/sh set -e -$coqc -R misc/quick-include/ QuickInclude -quick misc/quick-include/file1.v -$coqc -R misc/quick-include/ QuickInclude -quick misc/quick-include/file2.v +$coqc -R misc/quick-include/ QuickInclude -vio misc/quick-include/file1.v +$coqc -R misc/quick-include/ QuickInclude -vio misc/quick-include/file2.v diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out index e84ac85aa8..6976610b22 100644 --- a/test-suite/output/Cases.out +++ b/test-suite/output/Cases.out @@ -166,3 +166,15 @@ fun x : K => match x with : K -> nat The command has indeed failed with message: Pattern "S _, _" is redundant in this clause. +stray = +fun N : Tree => +match N with +| App (App Node (Node as strayvariable)) _ | + App (App Node (App Node _ as strayvariable)) _ | + App (App Node (App (App Node Node) (App _ _) as strayvariable)) _ | + App (App Node (App (App Node (App _ _)) _ as strayvariable)) _ | + App (App Node (App (App (App _ _) _) _ as strayvariable)) _ => + strayvariable +| _ => Node +end + : Tree -> Tree diff --git a/test-suite/output/Cases.v b/test-suite/output/Cases.v index a040b69b44..262ec2b677 100644 --- a/test-suite/output/Cases.v +++ b/test-suite/output/Cases.v @@ -222,3 +222,23 @@ Check fun x => match x with a3 | a4 | a1 => 3 | _ => 2 end. (* Test redundant clause within a disjunctive pattern *) Fail Check fun n m => match n, m with 0, 0 | _, S _ | S 0, _ | S (S _ | _), _ => false end. + +Module Bug11231. + +(* Missing dependency in computing if a clause is a default clause *) + +Inductive Tree: Set := +| Node : Tree +| App : Tree -> Tree -> Tree +. + +Definition stray N := +match N with +| App (App Node (App (App Node Node) Node)) _ => Node +| App (App Node strayvariable) _ => strayvariable +| _ => Node +end. + +Print stray. + +End Bug11231. diff --git a/test-suite/output/ErrorInModule.v b/test-suite/output/ErrorInModule.v index b2e3c3e923..fbb3c6bdab 100644 --- a/test-suite/output/ErrorInModule.v +++ b/test-suite/output/ErrorInModule.v @@ -1,4 +1,4 @@ -(* -*- mode: coq; coq-prog-args: ("-quick") -*- *) +(* -*- mode: coq; coq-prog-args: ("-vio") -*- *) Module M. Definition foo := nonexistent. End M. diff --git a/test-suite/output/ErrorInSection.v b/test-suite/output/ErrorInSection.v index 505c5ce378..a961330b81 100644 --- a/test-suite/output/ErrorInSection.v +++ b/test-suite/output/ErrorInSection.v @@ -1,4 +1,4 @@ -(* -*- mode: coq; coq-prog-args: ("-quick") -*- *) +(* -*- mode: coq; coq-prog-args: ("-vio") -*- *) Section S. Definition foo := nonexistent. End S. diff --git a/test-suite/output/ExtractionString.out b/test-suite/output/ExtractionString.out new file mode 100644 index 0000000000..2a101d9cea --- /dev/null +++ b/test-suite/output/ExtractionString.out @@ -0,0 +1,52 @@ +(** val str : string **) + +let str = + String ((Ascii (False, False, True, False, True, False, True, False)), + (String ((Ascii (False, False, False, True, False, True, True, False)), + (String ((Ascii (True, False, False, True, False, True, True, False)), + (String ((Ascii (True, True, False, False, True, True, True, False)), + (String ((Ascii (False, False, False, False, False, True, False, False)), + (String ((Ascii (True, False, False, True, False, True, True, False)), + (String ((Ascii (True, True, False, False, True, True, True, False)), + (String ((Ascii (False, False, False, False, False, True, False, False)), + (String ((Ascii (True, False, False, False, False, True, True, False)), + (String ((Ascii (False, False, False, False, False, True, False, False)), + (String ((Ascii (True, True, False, False, True, True, True, False)), + (String ((Ascii (False, False, True, False, True, True, True, False)), + (String ((Ascii (False, True, False, False, True, True, True, False)), + (String ((Ascii (True, False, False, True, False, True, True, False)), + (String ((Ascii (False, True, True, True, False, True, True, False)), + (String ((Ascii (True, True, True, False, False, True, True, False)), + EmptyString))))))))))))))))))))))))))))))) +str :: String +str = + String0 (Ascii False False True False True False True False) (String0 + (Ascii False False False True False True True False) (String0 (Ascii True + False False True False True True False) (String0 (Ascii True True False + False True True True False) (String0 (Ascii False False False False False + True False False) (String0 (Ascii True False False True False True True + False) (String0 (Ascii True True False False True True True False) + (String0 (Ascii False False False False False True False False) (String0 + (Ascii True False False False False True True False) (String0 (Ascii + False False False False False True False False) (String0 (Ascii True True + False False True True True False) (String0 (Ascii False False True False + True True True False) (String0 (Ascii False True False False True True + True False) (String0 (Ascii True False False True False True True False) + (String0 (Ascii False True True True False True True False) (String0 + (Ascii True True True False False True True False) + EmptyString))))))))))))))) + + +(** val str : char list **) + +let str = + 'T'::('h'::('i'::('s'::(' '::('i'::('s'::(' '::('a'::(' '::('s'::('t'::('r'::('i'::('n'::('g'::[]))))))))))))))) +(** val str : string **) + +let str = + "This is a string" +str :: Prelude.String +str = + "This is a string" + + diff --git a/test-suite/output/ExtractionString.v b/test-suite/output/ExtractionString.v new file mode 100644 index 0000000000..e4b9d22b38 --- /dev/null +++ b/test-suite/output/ExtractionString.v @@ -0,0 +1,25 @@ +Require Import String Extraction. + +Definition str := "This is a string"%string. + +(* Raw extraction of strings, in OCaml *) +Extraction Language OCaml. +Extraction str. + +(* Raw extraction of strings, in Haskell *) +Extraction Language Haskell. +Extraction str. + +(* Extraction to char list, in OCaml *) +Require Import ExtrOcamlString. +Extraction Language OCaml. +Extraction str. + +(* Extraction to native strings, in OCaml *) +Require Import ExtrOcamlNativeString. +Extraction str. + +(* Extraction to native strings, in Haskell *) +Require Import ExtrHaskellString. +Extraction Language Haskell. +Extraction str. diff --git a/test-suite/output/PrintCanonicalProjections.out b/test-suite/output/PrintCanonicalProjections.out new file mode 100644 index 0000000000..a4e2251440 --- /dev/null +++ b/test-suite/output/PrintCanonicalProjections.out @@ -0,0 +1,18 @@ +bool <- sort_eq ( bool_eqType ) +bool <- sort_TYPE ( bool_TYPE ) +nat <- sort_eq ( nat_eqType ) +nat <- sort_TYPE ( nat_TYPE ) +prod <- sort_eq ( prod_eqType ) +prod <- sort_TYPE ( prod_TYPE ) +sum <- sort_eq ( sum_eqType ) +sum <- sort_TYPE ( sum_TYPE ) +sum <- sort_TYPE ( sum_TYPE ) +prod <- sort_TYPE ( prod_TYPE ) +nat <- sort_TYPE ( nat_TYPE ) +bool <- sort_TYPE ( bool_TYPE ) +sum <- sort_eq ( sum_eqType ) +prod <- sort_eq ( prod_eqType ) +nat <- sort_eq ( nat_eqType ) +bool <- sort_eq ( bool_eqType ) +bool <- sort_TYPE ( bool_TYPE ) +bool <- sort_eq ( bool_eqType ) diff --git a/test-suite/output/PrintCanonicalProjections.v b/test-suite/output/PrintCanonicalProjections.v new file mode 100644 index 0000000000..808cdffe39 --- /dev/null +++ b/test-suite/output/PrintCanonicalProjections.v @@ -0,0 +1,46 @@ +Record TYPE := Pack_TYPE { sort_TYPE :> Type }. +Record eqType := Pack_eq { sort_eq :> Type; _ : sort_eq -> sort_eq -> bool }. + +Definition eq_op (T : eqType) : T -> T -> bool := + match T with Pack_eq _ op => op end. + +Definition bool_eqb b1 b2 := + match b1, b2 with + | false, false => true + | true, true => true + | _, _ => false + end. + +Canonical bool_TYPE := Pack_TYPE bool. +Canonical bool_eqType := Pack_eq bool bool_eqb. + +Canonical nat_TYPE := Pack_TYPE nat. +Canonical nat_eqType := Pack_eq nat Nat.eqb. + +Definition prod_eqb (T U : eqType) (x y : T * U) := + match x, y with + | (x1, x2), (y1, y2) => + andb (eq_op _ x1 y1) (eq_op _ x2 y2) + end. + +Canonical prod_TYPE (T U : TYPE) := Pack_TYPE (T * U). +Canonical prod_eqType (T U : eqType) := Pack_eq (T * U) (prod_eqb T U). + +Definition sum_eqb (T U : eqType) (x y : T + U) := + match x, y with + | inl x, inl y => eq_op _ x y + | inr x, inr y => eq_op _ x y + | _, _ => false + end. + +Canonical sum_TYPE (T U : TYPE) := Pack_TYPE (T + U). +Canonical sum_eqType (T U : eqType) := Pack_eq (T + U) (sum_eqb T U). + +Print Canonical Projections bool. +Print Canonical Projections nat. +Print Canonical Projections prod. +Print Canonical Projections sum. +Print Canonical Projections sort_TYPE. +Print Canonical Projections sort_eq. +Print Canonical Projections sort_TYPE bool. +Print Canonical Projections bool_eqType. diff --git a/test-suite/output/QArithSyntax.out b/test-suite/output/QArithSyntax.out new file mode 100644 index 0000000000..6bc04f1cef --- /dev/null +++ b/test-suite/output/QArithSyntax.out @@ -0,0 +1,14 @@ +eq_refl : 102e-2 = 102e-2 + : 102e-2 = 102e-2 +eq_refl : 102e-1 = 102e-1 + : 102e-1 = 102e-1 +eq_refl : 1020 = 1020 + : 1020 = 1020 +eq_refl : 102 = 102 + : 102 = 102 +eq_refl : 102e-2 = 102e-2 + : 102e-2 = 102e-2 +eq_refl : -1e-4 = -1e-4 + : -1e-4 = -1e-4 +eq_refl : -50e-2 = -50e-2 + : -50e-2 = -50e-2 diff --git a/test-suite/success/QArithSyntax.v b/test-suite/output/QArithSyntax.v index 2f2ee0134a..2f2ee0134a 100644 --- a/test-suite/success/QArithSyntax.v +++ b/test-suite/output/QArithSyntax.v diff --git a/test-suite/output/RealSyntax.out b/test-suite/output/RealSyntax.out index e6f7556d96..2d877bd813 100644 --- a/test-suite/output/RealSyntax.out +++ b/test-suite/output/RealSyntax.out @@ -2,3 +2,17 @@ : R (-31)%R : R +eq_refl : 102e-2 = 102e-2 + : 102e-2 = 102e-2 +eq_refl : 102e-1 = 102e-1 + : 102e-1 = 102e-1 +eq_refl : 102e1 = 102e1 + : 102e1 = 102e1 +eq_refl : 102 = 102 + : 102 = 102 +eq_refl : 102e-2 = 102e-2 + : 102e-2 = 102e-2 +eq_refl : -1e-4 = -1e-4 + : -1e-4 = -1e-4 +eq_refl : -50e-2 = -50e-2 + : -50e-2 = -50e-2 diff --git a/test-suite/output/RealSyntax.v b/test-suite/output/RealSyntax.v index 44e8c7a50c..cb3bce70d4 100644 --- a/test-suite/output/RealSyntax.v +++ b/test-suite/output/RealSyntax.v @@ -1,3 +1,25 @@ Require Import Reals.Rdefinitions. Check 32%R. Check (-31)%R. + +Open Scope R_scope. + +Check (eq_refl : 1.02 = IZR 102 / IZR (Z.pow_pos 10 2)). +Check (eq_refl : 1.02e1 = IZR 102 / IZR (Z.pow_pos 10 1)). +Check (eq_refl : 1.02e+03 = IZR 102 * IZR (Z.pow_pos 10 1)). +Check (eq_refl : 1.02e+02 = IZR 102). +Check (eq_refl : 10.2e-1 = 1.02). +Check (eq_refl : -0.0001 = IZR (-1) / IZR (Z.pow_pos 10 4)). +Check (eq_refl : -0.50 = IZR (-50) / IZR (Z.pow_pos 10 2)). + +Require Import Reals. + +Goal 254e3 = 2540 * 10 ^ 2. +ring. +Qed. + +Require Import Psatz. + +Goal 254e3 = 2540 * 10 ^ 2. +lra. +Qed. diff --git a/test-suite/output/unification.out b/test-suite/output/unification.out new file mode 100644 index 0000000000..dfd755da61 --- /dev/null +++ b/test-suite/output/unification.out @@ -0,0 +1,11 @@ +The command has indeed failed with message: +In environment +x : T +T : Type +a : T +Unable to unify "T" with "?X@{x0:=x; x:=C a}" (cannot instantiate +"?X" because "T" is not in its scope: available arguments are +"x" "C a"). +The command has indeed failed with message: +The term "id" has type "ID" while it is expected to have type +"Type -> ?T" (cannot instantiate "?T" because "A" is not in its scope). diff --git a/test-suite/output/unification.v b/test-suite/output/unification.v new file mode 100644 index 0000000000..ff99f2e23c --- /dev/null +++ b/test-suite/output/unification.v @@ -0,0 +1,12 @@ +(* Unification error tests *) + +Module A. + +(* Check regression of an UNBOUND_REL bug *) +Inductive T := C : forall {A}, A -> T. +Fail Check fun x => match x return ?[X] with C a => a end. + +(* Bug #3634 *) +Fail Check (id:Type -> _). + +End A. diff --git a/test-suite/prerequisite/ssr_mini_mathcomp.v b/test-suite/prerequisite/ssr_mini_mathcomp.v index d293dc0533..048fb3b027 100644 --- a/test-suite/prerequisite/ssr_mini_mathcomp.v +++ b/test-suite/prerequisite/ssr_mini_mathcomp.v @@ -65,7 +65,7 @@ Proof. by []. Qed. Lemma eqP T : Equality.axiom (@eq_op T). Proof. by case: T => ? []. Qed. -Arguments eqP [T x y]. +Arguments eqP {T x y}. Delimit Scope eq_scope with EQ. Open Scope eq_scope. @@ -345,7 +345,7 @@ Proof. by []. Qed. End SubEqType. -Arguments val_eqP [T P sT x y]. +Arguments val_eqP {T P sT x y}. Prenex Implicits val_eqP. Notation "[ 'eqMixin' 'of' T 'by' <: ]" := (SubEqMixin _ : Equality.class_of T) @@ -386,7 +386,7 @@ Qed. Canonical nat_eqMixin := EqMixin eqnP. Canonical nat_eqType := Eval hnf in EqType nat nat_eqMixin. -Arguments eqnP [x y]. +Arguments eqnP {x y}. Prenex Implicits eqnP. Coercion nat_of_bool (b : bool) := if b then 1 else 0. diff --git a/test-suite/ssr/under.v b/test-suite/ssr/under.v index c12491138a..0312b9c733 100644 --- a/test-suite/ssr/under.v +++ b/test-suite/ssr/under.v @@ -313,8 +313,7 @@ Qed. End TestGeneric2. Section TestPreOrder. -(* inspired by https://github.com/coq/coq/pull/10022#issuecomment-530101950 - but without needing to do [rewrite UnderE] manually. *) +(* inspired by https://github.com/coq/coq/pull/10022#issuecomment-530101950 *) Require Import Morphisms. @@ -330,7 +329,7 @@ Parameter leq_mul : Local Notation "+%N" := addn (at level 0, only parsing). -(** Context lemma (could *) +(** Context lemma *) Lemma leq'_big : forall I (F G : I -> nat) (r : seq I), (forall i : I, leq' (F i) (G i)) -> (leq' (\big[+%N/0%N]_(i <- r) F i) (\big[+%N/0%N]_(i <- r) G i)). @@ -370,8 +369,10 @@ have lem : forall (i : nat), i < n -> leq' (3 + i) (3 + n). under leq'_big => i. { - (* The "magic" is here: instantiate the evar with the bound "3 + n" *) - rewrite lem ?ltn_ord //. over. + rewrite UnderE. + + (* instantiate the evar with the bound "3 + n" *) + apply: lem; exact: ltn_ord. } cbv beta. diff --git a/test-suite/success/CanonicalStructure.v b/test-suite/success/CanonicalStructure.v index e6d674c1e6..88702a6e80 100644 --- a/test-suite/success/CanonicalStructure.v +++ b/test-suite/success/CanonicalStructure.v @@ -51,3 +51,22 @@ Fail Check (refl_equal _ : l _ = x2). Check s0. Check s1. Check s2. + +Section Y. + Let s3 := MKL x3. + Canonical Structure s3. + Check (refl_equal _ : l _ = x3). +End Y. +Fail Check (refl_equal _ : l _ = x3). +Fail Check s3. + +Section V. + #[canonical] Let s3 := MKL x3. + Check (refl_equal _ : l _ = x3). +End V. + +Section W. + #[canonical, local] Definition s2' := MKL x2. + Check (refl_equal _ : l _ = x2). +End W. +Fail Check (refl_equal _ : l _ = x2). diff --git a/test-suite/success/Inductive.v b/test-suite/success/Inductive.v index c2130995fc..4b2d4457bf 100644 --- a/test-suite/success/Inductive.v +++ b/test-suite/success/Inductive.v @@ -71,7 +71,7 @@ CoInductive LList (A : Set) : Set := | LNil : LList A | LCons : A -> LList A -> LList A. -Arguments LNil [A]. +Arguments LNil {A}. Inductive Finite (A : Set) : LList A -> Prop := | Finite_LNil : Finite LNil @@ -204,3 +204,19 @@ End NonRecLetIn. Fail Inductive foo (T : Type) : let T := Type in T := { r : forall x : T, x = x }. + +Module Discharge. + (* discharge test *) + Section S. + Let x := Prop. + Inductive foo : x := bla : foo. + End S. + Check bla:foo. + + Section S. + Variables (A:Type). + (* ensure params are scanned for needed section variables even with template arity *) + #[universes(template)] Inductive bar (d:A) := . + End S. + Check @bar nat 0. +End Discharge. diff --git a/test-suite/success/Inversion.v b/test-suite/success/Inversion.v index 1dbeaf3e1f..8297f54641 100644 --- a/test-suite/success/Inversion.v +++ b/test-suite/success/Inversion.v @@ -31,7 +31,7 @@ Inductive in_extension (I : Set) (r : rule I) : extension I -> Type := | in_first : forall e, in_extension r (add_rule r e) | in_rest : forall e r', in_extension r e -> in_extension r (add_rule r' e). -Arguments NL [I]. +Arguments NL {I}. Inductive super_extension (I : Set) (e : extension I) : extension I -> Type := diff --git a/test-suite/success/Omega.v b/test-suite/success/Omega.v index 470e4f0580..5e0f90d59b 100644 --- a/test-suite/success/Omega.v +++ b/test-suite/success/Omega.v @@ -90,5 +90,5 @@ Qed. (* Postponed... problem with goals of the form "(n*m=0)%nat -> (n*m=0)%Z" *) Lemma lem10 : forall n m:nat, le n (plus n (mult n m)). Proof. -intros; omega with *. +intros; zify; omega. Qed. diff --git a/test-suite/success/OmegaPre.v b/test-suite/success/OmegaPre.v index 17531064cc..0223255067 100644 --- a/test-suite/success/OmegaPre.v +++ b/test-suite/success/OmegaPre.v @@ -16,112 +16,112 @@ Open Scope Z_scope. Goal forall a:Z, Z.max a a = a. intros. -omega with *. +zify; omega. Qed. Goal forall a b:Z, Z.max a b = Z.max b a. intros. -omega with *. +zify; omega. Qed. Goal forall a b c:Z, Z.max a (Z.max b c) = Z.max (Z.max a b) c. intros. -omega with *. +zify; omega. Qed. Goal forall a b:Z, Z.max a b + Z.min a b = a + b. intros. -omega with *. +zify; omega. Qed. Goal forall a:Z, (Z.abs a)*(Z.sgn a) = a. intros. zify. -intuition; subst; omega. (* pure multiplication: omega alone can't do it *) +intuition; subst; zify; omega. (* pure multiplication: zify; omega alone can't do it *) Qed. Goal forall a:Z, Z.abs a = a -> a >= 0. intros. -omega with *. +zify; omega. Qed. Goal forall a:Z, Z.sgn a = a -> a = 1 \/ a = 0 \/ a = -1. intros. -omega with *. +zify; omega. Qed. (* zify_nat *) Goal forall m: nat, (m<2)%nat -> (0<= m+m <=2)%nat. intros. -omega with *. +zify; omega. Qed. Goal forall m:nat, (m<1)%nat -> (m=0)%nat. intros. -omega with *. +zify; omega. Qed. Goal forall m: nat, (m<=100)%nat -> (0<= m+m <=200)%nat. intros. -omega with *. +zify; omega. Qed. (* 2000 instead of 200: works, but quite slow *) Goal forall m: nat, (m*m>=0)%nat. intros. -omega with *. +zify; omega. Qed. (* zify_positive *) Goal forall m: positive, (m<2)%positive -> (2 <= m+m /\ m+m <= 2)%positive. intros. -omega with *. +zify; omega. Qed. Goal forall m:positive, (m<2)%positive -> (m=1)%positive. intros. -omega with *. +zify; omega. Qed. Goal forall m: positive, (m<=1000)%positive -> (2<=m+m/\m+m <=2000)%positive. intros. -omega with *. +zify; omega. Qed. Goal forall m: positive, (m*m>=1)%positive. intros. -omega with *. +zify; omega. Qed. (* zify_N *) Goal forall m:N, (m<2)%N -> (0 <= m+m /\ m+m <= 2)%N. intros. -omega with *. +zify; omega. Qed. Goal forall m:N, (m<1)%N -> (m=0)%N. intros. -omega with *. +zify; omega. Qed. Goal forall m:N, (m<=1000)%N -> (0<=m+m/\m+m <=2000)%N. intros. -omega with *. +zify; omega. Qed. Goal forall m:N, (m*m>=0)%N. intros. -omega with *. +zify; omega. Qed. (* mix of datatypes *) Goal forall p, Z.of_N (N.of_nat (N.to_nat (Npos p))) = Zpos p. intros. -omega with *. +zify; omega. Qed. diff --git a/test-suite/success/RealSyntax.v b/test-suite/success/RealSyntax.v deleted file mode 100644 index 2765200991..0000000000 --- a/test-suite/success/RealSyntax.v +++ /dev/null @@ -1,19 +0,0 @@ -Require Import Reals. -Open Scope R_scope. -Check (eq_refl : 1.02 = IZR 102 / IZR (Z.pow_pos 10 2)). -Check (eq_refl : 1.02e1 = IZR 102 / IZR (Z.pow_pos 10 1)). -Check (eq_refl : 1.02e+03 = IZR 102 * IZR (Z.pow_pos 10 1)). -Check (eq_refl : 1.02e+02 = IZR 102). -Check (eq_refl : 10.2e-1 = 1.02). -Check (eq_refl : -0.0001 = IZR (-1) / IZR (Z.pow_pos 10 4)). -Check (eq_refl : -0.5 = IZR (-5) / IZR (Z.pow_pos 10 1)). - -Goal 254e3 = 2540 * 10 ^ 2. -ring. -Qed. - -Require Import Psatz. - -Goal 254e3 = 2540 * 10 ^ 2. -lra. -Qed. diff --git a/test-suite/success/RecTutorial.v b/test-suite/success/RecTutorial.v index 4fac798f76..15672eab7c 100644 --- a/test-suite/success/RecTutorial.v +++ b/test-suite/success/RecTutorial.v @@ -994,7 +994,7 @@ Qed. Arguments Vector.cons [A] _ [n]. -Arguments Vector.nil [A]. +Arguments Vector.nil {A}. Arguments Vector.hd [A n]. Arguments Vector.tl [A n]. @@ -1161,7 +1161,7 @@ infiniteproof map_iterate'. Qed. -Arguments LNil [A]. +Arguments LNil {A}. Lemma Lnil_not_Lcons : forall (A:Set)(a:A)(l:LList A), LNil <> (LCons a l). diff --git a/test-suite/success/Scheme.v b/test-suite/success/Scheme.v index 855f26698c..4b928007cf 100644 --- a/test-suite/success/Scheme.v +++ b/test-suite/success/Scheme.v @@ -25,3 +25,8 @@ Check myeq_rew_fwd_r_dep. Set Rewriting Schemes. Inductive myeq_true : bool -> Prop := myrefl_true : myeq_true true. Unset Rewriting Schemes. + +(* check that the scheme doesn't minimize itself into something non general *) +Polymorphic Inductive foo@{u v|u<=v} : Type@{u}:= . +Lemma bla@{u v|u < v} : foo@{u v} -> False. +Proof. induction 1. Qed. diff --git a/test-suite/success/custom_entry.v b/test-suite/success/custom_entry.v new file mode 100644 index 0000000000..e88ae65e18 --- /dev/null +++ b/test-suite/success/custom_entry.v @@ -0,0 +1,13 @@ +Declare Custom Entry foo. + +Print Custom Grammar foo. + +Notation "[ e ]" := e (e custom foo at level 0). + +Print Custom Grammar foo. + +Notation "1" := O (in custom foo at level 0). + +Print Custom Grammar foo. + +Fail Declare Custom Entry foo. diff --git a/test-suite/success/rapply.v b/test-suite/success/rapply.v new file mode 100644 index 0000000000..13efd986f0 --- /dev/null +++ b/test-suite/success/rapply.v @@ -0,0 +1,27 @@ +Require Import Coq.Program.Tactics. + +(** We make a version of [rapply] that takes [uconstr]; we do not +currently test what scope [rapply] interprets terms in. *) + +Tactic Notation "urapply" uconstr(p) := rapply p. + +Ltac test n := + (*let __ := match goal with _ => idtac n end in*) + lazymatch n with + | O => let __ := match goal with _ => assert True by urapply I; clear end in + uconstr:(fun _ => I) + | S ?n' + => let lem := test n' in + let __ := match goal with _ => assert True by (unshelve urapply lem; try exact I); clear end in + uconstr:(fun _ : True => lem) + end. + +Goal True. + assert True by urapply I. + assert True by (unshelve urapply (fun _ => I); try exact I). + assert True by (unshelve urapply (fun _ _ => I); try exact I). + assert True by (unshelve urapply (fun _ _ _ => I); try exact I). + clear. + Time let __ := test 50 in idtac. + urapply I. +Qed. diff --git a/test-suite/success/specialize.v b/test-suite/success/specialize.v index 1b04594290..1122b9fa34 100644 --- a/test-suite/success/specialize.v +++ b/test-suite/success/specialize.v @@ -109,28 +109,37 @@ match goal with H:_ |- _ => clear H end. match goal with H:_ |- _ => exact H end. Qed. -(* let ins should be supported in the type of the specialized hypothesis *) -Axiom foo: forall (m1 m2: nat), let n := 2 * m1 in m1 = m2 -> False. + +(* let ins should be supported int he type of the specialized hypothesis *) +Axiom foo: forall (m1:nat) (m2: nat), let n := 2 * m1 in (m1 = m2 -> False). Goal False. pose proof foo as P. assert (2 = 2) as A by reflexivity. + (* specialize P with (m2:= 2). *) specialize P with (1 := A). + match type of P with + | let n := 2 * 2 in False => idtac + | _ => fail "test failed" + end. assumption. Qed. (* Another more subtle test on letins: they should not interfere with foralls. *) -Goal forall (P: forall y:nat, - forall A (zz:A), - let a := zz in - let x := 1 in - forall n : y = x, - n = n), +Goal forall (P: forall a c:nat, + let b := c in + let d := 1 in + forall n : a = d, a = c+1), True. intros P. - specialize P with (zz := @eq_refl _ 2). + specialize P with (1:=eq_refl). + match type of P with + | forall c : nat, let f := c in let d := 1 in 1 = c + 1 => idtac + | _ => fail "test failed" + end. constructor. Qed. + (* Test specialize as *) Goal (forall x, x=0) -> 1=0. diff --git a/theories/Arith/Wf_nat.v b/theories/Arith/Wf_nat.v index 9822b270ba..1c183930f9 100644 --- a/theories/Arith/Wf_nat.v +++ b/theories/Arith/Wf_nat.v @@ -62,7 +62,7 @@ the ML-like program for [induction_ltof2] is : *) Theorem induction_ltof1 : - forall P:A -> Set, + forall P:A -> Type, (forall x:A, (forall y:A, ltof y x -> P y) -> P x) -> forall a:A, P a. Proof. intros P F. @@ -75,21 +75,21 @@ Proof. Defined. Theorem induction_gtof1 : - forall P:A -> Set, + forall P:A -> Type, (forall x:A, (forall y:A, gtof y x -> P y) -> P x) -> forall a:A, P a. Proof. exact induction_ltof1. Defined. Theorem induction_ltof2 : - forall P:A -> Set, + forall P:A -> Type, (forall x:A, (forall y:A, ltof y x -> P y) -> P x) -> forall a:A, P a. Proof. - exact (well_founded_induction well_founded_ltof). + exact (well_founded_induction_type well_founded_ltof). Defined. Theorem induction_gtof2 : - forall P:A -> Set, + forall P:A -> Type, (forall x:A, (forall y:A, gtof y x -> P y) -> P x) -> forall a:A, P a. Proof. exact induction_ltof2. @@ -119,6 +119,18 @@ Proof. exact (well_founded_ltof nat (fun m => m)). Defined. +Lemma lt_wf_rect1 : + forall n (P:nat -> Type), (forall n, (forall m, m < n -> P m) -> P n) -> P n. +Proof. + exact (fun p P F => induction_ltof1 nat (fun m => m) P F p). +Defined. + +Lemma lt_wf_rect : + forall n (P:nat -> Type), (forall n, (forall m, m < n -> P m) -> P n) -> P n. +Proof. + exact (fun p P F => induction_ltof2 nat (fun m => m) P F p). +Defined. + Lemma lt_wf_rec1 : forall n (P:nat -> Set), (forall n, (forall m, m < n -> P m) -> P n) -> P n. Proof. @@ -137,6 +149,12 @@ Proof. intro p; intros; elim (lt_wf p); auto with arith. Qed. +Lemma gt_wf_rect : + forall n (P:nat -> Type), (forall n, (forall m, n > m -> P m) -> P n) -> P n. +Proof. + exact lt_wf_rect. +Defined. + Lemma gt_wf_rec : forall n (P:nat -> Set), (forall n, (forall m, n > m -> P m) -> P n) -> P n. Proof. @@ -147,6 +165,16 @@ Lemma gt_wf_ind : forall n (P:nat -> Prop), (forall n, (forall m, n > m -> P m) -> P n) -> P n. Proof lt_wf_ind. +Lemma lt_wf_double_rect : + forall P:nat -> nat -> Type, + (forall n m, + (forall p q, p < n -> P p q) -> + (forall p, p < m -> P n p) -> P n m) -> forall n m, P n m. +Proof. + intros P Hrec p; pattern p; apply lt_wf_rect. + intros n H q; pattern q; apply lt_wf_rect; auto with arith. +Defined. + Lemma lt_wf_double_rec : forall P:nat -> nat -> Set, (forall n m, diff --git a/theories/Lists/List.v b/theories/Lists/List.v index 38723e291f..74335da2f1 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -120,62 +120,6 @@ Section Facts. Qed. - (************************) - (** *** Facts about [In] *) - (************************) - - - (** Characterization of [In] *) - - Theorem in_eq : forall (a:A) (l:list A), In a (a :: l). - Proof. - simpl; auto. - Qed. - - Theorem in_cons : forall (a b:A) (l:list A), In b l -> In b (a :: l). - Proof. - simpl; auto. - Qed. - - Theorem not_in_cons (x a : A) (l : list A): - ~ In x (a::l) <-> x<>a /\ ~ In x l. - Proof. - simpl. intuition. - Qed. - - Theorem in_nil : forall a:A, ~ In a []. - Proof. - unfold not; intros a H; inversion_clear H. - Qed. - - Theorem in_split : forall x (l:list A), In x l -> exists l1 l2, l = l1++x::l2. - Proof. - induction l; simpl; destruct 1. - subst a; auto. - exists [], l; auto. - destruct (IHl H) as (l1,(l2,H0)). - exists (a::l1), l2; simpl. apply f_equal. auto. - Qed. - - (** Inversion *) - Lemma in_inv : forall (a b:A) (l:list A), In b (a :: l) -> a = b \/ In b l. - Proof. - intros a b l H; inversion_clear H; auto. - Qed. - - (** Decidability of [In] *) - Theorem in_dec : - (forall x y:A, {x = y} + {x <> y}) -> - forall (a:A) (l:list A), {In a l} + {~ In a l}. - Proof. - intro H; induction l as [| a0 l IHl]. - right; apply in_nil. - destruct (H a0 a); simpl; auto. - destruct IHl; simpl; auto. - right; unfold not; intros [Hc1| Hc2]; auto. - Defined. - - (**************************) (** *** Facts about [app] *) (**************************) @@ -255,6 +199,14 @@ Section Facts. apply app_cons_not_nil in H1 as []. Qed. + Lemma elt_eq_unit : forall l1 l2 (a b : A), + l1 ++ a :: l2 = [b] -> a = b /\ l1 = [] /\ l2 = []. + Proof. + intros l1 l2 a b Heq. + apply app_eq_unit in Heq. + now destruct Heq as [[Heq1 Heq2]|[Heq1 Heq2]]; inversion_clear Heq2. + Qed. + Lemma app_inj_tail : forall (x y:list A) (a b:A), x ++ [a] = y ++ [b] -> x = y /\ a = b. Proof. @@ -281,6 +233,61 @@ Section Facts. induction l; simpl; auto. Qed. + Lemma last_length : forall (l : list A) a, length (l ++ a :: nil) = S (length l). + Proof. + intros ; rewrite app_length ; simpl. + rewrite <- plus_n_Sm, plus_n_O; reflexivity. + Qed. + + Lemma app_inv_head: + forall l l1 l2 : list A, l ++ l1 = l ++ l2 -> l1 = l2. + Proof. + induction l; simpl; auto; injection 1; auto. + Qed. + + Lemma app_inv_tail: + forall l l1 l2 : list A, l1 ++ l = l2 ++ l -> l1 = l2. + Proof. + intros l l1 l2; revert l1 l2 l. + induction l1 as [ | x1 l1]; destruct l2 as [ | x2 l2]; + simpl; auto; intros l H. + absurd (length (x2 :: l2 ++ l) <= length l). + simpl; rewrite app_length; auto with arith. + rewrite <- H; auto with arith. + absurd (length (x1 :: l1 ++ l) <= length l). + simpl; rewrite app_length; auto with arith. + rewrite H; auto with arith. + injection H as [= H H0]; f_equal; eauto. + Qed. + + (************************) + (** *** Facts about [In] *) + (************************) + + + (** Characterization of [In] *) + + Theorem in_eq : forall (a:A) (l:list A), In a (a :: l). + Proof. + simpl; auto. + Qed. + + Theorem in_cons : forall (a b:A) (l:list A), In b l -> In b (a :: l). + Proof. + simpl; auto. + Qed. + + Theorem not_in_cons (x a : A) (l : list A): + ~ In x (a::l) <-> x<>a /\ ~ In x l. + Proof. + simpl. intuition. + Qed. + + Theorem in_nil : forall a:A, ~ In a []. + Proof. + unfold not; intros a H; inversion_clear H. + Qed. + Lemma in_app_or : forall (l m:list A) (a:A), In a (l ++ m) -> In a l \/ In a m. Proof. intros l m a. @@ -314,27 +321,48 @@ Section Facts. split; auto using in_app_or, in_or_app. Qed. - Lemma app_inv_head: - forall l l1 l2 : list A, l ++ l1 = l ++ l2 -> l1 = l2. + Theorem in_split : forall x (l:list A), In x l -> exists l1 l2, l = l1++x::l2. Proof. - induction l; simpl; auto; injection 1; auto. + induction l; simpl; destruct 1. + subst a; auto. + exists [], l; auto. + destruct (IHl H) as (l1,(l2,H0)). + exists (a::l1), l2; simpl. apply f_equal. auto. Qed. - Lemma app_inv_tail: - forall l l1 l2 : list A, l1 ++ l = l2 ++ l -> l1 = l2. + Lemma in_elt : forall (x:A) l1 l2, In x (l1 ++ x :: l2). Proof. - intros l l1 l2; revert l1 l2 l. - induction l1 as [ | x1 l1]; destruct l2 as [ | x2 l2]; - simpl; auto; intros l H. - absurd (length (x2 :: l2 ++ l) <= length l). - simpl; rewrite app_length; auto with arith. - rewrite <- H; auto with arith. - absurd (length (x1 :: l1 ++ l) <= length l). - simpl; rewrite app_length; auto with arith. - rewrite H; auto with arith. - injection H as [= H H0]; f_equal; eauto. + intros. + apply in_or_app. + right; left; reflexivity. + Qed. + + Lemma in_elt_inv : forall (x y : A) l1 l2, + In x (l1 ++ y :: l2) -> x = y \/ In x (l1 ++ l2). + Proof. + intros x y l1 l2 Hin. + apply in_app_or in Hin. + destruct Hin as [Hin|[Hin|Hin]]; [right|left|right]; try apply in_or_app; intuition. Qed. + (** Inversion *) + Lemma in_inv : forall (a b:A) (l:list A), In b (a :: l) -> a = b \/ In b l. + Proof. easy. Qed. + + (** Decidability of [In] *) + Theorem in_dec : + (forall x y:A, {x = y} + {x <> y}) -> + forall (a:A) (l:list A), {In a l} + {~ In a l}. + Proof. + intro H; induction l as [| a0 l IHl]. + right; apply in_nil. + destruct (H a0 a); simpl; auto. + destruct IHl; simpl; auto. + right; unfold not; intros [Hc1| Hc2]; auto. + Defined. + + + End Facts. Hint Resolve app_assoc app_assoc_reverse: datatypes. @@ -463,6 +491,22 @@ Section Elts. - intros; simpl; rewrite IHl; auto with arith. Qed. + Lemma app_nth2_plus : forall l l' d n, + nth (length l + n) (l ++ l') d = nth n l' d. + Proof. + intros. + rewrite app_nth2, minus_plus; trivial. + auto with arith. + Qed. + + Lemma nth_middle : forall l l' a d, + nth (length l) (l ++ a :: l') d = a. + Proof. + intros. + rewrite plus_n_O at 1. + apply app_nth2_plus. + Qed. + Lemma nth_split n l d : n < length l -> exists l1, exists l2, l = l1 ++ nth n l d :: l2 /\ length l1 = n. Proof. @@ -473,6 +517,20 @@ Section Elts. exists (a::l1); exists l2; simpl; split; now f_equal. Qed. + Lemma nth_ext : forall l l' d, length l = length l' -> + (forall n, nth n l d = nth n l' d) -> l = l'. + Proof. + induction l; intros l' d Hlen Hnth; destruct l' as [| b l']. + - reflexivity. + - inversion Hlen. + - inversion Hlen. + - change a with (nth 0 (a :: l) d). + change b with (nth 0 (b :: l') d). + rewrite Hnth; f_equal. + apply IHl with d; [ now inversion Hlen | ]. + intros n; apply (Hnth (S n)). + Qed. + (** Results about [nth_error] *) Lemma nth_error_In l n x : nth_error l n = Some x -> In x l. @@ -556,31 +614,9 @@ Section Elts. rewrite app_nth2; [| auto]. repeat (rewrite Nat.sub_diag). reflexivity. Qed. - (*****************) - (** ** Remove *) - (*****************) - - Hypothesis eq_dec : forall x y : A, {x = y}+{x <> y}. - - Fixpoint remove (x : A) (l : list A) : list A := - match l with - | [] => [] - | y::tl => if (eq_dec x y) then remove x tl else y::(remove x tl) - end. - - Theorem remove_In : forall (l : list A) (x : A), ~ In x (remove x l). - Proof. - induction l as [|x l]; auto. - intro y; simpl; destruct (eq_dec y x) as [yeqx | yneqx]. - apply IHl. - unfold not; intro HF; simpl in HF; destruct HF; auto. - apply (IHl y); assumption. - Qed. - - -(******************************) -(** ** Last element of a list *) -(******************************) + (******************************) + (** ** Last element of a list *) + (******************************) (** [last l d] returns the last element of the list [l], or the default value [d] if [l] is empty. *) @@ -592,6 +628,13 @@ Section Elts. | a :: l => last l d end. + Lemma last_last : forall l a d, last (l ++ [a]) d = a. + Proof. + induction l; intros; [ reflexivity | ]. + simpl; rewrite IHl. + destruct l; reflexivity. + Qed. + (** [removelast l] remove the last element of [l] *) Fixpoint removelast (l:list A) : list A := @@ -638,6 +681,119 @@ Section Elts. destruct (l++l'); [elim H0; auto|f_equal; auto]. Qed. + Lemma removelast_last : forall l a, removelast (l ++ [a]) = l. + Proof. + intros. + rewrite removelast_app. + - apply app_nil_r. + - intros Heq; inversion Heq. + Qed. + + + (*****************) + (** ** Remove *) + (*****************) + + Hypothesis eq_dec : forall x y : A, {x = y}+{x <> y}. + + Fixpoint remove (x : A) (l : list A) : list A := + match l with + | [] => [] + | y::tl => if (eq_dec x y) then remove x tl else y::(remove x tl) + end. + + Lemma remove_cons : forall x l, remove x (x :: l) = remove x l. + Proof. + intros x l; simpl; destruct (eq_dec x x); [ reflexivity | now exfalso ]. + Qed. + + Lemma remove_app : forall x l1 l2, + remove x (l1 ++ l2) = remove x l1 ++ remove x l2. + Proof. + induction l1; intros l2; simpl. + - reflexivity. + - destruct (eq_dec x a). + + apply IHl1. + + rewrite <- app_comm_cons; f_equal. + apply IHl1. + Qed. + + Theorem remove_In : forall (l : list A) (x : A), ~ In x (remove x l). + Proof. + induction l as [|x l]; auto. + intro y; simpl; destruct (eq_dec y x) as [yeqx | yneqx]. + apply IHl. + unfold not; intro HF; simpl in HF; destruct HF; auto. + apply (IHl y); assumption. + Qed. + + Lemma notin_remove: forall l x, ~ In x l -> remove x l = l. + Proof. + intros l x; induction l as [|y l]; simpl; intros Hnin. + - reflexivity. + - destruct (eq_dec x y); subst; intuition. + f_equal; assumption. + Qed. + + Lemma in_remove: forall l x y, In x (remove y l) -> In x l /\ x <> y. + Proof. + induction l as [|z l]; intros x y Hin. + - inversion Hin. + - simpl in Hin. + destruct (eq_dec y z) as [Heq|Hneq]; subst; split. + + right; now apply IHl with z. + + intros Heq; revert Hin; subst; apply remove_In. + + inversion Hin; subst; [left; reflexivity|right]. + now apply IHl with y. + + destruct Hin as [Hin|Hin]; subst. + * now intros Heq; apply Hneq. + * intros Heq; revert Hin; subst; apply remove_In. + Qed. + + Lemma in_in_remove : forall l x y, x <> y -> In x l -> In x (remove y l). + Proof. + induction l as [|z l]; simpl; intros x y Hneq Hin. + - apply Hin. + - destruct (eq_dec y z); subst. + + destruct Hin. + * exfalso; now apply Hneq. + * now apply IHl. + + simpl; destruct Hin; [now left|right]. + now apply IHl. + Qed. + + Lemma remove_remove_comm : forall l x y, + remove x (remove y l) = remove y (remove x l). + Proof. + induction l as [| z l]; simpl; intros x y. + - reflexivity. + - destruct (eq_dec y z); simpl; destruct (eq_dec x z); try rewrite IHl; auto. + + subst; symmetry; apply remove_cons. + + simpl; destruct (eq_dec y z); tauto. + Qed. + + Lemma remove_remove_eq : forall l x, remove x (remove x l) = remove x l. + Proof. intros l x; now rewrite (notin_remove _ _ (remove_In l x)). Qed. + + Lemma remove_length_le : forall l x, length (remove x l) <= length l. + Proof. + induction l as [|y l IHl]; simpl; intros x; trivial. + destruct (eq_dec x y); simpl. + - rewrite IHl; constructor; reflexivity. + - apply (proj1 (Nat.succ_le_mono _ _) (IHl x)). + Qed. + + Lemma remove_length_lt : forall l x, In x l -> length (remove x l) < length l. + Proof. + induction l as [|y l IHl]; simpl; intros x Hin. + - contradiction Hin. + - destruct Hin as [-> | Hin]. + + destruct (eq_dec x x); intuition. + apply Nat.lt_succ_r, remove_length_le. + + specialize (IHl _ Hin); destruct (eq_dec x y); simpl; auto. + now apply Nat.succ_lt_mono in IHl. + Qed. + (******************************************) (** ** Counting occurrences of an element *) @@ -743,6 +899,12 @@ Section ListOps. rewrite IHl; auto. Qed. + Lemma rev_eq_app : forall l l1 l2, rev l = l1 ++ l2 -> l = rev l2 ++ rev l1. + Proof. + intros l l1 l2 Heq. + rewrite <- (rev_involutive l), Heq. + apply rev_app_distr. + Qed. (** Compatibility with other operations *) @@ -820,30 +982,27 @@ Section ListOps. Section Reverse_Induction. - Lemma rev_list_ind : - forall P:list A-> Prop, - P [] -> - (forall (a:A) (l:list A), P (rev l) -> P (rev (a :: l))) -> - forall l:list A, P (rev l). + Lemma rev_list_ind : forall P:list A-> Prop, + P [] -> + (forall (a:A) (l:list A), P (rev l) -> P (rev (a :: l))) -> + forall l:list A, P (rev l). Proof. induction l; auto. Qed. - Theorem rev_ind : - forall P:list A -> Prop, - P [] -> - (forall (x:A) (l:list A), P l -> P (l ++ [x])) -> forall l:list A, P l. + Theorem rev_ind : forall P:list A -> Prop, + P [] -> + (forall (x:A) (l:list A), P l -> P (l ++ [x])) -> forall l:list A, P l. Proof. intros. generalize (rev_involutive l). intros E; rewrite <- E. apply (rev_list_ind P). - auto. - - simpl. - intros. - apply (H0 a (rev l0)). - auto. + - auto. + - simpl. + intros. + apply (H0 a (rev l0)). + auto. Qed. End Reverse_Induction. @@ -871,10 +1030,28 @@ Section ListOps. Lemma concat_app : forall l1 l2, concat (l1 ++ l2) = concat l1 ++ concat l2. Proof. intros l1; induction l1 as [|x l1 IH]; intros l2; simpl. - + reflexivity. - + rewrite IH; apply app_assoc. + - reflexivity. + - rewrite IH; apply app_assoc. Qed. + Lemma in_concat : forall l y, + In y (concat l) <-> exists x, In x l /\ In y x. + Proof. + induction l; simpl; split; intros. + contradiction. + destruct H as (x,(H,_)); contradiction. + destruct (in_app_or _ _ _ H). + exists a; auto. + destruct (IHl y) as (H1,_); destruct (H1 H0) as (x,(H2,H3)). + exists x; auto. + apply in_or_app. + destruct H as (x,(H0,H1)); destruct H0. + subst; auto. + right; destruct (IHl y) as (_,H2); apply H2. + exists x; auto. + Qed. + + (***********************************) (** ** Decidable equality on lists *) (***********************************) @@ -944,6 +1121,13 @@ Section Map. intros; rewrite IHl; auto. Qed. + Lemma map_last : forall l a, + map (l ++ [a]) = (map l) ++ [f a]. + Proof. + induction l; intros; [ reflexivity | ]. + simpl; rewrite IHl; reflexivity. + Qed. + Lemma map_rev : forall l, map (rev l) = rev (map l). Proof. induction l; simpl; auto. @@ -956,6 +1140,26 @@ Section Map. destruct l; simpl; reflexivity || discriminate. Qed. + Lemma map_eq_cons : forall l l' b, + map l = b :: l' -> exists a tl, l = a :: tl /\ b = f a /\ l' = map tl. + Proof. + intros l l' b Heq. + destruct l; inversion_clear Heq. + exists a, l; repeat split. + Qed. + + Lemma map_eq_app : forall l l1 l2, + map l = l1 ++ l2 -> exists l1' l2', l = l1' ++ l2' /\ l1 = map l1' /\ l2 = map l2'. + Proof. + induction l; simpl; intros l1 l2 Heq. + - symmetry in Heq; apply app_eq_nil in Heq; destruct Heq; subst. + exists nil, nil; repeat split. + - destruct l1; simpl in Heq; inversion Heq as [[Heq2 Htl]]. + + exists nil, (a :: l); repeat split. + + destruct (IHl _ _ Htl) as (l1' & l2' & ? & ? & ?); subst. + exists (a :: l1'), l2'; repeat split. + Qed. + (** [map] and count of occurrences *) Hypothesis decA: forall x1 x2 : A, {x1 = x2} + {x1 <> x2}. @@ -969,10 +1173,10 @@ Section Map. - reflexivity. - specialize (Hrec x). destruct (decA a x) as [H1|H1], (decB (f a) (f x)) as [H2|H2]. - * rewrite Hrec. reflexivity. - * contradiction H2. rewrite H1. reflexivity. - * specialize (Hfinjective H2). contradiction H1. - * assumption. + + rewrite Hrec. reflexivity. + + contradiction H2. rewrite H1. reflexivity. + + specialize (Hfinjective H2). contradiction H1. + + assumption. Qed. (** [flat_map] *) @@ -984,10 +1188,18 @@ Section Map. | cons x t => (f x)++(flat_map t) end. + Lemma flat_map_app : forall f l1 l2, + flat_map f (l1 ++ l2) = flat_map f l1 ++ flat_map f l2. + Proof. + intros F l1 l2. + induction l1; [ reflexivity | simpl ]. + rewrite IHl1, app_assoc; reflexivity. + Qed. + Lemma in_flat_map : forall (f:A->list B)(l:list A)(y:B), In y (flat_map f l) <-> exists x, In x l /\ In y (f x). - Proof using A B. - clear Hfinjective. + Proof. + clear f Hfinjective. induction l; simpl; split; intros. contradiction. destruct H as (x,(H,_)); contradiction. @@ -1008,15 +1220,22 @@ Lemma flat_map_concat_map : forall A B (f : A -> list B) l, flat_map f l = concat (map f l). Proof. intros A B f l; induction l as [|x l IH]; simpl. -+ reflexivity. -+ rewrite IH; reflexivity. +- reflexivity. +- rewrite IH; reflexivity. Qed. Lemma concat_map : forall A B (f : A -> B) l, map f (concat l) = concat (map (map f) l). Proof. intros A B f l; induction l as [|x l IH]; simpl. -+ reflexivity. -+ rewrite map_app, IH; reflexivity. +- reflexivity. +- rewrite map_app, IH; reflexivity. +Qed. + +Lemma remove_concat A (eq_dec : forall x y : A, {x = y}+{x <> y}) : forall l x, + remove eq_dec x (concat l) = flat_map (remove eq_dec x) l. +Proof. + intros l x; induction l; [ reflexivity | simpl ]. + rewrite remove_app, IHl; reflexivity. Qed. Lemma map_id : forall (A :Type) (l : list A), @@ -1057,6 +1276,25 @@ Proof. intros; apply map_ext_in; auto. Qed. +Lemma flat_map_ext : forall (A B : Type)(f g : A -> list B), + (forall a, f a = g a) -> forall l, flat_map f l = flat_map g l. +Proof. + intros A B f g Hext l. + rewrite 2 flat_map_concat_map. + now rewrite map_ext with (g := g). +Qed. + +Lemma nth_nth_nth_map A : forall (l : list A) n d ln dn, n < length ln \/ length l <= dn -> + nth (nth n ln dn) l d = nth n (map (fun x => nth x l d) ln) d. +Proof. + intros l n d ln dn; revert n; induction ln; intros n Hlen. + - destruct Hlen as [Hlen|Hlen]. + + inversion Hlen. + + now rewrite nth_overflow; destruct n. + - destruct n; simpl; [ reflexivity | apply IHln ]. + destruct Hlen; [ left; apply lt_S_n | right ]; assumption. +Qed. + (************************************) (** Left-to-right iterator on lists *) @@ -1168,8 +1406,8 @@ End Fold_Right_Recursor. Fixpoint existsb (l:list A) : bool := match l with - | nil => false - | a::l => f a || existsb l + | nil => false + | a::l => f a || existsb l end. Lemma existsb_exists : @@ -1208,8 +1446,8 @@ End Fold_Right_Recursor. Fixpoint forallb (l:list A) : bool := match l with - | nil => true - | a::l => f a && forallb l + | nil => true + | a::l => f a && forallb l end. Lemma forallb_forall : @@ -1231,12 +1469,13 @@ End Fold_Right_Recursor. solve[auto]. case (f a); simpl; solve[auto]. Qed. + (** [filter] *) Fixpoint filter (l:list A) : list A := match l with - | nil => nil - | x :: l => if f x then x::(filter l) else filter l + | nil => nil + | x :: l => if f x then x::(filter l) else filter l end. Lemma filter_In : forall x l, In x (filter l) <-> In x l /\ f x = true. @@ -1265,8 +1504,8 @@ End Fold_Right_Recursor. Fixpoint find (l:list A) : option A := match l with - | nil => None - | x :: tl => if f x then Some x else find tl + | nil => None + | x :: tl => if f x then Some x else find tl end. Lemma find_some l x : find l = Some x -> In x l /\ f x = true. @@ -1288,9 +1527,9 @@ End Fold_Right_Recursor. Fixpoint partition (l:list A) : list A * list A := match l with - | nil => (nil, nil) - | x :: tl => let (g,d) := partition tl in - if f x then (x::g,d) else (g,x::d) + | nil => (nil, nil) + | x :: tl => let (g,d) := partition tl in + if f x then (x::g,d) else (g,x::d) end. Theorem partition_cons1 a l l1 l2: @@ -1405,8 +1644,8 @@ End Fold_Right_Recursor. Fixpoint split (l:list (A*B)) : list A * list B := match l with - | [] => ([], []) - | (x,y) :: tl => let (left,right) := split tl in (x::left, y::right) + | [] => ([], []) + | (x,y) :: tl => let (left,right) := split tl in (x::left, y::right) end. Lemma in_split_l : forall (l:list (A*B))(p:A*B), @@ -1460,8 +1699,8 @@ End Fold_Right_Recursor. Fixpoint combine (l : list A) (l' : list B) : list (A*B) := match l,l' with - | x::tl, y::tl' => (x,y)::(combine tl tl') - | _, _ => nil + | x::tl, y::tl' => (x,y)::(combine tl tl') + | _, _ => nil end. Lemma split_combine : forall (l: list (A*B)), @@ -1528,8 +1767,8 @@ End Fold_Right_Recursor. Fixpoint list_prod (l:list A) (l':list B) : list (A * B) := match l with - | nil => nil - | cons x t => (map (fun y:B => (x, y)) l')++(list_prod t l') + | nil => nil + | cons x t => (map (fun y:B => (x, y)) l')++(list_prod t l') end. Lemma in_prod_aux : @@ -1544,17 +1783,17 @@ End Fold_Right_Recursor. Lemma in_prod : forall (l:list A) (l':list B) (x:A) (y:B), - In x l -> In y l' -> In (x, y) (list_prod l l'). + In x l -> In y l' -> In (x, y) (list_prod l l'). Proof. induction l; - [ simpl; tauto - | simpl; intros; apply in_or_app; destruct H; - [ left; rewrite H; apply in_prod_aux; assumption | right; auto ] ]. + [ simpl; tauto + | simpl; intros; apply in_or_app; destruct H; + [ left; rewrite H; apply in_prod_aux; assumption | right; auto ] ]. Qed. Lemma in_prod_iff : forall (l:list A)(l':list B)(x:A)(y:B), - In (x,y) (list_prod l l') <-> In x l /\ In y l'. + In (x,y) (list_prod l l') <-> In x l /\ In y l'. Proof. split; [ | intros; apply in_prod; intuition ]. induction l; simpl; intros. @@ -1650,6 +1889,18 @@ Section SetIncl. Definition incl (l m:list A) := forall a:A, In a l -> In a m. Hint Unfold incl : core. + Lemma incl_nil_l : forall l, incl nil l. + Proof. + intros l a Hin; inversion Hin. + Qed. + + Lemma incl_l_nil : forall l, incl l nil -> l = nil. + Proof. + destruct l; intros Hincl. + - reflexivity. + - exfalso; apply Hincl with a; simpl; auto. + Qed. + Lemma incl_refl : forall l:list A, incl l l. Proof. auto. @@ -1694,6 +1945,13 @@ Section SetIncl. Qed. Hint Resolve incl_cons : core. + Lemma incl_cons_inv : forall (a:A) (l m:list A), + incl (a :: l) m -> In a m /\ incl l m. + Proof. + intros a l m Hi. + split; [ | intros ? ? ]; apply Hi; simpl; auto. + Qed. + Lemma incl_app : forall l m n:list A, incl l n -> incl m n -> incl (l ++ m) n. Proof. unfold incl; simpl; intros l m n H H0 a H1. @@ -1702,6 +1960,34 @@ Section SetIncl. Qed. Hint Resolve incl_app : core. + Lemma incl_app_app : forall l1 l2 m1 m2:list A, + incl l1 m1 -> incl l2 m2 -> incl (l1 ++ l2) (m1 ++ m2). + Proof. + intros. + apply incl_app; [ apply incl_appl | apply incl_appr]; assumption. + Qed. + + Lemma incl_app_inv : forall l1 l2 m : list A, + incl (l1 ++ l2) m -> incl l1 m /\ incl l2 m. + Proof. + induction l1; intros l2 m Hin; split; auto. + - apply incl_nil_l. + - intros b Hb; inversion_clear Hb; subst; apply Hin. + + now constructor. + + simpl; apply in_cons. + apply incl_appl with l1; [ apply incl_refl | assumption ]. + - apply IHl1. + now apply incl_cons_inv in Hin. + Qed. + + Lemma remove_incl (eq_dec : forall x y : A, {x = y} + {x <> y}) : forall l1 l2 x, + incl l1 l2 -> incl (remove eq_dec x l1) (remove eq_dec x l2). + Proof. + intros l1 l2 x Hincl y Hin. + apply in_remove in Hin; destruct Hin as [Hin Hneq]. + apply in_in_remove; intuition. + Qed. + End SetIncl. Hint Resolve incl_refl incl_tl incl_tran incl_appl incl_appr incl_cons @@ -1825,9 +2111,11 @@ Section Cutting. Lemma skipn_cons n a l: skipn (S n) (a::l) = skipn n l. Proof. reflexivity. Qed. - Lemma skipn_none : forall l, skipn (length l) l = []. + Lemma skipn_all : forall l, skipn (length l) l = nil. Proof. now induction l. Qed. +#[deprecated(since="8.12",note="Use skipn_all instead.")] Notation skipn_none := skipn_all. + Lemma skipn_all2 n: forall l, length l <= n -> skipn n l = []. Proof. intros l L%Nat.sub_0_le; rewrite <-(firstn_all l) at 1. @@ -1855,9 +2143,6 @@ Section Cutting. - destruct l; simpl; auto. Qed. - Lemma skipn_all l: skipn (length l) l = nil. - Proof. now induction l. Qed. - Lemma skipn_app n : forall l1 l2, skipn n (l1 ++ l2) = (skipn n l1) ++ (skipn (n - length l1) l2). Proof. induction n; auto; intros [|]; simpl; auto. Qed. @@ -1884,7 +2169,7 @@ Section Cutting. intros x l; rewrite firstn_skipn_rev, rev_involutive, <-rev_length. destruct (Nat.le_ge_cases (length (rev l)) x) as [L | L]. - rewrite skipn_all2; [apply Nat.sub_0_le in L | trivial]. - now rewrite L, Nat.sub_0_r, skipn_none. + now rewrite L, Nat.sub_0_r, skipn_all. - replace (length (rev l) - (length (rev l) - x)) with (length (rev l) + x - length (rev l)). rewrite minus_plus. reflexivity. @@ -1911,6 +2196,13 @@ Section Cutting. inversion_clear H0. Qed. + Lemma removelast_firstn_len : forall l, + removelast l = firstn (pred (length l)) l. + Proof. + induction l; [ reflexivity | simpl ]. + destruct l; [ | rewrite IHl ]; reflexivity. + Qed. + Lemma firstn_removelast : forall n l, n < length l -> firstn n (removelast l) = firstn n l. Proof. @@ -2082,6 +2374,16 @@ Section ReDun. + now constructor. Qed. + Lemma NoDup_rev l : NoDup l -> NoDup (rev l). + Proof. + induction l; simpl; intros Hnd; [ constructor | ]. + inversion_clear Hnd as [ | ? ? Hnin Hndl ]. + assert (Add a (rev l) (rev l ++ a :: nil)) as Hadd + by (rewrite <- (app_nil_r (rev l)) at 1; apply Add_app). + apply NoDup_Add in Hadd; apply Hadd; intuition. + now apply Hnin, in_rev. + Qed. + (** Effective computation of a list without duplicates *) Hypothesis decA: forall x y : A, {x = y} + {x <> y}. @@ -2110,6 +2412,11 @@ Section ReDun. * reflexivity. Qed. + Lemma nodup_incl l1 l2 : incl l1 (nodup l2) <-> incl l1 l2. + Proof. + split; intros Hincl a Ha; apply nodup_In; intuition. + Qed. + Lemma NoDup_nodup l: NoDup (nodup l). Proof. induction l as [|a l' Hrec]; simpl. @@ -2252,6 +2559,11 @@ Section NatSeq. | S len => start :: seq (S start) len end. + Lemma cons_seq : forall len start, start :: seq (S start) len = seq start (S len). + Proof. + reflexivity. + Qed. + Lemma seq_length : forall len start, length (seq start len) = len. Proof. induction len; simpl; auto. @@ -2284,8 +2596,8 @@ Section NatSeq. - rewrite <- plus_n_O. split;[easy|]. intros (H,H'). apply (Lt.lt_irrefl _ (Lt.le_lt_trans _ _ _ H H')). - rewrite IHlen, <- plus_n_Sm; simpl; split. - * intros [H|H]; subst; intuition auto with arith. - * intros (H,H'). destruct (Lt.le_lt_or_eq _ _ H); intuition. + + intros [H|H]; subst; intuition auto with arith. + + intros (H,H'). destruct (Lt.le_lt_or_eq _ _ H); intuition. Qed. Lemma seq_NoDup len start : NoDup (seq start len). @@ -2302,6 +2614,14 @@ Section NatSeq. - now rewrite Nat.add_succ_r, IHlen. Qed. + Lemma seq_S : forall len start, seq start (S len) = seq start len ++ [start + len]. + Proof. + intros len start. + change [start + len] with (seq (start + len) 1). + rewrite <- seq_app. + rewrite <- plus_n_Sm, <- plus_n_O; reflexivity. + Qed. + End NatSeq. Section Exists_Forall. @@ -2328,6 +2648,21 @@ Section Exists_Forall. - induction l; firstorder; subst; auto. Qed. + Lemma Exists_nth l : + Exists l <-> exists i d, i < length l /\ P (nth i l d). + Proof. + split. + - intros HE; apply Exists_exists in HE. + destruct HE as [a [Hin HP]]. + apply In_nth with (d := a) in Hin; destruct Hin as [i [Hl Heq]]. + rewrite <- Heq in HP. + now exists i; exists a. + - intros [i [d [Hl HP]]]. + apply Exists_exists; exists (nth i l d); split. + apply nth_In; assumption. + assumption. + Qed. + Lemma Exists_nil : Exists nil <-> False. Proof. split; inversion 1. Qed. @@ -2335,6 +2670,21 @@ Section Exists_Forall. Exists (x::l) <-> P x \/ Exists l. Proof. split; inversion 1; auto. Qed. + Lemma Exists_app l1 l2 : + Exists (l1 ++ l2) <-> Exists l1 \/ Exists l2. + Proof. + induction l1; simpl; split; intros HE; try now intuition. + - inversion_clear HE; intuition. + - destruct HE as [HE|HE]; intuition. + inversion_clear HE; intuition. + Qed. + + Lemma Exists_rev l : Exists l -> Exists (rev l). + Proof. + induction l; intros HE; intuition. + inversion_clear HE; simpl; apply Exists_app; intuition. + Qed. + Lemma Exists_dec l: (forall x:A, {P x} + { ~ P x }) -> {Exists l} + {~ Exists l}. @@ -2342,12 +2692,25 @@ Section Exists_Forall. intro Pdec. induction l as [|a l' Hrec]. - right. abstract now rewrite Exists_nil. - destruct Hrec as [Hl'|Hl']. - * left. now apply Exists_cons_tl. - * destruct (Pdec a) as [Ha|Ha]. - + left. now apply Exists_cons_hd. - + right. abstract now inversion 1. + + left. now apply Exists_cons_tl. + + destruct (Pdec a) as [Ha|Ha]. + * left. now apply Exists_cons_hd. + * right. abstract now inversion 1. Defined. + Lemma Exists_fold_right l : + Exists l <-> fold_right (fun x => or (P x)) False l. + Proof. + induction l; simpl; split; intros HE; try now inversion HE; intuition. + Qed. + + Lemma incl_Exists l1 l2 : incl l1 l2 -> Exists l1 -> Exists l2. + Proof. + intros Hincl HE. + apply Exists_exists in HE; destruct HE as [a [Hin HP]]. + apply Exists_exists; exists a; intuition. + Qed. + Inductive Forall : list A -> Prop := | Forall_nil : Forall nil | Forall_cons : forall x l, P x -> Forall l -> Forall (x::l). @@ -2362,11 +2725,49 @@ Section Exists_Forall. - induction l; firstorder. Qed. + Lemma Forall_nth l : + Forall l <-> forall i d, i < length l -> P (nth i l d). + Proof. + split. + - intros HF i d Hl. + apply Forall_forall with (x := nth i l d) in HF. + assumption. + apply nth_In; assumption. + - intros HF. + apply Forall_forall; intros a Hin. + apply In_nth with (d := a) in Hin; destruct Hin as [i [Hl Heq]]. + rewrite <- Heq; intuition. + Qed. + Lemma Forall_inv : forall (a:A) l, Forall (a :: l) -> P a. Proof. intros; inversion H; trivial. Qed. + Theorem Forall_inv_tail : forall (a:A) l, Forall (a :: l) -> Forall l. + Proof. + intros; inversion H; trivial. + Qed. + + Lemma Forall_app l1 l2 : + Forall (l1 ++ l2) <-> Forall l1 /\ Forall l2. + Proof. + induction l1; simpl; split; intros HF; try now intuition. + - inversion_clear HF; intuition. + - destruct HF as [HF1 HF2]; inversion HF1; intuition. + Qed. + + Lemma Forall_elt a l1 l2 : Forall (l1 ++ a :: l2) -> P a. + Proof. + intros HF; apply Forall_app in HF; destruct HF as [HF1 HF2]; now inversion HF2. + Qed. + + Lemma Forall_rev l : Forall l -> Forall (rev l). + Proof. + induction l; intros HF; intuition. + inversion_clear HF; simpl; apply Forall_app; intuition. + Qed. + Lemma Forall_rect : forall (Q : list A -> Type), Q [] -> (forall b l, P b -> Q (b :: l)) -> forall l, Forall l -> Q l. Proof. @@ -2386,53 +2787,89 @@ Section Exists_Forall. + right. abstract now inversion 1. Defined. + Lemma Forall_fold_right l : + Forall l <-> fold_right (fun x => and (P x)) True l. + Proof. + induction l; simpl; split; intros HF; try now inversion HF; intuition. + Qed. + + Lemma incl_Forall l1 l2 : incl l2 l1 -> Forall l1 -> Forall l2. + Proof. + intros Hincl HF. + apply Forall_forall; intros a Ha. + apply Forall_forall with (x:=a) in HF; intuition. + Qed. + End One_predicate. - Theorem Forall_inv_tail - : forall (P : A -> Prop) (x0 : A) (xs : list A), Forall P (x0 :: xs) -> Forall P xs. + Lemma map_ext_Forall B : forall (f g : A -> B) l, + Forall (fun x => f x = g x) l -> map f l = map g l. Proof. - intros P x0 xs H. - apply Forall_forall with (l := xs). - assert (H0 : forall x : A, In x (x0 :: xs) -> P x). - apply Forall_forall with (P := P) (l := x0 :: xs). - exact H. - assert (H1 : forall (x : A) (H2 : In x xs), P x). - intros x H2. - apply (H0 x). - right. - exact H2. - intros x H2. - apply (H1 x H2). + intros; apply map_ext_in, Forall_forall; assumption. Qed. - Theorem Exists_impl - : forall (P Q : A -> Prop), (forall x : A, P x -> Q x) -> forall xs : list A, Exists P xs -> Exists Q xs. + Theorem Exists_impl : forall (P Q : A -> Prop), (forall a : A, P a -> Q a) -> + forall l, Exists P l -> Exists Q l. Proof. - intros P Q H xs H0. + intros P Q H l H0. induction H0. apply (Exists_cons_hd Q x l (H x H0)). apply (Exists_cons_tl x IHExists). Qed. + Lemma Exists_or : forall (P Q : A -> Prop) l, + Exists P l \/ Exists Q l -> Exists (fun x => P x \/ Q x) l. + Proof. + induction l; intros [H | H]; inversion H; subst. + 1,3: apply Exists_cons_hd; auto. + all: apply Exists_cons_tl, IHl; auto. + Qed. + + Lemma Exists_or_inv : forall (P Q : A -> Prop) l, + Exists (fun x => P x \/ Q x) l -> Exists P l \/ Exists Q l. + Proof. + induction l; intro Hl; inversion Hl as [ ? ? H | ? ? H ]; subst. + - inversion H; now repeat constructor. + - destruct (IHl H); now repeat constructor. + Qed. + + Lemma Forall_impl : forall (P Q : A -> Prop), (forall a, P a -> Q a) -> + forall l, Forall P l -> Forall Q l. + Proof. + intros P Q H l. rewrite !Forall_forall. firstorder. + Qed. + + Lemma Forall_and : forall (P Q : A -> Prop) l, + Forall P l -> Forall Q l -> Forall (fun x => P x /\ Q x) l. + Proof. + induction l; intros HP HQ; constructor; inversion HP; inversion HQ; auto. + Qed. + + Lemma Forall_and_inv : forall (P Q : A -> Prop) l, + Forall (fun x => P x /\ Q x) l -> Forall P l /\ Forall Q l. + Proof. + induction l; intro Hl; split; constructor; inversion Hl; firstorder. + Qed. + Lemma Forall_Exists_neg (P:A->Prop)(l:list A) : - Forall (fun x => ~ P x) l <-> ~(Exists P l). + Forall (fun x => ~ P x) l <-> ~(Exists P l). Proof. - rewrite Forall_forall, Exists_exists. firstorder. + rewrite Forall_forall, Exists_exists. firstorder. Qed. Lemma Exists_Forall_neg (P:A->Prop)(l:list A) : (forall x, P x \/ ~P x) -> Exists (fun x => ~ P x) l <-> ~(Forall P l). Proof. - intro Dec. - split. - - rewrite Forall_forall, Exists_exists; firstorder. - - intros NF. - induction l as [|a l IH]. - + destruct NF. constructor. - + destruct (Dec a) as [Ha|Ha]. - * apply Exists_cons_tl, IH. contradict NF. now constructor. - * now apply Exists_cons_hd. + intro Dec. + split. + - rewrite Forall_forall, Exists_exists; firstorder. + - intros NF. + induction l as [|a l IH]. + + destruct NF. constructor. + + destruct (Dec a) as [Ha|Ha]. + * apply Exists_cons_tl, IH. contradict NF. now constructor. + * now apply Exists_cons_hd. Qed. Lemma neg_Forall_Exists_neg (P:A->Prop) (l:list A) : @@ -2455,17 +2892,61 @@ Section Exists_Forall. now apply neg_Forall_Exists_neg. Defined. - Lemma Forall_impl : forall (P Q : A -> Prop), (forall a, P a -> Q a) -> - forall l, Forall P l -> Forall Q l. - Proof. - intros P Q H l. rewrite !Forall_forall. firstorder. - Qed. - End Exists_Forall. Hint Constructors Exists : core. Hint Constructors Forall : core. +Lemma exists_Forall A B : forall (P : A -> B -> Prop) l, + (exists k, Forall (P k) l) -> Forall (fun x => exists k, P k x) l. +Proof. + induction l; intros [k HF]; constructor; inversion_clear HF. + - now exists k. + - now apply IHl; exists k. +Qed. + +Lemma Forall_image A B : forall (f : A -> B) l, + Forall (fun y => exists x, y = f x) l <-> exists l', l = map f l'. +Proof. + induction l; split; intros HF. + - exists nil; reflexivity. + - constructor. + - inversion_clear HF as [| ? ? [x Hx] HFtl]; subst. + destruct (proj1 IHl HFtl) as [l' Heq]; subst. + now exists (x :: l'). + - destruct HF as [l' Heq]. + symmetry in Heq; apply map_eq_cons in Heq. + destruct Heq as (x & tl & ? & ? & ?); subst. + constructor. + + now exists x. + + now apply IHl; exists tl. +Qed. + +Lemma concat_nil_Forall A : forall (l : list (list A)), + concat l = nil <-> Forall (fun x => x = nil) l. +Proof. + induction l; simpl; split; intros Hc; auto. + - apply app_eq_nil in Hc. + constructor; firstorder. + - inversion Hc; subst; simpl. + now apply IHl. +Qed. + +Lemma in_flat_map_Exists A B : forall (f : A -> list B) x l, + In x (flat_map f l) <-> Exists (fun y => In x (f y)) l. +Proof. + intros f x l; rewrite in_flat_map. + split; apply Exists_exists. +Qed. + +Lemma notin_flat_map_Forall A B : forall (f : A -> list B) x l, + ~ In x (flat_map f l) <-> Forall (fun y => ~ In x (f y)) l. +Proof. + intros f x l; rewrite Forall_Exists_neg. + apply not_iff_compat, in_flat_map_Exists. +Qed. + + Section Forall2. (** [Forall2]: stating that elements of two lists are pairwise related. *) @@ -2567,6 +3048,96 @@ Section ForallPairs. Qed. End ForallPairs. +Section Repeat. + + Variable A : Type. + Fixpoint repeat (x : A) (n: nat ) := + match n with + | O => [] + | S k => x::(repeat x k) + end. + + Theorem repeat_length x n: + length (repeat x n) = n. + Proof. + induction n as [| k Hrec]; simpl; rewrite ?Hrec; reflexivity. + Qed. + + Theorem repeat_spec n x y: + In y (repeat x n) -> y=x. + Proof. + induction n as [|k Hrec]; simpl; destruct 1; auto. + Qed. + + Lemma repeat_cons n a : + a :: repeat a n = repeat a n ++ (a :: nil). + Proof. + induction n; simpl. + - reflexivity. + - f_equal; apply IHn. + Qed. + +End Repeat. + +Lemma repeat_to_concat A n (a:A) : + repeat a n = concat (repeat [a] n). +Proof. + induction n; simpl. + - reflexivity. + - f_equal; apply IHn. +Qed. + + +(** Sum of elements of a list of [nat]: [list_sum] *) + +Definition list_sum l := fold_right plus 0 l. + +Lemma list_sum_app : forall l1 l2, + list_sum (l1 ++ l2) = list_sum l1 + list_sum l2. +Proof. +induction l1; intros l2; [ reflexivity | ]. +simpl; rewrite IHl1. +apply Nat.add_assoc. +Qed. + +(** Max of elements of a list of [nat]: [list_max] *) + +Definition list_max l := fold_right max 0 l. + +Lemma list_max_app : forall l1 l2, + list_max (l1 ++ l2) = max (list_max l1) (list_max l2). +Proof. +induction l1; intros l2; [ reflexivity | ]. +now simpl; rewrite IHl1, Nat.max_assoc. +Qed. + +Lemma list_max_le : forall l n, + list_max l <= n <-> Forall (fun k => k <= n) l. +Proof. +induction l; simpl; intros n; split; intros H; intuition. +- apply Nat.max_lub_iff in H. + now constructor; [ | apply IHl ]. +- inversion_clear H as [ | ? ? Hle HF ]. + apply IHl in HF; apply Nat.max_lub; assumption. +Qed. + +Lemma list_max_lt : forall l n, l <> nil -> + list_max l < n <-> Forall (fun k => k < n) l. +Proof. +induction l; simpl; intros n Hnil; split; intros H; intuition. +- destruct l. + + repeat constructor. + now simpl in H; rewrite Nat.max_0_r in H. + + apply Nat.max_lub_lt_iff in H. + now constructor; [ | apply IHl ]. +- destruct l; inversion_clear H as [ | ? ? Hlt HF ]. + + now simpl; rewrite Nat.max_0_r. + + apply IHl in HF. + * now apply Nat.max_lub_lt_iff. + * intros Heq; inversion Heq. +Qed. + + (** * Inversion of predicates over lists based on head symbol *) Ltac is_list_constr c := @@ -2633,27 +3204,5 @@ Notation AllS := Forall (only parsing). (* was formerly in TheoryList *) Hint Resolve app_nil_end : datatypes. (* end hide *) -Section Repeat. - - Variable A : Type. - Fixpoint repeat (x : A) (n: nat ) := - match n with - | O => [] - | S k => x::(repeat x k) - end. - - Theorem repeat_length x n: - length (repeat x n) = n. - Proof. - induction n as [| k Hrec]; simpl; rewrite ?Hrec; reflexivity. - Qed. - - Theorem repeat_spec n x y: - In y (repeat x n) -> y=x. - Proof. - induction n as [|k Hrec]; simpl; destruct 1; auto. - Qed. - -End Repeat. (* Unset Universe Polymorphism. *) diff --git a/theories/Program/Tactics.v b/theories/Program/Tactics.v index ba8e4dff6d..c8a100b0e7 100644 --- a/theories/Program/Tactics.v +++ b/theories/Program/Tactics.v @@ -61,12 +61,12 @@ Ltac destruct_pairs := repeat (destruct_one_pair). Ltac destruct_one_ex := let tac H := let ph := fresh "H" in (destruct H as [H ph]) in - let tac2 H := let ph := fresh "H" in let ph' := fresh "H" in - (destruct H as [H ph ph']) + let tac2 H := let ph := fresh "H" in let ph' := fresh "H" in + (destruct H as [H ph ph']) in let tacT H := let ph := fresh "X" in (destruct H as [H ph]) in - let tacT2 H := let ph := fresh "X" in let ph' := fresh "X" in - (destruct H as [H ph ph']) + let tacT2 H := let ph := fresh "X" in let ph' := fresh "X" in + (destruct H as [H ph ph']) in match goal with | [H : (ex _) |- _] => tac H @@ -140,7 +140,7 @@ Ltac clear_dups := repeat clear_dup. (** Try to clear everything except some hyp *) -Ltac clear_except hyp := +Ltac clear_except hyp := repeat match goal with [ H : _ |- _ ] => match H with | hyp => fail 1 @@ -173,22 +173,10 @@ Ltac on_application f tac T := (** A variant of [apply] using [refine], doing as much conversion as necessary. *) Ltac rapply p := - refine (p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || - refine (p _ _ _ _ _ _ _ _ _ _ _ _ _ _) || - refine (p _ _ _ _ _ _ _ _ _ _ _ _ _) || - refine (p _ _ _ _ _ _ _ _ _ _ _ _) || - refine (p _ _ _ _ _ _ _ _ _ _ _) || - refine (p _ _ _ _ _ _ _ _ _ _) || - refine (p _ _ _ _ _ _ _ _ _) || - refine (p _ _ _ _ _ _ _ _) || - refine (p _ _ _ _ _ _ _) || - refine (p _ _ _ _ _ _) || - refine (p _ _ _ _ _) || - refine (p _ _ _ _) || - refine (p _ _ _) || - refine (p _ _) || - refine (p _) || - refine p. + (** before we try to add more underscores, first ensure that adding such underscores is valid *) + (assert_succeeds (idtac; let __ := open_constr:(p _) in idtac); + rapply uconstr:(p _)) + || refine p. (** Tactical [on_call f tac] applies [tac] on any application of [f] in the hypothesis or goal. *) diff --git a/theories/Reals/Ranalysis.v b/theories/Reals/Ranalysis.v index 28d1c2c97f..332d3b14e4 100644 --- a/theories/Reals/Ranalysis.v +++ b/theories/Reals/Ranalysis.v @@ -24,7 +24,6 @@ Require Export Rsqrt_def. Require Export R_sqrt. Require Export Rtrigo_calc. Require Export Rgeom. -Require Export RList. Require Export Sqrt_reg. Require Export Ranalysis4. Require Export Rpower. diff --git a/theories/Reals/Ranalysis_reg.v b/theories/Reals/Ranalysis_reg.v index cb6d57be84..e6b3f2e37b 100644 --- a/theories/Reals/Ranalysis_reg.v +++ b/theories/Reals/Ranalysis_reg.v @@ -24,7 +24,6 @@ Require Export Rsqrt_def. Require Export R_sqrt. Require Export Rtrigo_calc. Require Export Rgeom. -Require Export RList. Require Export Sqrt_reg. Require Export Ranalysis4. Require Export Rpower. diff --git a/theories/Reals/RiemannInt.v b/theories/Reals/RiemannInt.v index a848a59d48..0337b12cad 100644 --- a/theories/Reals/RiemannInt.v +++ b/theories/Reals/RiemannInt.v @@ -15,6 +15,7 @@ Require Import Ranalysis_reg. Require Import Rbase. Require Import RiemannInt_SF. Require Import Max. +Require Import RList. Local Open Scope R_scope. Set Implicit Arguments. diff --git a/theories/Reals/RiemannInt_SF.v b/theories/Reals/RiemannInt_SF.v index 6da0fe3966..c8ec4782d9 100644 --- a/theories/Reals/RiemannInt_SF.v +++ b/theories/Reals/RiemannInt_SF.v @@ -12,6 +12,7 @@ Require Import Rbase. Require Import Rfunctions. Require Import Ranalysis_reg. Require Import Classical_Prop. +Require Import RList. Local Open Scope R_scope. Set Implicit Arguments. diff --git a/theories/Strings/Ascii.v b/theories/Strings/Ascii.v index 79ec67b633..6a849bb0b1 100644 --- a/theories/Strings/Ascii.v +++ b/theories/Strings/Ascii.v @@ -24,6 +24,9 @@ Declare Scope char_scope. Delimit Scope char_scope with char. Bind Scope char_scope with ascii. +Register ascii as core.ascii.type. +Register Ascii as core.ascii.ascii. + Definition zero := Ascii false false false false false false false false. Definition one := Ascii true false false false false false false false. diff --git a/theories/Strings/String.v b/theories/Strings/String.v index 9d0d2f854d..b736f41a08 100644 --- a/theories/Strings/String.v +++ b/theories/Strings/String.v @@ -30,8 +30,9 @@ Delimit Scope string_scope with string. Bind Scope string_scope with string. Local Open Scope string_scope. -Register EmptyString as plugins.syntax.EmptyString. -Register String as plugins.syntax.String. +Register string as core.string.type. +Register EmptyString as core.string.empty. +Register String as core.string.string. (** Equality is decidable *) diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in index 7c53ecfe18..d3ed5e78b4 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -389,7 +389,11 @@ optfiles: $(if $(DO_NATDYNLINK),$(CMXSFILES)) .PHONY: optfiles # FIXME, see Ralf's bugreport -quick: $(VOFILES:.vo=.vio) +# quick is deprecated, now renamed vio +vio: $(VOFILES:.vo=.vio) +.PHONY: vio +quick: vio + $(warning "'make quick' is deprecated, use 'make vio' or consider using 'vos' files") .PHONY: quick vio2vo: @@ -397,8 +401,9 @@ vio2vo: -schedule-vio2vo $(J) $(VOFILES:%.vo=%.vio) .PHONY: vio2vo +# quick2vo is undocumented quick2vo: - $(HIDE)make -j $(J) quick + $(HIDE)make -j $(J) vio $(HIDE)VIOFILES=$$(for vofile in $(VOFILES); do \ viofile="$$(echo "$$vofile" | sed "s/\.vo$$/.vio/")"; \ if [ "$$vofile" -ot "$$viofile" -o ! -e "$$vofile" ]; then printf "$$viofile "; fi; \ @@ -632,7 +637,7 @@ $(MLLIBFILES:.mllib=.cma): %.cma: | %.mllib $(MLLIBFILES:.mllib=.cmxa): %.cmxa: | %.mllib $(SHOW)'CAMLOPT -a -o $@' - $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) -a -o $@ $^ + $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -a -o $@ $^ $(MLPACKFILES:.mlpack=.cmxs): %.cmxs: %.cmxa @@ -677,8 +682,8 @@ $(GLOBFILES): %.glob: %.v $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< $(VFILES:.v=.vio): %.vio: %.v - $(SHOW)COQC -quick $< - $(HIDE)$(TIMER) $(COQC) -quick $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< + $(SHOW)COQC -vio $< + $(HIDE)$(TIMER) $(COQC) -vio $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< $(VFILES:.v=.vos): %.vos: %.v $(SHOW)COQC -vos $< diff --git a/tools/coqdoc/cpretty.mll b/tools/coqdoc/cpretty.mll index a44ddf7467..13913cabc3 100644 --- a/tools/coqdoc/cpretty.mll +++ b/tools/coqdoc/cpretty.mll @@ -547,6 +547,9 @@ rule coq_bol = parse comment lexbuf end else skipped_comment lexbuf in if eol then coq_bol lexbuf else coq lexbuf } + | space* "#[" { + let eol = begin backtrack lexbuf; body_bol lexbuf end + in if eol then coq_bol lexbuf else coq lexbuf } | eof { () } | _ @@ -643,6 +646,11 @@ and coq = parse Output.ident s None; let eol = body lexbuf in if eol then coq_bol lexbuf else coq lexbuf } + | "#[" + { ignore(lexeme lexbuf); + Output.char '#'; Output.char '['; + let eol = body lexbuf in + if eol then coq_bol lexbuf else coq lexbuf } | space+ { Output.char ' '; coq lexbuf } | eof { () } diff --git a/topbin/coqtop_byte_bin.ml b/topbin/coqtop_byte_bin.ml index aaabd90370..604c6e251a 100644 --- a/topbin/coqtop_byte_bin.ml +++ b/topbin/coqtop_byte_bin.ml @@ -8,6 +8,14 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +(* We register this handler for lower-level toplevel loading code *) +let _ = CErrors.register_handler (function + | Symtable.Error e -> + Pp.str (Format.asprintf "%a" Symtable.report_error e) + | _ -> + raise CErrors.Unhandled + ) + let drop_setup () = begin try (* Enable rectypes in the toplevel if it has the directive #rectypes *) @@ -23,7 +31,6 @@ let drop_setup () = { load_obj = (fun f -> if not (Topdirs.load_file ppf f) then CErrors.user_err Pp.(str ("Could not load plugin "^f)) ); - use_file = Topdirs.dir_use ppf; add_dir = Topdirs.dir_directory; ml_loop = (fun () -> Toploop.loop ppf); }) diff --git a/toplevel/ccompile.ml b/toplevel/ccompile.ml index 3c198dc600..dceb811d66 100644 --- a/toplevel/ccompile.ml +++ b/toplevel/ccompile.ml @@ -121,6 +121,10 @@ let compile opts copts ~echo ~f_in ~f_out = in let long_f_dot_in, long_f_dot_out = ensure_exists_with_prefix f_in f_out ext_in ext_out in + let dump_empty_vos () = + (* Produce an empty .vos file, as a way to ensure that a stale .vos can never be loaded *) + let long_f_dot_vos = (chop_extension long_f_dot_out) ^ ".vos" in + create_empty_file long_f_dot_vos in match mode with | BuildVo | BuildVok -> let doc, sid = Topfmt.(in_phase ~phase:LoadingPrelude) @@ -145,18 +149,20 @@ let compile opts copts ~echo ~f_in ~f_out = let _doc = Stm.join ~doc:state.doc in let wall_clock2 = Unix.gettimeofday () in check_pending_proofs (); - if mode <> BuildVok (* Don't output proofs in -vok mode *) - then Library.save_library_to ~output_native_objects Library.ProofsTodoNone ldir long_f_dot_out (Global.opaque_tables ()); + (* In .vo production, dump a complete .vo file. + In .vok production, only dump an empty .vok file. *) + if mode = BuildVo + then Library.save_library_to ~output_native_objects Library.ProofsTodoNone ldir long_f_dot_out (Global.opaque_tables ()) + else create_empty_file long_f_dot_out; Aux_file.record_in_aux_at "vo_compile_time" (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1)); Aux_file.stop_aux_file (); - (* Produce an empty .vos file and an empty .vok file when producing a .vo in standard mode *) + (* In .vo production, dump an empty .vos file to indicate that the .vo should be loaded, + and dump an empty .vok file to indicate that proofs are ok. *) if mode = BuildVo then begin - create_empty_file (long_f_dot_out ^ "s"); + dump_empty_vos(); create_empty_file (long_f_dot_out ^ "k"); end; - (* Produce an empty .vok file when in -vok mode *) - if mode = BuildVok then create_empty_file (long_f_dot_out); Dumpglob.end_dump_glob () | BuildVio | BuildVos -> @@ -186,15 +192,22 @@ let compile opts copts ~echo ~f_in ~f_out = let doc = Stm.finish ~doc:state.doc in check_pending_proofs (); let create_vos = (mode = BuildVos) in + (* In .vos production, the output .vos file contains compiled statements. + In .vio production, the output .vio file contains compiled statements and suspended proofs. *) let () = ignore (Stm.snapshot_vio ~create_vos ~doc ~output_native_objects ldir long_f_dot_out) in - Stm.reset_task_queue () + Stm.reset_task_queue (); + (* In .vio production, dump an empty .vos file to indicate that the .vio should be loaded. *) + if mode = BuildVio then dump_empty_vos() | Vio2Vo -> let sum, lib, univs, tasks, proofs = Library.load_library_todo long_f_dot_in in let univs, proofs = Stm.finish_tasks long_f_dot_out univs proofs tasks in - Library.save_library_raw long_f_dot_out sum lib univs proofs + Library.save_library_raw long_f_dot_out sum lib univs proofs; + (* Like in direct .vo production, dump an empty .vok file and an empty .vos file. *) + dump_empty_vos(); + create_empty_file (long_f_dot_out ^ "k") let compile opts copts ~echo ~f_in ~f_out = ignore(CoqworkmgrApi.get 1); diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index 5326ce6114..74d9c113d6 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -395,12 +395,6 @@ let parse_args ~help ~init arglist : t * string list = |"-inputstate"|"-is" -> set_inputstate oval (next ()) - |"-load-ml-object" -> - Mltop.dir_ml_load (next ()); oval - - |"-load-ml-source" -> - Mltop.dir_ml_use (next ()); oval - |"-load-vernac-object" -> add_vo_require oval (next ()) None None @@ -503,7 +497,7 @@ let parse_args ~help ~init arglist : t * string list = }}} |"-test-mode" -> Vernacinterp.test_mode := true; oval |"-beautify" -> Flags.beautify := true; oval - |"-bt" -> Backtrace.record_backtrace true; oval + |"-bt" -> Exninfo.record_backtrace true; oval |"-color" -> set_color oval (next ()) |"-config"|"--config" -> set_query oval PrintConfig |"-debug" -> Coqinit.set_debug (); oval diff --git a/toplevel/coqc.ml b/toplevel/coqc.ml index 178aa362c0..0c15f66c07 100644 --- a/toplevel/coqc.ml +++ b/toplevel/coqc.ml @@ -25,7 +25,6 @@ let coqc_specific_usage = Usage.{ coqc specific options:\ \n -o f.vo use f.vo as the output file name\ \n -verbose compile and output the input file\ -\n -quick quickly compile .v files to .vio files (skip proofs)\ \n -schedule-vio2vo j f1..fn run up to j instances of Coq to turn each fi.vio\ \n into fi.vo\ \n -schedule-vio-checking j f1..fn run up to j instances of Coq to check all\ @@ -33,8 +32,10 @@ coqc specific options:\ \n -vos process statements but ignore opaque proofs, and produce a .vos file\ \n -vok process the file by loading .vos instead of .vo files for\ \n dependencies, and produce an empty .vok file on success\ +\n -vio process statements and suspend opaque proofs, and produce a .vio file\ \n\ \nUndocumented:\ +\n -quick (deprecated) alias for -vio\ \n -vio2vo [see manual]\ \n -check-vio-tasks [see manual]\ \n" diff --git a/toplevel/coqcargs.ml b/toplevel/coqcargs.ml index e614d4fe6d..0c20563d07 100644 --- a/toplevel/coqcargs.ml +++ b/toplevel/coqcargs.ml @@ -98,7 +98,7 @@ let set_compilation_mode opts mode = match opts.compilation_mode with | BuildVo -> { opts with compilation_mode = mode } | mode' when mode <> mode' -> - prerr_endline "Options -quick and -vio2vo are exclusive"; + prerr_endline "Options -vio and -vio2vo are exclusive"; exit 1 | _ -> opts @@ -126,6 +126,11 @@ let warn_deprecated_outputstate = (fun () -> Pp.strbrk "The outputstate option is deprecated and discouraged.") +let warn_deprecated_quick = + CWarnings.create ~name:"deprecated-quick" ~category:"deprecated" + (fun () -> + Pp.strbrk "The -quick option is renamed -vio. Please consider using the -vos feature instead.") + let set_outputstate opts s = warn_deprecated_outputstate (); { opts with outputstate = Some s } @@ -165,6 +170,9 @@ let parse arglist : t = | "-o" -> { oval with compilation_output_name = Some (next ()) } | "-quick" -> + warn_deprecated_quick(); + set_compilation_mode oval BuildVio + | "-vio" -> set_compilation_mode oval BuildVio |"-vos" -> Flags.load_vos_libraries := true; diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index ae37e40101..ac348b9646 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -14,7 +14,7 @@ open Pp let ( / ) s1 s2 = Filename.concat s1 s2 let set_debug () = - let () = Backtrace.record_backtrace true in + let () = Exninfo.record_backtrace true in Flags.debug := true (* Loading of the resource file. diff --git a/toplevel/usage.ml b/toplevel/usage.ml index b17ca71f4c..051638d53c 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -36,8 +36,6 @@ let print_usage_common co command = \n -nois (idem)\ \n -compat X.Y provides compatibility support for Coq version X.Y\ \n\ -\n -load-ml-object f load ML object file f\ -\n -load-ml-source f load ML file f\ \n -load-vernac-source f load Coq file f.v (Load \"f\".)\ \n -l f (idem)\ \n -load-vernac-source-verbose f load Coq file f.v (Load Verbose \"f\".)\ diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index bca6b48499..adcce67b0d 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -69,10 +69,10 @@ let interp_vernac ~check ~interactive ~state ({CAst.loc;_} as com) = let new_proof = Vernacstate.Proof_global.give_me_the_proof_opt () [@ocaml.warning "-3"] in { state with doc = ndoc; sid = nsid; proof = new_proof; } with reraise -> + let (reraise, info) = CErrors.push reraise in (* XXX: In non-interactive mode edit_at seems to do very weird things, so we better avoid it while we investigate *) if interactive then ignore(Stm.edit_at ~doc:state.doc state.sid); - let (reraise, info) = CErrors.push reraise in let info = begin match Loc.get_loc info with | None -> Option.cata (Loc.add_loc info) info loc diff --git a/vernac/attributes.ml b/vernac/attributes.ml index b7a3b002bd..68d2c3a00d 100644 --- a/vernac/attributes.ml +++ b/vernac/attributes.ml @@ -234,5 +234,7 @@ let only_polymorphism atts = parse polymorphic atts let vernac_polymorphic_flag = ukey, VernacFlagList ["polymorphic", VernacFlagEmpty] let vernac_monomorphic_flag = ukey, VernacFlagList ["monomorphic", VernacFlagEmpty] -let canonical = +let canonical_field = enable_attribute ~key:"canonical" ~default:(fun () -> true) +let canonical_instance = + enable_attribute ~key:"canonical" ~default:(fun () -> false) diff --git a/vernac/attributes.mli b/vernac/attributes.mli index 34ff15ca7d..0074db66d3 100644 --- a/vernac/attributes.mli +++ b/vernac/attributes.mli @@ -48,7 +48,8 @@ val program : bool attribute val template : bool option attribute val locality : bool option attribute val deprecation : Deprecation.t option attribute -val canonical : bool attribute +val canonical_field : bool attribute +val canonical_instance : bool attribute val program_mode_option_name : string list (** For internal use when messing with the global option. *) diff --git a/vernac/canonical.ml b/vernac/canonical.ml index 141b02ef63..e41610b532 100644 --- a/vernac/canonical.ml +++ b/vernac/canonical.ml @@ -21,10 +21,12 @@ let cache_canonical_structure (_, (o,_)) = let sigma = Evd.from_env env in register_canonical_structure ~warn:true env sigma o -let discharge_canonical_structure (_,(x, local)) = - if local then None else Some (x, local) +let discharge_canonical_structure (_,((gref, _ as x), local)) = + if local || (Globnames.isVarRef gref && Lib.is_in_section gref) then None + else Some (x, local) -let inCanonStruc : (Constant.t * inductive) * bool -> obj = + +let inCanonStruc : (GlobRef.t * inductive) * bool -> obj = declare_object {(default_object "CANONICAL-STRUCTURE") with open_function = open_canonical_structure; cache_function = cache_canonical_structure; diff --git a/vernac/classes.ml b/vernac/classes.ml index c9b5144299..77bc4e4f8a 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -42,13 +42,10 @@ let () = Hook.set Typeclasses.classes_transparent_state_hook classes_transparent_state let add_instance_hint inst path local info poly = - let inst' = match inst with IsConstr c -> Hints.IsConstr (EConstr.of_constr c, Univ.ContextSet.empty) - | IsGlobal gr -> Hints.IsGlobRef gr - in Flags.silently (fun () -> Hints.add_hints ~local [typeclasses_db] (Hints.HintsResolveEntry - [info, poly, false, Hints.PathHints path, inst'])) () + [info, poly, false, Hints.PathHints path, inst])) () let is_local_for_hint i = match i.is_global with @@ -61,9 +58,9 @@ let is_local_for_hint i = let add_instance check inst = let poly = Global.is_polymorphic inst.is_impl in let local = is_local_for_hint inst in - add_instance_hint (IsGlobal inst.is_impl) [inst.is_impl] local + add_instance_hint (Hints.IsGlobRef inst.is_impl) [inst.is_impl] local inst.is_info poly; - List.iter (fun (path, pri, c) -> add_instance_hint (IsConstr c) path + List.iter (fun (path, pri, c) -> add_instance_hint (Hints.IsConstr (EConstr.of_constr c, Univ.ContextSet.empty)) path local pri poly) (build_subclasses ~check:(check && not (isVarRef inst.is_impl)) (Global.env ()) (Evd.from_env (Global.env ())) inst.is_impl inst.is_info) diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index 8a403e5a03..625ffb5a06 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -32,7 +32,7 @@ let declare_variable is_coe ~kind typ imps impl {CAst.v=name} = let env = Global.env () in let sigma = Evd.from_env env in let () = Classes.declare_instance env sigma None true r in - let () = if is_coe then Class.try_add_new_coercion r ~local:true ~poly:false in + let () = if is_coe then ComCoercion.try_add_new_coercion r ~local:true ~poly:false in () let instance_of_univ_entry = function @@ -65,7 +65,7 @@ let declare_axiom is_coe ~poly ~local ~kind typ (univs, pl) imps nl {CAst.v=name | Declare.ImportNeedQualified -> true | Declare.ImportDefaultBehavior -> false in - let () = if is_coe then Class.try_add_new_coercion gr ~local ~poly in + let () = if is_coe then ComCoercion.try_add_new_coercion gr ~local ~poly in let inst = instance_of_univ_entry univs in (gr,inst) diff --git a/vernac/class.ml b/vernac/comCoercion.ml index 3c43b125d1..56ab6f289d 100644 --- a/vernac/class.ml +++ b/vernac/comCoercion.ml @@ -18,7 +18,7 @@ open Context open Vars open Termops open Environ -open Classops +open Coercionops open Declare open Libobject @@ -231,7 +231,7 @@ let check_source = function let cache_coercion (_,c) = let env = Global.env () in let sigma = Evd.from_env env in - Classops.declare_coercion env sigma c + Coercionops.declare_coercion env sigma c let open_coercion i o = if Int.equal i 1 then diff --git a/vernac/class.mli b/vernac/comCoercion.mli index 3254d5d981..f98ef4fdd6 100644 --- a/vernac/class.mli +++ b/vernac/comCoercion.mli @@ -9,7 +9,7 @@ (************************************************************************) open Names -open Classops +open Coercionops (** Classes and coercions. *) diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index b603c54026..8de1c69424 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -553,7 +553,7 @@ let do_mutual_inductive ~template udecl indl ~cumulative ~poly ~private_ind ~uni (* Declare the possible notations of inductive types *) List.iter (Metasyntax.add_notation_interpretation (Global.env ())) ntns; (* Declare the coercions *) - List.iter (fun qid -> Class.try_add_new_coercion (Nametab.locate qid) ~local:false ~poly) coes + List.iter (fun qid -> ComCoercion.try_add_new_coercion (Nametab.locate qid) ~local:false ~poly) coes (** Prepare a "match" template for a given inductive type. For each branch of the match, we list the constructor name diff --git a/vernac/declareUniv.ml b/vernac/declareUniv.ml index 69ba9d76ec..def2fdad2a 100644 --- a/vernac/declareUniv.ml +++ b/vernac/declareUniv.ml @@ -72,7 +72,7 @@ let declare_univ_binders gr pl = CErrors.anomaly ~label:"declare_univ_binders" Pp.(str "declare_univ_binders on variable " ++ Id.print id ++ str".") | ConstructRef _ -> CErrors.anomaly ~label:"declare_univ_binders" - Pp.(str "declare_univ_binders on an constructor reference") + Pp.(str "declare_univ_binders on a constructor reference") in let univs = Id.Map.fold (fun id univ univs -> match Univ.Level.name univ with diff --git a/vernac/egramcoq.ml b/vernac/egramcoq.ml index b65a126f55..07656f9715 100644 --- a/vernac/egramcoq.ml +++ b/vernac/egramcoq.ml @@ -278,6 +278,10 @@ let find_custom_entry s = try (find_custom_entry constr_custom_entry sc, find_custom_entry pattern_custom_entry sp) with Not_found -> user_err Pp.(str "Undeclared custom entry: " ++ str s ++ str ".") +let exists_custom_entry s = match find_custom_entry s with +| _ -> true +| exception _ -> false + let locality_of_custom_entry s = String.Set.mem s !custom_entry_locality (* This computes the name of the level where to add a new rule *) diff --git a/vernac/egramcoq.mli b/vernac/egramcoq.mli index f879d51660..6768d24d5c 100644 --- a/vernac/egramcoq.mli +++ b/vernac/egramcoq.mli @@ -19,4 +19,7 @@ val extend_constr_grammar : Notation_gram.one_notation_grammar -> unit (** Add a term notation rule to the parsing system. *) val create_custom_entry : local:bool -> string -> unit + +val exists_custom_entry : string -> bool + val locality_of_custom_entry : string -> bool diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 436648c163..3302231fd1 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -471,7 +471,7 @@ GRAMMAR EXTEND Gram [ [ attr = LIST0 quoted_attributes ; bd = record_binder; rf_priority = OPT [ "|"; n = natural -> { n } ]; rf_notation = decl_notation -> { - let rf_canonical = attr |> List.flatten |> parse canonical in + let rf_canonical = attr |> List.flatten |> parse canonical_field in let rf_subclass, rf_decl = bd in rf_decl, { rf_subclass ; rf_priority ; rf_notation ; rf_canonical } } ] ] ; @@ -1026,7 +1026,8 @@ GRAMMAR EXTEND Gram | IDENT "Coercions" -> { PrintCoercions } | IDENT "Coercion"; IDENT "Paths"; s = class_rawexpr; t = class_rawexpr -> { PrintCoercionPaths (s,t) } - | IDENT "Canonical"; IDENT "Projections" -> { PrintCanonicalConversions } + | IDENT "Canonical"; IDENT "Projections"; qids = LIST0 smart_global + -> { PrintCanonicalConversions qids } | IDENT "Typing"; IDENT "Flags" -> { PrintTypingFlags } | IDENT "Tables" -> { PrintTables } | IDENT "Options" -> { PrintTables (* A Synonymous to Tables *) } diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 19ec0a3642..eb39564fed 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -297,6 +297,7 @@ let explain_unification_error env sigma p1 p2 = function strbrk " with term " ++ pr_leconstr_env env sigma rhs ++ strbrk " that would depend on itself"] | NotClean ((evk,args),env,c) -> + let env = make_all_name_different env sigma in [str "cannot instantiate " ++ quote (pr_existential_key sigma evk) ++ strbrk " because " ++ pr_leconstr_env env sigma c ++ strbrk " is not in its scope" ++ @@ -605,7 +606,7 @@ let rec explain_evar_kind env sigma evk ty = let explain_typeclass_resolution env sigma evi k = match Typeclasses.class_of_constr env sigma evi.evar_concl with | Some _ -> - let env = Evd.evar_filtered_env evi in + let env = Evd.evar_filtered_env env evi in fnl () ++ str "Could not find an instance for " ++ pr_leconstr_env env sigma evi.evar_concl ++ pr_trailing_ne_context_of env sigma @@ -622,7 +623,7 @@ let explain_placeholder_kind env sigma c e = let explain_unsolvable_implicit env sigma evk explain = let evi = Evarutil.nf_evar_info sigma (Evd.find_undefined sigma evk) in - let env = Evd.evar_filtered_env evi in + let env = Evd.evar_filtered_env env evi in let type_of_hole = pr_leconstr_env env sigma evi.evar_concl in let pe = pr_trailing_ne_context_of env sigma in strbrk "Cannot infer " ++ @@ -1363,7 +1364,6 @@ let explain_exn_default = function | Sys_error msg -> hov 0 (str "System error: " ++ quote (str msg)) | Out_of_memory -> hov 0 (str "Out of memory.") | Stack_overflow -> hov 0 (str "Stack overflow.") - | Dynlink.Error e -> hov 0 (str "Dynlink error: " ++ str Dynlink.(error_message e)) | CErrors.Timeout -> hov 0 (str "Timeout!") | Sys.Break -> hov 0 (fnl () ++ str "User interrupt.") (* Otherwise, not handled here *) diff --git a/vernac/library.ml b/vernac/library.ml index 244424de6b..0f7e7d2aa0 100644 --- a/vernac/library.ml +++ b/vernac/library.ml @@ -430,6 +430,22 @@ let error_recursively_dependent_library dir = (* Security weakness: file might have been changed on disk between writing the content and computing the checksum... *) +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 + with reraise -> + let reraise = CErrors.push reraise in + close_out ch; + Feedback.msg_warning (str "Removed file " ++ str f); + Sys.remove f; + iraise reraise + type ('document,'counters) todo_proofs = | ProofsTodoNone (* for .vo *) | ProofsTodoSomeEmpty of Future.UUIDSet.t (* for .vos *) @@ -454,18 +470,17 @@ let save_library_to todo_proofs ~output_native_objects dir f otab = match todo_proofs with | ProofsTodoNone -> None, None | ProofsTodoSomeEmpty _except -> - None, - Some (Univ.ContextSet.empty,false) + None, Some (Univ.ContextSet.empty,false) | ProofsTodoSome (_except, tasks, rcbackup) -> - let tasks = - List.map Stateid.(fun (r,b) -> + let tasks = + List.map Stateid.(fun (r,b) -> try { r with uuid = Future.UUIDMap.find r.uuid f2t_map }, b with Not_found -> assert b; { r with uuid = -1 }, b) tasks in - Some (tasks,rcbackup), - Some (Univ.ContextSet.empty,false) - in - let sd = { + Some (tasks,rcbackup), + Some (Univ.ContextSet.empty,false) + in + let sd = { md_name = dir; md_deps = Array.of_list (current_deps ()); } in @@ -475,36 +490,15 @@ let save_library_to todo_proofs ~output_native_objects dir f otab = } in if Array.exists (fun (d,_) -> DirPath.equal d dir) sd.md_deps then error_recursively_dependent_library dir; - (* Open the vo file and write the magic number *) - let f' = f in - let ch = raw_extern_library f' in - try - (* Writing vo payload *) - System.marshal_out_segment f' ch (sd : seg_sum); - System.marshal_out_segment f' ch (md : seg_lib); - System.marshal_out_segment f' ch (utab : seg_univ option); - System.marshal_out_segment f' ch (tasks : 'tasks option); - System.marshal_out_segment f' ch (opaque_table : seg_proofs); - close_out ch; - (* Writing native code files *) - if output_native_objects then - let fn = Filename.dirname f'^"/"^Nativecode.mod_uid_of_dirpath dir in - Nativelib.compile_library dir ast fn - with reraise -> - let reraise = CErrors.push reraise in - let () = Feedback.msg_warning (str "Removed file " ++ str f') in - let () = close_out ch in - let () = Sys.remove f' in - iraise reraise + (* Writing vo payload *) + save_library_base f sd md utab tasks opaque_table; + (* Writing native code files *) + if output_native_objects then + let fn = Filename.dirname f ^"/"^ Nativecode.mod_uid_of_dirpath dir in + Nativelib.compile_library dir ast fn let save_library_raw f sum lib univs proofs = - let ch = raw_extern_library f in - System.marshal_out_segment f ch (sum : seg_sum); - System.marshal_out_segment f ch (lib : seg_lib); - System.marshal_out_segment f ch (Some univs : seg_univ option); - System.marshal_out_segment f ch (None : 'tasks option); - System.marshal_out_segment f ch (proofs : seg_proofs); - close_out ch + save_library_base f sum lib (Some univs) None proofs module StringOrd = struct type t = string let compare = String.compare end module StringSet = Set.Make(StringOrd) diff --git a/vernac/loadpath.ml b/vernac/loadpath.ml index a8462e31e1..506b3bc505 100644 --- a/vernac/loadpath.ml +++ b/vernac/loadpath.ml @@ -138,27 +138,31 @@ let select_vo_file ~warn loadpath base = System.where_in_path ~warn loadpath name in Some (lpath, file) with Not_found -> None in + (* If [!Flags.load_vos_libraries] + and the .vos file exists + and this file is not empty + Then load this library + Else load the most recent between the .vo file and the .vio file, + or if there is only of the two files, take this one, + or raise an error if both are missing. *) + let load_most_recent_of_vo_and_vio () = + match find ".vo", find ".vio" with + | None, None -> + Error LibNotFound + | Some res, None | None, Some res -> + Ok res + | Some (_, vo), Some (_, vi as resvi) + when Unix.((stat vo).st_mtime < (stat vi).st_mtime) -> + warn_several_object_files (vi, vo); + Ok resvi + | Some resvo, Some _ -> + Ok resvo + in if !Flags.load_vos_libraries then begin - (* If the .vos file exists and is not empty, it describes the library. - Otherwise, load the .vo file, or fail if is missing. *) match find ".vos" with | Some (_, vos as resvos) when (Unix.stat vos).Unix.st_size > 0 -> Ok resvos - | _ -> - match find ".vo" with - | None -> Error LibNotFound - | Some resvo -> Ok resvo - end else - match find ".vo", find ".vio" with - | None, None -> - Error LibNotFound - | Some res, None | None, Some res -> - Ok res - | Some (_, vo), Some (_, vi as resvi) - when Unix.((stat vo).st_mtime < (stat vi).st_mtime) -> - warn_several_object_files (vi, vo); - Ok resvi - | Some resvo, Some _ -> - Ok resvo + | _ -> load_most_recent_of_vo_and_vio() + end else load_most_recent_of_vo_and_vio() let locate_absolute_library dir : CUnix.physical_path locate_result = (* Search in loadpath *) diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 35681aed13..05e23164b1 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -1346,7 +1346,7 @@ let inNotation : notation_obj -> obj = (**********************************************************************) let with_lib_stk_protection f x = - let fs = Lib.freeze ~marshallable:false in + let fs = Lib.freeze () in try let a = f x in Lib.unfreeze fs; a with reraise -> let reraise = CErrors.push reraise in @@ -1654,10 +1654,16 @@ let add_syntactic_definition ~local deprecation env ident (vars,c) { onlyparsing (**********************************************************************) (* Declaration of custom entry *) +let warn_custom_entry = + CWarnings.create ~name:"custom-entry-overriden" ~category:"parsing" + (fun s -> + strbrk "Custom entry " ++ str s ++ strbrk " has been overriden.") + let load_custom_entry _ _ = () let open_custom_entry _ (_,(local,s)) = - Egramcoq.create_custom_entry ~local s + if Egramcoq.exists_custom_entry s then warn_custom_entry s + else Egramcoq.create_custom_entry ~local s let cache_custom_entry o = load_custom_entry 1 o; @@ -1677,4 +1683,7 @@ let inCustomEntry : locality_flag * string -> obj = classify_function = classify_custom_entry} let declare_custom_entry local s = - Lib.add_anonymous_leaf (inCustomEntry (local,s)) + if Egramcoq.exists_custom_entry s then + user_err Pp.(str "Custom entry " ++ str s ++ str " already exists") + else + Lib.add_anonymous_leaf (inCustomEntry (local,s)) diff --git a/vernac/mltop.ml b/vernac/mltop.ml index 9c18441d9c..2bac35b08f 100644 --- a/vernac/mltop.ml +++ b/vernac/mltop.ml @@ -56,7 +56,6 @@ let keep_copy_mlpath path = (* If there is a toplevel under Coq *) type toplevel = { load_obj : string -> unit; - use_file : string -> unit; add_dir : string -> unit; ml_loop : unit -> unit } @@ -94,43 +93,26 @@ let ocaml_toploop () = | WithTop t -> Printexc.catch t.ml_loop () | _ -> () -(* Try to interpret load_obj's (internal) errors *) -let report_on_load_obj_error exc = - let x = Obj.repr exc in - (* Try an horrible (fragile) hack to report on Symtable dynlink errors *) - (* (we follow ocaml's Printexc.to_string decoding of exceptions) *) - if Obj.is_block x && String.equal (Obj.magic (Obj.field (Obj.field x 0) 0)) "Symtable.Error" - then - let err_block = Obj.field x 1 in - if Int.equal (Obj.tag err_block) 0 then - (* Symtable.Undefined_global of string *) - str "reference to undefined global " ++ - str (Obj.magic (Obj.field err_block 0)) - else str (Printexc.to_string exc) - else str (Printexc.to_string exc) - (* Dynamic loading of .cmo/.cma *) +(* We register errors at least for Dynlink, it is possible to do so Symtable + too, as we do in the bytecode init code. +*) +let _ = CErrors.register_handler (function + | Dynlink.Error e -> + hov 0 (str "Dynlink error: " ++ str Dynlink.(error_message e)) + | _ -> + raise CErrors.Unhandled + ) + let ml_load s = - match !load with - | WithTop t -> - (try t.load_obj s; s - with - | e when CErrors.noncritical e -> - let e = CErrors.push e in - match fst e with - | (UserError _ | Failure _ | Not_found as u) -> Exninfo.iraise (u, snd e) - | exc -> - let msg = report_on_load_obj_error exc in - user_err ~hdr:"Mltop.load_object" (str"Cannot link ml-object " ++ - str s ++ str" to Coq code (" ++ msg ++ str ").")) - | WithoutTop -> - try - Dynlink.loadfile s; s - with Dynlink.Error a -> - user_err ~hdr:"Mltop.load_object" - (strbrk "while loading " ++ str s ++ - strbrk ": " ++ str (Dynlink.error_message a)) + (match !load with + | WithTop t -> + t.load_obj s + | WithoutTop -> + Dynlink.loadfile s + ); + s let dir_ml_load s = match !load with @@ -140,17 +122,6 @@ let dir_ml_load s = let _,gname = find_file_in_path ~warn !coq_mlpath_copy s in ml_load gname -(* Dynamic interpretation of .ml *) -let dir_ml_use s = - match !load with - | WithTop t -> t.use_file s - | _ -> - let moreinfo = - if Sys.(backend_type = Native) then " Loading ML code works only in bytecode." - else "" - in - user_err ~hdr:"Mltop.dir_ml_use" (str "Could not load ML code." ++ str moreinfo) - (* Adds a path to the ML paths *) let add_ml_dir s = match !load with @@ -275,7 +246,6 @@ let load_ml_object mname ?path fname= init_ml_object mname; path -let dir_ml_load m = ignore(dir_ml_load m) let add_known_module m = add_known_module m None (* Summary of declared ML Modules *) diff --git a/vernac/mltop.mli b/vernac/mltop.mli index 56a28b64b0..271772d7ba 100644 --- a/vernac/mltop.mli +++ b/vernac/mltop.mli @@ -14,7 +14,6 @@ record. *) type toplevel = { load_obj : string -> unit; - use_file : string -> unit; add_dir : string -> unit; ml_loop : unit -> unit } @@ -38,12 +37,6 @@ val add_ml_dir : recursive:bool -> string -> unit (** Tests if we can load ML files *) val has_dynlink : bool -(** Dynamic loading of .cmo *) -val dir_ml_load : string -> unit - -(** Dynamic interpretation of .ml *) -val dir_ml_use : string -> unit - (** List of modules linked to the toplevel *) val add_known_module : string -> unit val module_is_known : string -> bool diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 1742027076..a1bd99c237 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -513,8 +513,8 @@ let string_of_theorem_kind = let open Decls in function keyword "Print Coercion Paths" ++ spc() ++ pr_class_rawexpr s ++ spc() ++ pr_class_rawexpr t - | PrintCanonicalConversions -> - keyword "Print Canonical Structures" + | PrintCanonicalConversions qids -> + keyword "Print Canonical Structures" ++ prlist pr_smart_global qids | PrintTypingFlags -> keyword "Print Typing Flags" | PrintTables -> diff --git a/vernac/prettyp.ml b/vernac/prettyp.ml index ec8658d939..2cd1cf7c65 100644 --- a/vernac/prettyp.ml +++ b/vernac/prettyp.ml @@ -199,7 +199,7 @@ let print_opacity ref = (*******************) let print_if_is_coercion ref = - if Classops.coercion_exists ref then [pr_global ref ++ str " is a coercion"] else [] + if Coercionops.coercion_exists ref then [pr_global ref ++ str " is a coercion"] else [] (*******************) (* *) @@ -972,7 +972,7 @@ let inspect env sigma depth = (*************************************************************************) (* Pretty-printing functions coming from classops.ml *) -open Classops +open Coercionops let print_coercion_value v = Printer.pr_global v.coe_value @@ -986,7 +986,7 @@ let print_path ((i,j),p) = str"] : ") ++ print_class i ++ str" >-> " ++ print_class j -let _ = Classops.install_path_printer print_path +let _ = Coercionops.install_path_printer print_path let print_graph () = prlist_with_sep fnl print_path (inheritance_graph()) @@ -1017,12 +1017,24 @@ let print_path_between cls clt = in print_path ((i,j),p) -let print_canonical_projections env sigma = +let print_canonical_projections env sigma grefs = + let match_proj_gref ((x,y),c) gr = + GlobRef.equal x gr || + begin match y with + | Const_cs y -> GlobRef.equal y gr + | _ -> false + end || + GlobRef.equal c.o_ORIGIN gr + in + let projs = + List.filter (fun p -> List.for_all (match_proj_gref p) grefs) + (canonical_projections ()) + in prlist_with_sep fnl (fun ((r1,r2),o) -> pr_cs_pattern r2 ++ str " <- " ++ pr_global r1 ++ str " ( " ++ pr_lconstr_env env sigma o.o_DEF ++ str " )") - (canonical_projections ()) + projs (*************************************************************************) diff --git a/vernac/prettyp.mli b/vernac/prettyp.mli index dc4280f286..ac41f30c5d 100644 --- a/vernac/prettyp.mli +++ b/vernac/prettyp.mli @@ -52,8 +52,8 @@ val print_impargs : qualid Constrexpr.or_by_notation -> Pp.t val print_graph : unit -> Pp.t val print_classes : unit -> Pp.t val print_coercions : unit -> Pp.t -val print_path_between : Classops.cl_typ -> Classops.cl_typ -> Pp.t -val print_canonical_projections : env -> Evd.evar_map -> Pp.t +val print_path_between : Coercionops.cl_typ -> Coercionops.cl_typ -> Pp.t +val print_canonical_projections : env -> Evd.evar_map -> GlobRef.t list -> Pp.t (** Pretty-printing functions for type classes and instances *) val print_typeclasses : unit -> Pp.t diff --git a/vernac/record.ml b/vernac/record.ml index ea10e06d02..df9b4a0914 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -366,8 +366,8 @@ let declare_projections indsp ctx ?(kind=Decls.StructureComponent) binder_name f let refi = GlobRef.ConstRef kn in Impargs.maybe_declare_manual_implicits false refi impls; if flags.pf_subclass then begin - let cl = Class.class_of_global (GlobRef.IndRef indsp) in - Class.try_add_new_coercion_with_source refi ~local:false ~poly ~source:cl + 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) @@ -489,7 +489,7 @@ let declare_structure ~cumulative finite ubinders univs paramimpls params templa let cstr = (rsp, 1) in let kinds,sp_projs = declare_projections rsp ctx ~kind binder_name.(i) coers fieldimpls fields in let build = GlobRef.ConstructRef cstr in - let () = if is_coe then Class.try_add_new_coercion build ~local:false ~poly in + let () = if is_coe then ComCoercion.try_add_new_coercion build ~local:false ~poly in let () = declare_structure_entry (cstr, List.rev kinds, List.rev sp_projs) in rsp in diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml index 45f40b1258..de02f7ecfb 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -359,7 +359,7 @@ let in_phase ~phase f x = default_phase := op; res with exn -> - let iexn = Backtrace.add_backtrace exn in + let iexn = Exninfo.capture exn in default_phase := op; Util.iraise iexn @@ -415,7 +415,7 @@ let with_output_to_file fname func input = close_out channel; output with reraise -> - let reraise = Backtrace.add_backtrace reraise in + let reraise = Exninfo.capture reraise in std_ft := Util.pi1 old_fmt; err_ft := Util.pi2 old_fmt; deep_ft := Util.pi3 old_fmt; diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index 833c279320..6e398d87ca 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -20,7 +20,7 @@ Canonical RecLemmas Library Lemmas -Class +ComCoercion Auto_ind_decl Indschemes Obligations diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 439ec61d38..d011fb2e77 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -49,9 +49,9 @@ let get_goal_or_global_context ~pstate glnum = | Some p -> Pfedit.get_goal_context p glnum let cl_of_qualid = function - | FunClass -> Classops.CL_FUN - | SortClass -> Classops.CL_SORT - | RefClass r -> Class.class_of_global (Smartlocate.smart_global ~head:true r) + | FunClass -> Coercionops.CL_FUN + | SortClass -> Coercionops.CL_SORT + | RefClass r -> ComCoercion.class_of_global (Smartlocate.smart_global ~head:true r) let scope_class_of_qualid qid = Notation.scope_class_of_class (cl_of_qualid qid) @@ -63,14 +63,15 @@ module DefAttributes = struct polymorphic : bool; program : bool; deprecated : Deprecation.t option; + canonical_instance : bool; } let parse f = let open Attributes in - let ((locality, deprecated), polymorphic), program = - parse Notations.(locality ++ deprecation ++ polymorphic ++ program) f + let (((locality, deprecated), polymorphic), program), canonical_instance = + parse Notations.(locality ++ deprecation ++ polymorphic ++ program ++ canonical_instance) f in - { polymorphic; program; locality; deprecated } + { polymorphic; program; locality; deprecated; canonical_instance } end let module_locality = Attributes.Notations.(locality >>= fun l -> return (make_module_locality l)) @@ -474,7 +475,7 @@ let program_inference_hook env sigma ev = let tac = !Obligations.default_tactic in let evi = Evd.find sigma ev in let evi = Evarutil.nf_evar_info sigma evi in - let env = Evd.evar_filtered_env evi in + let env = Evd.evar_filtered_env env evi in try let concl = evi.Evd.evar_concl in if not (Evarutil.is_ground_env sigma env && @@ -522,13 +523,17 @@ let start_lemma_com ~program_mode ~poly ~scope ~kind ?hook thms = in start_lemma_with_initialization ?hook ~poly ~scope ~kind evd ~udecl recguard thms snl -let vernac_definition_hook ~local ~poly = let open Decls in function +let vernac_definition_hook ~canonical_instance ~local ~poly = let open Decls in function | Coercion -> - Some (Class.add_coercion_hook ~poly) + Some (ComCoercion.add_coercion_hook ~poly) | CanonicalStructure -> Some (DeclareDef.Hook.(make (fun { S.dref } -> Canonical.declare_canonical_structure ?local dref))) | SubClass -> - Some (Class.add_subclass_hook ~poly) + Some (ComCoercion.add_subclass_hook ~poly) +| Definition when canonical_instance -> + Some (DeclareDef.Hook.(make (fun { S.dref } -> Canonical.declare_canonical_structure ?local dref))) +| Let when canonical_instance -> + Some (DeclareDef.Hook.(make (fun { S.dref } -> Canonical.declare_canonical_structure dref))) | _ -> None let fresh_name_for_anonymous_theorem () = @@ -551,7 +556,7 @@ let vernac_definition_name lid local = let vernac_definition_interactive ~atts (discharge, kind) (lid, pl) bl t = let open DefAttributes in let local = enforce_locality_exp atts.locality discharge in - let hook = vernac_definition_hook ~local:atts.locality ~poly:atts.polymorphic kind in + let hook = vernac_definition_hook ~canonical_instance:atts.canonical_instance ~local:atts.locality ~poly:atts.polymorphic kind in let program_mode = atts.program in let poly = atts.polymorphic in let name = vernac_definition_name lid local in @@ -560,7 +565,7 @@ let vernac_definition_interactive ~atts (discharge, kind) (lid, pl) bl t = let vernac_definition ~atts (discharge, kind) (lid, pl) bl red_option c typ_opt = let open DefAttributes in let scope = enforce_locality_exp atts.locality discharge in - let hook = vernac_definition_hook ~local:atts.locality ~poly:atts.polymorphic kind in + let hook = vernac_definition_hook ~canonical_instance:atts.canonical_instance ~local:atts.locality ~poly:atts.polymorphic kind in let program_mode = atts.program in let name = vernac_definition_name lid scope in let red_option = match red_option with @@ -1034,7 +1039,7 @@ let vernac_coercion ~atts ref qids qidt = let target = cl_of_qualid qidt in let source = cl_of_qualid qids in let ref' = smart_global ref in - Class.try_add_new_coercion_with_target ref' ~local ~poly ~source ~target; + ComCoercion.try_add_new_coercion_with_target ref' ~local ~poly ~source ~target; Flags.if_verbose Feedback.msg_info (pr_global ref' ++ str " is now a coercion") let vernac_identity_coercion ~atts id qids qidt = @@ -1042,7 +1047,7 @@ let vernac_identity_coercion ~atts id qids qidt = let local = enforce_locality local in let target = cl_of_qualid qidt in let source = cl_of_qualid qids in - Class.try_add_new_identity_coercion id ~local ~poly ~source ~target + ComCoercion.try_add_new_identity_coercion id ~local ~poly ~source ~target (* Type classes *) @@ -1448,6 +1453,14 @@ let () = optread = Nativenorm.get_profiling_enabled; optwrite = Nativenorm.set_profiling_enabled } +let () = + declare_bool_option + { optdepr = false; + optname = "enable native compute timing"; + optkey = ["NativeCompute"; "Timing"]; + optread = Nativenorm.get_timing_enabled; + optwrite = Nativenorm.set_timing_enabled } + let _ = declare_bool_option { optdepr = false; @@ -1701,7 +1714,9 @@ let vernac_print ~pstate ~atts = | PrintCoercions -> Prettyp.print_coercions () | PrintCoercionPaths (cls,clt) -> Prettyp.print_path_between (cl_of_qualid cls) (cl_of_qualid clt) - | PrintCanonicalConversions -> Prettyp.print_canonical_projections env sigma + | PrintCanonicalConversions qids -> + let grefs = List.map Smartlocate.smart_global qids in + Prettyp.print_canonical_projections env sigma grefs | PrintUniverses (sort, subgraph, dst) -> print_universes ~sort ~subgraph dst | PrintHint r -> Hints.pr_hint_ref env sigma (smart_global r) | PrintHintGoal -> diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index 32ff8b8fb2..1daa244986 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -46,7 +46,7 @@ type printable = | PrintInstances of qualid or_by_notation | PrintCoercions | PrintCoercionPaths of class_rawexpr * class_rawexpr - | PrintCanonicalConversions + | PrintCanonicalConversions of qualid or_by_notation list | PrintUniverses of bool * qualid list option * string option | PrintHint of qualid or_by_notation | PrintHintGoal |
