diff options
341 files changed, 5579 insertions, 4349 deletions
diff --git a/.bintray.json b/.bintray.json index 8672c2bb9a..1b32a144c8 100644 --- a/.bintray.json +++ b/.bintray.json @@ -6,7 +6,7 @@ }, "version": { - "name": "8.9+alpha" + "name": "8.10+alpha" }, "files": diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index 274a0001b1..267da478d7 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -6,11 +6,23 @@ /.github/ @maximedenes # Secondary maintainer @Zimmi48 +########## Build system ########## + +/Makefile* @gares + +/configure* @ejgallego + +/META.coq.in @ejgallego + +/dev/build/windows @MSoegtropIMC +# Secondary maintainer @maximedenes + ########## 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/user-overlays/*.sh @ghost # Trick to avoid getting review requests @@ -21,8 +33,7 @@ /dev/ci/*.bat @maximedenes # Secondary maintainer @SkySkimmer -/default.nix @Zimmi48 -# Secondary maintainer @vbgl +*.nix @coq/nix-maintainers ########## Documentation ########## @@ -35,6 +46,9 @@ /CONTRIBUTING.md @Zimmi48 # Secondary maintainer @maximedenes +/CODE_OF_CONDUCT.md @Zimmi48 +# Secondary maintainer @mattam82 + /dev/doc/ @Zimmi48 # Secondary maintainer @maximedenes @@ -43,6 +57,7 @@ # each time someone modifies the dev changelog /doc/ @coq/doc-maintainers +/Makefile.doc @coq/doc-maintainers /man/ @silene # Secondary maintainer @maximedenes @@ -136,9 +151,8 @@ /plugins/ltac/ @ppedrot # Secondary maintainer @herbelin -/plugins/micromega/ @fajb -/test-suite/micromega/ @fajb -# Secondary maintainer @bgregoir +/plugins/micromega/ @coq/micromega-maintainers +/test-suite/micromega/ @coq/micromega-maintainers /plugins/nsatz/ @thery # Secondary maintainer @ppedrot @@ -156,8 +170,6 @@ /plugins/syntax/ @ppedrot # Secondary maintainer @maximedenes -/plugins/quote/ @herbelin - /plugins/rtauto/ @PierreCorbineau # Secondary maintainer @herbelin @@ -302,25 +314,6 @@ /vernac/ @mattam82 # Secondary maintainer @maximedenes -########## Build system ########## - -/Makefile* @gares - -/configure* @ejgallego - -/META.coq.in @ejgallego - -/dev/build/windows @MSoegtropIMC -# Secondary maintainer @maximedenes - -# This file belongs to CI -/Makefile.ci @ejgallego -# Secondary maintainer @SkySkimmer - -# This file belongs to the doc -/Makefile.doc @maximedenes -# Secondary maintainer @silene - ########## Test suite ########## /test-suite/Makefile @gares diff --git a/.gitignore b/.gitignore index 8fc3c802ad..582a8f43c7 100644 --- a/.gitignore +++ b/.gitignore @@ -99,6 +99,9 @@ doc/faq/axioms.eps doc/faq/axioms.eps_t doc/faq/axioms.pdf_t doc/faq/axioms.png +doc/sphinx/index.rst +doc/sphinx/zebibliography.rst +doc/sphinx/credits-wrapper.rst doc/stdlib/Library.out doc/stdlib/Library.ps doc/stdlib/Library.coqdoc.tex diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 693a0b6bf0..15fcdf371a 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -9,7 +9,7 @@ stages: variables: # Format: $IMAGE-V$DATE [Cache is not used as of today but kept here # for reference] - CACHEKEY: "bionic_coq-V2018-08-27-V2" + CACHEKEY: "bionic_coq-V2018-09-23-V01" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -40,8 +40,8 @@ before_script: - printenv -0 | sort -z | tr '\0' '\n' - declare -A switch_table - switch_table=( ["base"]="$COMPILER" ["edge"]="$COMPILER_EDGE" ) - - opam switch -y "${switch_table[$OPAM_SWITCH]}$OPAM_VARIANT" - - eval $(opam config env) + - opam switch set -y "${switch_table[$OPAM_SWITCH]}$OPAM_VARIANT" + - eval $(opam env) - opam list - opam config list @@ -175,8 +175,8 @@ after_script: artifacts: name: "%CI_JOB_NAME%" paths: - - dev\nsis\*.exe - - coq-opensource-archive-windows-*.zip + - artifacts + when: always expire_in: 1 week dependencies: [] tags: @@ -275,7 +275,7 @@ doc:refman: dependencies: - build:base -doc:ml-api: +doc:ml-api:ocamldoc: stage: test dependencies: - build:edge @@ -287,6 +287,18 @@ doc:ml-api: paths: - dev/ocamldoc +doc:ml-api:odoc: + stage: test + dependencies: + - build:egde:dune:dev + script: make -f Makefile.dune apidoc + variables: + OPAM_SWITCH: edge + artifacts: + name: "$CI_JOB_NAME" + paths: + - _build/default/_doc/ + test-suite:base: <<: *test-suite-template dependencies: diff --git a/.travis.yml b/.travis.yml index dd28410bec..1a2c909c7d 100644 --- a/.travis.yml +++ b/.travis.yml @@ -105,8 +105,8 @@ matrix: # Full Coq test-suite with two compilers - if: NOT (type = pull_request) env: - - TEST_TARGET="test-suite" - - EXTRA_CONF="-coqide opt -with-doc yes" + - TEST_TARGET="doc-html test-suite" + - EXTRA_CONF="-coqide opt" - EXTRA_OPAM="${LABLGTK} ounit" before_install: &sphinx-install - sudo pip3 install bs4 sphinx sphinx_rtd_theme pexpect antlr4-python3-runtime sphinxcontrib-bibtex @@ -119,26 +119,17 @@ matrix: - aspcud - libgtk2.0-dev - libgtksourceview2.0-dev - - texlive-latex-base - - texlive-latex-recommended - - texlive-latex-extra - - texlive-math-extra - - texlive-fonts-recommended - - texlive-fonts-extra - - latex-xcolor - - ghostscript - - tipa - python3 - python3-pip - python3-setuptools - if: NOT (type = pull_request) env: - - TEST_TARGET="test-suite" + - TEST_TARGET="doc-html test-suite" - COMPILER="${COMPILER_BE}" - FINDLIB_VER="${FINDLIB_VER_BE}" - CAMLP5_VER="${CAMLP5_VER_BE}" - - EXTRA_CONF="-coqide opt -with-doc yes" + - EXTRA_CONF="-coqide opt" - EXTRA_OPAM="${LABLGTK_BE} ounit" before_install: *sphinx-install addons: @@ -150,11 +141,11 @@ matrix: # Full test-suite with flambda - if: NOT (type = pull_request) env: - - TEST_TARGET="test-suite" + - TEST_TARGET="doc-html test-suite" - COMPILER="${COMPILER_BE}+flambda" - FINDLIB_VER="${FINDLIB_VER_BE}" - CAMLP5_VER="${CAMLP5_VER_BE}" - - EXTRA_CONF="-coqide opt -with-doc yes -flambda-opts -O3" + - EXTRA_CONF="-coqide opt -flambda-opts -O3" - EXTRA_OPAM="${LABLGTK_BE} ounit" before_install: *sphinx-install addons: @@ -175,7 +166,9 @@ matrix: before_install: - brew update - brew unlink python - - brew install opam gnu-time + - brew install gnu-time + # only way to continue using OPAM 1.2 + - brew install https://raw.githubusercontent.com/Homebrew/homebrew-core/d156edeeed7291f4bc1e08620b331bbd05d52b78/Formula/opam.rb - if: NOT (type = pull_request) os: osx @@ -192,7 +185,9 @@ matrix: before_install: - brew update - brew unlink python - - brew install opam gnu-time gtk+ expat gtksourceview gdk-pixbuf + - brew install gnu-time gtk+ expat gtksourceview gdk-pixbuf + # only way to continue using OPAM 1.2 + - brew install https://raw.githubusercontent.com/Homebrew/homebrew-core/d156edeeed7291f4bc1e08620b331bbd05d52b78/Formula/opam.rb - brew unlink python@2 - brew install python3 - pip3 install macpack @@ -1,3 +1,13 @@ +Changes beyond 8.9 +================== + +Plugins + +- The quote plugin (https://coq.inria.fr/distrib/V8.8.1/refman/proof-engine/detailed-tactic-examples.html#quote) + was removed. If some users are interested in maintaining this plugin + externally, the Coq development team can provide assistance for extracting + the plugin and setting up a new repository. + Changes from 8.8.2 to 8.9+beta1 =============================== @@ -10,6 +20,11 @@ Notations - New support for autonomous grammars of terms, called "custom entries" (see chapter "Syntax extensions" of the reference manual). +- New command "Declare Scope" to explicitly declare a scope name + before any use of it. Implicit declaration of a scope at the time of + "Bind Scope", "Delimit Scope", "Undelimit Scope", or "Notation" is + deprecated. + Tactics - Added toplevel goal selector ! which expects a single focused goal. @@ -34,6 +49,10 @@ Tactics - Deprecated the Implicit Tactic family of commands. +- The default program obligation tactic uses a bounded proof search + instead of an unbounded and potentially non-terminating one now + (source of incompatibility). + - The `simple apply` tactic now respects the `Opaque` flag when called from Ltac (`auto` still does not respect it). @@ -48,12 +67,20 @@ Tactics may need to add `Require Import Lra` to your developments. For compatibility, we now define `fourier` as a deprecated alias of `lra`. +- The `romega` tactics have been deprecated; please use `lia` instead. + Focusing - Focusing bracket `{` now supports named goal selectors, e.g. `[x]: {` will focus on a goal (existential variable) named `x`. As usual, unfocus with `}` once the sub-goal is fully solved. +Specification language + +- A fix to unification (which was sensitive to the ascii name of + variables) may occasionally change type inference in incompatible + ways, especially regarding the inference of the return clause of "match". + Standard Library - Added `Ascii.eqb` and `String.eqb` and the `=?` notation for them, @@ -189,12 +216,30 @@ Notations Changes from 8.8.1 to 8.8.2 =========================== +Documentation + +- A PDF version of the reference manual is available once again. + Tools - The coq-makefile targets `print-pretty-timed`, `print-pretty-timed-diff`, and `print-pretty-single-time-diff` now correctly label the "before" and "after" columns, rather than swapping them. +Kernel + +- The kernel does not tolerate capture of global universes by + polymorphic universe binders, fixing a soundness break (triggered + only through custom plugins) + +Windows installer + +- The Windows installer now includes many more external packages that can be +individually selected for installation. + +Many other bug fixes and lots of documentation improvements (for details, +see the 8.8.2 milestone at https://github.com/coq/coq/milestone/15?closed=1). + Changes from 8.8.0 to 8.8.1 =========================== diff --git a/CODE_OF_CONDUCT.md b/CODE_OF_CONDUCT.md new file mode 100644 index 0000000000..8eee2009c9 --- /dev/null +++ b/CODE_OF_CONDUCT.md @@ -0,0 +1,118 @@ +# Coq Code of Conduct # + +The Coq development team and the user community are made up of a mixture of +professionals and volunteers from all over the world. +Diversity brings variety of perspectives that can be very valuable, but it can +also lead to communication issues and unhappiness. Therefore, we have a few +ground rules that we ask people to adhere to. +These rules apply equally to core developers (who should lead by example), +occasional contributors and those seeking help and guidance. +Their goal is that everyone feels safe and welcome when contributing to Coq or +interacting with others in Coq related forums. + +These rules apply to all spaces managed by the Coq development team. +This includes the GitHub repository, the mailing lists, the Gitter channel, +physical events like Coq working groups and workshops, and any other forums +created or managed by the development team which the community uses for +communication. In addition, violations of these rules outside these spaces may +affect a person's ability to participate within them. + +- **Be friendly and patient.** +- **Be welcoming.** + We strive to be a community that welcomes and supports people of all + backgrounds and identities. This includes, but is not limited to people of + any origin, color, status, educational level, gender identity, sexual + orientation, age, culture and beliefs, and mental and physical ability. +- **Be considerate.** + Your work will be used by other people, and you in turn will depend on the + work of others. Any decision you take will affect users and colleagues, and + you should take those consequences into account when making decisions. +- **Be respectful.** + Not all of us will agree all the time, but disagreement is no excuse for poor + behavior and poor manners. We might all experience some frustration now and + then, but we cannot allow that frustration to turn into a personal attack. + It's important to remember that a community where people feel uncomfortable + or threatened is not a productive one. Members of the Coq development team + and user community should be respectful when dealing with other members as + well as with people outside the community. +- **Be careful in the words that you choose.** + Be kind to others. Do not insult or put down other participants. Harassment + and other exclusionary behavior aren't acceptable. + * Violent language or threats or personal insults have no chance to + resolve a dispute or to let a discussion florish. Worse, they can + hurt durably, or generate durable fears. They are thus unwelcome. + * Not everyone is comfortable with sexually explicit or violent + material, even as a joke. In an online open multicultural world, you + don't know who might be listening. So be cautious and responsible + with your words. + * Discussions are online and recorded for posterity; we all have our + right for privacy and online gossiping as well as posting or threatening to + post other people's personally identifying information is prohibited. +- **Remember that what you write in a public online forum might be read by + many people you don't know.** + Consider what image your words will give to outsiders of the development + team / the user community as a whole. Try to avoid references to private + knowledge to be understandable by anyone. +- **Coq online forums are only to discuss Coq-related subjects.** + Unrelated political discussions or long digressions are unwelcome, + even for illustration or comparison purposes. +- **When we disagree, try to understand why.** + Disagreements, both social and technical, happen all the time and Coq is no + exception. It is important that we resolve disagreements and differing views + constructively. Remember that we are different. Different people + have different perspectives on issues. Being unable to understand why someone + holds a viewpoint doesn't mean that they're wrong. +- **It is human to make errors, and please try not to take things personally.** + Please do not answer aggressively to problematic behavior and simply + signal the issue. If actions have been taken with you (e.g. bans or simple + demands of apology, of rephrasing or keeping personal beliefs or troubles + private), please understand that they are not intended as aggression or + punishment ― even if you they feel harsh to you ― but as ways to enforce a + calm communication for the other participants and to give you the opportunity + to change your behavior. We understand you may feel hurt, or maybe you had a + bad day, so please take this opportunity to question yourself, cool down if + necessary and do not persist in the exact same behavior you have been + reported for. + +## Enforcement ## + +If you believe someone is violating the code of conduct, we ask that you report +it by emailing the Coq Code of Conduct enforcement team at +<coq-conduct@inria.fr>. Confidentiality with regard to the reporter of an +incident will be maintained while dealing with it. + +In particular, you should seek support from the team instead of dealing by +yourself with a behavior that you consider hurtful. This applies to members of +the enforcement team as well, who shouldn't deal by themselves with violations +in discussions in which they are a participant. + +Depending on the violation, the team can choose to address a private or public +warning to the offender, request an apology, or ban them for a short or a long +period from interacting on one or all of our forums. + +Except in case of serious violations, the team will always try a pedagogical +approach first (the offender does not necessarily realize immediately why their +behavior is wrong). We consider short bans to form part of the pedagogical +approach, especially when they come with explanatory comments, as this can give +some time to the offender to calm down and think about their actions. + +## Questions? ## + +If you have questions, feel free to write to <coq-conduct@inria.fr>. + +## Attribution ## + +This text is adapted from the [Django Code of Conduct][django-code-of-conduct] +which itself was adapted from the Speak Up! Community Code of Conduct. + +## License ## + +<a rel="license" href="http://creativecommons.org/licenses/by/4.0/"> +<img alt="Creative Commons License" style="border-width:0" src="https://i.creativecommons.org/l/by/4.0/88x31.png"> +</a><br> +This work is licensed under a +<a rel="license" href="http://creativecommons.org/licenses/by/4.0/"> +Creative Commons Attribution 4.0 International License +</a>. + +[django-code-of-conduct]: https://web.archive.org/web/20180714161115/https://www.djangoproject.com/conduct/ @@ -50,8 +50,6 @@ plugins/nsatz developed by Loïc Pottier (INRIA-Marelle, 2009-2011) plugins/omega developed by Pierre Crégut (France Telecom R&D, 1996) -plugins/quote - developed by Patrick Loiseleur (LRI, 1997-1999) plugins/romega developed by Pierre Crégut (France Telecom R&D, 2001-2004) plugins/rtauto diff --git a/META.coq.in b/META.coq.in index b2924e3241..a7bf08ec49 100644 --- a/META.coq.in +++ b/META.coq.in @@ -1,7 +1,7 @@ # TODO: Generate automatically with Dune description = "The Coq Proof Assistant Plugin API" -version = "8.9" +version = "8.10" directory = "" requires = "camlp5" @@ -9,7 +9,7 @@ requires = "camlp5" package "grammar" ( description = "Coq Camlp5 Grammar Extensions for Plugins" - version = "8.9" + version = "8.10" requires = "camlp5.gramlib" directory = "grammar" @@ -21,7 +21,7 @@ package "grammar" ( package "config" ( description = "Coq Configuration Variables" - version = "8.9" + version = "8.10" directory = "config" @@ -29,7 +29,7 @@ package "config" ( package "clib" ( description = "Base General Coq Library" - version = "8.9" + version = "8.10" directory = "clib" requires = "num, str, unix, threads" @@ -41,7 +41,7 @@ package "clib" ( package "lib" ( description = "Base Coq-Specific Library" - version = "8.9" + version = "8.10" directory = "lib" @@ -55,7 +55,7 @@ package "lib" ( package "vm" ( description = "Coq VM" - version = "8.9" + version = "8.10" directory = "kernel/byterun" @@ -74,7 +74,7 @@ package "vm" ( package "kernel" ( description = "Coq's Kernel" - version = "8.9" + version = "8.10" directory = "kernel" @@ -88,7 +88,7 @@ package "kernel" ( package "library" ( description = "Coq Libraries (vo) support" - version = "8.9" + version = "8.10" requires = "coq.kernel" @@ -102,7 +102,7 @@ package "library" ( package "engine" ( description = "Coq Tactic Engine" - version = "8.9" + version = "8.10" requires = "coq.library" directory = "engine" @@ -115,7 +115,7 @@ package "engine" ( package "pretyping" ( description = "Coq Pretyper" - version = "8.9" + version = "8.10" requires = "coq.engine" directory = "pretyping" @@ -128,7 +128,7 @@ package "pretyping" ( package "interp" ( description = "Coq Term Interpretation" - version = "8.9" + version = "8.10" requires = "coq.pretyping" directory = "interp" @@ -141,7 +141,7 @@ package "interp" ( package "proofs" ( description = "Coq Proof Engine" - version = "8.9" + version = "8.10" requires = "coq.interp" directory = "proofs" @@ -154,7 +154,7 @@ package "proofs" ( package "parsing" ( description = "Coq Parsing Engine" - version = "8.9" + version = "8.10" requires = "camlp5.gramlib, coq.proofs" directory = "parsing" @@ -167,7 +167,7 @@ package "parsing" ( package "printing" ( description = "Coq Printing Engine" - version = "8.9" + version = "8.10" requires = "coq.parsing" directory = "printing" @@ -180,7 +180,7 @@ package "printing" ( package "tactics" ( description = "Coq Basic Tactics" - version = "8.9" + version = "8.10" requires = "coq.printing" directory = "tactics" @@ -193,7 +193,7 @@ package "tactics" ( package "vernac" ( description = "Coq Vernacular Interpreter" - version = "8.9" + version = "8.10" requires = "coq.tactics" directory = "vernac" @@ -206,7 +206,7 @@ package "vernac" ( package "stm" ( description = "Coq State Transactional Machine" - version = "8.9" + version = "8.10" requires = "coq.vernac" directory = "stm" @@ -219,7 +219,7 @@ package "stm" ( package "toplevel" ( description = "Coq Toplevel" - version = "8.9" + version = "8.10" requires = "coq.stm" directory = "toplevel" @@ -232,7 +232,7 @@ package "toplevel" ( package "idetop" ( description = "Coq IDE Libraries" - version = "8.9" + version = "8.10" requires = "coq.toplevel" directory = "ide" @@ -246,7 +246,7 @@ package "idetop" ( package "ide" ( description = "Coq IDE Libraries" - version = "8.9" + version = "8.10" # XXX Add GTK requires = "coq.toplevel" @@ -260,14 +260,14 @@ package "ide" ( package "plugins" ( description = "Coq built-in plugins" - version = "8.9" + version = "8.10" directory = "plugins" package "ltac" ( description = "Coq LTAC Plugin" - version = "8.9" + version = "8.10" requires = "coq.stm" directory = "ltac" @@ -280,7 +280,7 @@ package "plugins" ( package "tauto" ( description = "Coq tauto plugin" - version = "8.9" + version = "8.10" requires = "coq.plugins.ltac" directory = "ltac" @@ -292,7 +292,7 @@ package "plugins" ( package "omega" ( description = "Coq omega plugin" - version = "8.9" + version = "8.10" requires = "coq.plugins.ltac" directory = "omega" @@ -304,7 +304,7 @@ package "plugins" ( package "romega" ( description = "Coq romega plugin" - version = "8.9" + version = "8.10" requires = "coq.plugins.omega" directory = "romega" @@ -316,7 +316,7 @@ package "plugins" ( package "micromega" ( description = "Coq micromega plugin" - version = "8.9" + version = "8.10" requires = "num,coq.plugins.ltac" directory = "micromega" @@ -325,24 +325,12 @@ package "plugins" ( archive(native) = "micromega_plugin.cmx" ) - package "quote" ( - - description = "Coq quote plugin" - version = "8.9" - - requires = "coq.plugins.ltac" - directory = "quote" - - archive(byte) = "quote_plugin.cmo" - archive(native) = "quote_plugin.cmx" - ) - package "newring" ( description = "Coq newring plugin" - version = "8.9" + version = "8.10" - requires = "coq.plugins.quote" + requires = "" directory = "setoid_ring" archive(byte) = "newring_plugin.cmo" @@ -352,7 +340,7 @@ package "plugins" ( package "extraction" ( description = "Coq extraction plugin" - version = "8.9" + version = "8.10" requires = "coq.plugins.ltac" directory = "extraction" @@ -364,7 +352,7 @@ package "plugins" ( package "cc" ( description = "Coq cc plugin" - version = "8.9" + version = "8.10" requires = "coq.plugins.ltac" directory = "cc" @@ -376,7 +364,7 @@ package "plugins" ( package "ground" ( description = "Coq ground plugin" - version = "8.9" + version = "8.10" requires = "coq.plugins.ltac" directory = "firstorder" @@ -388,7 +376,7 @@ package "plugins" ( package "rtauto" ( description = "Coq rtauto plugin" - version = "8.9" + version = "8.10" requires = "coq.plugins.ltac" directory = "rtauto" @@ -400,7 +388,7 @@ package "plugins" ( package "btauto" ( description = "Coq btauto plugin" - version = "8.9" + version = "8.10" requires = "coq.plugins.ltac" directory = "btauto" @@ -412,7 +400,7 @@ package "plugins" ( package "recdef" ( description = "Coq recdef plugin" - version = "8.9" + version = "8.10" requires = "coq.plugins.extraction" directory = "funind" @@ -424,7 +412,7 @@ package "plugins" ( package "nsatz" ( description = "Coq nsatz plugin" - version = "8.9" + version = "8.10" requires = "num,coq.plugins.ltac" directory = "nsatz" @@ -436,7 +424,7 @@ package "plugins" ( package "natsyntax" ( description = "Coq natsyntax plugin" - version = "8.9" + version = "8.10" requires = "" directory = "syntax" @@ -448,7 +436,7 @@ package "plugins" ( package "zsyntax" ( description = "Coq zsyntax plugin" - version = "8.9" + version = "8.10" requires = "" directory = "syntax" @@ -460,7 +448,7 @@ package "plugins" ( package "rsyntax" ( description = "Coq rsyntax plugin" - version = "8.9" + version = "8.10" requires = "" directory = "syntax" @@ -472,7 +460,7 @@ package "plugins" ( package "int31syntax" ( description = "Coq int31syntax plugin" - version = "8.9" + version = "8.10" requires = "" directory = "syntax" @@ -484,7 +472,7 @@ package "plugins" ( package "asciisyntax" ( description = "Coq asciisyntax plugin" - version = "8.9" + version = "8.10" requires = "" directory = "syntax" @@ -496,7 +484,7 @@ package "plugins" ( package "stringsyntax" ( description = "Coq stringsyntax plugin" - version = "8.9" + version = "8.10" requires = "coq.plugins.asciisyntax" directory = "syntax" @@ -508,7 +496,7 @@ package "plugins" ( package "derive" ( description = "Coq derive plugin" - version = "8.9" + version = "8.10" requires = "" directory = "derive" @@ -520,7 +508,7 @@ package "plugins" ( package "ssrmatching" ( description = "Coq ssrmatching plugin" - version = "8.9" + version = "8.10" requires = "coq.plugins.ltac" directory = "ssrmatching" @@ -532,7 +520,7 @@ package "plugins" ( package "ssreflect" ( description = "Coq ssreflect plugin" - version = "8.9" + version = "8.10" requires = "coq.plugins.ssrmatching" directory = "ssr" @@ -177,6 +177,9 @@ Makefile $(wildcard Makefile.*) config/Makefile : ; ########################################################################### camldevfiles: $(MERLINFILES) META.coq +# prevent submake dependency +META.coq.in $(MERLININFILES): ; + .merlin: .merlin.in cp -a "$<" "$@" @@ -199,7 +202,7 @@ cleankeepvo: indepclean clean-ide optclean cruftclean depclean docclean devdoccl objclean: archclean indepclean cruftclean: ml4clean - find . -name '*~' -o -name '*.annot' | xargs rm -f + find . \( -name '*~' -o -name '*.annot' \) -exec rm -f {} + rm -f gmon.out core camldevfilesclean: @@ -208,7 +211,7 @@ camldevfilesclean: indepclean: rm -f $(GENFILES) rm -f $(COQTOPBYTE) $(CHICKENBYTE) $(TOPBYTE) - find . \( -name '*~' -o -name '*.cm[ioat]' -o -name '*.cmti' \) -delete + find . \( -name '*~' -o -name '*.cm[ioat]' -o -name '*.cmti' \) -exec rm -f {} + rm -f */*.pp[iox] plugins/*/*.pp[iox] rm -rf $(SOURCEDOCDIR) rm -f toplevel/mltop.byteml toplevel/mltop.optml @@ -239,7 +242,7 @@ archclean: clean-ide optclean voclean optclean: rm -f $(COQTOPEXE) $(CHICKEN) $(TOPBINOPT) rm -f $(TOOLS) $(PRIVATEBINARIES) $(CSDPCERT) - find . -name '*.cmx' -o -name '*.cmx[as]' -o -name '*.[soa]' -o -name '*.so' | xargs rm -f + find . \( -name '*.cmx' -o -name '*.cmx[as]' -o -name '*.[soa]' -o -name '*.so' \) -exec rm -f {} + clean-ide: rm -f $(COQIDECMO) $(COQIDECMX) $(COQIDECMO:.cmo=.cmi) $(COQIDEBYTE) $(COQIDE) @@ -252,10 +255,10 @@ ml4clean: rm -f $(GENML4FILES) $(GENMLGFILES) depclean: - find . $(FIND_SKIP_DIRS) '(' -name '*.d' ')' -print | xargs rm -f + find . $(FIND_SKIP_DIRS) '(' -name '*.d' ')' -exec rm -f {} + cacheclean: - find theories plugins test-suite -name '.*.aux' -delete + find theories plugins test-suite -name '.*.aux' -exec rm -f {} + cleanconfig: rm -f config/Makefile config/coq_config.ml myocamlbuild_config.ml dev/ocamldebug-coq dev/camlp5.dbg config/Info-*.plist @@ -263,14 +266,18 @@ cleanconfig: distclean: clean cleanconfig cacheclean timingclean voclean: - find theories plugins test-suite \( -name '*.vo' -o -name '*.glob' -o -name "*.cmxs" -o -name "*.native" -o -name "*.cmx" -o -name "*.cmi" -o -name "*.o" \) -delete - find theories plugins test-suite -name .coq-native -empty -delete + find theories plugins test-suite \( -name '*.vo' -o -name '*.glob' -o -name "*.cmxs" \ + -o -name "*.native" -o -name "*.cmx" -o -name "*.cmi" -o -name "*.o" \) -exec rm -f {} + + find theories plugins test-suite -name .coq-native -empty -exec rm -f {} + timingclean: - find theories plugins test-suite \( -name '*.v.timing' -o -name '*.v.before-timing' -o -name "*.v.after-timing" -o -name "*.v.timing.diff" -o -name "time-of-build.log" -o -name "time-of-build-before.log" -o -name "time-of-build-after.log" -o -name "time-of-build-pretty.log" -o -name "time-of-build-both.log" \) -delete + find theories plugins test-suite \( -name '*.v.timing' -o -name '*.v.before-timing' \ + -o -name "*.v.after-timing" -o -name "*.v.timing.diff" -o -name "time-of-build.log" \ + -o -name "time-of-build-before.log" -o -name "time-of-build-after.log" \ + -o -name "time-of-build-pretty.log" -o -name "time-of-build-both.log" \) -exec rm -f {} + devdocclean: - find . -name '*.dep.ps' -o -name '*.dot' | xargs rm -f + find . \( -name '*.dep.ps' -o -name '*.dot' \) -exec rm -f {} + rm -f $(OCAMLDOCDIR)/*.log $(OCAMLDOCDIR)/*.aux $(OCAMLDOCDIR)/*.toc rm -f $(OCAMLDOCDIR)/ocamldoc.sty $(OCAMLDOCDIR)/coq.tex rm -f $(OCAMLDOCDIR)/html/*.html diff --git a/Makefile.common b/Makefile.common index 09457ced7b..69dea1d284 100644 --- a/Makefile.common +++ b/Makefile.common @@ -95,7 +95,7 @@ CORESRCDIRS:=\ tactics vernac stm toplevel PLUGINDIRS:=\ - omega romega micromega quote \ + omega romega micromega \ setoid_ring extraction \ cc funind firstorder derive \ rtauto nsatz syntax btauto \ @@ -131,7 +131,6 @@ GRAMMARCMA:=grammar/grammar.cma OMEGACMO:=plugins/omega/omega_plugin.cmo ROMEGACMO:=plugins/romega/romega_plugin.cmo MICROMEGACMO:=plugins/micromega/micromega_plugin.cmo -QUOTECMO:=plugins/quote/quote_plugin.cmo RINGCMO:=plugins/setoid_ring/newring_plugin.cmo NSATZCMO:=plugins/nsatz/nsatz_plugin.cmo EXTRACTIONCMO:=plugins/extraction/extraction_plugin.cmo @@ -152,7 +151,7 @@ SSRMATCHINGCMO:=plugins/ssrmatching/ssrmatching_plugin.cmo SSRCMO:=plugins/ssr/ssreflect_plugin.cmo PLUGINSCMO:=$(LTACCMO) $(OMEGACMO) $(ROMEGACMO) $(MICROMEGACMO) \ - $(QUOTECMO) $(RINGCMO) \ + $(RINGCMO) \ $(EXTRACTIONCMO) \ $(CCCMO) $(FOCMO) $(RTAUTOCMO) $(BTAUTOCMO) \ $(FUNINDCMO) $(NSATZCMO) $(SYNTAXCMO) \ diff --git a/Makefile.dev b/Makefile.dev index 7fc1076a8f..2a7e61126a 100644 --- a/Makefile.dev +++ b/Makefile.dev @@ -171,7 +171,6 @@ noreal: unicode logic arith bool zarith qarith lists sets fsets \ OMEGAVO:=$(filter plugins/omega/%, $(PLUGINSVO)) ROMEGAVO:=$(filter plugins/romega/%, $(PLUGINSVO)) MICROMEGAVO:=$(filter plugins/micromega/%, $(PLUGINSVO)) -QUOTEVO:=$(filter plugins/quote/%, $(PLUGINSVO)) RINGVO:=$(filter plugins/setoid_ring/%, $(PLUGINSVO)) NSATZVO:=$(filter plugins/nsatz/%, $(PLUGINSVO)) FUNINDVO:=$(filter plugins/funind/%, $(PLUGINSVO)) diff --git a/Makefile.doc b/Makefile.doc index 0dcf9daf27..788e4e61e7 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -58,17 +58,24 @@ ifndef QUICK SPHINX_DEPS := coq endif +# sphinx-html and sphinx-latex +sphinx-%: $(SPHINX_DEPS) + $(SHOW)'SPHINXBUILD doc/sphinx ($*)' + $(HIDE)$(SPHINXENV) $(SPHINXBUILD) -b $* \ + $(ALLSPHINXOPTS) doc/sphinx $(SPHINXBUILDDIR)/$* + +sphinx-pdf: sphinx-latex + +$(MAKE) -C $(SPHINXBUILDDIR)/latex + sphinx: $(SPHINX_DEPS) - $(SHOW)'SPHINXBUILD doc/sphinx' - $(HIDE)$(SPHINXENV) $(SPHINXBUILD) -b html $(ALLSPHINXOPTS) doc/sphinx $(SPHINXBUILDDIR)/html - @echo - @echo "Build finished. The HTML pages are in $(SPHINXBUILDDIR)/html." + +$(MAKE) sphinx-html + +$(MAKE) sphinx-pdf doc-html:\ - doc/stdlib/html/index.html sphinx + doc/stdlib/html/index.html sphinx-html doc-pdf:\ - doc/stdlib/Library.pdf + doc/stdlib/Library.pdf sphinx-pdf doc-ps:\ doc/stdlib/Library.ps @@ -181,7 +188,7 @@ install-doc-meta: $(MKDIR) $(FULLDOCDIR) $(INSTALLLIB) doc/LICENSE $(FULLDOCDIR)/LICENSE.doc -install-doc-html: install-doc-stdlib-html install-doc-sphinx +install-doc-html: install-doc-stdlib-html install-doc-sphinx-html install-doc-stdlib-html: $(MKDIR) $(FULLDOCDIR)/html/stdlib @@ -192,7 +199,7 @@ install-doc-printable: $(INSTALLLIB) doc/stdlib/Library.pdf $(FULLDOCDIR)/pdf $(INSTALLLIB) doc/stdlib/Library.ps $(FULLDOCDIR)/ps -install-doc-sphinx: +install-doc-sphinx-html: $(MKDIR) $(FULLDOCDIR)/sphinx (for f in `cd doc/sphinx/_build; find . -type f`; do \ $(MKDIR) $$(dirname $(FULLDOCDIR)/sphinx/$$f);\ diff --git a/Makefile.dune b/Makefile.dune index f90f555557..cac1bdd6a1 100644 --- a/Makefile.dune +++ b/Makefile.dune @@ -7,12 +7,17 @@ # DUNEOPT=--display=short BUILD_CONTEXT=_build/default +COQ_CONFIGURE_PREFIX?=_build/install/default + +export COQ_CONFIGURE_PREFIX help: @echo "Welcome to Coq's Dune-based build system. Targets are:" @echo " - states: build a minimal functional coqtop" @echo " - world: build all binaries and libraries" + @echo " - watch: build all binaries and libraries [continuous build]" @echo " - release: build Coq in release mode" + @echo " - apidoc: build ML API documentation" @echo " - clean: remove build directory and autogenerated files" @echo " - help: show this message" @@ -26,9 +31,18 @@ states: voboot world: voboot dune build $(DUNEOPT) @install +watch: voboot + dune build $(DUNEOPT) @install -w + release: voboot dune build $(DUNEOPT) -p coq +apidoc: + # Ugly workaround for https://github.com/ocaml/odoc/issues/148 + mv checker/dune checker/dune.disabled || true + dune build $(DUNEOPT) @doc + mv checker/dune.disabled checker/dune || true + clean: dune clean diff --git a/checker/cic.mli b/checker/cic.mli index 17259bb438..4162903b04 100644 --- a/checker/cic.mli +++ b/checker/cic.mli @@ -132,7 +132,7 @@ type delta_hint = type delta_resolver = ModPath.t MPmap.t * delta_hint KNmap.t -type 'a umap_t = 'a MPmap.t * 'a MBImap.t +type 'a umap_t = 'a MPmap.t type substitution = (ModPath.t * delta_resolver) umap_t (** {6 Delayed constr} *) diff --git a/checker/declarations.ml b/checker/declarations.ml index 0540227ccb..03fee1ab51 100644 --- a/checker/declarations.ml +++ b/checker/declarations.ml @@ -28,18 +28,13 @@ let empty_delta_resolver = Deltamap.empty module Umap = struct [@@@ocaml.warning "-32-34"] type 'a t = 'a umap_t - let empty = MPmap.empty, MBImap.empty - let is_empty (m1,m2) = MPmap.is_empty m1 && MBImap.is_empty m2 - let add_mbi mbi x (m1,m2) = (m1,MBImap.add mbi x m2) - let add_mp mp x (m1,m2) = (MPmap.add mp x m1, m2) - let find_mp mp map = MPmap.find mp (fst map) - let find_mbi mbi map = MBImap.find mbi (snd map) - let mem_mp mp map = MPmap.mem mp (fst map) - let mem_mbi mbi map = MBImap.mem mbi (snd map) - let iter_mbi f map = MBImap.iter f (snd map) - let fold fmp fmbi (m1,m2) i = - MPmap.fold fmp m1 (MBImap.fold fmbi m2 i) - let join map1 map2 = fold add_mp add_mbi map1 map2 + let empty = MPmap.empty + let is_empty m = MPmap.is_empty m + let add_mbi mbi x m = MPmap.add (MPbound mbi) x m + let add_mp mp x m = MPmap.add mp x m + let find = MPmap.find + let fold = MPmap.fold + let join map1 map2 = fold add_mp map1 map2 end type 'a subst_fun = substitution -> 'a -> 'a @@ -117,15 +112,10 @@ let constant_of_delta_with_inline resolve con = let subst_mp0 sub mp = (* 's like subst *) let rec aux mp = match mp with - | MPfile sid -> Umap.find_mp mp sub - | MPbound bid -> - begin - try Umap.find_mbi bid sub - with Not_found -> Umap.find_mp mp sub - end + | MPfile _ | MPbound _ -> Umap.find mp sub | MPdot (mp1,l) as mp2 -> begin - try Umap.find_mp mp2 sub + try Umap.find mp2 sub with Not_found -> let mp1',resolve = aux mp1 in MPdot (mp1',l),resolve @@ -382,9 +372,7 @@ let substition_prefixed_by k mp subst = Umap.add_mp new_key (mp_to,reso) sub else sub in - let mbi_prefixmp mbi _ sub = sub - in - Umap.fold mp_prefixmp mbi_prefixmp subst empty_subst + Umap.fold mp_prefixmp subst empty_subst let join subst1 subst2 = let apply_subst mpk add (mp,resolve) res = @@ -404,8 +392,7 @@ let join subst1 subst2 = Umap.join prefixed_subst (add (mp',resolve'') res) in let mp_apply_subst mp = apply_subst mp (Umap.add_mp mp) in - let mbi_apply_subst mbi = apply_subst (MPbound mbi) (Umap.add_mbi mbi) in - let subst = Umap.fold mp_apply_subst mbi_apply_subst subst1 empty_subst in + let subst = Umap.fold mp_apply_subst subst1 empty_subst in Umap.join subst2 subst let from_val x = { subst_value = x; subst_subst = []; } diff --git a/checker/values.ml b/checker/values.ml index e1b5a949ac..801874773a 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -15,7 +15,7 @@ To ensure this file is up-to-date, 'make' now compares the md5 of cic.mli with a copy we maintain here: -MD5 f7b267579138eabf86a74d6f2a7ed794 checker/cic.mli +MD5 a127e0c2322c7846914bbca9921309c7 checker/cic.mli *) @@ -185,10 +185,7 @@ let v_resolver = let v_mp_resolver = v_tuple "" [|v_mp;v_resolver|] let v_subst = - v_tuple "substitution" - [|v_map v_mp v_mp_resolver; - v_map v_uid v_mp_resolver|] - + Annot ("substitution", v_map v_mp v_mp_resolver) (** kernel/lazyconstr *) diff --git a/config/dune b/config/dune index 30faf1233e..cf2bc71363 100644 --- a/config/dune +++ b/config/dune @@ -9,5 +9,5 @@ (rule (targets coq_config.ml) (mode fallback) - (deps %{project_root}/configure.ml %{project_root}/dev/ocamldebug-coq.run) - (action (chdir %{project_root} (run %{ocaml} configure.ml -local -warn-error yes -native-compiler yes)))) + (deps %{project_root}/configure.ml %{project_root}/dev/ocamldebug-coq.run (env_var COQ_CONFIGURE_PREFIX)) + (action (chdir %{project_root} (run %{ocaml} configure.ml -native-compiler no)))) diff --git a/configure.ml b/configure.ml index 7e0fd4c8ac..1c2edefc5c 100644 --- a/configure.ml +++ b/configure.ml @@ -11,11 +11,11 @@ #load "str.cma" open Printf -let coq_version = "8.9+alpha" -let coq_macos_version = "8.8.90" (** "[...] should be a string comprised of +let coq_version = "8.10+alpha" +let coq_macos_version = "8.9.90" (** "[...] should be a string comprised of three non-negative, period-separated integers [...]" *) -let vo_magic = 8891 -let state_magic = 58891 +let vo_magic = 8991 +let state_magic = 58991 let distributed_exec = ["coqtop.opt"; "coqidetop.opt"; "coqqueryworker.opt"; "coqproofworker.opt"; "coqtacticworker.opt"; "coqc";"coqchk";"coqdoc";"coqworkmgr";"coq_makefile";"coq-tex";"coqwc";"csdpcert";"coqdep"] @@ -1038,7 +1038,16 @@ let find_suffix prefix path = match prefix with let do_one_instdir (var,msg,uservalue,selfcontainedlayout,unixlayout,locallayout) = let dir,suffix = if !prefs.local then (use_suffix coqtop locallayout,locallayout) - else match uservalue, !prefs.prefix with + else + let env_prefix = + match !prefs.prefix with + | None -> + begin + try Some (Sys.getenv "COQ_CONFIGURE_PREFIX") + with Not_found -> None + end + | p -> p + in match uservalue, env_prefix with | Some d, p -> d,find_suffix p d | _, Some p -> let suffix = if arch_is_win32 then selfcontainedlayout else relativize unixlayout in @@ -15,8 +15,12 @@ depends: [ "camlp5" ] +build-env: [ + [ COQ_CONFIGURE_PREFIX = "%{prefix}" ] +] + build: [ [ "dune" "build" "@vodeps" ] [ "dune" "exec" "coq_dune" "_build/default/.vfiles.d" ] - [ "dune" "build" "-p" package "-j" jobs ] + [ "dune" "build" "-p" name "-j" jobs ] ] diff --git a/default.nix b/default.nix index 80dca47f69..29c0c68174 100644 --- a/default.nix +++ b/default.nix @@ -23,8 +23,8 @@ { pkgs ? (import (fetchTarball { - url = "https://github.com/NixOS/nixpkgs/archive/4477cf04b6779a537cdb5f0bd3dd30e75aeb4a3b.tar.gz"; - sha256 = "1i39wsfwkvj9yryj8di3jibpdg3b3j86ych7s9rb6z79k08yaaxc"; + url = "https://github.com/NixOS/nixpkgs/archive/52a1179b6c20e923beddde1dd1e0034aa19176d2.tar.gz"; + sha256 = "040xrsgnip6gqljfyy1ad0l7q41h659h5hqbcn96bzhdiakcr4yc"; }) {}) , ocamlPackages ? pkgs.ocaml-ng.ocamlPackages_4_06 , buildIde ? true @@ -38,18 +38,6 @@ with pkgs; with stdenv.lib; -let dune = - overrideDerivation jbuilder (o: { - name = "dune-1.1.1"; - src = fetchFromGitHub { - owner = "ocaml"; - repo = "dune"; - rev = "1.1.1"; - sha256 = "0v2pnxpmqsvrvidpwxvbsypzhqfdnjs5crjp9y61qi8nyj8d75zw"; - }; - }); -in - stdenv.mkDerivation rec { name = "coq"; @@ -75,7 +63,7 @@ stdenv.mkDerivation rec { ++ [ ocamlPackages.ounit rsync which ] ) ++ optionals shell ( - [ jq curl git gnupg ] # Dependencies of the merging script + [ jq curl gitFull gnupg ] # Dependencies of the merging script ++ (with ocamlPackages; [ merlin ocp-indent ocp-index utop ]) # Dev tools ); diff --git a/dev/build/windows/MakeCoq_MinGW.bat b/dev/build/windows/MakeCoq_MinGW.bat index 5af0fcff3a..61cf6bc4cc 100755 --- a/dev/build/windows/MakeCoq_MinGW.bat +++ b/dev/build/windows/MakeCoq_MinGW.bat @@ -247,7 +247,7 @@ IF "%~0" == "-addon" ( IF NOT "%~0" == "" ( ECHO Install cygwin and download, compile and install OCaml and Coq for MinGW ECHO !!! Illegal parameter %~0 - ECHO Usage: + ECHO Usage: ECHO MakeCoq_MinGW CALL :PrintPars GOTO :EOF @@ -267,7 +267,6 @@ IF "%INSTALLMODE%" == "mingwincygwin" ( IF "%MAKEINSTALLER%" == "Y" ( SET INSTALLMODE=relocatable - SET INSTALLOCAML=Y ) REM ========== CONFIRM PARAMETERS ========== @@ -275,7 +274,7 @@ REM ========== CONFIRM PARAMETERS ========== CALL :PrintPars REM Note: DOS batch replaces variables on parsing, so one can't use a variable just set in an () block IF "%COQREGTESTING%"=="Y" (GOTO DontAsk) - SET /p ANSWER=Is this correct? y/n + SET /p ANSWER="Is this correct? y/n " IF NOT "%ANSWER%"=="y" (GOTO :EOF) :DontAsk @@ -315,12 +314,13 @@ ECHO RESULT INSTALL DIR (MINGW) = %RESULT_INSTALLDIR_MFMT% ECHO RESULT INSTALL DIR (CYGWIN) = %RESULT_INSTALLDIR_CFMT% REM WARNING: Add a space after the = in case you want set this to empty, otherwise the variable will be unset -SET MAKE_OPT=-j %MAKE_THREADS% +SET MAKE_OPT=-j %MAKE_THREADS% REM ========== DERIVED CYGWIN SETUP OPTIONS ========== -REM WARNING: Add a space after the = otherwise the variable will be unset -SET CYGWIN_OPT= +REM One can't set a variable to empty in DOS, but you can set it to a space this way. +REM The quotes are just there to make the space visible and to protect from "remove trailing spaces". +SET "CYGWIN_OPT= " IF "%CYGWIN_FROM_CACHE%" == "Y" ( SET CYGWIN_OPT= %CYGWIN_OPT% -L @@ -334,8 +334,6 @@ IF "%GTK_FROM_SOURCES%"=="N" ( SET CYGWIN_OPT= %CYGWIN_OPT% -P mingw64-%ARCH%-gtk2.0,mingw64-%ARCH%-gtksourceview2.0 ) -ECHO ========== INSTALL CYGWIN ========== - REM Cygwin setup sets proper ACLs (permissions) for folders it CREATES. REM Otherwise chmod won't work and e.g. the ocaml build will fail. REM Cygwin setup does not touch the ACLs of existing folders. @@ -349,7 +347,10 @@ IF EXIST "%CYGWIN_INSTALLDIR_WFMT%\etc\setup\installed.db" ( IF NOT "%CYGWIN_QUIET%" == "Y" ( SET RUNSETUP=Y ) + IF "%COQREGTESTING%" == "Y" ( + ECHO "========== REMOVE EXISTING CYGWIN ==========" + DEL /S /F /Q "%CYGWIN_INSTALLDIR_WFMT%" > NUL SET RUNSETUP=Y ) @@ -359,6 +360,8 @@ IF NOT "%APPVEYOR%" == "True" ( SET EXTRAPACKAGES=-P wget,curl,git,gcc-core,gcc-g++,automake1.5 ) +ECHO "========== INSTALL CYGWIN ==========" + IF "%RUNSETUP%"=="Y" ( %SETUP% ^ --proxy "%PROXY%" ^ @@ -436,10 +439,10 @@ ECHO ========== BATCH FUNCTIONS ========== ECHO -proxy ^<internet proxy^> ECHO -cygrepo ^<cygwin download repository^> ECHO -cygcache ^<local cygwin repository/cache^> - ECHO -cyglocal ^<Y or N^> install cygwin from cache + ECHO -cyglocal ^<Y or N^> install cygwin from cache ECHO -cygquiet ^<Y or N^> install cygwin without user interaction ECHO -srccache ^<local source code repository/cache^> - ECHO -coqver ^<Coq version to install^> + ECHO -coqver ^<Coq version to install^> ECHO -gtksrc ^<Y or N^> build GTK ^(90 min^) or use cygwin version ECHO -threads ^<1..N^> Number of make threads ECHO -addon ^<name^> Enable building selected addon (can be repeated) @@ -452,9 +455,9 @@ ECHO ========== BATCH FUNCTIONS ========== ECHO -ocaml = %INSTALLOCAML% ECHO -installer= %MAKEINSTALLER% ECHO -make = %INSTALLMAKE% - ECHO -destcyg = %DESTCYG% - ECHO -destcoq = %DESTCOQ% - ECHO -setup = %SETUP% + ECHO -destcyg = %DESTCYG% + ECHO -destcoq = %DESTCOQ% + ECHO -setup = %SETUP% ECHO -proxy = %PROXY% ECHO -cygrepo = %CYGWIN_REPOSITORY% ECHO -cygcache = %CYGWIN_LOCAL_CACHE_WFMT% diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index 8a49b97dac..23eb6fbc63 100644..100755 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -18,6 +18,8 @@ set -o nounset set -o errexit set -x +# Print current wall time as part of the xtrace +export PS4='+\t ' # Set this to 1 if all module directories shall be removed before build (no incremental make) RMDIR_BEFORE_BUILD=1 @@ -119,7 +121,11 @@ mkdir -p "$PREFIXCOQ/bin" mkdir -p "$PREFIXOCAML/bin" # This is required for building addons and plugins +# This must be CFMT (/cygdrive/c/...) otherwise coquelicot 3.0.2 configure fails. +# coquelicot uses which ${COQBIN}/coqc to check if coqc exists. This does not work with COQBIN in MFMT. export COQBIN=$RESULT_INSTALLDIR_CFMT/bin/ +# This must be MFMT (C:/) otherwise bignums 68a7a3d7e0b21985913a6c3ee12067f4c5ac4e20 fails +export COQLIB=$RESULT_INSTALLDIR_MFMT/lib/coq/ ###################### Copy Cygwin Setup Info ##################### @@ -145,27 +151,64 @@ LOGS=$(pwd)/buildlogs # The current log target (first part of the log file name) LOGTARGET=other -# Log command output - take log target name from command name (like log1 make => log target is "<module>-make") -log1() { - "$@" > >(tee "$LOGS/$LOGTARGET-$1.log" | sed -e "s/^/$LOGTARGET-$1.log: /") 2> >(tee "$LOGS/$LOGTARGET-$1.err" | sed -e "s/^/$LOGTARGET-$1.err: /" 1>&2) -} - -# Log command output - take log target name from command name and first argument (like log2 make install => log target is "<module>-make-install") -log2() { - "$@" > >(tee "$LOGS/$LOGTARGET-$1-$2.log" | sed -e "s/^/$LOGTARGET-$1-$2.log: /") 2> >(tee "$LOGS/$LOGTARGET-$1-$2.err" | sed -e "s/^/$LOGTARGET-$1-$2.err: /" 1>&2) -} - -# Log command output - take log target name from command name and second argument (like log_1_3 ocaml setup.ml -configure => log target is "<module>-ocaml--configure") -log_1_3() { - "$@" > >(tee "$LOGS/$LOGTARGET-$1-$3.log" | sed -e "s/^/$LOGTARGET-$1-$3.log: /") 2> >(tee "$LOGS/$LOGTARGET-$1-$3.err" | sed -e "s/^/$LOGTARGET-$1-$3.err: /" 1>&2) -} - -# Log command output - log target name is first argument (like logn untar tar xvaf ... => log target is "<module>-untar") -logn() { - LOGTARGETEX=$1 - shift - "$@" > >(tee "$LOGS/$LOGTARGET-$LOGTARGETEX.log" | sed -e "s/^/$LOGTARGET-$LOGTARGETEX.log: /") 2> >(tee "$LOGS/$LOGTARGET-$LOGTARGETEX.err" | sed -e "s/^/$LOGTARGET-$LOGTARGETEX.err: /" 1>&2) -} +# For an explanation of ${COQREGTESTING:-N} search for ${parameter:-word} in +# http://pubs.opengroup.org/onlinepubs/009695399/utilities/xcu_chap02.html + +if [ "${COQREGTESTING:-N}" == "Y" ] ; then + # If COQREGTESTING, log to log files only + # Log command output - take log target name from command name (like log1 make => log target is "<module>-make") + log1() { + { local -; set +x; } 2> /dev/null + "$@" >"$LOGS/$LOGTARGET-$1.log" 2>"$LOGS/$LOGTARGET-$1.err" + } + + # Log command output - take log target name from command name and first argument (like log2 make install => log target is "<module>-make-install") + log2() { + { local -; set +x; } 2> /dev/null + "$@" >"$LOGS/$LOGTARGET-$1-$2.log" 2>"$LOGS/$LOGTARGET-$1-$2.err" + } + + # Log command output - take log target name from command name and second argument (like log_1_3 ocaml setup.ml -configure => log target is "<module>-ocaml--configure") + log_1_3() { + { local -; set +x; } 2> /dev/null + "$@" >"$LOGS/$LOGTARGET-$1-$3.log" 2>"$LOGS/$LOGTARGET-$1-$3.err" + } + + # Log command output - log target name is first argument (like logn untar tar xvaf ... => log target is "<module>-untar") + logn() { + { local -; set +x; } 2> /dev/null + LOGTARGETEX=$1 + shift + "$@" >"$LOGS/$LOGTARGET-$LOGTARGETEX.log" 2>"$LOGS/$LOGTARGET-$LOGTARGETEX.err" + } +else + # If COQREGTESTING, log to log files and console + # Log command output - take log target name from command name (like log1 make => log target is "<module>-make") + log1() { + { local -; set +x; } 2> /dev/null + "$@" > >(tee "$LOGS/$LOGTARGET-$1.log" | sed -e "s/^/$LOGTARGET-$1.log: /") 2> >(tee "$LOGS/$LOGTARGET-$1.err" | sed -e "s/^/$LOGTARGET-$1.err: /" 1>&2) + } + + # Log command output - take log target name from command name and first argument (like log2 make install => log target is "<module>-make-install") + log2() { + { local -; set +x; } 2> /dev/null + "$@" > >(tee "$LOGS/$LOGTARGET-$1-$2.log" | sed -e "s/^/$LOGTARGET-$1-$2.log: /") 2> >(tee "$LOGS/$LOGTARGET-$1-$2.err" | sed -e "s/^/$LOGTARGET-$1-$2.err: /" 1>&2) + } + + # Log command output - take log target name from command name and second argument (like log_1_3 ocaml setup.ml -configure => log target is "<module>-ocaml--configure") + log_1_3() { + { local -; set +x; } 2> /dev/null + "$@" > >(tee "$LOGS/$LOGTARGET-$1-$3.log" | sed -e "s/^/$LOGTARGET-$1-$3.log: /") 2> >(tee "$LOGS/$LOGTARGET-$1-$3.err" | sed -e "s/^/$LOGTARGET-$1-$3.err: /" 1>&2) + } + + # Log command output - log target name is first argument (like logn untar tar xvaf ... => log target is "<module>-untar") + logn() { + { local -; set +x; } 2> /dev/null + LOGTARGETEX=$1 + shift + "$@" > >(tee "$LOGS/$LOGTARGET-$LOGTARGETEX.log" | sed -e "s/^/$LOGTARGET-$LOGTARGETEX.log: /") 2> >(tee "$LOGS/$LOGTARGET-$LOGTARGETEX.err" | sed -e "s/^/$LOGTARGET-$LOGTARGETEX.err: /" 1>&2) + } +fi ###################### 'UNFIX' SED ##################### @@ -229,7 +272,7 @@ function get_expand_source_tar { if [ -f "$SOURCE_LOCAL_CACHE_CFMT/$name.$3" ] ; then cp "$SOURCE_LOCAL_CACHE_CFMT/$name.$3" "$TARBALLS" else - wget "$1/$2.$3" + wget --progress=dot:giga "$1/$2.$3" if file -i "$2.$3" | grep text/html; then echo Download failed: "$1/$2.$3" echo The file wget downloaded is an html file: @@ -260,8 +303,8 @@ function get_expand_source_tar { if [ "$3" == "zip" ] ; then log1 unzip "$TARBALLS/$name.$3" if [ "$strip" == "1" ] ; then - # Ok, this is dirty, but it works and it fails if there are name clashes - mv -- */* . + # move subfolders of root folders one level up + find "$(ls)" -mindepth 1 -maxdepth 1 -exec mv -- "{}" . \; else echo "Unzip strip count not supported" return 1 @@ -314,13 +357,13 @@ function build_prep { fi # Check if build is already done - if [ ! -f "flagfiles/$name.finished" ] ; then + if [ ! -f "$FLAGFILES/$name.finished" ] ; then BUILD_PACKAGE_NAME=$name BUILD_OLDPATH=$PATH BUILD_OLDPWD=$(pwd) LOGTARGET=$name - touch "flagfiles/$name.started" + touch "$FLAGFILES/$name.started" get_expand_source_tar "$1" "$2" "$3" "$strip" "$name" @@ -344,9 +387,9 @@ function build_prep { # ------------------------------------------------------------------------------ function build_post { - if [ ! -f "flagfiles/$BUILD_PACKAGE_NAME.finished" ]; then + if [ ! -f "$FLAGFILES/$BUILD_PACKAGE_NAME.finished" ]; then cd "$BUILD_OLDPWD" - touch "flagfiles/$BUILD_PACKAGE_NAME.finished" + touch "$FLAGFILES/$BUILD_PACKAGE_NAME.finished" PATH=$BUILD_OLDPATH LOGTARGET=other fi @@ -384,19 +427,17 @@ function build_conf_make_inst { # Install all files given by a glob pattern to a given folder # # parameters -# $1 glob pattern (in '') -# $2 target folder +# $1 source path +# $2 pattern (in '') +# $3 target folder # ------------------------------------------------------------------------------ function install_glob { - # Check if any files matching the pattern exist - if [ "$(echo $1)" != "$1" ] ; then - # shellcheck disable=SC2086 - install -D -t $2 $1 - fi + SRCDIR=$(realpath -m $1) + DESTDIR=$(realpath -m $3) + ( cd "$SRCDIR" && find . -maxdepth 1 -type f -name "$2" -exec install -D -T "$SRCDIR"/{} "$DESTDIR"/{} \; ) } - # ------------------------------------------------------------------------------ # Recursively Install all files given by a glob pattern to a given folder # @@ -407,12 +448,15 @@ function install_glob { # ------------------------------------------------------------------------------ function install_rec { - ( cd "$1" && find . -type f -name "$2" -exec install -D -T "$1"/{} "$3"/{} \; ) + SRCDIR=$(realpath -m $1) + DESTDIR=$(realpath -m $3) + ( cd "$SRCDIR" && find . -type f -name "$2" -exec install -D -T "$SRCDIR"/{} "$DESTDIR"/{} \; ) } # ------------------------------------------------------------------------------ # Write a file list of the target folder # The file lists are used to create file lists for the windows installer +# Don't overwrite an existing file list # # parameters # $1 name of file list @@ -425,6 +469,19 @@ function list_files { } # ------------------------------------------------------------------------------ +# Write a file list of the target folder +# The file lists are used to create file lists for the windows installer +# Do overwrite an existing file list +# +# parameters +# $1 name of file list +# ------------------------------------------------------------------------------ + +function list_files_always { + ( cd "$PREFIXCOQ" && find . -type f | sort > /build/filelists/"$1" ) +} + +# ------------------------------------------------------------------------------ # Compute the set difference of two file lists # # parameters @@ -777,15 +834,15 @@ function make_flex_dll_link { # For this purpose hard links are better. function make_ln { - if [ ! -f flagfiles/myln.finished ] ; then - touch flagfiles/myln.started + if [ ! -f $FLAGFILES/myln.finished ] ; then + touch $FLAGFILES/myln.started mkdir -p myln ( cd myln cp $PATCHES/ln.c . "$TARGET_ARCH-gcc" -DUNICODE -D_UNICODE -DIGNORE_SYMBOLIC -mconsole -o ln.exe ln.c install -D ln.exe "$PREFIXCOQ/bin/ln.exe" ) - touch flagfiles/myln.finished + touch $FLAGFILES/myln.finished fi } @@ -848,7 +905,6 @@ function make_ocaml { function make_ocaml_tools { make_findlib - # make_menhir make_camlp5 } @@ -865,7 +921,7 @@ function make_ocaml_libs { function make_num { make_ocaml # We need this commit due to windows fixed, IMHO this is better than patching v1.1. - if build_prep https://github.com/ocaml/num/archive/ 7dd5e935aaa2b902585b3b2d0e55ad9b2442fff0 zip 1 num-1.1-7d; then + if build_prep https://github.com/ocaml/num/archive 7dd5e935aaa2b902585b3b2d0e55ad9b2442fff0 zip 1 num-1.1-7d; then log2 make all # log2 make test log2 make install @@ -874,17 +930,34 @@ function make_num { fi } +##### OCAMLBUILD ##### + +function make_ocamlbuild { + make_ocaml + if build_prep https://github.com/ocaml/ocamlbuild/archive 0.12.0 tar.gz 1 ocamlbuild-0.12.0; then + log2 make configure OCAML_NATIVE=true OCAMLBUILD_PREFIX=$PREFIXOCAML OCAMLBUILD_BINDIR=$PREFIXOCAML/bin OCAMLBUILD_LIBDIR=$PREFIXOCAML/lib + log1 make + log2 make install + build_post + fi +} + ##### FINDLIB Ocaml library manager ##### function make_findlib { make_ocaml - if build_prep https://opam.ocaml.org/archives ocamlfind.1.8.0+opam tar.gz 1 ; then + make_ocamlbuild + 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 log2 make all log2 make opt log2 make install log2 make clean + # Add Coq install library path to ocamlfind config file + # $(ocamlfind printconf conf | tr -d '\r') is the name of the config file + # printf "%q" "$PREFIXCOQ/lib" | sed -e 's/\\/\\\\/g' is the coq lib path double escaped for sed + sed -i -e 's|path="\(.*\)"|path="\1;'$(printf "%q" "$PREFIXCOQ/lib" | sed -e 's/\\/\\\\/g')'"|' $(ocamlfind printconf conf | tr -d '\r') build_post fi } @@ -894,15 +967,11 @@ function make_findlib { function make_menhir { make_ocaml make_findlib - # if build_prep http://gallium.inria.fr/~fpottier/menhir menhir-20151112 tar.gz 1 ; then - # For Ocaml 4.02 - # if build_prep http://gallium.inria.fr/~fpottier/menhir menhir-20151012 tar.gz 1 ; then - # For Ocaml 4.01 - if build_prep http://gallium.inria.fr/~fpottier/menhir menhir-20140422 tar.gz 1 ; then + make_ocamlbuild + if build_prep http://gallium.inria.fr/~fpottier/menhir menhir-20180530 tar.gz 1 ; then # Note: menhir doesn't support -j 8, so don't pass MAKE_OPT log2 make all PREFIX="$PREFIXOCAML" log2 make install PREFIX="$PREFIXOCAML" - mv "$PREFIXOCAML/bin/menhir" "$PREFIXOCAML/bin/menhir.exe" build_post fi } @@ -1085,13 +1154,13 @@ function copy_coq_dlls { function copy_coq_objects { # copy objects only from folders which exist in the target lib directory find . -type d | while read -r FOLDER ; do - if [ -e "$PREFIXCOQ/lib/$FOLDER" ] ; then - install_glob "$FOLDER"/'*.cmxa' "$PREFIXCOQ/lib/$FOLDER" - install_glob "$FOLDER"/'*.cmi' "$PREFIXCOQ/lib/$FOLDER" - install_glob "$FOLDER"/'*.cma' "$PREFIXCOQ/lib/$FOLDER" - install_glob "$FOLDER"/'*.cmo' "$PREFIXCOQ/lib/$FOLDER" - install_glob "$FOLDER"/'*.a' "$PREFIXCOQ/lib/$FOLDER" - install_glob "$FOLDER"/'*.o' "$PREFIXCOQ/lib/$FOLDER" + if [ -e "$PREFIXCOQ/lib/coq/$FOLDER" ] ; then + install_glob "$FOLDER" '*.cmxa' "$PREFIXCOQ/lib/coq/$FOLDER" + install_glob "$FOLDER" '*.cmi' "$PREFIXCOQ/lib/coq/$FOLDER" + install_glob "$FOLDER" '*.cma' "$PREFIXCOQ/lib/coq/$FOLDER" + install_glob "$FOLDER" '*.cmo' "$PREFIXCOQ/lib/coq/$FOLDER" + install_glob "$FOLDER" '*.a' "$PREFIXCOQ/lib/coq/$FOLDER" + install_glob "$FOLDER" '*.o' "$PREFIXCOQ/lib/coq/$FOLDER" fi done } @@ -1103,10 +1172,10 @@ function copq_coq_gtk { echo 'gtk-fallback-icon-theme = "Tango"' >> "$PREFIX/etc/gtk-2.0/gtkrc" if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then - install_glob "$PREFIX/etc/gtk-2.0/"'*' "$PREFIXCOQ/gtk-2.0" - install_glob "$PREFIX/share/gtksourceview-2.0/language-specs/"'*' "$PREFIXCOQ/share/gtksourceview-2.0/language-specs" - install_glob "$PREFIX/share/gtksourceview-2.0/styles/"'*' "$PREFIXCOQ/share/gtksourceview-2.0/styles" - install_rec "$PREFIX/share/themes/" '*' "$PREFIXCOQ/share/themes" + install_glob "$PREFIX/etc/gtk-2.0" '*' "$PREFIXCOQ/gtk-2.0" + install_glob "$PREFIX/share/gtksourceview-2.0/language-specs" '*' "$PREFIXCOQ/share/gtksourceview-2.0/language-specs" + install_glob "$PREFIX/share/gtksourceview-2.0/styles" '*' "$PREFIXCOQ/share/gtksourceview-2.0/styles" + install_rec "$PREFIX/share/themes" '*' "$PREFIXCOQ/share/themes" # This below item look like a bug in make install if [ -d "$PREFIXCOQ/share/coq/" ] ; then @@ -1136,7 +1205,7 @@ function copy_coq_license { install -D README.md "$PREFIXCOQ/license_readme/coq/ReadMe.md" install -D CHANGES "$PREFIXCOQ/license_readme/coq/Changes.txt" install -D INSTALL "$PREFIXCOQ/license_readme/coq/Install.txt" - install -D doc/README.md "$PREFIXCOQ/license_readme/coq/ReadMeDoc.md" + install -D doc/README.md "$PREFIXCOQ/license_readme/coq/ReadMeDoc.md" || true fi } @@ -1175,11 +1244,11 @@ function make_coq { then if [ "$INSTALLMODE" == "relocatable" ]; then # HACK: for relocatable builds, first configure with ./, then build but before install reconfigure with the real target path - ./configure -with-doc no -prefix ./ -libdir ./lib -mandir ./man + logn configure ./configure -with-doc no -prefix ./ -libdir ./lib/coq -mandir ./man elif [ "$INSTALLMODE" == "absolute" ]; then - ./configure -with-doc no -prefix "$PREFIXCOQ" -libdir "$PREFIXCOQ/lib" -mandir "$PREFIXCOQ/man" + logn configure ./configure -with-doc no -prefix "$PREFIXCOQ" -libdir "$PREFIXCOQ/lib/coq" -mandir "$PREFIXCOQ/man" else - ./configure -with-doc no -prefix "$PREFIXCOQ" + logn configure ./configure -with-doc no -prefix "$PREFIXCOQ" fi # The windows resource compiler binary name is hard coded @@ -1191,21 +1260,21 @@ function make_coq { log1 make else # shellcheck disable=SC2086 - make $MAKE_OPT + log1 make $MAKE_OPT fi if [ "$INSTALLMODE" == "relocatable" ]; then - ./configure -with-doc no -prefix "$PREFIXCOQ" -libdir "$PREFIXCOQ/lib" -mandir "$PREFIXCOQ/man" + logn reconfigure ./configure -with-doc no -prefix "$PREFIXCOQ" -libdir "$PREFIXCOQ/lib/coq" -mandir "$PREFIXCOQ/man" fi - make install - copy_coq_dlls + log2 make install + log1 copy_coq_dlls if [ "$INSTALLOCAML" == "Y" ]; then copy_coq_objects fi - copq_coq_gtk - copy_coq_license + log1 copq_coq_gtk + log1 copy_coq_license # make clean seems to be broken for 8.5pl2 # 1.) find | xargs fails on cygwin, can be fixed by sed -i 's|\| xargs rm -f|-exec rm -fv \{\} \+|' Makefile @@ -1213,8 +1282,8 @@ function make_coq { # make clean # Copy these files somewhere the plugin builds can find them - cp dev/ci/ci-basic-overlay.sh /build/ - cp -r dev/ci/user-overlays /build/ + logn copy-basic-overlays cp dev/ci/ci-basic-overlay.sh /build/ + logn copy-user-overlays cp -r dev/ci/user-overlays /build/ build_post fi @@ -1283,8 +1352,8 @@ function make_gcc { ##### Get sources for Cygwin MinGW packages ##### function get_cygwin_mingw_sources { - if [ ! -f flagfiles/cygwin_mingw_sources.finished ] ; then - touch flagfiles/cygwin_mingw_sources.started + if [ ! -f $FLAGFILES/cygwin_mingw_sources.finished ] ; then + touch $FLAGFILES/cygwin_mingw_sources.started # Find all installed files with mingw in the name and download the corresponding source code file from cygwin # Steps: @@ -1311,7 +1380,7 @@ function get_cygwin_mingw_sources { if [ -f "$SOURCE_LOCAL_CACHE_CFMT/$SOURCEFILE" ] ; then cp "$SOURCE_LOCAL_CACHE_CFMT/$SOURCEFILE" $TARBALLS else - wget "$CYGWIN_REPOSITORY/$SOURCE" + wget --progress=dot:giga "$CYGWIN_REPOSITORY/$SOURCE" mv "$SOURCEFILE" "$TARBALLS" # Save the source archive in the source cache if [ -d "$SOURCE_LOCAL_CACHE_CFMT" ] ; then @@ -1322,7 +1391,7 @@ function get_cygwin_mingw_sources { done - touch flagfiles/cygwin_mingw_sources.finished + touch $FLAGFILES/cygwin_mingw_sources.finished fi } @@ -1344,7 +1413,7 @@ function make_coq_installer { filter_files coq_objects coq '\.(cmxa|cmi|cma|cmo|a|o)$' # Filter out plugin object files - filter_files coq_objects_plugins coq_objects '/lib/plugins/.*\.(cmxa|cmi|cma|cmo|a|o)$' + filter_files coq_objects_plugins coq_objects '/lib/coq/plugins/.*\.(cmxa|cmi|cma|cmo|a|o)$' # Coq objects objects required for plugin development = coq objects except those for pre installed plugins diff_files coq_plugindev coq_objects coq_objects_plugins @@ -1460,6 +1529,8 @@ function make_addons { ###################### TOP LEVEL BUILD ##################### +ocamlfind list || true + make_sed make_ocaml make_ocaml_tools @@ -1477,7 +1548,7 @@ list_files ocaml_coq make_addons -list_files ocaml_coq_addons +list_files_always ocaml_coq_addons if [ "$MAKEINSTALLER" == "Y" ] ; then make_coq_installer diff --git a/dev/ci/README.md b/dev/ci/README.md index 95892ebe0a..3a179a9431 100644 --- a/dev/ci/README.md +++ b/dev/ci/README.md @@ -157,7 +157,7 @@ Currently available artifacts are: https://gitlab.com/coq/coq/-/jobs/artifacts/master/browse/_install_ci/?job=build:base Additionally, an experimental Dune build is provided: - https://gitlab.com/coq/coq/-/jobs/artifacts/master/browse/_build/?job=build:edge:dune + https://gitlab.com/coq/coq/-/jobs/artifacts/master/browse/_build/?job=build:edge:dune:dev - the Coq documentation, built in the `doc:*` jobs. When submitting a documentation PR, this can help reviewers checking the rendered result: @@ -167,7 +167,10 @@ Currently available artifacts are: + Coq's Standard Library Documentation [master branch] https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/_install_ci/share/doc/coq/html/stdlib/index.html?job=doc:refman + Coq's ML API Documentation [master branch] - https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/dev/ocamldoc/html/index.html?job=doc:ml-api + https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/dev/ocamldoc/html/index.html?job=doc:ml-api:ocamldoc + + The dune job also provides its own API documentation using the newer `odoc` tool: + https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/_build/default/_doc/_html/index.html?job=doc:ml-api:odoc ### GitLab and Windows diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index 7a649591dd..b04161918e 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,4 +1,4 @@ -# CACHEKEY: "bionic_coq-V2018-08-27-V2" +# CACHEKEY: "bionic_coq-V2018-09-23-V01" # ^^ Update when modifying this file. FROM ubuntu:bionic @@ -7,50 +7,65 @@ LABEL maintainer="e@x80.org" ENV DEBIAN_FRONTEND="noninteractive" RUN apt-get update -qq && apt-get install --no-install-recommends -y -qq \ - m4 automake autoconf time wget rsync git gcc-multilib opam \ + # Dependencies of the image, the test-suite and external projects + m4 automake autoconf time wget rsync git gcc-multilib build-essential unzip \ + # Dependencies of lablgtk (for CoqIDE) libgtk2.0-dev libgtksourceview2.0-dev \ - texlive-latex-extra texlive-fonts-recommended texlive-science tipa \ - python3-sphinx python3-pexpect python3-sphinx-rtd-theme python3-bs4 python3-sphinxcontrib.bibtex \ - python3-setuptools python3-wheel python3-pip + # Dependencies of stdlib and sphinx doc + texlive-latex-extra texlive-fonts-recommended texlive-xetex latexmk \ + xindy python3-pip python3-setuptools python3-pexpect python3-bs4 \ + # Dependencies of source-doc and coq-makefile + texlive-science tipa -RUN pip3 install antlr4-python3-runtime +# More dependencies of the sphinx doc +RUN pip3 install sphinx==1.7.8 sphinx_rtd_theme==0.2.5b2 \ + antlr4-python3-runtime==4.7.1 sphinxcontrib-bibtex==0.4.0 + +# We need to install OPAM 2.0 manually for now. +RUN wget https://github.com/ocaml/opam/releases/download/2.0.0/opam-2.0.0-x86_64-linux -O /usr/bin/opam && chmod 755 /usr/bin/opam # Basic OPAM setup ENV NJOBS="2" \ + OPAMJOBS="2" \ OPAMROOT=/root/.opamcache \ - OPAMROOTISOK="true" + OPAMROOTISOK="true" \ + OPAMYES="true" # Base opam is the set of base packages required by Coq ENV COMPILER="4.02.3" -RUN opam init -a -y -j $NJOBS --compiler="$COMPILER" default https://opam.ocaml.org && eval $(opam config env) && opam update - # Common OPAM packages. # `num` does not have a version number as the right version to install varies # with the compiler version. -ENV BASE_OPAM="num ocamlfind.1.8.0 dune.1.1.1 ounit.2.0.8" \ +ENV BASE_OPAM="num ocamlfind.1.8.0 dune.1.2.1 ounit.2.0.8" \ CI_OPAM="menhir.20180530 elpi.1.0.5 ocamlgraph.1.8.8" # BASE switch; CI_OPAM contains Coq's CI dependencies. ENV CAMLP5_VER="6.14" \ COQIDE_OPAM="lablgtk.2.18.5 conf-gtksourceview.2" -RUN opam switch -y -j $NJOBS "$COMPILER" && eval $(opam config env) && \ - opam install -j $NJOBS $BASE_OPAM camlp5.$CAMLP5_VER $COQIDE_OPAM $CI_OPAM +# The separate `opam install ocamlfind` workarounds an OPAM repository bug in 4.02.3 +RUN opam init -a --disable-sandboxing --compiler="$COMPILER" default https://opam.ocaml.org && eval $(opam env) && opam update && \ + opam install ocamlfind.1.8.0 && \ + opam install $BASE_OPAM camlp5.$CAMLP5_VER $COQIDE_OPAM $CI_OPAM # base+32bit switch -RUN opam switch -y -j $NJOBS "${COMPILER}+32bit" && eval $(opam config env) && \ - opam install -j $NJOBS $BASE_OPAM camlp5.$CAMLP5_VER +RUN opam switch create "${COMPILER}+32bit" && eval $(opam env) && \ + opam install ocamlfind.1.8.0 && \ + opam install $BASE_OPAM camlp5.$CAMLP5_VER # EDGE switch ENV COMPILER_EDGE="4.07.0" \ CAMLP5_VER_EDGE="7.06" \ - COQIDE_OPAM_EDGE="lablgtk.2.18.6 conf-gtksourceview.2" + COQIDE_OPAM_EDGE="lablgtk.2.18.6 conf-gtksourceview.2" \ + BASE_OPAM_EDGE="odoc.1.2.0 dune-release.0.3.0" -RUN opam switch -y -j $NJOBS $COMPILER_EDGE && eval $(opam config env) && \ - opam install -j $NJOBS $BASE_OPAM camlp5.$CAMLP5_VER_EDGE $COQIDE_OPAM_EDGE +RUN opam switch create $COMPILER_EDGE && eval $(opam env) && \ + opam install $BASE_OPAM $BASE_OPAM_EDGE camlp5.$CAMLP5_VER_EDGE $COQIDE_OPAM_EDGE # EDGE+flambda switch, we install CI_OPAM as to be able to use # `ci-template-flambda` with everything. -RUN opam switch -y -j $NJOBS "${COMPILER_EDGE}+flambda" && eval $(opam config env) && \ - opam install -j $NJOBS $BASE_OPAM camlp5.$CAMLP5_VER_EDGE $COQIDE_OPAM_EDGE $CI_OPAM +RUN opam switch create "${COMPILER_EDGE}+flambda" && eval $(opam env) && \ + opam install $BASE_OPAM $BASE_OPAM_EDGE camlp5.$CAMLP5_VER_EDGE $COQIDE_OPAM_EDGE $CI_OPAM + +RUN opam clean -a -c diff --git a/dev/ci/gitlab.bat b/dev/ci/gitlab.bat index 973319de68..31bd65af08 100644..100755 --- a/dev/ci/gitlab.bat +++ b/dev/ci/gitlab.bat @@ -2,6 +2,16 @@ REM This script builds and signs the Windows packages on Gitlab +ECHO "Start Time" +TIME /T + +REM List currently used cygwin and target folders for debugging / maintenance purposes + +ECHO "Currently used cygwin folders" +DIR C:\cygwin* +ECHO "Currently used target folders" +DIR C:\coq* + if %ARCH% == 32 ( SET ARCHLONG=i686 SET CYGROOT=C:\cygwin @@ -14,11 +24,15 @@ if %ARCH% == 64 ( SET SETUP=setup-x86_64.exe ) +SET DESTCOQ=C:\coq%ARCH%_inst + +CALL :MakeUniqueFolder %CYGROOT% CYGROOT +CALL :MakeUniqueFolder %DESTCOQ% DESTCOQ + powershell -Command "(New-Object Net.WebClient).DownloadFile('http://www.cygwin.com/%SETUP%', '%SETUP%')" SET CYGCACHE=%CYGROOT%\var\cache\setup SET CI_PROJECT_DIR_MFMT=%CI_PROJECT_DIR:\=/% SET CI_PROJECT_DIR_CFMT=%CI_PROJECT_DIR_MFMT:C:/=/cygdrive/c/% -SET DESTCOQ=C:\coq%ARCH%_inst SET COQREGTESTING=Y SET PATH=%PATH%;C:\Program Files\7-Zip\;C:\Program Files\Microsoft SDKs\Windows\v7.1\Bin @@ -29,10 +43,24 @@ call %CI_PROJECT_DIR%\dev\build\windows\MakeCoq_MinGW.bat -threads=1 ^ -arch=%ARCH% -installer=Y -coqver=%CI_PROJECT_DIR_CFMT% ^ -destcyg=%CYGROOT% -destcoq=%DESTCOQ% -cygcache=%CYGCACHE% ^ -addon="bignums ltac2 equations" -make=N ^ - -setup %CI_PROJECT_DIR%\%SETUP% || GOTO ErrorExit + -setup %CI_PROJECT_DIR%\%SETUP% || GOTO ErrorCopyLogFilesAndExit + + +ECHO "Start Artifact Creation" +TIME /T + +mkdir artifacts -copy "%CYGROOT%\build\coq-local\dev\nsis\*.exe" dev\nsis || GOTO ErrorExit -7z a coq-opensource-archive-windows-%ARCHLONG%.zip %CYGROOT%\build\tarballs\* || GOTO ErrorExit +CALL :CopyLogFiles + +copy "%CYGROOT%\build\coq-local\dev\nsis\*.exe" artifacts || GOTO ErrorExit +REM The open source archive is only required for release builds +IF DEFINED WIN_CERTIFICATE_PATH ( + 7z a artifacts\coq-opensource-archive-windows-%ARCHLONG%.zip %CYGROOT%\build\tarballs\* || GOTO ErrorExit +) ELSE ( + REM In non release builds, create a dummy file + ECHO "This is not a release build - open source archive not created / uploaded" > artifacts\coq-opensource-info.txt +) REM DO NOT echo the signing command below, as this would leak secrets in the logs IF DEFINED WIN_CERTIFICATE_PATH ( @@ -43,8 +71,49 @@ IF DEFINED WIN_CERTIFICATE_PATH ( ) ) +ECHO "Finished Artifact Creation" +TIME /T + +CALL :CleanupFolders + +ECHO "Finished Cleanup" +TIME /T + GOTO :EOF +:CopyLogFiles + ECHO Copy log files for artifact upload + MKDIR artifacts\buildlogs + COPY %CYGROOT%\build\buildlogs\* artifacts\buildlogs + MKDIR artifacts\filelists + COPY %CYGROOT%\build\filelists\* artifacts\filelists + MKDIR artifacts\flagfiles + COPY %CYGROOT%\build\flagfiles\* artifacts\flagfiles + GOTO :EOF + +:CleanupFolders + ECHO "Cleaning %CYGROOT%" + DEL /S /F /Q "%CYGROOT%" > NUL + ECHO "Cleaning %DESTCOQ%" + DEL /S /F /Q "%DESTCOQ%" > NUL + GOTO :EOF + +:MakeUniqueFolder + REM Create a uniquely named folder + REM This script is safe because folder creation is atomic - either we create it or fail + REM %1 = base path or directory (_%RANDOM%_%RANDOM% is appended to this) + REM %2 = name of the variable which receives the unique folder name + SET "UNIQUENAME=%1_%RANDOM%_%RANDOM%" + MKDIR "%UNIQUENAME%" + IF ERRORLEVEL 1 GOTO :MakeUniqueFolder + SET "%2=%UNIQUENAME%" + GOTO :EOF + +:ErrorCopyLogFilesAndExit + CALL :CopyLogFiles + REM fall through + :ErrorExit + CALL :CleanupFolders ECHO ERROR %0 failed EXIT /b 1 diff --git a/dev/ci/user-overlays/07257-herbelin-master+fix-yet-another-unif-dep-in-alphabet.sh b/dev/ci/user-overlays/07257-herbelin-master+fix-yet-another-unif-dep-in-alphabet.sh new file mode 100644 index 0000000000..019cb8054d --- /dev/null +++ b/dev/ci/user-overlays/07257-herbelin-master+fix-yet-another-unif-dep-in-alphabet.sh @@ -0,0 +1,4 @@ +if [ "$CI_PULL_REQUEST" = "7257" ] || [ "$CI_BRANCH" = "master+fix-yet-another-unif-dep-in-alphabet" ]; then + cross_crypto_CI_REF=master+fix-coq7257-ascii-sensitive-unification + cross_crypto_CI_GITURL=https://github.com/herbelin/cross-crypto +fi diff --git a/dev/ci/user-overlays/07288-herbelin-master+new-module-pretyping-id-management.sh b/dev/ci/user-overlays/07288-herbelin-master+new-module-pretyping-id-management.sh new file mode 100644 index 0000000000..3a6480a5a1 --- /dev/null +++ b/dev/ci/user-overlays/07288-herbelin-master+new-module-pretyping-id-management.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "7288" ] || [ "$CI_BRANCH" = "master+new-module-pretyping-id-management" ]; then + + ltac2_CI_BRANCH=master+globenv-coq-pr7288 + ltac2_CI_GITURL=https://github.com/herbelin/ltac2 + +fi diff --git a/dev/doc/changes.md b/dev/doc/changes.md index 1eea2443fe..4f3d793ed4 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -219,7 +219,7 @@ General deprecation Proof engine - Due to the introduction of `EConstr` in 8.7, it is not necessary to +- Due to the introduction of `EConstr` in 8.7, it is not necessary to track "goal evar normal form status" anymore, thus the type `'a Proofview.Goal.t` loses its ghost argument. This may introduce some minor incompatibilities at the typing level. Code-wise, things diff --git a/dev/doc/critical-bugs b/dev/doc/critical-bugs index 6166d24b70..8d78559c0d 100644 --- a/dev/doc/critical-bugs +++ b/dev/doc/critical-bugs @@ -109,6 +109,16 @@ Universes GH issue number: none risk: unlikely to be activated by chance + component: universe polymorphism + summary: universe polymorphism can capture global universes + impacted released versions: V8.5 to V8.8 + impacted coqchk versions: V8.5 to current (NOT FIXED) + fixed in: 2385b5c1ef + found by: Gaëtan Gilbert + exploit: test-suite/misc/poly-capture-global-univs + GH issue number: #8341 + risk: unlikely to be activated by chance (requires a plugin) + Primitive projections component: primitive projections, guard condition diff --git a/dev/doc/profiling.txt b/dev/doc/profiling.txt index b5dd8445db..45766293c7 100644 --- a/dev/doc/profiling.txt +++ b/dev/doc/profiling.txt @@ -21,6 +21,58 @@ and plug into the process perf record -g -p PID +### Per-component [flame graphs](https://github.com/brendangregg/FlameGraph) + +I (Andres Erbsen) have found it useful to look at library-wide flame graphs of +coq time consumption. As the Ltac interpreter stack is reflected in the OCaml +stack, calls to the same primitive can appear on top of multiple essentially +equivalent stacks. To make the profiles more readable, one could either try to +edit the stack trace to merge "equivalent" frames, or simply look at the +aggregate profile on a component-by-component basis. Here is how to do the +second for the standard library ([example output](https://cdn.rawgit.com/andres-erbsen/b29b29cb6480dfc6a662062e4fcd0ae3/raw/304fc3fea9630c8e453929aa7920ca8a2a570d0b/stdlib_categorized_outermost.svg)). + +~~~~~ +#!/bin/bash +make -f Makefile.dune clean +make -f Makefile.dune states +perf record -F99 `# ~1GB of data` --call-graph=dwarf -- make -f Makefile.dune world +perf script --time '0%-100%' | + stackcollapse-perf.pl | + grep Coqtop__compile | + sed -rf <(cat <<'EOF' + s/;caml/;/g + s/_[0-9]*;/;/g + s/Logic_monad__fun;//g + s/_apply[0-9];//g + s/;System/@&@/ + s/;Hashcons/@&@/ + s/;Grammar/@&@/ + s/;Declaremods/@&@/ + s/;Tactics/@&@/ + s/;Pretyping/@&@/ + s/;Typeops/@&@/ + s/;Reduction/@&@/ + s/;Unification/@&@/ + s/;Evarutil/@&@/ + s/;Evd/@&@/ + s/;EConstr/@&@/ + s/;Constr/@&@/ + s/;Univ/@&@/ + s/;Ugraph/@&@/ + s/;UState/@&@/ + s/;Micromega/@&@/ + s/;Omega/@&@/ + s/;Auto/@&@/ + s/;Ltac_plugin__Tacinterp/@&@/ + s/;Ltac_plugin__Rewrite/@&@/ + s/[^@]*@;([^@]*)@/\1;\1/ + s/@//g + :a; s/;([^;]+);\1;/;\1;/g;ta +EOF + ) | + flamegraph.pl +~~~~~ + ## Memory You first need a few commits atop trunk for this to work. diff --git a/dev/vm_printers.ml b/dev/vm_printers.ml index 98190b05b5..47cfeb98d7 100644 --- a/dev/vm_printers.ml +++ b/dev/vm_printers.ml @@ -2,7 +2,6 @@ open Format open Term open Constr open Names -open Cbytecodes open Cemitcodes open Vmvalues diff --git a/doc/README.md b/doc/README.md index 47507de52d..1461fa2e2c 100644 --- a/doc/README.md +++ b/doc/README.md @@ -28,18 +28,18 @@ To produce the complete documentation in HTML, you will need Coq dependencies listed in [`INSTALL`](../INSTALL). Additionally, the Sphinx-based reference manual requires Python 3, and the following Python packages: - sphinx sphinx_rtd_theme beautifulsoup4 antlr4-python3-runtime pexpect sphinxcontrib-bibtex + - sphinx >= 1.7.8 + - sphinx_rtd_theme >= 0.2.5b2 + - beautifulsoup4 >= 4.0.6 + - antlr4-python3-runtime >= 4.7.1 + - pexpect >= 4.2.1 + - sphinxcontrib-bibtex >= 0.4.0 -You can install them using `pip3 install` or using your distribution's package -manager. E.g. under recent Debian-based operating systems (Debian 10 "Buster", -Ubuntu 18.04, ...) you can use: +To install them, you should first install pip and setuptools (for instance, +with `apt install python3-pip python3-setuptools` on Debian / Ubuntu) then run: - apt install python3-sphinx python3-pexpect python3-sphinx-rtd-theme \ - python3-bs4 python3-sphinxcontrib.bibtex python3-pip - -Then, install the missing Python3 Antlr4 package: - - pip3 install antlr4-python3-runtime + pip3 install sphinx sphinx_rtd_theme beautifulsoup4 antlr4-python3-runtime \ + pexpect sphinxcontrib-bibtex Nix users should get the correct development environment to build the HTML documentation from Coq's [`default.nix`](../default.nix) (note this @@ -54,10 +54,19 @@ additional tools are required: - pdflatex - dvips - makeindex + - xelatex + - latexmk + - xindy + +All of them are part of the TexLive distribution. E.g. on Debian / Ubuntu, +install them with: + + apt install texlive-full -Install them using your package manager. E.g. on Debian / Ubuntu: +Or if you want to use less disk space: - apt install texlive-latex-extra texlive-fonts-recommended + apt install texlive-latex-extra texlive-fonts-recommended texlive-xetex \ + latexmk xindy Compilation ----------- @@ -80,7 +89,7 @@ Alternatively, you can use some specific targets: to produce all HTML documents - `make sphinx` - to produce the HTML version of the reference manual + to produce the HTML and PDF versions of the reference manual - `make stdlib` to produce all formats of the Coq standard library @@ -94,7 +103,7 @@ to avoid treating Sphinx warnings as errors. Otherwise, Sphinx quits upon detecting the first warning. You can set this on the Sphinx `make` command line or as an environment variable: -- `make sphinx SPINXWARNERROR=0` +- `make sphinx SPHINXWARNERROR=0` - ~~~ export SPHINXWARNERROR=0 diff --git a/doc/sphinx/README.rst b/doc/sphinx/README.rst index 4673107e3d..904945a58d 100644 --- a/doc/sphinx/README.rst +++ b/doc/sphinx/README.rst @@ -114,15 +114,24 @@ Here is the list of all objects of the Coq domain (The symbol :black_nib: indica Raised if :n:`@tactic` does not fully solve the goal. -``.. opt::`` :black_nib: A Coq option. +``.. flag::`` :black_nib: A Coq flag (i.e. a boolean setting). Example:: - .. opt:: Nonrecursive Elimination Schemes + .. flag:: Nonrecursive Elimination Schemes - This option controls whether types declared with the keywords - :cmd:`Variant` and :cmd:`Record` get an automatic declaration of the + Controls whether types declared with the keywords + :cmd:`Variant` and :cmd:`Record` get an automatic declaration of induction principles. +``.. opt::`` :black_nib: A Coq option (a setting with non-boolean value, e.g. a string or numeric value). + Example:: + + .. opt:: Hyps Limit @num + :name Hyps Limit + + Controls the maximum number of hypotheses displayed in goals after + 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 @@ -141,6 +150,14 @@ Here is the list of all objects of the Coq domain (The symbol :black_nib: indica .. prodn:: term += let: @pattern := @term in @term .. prodn:: occ_switch ::= { {? + %| - } {* @num } } +``.. table::`` :black_nib: A Coq table, i.e. a setting that is a set of values. + Example:: + + .. table:: Search Blacklist @string + :name: Search Blacklist + + Controls ... + ``.. tacn::`` :black_nib: A tactic, or a tactic notation. Example:: @@ -260,8 +277,8 @@ In addition to the objects above, the ``coqrst`` Sphinx plugin defines the follo .. inference:: name - newline-separated premisses - ------------------------ + newline-separated premises + -------------------------- conclusion Example:: @@ -274,14 +291,12 @@ In addition to the objects above, the ``coqrst`` Sphinx plugin defines the follo ----------------------------- \WTEG{\forall~x:T,U}{\Prop} -``.. preamble::`` A reST directive for hidden math. - Mostly useful to let MathJax know about `\def`\ s and `\newcommand`\ s. - - Example:: +``.. preamble::`` A reST directive to include a TeX file. + Mostly useful to let MathJax know about `\def`s and `\newcommand`s. - .. preamble:: + Usage:: - \newcommand{\paren}[#1]{\left(#1\right)} + .. preamble:: preamble.tex Coq roles ========= @@ -364,6 +379,32 @@ DON'T This is equivalent to ``Axiom`` :token`ident` : :token:`term`. +.. + +DO + .. code:: + + :n:`power_tac @term [@ltac]` + allows :tacn:`ring` and :tacn:`ring_simplify` to recognize … + +DON'T + .. code:: + + power_tac :n:`@term` [:n:`@ltac`] + allows :tacn:`ring` and :tacn:`ring_simplify` to recognize … + +.. + +DO + .. code:: + + :n:`name={*; attr}` + +DON'T + .. code:: + + ``name=``:n:`{*; attr}` + Omitting annotations -------------------- @@ -377,6 +418,86 @@ DON'T .. tacv:: assert form as intro_pattern +Using the ``.. coqtop::`` directive for syntax highlighting +----------------------------------------------------------- + +DO + .. code:: + + A tactic of the form: + + .. coqdoc:: + + do [ t1 | … | tn ]. + + is equivalent to the standard Ltac expression: + + .. coqdoc:: + + first [ t1 | … | tn ]. + +DON'T + .. code:: + + A tactic of the form: + + .. coqtop:: in + + do [ t1 | … | tn ]. + + is equivalent to the standard Ltac expression: + + .. coqtop:: in + + first [ t1 | … | tn ]. + +Overusing plain quotes +---------------------- + +DO + .. code:: + + The :tacn:`refine` tactic can raise the :exn:`Invalid argument` exception. + The term :g:`let a = 1 in a a` is ill-typed. + +DON'T + .. code:: + + The ``refine`` tactic can raise the ``Invalid argument`` exception. + The term ``let a = 1 in a a`` is ill-typed. + +Plain quotes produce plain text, without highlighting or cross-references. + +Overusing the ``example`` directive +----------------------------------- + +DO + .. code:: + + Here is a useful axiom: + + .. coqdoc:: + + Axiom proof_irrelevance : forall (P : Prop) (x y : P), x=y. + +DO + .. code:: + + .. example:: Using proof-irrelevance + + If you assume the axiom above, … + +DON'T + .. code:: + + Here is a useful axiom: + + .. example:: + + .. coqdoc:: + + Axiom proof_irrelevance : forall (P : Prop) (x y : P), x=y. + Tips and tricks =============== @@ -398,7 +519,7 @@ Add either ``undo`` to the first block or ``reset`` to the second block to avoid Abbreviations and macros ------------------------ -Abbreviations and placeholders for specially-formatted names (like ``|Cic|``, ``|Coq|``, ``|CoqIDE|``, ``|Ltac|``, and ``|Gallina|``) are defined in a `separate file </doc/sphinx/replaces.rst>`_ included by most chapters of the manual. Some useful LaTeX macros are defined in `</doc/sphinx/preamble.rst>`_. +Substitutions for specially-formatted names (like ``|Cic|``, ``|Coq|``, ``|CoqIDE|``, ``|Ltac|``, and ``|Gallina|``), along with some useful LaTeX macros, are defined in a `separate file </doc/sphinx/refman-preamble.rst>`_. This file is automatically included in all manual pages. Emacs ----- diff --git a/doc/sphinx/README.template.rst b/doc/sphinx/README.template.rst index c333d6e9d5..86914a71df 100644 --- a/doc/sphinx/README.template.rst +++ b/doc/sphinx/README.template.rst @@ -140,6 +140,32 @@ DON'T This is equivalent to ``Axiom`` :token`ident` : :token:`term`. +.. + +DO + .. code:: + + :n:`power_tac @term [@ltac]` + allows :tacn:`ring` and :tacn:`ring_simplify` to recognize … + +DON'T + .. code:: + + power_tac :n:`@term` [:n:`@ltac`] + allows :tacn:`ring` and :tacn:`ring_simplify` to recognize … + +.. + +DO + .. code:: + + :n:`name={*; attr}` + +DON'T + .. code:: + + ``name=``:n:`{*; attr}` + Omitting annotations -------------------- @@ -153,6 +179,86 @@ DON'T .. tacv:: assert form as intro_pattern +Using the ``.. coqtop::`` directive for syntax highlighting +----------------------------------------------------------- + +DO + .. code:: + + A tactic of the form: + + .. coqdoc:: + + do [ t1 | … | tn ]. + + is equivalent to the standard Ltac expression: + + .. coqdoc:: + + first [ t1 | … | tn ]. + +DON'T + .. code:: + + A tactic of the form: + + .. coqtop:: in + + do [ t1 | … | tn ]. + + is equivalent to the standard Ltac expression: + + .. coqtop:: in + + first [ t1 | … | tn ]. + +Overusing plain quotes +---------------------- + +DO + .. code:: + + The :tacn:`refine` tactic can raise the :exn:`Invalid argument` exception. + The term :g:`let a = 1 in a a` is ill-typed. + +DON'T + .. code:: + + The ``refine`` tactic can raise the ``Invalid argument`` exception. + The term ``let a = 1 in a a`` is ill-typed. + +Plain quotes produce plain text, without highlighting or cross-references. + +Overusing the ``example`` directive +----------------------------------- + +DO + .. code:: + + Here is a useful axiom: + + .. coqdoc:: + + Axiom proof_irrelevance : forall (P : Prop) (x y : P), x=y. + +DO + .. code:: + + .. example:: Using proof-irrelevance + + If you assume the axiom above, … + +DON'T + .. code:: + + Here is a useful axiom: + + .. example:: + + .. coqdoc:: + + Axiom proof_irrelevance : forall (P : Prop) (x y : P), x=y. + Tips and tricks =============== @@ -174,7 +280,7 @@ Add either ``undo`` to the first block or ``reset`` to the second block to avoid Abbreviations and macros ------------------------ -Abbreviations and placeholders for specially-formatted names (like ``|Cic|``, ``|Coq|``, ``|CoqIDE|``, ``|Ltac|``, and ``|Gallina|``) are defined in a `separate file </doc/sphinx/replaces.rst>`_ included by most chapters of the manual. Some useful LaTeX macros are defined in `</doc/sphinx/preamble.rst>`_. +Substitutions for specially-formatted names (like ``|Cic|``, ``|Coq|``, ``|CoqIDE|``, ``|Ltac|``, and ``|Gallina|``), along with some useful LaTeX macros, are defined in a `separate file </doc/sphinx/refman-preamble.rst>`_. This file is automatically included in all manual pages. Emacs ----- diff --git a/doc/sphinx/addendum/canonical-structures.rst b/doc/sphinx/addendum/canonical-structures.rst index 2cc1f95c08..3e414a714c 100644 --- a/doc/sphinx/addendum/canonical-structures.rst +++ b/doc/sphinx/addendum/canonical-structures.rst @@ -1,4 +1,3 @@ -.. include:: ../replaces.rst .. _canonicalstructures: Canonical Structures diff --git a/doc/sphinx/addendum/extended-pattern-matching.rst b/doc/sphinx/addendum/extended-pattern-matching.rst index e507a224c6..cb267576b2 100644 --- a/doc/sphinx/addendum/extended-pattern-matching.rst +++ b/doc/sphinx/addendum/extended-pattern-matching.rst @@ -1,15 +1,13 @@ -.. include:: ../replaces.rst - .. _extendedpatternmatching: -Extended pattern-matching +Extended pattern matching ========================= :Authors: Cristina Cornes and Hugo Herbelin .. TODO links to figures -This section describes the full form of pattern-matching in |Coq| terms. +This section describes the full form of pattern matching in |Coq| terms. .. |rhs| replace:: right hand sides @@ -38,7 +36,7 @@ same values as ``pattern`` does and ``identifier`` is bound to the matched value. A pattern of the form :n:`pattern | pattern` is called disjunctive. A list of patterns separated with commas is also considered as a pattern and is called *multiple pattern*. However multiple patterns can only -occur at the root of pattern-matching equations. Disjunctions of +occur at the root of pattern matching equations. Disjunctions of *multiple patterns* are allowed though. Since extended ``match`` expressions are compiled into the primitive ones, @@ -46,7 +44,7 @@ the expressiveness of the theory remains the same. Once parsing has finished only simple patterns remain. The original nesting of the ``match`` expressions is recovered at printing time. An easy way to see the result of the expansion is to toggle off the nesting performed at printing -(use here :opt:`Printing Matching`), then by printing the term with :cmd:`Print` +(use here :flag:`Printing Matching`), then by printing the term with :cmd:`Print` if the term is a constant, or using the command :cmd:`Check`. The extended ``match`` still accepts an optional *elimination predicate* @@ -88,7 +86,7 @@ Using multiple patterns in the definition of ``max`` lets us write: which will be compiled into the previous form. -The pattern-matching compilation strategy examines patterns from left +The pattern matching compilation strategy examines patterns from left to right. A match expression is generated **only** when there is at least one constructor in the column of patterns. E.g. the following example does not build a match expression. @@ -262,9 +260,9 @@ When we use parameters in patterns there is an error message: | cons A _ l' => l' end). -.. opt:: Asymmetric Patterns +.. flag:: Asymmetric Patterns -This option (off by default) removes parameters from constructors in patterns: + This flag (off by default) removes parameters from constructors in patterns: .. coqtop:: all @@ -597,7 +595,7 @@ situation: incorrect (because constructors are not applied to the correct number of the arguments, because they are not linear or they are wrongly typed). -.. exn:: Non exhaustive pattern-matching. +.. exn:: Non exhaustive pattern matching. The pattern matching is not exhaustive. diff --git a/doc/sphinx/addendum/extraction.rst b/doc/sphinx/addendum/extraction.rst index e3d25cf5cf..3d58f522dd 100644 --- a/doc/sphinx/addendum/extraction.rst +++ b/doc/sphinx/addendum/extraction.rst @@ -1,5 +1,3 @@ -.. include:: ../replaces.rst - .. _extraction: Extraction of programs in |OCaml| and Haskell @@ -131,14 +129,14 @@ order to produce more readable code. The type-preserving optimizations are controlled by the following |Coq| options: -.. opt:: Extraction Optimize +.. flag:: Extraction Optimize Default is on. This controls all type-preserving optimizations made on the ML terms (mostly reduction of dummy beta/iota redexes, but also simplifications on Cases, etc). Turn this option off if you want a ML term as close as possible to the Coq term. -.. opt:: Extraction Conservative Types +.. flag:: Extraction Conservative Types Default is off. This controls the non type-preserving optimizations made on ML terms (which try to avoid function abstraction of dummy @@ -146,7 +144,7 @@ The type-preserving optimizations are controlled by the following |Coq| options: implies that ``e':t'`` where ``e'`` and ``t'`` are the extracted code of ``e`` and ``t`` respectively. -.. opt:: Extraction KeepSingleton +.. flag:: Extraction KeepSingleton Default is off. Normally, when the extraction of an inductive type produces a singleton type (i.e. a type with only one constructor, and @@ -155,7 +153,7 @@ The type-preserving optimizations are controlled by the following |Coq| options: The typical example is ``sig``. This option allows disabling this optimization when one wishes to preserve the inductive structure of types. -.. opt:: Extraction AutoInline +.. flag:: Extraction AutoInline Default is on. The extraction mechanism inlines the bodies of some defined constants, according to some heuristics @@ -227,7 +225,7 @@ When an actual extraction takes place, an error is normally raised if the if any of the implicit arguments still occurs in the final code. This behavior can be relaxed via the following option: -.. opt:: Extraction SafeImplicits +.. flag:: Extraction SafeImplicits Default is on. When this option is off, a warning is emitted instead of an error if some implicit arguments still occur in the @@ -319,15 +317,15 @@ native boolean type instead of the |Coq| one. The syntax is the following: extractions for the type itself (first `string`) and all its constructors (all the `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. + pattern matching of the language will be used. .. cmdv:: Extract Inductive @qualid => @string [ {+ @string } ] @string Same as before, with a final extra `string` that indicates how to - perform pattern-matching over this inductive type. In this form, + perform pattern matching over this inductive type. In this form, the ML extraction could be an arbitrary type. For an inductive type with `k` constructors, the function used to - emulate the pattern-matching should expect `(k+1)` arguments, first the `k` + emulate the pattern matching should expect `(k+1)` arguments, first the `k` branches in functional form, and then the inductive element to destruct. For instance, the match branch ``| S n => foo`` gives the functional form ``(fun n -> foo)``. Note that a constructor with no @@ -344,7 +342,7 @@ native boolean type instead of the |Coq| one. The syntax is the following: * Extracting an inductive type to a pre-existing ML inductive type is quite sound. But extracting to a general type (by providing an - ad-hoc pattern-matching) will often **not** be fully rigorously + ad-hoc pattern matching) will often **not** be fully rigorously correct. For instance, when extracting ``nat`` to |OCaml| ``int``, it is theoretically possible to build ``nat`` values that are larger than |OCaml| ``max_int``. It is the user's responsibility to diff --git a/doc/sphinx/addendum/generalized-rewriting.rst b/doc/sphinx/addendum/generalized-rewriting.rst index e0babb6c4e..403b163196 100644 --- a/doc/sphinx/addendum/generalized-rewriting.rst +++ b/doc/sphinx/addendum/generalized-rewriting.rst @@ -1,6 +1,3 @@ -.. include:: ../preamble.rst -.. include:: ../replaces.rst - .. _generalizedrewriting: Generalized rewriting @@ -126,10 +123,10 @@ parameters is any term :math:`f \, t_1 \ldots t_n`. .. coqtop:: in - forall (A : Type) (S1 S1’ S2 S2’ : list A), - set_eq A S1 S1’ -> - set_eq A S2 S2’ -> - set_eq A (union A S1 S2) (union A S1’ S2’). + forall (A: Type) (S1 S1' S2 S2': list A), + set_eq A S1 S1' -> + set_eq A S2 S2' -> + set_eq A (union A S1 S2) (union A S1' S2'). The signature of the function ``union A`` is ``set_eq A ==> set_eq A ==> set_eq A`` for all ``A``. @@ -451,7 +448,7 @@ various combinations of properties on relations and morphisms are represented as records and instances of theses classes are put in a hint database. For example, the declaration: -.. coqtop:: in +.. coqdoc:: Add Parametric Relation (x1 : T1) ... (xn : Tn) : (A t1 ... tn) (Aeq t′1 ... t′m) [reflexivity proved by refl] @@ -462,7 +459,7 @@ hint database. For example, the declaration: is equivalent to an instance declaration: -.. coqtop:: in +.. coqdoc:: Instance (x1 : T1) ... (xn : Tn) => id : @Equivalence (A t1 ... tn) (Aeq t′1 ... t′m) := [Equivalence_Reflexive := refl] diff --git a/doc/sphinx/addendum/implicit-coercions.rst b/doc/sphinx/addendum/implicit-coercions.rst index c0c4539564..fc5a366caf 100644 --- a/doc/sphinx/addendum/implicit-coercions.rst +++ b/doc/sphinx/addendum/implicit-coercions.rst @@ -1,5 +1,3 @@ -.. include:: ../replaces.rst - .. _implicitcoercions: Implicit Coercions @@ -256,19 +254,16 @@ Displaying Available Coercions Activating the Printing of Coercions ------------------------------------- -.. opt:: Printing Coercions +.. flag:: Printing Coercions When on, this option forces all the coercions to be printed. By default, coercions are not printed. -.. cmd:: Add Printing Coercion @qualid - - This command forces coercion denoted by :n:`@qualid` to be printed. - By default, a coercion is never printed. - -.. cmd:: Remove Printing Coercion @qualid +.. table:: Printing Coercion @qualid + :name: Printing Coercion - Use this command, to skip the printing of coercion :n:`@qualid`. + Specifies a set of qualids for which coercions are always displayed. Use the + :cmd:`Add @table` and :cmd:`Remove @table` commands to update the set of qualids. .. _coercions-classes-as-records: @@ -315,7 +310,7 @@ are also forgotten. Coercions and Modules --------------------- -.. opt:: Automatic Coercions Import +.. flag:: Automatic Coercions Import Since |Coq| version 8.3, the coercions present in a module are activated only when the module is explicitly imported. Formerly, the coercions @@ -325,6 +320,12 @@ Coercions and Modules This option makes it possible to recover the behavior of the versions of |Coq| prior to 8.3. +.. warn:: Coercion used but not in scope: @qualid. If you want to use this coercion, please Import the module that contains it. + + This warning is emitted when typechecking relies on a coercion + contained in a module that has not been explicitely imported. It helps + migrating code and stop relying on the option above. + Examples -------- diff --git a/doc/sphinx/addendum/miscellaneous-extensions.rst b/doc/sphinx/addendum/miscellaneous-extensions.rst index 0f2d35d044..2cde65dcdc 100644 --- a/doc/sphinx/addendum/miscellaneous-extensions.rst +++ b/doc/sphinx/addendum/miscellaneous-extensions.rst @@ -1,5 +1,3 @@ -.. include:: ../replaces.rst - .. _miscellaneousextensions: Miscellaneous extensions diff --git a/doc/sphinx/addendum/nsatz.rst b/doc/sphinx/addendum/nsatz.rst index 9adeca46fc..e7a8c238ac 100644 --- a/doc/sphinx/addendum/nsatz.rst +++ b/doc/sphinx/addendum/nsatz.rst @@ -1,5 +1,3 @@ -.. include:: ../preamble.rst - .. _nsatz_chapter: Nsatz: tactics for proving equalities in integral domains diff --git a/doc/sphinx/addendum/omega.rst b/doc/sphinx/addendum/omega.rst index 1e92d01125..828505b850 100644 --- a/doc/sphinx/addendum/omega.rst +++ b/doc/sphinx/addendum/omega.rst @@ -26,7 +26,9 @@ Description of ``omega`` .. tacv:: romega :name: romega - To be documented. + .. deprecated:: 8.9 + + Use :tacn:`lia` instead. Arithmetical goals recognized by ``omega`` ------------------------------------------ @@ -114,23 +116,23 @@ loaded by Options ------- -.. opt:: Stable Omega +.. flag:: Stable Omega .. deprecated:: 8.5 This deprecated option (on by default) is for compatibility with Coq pre 8.5. It resets internal name counters to make executions of :tacn:`omega` independent. -.. opt:: Omega UseLocalDefs +.. flag:: Omega UseLocalDefs This option (on by default) allows :tacn:`omega` to use the bodies of local variables. -.. opt:: Omega System +.. flag:: Omega System This option (off by default) activate the printing of debug information -.. opt:: Omega Action +.. flag:: Omega Action This option (off by default) activate the printing of debug information diff --git a/doc/sphinx/addendum/parallel-proof-processing.rst b/doc/sphinx/addendum/parallel-proof-processing.rst index 8ee8f52227..8b7214e2ab 100644 --- a/doc/sphinx/addendum/parallel-proof-processing.rst +++ b/doc/sphinx/addendum/parallel-proof-processing.rst @@ -1,5 +1,3 @@ -.. include:: ../replaces.rst - .. _asynchronousandparallelproofprocessing: Asynchronous and Parallel Proof Processing @@ -60,7 +58,7 @@ variables used. Automatic suggestion of proof annotations ````````````````````````````````````````` -The command ``Set Suggest Proof Using`` makes |Coq| suggest, when a ``Qed`` +The flag :flag:`Suggest Proof Using` makes |Coq| suggest, when a ``Qed`` command is processed, a correct proof annotation. It is up to the user to modify the proof script accordingly. diff --git a/doc/sphinx/addendum/program.rst b/doc/sphinx/addendum/program.rst index d6895f5fe5..fad45995d2 100644 --- a/doc/sphinx/addendum/program.rst +++ b/doc/sphinx/addendum/program.rst @@ -1,6 +1,3 @@ -.. include:: ../preamble.rst -.. include:: ../replaces.rst - .. this should be just "_program", but refs to it don't work .. _programs: @@ -45,7 +42,7 @@ be considered as an object of type :g:`{x : T | P}` for any well-formed will generate an obligation for every such coercion. In the other direction, Russell will automatically insert a projection. -Another distinction is the treatment of pattern-matching. Apart from +Another distinction is the treatment of pattern matching. Apart from the following differences, it is equivalent to the standard match operation (see :ref:`extendedpatternmatching`). @@ -84,15 +81,15 @@ operation (see :ref:`extendedpatternmatching`). There are options to control the generation of equalities and coercions. -.. opt:: Program Cases +.. flag:: Program Cases - This controls the special treatment of pattern-matching generating equalities + This controls the special treatment of pattern matching generating equalities and disequalities when using |Program| (it is on by default). All pattern-matches and let-patterns are handled using the standard algorithm of |Coq| (see :ref:`extendedpatternmatching`) when this option is deactivated. -.. opt:: Program Generalized Coercion +.. flag:: Program Generalized Coercion This controls the coercion of general inductive types when using |Program| (the option is on by default). Coercion of subset types and pairs is still @@ -105,7 +102,7 @@ Syntactic control over equalities To give more control over the generation of equalities, the type checker will fall back directly to |Coq|’s usual typing of dependent -pattern-matching if a return or in clause is specified. Likewise, the +pattern matching if a return or in clause is specified. Likewise, the if construct is not treated specially by |Program| so boolean tests in the code are not automatically reflected in the obligations. One can use the :g:`dec` combinator to get the correct hypotheses as in: @@ -213,7 +210,7 @@ with mutually recursive definitions too. end. Here we have one obligation for each branch (branches for :g:`0` and -``(S 0)`` are automatically generated by the pattern-matching +``(S 0)`` are automatically generated by the pattern matching compilation algorithm). .. coqtop:: all @@ -320,19 +317,19 @@ optional tactic is replaced by the default one if not specified. Shows the term that will be fed to the kernel once the obligations are solved. Useful for debugging. -.. opt:: Transparent Obligations +.. flag:: Transparent Obligations Controls whether all obligations should be declared as transparent (the default), or if the system should infer which obligations can be declared opaque. -.. opt:: Hide Obligations +.. flag:: Hide Obligations Controls whether obligations appearing in the term should be hidden as implicit arguments of the special constantProgram.Tactics.obligation. -.. opt:: Shrink Obligations +.. flag:: Shrink Obligations *Deprecated since 8.7* @@ -378,6 +375,3 @@ Frequently Asked Questions using lazy evaluation; #. Mutual recursion on the underlying inductive type isn’t possible anymore, but nested mutual recursion is always possible. - -.. bibliography:: ../biblio.bib - :keyprefix: p- diff --git a/doc/sphinx/addendum/ring.rst b/doc/sphinx/addendum/ring.rst index 8cb86e2267..58617916c0 100644 --- a/doc/sphinx/addendum/ring.rst +++ b/doc/sphinx/addendum/ring.rst @@ -1,11 +1,9 @@ -.. include:: ../replaces.rst .. |ra| replace:: :math:`\rightarrow_{\beta\delta\iota}` .. |la| replace:: :math:`\leftarrow_{\beta\delta\iota}` .. |eq| replace:: `=`:sub:`(by the main correctness theorem)` .. |re| replace:: ``(PEeval`` `v` `ap`\ ``)`` .. |le| replace:: ``(Pphi_dev`` `v` ``(norm`` `ap`\ ``))`` - .. _theringandfieldtacticfamilies: The ring and field tactic families diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index ab4b4a9824..369dae0ead 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -1,5 +1,3 @@ -.. include:: ../replaces.rst - .. _typeclasses: Type Classes @@ -458,7 +456,7 @@ This is equivalent to ``Hint Transparent, Opaque ident : typeclass_instances``. Options ~~~~~~~ -.. opt:: Typeclasses Dependency Order +.. flag:: Typeclasses Dependency Order This option (on by default since 8.6) respects the dependency order between subgoals, meaning that subgoals on which other subgoals depend @@ -467,7 +465,7 @@ Options quite different performance behaviors of proof search. -.. opt:: Typeclasses Filtered Unification +.. flag:: Typeclasses Filtered Unification This option, available since Coq 8.6 and off by default, switches the hint application procedure to a filter-then-unify strategy. To apply a @@ -481,7 +479,7 @@ Options where there is a hole in that place. -.. opt:: Typeclasses Limit Intros +.. flag:: Typeclasses Limit Intros This option (on by default) controls the ability to apply hints while avoiding (functional) eta-expansions in the generated proof term. It @@ -495,7 +493,7 @@ Options status of the product introduction rule, resulting in potentially more expensive proof-search (i.e. more useless backtracking). -.. opt:: Typeclass Resolution For Conversion +.. flag:: Typeclass Resolution For Conversion This option (on by default) controls the use of typeclass resolution when a unification problem cannot be solved during elaboration/type @@ -503,7 +501,7 @@ Options resolution is tried before launching unification once again. -.. opt:: Typeclasses Strict Resolution +.. flag:: Typeclasses Strict Resolution Typeclass declarations introduced when this option is set have a stricter resolution behavior (the option is off by default). When @@ -513,28 +511,33 @@ Options instantiated. -.. opt:: Typeclasses Unique Solutions +.. flag:: Typeclasses Unique Solutions When a typeclass resolution is launched we ensure that it has a single solution or fail. This ensures that the resolution is canonical, but can make proof search much more expensive. -.. opt:: Typeclasses Unique Instances +.. flag:: Typeclasses Unique Instances Typeclass declarations introduced when this option is set have a more efficient resolution behavior (the option is off by default). When a solution to the typeclass goal of this class is found, we never backtrack on it, assuming that it is canonical. -.. opt:: Typeclasses Debug {? Verbosity @num} +.. flag:: Typeclasses Debug + + Controls whether typeclass resolution steps are shown during search. Setting this flag + also sets :opt:`Typeclasses Debug Verbosity` to 1. + +.. opt:: Typeclasses Debug Verbosity @num + :name: Typeclasses Debug Verbosity - These options allow to see the resolution steps of typeclasses that are - performed during search. The ``Debug`` option is synonymous to ``Debug - Verbosity 1``, and ``Debug Verbosity 2`` provides more information - (tried tactics, shelving of goals, etc…). + Determines how much information is shown for typeclass resolution steps during search. + 1 is the default level. 2 shows additional information such as tried tactics and shelving + of goals. Setting this option also sets :flag:`Typeclasses Debug`. -.. opt:: Refine Instance Mode +.. flag:: Refine Instance Mode This option allows to switch the behavior of instance declarations made through the Instance command. diff --git a/doc/sphinx/addendum/universe-polymorphism.rst b/doc/sphinx/addendum/universe-polymorphism.rst index 7e77dea457..41afe3c312 100644 --- a/doc/sphinx/addendum/universe-polymorphism.rst +++ b/doc/sphinx/addendum/universe-polymorphism.rst @@ -1,5 +1,3 @@ -.. include:: ../replaces.rst - .. _polymorphicuniverses: Polymorphic Universes @@ -59,7 +57,7 @@ so: Definition selfpid := pidentity (@pidentity). Of course, the two instances of :g:`pidentity` in this definition are -different. This can be seen when the :opt:`Printing Universes` option is on: +different. This can be seen when the :flag:`Printing Universes` flag is on: .. coqtop:: none @@ -79,7 +77,7 @@ levels. When printing :g:`pidentity`, we can see the universes it binds in the annotation :g:`@{Top.2}`. Additionally, when -:opt:`Printing Universes` is on we print the "universe context" of +:flag:`Printing Universes` is on we print the "universe context" of :g:`pidentity` consisting of the bound universes and the constraints they must verify (for :g:`pidentity` there are no constraints). @@ -129,14 +127,14 @@ Polymorphic, Monomorphic As shown in the examples, polymorphic definitions and inductives can be declared using the ``Polymorphic`` prefix. -.. opt:: Universe Polymorphism +.. flag:: Universe Polymorphism Once enabled, this option will implicitly prepend ``Polymorphic`` to any definition of the user. .. cmd:: Monomorphic @definition - When the :opt:`Universe Polymorphism` option is set, to make a definition + When the :flag:`Universe Polymorphism` option is set, to make a definition producing global universe constraints, one can use the ``Monomorphic`` prefix. Many other commands support the ``Polymorphic`` flag, including: @@ -169,7 +167,7 @@ declared cumulative using the :g:`Cumulative` prefix. Declares the inductive as cumulative -Alternatively, there is an option :opt:`Polymorphic Inductive +Alternatively, there is a flag :flag:`Polymorphic Inductive Cumulativity` which when set, makes all subsequent *polymorphic* inductive definitions cumulative. When set, inductive types and the like can be enforced to be non-cumulative using the :g:`NonCumulative` @@ -179,7 +177,7 @@ prefix. Declares the inductive as non-cumulative -.. opt:: Polymorphic Inductive Cumulativity +.. flag:: Polymorphic Inductive Cumulativity When this option is on, it sets all following polymorphic inductive types as cumulative (it is off by default). @@ -229,7 +227,7 @@ Cumulative inductive types, coninductive types, variants and records only make sense when they are universe polymorphic. Therefore, an error is issued whenever the user uses the :g:`Cumulative` or :g:`NonCumulative` prefix in a monomorphic context. -Notice that this is not the case for the option :opt:`Polymorphic Inductive Cumulativity`. +Notice that this is not the case for the option :flag:`Polymorphic Inductive Cumulativity`. That is, this option, when set, makes all subsequent *polymorphic* inductive declarations cumulative (unless, of course the :g:`NonCumulative` prefix is used) but has no effect on *monomorphic* inductive declarations. @@ -277,18 +275,18 @@ An example of a proof using cumulativity Cumulativity Weak Constraints ----------------------------- -.. opt:: Cumulativity Weak Constraints +.. flag:: Cumulativity Weak Constraints -This option, on by default, causes "weak" constraints to be produced -when comparing universes in an irrelevant position. Processing weak -constraints is delayed until minimization time. A weak constraint -between `u` and `v` when neither is smaller than the other and -one is flexible causes them to be unified. Otherwise the constraint is -silently discarded. + When set, which is the default, causes "weak" constraints to be produced + when comparing universes in an irrelevant position. Processing weak + constraints is delayed until minimization time. A weak constraint + between `u` and `v` when neither is smaller than the other and + one is flexible causes them to be unified. Otherwise the constraint is + silently discarded. -This heuristic is experimental and may change in future versions. -Disabling weak constraints is more predictable but may produce -arbitrary numbers of universes. + This heuristic is experimental and may change in future versions. + Disabling weak constraints is more predictable but may produce + arbitrary numbers of universes. Global and local universes @@ -354,9 +352,9 @@ This minimization process is applied only to fresh universe variables. It simply adds an equation between the variable and its lower bound if it is an atomic universe (i.e. not an algebraic max() universe). -.. opt:: Universe Minimization ToSet +.. flag:: Universe Minimization ToSet - Turning this option off (it is on by default) disallows minimization + Turning this flag off (it is on by default) disallows minimization to the sort :g:`Set` and only collapses floating universes between themselves. @@ -436,7 +434,7 @@ underscore or by omitting the annotation to a polymorphic definition. Check le@{k _}. Check le. -.. opt:: Strict Universe Declaration. +.. flag:: Strict Universe Declaration Turning this option off allows one to freely use identifiers for universes without declaring them first, with the diff --git a/doc/sphinx/biblio.bib b/doc/sphinx/biblio.bib index c74d8f540c..aa8537c92d 100644 --- a/doc/sphinx/biblio.bib +++ b/doc/sphinx/biblio.bib @@ -121,7 +121,7 @@ s}, volume = {7998}, editor = {Sandrine Blazy and Christine Paulin and David Pichardie }, series = {LNCS }, - doi = {10.1007/978-3-642-39634-2\_5 }, + doi = {10.1007/978-3-642-39634-2_5}, year = {2013}, } @@ -136,7 +136,7 @@ s}, pages = {85--95}, month = {November}, year = {2000}, - url = {http://www.lirmm.fr/\%7Edelahaye/papers/ltac\%20(LPAR\%2700).pdf} + url = {http://www.lirmm.fr/%7Edelahaye/papers/ltac%20(LPAR%2700).pdf} } @Article{Dyc92, diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py index 8127d3df3f..b43d5fb6f0 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -24,6 +24,8 @@ import sys import os +from shutil import copyfile +import sphinx # Increase recursion limit for sphinx sys.setrecursionlimit(1500) @@ -36,6 +38,12 @@ sys.path.append(os.path.abspath('../../config/')) import coq_config +# -- Prolog --------------------------------------------------------------- + +# Include substitution definitions in all files +with open("refman-preamble.rst") as s: + rst_prolog = s.read() + # -- General configuration ------------------------------------------------ # If your documentation needs a minimal Sphinx version, state it here. @@ -66,11 +74,39 @@ source_suffix = '.rst' # The encoding of source files. #source_encoding = 'utf-8-sig' +# Add extra cases here to support more formats + +SUPPORTED_FORMATS = ["html", "latex"] + +def readbin(fname): + try: + with open(fname, mode="rb") as f: + return f.read() + except FileNotFoundError: + return None + +def copy_formatspecific_files(app): + ext = ".{}.rst".format(app.builder.name) + for fname in sorted(os.listdir(app.srcdir)): + if fname.endswith(ext): + src = os.path.join(app.srcdir, fname) + dst = os.path.join(app.srcdir, fname[:-len(ext)] + ".rst") + logger = sphinx.util.logging.getLogger(__name__) + if readbin(src) == readbin(dst): + logger.info("Skipping {}: {} is up to date".format(src, dst)) + else: + logger.info("Copying {} to {}".format(src, dst)) + copyfile(src, dst) + +def setup(app): + app.connect('builder-inited', copy_formatspecific_files) + # The master toctree document. -master_doc = 'index' +# We create this file in `copy_master_doc` above. +master_doc = "index" # General information about the project. -project = 'Coq' +project = 'The Coq Reference Manual' copyright = '1999-2018, Inria' author = 'The Coq Development Team' @@ -104,9 +140,10 @@ exclude_patterns = [ 'Thumbs.db', '.DS_Store', 'introduction.rst', + 'refman-preamble.rst', 'README.rst', 'README.template.rst' -] +] + ["*.{}.rst".format(fmt) for fmt in SUPPORTED_FORMATS] # The reST default role (used for this markup: `text`) to use for all # documents. @@ -129,6 +166,7 @@ primary_domain = 'coq' # The name of the Pygments (syntax highlighting) style to use. pygments_style = 'sphinx' highlight_language = 'text' +suppress_warnings = ["misc.highlighting_failure"] # A list of ignored prefixes for module index sorting. #modindex_common_prefix = [] @@ -257,57 +295,57 @@ smartquotes = False ########################### # Set things up for XeTeX # ########################### + latex_elements = { 'babel': '', 'fontenc': '', 'inputenc': '', 'utf8extra': '', 'cmappkg': '', - # https://www.topbug.net/blog/2015/12/10/a-collection-of-issues-about-the-latex-output-in-sphinx-and-the-solutions/ 'papersize': 'letterpaper', 'classoptions': ',openany', # No blank pages - 'polyglossia' : '\\usepackage{polyglossia}', - 'unicode-math' : '\\usepackage{unicode-math}', - 'microtype' : '\\usepackage{microtype}', - "preamble": r"\usepackage{coqnotations}" + 'polyglossia': '\\usepackage{polyglossia}', + 'sphinxsetup': 'verbatimwithframe=false', + 'preamble': r""" + \usepackage{unicode-math} + \usepackage{microtype} + + % Macro definitions + \usepackage{refman-preamble} + + % Style definitions for notations + \usepackage{coqnotations} + + % Style tweaks + \newcssclass{sigannot}{\textrm{#1:}} + + % Silence 'LaTeX Warning: Command \nobreakspace invalid in math mode' + \everymath{\def\nobreakspace{\ }} + """ } -from sphinx.builders.latex import LaTeXBuilder +latex_engine = "xelatex" ######## # done # ######## -latex_additional_files = ["_static/coqnotations.sty"] +latex_additional_files = [ + "refman-preamble.sty", + "_static/coqnotations.sty" +] -# Grouping the document tree into LaTeX files. List of tuples -# (source start file, target name, title, -# author, documentclass [howto, manual, or own class]). -# latex_documents = [ -# (master_doc, 'CoqRefMan.tex', 'Coq Documentation', -# 'The Coq Development Team', 'manual'), -#] +latex_documents = [('index', 'CoqRefMan.tex', project, author, 'manual')] # The name of an image file (relative to this directory) to place at the top of # the title page. -#latex_logo = None - -# For "manual" documents, if this is true, then toplevel headings are parts, -# not chapters. -#latex_use_parts = False +# latex_logo = "../../ide/coq.png" # If true, show page references after internal links. #latex_show_pagerefs = False # If true, show URL addresses after external links. -#latex_show_urls = False - -# Documents to append as an appendix to all manuals. -#latex_appendices = [] - -# If false, no module index is generated. -#latex_domain_indices = True - +latex_show_urls = 'footnote' # -- Options for manual page output --------------------------------------- diff --git a/doc/sphinx/coq-cmdindex.rst b/doc/sphinx/coq-cmdindex.rst index 7df6cb36c5..fd0b342ae4 100644 --- a/doc/sphinx/coq-cmdindex.rst +++ b/doc/sphinx/coq-cmdindex.rst @@ -1,3 +1,5 @@ +:orphan: + .. hack to get index in TOC ----------------- diff --git a/doc/sphinx/coq-exnindex.rst b/doc/sphinx/coq-exnindex.rst index 100c57b085..fc55e91eee 100644 --- a/doc/sphinx/coq-exnindex.rst +++ b/doc/sphinx/coq-exnindex.rst @@ -1,5 +1,7 @@ +:orphan: + .. hack to get index in TOC ----------------------- -Errors, warnings index ----------------------- +------------------------- +Errors and warnings index +------------------------- diff --git a/doc/sphinx/coq-optindex.rst b/doc/sphinx/coq-optindex.rst index f8046a800b..0961bea61f 100644 --- a/doc/sphinx/coq-optindex.rst +++ b/doc/sphinx/coq-optindex.rst @@ -1,5 +1,7 @@ +:orphan: + .. hack to get index in TOC ------------------ -Option index ------------------ +------------------------------- +Flags, options and tables index +------------------------------- diff --git a/doc/sphinx/coq-tacindex.rst b/doc/sphinx/coq-tacindex.rst index 588104f465..31b2f7f8cb 100644 --- a/doc/sphinx/coq-tacindex.rst +++ b/doc/sphinx/coq-tacindex.rst @@ -1,3 +1,5 @@ +:orphan: + .. hack to get index in TOC ------------- diff --git a/doc/sphinx/credits-wrapper.html.rst b/doc/sphinx/credits-wrapper.html.rst new file mode 100644 index 0000000000..2d35a12dc2 --- /dev/null +++ b/doc/sphinx/credits-wrapper.html.rst @@ -0,0 +1,7 @@ +.. _credits: + +------- +Credits +------- + +.. include:: credits.rst diff --git a/doc/sphinx/credits-wrapper.latex.rst b/doc/sphinx/credits-wrapper.latex.rst new file mode 100644 index 0000000000..9f7dd49af8 --- /dev/null +++ b/doc/sphinx/credits-wrapper.latex.rst @@ -0,0 +1,3 @@ +.. _credits: + +.. include:: credits.rst diff --git a/doc/sphinx/credits.rst b/doc/sphinx/credits.rst index be0b5d5f12..212f0a65b0 100644 --- a/doc/sphinx/credits.rst +++ b/doc/sphinx/credits.rst @@ -1,12 +1,3 @@ -.. include:: preamble.rst -.. include:: replaces.rst - -.. _credits: - -------------------------------------------- -Credits -------------------------------------------- - Coq is a proof assistant for higher-order logic, allowing the development of computer programs consistent with their formal specification. It is the result of about ten years of research of the @@ -205,7 +196,7 @@ between sorts. The new version provides powerful tools for easier developments. Cristina Cornes designed an extension of the |Coq| syntax to allow -definition of terms using a powerful pattern-matching analysis in the +definition of terms using a powerful pattern matching analysis in the style of ML programs. Amokrane Saïbi wrote a mechanism to simulate inheritance between types @@ -249,7 +240,7 @@ names to Caml functions corresponding to |Coq| tactic names. Bruno Barras wrote new, more efficient reduction functions. Hugo Herbelin introduced more uniform notations in the |Coq| specification -language: the definitions by fixpoints and pattern-matching have a more +language: the definitions by fixpoints and pattern matching have a more readable syntax. Patrick Loiseleur introduced user-friendly notations for arithmetic expressions. @@ -326,14 +317,14 @@ modules and also to get closer to a certified kernel. Hugo Herbelin introduced a new structure of terms with local definitions. He introduced “qualified” names, wrote a new -pattern-matching compilation algorithm and designed a more compact +pattern matching compilation algorithm and designed a more compact algorithm for checking the logical consistency of universes. He contributed to the simplification of |Coq| internal structures and the optimisation of the system. He added basic tactics for forward reasoning and coercions in patterns. David Delahaye introduced a new language for tactics. General tactics -using pattern-matching on goals and context can directly be written from +using pattern matching on goals and context can directly be written from the |Coq| toplevel. He also provided primitives for the design of user-defined tactics in Caml. @@ -624,8 +615,8 @@ with the library of integers he developed. Beside the libraries, various improvements were contributed to provide a more comfortable end-user language and more expressive tactic language. Hugo -Herbelin and Matthieu Sozeau improved the pattern-matching compilation -algorithm (detection of impossible clauses in pattern-matching, +Herbelin and Matthieu Sozeau improved the pattern matching compilation +algorithm (detection of impossible clauses in pattern matching, automatic inference of the return type). Hugo Herbelin, Pierre Letouzey and Matthieu Sozeau contributed various new convenient syntactic constructs and new tactics or tactic features: more inference of @@ -801,7 +792,7 @@ through :math:`\beta`-redexes that are blocked by the “match” construction (blocked commutative cuts). Relying on the added permissiveness of the guard condition, Hugo -Herbelin could extend the pattern-matching compilation algorithm so that +Herbelin could extend the pattern matching compilation algorithm so that matching over a sequence of terms involving dependencies of a term or of the indices of the type of a term in the type of other terms is systematically supported. @@ -979,7 +970,7 @@ principle than the previously added :math:`\eta`-conversion for function types, based on formulations of the Calculus of Inductive Constructions with typed equality. Primitive projections, which do not carry the parameters of the record and are rigid names (not defined as a -pattern-matching construct), make working with nested records more +pattern matching construct), make working with nested records more manageable in terms of time and space consumption. This extension and universe polymorphism were carried out partly while Matthieu Sozeau was working at the IAS in Princeton. diff --git a/doc/sphinx/genindex.rst b/doc/sphinx/genindex.rst index a991c7f9f8..29f792b3aa 100644 --- a/doc/sphinx/genindex.rst +++ b/doc/sphinx/genindex.rst @@ -1,3 +1,5 @@ +:orphan: + .. hack to get index in TOC ----- diff --git a/doc/sphinx/index.rst b/doc/sphinx/index.html.rst index baf2e0d981..9d90857061 100644 --- a/doc/sphinx/index.rst +++ b/doc/sphinx/index.html.rst @@ -1,11 +1,16 @@ -.. include:: preamble.rst -.. include:: replaces.rst +========================== + The Coq Reference Manual +========================== + +.. _introduction: + +Introduction +------------ .. include:: introduction.rst ------------------- Table of contents ------------------- +----------------- .. toctree:: :caption: Indexes @@ -23,7 +28,7 @@ Table of contents :caption: Preamble self - credits + credits-wrapper .. toctree:: :caption: The language @@ -80,12 +85,7 @@ Table of contents zebibliography -This material (the Coq Reference Manual) may be distributed only subject to the -terms and conditions set forth in the Open Publication License, v1.0 or later -(the latest version is presently available at -http://www.opencontent.org/openpub). Options A and B are not elected. +License +------- -.. [#PG] Proof-General is available at https://proofgeneral.github.io/. - Optionally, you can enhance it with the minor mode - Company-Coq :cite:`Pit16` - (see https://github.com/cpitclaudel/company-coq). +.. include:: license.rst diff --git a/doc/sphinx/index.latex.rst b/doc/sphinx/index.latex.rst new file mode 100644 index 0000000000..0f2f7b4897 --- /dev/null +++ b/doc/sphinx/index.latex.rst @@ -0,0 +1,81 @@ +========================== + The Coq Reference Manual +========================== + +Introduction +------------ + +.. include:: introduction.rst + +Credits +------- + +.. include:: credits-wrapper.rst + +License +------- + +.. include:: license.rst + +The language +------------ + +.. toctree:: + + language/gallina-specification-language + language/gallina-extensions + language/coq-library + language/cic + language/module-system + +The proof engine +---------------- + +.. toctree:: + + proof-engine/vernacular-commands + proof-engine/proof-handling + proof-engine/tactics + proof-engine/ltac + proof-engine/detailed-tactic-examples + proof-engine/ssreflect-proof-language + +User extensions +--------------- + +.. toctree:: + + user-extensions/syntax-extensions + user-extensions/proof-schemes + +Practical tools +--------------- + +.. toctree:: + + practical-tools/coq-commands + practical-tools/utilities + practical-tools/coqide + +Addendum +-------- + +.. toctree:: + + addendum/extended-pattern-matching + addendum/implicit-coercions + addendum/canonical-structures + addendum/type-classes + addendum/omega + addendum/micromega + addendum/extraction + addendum/program + addendum/ring + addendum/nsatz + addendum/generalized-rewriting + addendum/parallel-proof-processing + addendum/miscellaneous-extensions + addendum/universe-polymorphism + +.. toctree:: + zebibliography diff --git a/doc/sphinx/introduction.rst b/doc/sphinx/introduction.rst index b57e4b209c..b8d2f6b6dc 100644 --- a/doc/sphinx/introduction.rst +++ b/doc/sphinx/introduction.rst @@ -1,9 +1,3 @@ -.. _introduction: - ------------------------- -Introduction ------------------------- - This document is the Reference Manual of the |Coq| proof assistant. To start using Coq, it is advised to first read a tutorial. Links to several tutorials can be found at @@ -41,6 +35,11 @@ are processed from a file. The `coqtop` read-eval-print-loop can also be used directly, for debugging purposes. + .. [#PG] Proof-General is available at https://proofgeneral.github.io/. + Optionally, you can enhance it with the minor mode + Company-Coq :cite:`Pit16` + (see https://github.com/cpitclaudel/company-coq). + - The compiled mode acts as a proof checker taking a file containing a whole development in order to ensure its correctness. Moreover, |Coq|’s compiler provides an output file containing a compact diff --git a/doc/sphinx/language/cic.rst b/doc/sphinx/language/cic.rst index 3d3a1b11b1..381f8bb661 100644 --- a/doc/sphinx/language/cic.rst +++ b/doc/sphinx/language/cic.rst @@ -1,6 +1,3 @@ -.. include:: ../preamble.rst -.. include:: ../replaces.rst - .. _calculusofinductiveconstructions: @@ -605,7 +602,7 @@ Subtyping rules At the moment, we did not take into account one rule between universes which says that any term in a universe of index i is also a term in -the universe of index i+1 (this is the *cumulativity* rule of|Cic|). +the universe of index i+1 (this is the *cumulativity* rule of |Cic|). This property extends the equivalence relation of convertibility into a *subtyping* relation inductively defined by: @@ -640,7 +637,7 @@ a *subtyping* relation inductively defined by: respectively then .. math:: - E[Γ] ⊢ t~w_1 … w_m ≤_{βδιζη} t~w_1' … w_m' + E[Γ] ⊢ t~w_1 … w_m ≤_{βδιζη} t'~w_1' … w_m' (notice that :math:`t` and :math:`t'` are both fully applied, i.e., they have a sort as a type) if @@ -1010,7 +1007,7 @@ the Type hierarchy. It is possible to declare the same inductive definition in the universe :math:`\Type`. The :g:`exType` inductive definition has type - :math:`(\Type(i)→\Prop)→\Type(j)` with the constraint that the parameter :math:`X` of :math:`\kw{exT_intro}` + :math:`(\Type(i)→\Prop)→\Type(j)` with the constraint that the parameter :math:`X` of :math:`\kw{exT}_{\kw{intro}}` has type :math:`\Type(k)` with :math:`k<j` and :math:`k≤ i`. .. coqtop:: all @@ -1025,8 +1022,26 @@ the Type hierarchy. Template polymorphism +++++++++++++++++++++ -Inductive types declared in :math:`\Type` are polymorphic over their arguments -in :math:`\Type`. If :math:`A` is an arity of some sort and :math:`s` is a sort, we write :math:`A_{/s}` +Inductive types can be made polymorphic over their arguments +in :math:`\Type`. + +.. flag:: Auto Template Polymorphism + + This option, enabled by default, makes every inductive type declared + at level :math:`Type` (without annotations or hiding it behind a + definition) template polymorphic. + + This can be prevented using the ``notemplate`` attribute. + + An inductive type can be forced to be template polymorphic using the + ``template`` attribute. + + Template polymorphism and universe polymorphism (see Chapter + :ref:`polymorphicuniverses`) are incompatible, so if the later is + enabled it will prevail over automatic template polymorphism and + cause an error when using the ``template`` attribute. + +If :math:`A` is an arity of some sort and :math:`s` is a sort, we write :math:`A_{/s}` for the arity obtained from :math:`A` by replacing its sort with :math:`s`. Especially, if :math:`A` is well-typed in some global environment and local context, then :math:`A_{/s}` is typable by typability of all products in the @@ -1105,7 +1120,7 @@ and otherwise in the Type hierarchy. Note that the side-condition about allowed elimination sorts in the rule **Ind-Family** is just to avoid to recompute the allowed elimination -sorts at each instance of a pattern-matching (see Section :ref:`Destructors`). As +sorts at each instance of a pattern matching (see Section :ref:`Destructors`). As an example, let us consider the following definition: .. example:: @@ -1229,7 +1244,7 @@ primitive recursion over the structure. But this operator is rather tedious to implement and use. We choose in this version of |Coq| to factorize the operator for primitive recursion into two more primitive operations as was first suggested by Th. -Coquand in :cite:`Coq92`. One is the definition by pattern-matching. The +Coquand in :cite:`Coq92`. One is the definition by pattern matching. The second one is a definition by guarded fixpoints. @@ -1246,14 +1261,14 @@ The |Coq| term for this proof will be written: .. math:: - \Match~m~\with~(c_1~x_{11} ... x_{1p_1} ) ⇒ f_1 | … | (c_n~x_{n1} ... x_{np_n} ) ⇒ f_n \endkw + \Match~m~\with~(c_1~x_{11} ... x_{1p_1} ) ⇒ f_1 | … | (c_n~x_{n1} ... x_{np_n} ) ⇒ f_n \kwend In this expression, if :math:`m` eventually happens to evaluate to :math:`(c_i~u_1 … u_{p_i})` then the expression will behave as specified in its :math:`i`-th branch and it will reduce to :math:`f_i` where the :math:`x_{i1} …x_{ip_i}` are replaced by the :math:`u_1 … u_{p_i}` according to the ι-reduction. -Actually, for type checking a :math:`\Match…\with…\endkw` expression we also need +Actually, for type checking a :math:`\Match…\with…\kwend` expression we also need to know the predicate P to be proved by case analysis. In the general case where :math:`I` is an inductively defined :math:`n`-ary relation, :math:`P` is a predicate over :math:`n+1` arguments: the :math:`n` first ones correspond to the arguments of :math:`I` @@ -1267,7 +1282,7 @@ using the syntax: .. math:: \Match~m~\as~x~\In~I~\_~a~\return~P~\with~ (c_1~x_{11} ... x_{1p_1} ) ⇒ f_1 | … - | (c_n~x_{n1} ... x_{np_n} ) ⇒ f_n~\endkw + | (c_n~x_{n1} ... x_{np_n} ) ⇒ f_n~\kwend The :math:`\as` part can be omitted if either the result type does not depend on :math:`m` (non-dependent elimination) or :math:`m` is a variable (in this case, :math:`m` @@ -1453,6 +1468,8 @@ We write :math:`\{c\}^P` for :math:`\{c:C\}^P` with :math:`C` the type of :math: where .. math:: + :nowrap: + \begin{eqnarray*} P & = & \lambda~l~.~P^\prime\\ f_1 & = & t_1\\ @@ -1693,13 +1710,15 @@ for primitive recursive operators. The following reductions are now possible: .. math:: - \def\plus{\mathsf{plus}} - \def\tri{\triangleright_\iota} - \begin{eqnarray*} - \plus~(\nS~(\nS~\nO))~(\nS~\nO) & \tri & \nS~(\plus~(\nS~\nO)~(\nS~\nO))\\ - & \tri & \nS~(\nS~(\plus~\nO~(\nS~\nO)))\\ - & \tri & \nS~(\nS~(\nS~\nO))\\ - \end{eqnarray*} + :nowrap: + + {\def\plus{\mathsf{plus}} + \def\tri{\triangleright_\iota} + \begin{eqnarray*} + \plus~(\nS~(\nS~\nO))~(\nS~\nO) & \tri & \nS~(\plus~(\nS~\nO)~(\nS~\nO))\\ + & \tri & \nS~(\nS~(\plus~\nO~(\nS~\nO)))\\ + & \tri & \nS~(\nS~(\nS~\nO))\\ + \end{eqnarray*}} .. _Mutual-induction: diff --git a/doc/sphinx/language/coq-library.rst b/doc/sphinx/language/coq-library.rst index 9de30e2190..85474a3e98 100644 --- a/doc/sphinx/language/coq-library.rst +++ b/doc/sphinx/language/coq-library.rst @@ -1,5 +1,3 @@ -.. include:: ../replaces.rst - .. _thecoqlibrary: The |Coq| library @@ -620,7 +618,7 @@ Finally, it gives the definition of the usual orderings ``le``, Properties of these relations are not initially known, but may be required by the user from modules ``Le`` and ``Lt``. Finally, -``Peano`` gives some lemmas allowing pattern-matching, and a double +``Peano`` gives some lemmas allowing pattern matching, and a double induction principle. .. index:: diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index 0fbe7ac70b..636144e0c8 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -1,5 +1,3 @@ -.. include:: ../replaces.rst - .. _extensionsofgallina: Extensions of |Gallina| @@ -22,7 +20,7 @@ expressions. In this sense, the :cmd:`Record` construction allows defining .. _record_grammar: - .. productionlist:: `sentence` + .. productionlist:: sentence record : `record_keyword` `record_body` with … with `record_body` record_keyword : Record | Inductive | CoInductive record_body : `ident` [ `binders` ] [: `sort` ] := [ `ident` ] { [ `field` ; … ; `field` ] }. @@ -82,11 +80,13 @@ To build an object of type :n:`@ident`, one should provide the constructor Definition half := mkRat true 1 2 (O_S 1) one_two_irred. Check half. +.. FIXME: move this to the main grammar in the spec chapter + .. _record-named-fields-grammar: .. productionlist:: - term : {| [`field_def` ; … ; `field_def`] |} - field_def : name [binders] := `term` + record_term : {| [`field_def` ; … ; `field_def`] |} + field_def : name [binders] := `record_term` Alternatively, the following syntax allows creating objects by using named fields, as shown in this grammar. The fields do not have to be in any particular order, nor do they have @@ -100,19 +100,25 @@ to be all present if the missing ones can be inferred or prompted for Rat_bottom_cond := O_S 1; Rat_irred_cond := one_two_irred |}. -This syntax can be disabled globally for printing by +The following settings let you control the display format for types: + +.. flag:: Printing Records -.. cmd:: Unset Printing Records + If set, use the record syntax (shown above) as the default display format. -For a given type, one can override this using either +You can override the display format for specified types by adding entries to these tables: -.. cmd:: Add Printing Record @ident +.. table:: Printing Record @qualid + :name: Printing Record -to get record syntax or + Specifies a set of qualids which are displayed as records. Use the + :cmd:`Add @table` and :cmd:`Remove @table` commands to update the set of qualids. -.. cmd:: Add Printing Constructor @ident +.. table:: Printing Constructor @qualid + :name: Printing Constructor -to get constructor syntax. + Specifies a set of qualids which are displayed as constructors. Use the + :cmd:`Add @table` and :cmd:`Remove @table` commands to update the set of qualids. This syntax can also be used for pattern matching. @@ -145,7 +151,7 @@ available: It can be activated for printing with -.. opt:: Printing Projections +.. flag:: Printing Projections .. example:: @@ -154,12 +160,14 @@ It can be activated for printing with Set Printing Projections. Check top half. +.. FIXME: move this to the main grammar in the spec chapter + .. _record_projections_grammar: .. productionlist:: terms - term : term `.` ( qualid ) - : | term `.` ( qualid arg … arg ) - : | term `.` ( @`qualid` `term` … `term` ) + projection : projection `.` ( `qualid` ) + : | projection `.` ( `qualid` `arg` … `arg` ) + : | projection `.` ( @`qualid` `term` … `term` ) Syntax of Record projections @@ -219,35 +227,35 @@ the errors of inductive definitions, as described in Section Primitive Projections ~~~~~~~~~~~~~~~~~~~~~ -.. opt:: Primitive Projections +.. flag:: Primitive Projections -Turns on the use of primitive -projections when defining subsequent records (even through the ``Inductive`` -and ``CoInductive`` commands). Primitive projections -extended the Calculus of Inductive Constructions with a new binary -term constructor `r.(p)` representing a primitive projection `p` applied -to a record object `r` (i.e., primitive projections are always applied). -Even if the record type has parameters, these do not appear at -applications of the projection, considerably reducing the sizes of -terms when manipulating parameterized records and type checking time. -On the user level, primitive projections can be used as a replacement -for the usual defined ones, although there are a few notable differences. + Turns on the use of primitive + projections when defining subsequent records (even through the ``Inductive`` + and ``CoInductive`` commands). Primitive projections + extended the Calculus of Inductive Constructions with a new binary + term constructor `r.(p)` representing a primitive projection `p` applied + to a record object `r` (i.e., primitive projections are always applied). + Even if the record type has parameters, these do not appear at + applications of the projection, considerably reducing the sizes of + terms when manipulating parameterized records and type checking time. + On the user level, primitive projections can be used as a replacement + for the usual defined ones, although there are a few notable differences. -.. opt:: Printing Primitive Projection Parameters +.. flag:: Printing Primitive Projection Parameters -This compatibility option reconstructs internally omitted parameters at -printing time (even though they are absent in the actual AST manipulated -by the kernel). + This compatibility option reconstructs internally omitted parameters at + printing time (even though they are absent in the actual AST manipulated + by the kernel). -.. opt:: Printing Primitive Projection Compatibility +.. flag:: Printing Primitive Projection Compatibility -This compatibility option (on by default) governs the -printing of pattern-matching over primitive records. + This compatibility option (on by default) governs the + printing of pattern matching over primitive records. Primitive Record Types ++++++++++++++++++++++ -When the :opt:`Primitive Projections` option is on, definitions of +When the :flag:`Primitive Projections` option is on, definitions of record types change meaning. When a type is declared with primitive projections, its :g:`match` construct is disabled (see :ref:`primitive_projections` though). To eliminate the (co-)inductive type, one must use its defined primitive projections. @@ -257,9 +265,9 @@ To eliminate the (co-)inductive type, one must use its defined primitive project For compatibility, the parameters still appear to the user when printing terms even though they are absent in the actual AST manipulated by the kernel. This can be changed by unsetting the -``Printing Primitive Projection Parameters`` flag. Further compatibility +:flag:`Printing Primitive Projection Parameters` flag. Further compatibility printing can be deactivated thanks to the ``Printing Primitive Projection -Compatibility`` option which governs the printing of pattern-matching +Compatibility`` option which governs the printing of pattern matching over primitive records. There are currently two ways to introduce primitive records types: @@ -289,7 +297,7 @@ the folded version delta-reduces to the unfolded version. This allows to precisely mimic the usual unfolding rules of constants. Projections obey the usual ``simpl`` flags of the ``Arguments`` command in particular. There is currently no way to input unfolded primitive projections at the -user-level, and one must use the ``Printing Primitive Projection Compatibility`` +user-level, and one must use the :flag:`Printing Primitive Projection Compatibility` to display unfolded primitive projections as matches and distinguish them from folded ones. @@ -302,7 +310,7 @@ an object of the record type as arguments, and whose body is an application of the unfolded primitive projection of the same name. These constants are used when elaborating partial applications of the projection. One can distinguish them from applications of the primitive -projection if the ``Printing Primitive Projection Parameters`` option +projection if the :flag`Printing Primitive Projection Parameters` option is off: For a primitive projection application, parameters are printed as underscores while for the compatibility projections they are printed as usual. @@ -316,17 +324,17 @@ Variants and extensions of :g:`match` .. _mult-match: -Multiple and nested pattern-matching +Multiple and nested pattern matching ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The basic version of :g:`match` allows pattern-matching on simple +The basic version of :g:`match` allows pattern matching on simple patterns. As an extension, multiple nested patterns or disjunction of patterns are allowed, as in ML-like languages. The extension just acts as a macro that is expanded during parsing into a sequence of match on simple patterns. Especially, a construction defined using the extended match is generally printed -under its expanded form (see :opt:`Printing Matching`). +under its expanded form (see :flag:`Printing Matching`). .. seealso:: :ref:`extendedpatternmatching`. @@ -335,7 +343,7 @@ under its expanded form (see :opt:`Printing Matching`). Pattern-matching on boolean values: the if expression ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For inductive types with exactly two constructors and for pattern-matching +For inductive types with exactly two constructors and for pattern matching expressions that do not depend on the arguments of the constructors, it is possible to use a ``if … then … else`` notation. For instance, the definition @@ -474,123 +482,93 @@ of :g:`match` expressions. Printing nested patterns +++++++++++++++++++++++++ -.. opt:: Printing Matching +.. flag:: Printing Matching -The Calculus of Inductive Constructions knows pattern-matching only -over simple patterns. It is however convenient to re-factorize nested -pattern-matching into a single pattern-matching over a nested -pattern. + The Calculus of Inductive Constructions knows pattern matching only + over simple patterns. It is however convenient to re-factorize nested + pattern matching into a single pattern matching over a nested + pattern. -When this option is on (default), |Coq|’s printer tries to do such -limited re-factorization. -Turning it off tells |Coq| to print only simple pattern-matching problems -in the same way as the |Coq| kernel handles them. + When this option is on (default), |Coq|’s printer tries to do such + limited re-factorization. + Turning it off tells |Coq| to print only simple pattern matching problems + in the same way as the |Coq| kernel handles them. Factorization of clauses with same right-hand side ++++++++++++++++++++++++++++++++++++++++++++++++++ -.. opt:: Printing Factorizable Match Patterns +.. flag:: Printing Factorizable Match Patterns -When several patterns share the same right-hand side, it is additionally -possible to share the clauses using disjunctive patterns. Assuming that the -printing matching mode is on, this option (on by default) tells |Coq|'s -printer to try to do this kind of factorization. + When several patterns share the same right-hand side, it is additionally + possible to share the clauses using disjunctive patterns. Assuming that the + printing matching mode is on, this option (on by default) tells |Coq|'s + printer to try to do this kind of factorization. Use of a default clause +++++++++++++++++++++++ -.. opt:: Printing Allow Default Clause +.. flag:: Printing Allow Match Default Clause -When several patterns share the same right-hand side which do not depend on the -arguments of the patterns, yet an extra factorization is possible: the -disjunction of patterns can be replaced with a `_` default clause. Assuming that -the printing matching mode and the factorization mode are on, this option (on by -default) tells |Coq|'s printer to use a default clause when relevant. + When several patterns share the same right-hand side which do not depend on the + arguments of the patterns, yet an extra factorization is possible: the + disjunction of patterns can be replaced with a `_` default clause. Assuming that + the printing matching mode and the factorization mode are on, this option (on by + default) tells |Coq|'s printer to use a default clause when relevant. Printing of wildcard patterns ++++++++++++++++++++++++++++++ -.. opt:: Printing Wildcard +.. flag:: Printing Wildcard -Some variables in a pattern may not occur in the right-hand side of -the pattern-matching clause. When this option is on (default), the -variables having no occurrences in the right-hand side of the -pattern-matching clause are just printed using the wildcard symbol -“_”. + Some variables in a pattern may not occur in the right-hand side of + the pattern matching clause. When this option is on (default), the + variables having no occurrences in the right-hand side of the + pattern matching clause are just printed using the wildcard symbol + “_”. Printing of the elimination predicate +++++++++++++++++++++++++++++++++++++ -.. opt:: Printing Synth +.. flag:: Printing Synth -In most of the cases, the type of the result of a matched term is -mechanically synthesizable. Especially, if the result type does not -depend of the matched term. When this option is on (default), -the result type is not printed when |Coq| knows that it can re- -synthesize it. + In most of the cases, the type of the result of a matched term is + mechanically synthesizable. Especially, if the result type does not + depend of the matched term. When this option is on (default), + the result type is not printed when |Coq| knows that it can re- + synthesize it. Printing matching on irrefutable patterns ++++++++++++++++++++++++++++++++++++++++++ -If an inductive type has just one constructor, pattern-matching can be +If an inductive type has just one constructor, pattern matching can be written using the first destructuring let syntax. -.. cmd:: Add Printing Let @ident - - This adds `ident` to the list of inductive types for which pattern-matching - is written using a let expression. - -.. cmd:: Remove Printing Let @ident - - This removes ident from this list. Note that removing an inductive - type from this list has an impact only for pattern-matching written - using :g:`match`. Pattern-matching explicitly written using a destructuring - :g:`let` are not impacted. - -.. cmd:: Test Printing Let for @ident - - This tells if `ident` belongs to the list. - -.. cmd:: Print Table Printing Let +.. table:: Printing Let @qualid + :name: Printing Let - This prints the list of inductive types for which pattern-matching is - written using a let expression. - - The list of inductive types for which pattern-matching is written - using a :g:`let` expression is managed synchronously. This means that it is - sensitive to the command ``Reset``. + Specifies a set of qualids for which pattern matching is displayed using a let expression. + Note that this only applies to pattern matching instances entered with :g:`match`. + It doesn't affect pattern matching explicitly entered with a destructuring + :g:`let`. + Use the :cmd:`Add @table` and :cmd:`Remove @table` commands to update this set. Printing matching on booleans +++++++++++++++++++++++++++++ -If an inductive type is isomorphic to the boolean type, pattern-matching -can be written using ``if`` … ``then`` … ``else`` …: - -.. cmd:: Add Printing If @ident - - This adds ident to the list of inductive types for which pattern-matching is - written using an if expression. - -.. cmd:: Remove Printing If @ident - - This removes ident from this list. +If an inductive type is isomorphic to the boolean type, pattern matching +can be written using ``if`` … ``then`` … ``else`` …. This table controls +which types are written this way: -.. cmd:: Test Printing If for @ident +.. table:: Printing If @qualid + :name: Printing If - This tells if ident belongs to the list. - -.. cmd:: Print Table Printing If - - This prints the list of inductive types for which pattern-matching is - written using an if expression. - -The list of inductive types for which pattern-matching is written -using an ``if`` expression is managed synchronously. This means that it is -sensitive to the command ``Reset``. + Specifies a set of qualids for which pattern matching is displayed using + ``if`` … ``then`` … ``else`` …. Use the :cmd:`Add @table` and :cmd:`Remove @table` + commands to update this set. This example emphasizes what the printing options offer. @@ -672,7 +650,7 @@ than like this: *Limitations* -|term_0| must be built as a *pure pattern-matching tree* (:g:`match … with`) +|term_0| must be built as a *pure pattern matching tree* (:g:`match … with`) with applications only *at the end* of each branch. Function does not support partial application of the function being @@ -700,7 +678,7 @@ terminating functions. - the definition uses pattern matching on dependent types, which ``Function`` cannot deal with yet. - - the definition is not a *pattern-matching tree* as explained above. + - the definition is not a *pattern matching tree* as explained above. .. warn:: Cannot define principle(s) for @ident. @@ -1238,7 +1216,7 @@ component is equal ``nat`` and hence ``M1.T`` as specified. Prints the module type corresponding to :n:`@ident`. -.. opt:: Short Module Printing +.. flag:: Short Module Printing This option (off by default) disables the printing of the types of fields, leaving only their names, for the commands :cmd:`Print Module` and @@ -1513,7 +1491,7 @@ says that the implicit argument is maximally inserted. Each implicit argument can be declared to have to be inserted maximally or non maximally. This can be governed argument per argument by the command -:cmd:`Arguments (implicits)` or globally by the :opt:`Maximal Implicit Insertion` option. +:cmd:`Arguments (implicits)` or globally by the :flag:`Maximal Implicit Insertion` option. .. seealso:: :ref:`displaying-implicit-args`. @@ -1745,65 +1723,65 @@ appear strictly in the body of the type, they are implicit. Mode for automatic declaration of implicit arguments ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. opt:: Implicit Arguments +.. flag:: Implicit Arguments -This option (off by default) allows to systematically declare implicit -the arguments detectable as such. Auto-detection of implicit arguments is -governed by options controlling whether strict and contextual implicit -arguments have to be considered or not. + This option (off by default) allows to systematically declare implicit + the arguments detectable as such. Auto-detection of implicit arguments is + governed by options controlling whether strict and contextual implicit + arguments have to be considered or not. .. _controlling-strict-implicit-args: Controlling strict implicit arguments ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. opt:: Strict Implicit +.. flag:: Strict Implicit -When the mode for automatic declaration of implicit arguments is on, -the default is to automatically set implicit only the strict implicit -arguments plus, for historical reasons, a small subset of the non-strict -implicit arguments. To relax this constraint and to set -implicit all non strict implicit arguments by default, you can turn this -option off. + When the mode for automatic declaration of implicit arguments is on, + the default is to automatically set implicit only the strict implicit + arguments plus, for historical reasons, a small subset of the non-strict + implicit arguments. To relax this constraint and to set + implicit all non strict implicit arguments by default, you can turn this + option off. -.. opt:: Strongly Strict Implicit +.. flag:: Strongly Strict Implicit -Use this option (off by default) to capture exactly the strict implicit -arguments and no more than the strict implicit arguments. + Use this option (off by default) to capture exactly the strict implicit + arguments and no more than the strict implicit arguments. .. _controlling-contextual-implicit-args: Controlling contextual implicit arguments ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. opt:: Contextual Implicit +.. flag:: Contextual Implicit -By default, |Coq| does not automatically set implicit the contextual -implicit arguments. You can turn this option on to tell |Coq| to also -infer contextual implicit argument. + By default, |Coq| does not automatically set implicit the contextual + implicit arguments. You can turn this option on to tell |Coq| to also + infer contextual implicit argument. .. _controlling-rev-pattern-implicit-args: Controlling reversible-pattern implicit arguments ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. opt:: Reversible Pattern Implicit +.. flag:: Reversible Pattern Implicit -By default, |Coq| does not automatically set implicit the reversible-pattern -implicit arguments. You can turn this option on to tell |Coq| to also infer -reversible-pattern implicit argument. + By default, |Coq| does not automatically set implicit the reversible-pattern + implicit arguments. You can turn this option on to tell |Coq| to also infer + reversible-pattern implicit argument. .. _controlling-insertion-implicit-args: Controlling the insertion of implicit arguments not followed by explicit arguments ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. opt:: Maximal Implicit Insertion +.. flag:: Maximal Implicit Insertion -Assuming the implicit argument mode is on, this option (off by default) -declares implicit arguments to be automatically inserted when a -function is partially applied and the next argument of the function is -an implicit one. + Assuming the implicit argument mode is on, this option (off by default) + declares implicit arguments to be automatically inserted when a + function is partially applied and the next argument of the function is + an implicit one. .. _explicit-applications: @@ -1875,20 +1853,20 @@ if each of them is to be used maximally or not, use the command Explicit displaying of implicit arguments for pretty-printing ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. opt:: Printing Implicit +.. flag:: Printing Implicit -By default, the basic pretty-printing rules hide the inferable implicit -arguments of an application. Turn this option on to force printing all -implicit arguments. + By default, the basic pretty-printing rules hide the inferable implicit + arguments of an application. Turn this option on to force printing all + implicit arguments. -.. opt:: Printing Implicit Defensive +.. flag:: Printing Implicit Defensive -By default, the basic pretty-printing rules display the implicit -arguments that are not detected as strict implicit arguments. This -“defensive” mode can quickly make the display cumbersome so this can -be deactivated by turning this option off. + By default, the basic pretty-printing rules display the implicit + arguments that are not detected as strict implicit arguments. This + “defensive” mode can quickly make the display cumbersome so this can + be deactivated by turning this option off. -.. seealso:: :opt:`Printing All`. +.. seealso:: :flag:`Printing All`. Interaction with subtyping ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1913,14 +1891,14 @@ but succeeds in Deactivation of implicit arguments for parsing ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. opt:: Parsing Explicit +.. flag:: Parsing Explicit -Turning this option on (it is off by default) deactivates the use of implicit arguments. + Turning this option on (it is off by default) deactivates the use of implicit arguments. -In this case, all arguments of constants, inductive types, -constructors, etc, including the arguments declared as implicit, have -to be given as if no arguments were implicit. By symmetry, this also -affects printing. + In this case, all arguments of constants, inductive types, + constructors, etc, including the arguments declared as implicit, have + to be given as if no arguments were implicit. By symmetry, this also + affects printing. Canonical structures ~~~~~~~~~~~~~~~~~~~~ @@ -2132,32 +2110,32 @@ to coercions are provided in :ref:`implicitcoercions`. Printing constructions in full ------------------------------ -.. opt:: Printing All +.. flag:: Printing All -Coercions, implicit arguments, the type of pattern-matching, but also -notations (see :ref:`syntaxextensionsandinterpretationscopes`) can obfuscate the behavior of some -tactics (typically the tactics applying to occurrences of subterms are -sensitive to the implicit arguments). Turning this option on -deactivates all high-level printing features such as coercions, -implicit arguments, returned type of pattern-matching, notations and -various syntactic sugar for pattern-matching or record projections. -Otherwise said, :opt:`Printing All` includes the effects of the options -:opt:`Printing Implicit`, :opt:`Printing Coercions`, :opt:`Printing Synth`, -:opt:`Printing Projections`, and :opt:`Printing Notations`. To reactivate -the high-level printing features, use the command ``Unset Printing All``. + Coercions, implicit arguments, the type of pattern matching, but also + notations (see :ref:`syntaxextensionsandinterpretationscopes`) can obfuscate the behavior of some + tactics (typically the tactics applying to occurrences of subterms are + sensitive to the implicit arguments). Turning this option on + deactivates all high-level printing features such as coercions, + implicit arguments, returned type of pattern matching, notations and + various syntactic sugar for pattern matching or record projections. + Otherwise said, :flag:`Printing All` includes the effects of the options + :flag:`Printing Implicit`, :flag:`Printing Coercions`, :flag:`Printing Synth`, + :flag:`Printing Projections`, and :flag:`Printing Notations`. To reactivate + the high-level printing features, use the command ``Unset Printing All``. .. _printing-universes: Printing universes ------------------ -.. opt:: Printing Universes +.. flag:: Printing Universes -Turn this option on to activate the display of the actual level of each -occurrence of :g:`Type`. See :ref:`Sorts` for details. This wizard option, in -combination with :opt:`Printing All` can help to diagnose failures to unify -terms apparently identical but internally different in the Calculus of Inductive -Constructions. + Turn this option on to activate the display of the actual level of each + occurrence of :g:`Type`. See :ref:`Sorts` for details. This wizard option, in + combination with :flag:`Printing All` can help to diagnose failures to unify + terms apparently identical but internally different in the Calculus of Inductive + Constructions. The constraints on the internal level of the occurrences of Type (see :ref:`Sorts`) can be printed using the command @@ -2219,7 +2197,7 @@ form is appending to its name, indicating how the variables of its defining context are instantiated. The variables of the context of the existential variables which are -instantiated by themselves are not written, unless the flag ``Printing Existential Instances`` +instantiated by themselves are not written, unless the flag :flag:`Printing Existential Instances` is on (see Section :ref:`explicit-display-existentials`), and this is why an existential variable used in the same context as its context of definition is written with no instance. @@ -2241,11 +2219,11 @@ with a named-goal selector, see :ref:`goal-selectors`). Explicit displaying of existential instances for pretty-printing ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. opt:: Printing Existential Instances +.. flag:: Printing Existential Instances -This option (off by default) activates the full display of how the -context of an existential variable is instantiated at each of the -occurrences of the existential variable. + This option (off by default) activates the full display of how the + context of an existential variable is instantiated at each of the + occurrences of the existential variable. .. _tactics-in-terms: diff --git a/doc/sphinx/language/gallina-specification-language.rst b/doc/sphinx/language/gallina-specification-language.rst index 075235a8e2..daf34500bf 100644 --- a/doc/sphinx/language/gallina-specification-language.rst +++ b/doc/sphinx/language/gallina-specification-language.rst @@ -216,6 +216,11 @@ numbers (see :ref:`datatypes`). Negative integers are not at the same level as :token:`num`, for this would make precedence unnatural. +.. index:: + single: Set (sort) + single: Prop + single: Type + Sorts ----- @@ -262,6 +267,8 @@ 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.: :g:`fun (x y z : A) => t` can be shortened in :g:`fun x y z : A => t`). +.. index:: fun ... => ... + Abstractions ------------ @@ -282,6 +289,8 @@ a let-binder occurs in the list of binders, it is expanded to a let-in definition (see Section :ref:`let-in`). +.. index:: forall + Products -------- @@ -320,6 +329,11 @@ The notation :n:`(@ident := @term)` for arguments is used for making explicit the value of implicit arguments (see Section :ref:`explicit-applications`). +.. index:: + single: ... : ... (type cast) + single: ... <: ... + single: ... <<: ... + Type cast --------- @@ -329,6 +343,11 @@ the type of :token:`term` to be :token:`type`. :n:`@term <: @type` locally sets up the virtual machine for checking that :token:`term` has type :token:`type`. +:n:`@term <<: @type` uses native compilation for checking that :token:`term` +has type :token:`type`. + +.. index:: _ + Inferable subterms ------------------ @@ -336,6 +355,8 @@ Expressions often contain redundant pieces of information. Subterms that can be automatically inferred by Coq can be replaced by the symbol ``_`` and Coq will guess the missing piece of information. +.. index:: let ... := ... (term) + .. _let-in: Let-in definitions @@ -347,17 +368,19 @@ denotes the local binding of :token:`term` to the variable definition of functions: :n:`let @ident {+ @binder} := @term in @term’` stands for :n:`let @ident := fun {+ @binder} => @term in @term’`. +.. index:: match ... with ... + Definition by case analysis --------------------------- Objects of inductive types can be destructurated by a case-analysis -construction called *pattern-matching* expression. A pattern-matching +construction called *pattern matching* expression. A pattern matching expression is used to analyze the structure of an inductive object and to apply specific treatments accordingly. -This paragraph describes the basic form of pattern-matching. See +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 +of the general form. The basic form of pattern matching is characterized by a single :token:`match_item` expression, a :token:`mult_pattern` restricted to a single :token:`pattern` and :token:`pattern` restricted to the form :n:`@qualid {* @ident}`. @@ -365,9 +388,9 @@ single :token:`pattern` and :token:`pattern` restricted to the form The expression match ":token:`term`:math:`_0` :token:`return_type` 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 +*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 +: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 exactly one branch for every constructor of :math:`I`. @@ -380,7 +403,7 @@ inferred from the type of the branches [2]_. 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 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` is dependent in the return type. For instance, in the following example: @@ -401,7 +424,7 @@ is dependent in the return type. For instance, in the following example: the branches have respective types ":g:`or (eq bool true true) (eq bool true false)`" and ":g:`or (eq bool false true) (eq bool false false)`" while the whole -pattern-matching expression has type ":g:`or (eq bool b true) (eq bool b false)`", +pattern matching expression has type ":g:`or (eq bool b true) (eq bool b false)`", the identifier :g:`b` being used to represent the dependency. .. note:: @@ -424,7 +447,7 @@ as the equality predicate (see Section :ref:`coq-equality`), the order predicate on natural numbers or the type of lists of a given length (see Section :ref:`matching-dependent`). In this configuration, the type of each branch can depend on the type dependencies specific to the -branch and the whole pattern-matching expression has a type determined +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` … @@ -453,13 +476,13 @@ For instance, in the following example: the type of the branch is :g:`eq A x x` because the third argument of :g:`eq` is :g:`x` in the type of the pattern :g:`eq_refl`. On the contrary, the -type of the whole pattern-matching expression has type :g:`eq A y x` because the +type of the whole pattern matching expression has type :g:`eq A y x` because the third argument of eq is y in the type of H. This dependency of the case analysis in the third argument of :g:`eq` is expressed by the identifier :g:`z` in the return type. Finally, the third subcase is a combination of the first and second -subcase. In particular, it only applies to pattern-matching on terms in +subcase. In particular, it only applies to pattern matching on terms in a type with annotations. For this third subcase, both the clauses ``as`` and ``in`` are available. @@ -467,6 +490,10 @@ There are specific notations for case analysis on types with one or two constructors: ``if … then … else …`` and ``let (…,…) := … in …`` (see Sections :ref:`if-then-else` and :ref:`irrefutable-patterns`). +.. index:: + single: fix + single: cofix + Recursive functions ------------------- @@ -916,7 +943,7 @@ Parametrized inductive types sort for the inductive definition and will produce a less convenient rule for case elimination. -.. opt:: Uniform Inductive Parameters +.. flag:: Uniform Inductive Parameters When this option is set (it is off by default), inductive definitions are abstracted over their parameters @@ -953,7 +980,7 @@ Variants The :cmd:`Variant` command is identical to the :cmd:`Inductive` command, except that it disallows recursive definition of types (for instance, lists cannot be defined using :cmd:`Variant`). No induction scheme is generated for - this variant, unless option :opt:`Nonrecursive Elimination Schemes` is on. + this variant, unless option :flag:`Nonrecursive Elimination Schemes` is on. .. exn:: The @num th argument of @ident must be @ident in @type. :undocumented: @@ -1099,7 +1126,7 @@ constructions. .. cmd:: Fixpoint @ident @binders {? {struct @ident} } {? : @type } := @term - This command allows defining functions by pattern-matching over inductive + This command allows defining functions by pattern matching over inductive objects using a fixed point construction. The meaning of this declaration is to define :token:`ident` a recursive function with arguments specified by the :token:`binders` such that :token:`ident` applied to arguments @@ -1302,7 +1329,7 @@ Chapter :ref:`Tactics`. The basic assertion command is: You are asserting a new statement while already being in proof editing mode. This feature, called nested proofs, is disabled by default. - To activate it, turn option :opt:`Nested Proofs Allowed` on. + To activate it, turn option :flag:`Nested Proofs Allowed` on. .. cmdv:: Lemma @ident {? @binders } : @type Remark @ident {? @binders } : @type @@ -1376,7 +1403,7 @@ using the keyword :cmd:`Qed`. .. note:: #. Several statements can be simultaneously asserted provided option - :opt:`Nested Proofs Allowed` was turned on. + :flag:`Nested Proofs Allowed` was turned on. #. Not only other assertions but any vernacular command can be given while in the process of proving a given assertion. In this case, the diff --git a/doc/sphinx/language/module-system.rst b/doc/sphinx/language/module-system.rst index e6a6736654..15fee91245 100644 --- a/doc/sphinx/language/module-system.rst +++ b/doc/sphinx/language/module-system.rst @@ -1,6 +1,3 @@ -.. include:: ../preamble.rst -.. include:: ../replaces.rst - .. _themodulesystem: The Module System diff --git a/doc/sphinx/license.rst b/doc/sphinx/license.rst new file mode 100644 index 0000000000..232b04211c --- /dev/null +++ b/doc/sphinx/license.rst @@ -0,0 +1,4 @@ +This material (the Coq Reference Manual) may be distributed only subject to the +terms and conditions set forth in the Open Publication License, v1.0 or later +(the latest version is presently available at +http://www.opencontent.org/openpub). Options A and B are not elected. diff --git a/doc/sphinx/practical-tools/coq-commands.rst b/doc/sphinx/practical-tools/coq-commands.rst index 9498f37c7e..343ca9ed7d 100644 --- a/doc/sphinx/practical-tools/coq-commands.rst +++ b/doc/sphinx/practical-tools/coq-commands.rst @@ -1,5 +1,3 @@ -.. include:: ../replaces.rst - .. _thecoqcommands: The |Coq| commands diff --git a/doc/sphinx/practical-tools/coqide.rst b/doc/sphinx/practical-tools/coqide.rst index bc6a074a27..9455228e7d 100644 --- a/doc/sphinx/practical-tools/coqide.rst +++ b/doc/sphinx/practical-tools/coqide.rst @@ -1,5 +1,3 @@ -.. include:: ../replaces.rst - .. _coqintegrateddevelopmentenvironment: |Coq| Integrated Development Environment @@ -263,7 +261,7 @@ for the ∀ symbol. A list of symbol codes is available at An alternative method which does not require to know the hexadecimal code of the character is to use an Input Method Editor. On POSIX systems (Linux distributions, BSD variants and MacOS X), you can -use `uim` version 1.6 or later which provides a :math:`\LaTeX`-style input +use `uim` version 1.6 or later which provides a LaTeX-style input method. To configure uim, execute uim-pref-gtk as your regular user. In the diff --git a/doc/sphinx/practical-tools/utilities.rst b/doc/sphinx/practical-tools/utilities.rst index 218a19c2e5..5d300c3d6d 100644 --- a/doc/sphinx/practical-tools/utilities.rst +++ b/doc/sphinx/practical-tools/utilities.rst @@ -1,5 +1,3 @@ -.. include:: ../replaces.rst - .. _utilities: --------------------- @@ -268,13 +266,12 @@ file timing data: + ``print-pretty-timed-diff`` - this target builds a table of timing - changes between two compilations; run ``make make-pretty-timed-before`` to - build the log of the “before” times, and run ``make make-pretty-timed- - after`` to build the log of the “after” times. The table is printed on - the command line, and stored in ``time-of-build-both.log``. This target is - most useful for profiling the difference between two commits to a - repo. + this target builds a table of timing changes between two compilations; run + ``make make-pretty-timed-before`` to build the log of the “before” times, + and run ``make make-pretty-timed-after`` to build the log of the “after” + times. The table is printed on the command line, and stored in + ``time-of-build-both.log``. This target is most useful for profiling the + difference between two commits in a repository. .. note:: This target requires ``python`` to build the table. @@ -331,7 +328,9 @@ line timing data: Chars 163 - 208 [Definition~foo1~:=~Eval~comp~i...] 0.239 secs (0.236u,0.s) + ``print-pretty-single-time-diff`` + :: + print-pretty-single-time-diff BEFORE=path/to/file.v.before-timing AFTER=path/to/file.v.after-timing this target will make a sorted table of the per-line timing differences diff --git a/doc/sphinx/preamble.rst b/doc/sphinx/preamble.rst deleted file mode 100644 index 395f558a85..0000000000 --- a/doc/sphinx/preamble.rst +++ /dev/null @@ -1,92 +0,0 @@ -.. preamble:: - - \[ - \newcommand{\alors}{\textsf{then}} - \newcommand{\alter}{\textsf{alter}} - \newcommand{\as}{\kw{as}} - \newcommand{\Assum}[3]{\kw{Assum}(#1)(#2:#3)} - \newcommand{\bool}{\textsf{bool}} - \newcommand{\case}{\kw{case}} - \newcommand{\conc}{\textsf{conc}} - \newcommand{\cons}{\textsf{cons}} - \newcommand{\consf}{\textsf{consf}} - \newcommand{\conshl}{\textsf{cons\_hl}} - \newcommand{\Def}[4]{\kw{Def}(#1)(#2:=#3:#4)} - \newcommand{\emptyf}{\textsf{emptyf}} - \newcommand{\End}{\kw{End}} - \newcommand{\endkw}{\kw{end}} - \newcommand{\EqSt}{\textsf{EqSt}} - \newcommand{\even}{\textsf{even}} - \newcommand{\evenO}{\textsf{even_O}} - \newcommand{\evenS}{\textsf{even_S}} - \newcommand{\false}{\textsf{false}} - \newcommand{\filter}{\textsf{filter}} - \newcommand{\Fix}{\kw{Fix}} - \newcommand{\fix}{\kw{fix}} - \newcommand{\for}{\textsf{for}} - \newcommand{\forest}{\textsf{forest}} - \newcommand{\from}{\textsf{from}} - \newcommand{\Functor}{\kw{Functor}} - \newcommand{\haslength}{\textsf{has\_length}} - \newcommand{\hd}{\textsf{hd}} - \newcommand{\ident}{\textsf{ident}} - \newcommand{\In}{\kw{in}} - \newcommand{\Ind}[4]{\kw{Ind}[#2](#3:=#4)} - \newcommand{\ind}[3]{\kw{Ind}~[#1]\left(#2\mathrm{~:=~}#3\right)} - \newcommand{\Indp}[5]{\kw{Ind}_{#5}(#1)[#2](#3:=#4)} - \newcommand{\Indpstr}[6]{\kw{Ind}_{#5}(#1)[#2](#3:=#4)/{#6}} - \newcommand{\injective}{\kw{injective}} - \newcommand{\kw}[1]{\textsf{#1}} - \newcommand{\lb}{\lambda} - \newcommand{\length}{\textsf{length}} - \newcommand{\letin}[3]{\kw{let}~#1:=#2~\kw{in}~#3} - \newcommand{\List}{\textsf{list}} - \newcommand{\lra}{\longrightarrow} - \newcommand{\Match}{\kw{match}} - \newcommand{\Mod}[3]{{\kw{Mod}}({#1}:{#2}\,\zeroone{:={#3}})} - \newcommand{\ModA}[2]{{\kw{ModA}}({#1}=={#2})} - \newcommand{\ModS}[2]{{\kw{Mod}}({#1}:{#2})} - \newcommand{\ModType}[2]{{\kw{ModType}}({#1}:={#2})} - \newcommand{\mto}{.\;} - \newcommand{\Nat}{\mathbb{N}} - \newcommand{\nat}{\textsf{nat}} - \newcommand{\Nil}{\textsf{nil}} - \newcommand{\nilhl}{\textsf{nil\_hl}} - \newcommand{\nO}{\textsf{O}} - \newcommand{\node}{\textsf{node}} - \newcommand{\nS}{\textsf{S}} - \newcommand{\odd}{\textsf{odd}} - \newcommand{\oddS}{\textsf{odd_S}} - \newcommand{\ovl}[1]{\overline{#1}} - \newcommand{\Pair}{\textsf{pair}} - \newcommand{\Prod}{\textsf{prod}} - \newcommand{\Prop}{\textsf{Prop}} - \newcommand{\return}{\kw{return}} - \newcommand{\Set}{\textsf{Set}} - \newcommand{\si}{\textsf{if}} - \newcommand{\sinon}{\textsf{else}} - \newcommand{\Sort}{\cal S} - \newcommand{\Str}{\textsf{Stream}} - \newcommand{\Struct}{\kw{Struct}} - \newcommand{\subst}[3]{#1\{#2/#3\}} - \newcommand{\tl}{\textsf{tl}} - \newcommand{\tree}{\textsf{tree}} - \newcommand{\true}{\textsf{true}} - \newcommand{\Type}{\textsf{Type}} - \newcommand{\unfold}{\textsf{unfold}} - \newcommand{\WEV}[3]{\mbox{$#1[] \vdash #2 \lra #3$}} - \newcommand{\WEVT}[3]{\mbox{$#1[] \vdash #2 \lra$}\\ \mbox{$ #3$}} - \newcommand{\WF}[2]{{\cal W\!F}(#1)[#2]} - \newcommand{\WFE}[1]{\WF{E}{#1}} - \newcommand{\WFT}[2]{#1[] \vdash {\cal W\!F}(#2)} - \newcommand{\WFTWOLINES}[2]{{\cal W\!F}\begin{array}{l}(#1)\\\mbox{}[{#2}]\end{array}} - \newcommand{\with}{\kw{with}} - \newcommand{\WS}[3]{#1[] \vdash #2 <: #3} - \newcommand{\WSE}[2]{\WS{E}{#1}{#2}} - \newcommand{\WT}[4]{#1[#2] \vdash #3 : #4} - \newcommand{\WTE}[3]{\WT{E}{#1}{#2}{#3}} - \newcommand{\WTEG}[2]{\WTE{\Gamma}{#1}{#2}} - \newcommand{\WTM}[3]{\WT{#1}{}{#2}{#3}} - \newcommand{\zeroone}[1]{[{#1}]} - \newcommand{\zeros}{\textsf{zeros}} - \] diff --git a/doc/sphinx/proof-engine/detailed-tactic-examples.rst b/doc/sphinx/proof-engine/detailed-tactic-examples.rst index 72dd79d930..bd16b70d02 100644 --- a/doc/sphinx/proof-engine/detailed-tactic-examples.rst +++ b/doc/sphinx/proof-engine/detailed-tactic-examples.rst @@ -417,218 +417,8 @@ the optional tactic of the ``Hint Rewrite`` command. Qed. -.. _quote: - -quote ------ - -The tactic ``quote`` allows using Barendregt’s so-called 2-level approach -without writing any ML code. Suppose you have a language ``L`` of -'abstract terms' and a type ``A`` of 'concrete terms' and a function ``f : L -> A``. -If ``L`` is a simple inductive datatype and ``f`` a simple fixpoint, -``quote f`` will replace the head of current goal by a convertible term of -the form ``(f t)``. ``L`` must have a constructor of type: ``A -> L``. - -Here is an example: - -.. coqtop:: in reset - - Require Import Quote. - -.. coqtop:: all - - Parameters A B C : Prop. - -.. coqtop:: all - - Inductive formula : Type := - | f_and : formula -> formula -> formula (* binary constructor *) - | f_or : formula -> formula -> formula - | f_not : formula -> formula (* unary constructor *) - | f_true : formula (* 0-ary constructor *) - | f_const : Prop -> formula (* constructor for constants *). - -.. coqtop:: all - - Fixpoint interp_f (f:formula) : Prop := - match f with - | f_and f1 f2 => interp_f f1 /\ interp_f f2 - | f_or f1 f2 => interp_f f1 \/ interp_f f2 - | f_not f1 => ~ interp_f f1 - | f_true => True - | f_const c => c - end. - -.. coqtop:: all - - Goal A /\ (A \/ True) /\ ~ B /\ (A <-> A). - -.. coqtop:: all - - quote interp_f. - -The algorithm to perform this inversion is: try to match the term with -right-hand sides expression of ``f``. If there is a match, apply the -corresponding left-hand side and call yourself recursively on sub- -terms. If there is no match, we are at a leaf: return the -corresponding constructor (here ``f_const``) applied to the term. - -When ``quote`` is not able to perform inversion properly, it will error out with -:exn:`quote: not a simple fixpoint`. - - -Introducing variables map -~~~~~~~~~~~~~~~~~~~~~~~~~ - -The normal use of quote is to make proofs by reflection: one defines a -function ``simplify : formula -> formula`` and proves a theorem -``simplify_ok: (f:formula)(interp_f (simplify f)) -> (interp_f f)``. Then, -one can simplify formulas by doing: - -.. coqtop:: in - - quote interp_f. - apply simplify_ok. - compute. - -But there is a problem with leafs: in the example above one cannot -write a function that implements, for example, the logical -simplifications :math:`A \wedge A \rightarrow A` or :math:`A \wedge -\lnot A \rightarrow \mathrm{False}`. This is because ``Prop`` is -impredicative. - -It is better to use that type of formulas: - -.. coqtop:: in reset - - Require Import Quote. - -.. coqtop:: in - - Parameters A B C : Prop. - -.. coqtop:: all - - Inductive formula : Set := - | f_and : formula -> formula -> formula - | f_or : formula -> formula -> formula - | f_not : formula -> formula - | f_true : formula - | f_atom : index -> formula. - -``index`` is defined in module ``Quote``. Equality on that type is -decidable so we are able to simplify :math:`A \wedge A` into :math:`A` -at the abstract level. - -When there are variables, there are bindings, and ``quote`` also -provides a type ``(varmap A)`` of bindings from index to any set -``A``, and a function ``varmap_find`` to search in such maps. The -interpretation function also has another argument, a variables map: - -.. coqtop:: all - - Fixpoint interp_f (vm:varmap Prop) (f:formula) {struct f} : Prop := - match f with - | f_and f1 f2 => interp_f vm f1 /\ interp_f vm f2 - | f_or f1 f2 => interp_f vm f1 \/ interp_f vm f2 - | f_not f1 => ~ interp_f vm f1 - | f_true => True - | f_atom i => varmap_find True i vm - end. - -``quote`` handles this second case properly: - -.. coqtop:: all - - Goal A /\ (B \/ A) /\ (A \/ ~ B). - -.. coqtop:: all - - quote interp_f. - -It builds ``vm`` and ``t`` such that ``(f vm t)`` is convertible with the -conclusion of current goal. - - -Combining variables and constants -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -One can have both variables and constants in abstracts terms; for -example, this is the case for the :tacn:`ring` tactic. Then one must provide to -``quote`` a list of *constructors of constants*. For example, if the list -is ``[O S]`` then closed natural numbers will be considered as constants -and other terms as variables. - -.. coqtop:: in reset - - Require Import Quote. - -.. coqtop:: in - - Parameters A B C : Prop. - -.. coqtop:: in - - Inductive formula : Type := - | f_and : formula -> formula -> formula - | f_or : formula -> formula -> formula - | f_not : formula -> formula - | f_true : formula - | f_const : Prop -> formula (* constructor for constants *) - | f_atom : index -> formula. - -.. coqtop:: in - - Fixpoint interp_f (vm:varmap Prop) (f:formula) {struct f} : Prop := - match f with - | f_and f1 f2 => interp_f vm f1 /\ interp_f vm f2 - | f_or f1 f2 => interp_f vm f1 \/ interp_f vm f2 - | f_not f1 => ~ interp_f vm f1 - | f_true => True - | f_const c => c - | f_atom i => varmap_find True i vm - end. - -.. coqtop:: in - - Goal A /\ (A \/ True) /\ ~ B /\ (C <-> C). - -.. coqtop:: all - - quote interp_f [ A B ]. - - -.. coqtop:: all - - Undo. - -.. coqtop:: all - - quote interp_f [ B C iff ]. - -.. warning:: - Since functional inversion is undecidable in the general case, - don’t expect miracles from it! - -.. tacv:: quote @ident in @term using @tactic - - ``tactic`` must be a functional tactic (starting with ``fun x =>``) and - will be called with the quoted version of term according to ``ident``. - -.. tacv:: quote @ident [{+ @ident}] in @term using @tactic - - Same as above, but will use the additional ``ident`` list to chose - which subterms are constants (see above). - -.. seealso:: - Comments from the source file ``plugins/quote/quote.ml`` - -.. seealso:: - The :tacn:`ring` tactic. - - Using the tactic language ---------------------------- +------------------------- About the cardinality of the set of natural numbers diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index 7608ea7245..edd83b7cee 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -1,6 +1,3 @@ -.. include:: ../preamble.rst -.. include:: ../replaces.rst - .. _ltac: The tactic language @@ -27,14 +24,14 @@ represent respectively the natural and integer numbers, the authorized identificators and qualified names, Coq terms and patterns and all the atomic tactics described in Chapter :ref:`tactics`. The syntax of :token:`cpattern` is the same as that of terms, but it is extended with pattern matching -metavariables. In :token:`cpattern`, a pattern-matching metavariable is +metavariables. In :token:`cpattern`, a pattern matching metavariable is represented with the syntax :g:`?id` where :g:`id` is an :token:`ident`. The notation :g:`_` can also be used to denote metavariable whose instance is irrelevant. In the notation :g:`?id`, the identifier allows us to keep instantiations and to make constraints whereas :g:`_` shows that we are not -interested in what will be matched. On the right hand side of pattern-matching +interested in what will be matched. On the right hand side of pattern matching clauses, the named metavariables are used without the question mark prefix. There -is also a special notation for second-order pattern-matching problems: in an +is also a special notation for second-order pattern matching problems: in an applicative pattern of the form :g:`@?id id1 … idn`, the variable id matches any complex expression with (possible) dependencies in the variables :g:`id1 … idn` and returns a functional term of the form :g:`fun id1 … idn => term`. @@ -107,7 +104,7 @@ mode but it can also be used in toplevel definitions as shown below. : | solve [ `expr` | ... | `expr` ] : | idtac [ `message_token` ... `message_token`] : | fail [`natural`] [`message_token` ... `message_token`] - : | fresh | fresh `string` | fresh `qualid` + : | fresh [ `component` … `component` ] : | context `ident` [`term`] : | eval `redexpr` in `term` : | type of `term` @@ -125,6 +122,7 @@ mode but it can also be used in toplevel definitions as shown below. : | () : | `integer` : | ( `expr` ) + component : `string` | `qualid` message_token : `string` | `ident` | `integer` tacarg : `qualid` : | () @@ -716,6 +714,7 @@ Local definitions Local definitions can be done as follows: .. tacn:: let @ident__1 := @expr__1 {* with @ident__i := @expr__i} in @expr + :name: let ... := ... each :n:`@expr__i` is evaluated to :n:`v__i`, then, :n:`@expr` is evaluated by substituting :n:`v__i` to each occurrence of :n:`@ident__i`, for @@ -834,7 +833,7 @@ We can carry out pattern matching on terms with: matching subterm is tried. If no further subterm matches, the next clause is tried. Matching subterms are considered top-bottom and from left to right (with respect to the raw printing obtained by setting option - :opt:`Printing All`). + :flag:`Printing All`). .. example:: @@ -946,12 +945,10 @@ expression returns an identifier: .. tacn:: fresh {* component} It evaluates to an identifier unbound in the goal. This fresh identifier - is obtained by concatenating the value of the :n:`@component`s (each of them + is obtained by concatenating the value of the :n:`@component`\ s (each of them is, either a :n:`@qualid` which has to refer to a (unqualified) name, or directly a name denoted by a :n:`@string`). - .. I don't understand this component thing. Couldn't we give the grammar? - If the resulting name is already used, it is padded with a number so that it becomes fresh. If no component is given, the name is a fresh derivative of the name ``H``. @@ -1190,6 +1187,7 @@ Info trace not printed. .. opt:: Info Level @num + :name: Info Level This option is an alternative to the :cmd:`Info` command. @@ -1200,7 +1198,7 @@ Info trace Interactive debugger ~~~~~~~~~~~~~~~~~~~~ -.. opt:: Ltac Debug +.. flag:: Ltac Debug This option governs the step-by-step debugger that comes with the |Ltac| interpreter @@ -1228,7 +1226,7 @@ following: A non-interactive mode for the debugger is available via the option: -.. opt:: Ltac Batch Debug +.. flag:: Ltac Batch Debug This option has the effect of presenting a newline at every prompt, when the debugger is on. The debug log thus created, which does not require @@ -1249,7 +1247,7 @@ indicates the time spent in a tactic depending on its calling context. Thus it allows to locate the part of a tactic definition that contains the performance issue. -.. opt:: Ltac Profiling +.. flag:: Ltac Profiling This option enables and disables the profiler. @@ -1335,7 +1333,7 @@ performance issue. benchmarking purposes. You can also pass the ``-profile-ltac`` command line option to ``coqc``, which -turns the :opt:`Ltac Profiling` option on at the beginning of each document, +turns the :flag:`Ltac Profiling` option on at the beginning of each document, and performs a :cmd:`Show Ltac Profile` at the end. .. warning:: diff --git a/doc/sphinx/proof-engine/proof-handling.rst b/doc/sphinx/proof-engine/proof-handling.rst index b1e769c571..4b1b7719c5 100644 --- a/doc/sphinx/proof-engine/proof-handling.rst +++ b/doc/sphinx/proof-engine/proof-handling.rst @@ -1,4 +1,3 @@ -.. include:: ../replaces.rst .. _proofhandling: ------------------- @@ -113,7 +112,7 @@ list of assertion commands is given in :ref:`Assertions`. The command Aborts the editing of the proof named :token:`ident` (in case you have nested proofs). - .. seealso:: :opt:`Nested Proofs Allowed` + .. seealso:: :flag:`Nested Proofs Allowed` .. cmdv:: Abort All @@ -201,13 +200,14 @@ The following options modify the behavior of ``Proof using``. .. opt:: Default Proof Using "@expression" + :name: Default Proof Using Use :n:`@expression` as the default ``Proof using`` value. E.g. ``Set Default Proof Using "a b"`` will complete all ``Proof`` commands not followed by a ``using`` part with ``using a b``. -.. opt:: Suggest Proof Using +.. flag:: Suggest Proof Using When :cmd:`Qed` is performed, suggest a ``using`` annotation if the user did not provide one. @@ -442,13 +442,19 @@ The following example script illustrates all these features: You tried to apply a tactic but no goals were under focus. Using :n:`@bullet` is mandatory here. -.. exn:: No such goal. Try unfocusing with %{. +.. FIXME: the :noindex: below works around a Sphinx issue. + (https://github.com/sphinx-doc/sphinx/issues/4979) + It should be removed once that issue is fixed. + +.. exn:: No such goal. Try unfocusing with %}. + :noindex: You just finished a goal focused by ``{``, you must unfocus it with ``}``. Set Bullet Behavior ``````````````````` .. opt:: Bullet Behavior %( "None" %| "Strict Subproofs" %) + :name: Bullet Behavior This option controls the bullet behavior and can take two possible values: @@ -581,6 +587,7 @@ Controlling the effect of proof editing commands .. opt:: Hyps Limit @num + :name: Hyps Limit This option controls the maximum number of hypotheses displayed in goals after the application of a tactic. All the hypotheses remain usable @@ -589,7 +596,7 @@ Controlling the effect of proof editing commands available hypotheses. -.. opt:: Automatic Introduction +.. flag:: Automatic Introduction This option controls the way binders are handled in assertion commands such as :n:`Theorem @ident {? @binders} : @term`. When the @@ -601,7 +608,7 @@ Controlling the effect of proof editing commands has to be used to move the assumptions to the local context. -.. opt:: Nested Proofs Allowed +.. flag:: Nested Proofs Allowed When turned on (it is off by default), this option enables support for nested proofs: a new assertion command can be inserted before the current proof is diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index 7c3ea1a28c..52609546d5 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -1,5 +1,3 @@ -.. include:: ../replaces.rst - .. _thessreflectprooflanguage: ------------------------------ @@ -104,8 +102,8 @@ this corresponds to working in the following context: Unset Printing Implicit Defensive. .. seealso:: - :opt:`Implicit Arguments`, :opt:`Strict Implicit`, - :opt:`Printing Implicit Defensive` + :flag:`Implicit Arguments`, :flag:`Strict Implicit`, + :flag:`Printing Implicit Defensive` .. _compatibility_issues_ssr: @@ -444,11 +442,16 @@ not its name, one usually uses “arrow” abstractions for prenex arguments, or the ``(_ : term)`` syntax for inner arguments. In |SSR|, the latter can be replaced by the open syntax ``of term`` or (equivalently) ``& term``, which are both syntactically equivalent to a -``(_ : term)`` expression. +``(_ : term)`` expression. This feature almost behaves as the +following extension of the binder syntax: + +.. prodn:: + binder += & @term | of @term -For instance, the usual two-constructor polymorphic type list, i.e. -the one of the standard List library, can be defined by the following -declaration: +Caveat: ``& T`` and ``of T`` abbreviations have to appear at the end +of a binder list. For instance, the usual two-constructor polymorphic +type list, i.e. the one of the standard ``List`` library, can be +defined by the following declaration: .. example:: @@ -2698,7 +2701,7 @@ typeclass inference. No inference for ``t``. Unresolved instances are quantified in the (inferred) type of ``t`` and abstracted in ``t``. -.. opt:: SsrHave NoTCResolution +.. flag:: SsrHave NoTCResolution This option restores the behavior of |SSR| 1.4 and below (never resolve typeclasses). @@ -3862,7 +3865,7 @@ duplication of function arguments. These copies usually end up in types hidden by the implicit arguments machinery or by user-defined notations. In these situations computing the right occurrence numbers is very tedious because they must be counted on the goal as printed -after setting the Printing All flag. Moreover the resulting script is +after setting the :flag:`Printing All` flag. Moreover the resulting script is not really informative for the reader, since it refers to occurrence numbers he cannot easily see. @@ -5387,7 +5390,7 @@ Tacticals discharge :ref:`discharge_ssr` -.. prodn:: tactic += @tacitc => {+ @i_item } +.. prodn:: tactic += @tactic => {+ @i_item } introduction see :ref:`introduction_ssr` diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 62a482096c..f99c539251 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -1,6 +1,3 @@ -.. include:: ../preamble.rst -.. include:: ../replaces.rst - .. _tactics: Tactics @@ -51,7 +48,8 @@ specified, the default selector is used. tactic_invocation : toplevel_selector : tactic. : |tactic . -.. opt:: Default Goal Selector @toplevel_selector +.. opt:: Default Goal Selector "@toplevel_selector" + :name: Default Goal Selector This option controls the default selector, used when no selector is specified when applying a tactic. The initial value is 1, hence the @@ -127,7 +125,7 @@ that occurrences have to be selected in the hypotheses named :token:`ident`. If no numbers are given for hypothesis :token:`ident`, then all the occurrences of :token:`term` in the hypothesis are selected. If numbers are given, they refer to occurrences of :token:`term` when the term is printed -using option :opt:`Printing All`, counting from left to right. In particular, +using option :flag:`Printing All`, counting from left to right. In particular, occurrences of :token:`term` in implicit arguments (see :ref:`ImplicitArguments`) or coercions (see :ref:`Coercions`) are counted. @@ -451,7 +449,7 @@ Applying theorems ``forall A, ... -> A``. Excluding this kind of lemma can be avoided by setting the following option: -.. opt:: Universal Lemma Under Conjunction +.. flag:: Universal Lemma Under Conjunction This option, which preserves compatibility with versions of Coq prior to 8.4 is also available for :n:`apply @term in @ident` (see :tacn:`apply ... in`). @@ -476,7 +474,7 @@ Applying theorems :token:`ident`. Tuples are decomposed in a width-first left-to-right order (for instance if the type of :g:`H1` is :g:`A <-> B` and the type of :g:`H2` is :g:`A` then :g:`apply H1 in H2` transforms the type of :g:`H2` - into :g:`B`). The tactic :tacn:`apply` relies on first-order pattern-matching + into :g:`B`). The tactic :tacn:`apply` relies on first-order pattern matching with dependent types. .. exn:: Statement without assumptions. @@ -855,7 +853,7 @@ Managing the local context so that all the arguments of the i-th constructors of the corresponding inductive type are introduced can be controlled with the following option: - .. opt:: Bracketing Last Introduction Pattern + .. flag:: Bracketing Last Introduction Pattern Force completion, if needed, when the last introduction pattern is a disjunctive or conjunctive pattern (on by default). @@ -1298,7 +1296,7 @@ name of the variable (here :g:`n`) is chosen based on :g:`T`. This is equivalent to :n:`generalize @term` but it generalizes only over the specified occurrences of :n:`@term` (counting from left to right on the - expression printed using option :opt:`Printing All`). + expression printed using option :flag:`Printing All`). .. tacv:: generalize @term as @ident @@ -2041,14 +2039,14 @@ and an explanation of the underlying technique. to the number of new equalities. The original equality is erased if it corresponds to a hypothesis. - .. opt:: Structural Injection + .. flag:: Structural Injection This option ensure that :n:`injection @term` erases the original hypothesis and leaves the generated equalities in the context rather than putting them as antecedents of the current goal, as if giving :n:`injection @term as` (with an empty list of names). This option is off by default. - .. opt:: Keep Proof Equalities + .. flag:: Keep Proof Equalities By default, :tacn:`injection` only creates new equalities between :n:`@terms` whose type is in sort :g:`Type` or :g:`Set`, thus implementing a special @@ -2080,7 +2078,7 @@ and an explanation of the underlying technique. being processed. By default, no equalities are generated if they relate two proofs (i.e. equalities between :n:`@terms` whose type is in sort :g:`Prop`). This behavior can be turned off by using the option - :opt`Keep Proof Equalities`. + :flag`Keep Proof Equalities`. .. tacv:: inversion @num @@ -2590,7 +2588,7 @@ simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. context for which an equality of the form :n:`@ident = t` or :n:`t = @ident` or :n:`@ident := t` exists, with :n:`@ident` not occurring in ``t``. - .. opt:: Regular Subst Tactic + .. flag:: Regular Subst Tactic This option controls the behavior of :tacn:`subst`. When it is activated (it is by default), :tacn:`subst` also deals with the following corner cases: @@ -2725,7 +2723,7 @@ the conversion in hypotheses :n:`{+ @ident}`. :math:`\beta` (reduction of functional application), :math:`\delta` (unfolding of transparent constants, see :ref:`vernac-controlling-the-reduction-strategies`), :math:`\iota` (reduction of - pattern-matching over a constructed term, and unfolding of :g:`fix` and + pattern matching over a constructed term, and unfolding of :g:`fix` and :g:`cofix` expressions) and :math:`\zeta` (contraction of local definitions), the flags are either ``beta``, ``delta``, ``match``, ``fix``, ``cofix``, ``iota`` or ``zeta``. The ``iota`` flag is a shorthand for ``match``, ``fix`` @@ -2808,12 +2806,13 @@ the conversion in hypotheses :n:`{+ @ident}`. compilation cost is higher, so it is worth using only for intensive computations. - .. opt:: NativeCompute Profiling + .. flag:: NativeCompute Profiling On Linux, if you have the ``perf`` profiler installed, this option makes it possible to profile ``native_compute`` evaluations. - .. opt:: NativeCompute Profile Filename + .. opt:: NativeCompute Profile Filename @string + :name: NativeCompute Profile Filename This option specifies the profile output; the default is ``native_compute_profile.data``. The actual filename used @@ -2824,7 +2823,7 @@ the conversion in hypotheses :n:`{+ @ident}`. on the profile file to see the results. Consult the ``perf`` documentation for more details. -.. opt:: Debug Cbv +.. flag:: Debug Cbv This option makes :tacn:`cbv` (and its derivative :tacn:`compute`) print information about the constants it encounters and the unfolding decisions it @@ -2991,7 +2990,7 @@ the conversion in hypotheses :n:`{+ @ident}`. This applies ``simpl`` only to the :n:`{+ @num}` applicative subterms whose head occurrence is :n:`@qualid` (or :n:`@string`). -.. opt:: Debug RAKAM +.. flag:: Debug RAKAM This option makes :tacn:`cbn` print various debugging information. ``RAKAM`` is the Refolding Algebraic Krivine Abstract Machine. @@ -3198,10 +3197,11 @@ hints of the database named core. The following options enable printing of informative or debug information for the :tacn:`auto` and :tacn:`trivial` tactics: -.. opt:: Info Auto -.. opt:: Debug Auto -.. opt:: Info Trivial -.. opt:: Debug Trivial +.. flag:: Info Auto + Debug Auto + Info Trivial + Debug Trivial + :undocumented: .. seealso:: :ref:`The Hints Databases for auto and eauto <thehintsdatabasesforautoandeauto>` @@ -3231,8 +3231,9 @@ Note that ``ex_intro`` should be declared as a hint. :tacn:`eauto` also obeys the following options: -.. opt:: Info Eauto -.. opt:: Debug Eauto +.. flag:: Info Eauto + Debug Eauto + :undocumented: .. seealso:: :ref:`The Hints Databases for auto and eauto <thehintsdatabasesforautoandeauto>` @@ -3566,7 +3567,7 @@ The general command to add a hint to some databases :n:`{+ @ident}` is .. note:: - One can use an ``Extern`` hint with no pattern to do pattern-matching on + One can use an ``Extern`` hint with no pattern to do pattern matching on hypotheses using ``match goal`` with inside the tactic. @@ -3862,7 +3863,7 @@ some incompatibilities. ``Empty_set``, ``unit``, ``True``, :tacn:`dintuition` also recognizes all inductive types with one constructor and no indices, i.e. record-style connectives. -.. opt:: Intuition Negation Unfolding +.. flag:: Intuition Negation Unfolding Controls whether :tacn:`intuition` unfolds inner negations which do not need to be unfolded. This option is on by default. @@ -3891,6 +3892,7 @@ usual logical connectives but instead may reason about any first-order class inductive definition. .. opt:: Firstorder Solver @tactic + :name: Firstorder Solver The default tactic used by :tacn:`firstorder` when no rule applies is :g:`auto with *`, it can be reset locally or globally using this option. @@ -3919,6 +3921,7 @@ inductive definition. This combines the effects of the different variants of :tacn:`firstorder`. .. opt:: Firstorder Depth @num + :name: Firstorder Depth This option controls the proof-search depth bound. @@ -3981,7 +3984,7 @@ match against it. additional arguments can be given to congruence by filling in the holes in the terms given in the error message, using the :tacn:`congruence with` variant described above. -.. opt:: Congruence Verbose +.. flag:: Congruence Verbose This option makes :tacn:`congruence` print debug information. @@ -4217,26 +4220,6 @@ available after a ``Require Import FunInd``. functional inversion, this variant allows choosing which :n:`@qualid` is inverted. -.. tacn:: quote @ident - :name: quote - -This kind of inversion has nothing to do with the tactic :tacn:`inversion` -above. This tactic does :g:`change (@ident t)`, where `t` is a term built in -order to ensure the convertibility. In other words, it does inversion of the -function :n:`@ident`. This function must be a fixpoint on a simple recursive -datatype: see :ref:`quote` for the full details. - - -.. exn:: quote: not a simple fixpoint. - - Happens when quote is not able to perform inversion properly. - - -.. tacv:: quote @ident {* @ident} - - All terms that are built only with :n:`{* @ident}` will be considered by quote - as constants rather than variables. - Classical tactics ----------------- diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index 584193b9c6..837d3f10a2 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -1,6 +1,3 @@ -.. include:: ../preamble.rst -.. include:: ../replaces.rst - .. _vernacularcommands: Vernacular commands @@ -78,145 +75,106 @@ Displaying Flags, Options and Tables ----------------------------- -|Coq| configurability is based on flags (e.g. :opt:`Printing All`), options -(e.g. :opt:`Printing Width`), or tables (e.g. :cmd:`Add Printing Record`). The -names of flags, options and tables are made of non-empty sequences of -identifiers (conventionally with capital initial letter). The general commands -handling flags, options and tables are given below. - -.. TODO : flag is not a syntax entry - -.. cmd:: Set @flag - - This command switches :n:`@flag` on. The original state of :n:`@flag` - is restored when the current module ends. - - .. cmdv:: Local Set @flag - - This command switches :n:`@flag` on. The original state - of :n:`@flag` is restored when the current *section* ends. - - .. cmdv:: Global Set @flag - - This command switches :n:`@flag` on. The original state - of :n:`@flag` is *not* restored at the end of the module. Additionally, if - set in a file, :n:`@flag` is switched on when the file is `Require`-d. +Coq has many settings to control its behavior. Setting types include flags, options +and tables: - .. cmdv:: Export Set @flag +* A :production:`flag` has a boolean value, such as :flag:`Asymmetric Patterns`. +* An :production:`option` generally has a numeric or string value, such as :opt:`Firstorder Depth`. +* A :production:`table` contains a set of strings or qualids. +* In addition, some commands provide settings, such as :cmd:`Extraction Language OCaml`. - This command switches :n:`@flag` on. The original state - of :n:`@flag` is restored at the end of the current module, but :n:`@flag` - is switched on when this module is imported. +.. FIXME Convert `Extraction Language OCaml` to an option. +Flags, options and tables are identified by a series of identifiers, each with an initial +capital letter. -.. cmd:: Unset @flag +.. cmd:: {? Local | Global | Export } Set @flag + :name: Set - This command switches :n:`@flag` off. The original state of - :n:`@flag` is restored when the current module ends. + Sets :token:`flag` on. Scoping qualifiers are + described :ref:`here <set_unset_scope_qualifiers>`. - .. cmdv:: Local Unset @flag - - This command switches :n:`@flag` off. The original - state of :n:`@flag` is restored when the current *section* ends. - - .. cmdv:: Global Unset @flag - - This command switches :n:`@flag` off. The original - state of :n:`@flag` is *not* restored at the end of the module. Additionally, - if set in a file, :n:`@flag` is switched off when the file is `Require`-d. - - .. cmdv:: Export Unset @flag - - This command switches :n:`@flag` off. The original state - of :n:`@flag` is restored at the end of the current module, but :n:`@flag` - is switched off when this module is imported. +.. cmd:: {? Local | Global | Export } Unset @flag + :name: Unset + Sets :token:`flag` off. Scoping qualifiers are + described :ref:`here <set_unset_scope_qualifiers>`. .. cmd:: Test @flag - This command prints whether :n:`@flag` is on or off. - - -.. cmd:: Set @option @value + Prints the current value of :token:`flag`. - This command sets :n:`@option` to :n:`@value`. The original value of ` option` is - restored when the current module ends. - .. TODO : option and value are not syntax entries +.. cmd:: {? Local | Global | Export } Set @option ( @num | @string ) + :name: Set @option - .. cmdv:: Local Set @option @value + Sets :token:`option` to the specified value. Scoping qualifiers are + described :ref:`here <set_unset_scope_qualifiers>`. - This command sets :n:`@option` to :n:`@value`. The - original value of :n:`@option` is restored at the end of the module. +.. cmd:: {? Local | Global | Export } Unset @option + :name: Unset @option - .. cmdv:: Global Set @option @value + Sets :token:`option` to its default value. Scoping qualifiers are + described :ref:`here <set_unset_scope_qualifiers>`. - This command sets :n:`@option` to :n:`@value`. The - original value of :n:`@option` is *not* restored at the end of the module. - Additionally, if set in a file, :n:`@option` is set to value when the file - is `Require`-d. - - .. cmdv:: Export Set @option - - This command set :n:`@option` to :n:`@value`. The original state - of :n:`@option` is restored at the end of the current module, but :n:`@option` - is set to :n:`@value` when this module is imported. - - -.. cmd:: Unset @option - - This command turns off :n:`@option`. - - .. cmdv:: Local Unset @option +.. cmd:: Test @option - This command turns off :n:`@option`. The original state of :n:`@option` - is restored when the current *section* ends. + Prints the current value of :token:`option`. - .. cmdv:: Global Unset @option +.. cmd:: Print Options - This command turns off :n:`@option`. The original state of :n:`@option` - is *not* restored at the end of the module. Additionally, if unset in a file, - :n:`@option` is reset to its default value when the file is `Require`-d. + Prints the current value of all flags and options, and the names of all tables. - .. cmdv:: Export Unset @option - This command turns off :n:`@option`. The original state of :n:`@option` - is restored at the end of the current module, but :n:`@option` is set to - its default value when this module is imported. +.. cmd:: Add @table ( @string | @qualid ) + :name: Add @table + Adds the specified value to :token:`table`. -.. cmd:: Test @option +.. cmd:: Remove @table ( @string | @qualid ) + :name: Remove @table - This command prints the current value of :n:`@option`. + Removes the specified value from :token:`table`. +.. cmd:: Test @table for ( @string | @qualid ) + :name: Test @table for -.. TODO : table is not a syntax entry + Reports whether :token:`table` contains the specified value. -.. cmd:: Add @table @value - :name: Add `table` `value` +.. cmd:: Print Table @table + :name: Print Table @table -.. cmd:: Remove @table @value - :name: Remove `table` `value` + Prints the values in :token:`table`. -.. cmd:: Test @table @value - :name: Test `table` `value` +.. cmd:: Test @table -.. cmd:: Test @table for @value - :name: Test `table` for `value` + A synonym for :cmd:`Print Table @table`. -.. cmd:: Print Table @table +.. cmd:: Print Tables -These are general commands for tables. + A synonym for :cmd:`Print Options`. +.. _set_unset_scope_qualifiers: -.. cmd:: Print Options +Scope qualifiers for :cmd:`Set` and :cmd:`Unset` +````````````````````````````````````````````````` - This command lists all available flags, options and tables. +:n:`{? Local | Global | Export }` - .. cmdv:: Print Tables +Flag and option settings can be global in scope or local to nested scopes created by +:cmd:`Module` and :cmd:`Section` commands. There are four alternatives: - This is a synonymous of :cmd:`Print Options`. +* no qualifier: the original setting is *not* restored at the end of the current module or section. +* **Local**: the setting is applied within the current scope. The original value of the option + or flag is restored at the end of the current module or section. +* **Global**: similar to no qualifier, the original setting is *not* restored at the end of the current + module or section. In addition, if the value is set in a file, then :cmd:`Require`-ing + the file sets the option. +* **Export**: similar to **Local**, the original value of the option or flag is restored at the + end of the current module or section. In addition, if the value is set in a file, then :cmd:`Import`-ing + the file sets the option. +Newly opened scopes inherit the current settings. .. _requests-to-the-environment: @@ -502,19 +460,16 @@ Requests to the environment .. note:: - .. cmd:: Add Search Blacklist @string + .. table:: Search Blacklist @string - For the ``Search``, ``SearchHead``, ``SearchPattern`` and ``SearchRewrite`` - queries, it is possible to globally filter the search results using this - command. A lemma whose fully-qualified name - contains any of the declared strings will be removed from the - search results. The default blacklisted substrings are ``_subproof`` and + Specifies a set of strings used to exclude lemmas from the results of :cmd:`Search`, + :cmd:`SearchHead`, :cmd:`SearchPattern` and :cmd:`SearchRewrite` queries. A lemma whose + fully-qualified name contains any of the strings will be excluded from the + search results. The default blacklisted substrings are ``_subterm``, ``_subproof`` and ``Private_``. - .. cmd:: Remove Search Blacklist @string - - This command allows expunging this blacklist. - + Use the :cmd:`Add @table` and :cmd:`Remove @table` commands to update the set of + blacklisted strings. .. cmd:: Locate @qualid @@ -979,6 +934,7 @@ Quitting and debugging displayed. .. opt:: Default Timeout @num + :name: Default Timeout This option controls a default timeout for subsequent commands, as if they were passed to a :cmd:`Timeout` command. Commands already starting by a @@ -1003,11 +959,12 @@ Quitting and debugging Controlling display ----------------------- -.. opt:: Silent +.. flag:: Silent This option controls the normal displaying. .. opt:: Warnings "{+, {? %( - %| + %) } @ident }" + :name: Warnings This option configures the display of warnings. It is experimental, and expects, between quotes, a comma-separated list of warning names or @@ -1017,7 +974,7 @@ Controlling display interpreted from left to right, so in case of an overlap, the flags on the right have higher priority, meaning that `A,-A` is equivalent to `-A`. -.. opt:: Search Output Name Only +.. flag:: Search Output Name Only This option restricts the output of search commands to identifier names; turning it on causes invocations of :cmd:`Search`, :cmd:`SearchHead`, @@ -1038,7 +995,7 @@ Controlling display printing. Beyond this depth, display of subterms is replaced by dots. At the time of writing this documentation, the default value is 50. -.. opt:: Printing Compact Contexts +.. flag:: Printing Compact Contexts This option controls the compact display mode for goals contexts. When on, the printer tries to reduce the vertical size of goals contexts by putting @@ -1046,13 +1003,13 @@ Controlling display does not exceed the printing width (see :opt:`Printing Width`). At the time of writing this documentation, it is off by default. -.. opt:: Printing Unfocused +.. flag:: Printing Unfocused This option controls whether unfocused goals are displayed. Such goals are created by focusing other goals with bullets (see :ref:`bullets` or :ref:`curly braces <curly-braces>`). It is off by default. -.. opt:: Printing Dependent Evars Line +.. flag:: Printing Dependent Evars Line This option controls the printing of the “(dependent evars: …)” line when ``-emacs`` is passed. diff --git a/doc/sphinx/replaces.rst b/doc/sphinx/refman-preamble.rst index 28a04f90ce..c662028773 100644 --- a/doc/sphinx/replaces.rst +++ b/doc/sphinx/refman-preamble.rst @@ -1,4 +1,13 @@ -.. some handy replacements for common items +.. This file is automatically prepended to all other files using the ``rst_prolog`` option. + +.. only:: html + + .. This is included once per page in the HTML build, and a single time (in the + document's preamble) in the LaTeX one. + + .. preamble:: /refman-preamble.sty + +.. Some handy replacements for common items .. role:: smallcaps @@ -21,7 +30,7 @@ .. |class_2| replace:: `class`\ :math:`_{2}` .. |Coq| replace:: :smallcaps:`Coq` .. |CoqIDE| replace:: :smallcaps:`CoqIDE` -.. |eq_beta_delta_iota_zeta| replace:: `=`\ :math:`_{\small{\beta\delta\iota\zeta}}` +.. |eq_beta_delta_iota_zeta| replace:: `=`\ :math:`_{\beta\delta\iota\zeta}` .. |Gallina| replace:: :smallcaps:`Gallina` .. |ident_0| replace:: `ident`\ :math:`_{0}` .. |ident_1,1| replace:: `ident`\ :math:`_{1,1}` diff --git a/doc/sphinx/refman-preamble.sty b/doc/sphinx/refman-preamble.sty new file mode 100644 index 0000000000..b4fc608e47 --- /dev/null +++ b/doc/sphinx/refman-preamble.sty @@ -0,0 +1,88 @@ +\newcommand{\alors}{\textsf{then}} +\newcommand{\alter}{\textsf{alter}} +\newcommand{\as}{\kw{as}} +\newcommand{\Assum}[3]{\kw{Assum}(#1)(#2:#3)} +\newcommand{\bool}{\textsf{bool}} +\newcommand{\case}{\kw{case}} +\newcommand{\conc}{\textsf{conc}} +\newcommand{\cons}{\textsf{cons}} +\newcommand{\consf}{\textsf{consf}} +\newcommand{\conshl}{\textsf{cons\_hl}} +\newcommand{\Def}[4]{\kw{Def}(#1)(#2:=#3:#4)} +\newcommand{\emptyf}{\textsf{emptyf}} +\newcommand{\End}{\kw{End}} +\newcommand{\kwend}{\kw{end}} +\newcommand{\EqSt}{\textsf{EqSt}} +\newcommand{\even}{\textsf{even}} +\newcommand{\evenO}{\textsf{even}_\textsf{O}} +\newcommand{\evenS}{\textsf{even}_\textsf{S}} +\newcommand{\false}{\textsf{false}} +\newcommand{\filter}{\textsf{filter}} +\newcommand{\Fix}{\kw{Fix}} +\newcommand{\fix}{\kw{fix}} +\newcommand{\for}{\textsf{for}} +\newcommand{\forest}{\textsf{forest}} +\newcommand{\from}{\textsf{from}} +\newcommand{\Functor}{\kw{Functor}} +\newcommand{\haslength}{\textsf{has\_length}} +\newcommand{\hd}{\textsf{hd}} +\newcommand{\ident}{\textsf{ident}} +\newcommand{\In}{\kw{in}} +\newcommand{\Ind}[4]{\kw{Ind}[#2](#3:=#4)} +\newcommand{\ind}[3]{\kw{Ind}~[#1]\left(#2\mathrm{~:=~}#3\right)} +\newcommand{\Indp}[5]{\kw{Ind}_{#5}(#1)[#2](#3:=#4)} +\newcommand{\Indpstr}[6]{\kw{Ind}_{#5}(#1)[#2](#3:=#4)/{#6}} +\newcommand{\injective}{\kw{injective}} +\newcommand{\kw}[1]{\textsf{#1}} +\newcommand{\lb}{\lambda} +\newcommand{\length}{\textsf{length}} +\newcommand{\letin}[3]{\kw{let}~#1:=#2~\kw{in}~#3} +\newcommand{\List}{\textsf{list}} +\newcommand{\lra}{\longrightarrow} +\newcommand{\Match}{\kw{match}} +\newcommand{\Mod}[3]{{\kw{Mod}}({#1}:{#2}\,\zeroone{:={#3}})} +\newcommand{\ModA}[2]{{\kw{ModA}}({#1}=={#2})} +\newcommand{\ModS}[2]{{\kw{Mod}}({#1}:{#2})} +\newcommand{\ModType}[2]{{\kw{ModType}}({#1}:={#2})} +\newcommand{\mto}{.\;} +\newcommand{\Nat}{\mathbb{N}} +\newcommand{\nat}{\textsf{nat}} +\newcommand{\Nil}{\textsf{nil}} +\newcommand{\nilhl}{\textsf{nil\_hl}} +\newcommand{\nO}{\textsf{O}} +\newcommand{\node}{\textsf{node}} +\newcommand{\nS}{\textsf{S}} +\newcommand{\odd}{\textsf{odd}} +\newcommand{\oddS}{\textsf{odd}_\textsf{S}} +\newcommand{\ovl}[1]{\overline{#1}} +\newcommand{\Pair}{\textsf{pair}} +\newcommand{\Prod}{\textsf{prod}} +\newcommand{\Prop}{\textsf{Prop}} +\newcommand{\return}{\kw{return}} +\newcommand{\Set}{\textsf{Set}} +\newcommand{\si}{\textsf{if}} +\newcommand{\sinon}{\textsf{else}} +\newcommand{\Sort}{\cal S} +\newcommand{\Str}{\textsf{Stream}} +\newcommand{\Struct}{\kw{Struct}} +\newcommand{\subst}[3]{#1\{#2/#3\}} +\newcommand{\tl}{\textsf{tl}} +\newcommand{\tree}{\textsf{tree}} +\newcommand{\true}{\textsf{true}} +\newcommand{\Type}{\textsf{Type}} +\newcommand{\unfold}{\textsf{unfold}} +\newcommand{\WEV}[3]{\mbox{$#1[] \vdash #2 \lra #3$}} +\newcommand{\WEVT}[3]{\mbox{$#1[] \vdash #2 \lra$}\\ \mbox{$ #3$}} +\newcommand{\WF}[2]{{\cal W\!F}(#1)[#2]} +\newcommand{\WFE}[1]{\WF{E}{#1}} +\newcommand{\WFT}[2]{#1[] \vdash {\cal W\!F}(#2)} +\newcommand{\WFTWOLINES}[2]{{\cal W\!F}\begin{array}{l}(#1)\\\mbox{}[{#2}]\end{array}} +\newcommand{\with}{\kw{with}} +\newcommand{\WS}[3]{#1[] \vdash #2 <: #3} +\newcommand{\WSE}[2]{\WS{E}{#1}{#2}} +\newcommand{\WT}[4]{#1[#2] \vdash #3 : #4} +\newcommand{\WTE}[3]{\WT{E}{#1}{#2}{#3}} +\newcommand{\WTEG}[2]{\WTE{\Gamma}{#1}{#2}} +\newcommand{\WTM}[3]{\WT{#1}{}{#2}{#3}} +\newcommand{\zeroone}[1]{[{#1}]} +\newcommand{\zeros}{\textsf{zeros}} diff --git a/doc/sphinx/user-extensions/proof-schemes.rst b/doc/sphinx/user-extensions/proof-schemes.rst index ab1edc0b27..59cad3bea2 100644 --- a/doc/sphinx/user-extensions/proof-schemes.rst +++ b/doc/sphinx/user-extensions/proof-schemes.rst @@ -103,26 +103,23 @@ induction for objects in type `identᵢ`. Automatic declaration of schemes ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. opt:: Elimination Schemes +.. flag:: Elimination Schemes - It is possible to deactivate the automatic declaration of the - induction principles when defining a new inductive type with the - ``Unset Elimination Schemes`` command. It may be reactivated at any time with - ``Set Elimination Schemes``. + Enables automatic declaration of induction principles when defining a new + inductive type. Defaults to on. -.. opt:: Nonrecursive Elimination Schemes +.. flag:: Nonrecursive Elimination Schemes - This option controls whether types declared with the keywords :cmd:`Variant` and - :cmd:`Record` get an automatic declaration of the induction principles. + Enables automatic declaration of induction principles for types declared with the :cmd:`Variant` and + :cmd:`Record` commands. Defaults to off. -.. opt:: Case Analysis Schemes +.. flag:: Case Analysis Schemes This flag governs the generation of case analysis lemmas for inductive types, - i.e. corresponding to the pattern-matching term alone and without fixpoint. + i.e. corresponding to the pattern matching term alone and without fixpoint. -.. opt:: Boolean Equality Schemes - -.. opt:: Decidable Equality Schemes +.. flag:: Boolean Equality Schemes + Decidable Equality Schemes These flags control the automatic declaration of those Boolean equalities (see the second variant of ``Scheme``). @@ -132,7 +129,7 @@ Automatic declaration of schemes You have to be careful with this option since Coq may now reject well-defined inductive types because it cannot compute a Boolean equality for them. -.. opt:: Rewriting Schemes +.. flag:: Rewriting Schemes This flag governs generation of equality-related schemes such as congruence. diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index b46382dbbf..705d67e6c6 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -1,5 +1,3 @@ -.. include:: ../replaces.rst - .. _syntaxextensionsandinterpretationscopes: Syntax extensions and interpretation scopes @@ -378,17 +376,14 @@ for records. Here are examples: Displaying information about notations ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. opt:: Printing Notations - - To deactivate the printing of all notations, use the command - ``Unset Printing Notations``. To reactivate it, use the command - ``Set Printing Notations``. +.. flag:: Printing Notations - The default is to use notations for printing terms wherever possible. + Controls whether to use notations for printing terms wherever possible. + Default is on. .. seealso:: - :opt:`Printing All` + :flag:`Printing All` To disable other elements in addition to notations. .. _locating-notations: @@ -949,16 +944,25 @@ Interpretation scopes can include an interpretation for numerals and strings. However, this is only made possible at the Objective Caml level. -See :ref:`above <NotationSyntax>` for the syntax of notations including the -possibility to declare them in a given scope. Here is a typical example which -declares the notation for conjunction in the scope ``type_scope``. +.. cmd:: Declare Scope @scope + + This adds a new scope named :n:`@scope`. Note that the initial + state of Coq declares by default the following interpretation scopes: + ``core_scope``, ``type_scope``, ``function_scope``, ``nat_scope``, + ``bool_scope``, ``list_scope``, ``int_scope``, ``uint_scope``. + +The syntax to associate a notation to a scope is given +:ref:`above <NotationSyntax>`. Here is a typical example which declares the +notation for conjunction in the scope ``type_scope``. .. coqtop:: in Notation "A /\ B" := (and A B) : type_scope. .. note:: A notation not defined in a scope is called a *lonely* - notation. + notation. No example of lonely notations can be found in the + initial state of Coq though. + Global interpretation rules for notations ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -977,10 +981,6 @@ interpretation: otherwise said, only the order of lonely interpretations and opening of scopes matters, and not the declaration of interpretations within a scope). -The initial state of Coq declares three interpretation scopes and no -lonely notations. These scopes, in opening order, are ``core_scope``, -``type_scope`` and ``nat_scope``. - .. cmd:: Open Scope @scope The command to add a scope to the interpretation scope stack is diff --git a/doc/sphinx/zebibliography.html.rst b/doc/sphinx/zebibliography.html.rst new file mode 100644 index 0000000000..756edd5482 --- /dev/null +++ b/doc/sphinx/zebibliography.html.rst @@ -0,0 +1,17 @@ +.. There are multiple issues with sphinxcontrib-bibtex that we have to work around: + - The list of cited entries is computed right after encountering + `.. bibliography`, so the file containing that command has to come last + alphabetically: + https://sphinxcontrib-bibtex.readthedocs.io/en/latest/usage.html#unresolved-citations-across-documents + - `.. bibliography::` puts the bibliography on its own page with its own + title in LaTeX, but includes it inline without a title in HTML: + https://sphinxcontrib-bibtex.readthedocs.io/en/latest/usage.html#mismatch-between-output-of-html-and-latex-backends + +.. _bibliography: + +============== + Bibliography +============== + +.. bibliography:: biblio.bib + :cited: diff --git a/doc/sphinx/zebibliography.rst b/doc/sphinx/zebibliography.latex.rst index 0000caa301..2c0396f1c9 100644 --- a/doc/sphinx/zebibliography.rst +++ b/doc/sphinx/zebibliography.latex.rst @@ -1,8 +1,6 @@ -.. _bibliography: +.. See zebibliography.html.rst for details -============ -Bibliography -============ +.. _bibliography: .. bibliography:: biblio.bib :cited: diff --git a/doc/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index 40554c3ca3..97dabbf815 100644 --- a/doc/tools/coqrst/coqdomain.py +++ b/doc/tools/coqrst/coqdomain.py @@ -34,7 +34,7 @@ from sphinx.util.logging import getLogger from sphinx.directives import ObjectDescription from sphinx.domains import Domain, ObjType, Index from sphinx.domains.std import token_xrefs -from sphinx.ext.mathbase import MathDirective, displaymath +from sphinx.ext import mathbase from . import coqdoc from .repl import ansicolors @@ -58,6 +58,15 @@ def make_target(objtype, targetid): """Create a target to an object of type objtype and id targetid""" return "coq:{}.{}".format(objtype, targetid) +def make_math_node(latex, docname, nowrap): + node = mathbase.displaymath() + node['latex'] = latex + node['label'] = None # Otherwise equations are numbered + node['nowrap'] = nowrap + node['docname'] = docname + node['number'] = None + return node + class CoqObject(ObjectDescription): """A generic Coq object for Sphinx; all Coq objects are subclasses of this. @@ -101,7 +110,9 @@ class CoqObject(ObjectDescription): # Explicit object naming 'name': directives.unchanged, # Silence warnings produced by report_undocumented_coq_objects - 'undocumented': directives.flag + 'undocumented': directives.flag, + # noindex omits this object from its index + 'noindex': directives.flag } def subdomain_data(self): @@ -138,6 +149,13 @@ class CoqObject(ObjectDescription): msg = MSG.format(name, self.env.doc2path(objects[name][0])) self.state_machine.reporter.warning(msg, line=self.lineno) + def _warn_if_duplicate_name(self, objects, name): + """Check that two objects in the same domain don't have the same name.""" + if name in objects: + MSG = 'Duplicate object: {}; other is at {}' + msg = MSG.format(name, self.env.doc2path(objects[name][0])) + self.state_machine.reporter.warning(msg, line=self.lineno) + def _record_name(self, name, target_id): """Record a name, mapping it to target_id @@ -165,13 +183,16 @@ class CoqObject(ObjectDescription): """Add `name` (pointing to `target`) to the main index.""" assert isinstance(name, str) if not name.startswith("_"): - index_text = name + # remove trailing . , found in commands, but not ... (ellipsis) + trim = name.endswith(".") and not name.endswith("...") + index_text = name[:-1] if trim else name if self.index_suffix: index_text += " " + self.index_suffix self.indexnode['entries'].append(('single', index_text, target, '', None)) def add_target_and_index(self, name, _, signode): - """Attach a link target to `signode` and an index entry for `name`.""" + """Attach a link target to `signode` and an index entry for `name`. + This is only called (from ``ObjectDescription.run``) if ``:noindex:`` isn't specified.""" if name: target = self._add_target(signode, name) self._add_index_entry(name, target) @@ -312,15 +333,15 @@ class TacticNotationVariantObject(TacticNotationObject): annotation = "Variant" class OptionObject(NotationObject): - """A Coq option. + """A Coq option (a setting with non-boolean value, e.g. a string or numeric value). Example:: - .. opt:: Nonrecursive Elimination Schemes + .. opt:: Hyps Limit @num + :name Hyps Limit - This option controls whether types declared with the keywords - :cmd:`Variant` and :cmd:`Record` get an automatic declaration of the - induction principles. + Controls the maximum number of hypotheses displayed in goals after + application of a tactic. """ subdomain = "opt" index_suffix = "(opt)" @@ -329,6 +350,43 @@ class OptionObject(NotationObject): def _name_from_signature(self, signature): return stringify_with_ellipses(signature) + +class FlagObject(NotationObject): + """A Coq flag (i.e. a boolean setting). + + Example:: + + .. flag:: Nonrecursive Elimination Schemes + + Controls whether types declared with the keywords + :cmd:`Variant` and :cmd:`Record` get an automatic declaration of + induction principles. + """ + subdomain = "flag" + index_suffix = "(flag)" + annotation = "Flag" + + def _name_from_signature(self, signature): + return stringify_with_ellipses(signature) + + +class TableObject(NotationObject): + """A Coq table, i.e. a setting that is a set of values. + + Example:: + + .. table:: Search Blacklist @string + :name: Search Blacklist + + Controls ... + """ + subdomain = "table" + index_suffix = "(table)" + annotation = "Table" + + def _name_from_signature(self, signature): + return stringify_with_ellipses(signature) + class ProductionObject(CoqObject): r"""A grammar production. @@ -487,7 +545,7 @@ def coq_code_role(role, rawtext, text, lineno, inliner, options={}, content=[]): CoqCodeRole = coq_code_role class CoqtopDirective(Directive): - """A reST directive to describe interactions with Coqtop. + r"""A reST directive to describe interactions with Coqtop. Usage:: @@ -525,16 +583,17 @@ class CoqtopDirective(Directive): required_arguments = 0 optional_arguments = 1 final_argument_whitespace = True + option_spec = { 'name': directives.unchanged } directive_name = "coqtop" def run(self): # Uses a ‘container’ instead of a ‘literal_block’ to disable # Pygments-based post-processing (we could also set rawsource to '') content = '\n'.join(self.content) - options = self.arguments[0].split() if self.arguments else ['in'] - if 'all' in options: - options.extend(['in', 'out']) - node = nodes.container(content, coqtop_options = list(set(options)), + args = self.arguments[0].split() if self.arguments else ['in'] + if 'all' in args: + args.extend(['in', 'out']) + node = nodes.container(content, coqtop_options = list(set(args)), classes=['coqtop', 'literal-block']) self.add_name(node) return [node] @@ -559,6 +618,7 @@ class CoqdocDirective(Directive): required_arguments = 0 optional_arguments = 0 final_argument_whitespace = True + option_spec = { 'name': directives.unchanged } directive_name = "coqdoc" def run(self): @@ -567,6 +627,7 @@ class CoqdocDirective(Directive): content = '\n'.join(self.content) node = nodes.inline(content, '', *highlight_using_coqdoc(content)) wrapper = nodes.container(content, node, classes=['coqdoc', 'literal-block']) + self.add_name(wrapper) return [wrapper] class ExampleDirective(BaseAdmonition): @@ -602,24 +663,39 @@ class ExampleDirective(BaseAdmonition): self.options['classes'] = ['admonition', 'note'] return super().run() -class PreambleDirective(MathDirective): - r"""A reST directive for hidden math. - - Mostly useful to let MathJax know about `\def`\ s and `\newcommand`\ s. +class PreambleDirective(Directive): + r"""A reST directive to include a TeX file. - Example:: + Mostly useful to let MathJax know about `\def`s and `\newcommand`s. - .. preamble:: + Usage:: - \newcommand{\paren}[#1]{\left(#1\right)} + .. preamble:: preamble.tex """ - + has_content = False + required_arguments = 1 + optional_arguments = 0 + final_argument_whitespace = True + option_spec = {} directive_name = "preamble" def run(self): - self.options['nowrap'] = True - [node] = super().run() + document = self.state.document + env = document.settings.env + + if not document.settings.file_insertion_enabled: + msg = 'File insertion disabled' + return [document.reporter.warning(msg, line=self.lineno)] + + rel_fname, abs_fname = env.relfn2path(self.arguments[0]) + env.note_dependency(rel_fname) + + with open(abs_fname, encoding="utf-8") as ltx: + latex = ltx.read() + + node = make_math_node(latex, env.docname, nowrap=True) node['classes'] = ["math-preamble"] + set_source_info(self, node) return [node] class InferenceDirective(Directive): @@ -632,8 +708,8 @@ class InferenceDirective(Directive): .. inference:: name - newline-separated premisses - ------------------------ + newline-separated premises + -------------------------- conclusion Example:: @@ -652,15 +728,6 @@ class InferenceDirective(Directive): final_argument_whitespace = True directive_name = "inference" - def make_math_node(self, latex): - node = displaymath() - node['latex'] = latex - node['label'] = None # Otherwise equations are numbered - node['nowrap'] = False - node['docname'] = self.state.document.settings.env.docname - node['number'] = None - return node - @staticmethod def prepare_latex_operand(op): # TODO: Could use a fancier inference class in LaTeX @@ -680,7 +747,8 @@ class InferenceDirective(Directive): title = self.arguments[0] content = '\n'.join(self.content) latex = self.prepare_latex(content) - math_node = self.make_math_node(latex) + docname = self.state.document.settings.env.docname + math_node = make_math_node(latex, docname, nowrap=False) tid = nodes.make_id(title) target = nodes.target('', '', ids=['inference-' + tid]) @@ -827,23 +895,28 @@ class CoqtopBlocksTransform(Transform): kept_node['classes'] = [c for c in kept_node['classes'] if c != 'coqtop-hidden'] - def merge_consecutive_coqtop_blocks(self): + @staticmethod + def merge_consecutive_coqtop_blocks(app, doctree, _): """Merge consecutive divs wrapping lists of Coq sentences; keep ‘dl’s separate.""" - for node in self.document.traverse(CoqtopBlocksTransform.is_coqtop_block): + for node in doctree.traverse(CoqtopBlocksTransform.is_coqtop_block): if node.parent: + rawsources, names = [node.rawsource], set(node['names']) for sibling in node.traverse(include_self=False, descend=False, siblings=True, ascend=False): if CoqtopBlocksTransform.is_coqtop_block(sibling): - self.merge_coqtop_classes(node, sibling) + CoqtopBlocksTransform.merge_coqtop_classes(node, sibling) + rawsources.append(sibling.rawsource) + names.update(sibling['names']) node.extend(sibling.children) node.parent.remove(sibling) sibling.parent = None else: break + node.rawsource = "\n\n".join(rawsources) + node['names'] = list(names) def apply(self): self.add_coqtop_output() - self.merge_consecutive_coqtop_blocks() class CoqSubdomainsIndex(Index): """Index subclass to provide subdomain-specific indices. @@ -876,7 +949,7 @@ class CoqTacticIndex(CoqSubdomainsIndex): name, localname, shortname, subdomains = "tacindex", "Tactic Index", "tactics", ["tacn"] class CoqOptionIndex(CoqSubdomainsIndex): - name, localname, shortname, subdomains = "optindex", "Option Index", "options", ["opt"] + name, localname, shortname, subdomains = "optindex", "Flags, options and Tables Index", "options", ["flag", "opt", "table"] class CoqGallinaIndex(CoqSubdomainsIndex): name, localname, shortname, subdomains = "thmindex", "Gallina Index", "theorems", ["thm"] @@ -949,6 +1022,8 @@ class CoqDomain(Domain): 'tacn': ObjType('tacn', 'tacn'), 'tacv': ObjType('tacv', 'tacn'), 'opt': ObjType('opt', 'opt'), + 'flag': ObjType('flag', 'flag'), + 'table': ObjType('table', 'table'), 'thm': ObjType('thm', 'thm'), 'prodn': ObjType('prodn', 'prodn'), 'exn': ObjType('exn', 'exn'), @@ -965,6 +1040,8 @@ class CoqDomain(Domain): 'tacn': TacticNotationObject, 'tacv': TacticNotationVariantObject, 'opt': OptionObject, + 'flag': FlagObject, + 'table': TableObject, 'thm': GallinaObject, 'prodn' : ProductionObject, 'exn': ExceptionObject, @@ -976,6 +1053,8 @@ class CoqDomain(Domain): 'cmd': XRefRole(warn_dangling=True), 'tacn': XRefRole(warn_dangling=True), 'opt': XRefRole(warn_dangling=True), + 'flag': XRefRole(warn_dangling=True), + 'table': XRefRole(warn_dangling=True), 'thm': XRefRole(warn_dangling=True), 'prodn' : XRefRole(warn_dangling=True), 'exn': XRefRole(warn_dangling=True), @@ -997,6 +1076,8 @@ class CoqDomain(Domain): 'cmd': {}, 'tacn': {}, 'opt': {}, + 'flag': {}, + 'table': {}, 'thm': {}, 'prodn' : {}, 'exn': {}, @@ -1059,7 +1140,6 @@ def simplify_source_code_blocks_for_latex(app, doctree, fromdocname): # pylint: pygments if available. This prevents the LaTeX builder from getting confused. """ - is_html = app.builder.tags.has("html") for node in doctree.traverse(is_coqtop_or_coqdoc_block): if is_html: @@ -1096,6 +1176,7 @@ def setup(app): app.add_transform(CoqtopBlocksTransform) app.connect('doctree-resolved', simplify_source_code_blocks_for_latex) + app.connect('doctree-resolved', CoqtopBlocksTransform.merge_consecutive_coqtop_blocks) # Add extra styles app.add_stylesheet("fonts.css") @@ -1108,4 +1189,11 @@ def setup(app): # Tell Sphinx about extra settings app.add_config_value("report_undocumented_coq_objects", None, 'env') - return {'version': '0.1', "parallel_read_safe": True} + # ``env_version`` is used by Sphinx to know when to invalidate + # coqdomain-specific bits in its caches. It should be incremented when the + # contents of ``env.domaindata['coq']`` change. See + # `https://github.com/sphinx-doc/sphinx/issues/4460`. + meta = { "version": "0.1", + "env_version": 2, + "parallel_read_safe": True } + return meta diff --git a/engine/eConstr.ml b/engine/eConstr.ml index 3dc1933a14..678f7c6ce6 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -259,7 +259,17 @@ let decompose_prod_n_assum sigma n c = let existential_type = Evd.existential_type -let map sigma f c = match kind sigma c with +let map_under_context f n c = + let f c = unsafe_to_constr (f (of_constr c)) in + of_constr (Constr.map_under_context f n (unsafe_to_constr c)) +let map_branches f ci br = + let f c = unsafe_to_constr (f (of_constr c)) in + of_constr_array (Constr.map_branches f ci (unsafe_to_constr_array br)) +let map_return_predicate f ci p = + let f c = unsafe_to_constr (f (of_constr c)) in + of_constr (Constr.map_return_predicate f ci (unsafe_to_constr p)) + +let map_gen userview sigma f c = match kind sigma c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> c | Cast (b,k,t) -> @@ -296,6 +306,12 @@ let map sigma f c = match kind sigma c with let l' = Array.Smart.map f l in if l'==l then c else mkEvar (e, l') + | Case (ci,p,b,bl) when userview -> + let b' = f b in + let p' = map_return_predicate f ci p in + let bl' = map_branches f ci bl in + if b'==b && p'==p && bl'==bl then c + else mkCase (ci, p', b', bl') | Case (ci,p,b,bl) -> let b' = f b in let p' = f p in @@ -313,6 +329,9 @@ let map sigma f c = match kind sigma c with if tl'==tl && bl'==bl then c else mkCoFix (ln,(lna,tl',bl')) +let map_user_view = map_gen true +let map = map_gen false + let map_with_binders sigma g f l c0 = match kind sigma c0 with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> c0 @@ -426,10 +445,22 @@ let fold sigma f acc c = match kind sigma c with let compare_gen k eq_inst eq_sort eq_constr nargs c1 c2 = (c1 == c2) || Constr.compare_head_gen_with k k eq_inst eq_sort eq_constr nargs c1 c2 +let eq_einstance sigma i1 i2 = + let i1 = EInstance.kind sigma (EInstance.make i1) in + let i2 = EInstance.kind sigma (EInstance.make i2) in + Univ.Instance.equal i1 i2 + +let eq_esorts sigma s1 s2 = + let s1 = ESorts.kind sigma (ESorts.make s1) in + let s2 = ESorts.kind sigma (ESorts.make s2) in + Sorts.equal s1 s2 + let eq_constr sigma c1 c2 = let kind c = kind_upto sigma c in + let eq_inst _ _ i1 i2 = eq_einstance sigma i1 i2 in + let eq_sorts s1 s2 = eq_esorts sigma s1 s2 in let rec eq_constr nargs c1 c2 = - compare_gen kind (fun _ _ -> Univ.Instance.equal) Sorts.equal eq_constr nargs c1 c2 + compare_gen kind eq_inst eq_sorts eq_constr nargs c1 c2 in eq_constr 0 (unsafe_to_constr c1) (unsafe_to_constr c2) @@ -442,8 +473,10 @@ let eq_constr_nounivs sigma c1 c2 = let compare_constr sigma cmp c1 c2 = let kind c = kind_upto sigma c in + let eq_inst _ _ i1 i2 = eq_einstance sigma i1 i2 in + let eq_sorts s1 s2 = eq_esorts sigma s1 s2 in let cmp nargs c1 c2 = cmp (of_constr c1) (of_constr c2) in - compare_gen kind (fun _ _ -> Univ.Instance.equal) Sorts.equal cmp 0 (unsafe_to_constr c1) (unsafe_to_constr c2) + compare_gen kind eq_inst eq_sorts cmp 0 (unsafe_to_constr c1) (unsafe_to_constr c2) let compare_cumulative_instances cv_pb nargs_ok variances u u' cstrs = let open UnivProblem in @@ -794,6 +827,7 @@ struct let to_sorts = ESorts.unsafe_to_sorts let to_instance = EInstance.unsafe_to_instance let to_constr = unsafe_to_constr +let to_constr_array = unsafe_to_constr_array let to_rel_decl = unsafe_to_rel_decl let to_named_decl = unsafe_to_named_decl let to_named_context = diff --git a/engine/eConstr.mli b/engine/eConstr.mli index ecb36615f3..f897448557 100644 --- a/engine/eConstr.mli +++ b/engine/eConstr.mli @@ -224,7 +224,11 @@ val compare_constr : Evd.evar_map -> (t -> t -> bool) -> t -> t -> bool (** {6 Iterators} *) val map : Evd.evar_map -> (t -> t) -> t -> t +val map_user_view : Evd.evar_map -> (t -> t) -> t -> t val map_with_binders : Evd.evar_map -> ('a -> 'a) -> ('a -> t -> t) -> 'a -> t -> t +val map_under_context : (t -> t) -> int -> t -> t +val map_branches : (t -> t) -> case_info -> t array -> t array +val map_return_predicate : (t -> t) -> case_info -> t -> t val iter : Evd.evar_map -> (t -> unit) -> t -> unit val iter_with_binders : Evd.evar_map -> ('a -> 'a) -> ('a -> t -> unit) -> 'a -> t -> unit val iter_with_full_binders : Evd.evar_map -> (rel_declaration -> 'a -> 'a) -> ('a -> t -> unit) -> 'a -> t -> unit @@ -315,6 +319,9 @@ sig val to_constr : t -> Constr.t (** Physical identity. Does not care for defined evars. *) + val to_constr_array : t array -> Constr.t array + (** Physical identity. Does not care for defined evars. *) + val to_rel_decl : (t, types) Context.Rel.Declaration.pt -> (Constr.t, Constr.types) Context.Rel.Declaration.pt (** Physical identity. Does not care for defined evars. *) diff --git a/engine/evarutil.ml b/engine/evarutil.ml index b77bf55d8d..b1d880b0ad 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -284,8 +284,8 @@ type csubst = { csubst_rev : subst_val Id.Map.t; (** Reverse mapping of the substitution *) } -(** This type represent a name substitution for the named and De Bruijn parts of - a environment. For efficiency we also store the reverse substitution. +(** This type represents a name substitution for the named and De Bruijn parts of + an environment. For efficiency we also store the reverse substitution. Invariant: all identifiers in the codomain of [csubst_var] and [csubst_rel] must be pairwise distinct. *) diff --git a/engine/evd.ml b/engine/evd.ml index 9f976b57dd..d7b03a84f1 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -1267,7 +1267,9 @@ module MiniEConstr = struct let kind_of_type sigma c = Term.kind_of_type (whd_evar sigma c) let of_kind = Constr.of_kind let of_constr c = c + let of_constr_array v = v let unsafe_to_constr c = c + let unsafe_to_constr_array v = v let unsafe_eq = Refl let to_constr ?(abort_on_undefined_evars=true) sigma c = diff --git a/engine/evd.mli b/engine/evd.mli index db2bd4eedf..1a5614988d 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -657,10 +657,12 @@ module MiniEConstr : sig val of_kind : (t, t, ESorts.t, EInstance.t) Constr.kind_of_term -> t val of_constr : Constr.t -> t + val of_constr_array : Constr.t array -> t array val to_constr : ?abort_on_undefined_evars:bool -> evar_map -> t -> Constr.t val unsafe_to_constr : t -> Constr.t + val unsafe_to_constr_array : t array -> Constr.t array val unsafe_eq : (t, Constr.t) eq diff --git a/engine/ftactic.ml b/engine/ftactic.ml index e23a03c0c7..b371884ba4 100644 --- a/engine/ftactic.ml +++ b/engine/ftactic.ml @@ -61,7 +61,7 @@ let nf_enter f = (fun gl -> gl >>= fun gl -> Proofview.Goal.normalize gl >>= fun nfgl -> - Proofview.V82.wrap_exceptions (fun () -> f nfgl)) + Proofview.V82.wrap_exceptions (fun () -> f nfgl)) [@warning "-3"] let enter f = bind goals diff --git a/engine/ftactic.mli b/engine/ftactic.mli index 6c389b2d67..3c4fa6f4e8 100644 --- a/engine/ftactic.mli +++ b/engine/ftactic.mli @@ -42,6 +42,8 @@ val run : 'a t -> ('a -> unit Proofview.tactic) -> unit Proofview.tactic (** {5 Focussing} *) val nf_enter : (Proofview.Goal.t -> 'a t) -> 'a t +[@@ocaml.deprecated "Normalization is enforced by EConstr, please use [enter]"] + (** Enter a goal. The resulting tactic is focussed. *) val enter : (Proofview.Goal.t -> 'a t) -> 'a t diff --git a/engine/namegen.ml b/engine/namegen.ml index 978f33b683..2a59b914db 100644 --- a/engine/namegen.ml +++ b/engine/namegen.ml @@ -258,15 +258,15 @@ let restart_subscript id = forget_subscript id let visible_ids sigma (nenv, c) = - let accu = ref (Refset_env.empty, Int.Set.empty, Id.Set.empty) in + let accu = ref (GlobRef.Set_env.empty, Int.Set.empty, Id.Set.empty) in let rec visible_ids n c = match EConstr.kind sigma c with | Const _ | Ind _ | Construct _ | Var _ as c -> let (gseen, vseen, ids) = !accu in let g = global_of_constr c in - if not (Refset_env.mem g gseen) then + if not (GlobRef.Set_env.mem g gseen) then begin try - let gseen = Refset_env.add g gseen in + let gseen = GlobRef.Set_env.add g gseen in let short = shortest_qualid_of_global Id.Set.empty g in let dir, id = repr_qualid short in let ids = if DirPath.is_empty dir then Id.Set.add id ids else ids in diff --git a/engine/proofview.mli b/engine/proofview.mli index a9666e4f90..0bb3229a9b 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -497,6 +497,7 @@ module Goal : sig (** Normalises the argument goal. *) val normalize : t -> t tactic + [@@ocaml.deprecated "Normalization is enforced by EConstr, [normalize] is not needed anymore"] (** [concl], [hyps], [env] and [sigma] given a goal [gl] return respectively the conclusion of [gl], the hypotheses of [gl], the @@ -514,6 +515,7 @@ module Goal : sig the current goal is also given as an argument to [t]. The goal is normalised with respect to evars. *) val nf_enter : (t -> unit tactic) -> unit tactic + [@@ocaml.deprecated "Normalization is enforced by EConstr, please use [enter]"] (** Like {!nf_enter}, but does not normalize the goal beforehand. *) val enter : (t -> unit tactic) -> unit tactic diff --git a/engine/termops.ml b/engine/termops.ml index e4c8ae66bc..156d1370e3 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -715,10 +715,26 @@ let map_constr_with_binders_left_to_right sigma g f l c = then c else mkCoFix (ln,(lna,tl',bl')) +let map_under_context_with_full_binders sigma g f l n d = + let open EConstr in + let f l c = Unsafe.to_constr (f l (of_constr c)) in + let g d l = g (of_rel_decl d) l in + let d = EConstr.Unsafe.to_constr (EConstr.whd_evar sigma d) in + EConstr.of_constr (Constr.map_under_context_with_full_binders g f l n d) + +let map_branches_with_full_binders sigma g f l ci bl = + let tags = Array.map List.length ci.ci_pp_info.cstr_tags in + let bl' = Array.map2 (map_under_context_with_full_binders sigma g f l) tags bl in + if Array.for_all2 (==) bl' bl then bl else bl' + +let map_return_predicate_with_full_binders sigma g f l ci p = + let n = List.length ci.ci_pp_info.ind_tags in + let p' = map_under_context_with_full_binders sigma g f l n p in + if p' == p then p else p' + (* strong *) -let map_constr_with_full_binders sigma g f l cstr = +let map_constr_with_full_binders_gen userview sigma g f l cstr = let open EConstr in - let open RelDecl in match EConstr.kind sigma cstr with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> cstr @@ -728,16 +744,16 @@ let map_constr_with_full_binders sigma g f l cstr = if c==c' && t==t' then cstr else mkCast (c', k, t') | Prod (na,t,c) -> let t' = f l t in - let c' = f (g (LocalAssum (na, t)) l) c in + let c' = f (g (RelDecl.LocalAssum (na, t)) l) c in if t==t' && c==c' then cstr else mkProd (na, t', c') | Lambda (na,t,c) -> let t' = f l t in - let c' = f (g (LocalAssum (na, t)) l) c in + let c' = f (g (RelDecl.LocalAssum (na, t)) l) c in if t==t' && c==c' then cstr else mkLambda (na, t', c') | LetIn (na,b,t,c) -> let b' = f l b in let t' = f l t in - let c' = f (g (LocalDef (na, b, t)) l) c in + let c' = f (g (RelDecl.LocalDef (na, b, t)) l) c in if b==b' && t==t' && c==c' then cstr else mkLetIn (na, b', t', c') | App (c,al) -> let c' = f l c in @@ -749,6 +765,12 @@ let map_constr_with_full_binders sigma g f l cstr = | Evar (e,al) -> let al' = Array.map (f l) al in if Array.for_all2 (==) al al' then cstr else mkEvar (e, al') + | Case (ci,p,c,bl) when userview -> + let p' = map_return_predicate_with_full_binders sigma g f l ci p in + let c' = f l c in + let bl' = map_branches_with_full_binders sigma g f l ci bl in + if p==p' && c==c' && bl'==bl then cstr else + mkCase (ci, p', c', bl') | Case (ci,p,c,bl) -> let p' = f l p in let c' = f l c in @@ -758,7 +780,7 @@ let map_constr_with_full_binders sigma g f l cstr = | Fix (ln,(lna,tl,bl)) -> let tl' = Array.map (f l) tl in let l' = - Array.fold_left2 (fun l na t -> g (LocalAssum (na, t)) l) l lna tl in + Array.fold_left2 (fun l na t -> g (RelDecl.LocalAssum (na, t)) l) l lna tl in let bl' = Array.map (f l') bl in if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl' then cstr @@ -766,12 +788,18 @@ let map_constr_with_full_binders sigma g f l cstr = | CoFix(ln,(lna,tl,bl)) -> let tl' = Array.map (f l) tl in let l' = - Array.fold_left2 (fun l na t -> g (LocalAssum (na, t)) l) l lna tl in + Array.fold_left2 (fun l na t -> g (RelDecl.LocalAssum (na, t)) l) l lna tl in let bl' = Array.map (f l') bl in if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl' then cstr else mkCoFix (ln,(lna,tl',bl')) +let map_constr_with_full_binders sigma g f = + map_constr_with_full_binders_gen false sigma g f + +let map_constr_with_full_binders_user_view sigma g f = + map_constr_with_full_binders_gen true sigma g f + (* [fold_constr_with_binders g f n acc c] folds [f n] on the immediate subterms of [c] starting from [acc] and proceeding from left to right according to the usual representation of the constructions as diff --git a/engine/termops.mli b/engine/termops.mli index 80988989f1..b967bb6abb 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -63,6 +63,10 @@ val map_constr_with_full_binders : Evd.evar_map -> (rel_declaration -> 'a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr +val map_constr_with_full_binders_user_view : + Evd.evar_map -> + (rel_declaration -> 'a -> 'a) -> + ('a -> constr -> constr) -> 'a -> constr -> constr (** [fold_constr_with_binders g f n acc c] folds [f n] on the immediate subterms of [c] starting from [acc] and proceeding from left to diff --git a/engine/univNames.ml b/engine/univNames.ml index a688401741..e861913de2 100644 --- a/engine/univNames.ml +++ b/engine/univNames.ml @@ -10,7 +10,6 @@ open Names open Univ -open Globnames open Nametab @@ -51,15 +50,15 @@ type universe_binders = Univ.Level.t Names.Id.Map.t let empty_binders = Id.Map.empty -let universe_binders_table = Summary.ref Refmap.empty ~name:"universe binders" +let universe_binders_table = Summary.ref GlobRef.Map.empty ~name:"universe binders" let universe_binders_of_global ref : universe_binders = try - let l = Refmap.find ref !universe_binders_table in l + let l = GlobRef.Map.find ref !universe_binders_table in l with Not_found -> Names.Id.Map.empty let cache_ubinder (_,(ref,l)) = - universe_binders_table := Refmap.add ref l !universe_binders_table + universe_binders_table := GlobRef.Map.add ref l !universe_binders_table let subst_ubinder (subst,(ref,l as orig)) = let ref' = fst (Globnames.subst_global subst ref) in diff --git a/ide/coqide.opam b/ide/coqide.opam index 1b46efdee2..ba05b9edcf 100644 --- a/ide/coqide.opam +++ b/ide/coqide.opam @@ -16,4 +16,4 @@ depends: [ "coq" ] -build: [ [ "dune" "build" "-p" package "-j" jobs ] ] +build: [ [ "dune" "build" "-p" name "-j" jobs ] ] diff --git a/ide/idetop.ml b/ide/idetop.ml index d846b3abb5..8a221a93e9 100644 --- a/ide/idetop.ml +++ b/ide/idetop.ml @@ -204,27 +204,35 @@ let export_pre_goals pgs = Interface.given_up_goals = pgs.Proof.given_up_goals } -let add_diffs oldp newp intf = - let open Interface in - let (hyps_pp_list, concl_pp) = Proof_diffs.diff_first_goal oldp newp in - match intf.fg_goals with - | [] -> intf - | first_goal :: tl -> - { intf with fg_goals = { first_goal with goal_hyp = hyps_pp_list; goal_ccl = concl_pp } :: tl } - let goals () = let doc = get_doc () in set_doc @@ Stm.finish ~doc; try let newp = Proof_global.give_me_the_proof () in - let intf = export_pre_goals (Proof.map_structured_proof newp process_goal) in - if Proof_diffs.show_diffs () then + if Proof_diffs.show_diffs () then begin let oldp = Stm.get_prev_proof ~doc (Stm.get_current_state ~doc) in + let diff_goal_map = Proof_diffs.make_goal_map oldp newp in + let map_goal_for_diff ng = (* todo: move to proof_diffs.ml *) + try Evar.Map.find ng diff_goal_map with Not_found -> ng + in + + let process_goal_diffs nsigma ng = + let open Evd in + let og = map_goal_for_diff ng in + let og_s = match oldp with + | Some oldp -> + let (_,_,_,_,osigma) = Proof.proof oldp in + Some { it = og; sigma = osigma } + | None -> None + in + let (hyps_pp_list, concl_pp) = Proof_diffs.diff_goal_ide og_s ng nsigma in + { Interface.goal_hyp = hyps_pp_list; Interface.goal_ccl = concl_pp; Interface.goal_id = Goal.uid ng } + in try - Some (add_diffs oldp (Some newp) intf) - with Pp_diff.Diff_Failure _ -> Some intf - else - Some intf + Some (export_pre_goals (Proof.map_structured_proof newp process_goal_diffs)) + with Pp_diff.Diff_Failure _ -> Some (export_pre_goals (Proof.map_structured_proof newp process_goal)) + end else + Some (export_pre_goals (Proof.map_structured_proof newp process_goal)) with Proof_global.NoCurrentProof -> None;; let evars () = diff --git a/interp/declare.ml b/interp/declare.ml index a82e6b35a6..22e6cf9d1c 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -39,7 +39,6 @@ type constant_obj = { cst_decl : global_declaration option; (** [None] when the declaration is a side-effect and has already been defined in the global environment. *) - cst_hyps : Dischargedhypsmap.discharged_hyps; cst_kind : logical_kind; cst_locl : bool; } @@ -94,28 +93,20 @@ let cache_constant ((sp,kn), obj) = Nametab.push (Nametab.Until 1) sp (ConstRef (Constant.make1 kn)); let cst = Global.lookup_constant kn' in add_section_constant (Declareops.constant_is_polymorphic cst) kn' cst.const_hyps; - Dischargedhypsmap.set_discharged_hyps sp obj.cst_hyps; add_constant_kind (Constant.make1 kn) obj.cst_kind -let discharged_hyps kn sechyps = - let (_,dir,_) = KerName.repr kn in - let args = Array.to_list (instance_from_variable_context sechyps) in - List.rev_map (Libnames.make_path dir) args - let discharge_constant ((sp, kn), obj) = let con = Constant.make1 kn in let from = Global.lookup_constant con in let modlist = replacement_context () in let { abstr_ctx = hyps; abstr_subst = subst; abstr_uctx = uctx } = section_segment_of_constant con in - let new_hyps = (discharged_hyps kn hyps) @ obj.cst_hyps in let abstract = (named_of_variable_context hyps, subst, uctx) in let new_decl = GlobalRecipe{ from; info = { Opaqueproof.modlist; abstract}} in - Some { obj with cst_hyps = new_hyps; cst_decl = Some new_decl; } + Some { obj with cst_decl = Some new_decl; } (* Hack to reduce the size of .vo: we keep only what load/open needs *) let dummy_constant cst = { cst_decl = None; - cst_hyps = []; cst_kind = cst.cst_kind; cst_locl = cst.cst_locl; } @@ -142,7 +133,6 @@ let update_tables c = let register_side_effect (c, role) = let o = inConstant { cst_decl = None; - cst_hyps = [] ; cst_kind = IsProof Theorem; cst_locl = false; } in @@ -194,7 +184,6 @@ let declare_constant ?(internal = UserIndividualRequest) ?(local = false) id ?(e let () = List.iter register_side_effect export in let cst = { cst_decl = Some decl; - cst_hyps = [] ; cst_kind = kind; cst_locl = local; } in @@ -255,7 +244,6 @@ let cache_variable ((sp,_),o) = poly, univs in Nametab.push (Nametab.Until 1) (restrict_path 0 sp) (VarRef id); add_section_variable id impl poly ctx; - Dischargedhypsmap.set_discharged_hyps sp []; add_variable_data id (p,opaq,ctx,poly,mk) let discharge_variable (_,o) = match o with @@ -311,15 +299,15 @@ let inductive_names sp kn mie = ([], 0) mie.mind_entry_inds in names -let load_inductive i ((sp,kn),(_,mie)) = +let load_inductive i ((sp,kn),mie) = let names = inductive_names sp kn mie in List.iter (fun (sp, ref) -> Nametab.push (Nametab.Until i) sp ref ) names -let open_inductive i ((sp,kn),(_,mie)) = +let open_inductive i ((sp,kn),mie) = let names = inductive_names sp kn mie in List.iter (fun (sp, ref) -> Nametab.push (Nametab.Exactly i) sp ref) names -let cache_inductive ((sp,kn),(dhyps,mie)) = +let cache_inductive ((sp,kn),mie) = let names = inductive_names sp kn mie in List.iter check_exists (List.map fst names); let id = basename sp in @@ -328,17 +316,14 @@ let cache_inductive ((sp,kn),(dhyps,mie)) = assert (MutInd.equal kn' (MutInd.make1 kn)); let mind = Global.lookup_mind kn' in add_section_kn (Declareops.inductive_is_polymorphic mind) kn' mind.mind_hyps; - Dischargedhypsmap.set_discharged_hyps sp dhyps; List.iter (fun (sp, ref) -> Nametab.push (Nametab.Until 1) sp ref) names -let discharge_inductive ((sp,kn),(dhyps,mie)) = +let discharge_inductive ((sp,kn),mie) = let mind = Global.mind_of_delta_kn kn in let mie = Global.lookup_mind mind in let repl = replacement_context () in let info = section_segment_of_mutual_inductive mind in - let sechyps = info.Lib.abstr_ctx in - Some (discharged_hyps kn sechyps, - Discharge.process_inductive info repl mie) + Some (Discharge.process_inductive info repl mie) let dummy_one_inductive_entry mie = { mind_entry_typename = mie.mind_entry_typename; @@ -349,30 +334,28 @@ let dummy_one_inductive_entry mie = { } (* Hack to reduce the size of .vo: we keep only what load/open needs *) -let dummy_inductive_entry (_,m) = ([],{ +let dummy_inductive_entry m = { mind_entry_params = []; mind_entry_record = None; mind_entry_finite = Declarations.BiFinite; mind_entry_inds = List.map dummy_one_inductive_entry m.mind_entry_inds; mind_entry_universes = Monomorphic_ind_entry Univ.ContextSet.empty; mind_entry_private = None; -}) +} (* reinfer subtyping constraints for inductive after section is dischared. *) -let infer_inductive_subtyping (pth, mind_ent) = +let infer_inductive_subtyping mind_ent = match mind_ent.mind_entry_universes with | Monomorphic_ind_entry _ | Polymorphic_ind_entry _ -> - (pth, mind_ent) + mind_ent | Cumulative_ind_entry cumi -> begin let env = Global.env () in (* let (env'', typed_params) = Typeops.infer_local_decls env' (mind_ent.mind_entry_params) in *) - (pth, InferCumulativity.infer_inductive env mind_ent) + InferCumulativity.infer_inductive env mind_ent end -type inductive_obj = Dischargedhypsmap.discharged_hyps * mutual_inductive_entry - -let inInductive : inductive_obj -> obj = +let inInductive : mutual_inductive_entry -> obj = declare_object {(default_object "INDUCTIVE") with cache_function = cache_inductive; load_function = load_inductive; @@ -426,7 +409,7 @@ let declare_mind mie = let id = match mie.mind_entry_inds with | ind::_ -> ind.mind_entry_typename | [] -> anomaly (Pp.str "cannot declare an empty list of inductives.") in - let (sp,kn as oname) = add_leaf id (inInductive ([],mie)) in + let (sp,kn as oname) = add_leaf id (inInductive mie) in let mind = Global.mind_of_delta_kn kn in let isprim = declare_projections mie.mind_entry_universes mind in declare_mib_implicits mind; diff --git a/interp/impargs.ml b/interp/impargs.ml index e542b818f6..3603367cf1 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -508,11 +508,11 @@ type implicit_discharge_request = | ImplInteractive of GlobRef.t * implicits_flags * implicit_interactive_request -let implicits_table = Summary.ref Refmap.empty ~name:"implicits" +let implicits_table = Summary.ref GlobRef.Map.empty ~name:"implicits" let implicits_of_global ref = try - let l = Refmap.find ref !implicits_table in + let l = GlobRef.Map.find ref !implicits_table in try let rename_l = Arguments_renaming.arguments_names ref in let rec rename implicits names = match implicits, names with @@ -527,7 +527,7 @@ let implicits_of_global ref = with Not_found -> [DefaultImpArgs,[]] let cache_implicits_decl (ref,imps) = - implicits_table := Refmap.add ref imps !implicits_table + implicits_table := GlobRef.Map.add ref imps !implicits_table let load_implicits _ (_,(_,l)) = List.iter cache_implicits_decl l diff --git a/interp/notation.ml b/interp/notation.ml index 55ead946cb..02c7812e21 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -98,21 +98,40 @@ let init_scope_map () = (**********************************************************************) (* Operations on scopes *) +let warn_undeclared_scope = + CWarnings.create ~name:"undeclared-scope" ~category:"deprecated" + (fun (scope) -> + strbrk "Declaring a scope implicitly is deprecated; use in advance an explicit " + ++ str "\"Declare Scope " ++ str scope ++ str ".\".") + let declare_scope scope = try let _ = String.Map.find scope !scope_map in () with Not_found -> -(* Flags.if_warn message ("Creating scope "^scope);*) scope_map := String.Map.add scope empty_scope !scope_map let error_unknown_scope sc = user_err ~hdr:"Notation" (str "Scope " ++ str sc ++ str " is not declared.") -let find_scope scope = +let find_scope ?(tolerant=false) scope = try String.Map.find scope !scope_map - with Not_found -> error_unknown_scope scope + with Not_found -> + if tolerant then + (* tolerant mode to be turn off after deprecation phase *) + begin + warn_undeclared_scope scope; + scope_map := String.Map.add scope empty_scope !scope_map; + empty_scope + end + else + error_unknown_scope scope -let check_scope sc = let _ = find_scope sc in () +let check_scope ?(tolerant=false) scope = + let _ = find_scope ~tolerant scope in () + +let ensure_scope scope = check_scope ~tolerant:true scope + +let find_scope scope = find_scope scope (* [sc] might be here a [scope_name] or a [delimiter] (now allowed after Open Scope) *) @@ -245,7 +264,7 @@ type key = | Oth let key_compare k1 k2 = match k1, k2 with -| RefKey gr1, RefKey gr2 -> RefOrdered.compare gr1 gr2 +| RefKey gr1, RefKey gr2 -> GlobRef.Ordered.compare gr1 gr2 | RefKey _, Oth -> -1 | Oth, RefKey _ -> 1 | Oth, Oth -> 0 @@ -360,23 +379,364 @@ module InnerPrimToken = struct end -(* The following two tables of (un)interpreters will *not* be synchronized. - But their indexes will be checked to be unique *) +(* The following two tables of (un)interpreters will *not* be + synchronized. But their indexes will be checked to be unique. + These tables contain primitive token interpreters which are + registered in plugins, such as string and ascii syntax. It is + essential that only plugins add to these tables, and that + vernacular commands do not. See + https://github.com/coq/coq/issues/8401 for details of what goes + wrong when vernacular commands add to these tables. *) let prim_token_interpreters = (Hashtbl.create 7 : (prim_token_uid, InnerPrimToken.interpreter) Hashtbl.t) let prim_token_uninterpreters = (Hashtbl.create 7 : (prim_token_uid, InnerPrimToken.uninterpreter) Hashtbl.t) +(*******************************************************) +(* Numeral notation interpretation *) +type numeral_notation_error = + | UnexpectedTerm of Constr.t + | UnexpectedNonOptionTerm of Constr.t + +exception NumeralNotationError of Environ.env * Evd.evar_map * numeral_notation_error + +type numnot_option = + | Nop + | Warning of raw_natural_number + | Abstract of raw_natural_number + +type int_ty = + { uint : Names.inductive; + int : Names.inductive } + +type z_pos_ty = + { z_ty : Names.inductive; + pos_ty : Names.inductive } + +type target_kind = + | Int of int_ty (* Coq.Init.Decimal.int + uint *) + | UInt of Names.inductive (* Coq.Init.Decimal.uint *) + | Z of z_pos_ty (* Coq.Numbers.BinNums.Z and positive *) + +type option_kind = Option | Direct +type conversion_kind = target_kind * option_kind + +type numeral_notation_obj = + { to_kind : conversion_kind; + to_ty : GlobRef.t; + of_kind : conversion_kind; + of_ty : GlobRef.t; + num_ty : Libnames.qualid; (* for warnings / error messages *) + warning : numnot_option } + +module Numeral = struct +(** * Numeral notation *) + +(** Reduction + + The constr [c] below isn't necessarily well-typed, since we + built it via an [mkApp] of a conversion function on a term + that starts with the right constructor but might be partially + applied. + + At least [c] is known to be evar-free, since it comes from + our own ad-hoc [constr_of_glob] or from conversions such + as [coqint_of_rawnum]. +*) + +let eval_constr env sigma (c : Constr.t) = + let c = EConstr.of_constr c in + let sigma,t = Typing.type_of env sigma c in + let c' = Vnorm.cbv_vm env sigma c t in + EConstr.Unsafe.to_constr c' + +(* For testing with "compute" instead of "vm_compute" : +let eval_constr env sigma (c : Constr.t) = + let c = EConstr.of_constr c in + let c' = Tacred.compute env sigma c in + EConstr.Unsafe.to_constr c' +*) + +let eval_constr_app env sigma c1 c2 = + eval_constr env sigma (mkApp (c1,[| c2 |])) + +exception NotANumber + +let warn_large_num = + CWarnings.create ~name:"large-number" ~category:"numbers" + (fun ty -> + strbrk "Stack overflow or segmentation fault happens when " ++ + strbrk "working with large numbers in " ++ pr_qualid ty ++ + strbrk " (threshold may vary depending" ++ + strbrk " on your system limits and on the command executed).") + +let warn_abstract_large_num = + CWarnings.create ~name:"abstract-large-number" ~category:"numbers" + (fun (ty,f) -> + strbrk "To avoid stack overflow, large numbers in " ++ + pr_qualid ty ++ strbrk " are interpreted as applications of " ++ + Nametab.pr_global_env (Termops.vars_of_env (Global.env ())) f ++ strbrk ".") + +(** Comparing two raw numbers (base 10, big-endian, non-negative). + A bit nasty, but not critical: only used to decide when a + number is considered as large (see warnings above). *) + +exception Comp of int + +let rec rawnum_compare s s' = + let l = String.length s and l' = String.length s' in + if l < l' then - rawnum_compare s' s + else + let d = l-l' in + try + for i = 0 to d-1 do if s.[i] != '0' then raise (Comp 1) done; + for i = d to l-1 do + let c = Pervasives.compare s.[i] s'.[i-d] in + if c != 0 then raise (Comp c) + done; + 0 + with Comp c -> c + +(***********************************************************************) + +(** ** Conversion between Coq [Decimal.int] and internal raw string *) + +(** Decimal.Nil has index 1, then Decimal.D0 has index 2 .. Decimal.D9 is 11 *) + +let digit_of_char c = + assert ('0' <= c && c <= '9'); + Char.code c - Char.code '0' + 2 + +let char_of_digit n = + assert (2<=n && n<=11); + Char.chr (n-2 + Char.code '0') + +let coquint_of_rawnum uint str = + let nil = mkConstruct (uint,1) in + let rec do_chars s i acc = + if i < 0 then acc + else + let dg = mkConstruct (uint, digit_of_char s.[i]) in + do_chars s (i-1) (mkApp(dg,[|acc|])) + in + do_chars str (String.length str - 1) nil + +let coqint_of_rawnum inds (str,sign) = + let uint = coquint_of_rawnum inds.uint str in + mkApp (mkConstruct (inds.int, if sign then 1 else 2), [|uint|]) + +let rawnum_of_coquint c = + let rec of_uint_loop c buf = + match Constr.kind c with + | Construct ((_,1), _) (* Nil *) -> () + | App (c, [|a|]) -> + (match Constr.kind c with + | Construct ((_,n), _) (* D0 to D9 *) -> + let () = Buffer.add_char buf (char_of_digit n) in + of_uint_loop a buf + | _ -> raise NotANumber) + | _ -> raise NotANumber + in + let buf = Buffer.create 64 in + let () = of_uint_loop c buf in + if Int.equal (Buffer.length buf) 0 then + (* To avoid ambiguities between Nil and (D0 Nil), we choose + to not display Nil alone as "0" *) + raise NotANumber + else Buffer.contents buf + +let rawnum_of_coqint c = + match Constr.kind c with + | App (c,[|c'|]) -> + (match Constr.kind c with + | Construct ((_,1), _) (* Pos *) -> (rawnum_of_coquint c', true) + | Construct ((_,2), _) (* Neg *) -> (rawnum_of_coquint c', false) + | _ -> raise NotANumber) + | _ -> raise NotANumber + + +(***********************************************************************) + +(** ** Conversion between Coq [Z] and internal bigint *) + +(** First, [positive] from/to bigint *) + +let rec pos_of_bigint posty n = + match Bigint.div2_with_rest n with + | (q, false) -> + let c = mkConstruct (posty, 2) in (* xO *) + mkApp (c, [| pos_of_bigint posty q |]) + | (q, true) when not (Bigint.equal q Bigint.zero) -> + let c = mkConstruct (posty, 1) in (* xI *) + mkApp (c, [| pos_of_bigint posty q |]) + | (q, true) -> + mkConstruct (posty, 3) (* xH *) + +let rec bigint_of_pos c = match Constr.kind c with + | Construct ((_, 3), _) -> (* xH *) Bigint.one + | App (c, [| d |]) -> + begin match Constr.kind c with + | Construct ((_, n), _) -> + begin match n with + | 1 -> (* xI *) Bigint.add_1 (Bigint.mult_2 (bigint_of_pos d)) + | 2 -> (* xO *) Bigint.mult_2 (bigint_of_pos d) + | n -> assert false (* no other constructor of type positive *) + end + | x -> raise NotANumber + end + | x -> raise NotANumber + +(** Now, [Z] from/to bigint *) + +let z_of_bigint { z_ty; pos_ty } n = + if Bigint.equal n Bigint.zero then + mkConstruct (z_ty, 1) (* Z0 *) + else + let (s, n) = + if Bigint.is_pos_or_zero n then (2, n) (* Zpos *) + else (3, Bigint.neg n) (* Zneg *) + in + let c = mkConstruct (z_ty, s) in + mkApp (c, [| pos_of_bigint pos_ty n |]) + +let bigint_of_z z = match Constr.kind z with + | Construct ((_, 1), _) -> (* Z0 *) Bigint.zero + | App (c, [| d |]) -> + begin match Constr.kind c with + | Construct ((_, n), _) -> + begin match n with + | 2 -> (* Zpos *) bigint_of_pos d + | 3 -> (* Zneg *) Bigint.neg (bigint_of_pos d) + | n -> assert false (* no other constructor of type Z *) + end + | _ -> raise NotANumber + end + | _ -> raise NotANumber + +(** The uninterp function below work at the level of [glob_constr] + which is too low for us here. So here's a crude conversion back + to [constr] for the subset that concerns us. *) + +let rec constr_of_glob env sigma g = match DAst.get g with + | Glob_term.GRef (ConstructRef c, _) -> + let sigma,c = Evd.fresh_constructor_instance env sigma c in + sigma,mkConstructU c + | Glob_term.GApp (gc, gcl) -> + let sigma,c = constr_of_glob env sigma gc in + let sigma,cl = List.fold_left_map (constr_of_glob env) sigma gcl in + sigma,mkApp (c, Array.of_list cl) + | _ -> + raise NotANumber + +let rec glob_of_constr ?loc env sigma c = match Constr.kind c with + | App (c, ca) -> + let c = glob_of_constr ?loc env sigma c in + let cel = List.map (glob_of_constr ?loc env sigma) (Array.to_list ca) in + DAst.make ?loc (Glob_term.GApp (c, cel)) + | Construct (c, _) -> DAst.make ?loc (Glob_term.GRef (ConstructRef c, None)) + | Const (c, _) -> DAst.make ?loc (Glob_term.GRef (ConstRef c, None)) + | Ind (ind, _) -> DAst.make ?loc (Glob_term.GRef (IndRef ind, None)) + | Var id -> DAst.make ?loc (Glob_term.GRef (VarRef id, None)) + | _ -> Loc.raise ?loc (NumeralNotationError(env,sigma,UnexpectedTerm c)) + +let no_such_number ?loc ty = + CErrors.user_err ?loc + (str "Cannot interpret this number as a value of type " ++ + pr_qualid ty) + +let interp_option ty ?loc env sigma c = + match Constr.kind c with + | App (_Some, [| _; c |]) -> glob_of_constr ?loc env sigma c + | App (_None, [| _ |]) -> no_such_number ?loc ty + | x -> Loc.raise ?loc (NumeralNotationError(env,sigma,UnexpectedNonOptionTerm c)) + +let uninterp_option c = + match Constr.kind c with + | App (_Some, [| _; x |]) -> x + | _ -> raise NotANumber + +let big2raw n = + if Bigint.is_pos_or_zero n then (Bigint.to_string n, true) + else (Bigint.to_string (Bigint.neg n), false) + +let raw2big (n,s) = + if s then Bigint.of_string n else Bigint.neg (Bigint.of_string n) + +let interp o ?loc n = + begin match o.warning with + | Warning threshold when snd n && rawnum_compare (fst n) threshold >= 0 -> + warn_large_num o.num_ty + | _ -> () + end; + let c = match fst o.to_kind with + | Int int_ty -> coqint_of_rawnum int_ty n + | UInt uint_ty when snd n -> coquint_of_rawnum uint_ty (fst n) + | UInt _ (* n <= 0 *) -> no_such_number ?loc o.num_ty + | Z z_pos_ty -> z_of_bigint z_pos_ty (raw2big n) + in + let env = Global.env () in + let sigma = Evd.from_env env in + let sigma,to_ty = Evd.fresh_global env sigma o.to_ty in + let to_ty = EConstr.Unsafe.to_constr to_ty in + match o.warning, snd o.to_kind with + | Abstract threshold, Direct when rawnum_compare (fst n) threshold >= 0 -> + warn_abstract_large_num (o.num_ty,o.to_ty); + glob_of_constr ?loc env sigma (mkApp (to_ty,[|c|])) + | _ -> + let res = eval_constr_app env sigma to_ty c in + match snd o.to_kind with + | Direct -> glob_of_constr ?loc env sigma res + | Option -> interp_option o.num_ty ?loc env sigma res + +let uninterp o (Glob_term.AnyGlobConstr n) = + let env = Global.env () in + let sigma = Evd.from_env env in + let sigma,of_ty = Evd.fresh_global env sigma o.of_ty in + let of_ty = EConstr.Unsafe.to_constr of_ty in + try + let sigma,n = constr_of_glob env sigma n in + let c = eval_constr_app env sigma of_ty n in + let c = if snd o.of_kind == Direct then c else uninterp_option c in + match fst o.of_kind with + | Int _ -> Some (rawnum_of_coqint c) + | UInt _ -> Some (rawnum_of_coquint c, true) + | Z _ -> Some (big2raw (bigint_of_z c)) + with + | Type_errors.TypeError _ | Pretype_errors.PretypeError _ -> None (* cf. eval_constr_app *) + | NotANumber -> None (* all other functions except big2raw *) +end + +(* A [prim_token_infos], which is synchronized with the document + state, either contains a unique id pointing to an unsynchronized + prim token function, or a numeral notation object describing how to + interpret and uninterpret. We provide [prim_token_infos] because + we expect plugins to provide their own interpretation functions, + rather than going through numeral notations, which are available as + a vernacular. *) + +type prim_token_interp_info = + Uid of prim_token_uid + | NumeralNotation of numeral_notation_obj + +type prim_token_infos = { + pt_local : bool; (** Is this interpretation local? *) + pt_scope : scope_name; (** Concerned scope *) + pt_interp_info : prim_token_interp_info; (** Unique id "pointing" to (un)interp functions, OR a numeral notation object describing (un)interp functions *) + pt_required : required_module; (** Module that should be loaded first *) + pt_refs : GlobRef.t list; (** Entry points during uninterpretation *) + pt_in_match : bool (** Is this prim token legal in match patterns ? *) +} + (* Table from scope_name to backtrack-able informations about interpreters (in particular interpreter unique id). *) let prim_token_interp_infos = - ref (String.Map.empty : (required_module * prim_token_uid) String.Map.t) + ref (String.Map.empty : (required_module * prim_token_interp_info) String.Map.t) (* Table from global_reference to backtrack-able informations about prim_token uninterpretation (in particular uninterpreter unique id). *) let prim_token_uninterp_infos = - ref (Refmap.empty : (scope_name * prim_token_uid * bool) Refmap.t) + ref (GlobRef.Map.empty : (scope_name * prim_token_interp_info * bool) GlobRef.Map.t) let hashtbl_check_and_set allow_overwrite uid f h eq = match Hashtbl.find h uid with @@ -406,23 +766,14 @@ let register_string_interpretation ?(allow_overwrite=false) uid (interp, uninter register_gen_interpretation allow_overwrite uid (InnerPrimToken.StringInterp interp, InnerPrimToken.StringUninterp uninterp) -type prim_token_infos = { - pt_local : bool; (** Is this interpretation local? *) - pt_scope : scope_name; (** Concerned scope *) - pt_uid : prim_token_uid; (** Unique id "pointing" to (un)interp functions *) - pt_required : required_module; (** Module that should be loaded first *) - pt_refs : GlobRef.t list; (** Entry points during uninterpretation *) - pt_in_match : bool (** Is this prim token legal in match patterns ? *) -} - let cache_prim_token_interpretation (_,infos) = + let ptii = infos.pt_interp_info in let sc = infos.pt_scope in - let uid = infos.pt_uid in - declare_scope sc; + check_scope ~tolerant:true sc; prim_token_interp_infos := - String.Map.add sc (infos.pt_required,infos.pt_uid) !prim_token_interp_infos; + String.Map.add sc (infos.pt_required,ptii) !prim_token_interp_infos; List.iter (fun r -> prim_token_uninterp_infos := - Refmap.add r (sc,uid,infos.pt_in_match) + GlobRef.Map.add r (sc,ptii,infos.pt_in_match) !prim_token_uninterp_infos) infos.pt_refs @@ -460,7 +811,7 @@ let declare_numeral_interpreter ?(local=false) sc dir interp (patl,uninterp,b) = enable_prim_token_interpretation { pt_local = local; pt_scope = sc; - pt_uid = uid; + pt_interp_info = Uid uid; pt_required = dir; pt_refs = List.map_filter glob_prim_constr_key patl; pt_in_match = b } @@ -470,7 +821,7 @@ let declare_string_interpreter ?(local=false) sc dir interp (patl,uninterp,b) = enable_prim_token_interpretation { pt_local = local; pt_scope = sc; - pt_uid = uid; + pt_interp_info = Uid uid; pt_required = dir; pt_refs = List.map_filter glob_prim_constr_key patl; pt_in_match = b } @@ -586,9 +937,12 @@ let find_prim_token check_allowed ?loc p sc = pat, df with Not_found -> (* Try for a primitive numerical notation *) - let (spdir,uid) = String.Map.find sc !prim_token_interp_infos in + let (spdir,info) = String.Map.find sc !prim_token_interp_infos in check_required_module ?loc sc spdir; - let interp = Hashtbl.find prim_token_interpreters uid in + let interp = match info with + | Uid uid -> Hashtbl.find prim_token_interpreters uid + | NumeralNotation o -> InnerPrimToken.RawNumInterp (Numeral.interp o) + in let pat = InnerPrimToken.do_interp ?loc interp p in check_allowed pat; pat, ((dirpath (fst spdir),DirPath.empty),"") @@ -764,8 +1118,11 @@ let uninterp_prim_token c = | None -> raise Notation_ops.No_match | Some r -> try - let (sc,uid,_) = Refmap.find r !prim_token_uninterp_infos in - let uninterp = Hashtbl.find prim_token_uninterpreters uid in + let (sc,info,_) = GlobRef.Map.find r !prim_token_uninterp_infos in + let uninterp = match info with + | Uid uid -> Hashtbl.find prim_token_uninterpreters uid + | NumeralNotation o -> InnerPrimToken.RawNumUninterp (Numeral.uninterp o) + in match InnerPrimToken.do_uninterp uninterp (AnyGlobConstr c) with | None -> raise Notation_ops.No_match | Some n -> (sc,n) @@ -780,12 +1137,16 @@ let availability_of_prim_token n printer_scope local_scopes = let f scope = try let uid = snd (String.Map.find scope !prim_token_interp_infos) in - let interp = Hashtbl.find prim_token_interpreters uid in let open InnerPrimToken in - match n, interp with - | Numeral _, (RawNumInterp _ | BigNumInterp _) -> true - | String _, StringInterp _ -> true - | _ -> false + match n, uid with + | Numeral _, NumeralNotation _ -> true + | _, NumeralNotation _ -> false + | _, Uid uid -> + let interp = Hashtbl.find prim_token_interpreters uid in + match n, interp with + | Numeral _, (RawNumInterp _ | BigNumInterp _) -> true + | String _, StringInterp _ -> true + | _ -> false with Not_found -> false in let scopes = make_current_scopes local_scopes in @@ -905,7 +1266,7 @@ let rec update_scopes cls scl = match cls, scl with | _, [] -> List.map find_scope_class_opt cls | cl :: cls, sco :: scl -> update_scope cl sco :: update_scopes cls scl -let arguments_scope = ref Refmap.empty +let arguments_scope = ref GlobRef.Map.empty type arguments_scope_discharge_request = | ArgsScopeAuto @@ -915,7 +1276,7 @@ type arguments_scope_discharge_request = let load_arguments_scope _ (_,(_,r,n,scl,cls)) = List.iter (Option.iter check_scope) scl; let initial_stamp = ScopeClassMap.empty in - arguments_scope := Refmap.add r (scl,cls,initial_stamp) !arguments_scope + arguments_scope := GlobRef.Map.add r (scl,cls,initial_stamp) !arguments_scope let cache_arguments_scope o = load_arguments_scope 1 o @@ -996,13 +1357,13 @@ let declare_arguments_scope local r scl = let find_arguments_scope r = try - let (scl,cls,stamp) = Refmap.find r !arguments_scope in + let (scl,cls,stamp) = GlobRef.Map.find r !arguments_scope in let cur_stamp = !scope_class_map in if stamp == cur_stamp then scl else (* Recent changes in the Bind Scope base, we re-compute the scopes *) let scl' = update_scopes cls scl in - arguments_scope := Refmap.add r (scl',cls,cur_stamp) !arguments_scope; + arguments_scope := GlobRef.Map.add r (scl',cls,cur_stamp) !arguments_scope; scl' with Not_found -> [] @@ -1331,7 +1692,7 @@ let init () = notations_key_table := KeyMap.empty; scope_class_map := initial_scope_class_map; prim_token_interp_infos := String.Map.empty; - prim_token_uninterp_infos := Refmap.empty + prim_token_uninterp_infos := GlobRef.Map.empty let _ = Summary.declare_summary "symbols" diff --git a/interp/notation.mli b/interp/notation.mli index e5478eff48..734198bbf6 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -41,6 +41,9 @@ type scopes (** = [scope_name list] *) val declare_scope : scope_name -> unit +(* To be removed after deprecation phase *) +val ensure_scope : scope_name -> unit + val current_scopes : unit -> scopes (** Check where a scope is opened or not in a scope list, or in @@ -99,10 +102,51 @@ val register_bignumeral_interpretation : val register_string_interpretation : ?allow_overwrite:bool -> prim_token_uid -> string prim_token_interpretation -> unit +(** * Numeral notation *) + +type numeral_notation_error = + | UnexpectedTerm of Constr.t + | UnexpectedNonOptionTerm of Constr.t + +exception NumeralNotationError of Environ.env * Evd.evar_map * numeral_notation_error + +type numnot_option = + | Nop + | Warning of raw_natural_number + | Abstract of raw_natural_number + +type int_ty = + { uint : Names.inductive; + int : Names.inductive } + +type z_pos_ty = + { z_ty : Names.inductive; + pos_ty : Names.inductive } + +type target_kind = + | Int of int_ty (* Coq.Init.Decimal.int + uint *) + | UInt of Names.inductive (* Coq.Init.Decimal.uint *) + | Z of z_pos_ty (* Coq.Numbers.BinNums.Z and positive *) + +type option_kind = Option | Direct +type conversion_kind = target_kind * option_kind + +type numeral_notation_obj = + { to_kind : conversion_kind; + to_ty : GlobRef.t; + of_kind : conversion_kind; + of_ty : GlobRef.t; + num_ty : Libnames.qualid; (* for warnings / error messages *) + warning : numnot_option } + +type prim_token_interp_info = + Uid of prim_token_uid + | NumeralNotation of numeral_notation_obj + type prim_token_infos = { pt_local : bool; (** Is this interpretation local? *) pt_scope : scope_name; (** Concerned scope *) - pt_uid : prim_token_uid; (** Unique id "pointing" to (un)interp functions *) + pt_interp_info : prim_token_interp_info; (** Unique id "pointing" to (un)interp functions, OR a numeral notation object describing (un)interp functions *) pt_required : required_module; (** Module that should be loaded first *) pt_refs : GlobRef.t list; (** Entry points during uninterpretation *) pt_in_match : bool (** Is this prim token legal in match patterns ? *) diff --git a/interp/reserve.ml b/interp/reserve.ml index 071248f01f..edbdf1dbba 100644 --- a/interp/reserve.ml +++ b/interp/reserve.ml @@ -28,7 +28,7 @@ type key = (** TODO: share code from Notation *) let key_compare k1 k2 = match k1, k2 with -| RefKey gr1, RefKey gr2 -> RefOrdered.compare gr1 gr2 +| RefKey gr1, RefKey gr2 -> GlobRef.Ordered.compare gr1 gr2 | RefKey _, Oth -> -1 | Oth, RefKey _ -> 1 | Oth, Oth -> 0 diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml index 9a1224aab2..ed3bd866a4 100644 --- a/kernel/cbytecodes.ml +++ b/kernel/cbytecodes.ml @@ -15,78 +15,7 @@ (* This file defines the type of bytecode instructions *) open Names -open Constr - -type tag = int - -let accu_tag = 0 - -let type_atom_tag = 2 -let max_atom_tag = 2 -let proj_tag = 3 -let fix_app_tag = 4 -let switch_tag = 5 -let cofix_tag = 6 -let cofix_evaluated_tag = 7 - -(* It would be great if OCaml exported this value, - So fixme if this happens in a new version of OCaml *) -let last_variant_tag = 245 - -type structured_constant = - | Const_sort of Sorts.t - | Const_ind of inductive - | Const_b0 of tag - | Const_bn of tag * structured_constant array - | Const_univ_level of Univ.Level.t - -type reloc_table = (tag * int) array - -type annot_switch = - {ci : case_info; rtbl : reloc_table; tailcall : bool; max_stack_size : int} - -let rec eq_structured_constant c1 c2 = match c1, c2 with -| Const_sort s1, Const_sort s2 -> Sorts.equal s1 s2 -| Const_sort _, _ -> false -| Const_ind i1, Const_ind i2 -> eq_ind i1 i2 -| Const_ind _, _ -> false -| Const_b0 t1, Const_b0 t2 -> Int.equal t1 t2 -| Const_b0 _, _ -> false -| Const_bn (t1, a1), Const_bn (t2, a2) -> - Int.equal t1 t2 && CArray.equal eq_structured_constant a1 a2 -| Const_bn _, _ -> false -| Const_univ_level l1 , Const_univ_level l2 -> Univ.Level.equal l1 l2 -| Const_univ_level _ , _ -> false - -let rec hash_structured_constant c = - let open Hashset.Combine in - match c with - | Const_sort s -> combinesmall 1 (Sorts.hash s) - | Const_ind i -> combinesmall 2 (ind_hash i) - | Const_b0 t -> combinesmall 3 (Int.hash t) - | Const_bn (t, a) -> - let fold h c = combine h (hash_structured_constant c) in - let h = Array.fold_left fold 0 a in - combinesmall 4 (combine (Int.hash t) h) - | Const_univ_level l -> combinesmall 5 (Univ.Level.hash l) - -let eq_annot_switch asw1 asw2 = - let eq_ci ci1 ci2 = - eq_ind ci1.ci_ind ci2.ci_ind && - Int.equal ci1.ci_npar ci2.ci_npar && - CArray.equal Int.equal ci1.ci_cstr_ndecls ci2.ci_cstr_ndecls - in - let eq_rlc (i1, j1) (i2, j2) = Int.equal i1 i2 && Int.equal j1 j2 in - eq_ci asw1.ci asw2.ci && - CArray.equal eq_rlc asw1.rtbl asw2.rtbl && - (asw1.tailcall : bool) == asw2.tailcall - -let hash_annot_switch asw = - let open Hashset.Combine in - let h1 = Constr.case_info_hash asw.ci in - let h2 = Array.fold_left (fun h (t, i) -> combine3 h t i) 0 asw.rtbl in - let h3 = if asw.tailcall then 1 else 0 in - combine3 h1 h2 h3 +open Vmvalues module Label = struct @@ -232,21 +161,6 @@ type comp_env = { open Pp open Util -let pp_sort s = - let open Sorts in - match s with - | Prop -> str "Prop" - | Set -> str "Set" - | Type u -> str "Type@{" ++ Univ.pr_uni u ++ str "}" - -let rec pp_struct_const = function - | Const_sort s -> pp_sort s - | Const_ind (mind, i) -> MutInd.print mind ++ str"#" ++ int i - | Const_b0 i -> int i - | Const_bn (i,t) -> - int i ++ surround (prvect_with_sep pr_comma pp_struct_const t) - | Const_univ_level l -> Univ.Level.pr l - let pp_lbl lbl = str "L" ++ int lbl let pp_fv_elem = function diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli index f17a1e657e..9c04c166a2 100644 --- a/kernel/cbytecodes.mli +++ b/kernel/cbytecodes.mli @@ -11,41 +11,7 @@ (* $Id$ *) open Names -open Constr - -type tag = int - -val accu_tag : tag - -val type_atom_tag : tag -val max_atom_tag : tag -val proj_tag : tag -val fix_app_tag : tag -val switch_tag : tag -val cofix_tag : tag -val cofix_evaluated_tag : tag - -val last_variant_tag : tag - -type structured_constant = - | Const_sort of Sorts.t - | Const_ind of inductive - | Const_b0 of tag - | Const_bn of tag * structured_constant array - | Const_univ_level of Univ.Level.t - -val pp_struct_const : structured_constant -> Pp.t - -type reloc_table = (tag * int) array - -type annot_switch = - {ci : case_info; rtbl : reloc_table; tailcall : bool; max_stack_size : int} - -val eq_structured_constant : structured_constant -> structured_constant -> bool -val hash_structured_constant : structured_constant -> int - -val eq_annot_switch : annot_switch -> annot_switch -> bool -val hash_annot_switch : annot_switch -> int +open Vmvalues module Label : sig diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index e336ea922d..5362f9a814 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -14,6 +14,7 @@ open Util open Names +open Vmvalues open Cbytecodes open Cemitcodes open Cinstr @@ -395,17 +396,17 @@ let init_fun_code () = fun_code := [] (* If [tag] hits the OCaml limitation for non constant constructors, we switch to another representation for the remaining constructors: -[last_variant_tag|tag - last_variant_tag|args] +[last_variant_tag|tag - Obj.last_non_constant_constructor_tag|args] -We subtract last_variant_tag for efficiency of match interpretation. +We subtract Obj.last_non_constant_constructor_tag for efficiency of match interpretation. *) let nest_block tag arity cont = - Kconst (Const_b0 (tag - last_variant_tag)) :: - Kmakeblock(arity+1, last_variant_tag) :: cont + Kconst (Const_b0 (tag - Obj.last_non_constant_constructor_tag)) :: + Kmakeblock(arity+1, Obj.last_non_constant_constructor_tag) :: cont let code_makeblock ~stack_size ~arity ~tag cont = - if tag < last_variant_tag then + if tag < Obj.last_non_constant_constructor_tag then Kmakeblock(arity, tag) :: cont else begin set_max_stack_size (stack_size + 1); @@ -490,7 +491,9 @@ let rec compile_lam env cenv lam sz cont = match lam with | Lrel(_, i) -> pos_rel i cenv sz :: cont - | Lval v -> compile_structured_constant cenv v sz cont + | Lint i -> compile_structured_constant cenv (Const_b0 i) sz cont + + | Lval v -> compile_structured_constant cenv (Const_val v) sz cont | Lproj (p,arg) -> compile_lam env cenv arg sz (Kproj p :: cont) @@ -634,9 +637,9 @@ let rec compile_lam env cenv lam sz cont = let lbl_consts = Array.make oib.mind_nb_constant Label.no in let nallblock = oib.mind_nb_args + 1 in (* +1 : accumulate *) let nconst = Array.length branches.constant_branches in - let nblock = min nallblock (last_variant_tag + 1) in + let nblock = min nallblock (Obj.last_non_constant_constructor_tag + 1) in let lbl_blocks = Array.make nblock Label.no in - let neblock = max 0 (nallblock - last_variant_tag) in + let neblock = max 0 (nallblock - Obj.last_non_constant_constructor_tag) in let lbl_eblocks = Array.make neblock Label.no in let branch1, cont = make_branch cont in (* Compilation of the return type *) @@ -662,7 +665,7 @@ let rec compile_lam env cenv lam sz cont = let lbl_b, code_b = label_code ( Kpush :: Kfield 0 :: Kswitch(lbl_eblocks, [||]) :: !c) in - lbl_blocks.(last_variant_tag) <- lbl_b; + lbl_blocks.(Obj.last_non_constant_constructor_tag) <- lbl_b; c := code_b end; @@ -684,7 +687,7 @@ let rec compile_lam env cenv lam sz cont = compile_lam env (push_param arity sz_b cenv) body (sz_b+arity) (add_pop arity (branch::!c)) in let code_b = - if tag < last_variant_tag then begin + if tag < Obj.last_non_constant_constructor_tag then begin set_max_stack_size (sz_b + arity); Kpushfields arity :: code_b end @@ -694,8 +697,8 @@ let rec compile_lam env cenv lam sz cont = end in let lbl_b, code_b = label_code code_b in - if tag < last_variant_tag then lbl_blocks.(tag) <- lbl_b - else lbl_eblocks.(tag - last_variant_tag) <- lbl_b; + if tag < Obj.last_non_constant_constructor_tag then lbl_blocks.(tag) <- lbl_b + else lbl_eblocks.(tag - Obj.last_non_constant_constructor_tag) <- lbl_b; c := code_b done; diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index ca24f9b689..50f5607e31 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -14,6 +14,7 @@ open Names open Constr +open Vmvalues open Cbytecodes open Copcodes open Mod_subst @@ -357,10 +358,9 @@ let rec emit env insns remaining = match insns with type to_patch = emitcodes * patches * fv (* Substitution *) -let rec subst_strcst s sc = +let subst_strcst s sc = match sc with - | Const_sort _ | Const_b0 _ | Const_univ_level _ -> sc - | Const_bn(tag,args) -> Const_bn(tag,Array.map (subst_strcst s) args) + | Const_sort _ | Const_b0 _ | Const_univ_level _ | Const_val _ -> sc | Const_ind ind -> let kn,i = ind in Const_ind (subst_mind s kn, i) let subst_reloc s ri = diff --git a/kernel/cemitcodes.mli b/kernel/cemitcodes.mli index 9009926bdb..39ddf4a047 100644 --- a/kernel/cemitcodes.mli +++ b/kernel/cemitcodes.mli @@ -1,4 +1,5 @@ open Names +open Vmvalues open Cbytecodes type reloc_info = diff --git a/kernel/cinstr.mli b/kernel/cinstr.mli index 171ca38830..dca1757b7d 100644 --- a/kernel/cinstr.mli +++ b/kernel/cinstr.mli @@ -9,6 +9,7 @@ (************************************************************************) open Names open Constr +open Vmvalues open Cbytecodes (** This file defines the lambda code for the bytecode compiler. It has been @@ -33,10 +34,11 @@ and lambda = | Lfix of (int array * int) * fix_decl | Lcofix of int * fix_decl (* must be in eta-expanded form *) | Lmakeblock of int * lambda array - | Lval of structured_constant + | Lval of structured_values | Lsort of Sorts.t | Lind of pinductive | Lproj of Projection.Repr.t * lambda + | Lint of int | Luint of uint (* Cofixpoints have to be in eta-expanded form for their call-by-need evaluation diff --git a/kernel/clambda.ml b/kernel/clambda.ml index 7c00e40fb0..31dede6f5d 100644 --- a/kernel/clambda.ml +++ b/kernel/clambda.ml @@ -4,6 +4,7 @@ open Esubst open Term open Constr open Declarations +open Vmvalues open Cbytecodes open Cinstr open Environ @@ -115,6 +116,8 @@ let rec pp_lam lam = hov 1 (str "(proj " ++ Projection.Repr.print p ++ str "(" ++ pp_lam arg ++ str ")") + | Lint i -> + Pp.(str "(int:" ++ int i ++ str ")") | Luint _ -> str "(uint)" @@ -150,7 +153,7 @@ let shift subst = subs_shft (1, subst) let rec map_lam_with_binders g f n lam = match lam with - | Lrel _ | Lvar _ | Lconst _ | Lval _ | Lsort _ | Lind _ -> lam + | Lrel _ | Lvar _ | Lconst _ | Lval _ | Lsort _ | Lind _ | Lint _ -> lam | Levar (evk, args) -> let args' = Array.Smart.map (f n) args in if args == args' then lam else Levar (evk, args') @@ -269,7 +272,7 @@ let lam_subst_args subst args = let can_subst lam = match lam with | Lrel _ | Lvar _ | Lconst _ - | Lval _ | Lsort _ | Lind _ | Llam _ -> true + | Lval _ | Lsort _ | Lind _ -> true | _ -> false let rec simplify subst lam = @@ -349,7 +352,7 @@ let rec occurrence k kind lam = if n = k then if kind then false else raise Not_found else kind - | Lvar _ | Lconst _ | Lval _ | Lsort _ | Lind _ -> kind + | Lvar _ | Lconst _ | Lval _ | Lsort _ | Lind _ | Lint _ -> kind | Levar (_, args) -> occurrence_args k kind args | Lprod(dom, codom) -> @@ -419,7 +422,7 @@ let rec remove_let subst lam = exception TooLargeInductive of Pp.t let max_nb_const = 0x1000000 -let max_nb_block = 0x1000000 + last_variant_tag - 1 +let max_nb_block = 0x1000000 + Obj.last_non_constant_constructor_tag - 1 let str_max_constructors = Format.sprintf @@ -436,23 +439,22 @@ let check_compilable ib = let is_value lc = match lc with - | Lval _ -> true + | Lval _ | Lint _ -> true | _ -> false let get_value lc = match lc with | Lval v -> v + | Lint i -> val_of_int i | _ -> raise Not_found -let mkConst_b0 n = Lval (Cbytecodes.Const_b0 n) - let make_args start _end = Array.init (start - _end + 1) (fun i -> Lrel (Anonymous, start - i)) (* Translation of constructors *) let expand_constructor tag nparams arity = let ids = Array.make (nparams + arity) Anonymous in - if arity = 0 then mkLlam ids (mkConst_b0 tag) + if arity = 0 then mkLlam ids (Lint tag) else let args = make_args arity 1 in Llam(ids, Lmakeblock (tag, args)) @@ -463,15 +465,15 @@ let makeblock tag nparams arity args = mkLapp (expand_constructor tag nparams arity) args else (* The constructor is fully applied *) - if arity = 0 then mkConst_b0 tag + if arity = 0 then Lint tag else if Array.for_all is_value args then - if tag < last_variant_tag then - Lval(Cbytecodes.Const_bn(tag, Array.map get_value args)) + if tag < Obj.last_non_constant_constructor_tag then + Lval(val_of_block tag (Array.map get_value args)) else let args = Array.map get_value args in - let args = Array.append [|Cbytecodes.Const_b0 (tag - last_variant_tag) |] args in - Lval(Cbytecodes.Const_bn(last_variant_tag, args)) + let args = Array.append [| val_of_int (tag - Obj.last_non_constant_constructor_tag) |] args in + Lval(val_of_block Obj.last_non_constant_constructor_tag args) else Lmakeblock(tag, args) @@ -659,11 +661,11 @@ let rec lambda_of_constr env c = (* translation of the argument *) let la = lambda_of_constr env a in - let entry = mkInd ind in + let gr = GlobRef.IndRef ind in let la = try Retroknowledge.get_vm_before_match_info env.global_env.retroknowledge - entry la + gr la with Not_found -> la in (* translation of the type *) @@ -721,7 +723,7 @@ and lambda_of_app env f args = (try (* We delay the compilation of arguments to avoid an exponential behavior *) let f = Retroknowledge.get_vm_compiling_info env.global_env.retroknowledge - (mkConstU (kn,u)) in + (GlobRef.ConstRef kn) in let args = lambda_of_args env 0 args in f args with Not_found -> @@ -734,6 +736,7 @@ and lambda_of_app env f args = | Construct (c,_) -> let tag, nparams, arity = Renv.get_construct_info env c in let nargs = Array.length args in + let gr = GlobRef.ConstructRef c in if Int.equal (nparams + arity) nargs then (* fully applied *) (* spiwack: *) (* 1/ tries to compile the constructor in an optimal way, @@ -748,7 +751,7 @@ and lambda_of_app env f args = try Retroknowledge.get_vm_constant_static_info env.global_env.retroknowledge - f args + gr args with NotClosed -> (* 2/ if the arguments are not all closed (this is expectingly (and it is currently the case) the only @@ -769,7 +772,7 @@ and lambda_of_app env f args = let args = lambda_of_args env nparams rargs in Retroknowledge.get_vm_constant_dynamic_info env.global_env.retroknowledge - f args + gr args with Not_found -> (* 3/ if no special behavior is available, then the compiler falls back to the normal behavior *) @@ -782,7 +785,7 @@ and lambda_of_app env f args = (try (Retroknowledge.get_vm_constant_dynamic_info env.global_env.retroknowledge - f) args + gr) args with Not_found -> if nparams <= nargs then (* got all parameters *) makeblock tag 0 arity args @@ -834,10 +837,11 @@ let dynamic_int31_compilation fc args = if not fc then raise Not_found else Luint (UintDigits args) +let d0 = Lint 0 +let d1 = Lint 1 + (* We are relying here on the tags of digits constructors *) let digits_from_uint i = - let d0 = mkConst_b0 0 in - let d1 = mkConst_b0 1 in let digits = Array.make 31 d0 in for k = 0 to 30 do if Int.equal ((Uint31.to_int i lsr k) land 1) 1 then diff --git a/kernel/constr.ml b/kernel/constr.ml index 9bf743152f..c73fe7fbde 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -503,7 +503,79 @@ let fold_constr_with_binders g f n acc c = not recursive and the order with which subterms are processed is not specified *) -let map f c = match kind c with +let rec map_under_context f n d = + if n = 0 then f d else + match kind d with + | LetIn (na,b,t,c) -> + let b' = f b in + let t' = f t in + let c' = map_under_context f (n-1) c in + if b' == b && t' == t && c' == c then d + else mkLetIn (na,b',t',c') + | Lambda (na,t,b) -> + let t' = f t in + let b' = map_under_context f (n-1) b in + if t' == t && b' == b then d + else mkLambda (na,t',b') + | _ -> CErrors.anomaly (Pp.str "Ill-formed context") + +let map_branches f ci bl = + let nl = Array.map List.length ci.ci_pp_info.cstr_tags in + let bl' = Array.map2 (map_under_context f) nl bl in + if Array.for_all2 (==) bl' bl then bl else bl' + +let map_return_predicate f ci p = + map_under_context f (List.length ci.ci_pp_info.ind_tags) p + +let rec map_under_context_with_binders g f l n d = + if n = 0 then f l d else + match kind d with + | LetIn (na,b,t,c) -> + let b' = f l b in + let t' = f l t in + let c' = map_under_context_with_binders g f (g l) (n-1) c in + if b' == b && t' == t && c' == c then d + else mkLetIn (na,b',t',c') + | Lambda (na,t,b) -> + let t' = f l t in + let b' = map_under_context_with_binders g f (g l) (n-1) b in + if t' == t && b' == b then d + else mkLambda (na,t',b') + | _ -> CErrors.anomaly (Pp.str "Ill-formed context") + +let map_branches_with_binders g f l ci bl = + let tags = Array.map List.length ci.ci_pp_info.cstr_tags in + let bl' = Array.map2 (map_under_context_with_binders g f l) tags bl in + if Array.for_all2 (==) bl' bl then bl else bl' + +let map_return_predicate_with_binders g f l ci p = + map_under_context_with_binders g f l (List.length ci.ci_pp_info.ind_tags) p + +let rec map_under_context_with_full_binders g f l n d = + if n = 0 then f l d else + match kind d with + | LetIn (na,b,t,c) -> + let b' = f l b in + let t' = f l t in + let c' = map_under_context_with_full_binders g f (g (Context.Rel.Declaration.LocalDef (na,b,t)) l) (n-1) c in + if b' == b && t' == t && c' == c then d + else mkLetIn (na,b',t',c') + | Lambda (na,t,b) -> + let t' = f l t in + let b' = map_under_context_with_full_binders g f (g (Context.Rel.Declaration.LocalAssum (na,t)) l) (n-1) b in + if t' == t && b' == b then d + else mkLambda (na,t',b') + | _ -> CErrors.anomaly (Pp.str "Ill-formed context") + +let map_branches_with_full_binders g f l ci bl = + let tags = Array.map List.length ci.ci_pp_info.cstr_tags in + let bl' = Array.map2 (map_under_context_with_full_binders g f l) tags bl in + if Array.for_all2 (==) bl' bl then bl else bl' + +let map_return_predicate_with_full_binders g f l ci p = + map_under_context_with_full_binders g f l (List.length ci.ci_pp_info.ind_tags) p + +let map_gen userview f c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> c | Cast (b,k,t) -> @@ -540,6 +612,12 @@ let map f c = match kind c with let l' = Array.Smart.map f l in if l'==l then c else mkEvar (e, l') + | Case (ci,p,b,bl) when userview -> + let b' = f b in + let p' = map_return_predicate f ci p in + let bl' = map_branches f ci bl in + if b'==b && p'==p && bl'==bl then c + else mkCase (ci, p', b', bl') | Case (ci,p,b,bl) -> let b' = f b in let p' = f p in @@ -557,6 +635,9 @@ let map f c = match kind c with if tl'==tl && bl'==bl then c else mkCoFix (ln,(lna,tl',bl')) +let map_user_view = map_gen true +let map = map_gen false + (* Like {!map} but with an accumulator. *) let fold_map f accu c = match kind c with diff --git a/kernel/constr.mli b/kernel/constr.mli index 70acf19328..ea38dabd5c 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -285,8 +285,8 @@ val destMeta : constr -> metavariable (** Destructs a variable *) val destVar : constr -> Id.t -(** Destructs a sort. [is_Prop] recognizes the sort {% \textsf{%}Prop{% }%}, whether - [isprop] recognizes both {% \textsf{%}Prop{% }%} and {% \textsf{%}Set{% }%}. *) +(** Destructs a sort. [is_Prop] recognizes the sort [Prop], whether + [isprop] recognizes both [Prop] and [Set]. *) val destSort : constr -> Sorts.t (** Destructs a casted term *) @@ -381,6 +381,85 @@ type rel_context = rel_declaration list type named_context = named_declaration list type compacted_context = compacted_declaration list +(** {6 Functionals working on expressions canonically abstracted over + a local context (possibly with let-ins)} *) + +(** [map_under_context f l c] maps [f] on the immediate subterms of a + term abstracted over a context of length [n] (local definitions + are counted) *) + +val map_under_context : (constr -> constr) -> int -> constr -> constr + +(** [map_branches f br] maps [f] on the immediate subterms of an array + of "match" branches [br] in canonical eta-let-expanded form; it is + not recursive and the order with which subterms are processed is + not specified; it preserves sharing; the immediate subterms are the + types and possibly terms occurring in the context of each branch as + well as the body of each branch *) + +val map_branches : (constr -> constr) -> case_info -> constr array -> constr array + +(** [map_return_predicate f p] maps [f] on the immediate subterms of a + return predicate of a "match" in canonical eta-let-expanded form; + it is not recursive and the order with which subterms are processed + is not specified; it preserves sharing; the immediate subterms are + the types and possibly terms occurring in the context of each + branch as well as the body of the predicate *) + +val map_return_predicate : (constr -> constr) -> case_info -> constr -> constr + +(** [map_under_context_with_binders g f n l c] maps [f] on the + immediate subterms of a term abstracted over a context of length + [n] (local definitions are counted); it preserves sharing; it + carries an extra data [n] (typically a lift index) which is + processed by [g] (which typically add 1 to [n]) at each binder + traversal *) + +val map_under_context_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> int -> constr -> constr + +(** [map_branches_with_binders f br] maps [f] on the immediate + subterms of an array of "match" branches [br] in canonical + eta-let-expanded form; it carries an extra data [n] (typically a + lift index) which is processed by [g] (which typically adds 1 to + [n]) at each binder traversal; it is not recursive and the order + with which subterms are processed is not specified; it preserves + sharing; the immediate subterms are the types and possibly terms + occurring in the context of the branch as well as the body of the + branch *) + +val map_branches_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> case_info -> constr array -> constr array + +(** [map_return_predicate_with_binders f p] maps [f] on the immediate + subterms of a return predicate of a "match" in canonical + eta-let-expanded form; it carries an extra data [n] (typically a + lift index) which is processed by [g] (which typically adds 1 to + [n]) at each binder traversal; it is not recursive and the order + with which subterms are processed is not specified; it preserves + sharing; the immediate subterms are the types and possibly terms + occurring in the context of each branch as well as the body of the + predicate *) + +val map_return_predicate_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> case_info -> constr -> constr + +(** [map_under_context_with_full_binders g f n l c] is similar to + [map_under_context_with_binders] except that [g] takes also a full + binder as argument and that only the number of binders (and not + their signature) is required *) + +val map_under_context_with_full_binders : ((constr, constr) Context.Rel.Declaration.pt -> 'a -> 'a) -> ('a -> constr -> constr) -> 'a -> int -> constr -> constr + +(** [map_branches_with_full_binders g f l br] is equivalent to + [map_branches_with_binders] but using + [map_under_context_with_full_binders] *) + +val map_branches_with_full_binders : ((constr, constr) Context.Rel.Declaration.pt -> 'a -> 'a) -> ('a -> constr -> constr) -> 'a -> case_info -> constr array -> constr array + +(** [map_return_predicate_with_full_binders g f l p] is equivalent to + [map_return_predicate_with_binders] but using + [map_under_context_with_full_binders] *) + +val map_return_predicate_with_full_binders : ((constr, constr) Context.Rel.Declaration.pt -> 'a -> 'a) -> ('a -> constr -> constr) -> 'a -> case_info -> constr -> constr + (** {6 Functionals working on the immediate subterm of a construction } *) (** [fold f acc c] folds [f] on the immediate subterms of [c] @@ -395,6 +474,13 @@ val fold : ('a -> constr -> 'a) -> 'a -> constr -> 'a val map : (constr -> constr) -> constr -> constr +(** [map_user_view f c] maps [f] on the immediate subterms of [c]; it + differs from [map f c] in that the typing context and body of the + return predicate and of the branches of a [match] are considered as + immediate subterm of a [match] *) + +val map_user_view : (constr -> constr) -> constr -> constr + (** Like {!map}, but also has an additional accumulator. *) val fold_map : ('a -> constr -> 'a * constr) -> 'a -> constr -> 'a * constr diff --git a/kernel/declarations.ml b/kernel/declarations.ml index 1d49550442..61fcb4832a 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -164,7 +164,7 @@ type one_inductive_body = { mind_nb_args : int; (** number of no constant constructor *) - mind_reloc_tbl : Cbytecodes.reloc_table; + mind_reloc_tbl : Vmvalues.reloc_table; } type abstract_inductive_universes = diff --git a/kernel/environ.ml b/kernel/environ.ml index e7efa5e2c9..3bfcaa7f52 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -365,8 +365,7 @@ let push_constraints_to_env (_,univs) env = let add_universes strict ctx g = let g = Array.fold_left - (* Be lenient, module typing reintroduces universes and constraints due to includes *) - (fun g v -> try UGraph.add_universe v strict g with UGraph.AlreadyDeclared -> g) + (fun g v -> UGraph.add_universe v strict g) g (Univ.Instance.to_array (Univ.UContext.instance ctx)) in UGraph.merge_constraints (Univ.UContext.constraints ctx) g @@ -376,6 +375,7 @@ let push_context ?(strict=false) ctx env = let add_universes_set strict ctx g = let g = Univ.LSet.fold + (* Be lenient, module typing reintroduces universes and constraints due to includes *) (fun v g -> try UGraph.add_universe v strict g with UGraph.AlreadyDeclared -> g) (Univ.ContextSet.levels ctx) g in UGraph.merge_constraints (Univ.ContextSet.constraints ctx) g @@ -693,12 +693,12 @@ let register_one env field entry = { env with retroknowledge = Retroknowledge.add_field env.retroknowledge field entry } (* [register env field entry] may register several fields when needed *) -let register env field entry = +let register env field gr = match field with - | KInt31 (grp, Int31Type) -> - let i31c = match kind entry with - | Ind i31t -> mkConstructUi (i31t, 1) - | _ -> anomaly ~label:"Environ.register" (Pp.str "should be an inductive type.") - in - register_one (register_one env (KInt31 (grp,Int31Constructor)) i31c) field entry - | field -> register_one env field entry + | KInt31 Int31Type -> + let i31c = match gr with + | GlobRef.IndRef i31t -> GlobRef.ConstructRef (i31t, 1) + | _ -> anomaly ~label:"Environ.register" (Pp.str "should be an inductive type.") + in + register_one (register_one env (KInt31 Int31Constructor) i31c) field gr + | field -> register_one env field gr diff --git a/kernel/environ.mli b/kernel/environ.mli index f45b7be821..1343b9029b 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -325,7 +325,7 @@ val retroknowledge : (retroknowledge->'a) -> env -> 'a val registered : env -> field -> bool -val register : env -> field -> Retroknowledge.entry -> env +val register : env -> field -> GlobRef.t -> env (** Native compiler *) val no_link_info : link_info diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index d7eb865e0a..7abf8027bd 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -234,8 +234,7 @@ let check_subtyping cumi paramsctxt env_ar inds = let instance_other = Instance.of_array new_levels in let constraints_other = Univ.subst_univs_level_constraints lmap (Univ.UContext.constraints uctx) in let uctx_other = Univ.UContext.make (instance_other, constraints_other) in - let env = Environ.push_context uctx env_ar in - let env = Environ.push_context uctx_other env in + let env = Environ.push_context uctx_other env_ar in let subtyp_constraints = CumulativityInfo.leq_constraints cumi (UContext.instance uctx) instance_other @@ -280,7 +279,7 @@ let typecheck_inductive env mie = List.fold_left (fun (env_ar,l) ind -> (* Arities (without params) are typed-checked here *) - let expltype = ind.mind_entry_template in + let template = ind.mind_entry_template in let arity = if isArity ind.mind_entry_arity then let (ctx,s) = dest_arity env_params ind.mind_entry_arity in @@ -316,7 +315,7 @@ let typecheck_inductive env mie = let env_ar' = push_rel (LocalAssum (Name id, full_arity)) env_ar in (* (add_constraints cst2 env_ar) in *) - (env_ar', (id,full_arity,sign @ paramsctxt,expltype,deflev,inflev)::l)) + (env_ar', (id,full_arity,sign @ paramsctxt,template,deflev,inflev)::l)) (env',[]) mie.mind_entry_inds in @@ -343,7 +342,7 @@ let typecheck_inductive env mie = (* Compute/check the sorts of the inductive types *) let inds = - Array.map (fun ((id,full_arity,sign,expltype,def_level,inf_level),cn,lc,clev) -> + Array.map (fun ((id,full_arity,sign,template,def_level,inf_level),cn,lc,clev) -> let infu = (** Inferred level, with parameters and constructors. *) match inf_level with @@ -369,31 +368,34 @@ let typecheck_inductive env mie = RegularArity (not is_natural,full_arity,defu) in let template_polymorphic () = - let sign, s = + let _, s = try dest_arity env full_arity with NotArity -> raise (InductiveError (NotAnArity (env, full_arity))) - in - match s with - | Type u when expltype (* Explicitly polymorphic *) -> - (* The polymorphic level is a function of the level of the *) - (* conclusions of the parameters *) - (* We enforce [u >= lev] in case [lev] has a strict upper *) - (* constraints over [u] *) - let b = type_in_type env || UGraph.check_leq (universes env') infu u in - if not b then - anomaly ~label:"check_inductive" - (Pp.str"Incorrect universe " ++ - Universe.pr u ++ Pp.str " declared for inductive type, inferred level is " - ++ Universe.pr clev ++ Pp.str ".") - else - TemplateArity (param_ccls paramsctxt, infu) - | _ (* Not an explicit occurrence of Type *) -> - full_polymorphic () + in + let u = Sorts.univ_of_sort s in + (* The polymorphic level is a function of the level of the *) + (* conclusions of the parameters *) + (* We enforce [u >= lev] in case [lev] has a strict upper *) + (* constraints over [u] *) + let b = type_in_type env || UGraph.check_leq (universes env') infu u in + if not b then + anomaly ~label:"check_inductive" + (Pp.str"Incorrect universe " ++ + Universe.pr u ++ Pp.str " declared for inductive type, inferred level is " + ++ Universe.pr clev ++ Pp.str ".") + else + TemplateArity (param_ccls paramsctxt, infu) in let arity = match mie.mind_entry_universes with - | Monomorphic_ind_entry _ -> template_polymorphic () - | Polymorphic_ind_entry _ | Cumulative_ind_entry _ -> full_polymorphic () + | Monomorphic_ind_entry _ -> + if template then template_polymorphic () + else full_polymorphic () + | Polymorphic_ind_entry _ | Cumulative_ind_entry _ -> + if template + then anomaly ~label:"polymorphic_template_ind" + Pp.(strbrk "Template polymorphism and full polymorphism are incompatible.") + else full_polymorphic () in (id,cn,lc,(sign,arity))) inds diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 4d13a5fcb8..1d2f22b006 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -932,7 +932,7 @@ let check_one_fix renv recpos trees def = let case_spec = branches_specif renv (lazy_subterm_specif renv [] c_0) ci in let stack' = push_stack_closures renv l stack in - let stack' = filter_stack_domain renv.env p stack' in + let stack' = filter_stack_domain renv.env p stack' in Array.iteri (fun k br' -> let stack_br = push_stack_args case_spec.(k) stack' in check_rec_call renv stack_br br') lrest diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib index 07a02f6ef5..a18c5d1e20 100644 --- a/kernel/kernel.mllib +++ b/kernel/kernel.mllib @@ -10,13 +10,13 @@ Constr Vars Term Mod_subst +Vmvalues Cbytecodes Copcodes Cemitcodes Opaqueproof Declarations Entries -Vmvalues Nativevalues CPrimitives Declareops diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index b35b9dda31..f1d08ef6dd 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -53,18 +53,25 @@ type delta_resolver = Deltamap.t let empty_delta_resolver = Deltamap.empty -module Umap = struct - type 'a t = 'a MPmap.t * 'a MBImap.t - let empty = MPmap.empty, MBImap.empty - let is_empty (m1,m2) = MPmap.is_empty m1 && MBImap.is_empty m2 - let add_mbi mbi x (m1,m2) = (m1,MBImap.add mbi x m2) - let add_mp mp x (m1,m2) = (MPmap.add mp x m1, m2) - let find_mp mp map = MPmap.find mp (fst map) - let find_mbi mbi map = MBImap.find mbi (snd map) - let iter_mbi f map = MBImap.iter f (snd map) - let fold fmp fmbi (m1,m2) i = - MPmap.fold fmp m1 (MBImap.fold fmbi m2 i) - let join map1 map2 = fold add_mp add_mbi map1 map2 +module Umap : + sig + type 'a t + val empty : 'a t + val is_empty : 'a t -> bool + val add_mbi : MBId.t -> 'a -> 'a t -> 'a t + val add_mp : ModPath.t -> 'a -> 'a t -> 'a t + val find : ModPath.t -> 'a t -> 'a + val join : 'a t -> 'a t -> 'a t + val fold : (ModPath.t -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + end = struct + type 'a t = 'a MPmap.t + let empty = MPmap.empty + let is_empty m = MPmap.is_empty m + let add_mbi mbi x m = MPmap.add (MPbound mbi) x m + let add_mp mp x m = MPmap.add mp x m + let find = MPmap.find + let fold = MPmap.fold + let join map1 map2 = fold add_mp map1 map2 end type substitution = (ModPath.t * delta_resolver) Umap.t @@ -93,8 +100,7 @@ let debug_string_of_delta resolve = let list_contents sub = let one_pair (mp,reso) = (ModPath.to_string mp,debug_string_of_delta reso) in let mp_one_pair mp0 p l = (ModPath.to_string mp0, one_pair p)::l in - let mbi_one_pair mbi p l = (MBId.debug_to_string mbi, one_pair p)::l in - Umap.fold mp_one_pair mbi_one_pair sub [] + Umap.fold mp_one_pair sub [] let debug_string_of_subst sub = let l = List.map (fun (s1,(s2,s3)) -> s1^"|->"^s2^"["^s3^"]") @@ -222,15 +228,10 @@ let search_delta_inline resolve kn1 kn2 = let subst_mp0 sub mp = (* 's like subst *) let rec aux mp = match mp with - | MPfile sid -> Umap.find_mp mp sub - | MPbound bid -> - begin - try Umap.find_mbi bid sub - with Not_found -> Umap.find_mp mp sub - end + | MPfile _ | MPbound _ -> Umap.find mp sub | MPdot (mp1,l) as mp2 -> begin - try Umap.find_mp mp2 sub + try Umap.find mp2 sub with Not_found -> let mp1',resolve = aux mp1 in MPdot (mp1',l),resolve @@ -525,9 +526,7 @@ let substition_prefixed_by k mp subst = Umap.add_mp new_key (mp_to,reso) sub else sub in - let mbi_prefixmp mbi _ sub = sub - in - Umap.fold mp_prefixmp mbi_prefixmp subst empty_subst + Umap.fold mp_prefixmp subst empty_subst let join subst1 subst2 = let apply_subst mpk add (mp,resolve) res = @@ -547,24 +546,9 @@ let join subst1 subst2 = Umap.join prefixed_subst (add (mp',resolve'') res) in let mp_apply_subst mp = apply_subst mp (Umap.add_mp mp) in - let mbi_apply_subst mbi = apply_subst (MPbound mbi) (Umap.add_mbi mbi) in - let subst = Umap.fold mp_apply_subst mbi_apply_subst subst1 empty_subst in + let subst = Umap.fold mp_apply_subst subst1 empty_subst in Umap.join subst2 subst -let rec occur_in_path mbi = function - | MPbound bid' -> MBId.equal mbi bid' - | MPdot (mp1,_) -> occur_in_path mbi mp1 - | _ -> false - -let occur_mbid mbi sub = - let check_one mbi' (mp,_) = - if MBId.equal mbi mbi' || occur_in_path mbi mp then raise Exit - in - try - Umap.iter_mbi check_one sub; - false - with Exit -> true - type 'a substituted = { mutable subst_value : 'a; mutable subst_subst : substitution list; diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli index 2e5211c770..8416094063 100644 --- a/kernel/mod_subst.mli +++ b/kernel/mod_subst.mli @@ -165,11 +165,6 @@ val replace_mp_in_kn : ModPath.t -> ModPath.t -> KerName.t -> KerName.t names appearing in [c] *) val subst_mps : substitution -> constr -> constr -(** [occur_*id id sub] returns true iff [id] occurs in [sub] - on either side *) - -val occur_mbid : MBId.t -> substitution -> bool - (** [repr_substituted r] dumps the representation of a substituted: - [None, a] when r is a value - [Some s, a] when r is a delayed substitution [s] applied to [a] *) diff --git a/kernel/modops.ml b/kernel/modops.ml index 98a9973117..9435f46c6b 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -267,7 +267,7 @@ let subst_structure subst = subst_structure subst do_delta_codom (* lclrk : retroknowledge_action list, rkaction : retroknowledge action *) let add_retroknowledge = let perform rkaction env = match rkaction with - | Retroknowledge.RKRegister (f, e) when (isConst e || isInd e) -> + | Retroknowledge.RKRegister (f, ((GlobRef.ConstRef _ | GlobRef.IndRef _) as e)) -> Environ.register env f e | _ -> CErrors.anomaly ~label:"Modops.add_retroknowledge" diff --git a/kernel/names.ml b/kernel/names.ml index e1d70e8111..933cefe993 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -935,7 +935,7 @@ end type projection = Projection.t -module GlobRef = struct +module GlobRefInternal = struct type t = | VarRef of variable (** A reference to the section-context. *) @@ -951,11 +951,84 @@ module GlobRef = struct | VarRef v1, VarRef v2 -> Id.equal v1 v2 | (ConstRef _ | IndRef _ | ConstructRef _ | VarRef _), _ -> false + let global_eq_gen eq_cst eq_ind eq_cons x y = + x == y || + match x, y with + | ConstRef cx, ConstRef cy -> eq_cst cx cy + | IndRef indx, IndRef indy -> eq_ind indx indy + | ConstructRef consx, ConstructRef consy -> eq_cons consx consy + | VarRef v1, VarRef v2 -> Id.equal v1 v2 + | (VarRef _ | ConstRef _ | IndRef _ | ConstructRef _), _ -> false + + let global_ord_gen ord_cst ord_ind ord_cons x y = + if x == y then 0 + else match x, y with + | VarRef v1, VarRef v2 -> Id.compare v1 v2 + | VarRef _, _ -> -1 + | _, VarRef _ -> 1 + | ConstRef cx, ConstRef cy -> ord_cst cx cy + | ConstRef _, _ -> -1 + | _, ConstRef _ -> 1 + | IndRef indx, IndRef indy -> ord_ind indx indy + | IndRef _, _ -> -1 + | _ , IndRef _ -> 1 + | ConstructRef consx, ConstructRef consy -> ord_cons consx consy + + let global_hash_gen hash_cst hash_ind hash_cons gr = + let open Hashset.Combine in + match gr with + | ConstRef c -> combinesmall 1 (hash_cst c) + | IndRef i -> combinesmall 2 (hash_ind i) + | ConstructRef c -> combinesmall 3 (hash_cons c) + | VarRef id -> combinesmall 4 (Id.hash id) + +end + +module GlobRef = struct + + type t = GlobRefInternal.t = + | VarRef of variable (** A reference to the section-context. *) + | ConstRef of Constant.t (** A reference to the environment. *) + | IndRef of inductive (** A reference to an inductive type. *) + | ConstructRef of constructor (** A reference to a constructor of an inductive type. *) + + let equal = GlobRefInternal.equal + + (* By default, [global_reference] are ordered on their canonical part *) + + module Ordered = struct + open Constant.CanOrd + type t = GlobRefInternal.t + let compare gr1 gr2 = + GlobRefInternal.global_ord_gen compare ind_ord constructor_ord gr1 gr2 + let equal gr1 gr2 = GlobRefInternal.global_eq_gen equal eq_ind eq_constructor gr1 gr2 + let hash gr = GlobRefInternal.global_hash_gen hash ind_hash constructor_hash gr + end + + module Ordered_env = struct + open Constant.UserOrd + type t = GlobRefInternal.t + let compare gr1 gr2 = + GlobRefInternal.global_ord_gen compare ind_user_ord constructor_user_ord gr1 gr2 + let equal gr1 gr2 = + GlobRefInternal.global_eq_gen equal eq_user_ind eq_user_constructor gr1 gr2 + let hash gr = GlobRefInternal.global_hash_gen hash ind_user_hash constructor_user_hash gr + end + + module Map = HMap.Make(Ordered) + module Set = Map.Set + + (* Alternative sets and maps indexed by the user part of the kernel names *) + + module Map_env = HMap.Make(Ordered_env) + module Set_env = Map_env.Set + end type global_reference = GlobRef.t [@@ocaml.deprecated "Alias for [GlobRef.t]"] + type evaluable_global_reference = | EvalVarRef of Id.t | EvalConstRef of Constant.t diff --git a/kernel/names.mli b/kernel/names.mli index 1cdf5c2402..2ea8108734 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -645,6 +645,28 @@ module GlobRef : sig val equal : t -> t -> bool + module Ordered : sig + type nonrec t = t + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int + end + + module Ordered_env : sig + type nonrec t = t + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int + end + + module Set_env : CSig.SetS with type elt = t + module Map_env : Map.ExtS + with type key = t and module Set := Set_env + + module Set : CSig.SetS with type elt = t + module Map : Map.ExtS + with type key = t and module Set := Set + end type global_reference = GlobRef.t diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index ad10c86945..eed25a4ca4 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -632,6 +632,14 @@ let mkMLapp f args = | MLapp(f,args') -> MLapp(f,Array.append args' args) | _ -> MLapp(f,args) +let mkForceCofix prefix ind arg = + let name = fresh_lname Anonymous in + MLlet (name, arg, + MLif ( + MLisaccu (prefix, ind, MLlocal name), + MLapp (MLprimitive Force_cofix, [|MLlocal name|]), + MLlocal name)) + let empty_params = [||] let decompose_MLlam c = @@ -1143,7 +1151,7 @@ let ml_of_instance instance u = let arg = ml_of_lam env l a in let force = if annot.asw_finite then arg - else MLapp(MLprimitive Force_cofix, [|arg|]) in + else mkForceCofix annot.asw_prefix annot.asw_ind arg in mkMLapp (MLapp (MLglobal cn, fv_args env fvn fvr)) [|force|] | Lif(t,bt,bf) -> MLif(ml_of_lam env l t, ml_of_lam env l bt, ml_of_lam env l bf) @@ -1999,7 +2007,7 @@ let compile_mind mb mind stack = let accu = MLapp (MLprimitive Cast_accu, [|MLlocal cf_uid|]) in let accu_br = MLapp (MLprimitive Mk_proj, [|get_proj_code i;accu|]) in let code = MLmatch(asw,MLlocal cf_uid,accu_br,[|[((ind,1),cargs)],MLlocal ci_uid|]) in - let code = MLlet(cf_uid, MLapp (MLprimitive Force_cofix, [|MLlocal c_uid|]), code) in + let code = MLlet(cf_uid, mkForceCofix "" ind (MLlocal c_uid), code) in let gn = Gproj ("", ind, proj_arg) in Glet (gn, mkMLlam [|c_uid|] code) :: acc in diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index 122fe95df4..ab40c643f9 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -373,14 +373,14 @@ let is_lazy env prefix t = | App (f,args) -> begin match kind f with | Construct (c,_) -> - let entry = mkInd (fst c) in - (try - let _ = - Retroknowledge.get_native_before_match_info env.retroknowledge - entry prefix c Llazy; - in + let gr = GlobRef.IndRef (fst c) in + (try + let _ = + Retroknowledge.get_native_before_match_info env.retroknowledge + gr prefix c Llazy; + in false - with Not_found -> true) + with Not_found -> true) | _ -> true end | LetIn _ | Case _ | Proj _ -> true @@ -482,12 +482,12 @@ let rec lambda_of_constr cache env sigma c = in (* translation of the argument *) let la = lambda_of_constr cache env sigma a in - let entry = mkInd ind in + let gr = GlobRef.IndRef ind in let la = - try - Retroknowledge.get_native_before_match_info (env).retroknowledge - entry prefix (ind,1) la - with Not_found -> la + try + Retroknowledge.get_native_before_match_info (env).retroknowledge + gr prefix (ind,1) la + with Not_found -> la in (* translation of the type *) let lt = lambda_of_constr cache env sigma t in @@ -536,7 +536,7 @@ and lambda_of_app cache env sigma f args = let prefix = get_const_prefix env kn in (* We delay the compilation of arguments to avoid an exponential behavior *) let f = Retroknowledge.get_native_compiling_info - (env).retroknowledge (mkConst kn) prefix in + (env).retroknowledge (GlobRef.ConstRef kn) prefix in let args = lambda_of_args cache env sigma 0 args in f args with Not_found -> @@ -561,17 +561,18 @@ and lambda_of_app cache env sigma f args = let expected = nparams + arity in let nargs = Array.length args in let prefix = get_mind_prefix env (fst (fst c)) in + let gr = GlobRef.ConstructRef c in if Int.equal nargs expected then try try Retroknowledge.get_native_constant_static_info (env).retroknowledge - f args + gr args with NotClosed -> assert (Int.equal nparams 0); (* should be fine for int31 *) let args = lambda_of_args cache env sigma nparams args in Retroknowledge.get_native_constant_dynamic_info - (env).retroknowledge f prefix c args + (env).retroknowledge gr prefix c args with Not_found -> let args = lambda_of_args cache env sigma nparams args in makeblock env c u tag args @@ -579,7 +580,7 @@ and lambda_of_app cache env sigma f args = let args = lambda_of_args cache env sigma 0 args in (try Retroknowledge.get_native_constant_dynamic_info - (env).retroknowledge f prefix c args + (env).retroknowledge gr prefix c args with Not_found -> mkLapp (Lconstruct (prefix, (c,u))) args) | _ -> diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index 3bf23f1468..93e74af845 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -154,10 +154,6 @@ let args_of_accu (k:accumulator) = let acc = (get_accu k).acc_arg in (Obj.magic (Array.of_list acc) : t array) -let is_accu x = - let o = Obj.repr x in - Obj.is_block o && Int.equal (Obj.tag o) accumulate_tag - let mk_fix_accu rec_pos pos types bodies = mk_accu (Afix(types,bodies,rec_pos, pos)) @@ -172,19 +168,17 @@ let upd_cofix (cofix :t) (cofix_fun : t) = | _ -> assert false let force_cofix (cofix : t) = - if is_accu cofix then - let accu = (Obj.magic cofix : accumulator) in - let atom = atom_of_accu accu in - match atom with - | Acofix(typ,norm,pos,f) -> - let args = args_of_accu accu in - let f = Array.fold_right (fun arg f -> f arg) args f in - let v = f (Obj.magic ()) in - set_atom_of_accu accu (Acofixe(typ,norm,pos,v)); - v - | Acofixe(_,_,_,v) -> v - | _ -> cofix - else cofix + let accu = (Obj.magic cofix : accumulator) in + let atom = atom_of_accu accu in + match atom with + | Acofix(typ,norm,pos,f) -> + let args = args_of_accu accu in + let f = Array.fold_right (fun arg f -> f arg) args f in + let v = f (Obj.magic ()) in + set_atom_of_accu accu (Acofixe(typ,norm,pos,v)); + v + | Acofixe(_,_,_,v) -> v + | _ -> cofix let mk_const tag = Obj.magic tag diff --git a/kernel/retroknowledge.ml b/kernel/retroknowledge.ml index 34f62defb8..e51c25c06b 100644 --- a/kernel/retroknowledge.ml +++ b/kernel/retroknowledge.ml @@ -19,12 +19,9 @@ open Names open Constr (* The retroknowledge defines a bijective correspondance between some - [entry]-s (which are, in fact, merely terms) and [field]-s which + [entry]-s (which are, in fact, merely names) and [field]-s which are roles assigned to these entries. *) -(* aliased type for clarity purpose*) -type entry = Constr.t - type int31_field = | Int31Bits | Int31Type @@ -53,8 +50,37 @@ type int31_field = | Int31Lxor type field = - | KInt31 of string*int31_field - + | KInt31 of int31_field + +let int31_field_of_string = + function + | "bits" -> Int31Bits + | "type" -> Int31Type + | "twice" -> Int31Twice + | "twice_plus_one" -> Int31TwicePlusOne + | "phi" -> Int31Phi + | "phi_inv" -> Int31PhiInv + | "plus" -> Int31Plus + | "plusc" -> Int31PlusC + | "pluscarryc" -> Int31PlusCarryC + | "minus" -> Int31Minus + | "minusc" -> Int31MinusC + | "minuscarryc" -> Int31MinusCarryC + | "times" -> Int31Times + | "timesc" -> Int31TimesC + | "div21" -> Int31Div21 + | "div" -> Int31Div + | "diveucl" -> Int31Diveucl + | "addmuldiv" -> Int31AddMulDiv + | "compare" -> Int31Compare + | "head0" -> Int31Head0 + | "tail0" -> Int31Tail0 + | "lor" -> Int31Lor + | "land" -> Int31Land + | "lxor" -> Int31Lxor + | s -> CErrors.user_err Pp.(str "Registering unknown int31 operator " ++ str s) + +let int31_path = DirPath.make [ Id.of_string "int31" ] (* record representing all the flags of the internal state of the kernel *) type flags = {fastcomputation : bool} @@ -68,19 +94,13 @@ type flags = {fastcomputation : bool} module Proactive = Map.Make (struct type t = field let compare = Pervasives.compare end) -type proactive = entry Proactive.t +type proactive = GlobRef.t Proactive.t (* The [reactive] knowledge contains the mapping [entry->field]. Fields are later to be interpreted as a [reactive_info]. *) -module EntryOrd = -struct - type t = entry - let compare = Constr.compare -end - -module Reactive = Map.Make (EntryOrd) +module Reactive = GlobRef.Map type reactive_info = {(*information required by the compiler of the VM *) vm_compiling : @@ -127,7 +147,7 @@ and retroknowledge = {flags : flags; proactive : proactive; reactive : reactive} (* As per now, there is only the possibility of registering things the possibility of unregistering or changing the flag is under study *) type action = - | RKRegister of field*entry + | RKRegister of field * GlobRef.t (*initialisation*) diff --git a/kernel/retroknowledge.mli b/kernel/retroknowledge.mli index 02d961d893..0a2ef5300e 100644 --- a/kernel/retroknowledge.mli +++ b/kernel/retroknowledge.mli @@ -13,9 +13,6 @@ open Constr type retroknowledge -(** aliased type for clarity purpose*) -type entry = Constr.t - (** the following types correspond to the different "things" the kernel can learn about.*) type int31_field = @@ -46,14 +43,18 @@ type int31_field = | Int31Lxor type field = - | KInt31 of string*int31_field + | KInt31 of int31_field + +val int31_field_of_string : string -> int31_field + +val int31_path : DirPath.t (** This type represent an atomic action of the retroknowledge. It is stored in the compiled libraries As per now, there is only the possibility of registering things the possibility of unregistering or changing the flag is under study *) type action = - | RKRegister of field*entry + | RKRegister of field * GlobRef.t (** initial value for retroknowledge *) @@ -64,7 +65,7 @@ val initial_retroknowledge : retroknowledge and the continuation cont of the bytecode compilation returns the compilation of id in cont if it has a specific treatment or raises Not_found if id should be compiled as usual *) -val get_vm_compiling_info : retroknowledge -> entry -> +val get_vm_compiling_info : retroknowledge -> GlobRef.t -> Cinstr.lambda array -> Cinstr.lambda (*Given an identifier id (usually Construct _) and its argument array, returns a function that tries an ad-hoc optimisated @@ -73,7 +74,7 @@ val get_vm_compiling_info : retroknowledge -> entry -> raises Not_found if id should be compiled as usual, and expectingly CBytecodes.NotClosed if the term is not a closed constructor pattern (a constant for the compiler) *) -val get_vm_constant_static_info : retroknowledge -> entry -> +val get_vm_constant_static_info : retroknowledge -> GlobRef.t -> constr array -> Cinstr.lambda (*Given an identifier id (usually Construct _ ) @@ -81,45 +82,45 @@ val get_vm_constant_static_info : retroknowledge -> entry -> of id+args+cont when id has a specific treatment (in the case of 31-bit integers, that would be the dynamic compilation into integers) or raises Not_found if id should be compiled as usual *) -val get_vm_constant_dynamic_info : retroknowledge -> entry -> +val get_vm_constant_dynamic_info : retroknowledge -> GlobRef.t -> Cinstr.lambda array -> Cinstr.lambda (** Given a type identifier, this function is used before compiling a match over this type. In the case of 31-bit integers for instance, it is used to add the instruction sequence which would perform a dynamic decompilation in case the argument of the match is not in coq representation *) -val get_vm_before_match_info : retroknowledge -> entry -> Cinstr.lambda +val get_vm_before_match_info : retroknowledge -> GlobRef.t -> Cinstr.lambda -> Cinstr.lambda (** Given a type identifier, this function is used by pretyping/vnorm.ml to recover the elements of that type from their compiled form if it's non standard (it is used (and can be used) only when the compiled form is not a block *) -val get_vm_decompile_constant_info : retroknowledge -> entry -> int -> constr +val get_vm_decompile_constant_info : retroknowledge -> GlobRef.t -> int -> constr -val get_native_compiling_info : retroknowledge -> entry -> Nativeinstr.prefix -> +val get_native_compiling_info : retroknowledge -> GlobRef.t -> Nativeinstr.prefix -> Nativeinstr.lambda array -> Nativeinstr.lambda -val get_native_constant_static_info : retroknowledge -> entry -> +val get_native_constant_static_info : retroknowledge -> GlobRef.t -> constr array -> Nativeinstr.lambda -val get_native_constant_dynamic_info : retroknowledge -> entry -> +val get_native_constant_dynamic_info : retroknowledge -> GlobRef.t -> Nativeinstr.prefix -> constructor -> Nativeinstr.lambda array -> Nativeinstr.lambda -val get_native_before_match_info : retroknowledge -> entry -> +val get_native_before_match_info : retroknowledge -> GlobRef.t -> Nativeinstr.prefix -> constructor -> Nativeinstr.lambda -> Nativeinstr.lambda (** the following functions are solely used in Environ and Safe_typing to implement the functions register and unregister (and mem) of Environ *) -val add_field : retroknowledge -> field -> entry -> retroknowledge +val add_field : retroknowledge -> field -> GlobRef.t -> retroknowledge val mem : retroknowledge -> field -> bool (* val remove : retroknowledge -> field -> retroknowledge *) -val find : retroknowledge -> field -> entry +val find : retroknowledge -> field -> GlobRef.t (** Dispatching type for the above [get_*] functions. *) @@ -161,4 +162,4 @@ val empty_reactive_info : reactive_info (** Hook to be set after the compiler are installed to dispatch fields into the above [get_*] functions. *) -val dispatch_hook : (retroknowledge -> entry -> field -> reactive_info) Hook.t +val dispatch_hook : (retroknowledge -> GlobRef.t -> field -> reactive_info) Hook.t diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 6c87ff570f..9d302c69fb 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -892,8 +892,8 @@ let retroknowledge f senv = Environ.retroknowledge f (env_of_senv senv) [@@@ocaml.warning "+3"] -let register field value by_clause senv = - (* todo : value closed, by_clause safe, by_clause of the proper type*) +let register field value senv = + (* todo : value closed *) (* spiwack : updates the safe_env with the information that the register action has to be performed (again) when the environment is imported *) { senv with @@ -977,39 +977,39 @@ let dispatch = it to the name of the coq definition in the reactive retroknowledge) *) let int31_op n op prim kn = { empty_reactive_info with - vm_compiling = Some (Clambda.compile_prim n op kn); - native_compiling = Some (Nativelambda.compile_prim prim (Univ.out_punivs kn)); + vm_compiling = Some (Clambda.compile_prim n op (kn, Univ.Instance.empty)); (*XXX: FIXME universes? *) + native_compiling = Some (Nativelambda.compile_prim prim kn); } in fun rk value field -> (* subfunction which shortens the (very common) dispatch of operations *) let int31_op_from_const n op prim = - match Constr.kind value with - | Constr.Const kn -> int31_op n op prim kn + match value with + | GlobRef.ConstRef kn -> int31_op n op prim kn | _ -> anomaly ~label:"Environ.register" (Pp.str "should be a constant.") in let int31_binop_from_const op prim = int31_op_from_const 2 op prim in let int31_unop_from_const op prim = int31_op_from_const 1 op prim in match field with - | KInt31 (grp, Int31Type) -> + | KInt31 Int31Type -> let int31bit = (* invariant : the type of bits is registered, otherwise the function would raise Not_found. The invariant is enforced in safe_typing.ml *) match field with - | KInt31 (grp, Int31Type) -> Retroknowledge.find rk (KInt31 (grp,Int31Bits)) + | KInt31 Int31Type -> Retroknowledge.find rk (KInt31 Int31Bits) | _ -> anomaly ~label:"Environ.register" (Pp.str "add_int31_decompilation_from_type called with an abnormal field.") in let i31bit_type = - match Constr.kind int31bit with - | Constr.Ind (i31bit_type,_) -> i31bit_type + match int31bit with + | GlobRef.IndRef i31bit_type -> i31bit_type | _ -> anomaly ~label:"Environ.register" (Pp.str "Int31Bits should be an inductive type.") in let int31_decompilation = - match Constr.kind value with - | Constr.Ind (i31t,_) -> + match value with + | GlobRef.IndRef i31t -> constr_of_int31 i31t i31bit_type | _ -> anomaly ~label:"Environ.register" (Pp.str "should be an inductive type.") @@ -1019,46 +1019,46 @@ fun rk value field -> vm_before_match = Some Clambda.int31_escape_before_match; native_before_match = Some (Nativelambda.before_match_int31 i31bit_type); } - | KInt31 (_, Int31Constructor) -> + | KInt31 Int31Constructor -> { empty_reactive_info with vm_constant_static = Some Clambda.compile_structured_int31; vm_constant_dynamic = Some Clambda.dynamic_int31_compilation; native_constant_static = Some Nativelambda.compile_static_int31; native_constant_dynamic = Some Nativelambda.compile_dynamic_int31; } - | KInt31 (_, Int31Plus) -> int31_binop_from_const Cbytecodes.Kaddint31 + | KInt31 Int31Plus -> int31_binop_from_const Cbytecodes.Kaddint31 CPrimitives.Int31add - | KInt31 (_, Int31PlusC) -> int31_binop_from_const Cbytecodes.Kaddcint31 + | KInt31 Int31PlusC -> int31_binop_from_const Cbytecodes.Kaddcint31 CPrimitives.Int31addc - | KInt31 (_, Int31PlusCarryC) -> int31_binop_from_const Cbytecodes.Kaddcarrycint31 + | KInt31 Int31PlusCarryC -> int31_binop_from_const Cbytecodes.Kaddcarrycint31 CPrimitives.Int31addcarryc - | KInt31 (_, Int31Minus) -> int31_binop_from_const Cbytecodes.Ksubint31 + | KInt31 Int31Minus -> int31_binop_from_const Cbytecodes.Ksubint31 CPrimitives.Int31sub - | KInt31 (_, Int31MinusC) -> int31_binop_from_const Cbytecodes.Ksubcint31 + | KInt31 Int31MinusC -> int31_binop_from_const Cbytecodes.Ksubcint31 CPrimitives.Int31subc - | KInt31 (_, Int31MinusCarryC) -> int31_binop_from_const + | KInt31 Int31MinusCarryC -> int31_binop_from_const Cbytecodes.Ksubcarrycint31 CPrimitives.Int31subcarryc - | KInt31 (_, Int31Times) -> int31_binop_from_const Cbytecodes.Kmulint31 + | KInt31 Int31Times -> int31_binop_from_const Cbytecodes.Kmulint31 CPrimitives.Int31mul - | KInt31 (_, Int31TimesC) -> int31_binop_from_const Cbytecodes.Kmulcint31 + | KInt31 Int31TimesC -> int31_binop_from_const Cbytecodes.Kmulcint31 CPrimitives.Int31mulc - | KInt31 (_, Int31Div21) -> int31_op_from_const 3 Cbytecodes.Kdiv21int31 + | KInt31 Int31Div21 -> int31_op_from_const 3 Cbytecodes.Kdiv21int31 CPrimitives.Int31div21 - | KInt31 (_, Int31Diveucl) -> int31_binop_from_const Cbytecodes.Kdivint31 + | KInt31 Int31Diveucl -> int31_binop_from_const Cbytecodes.Kdivint31 CPrimitives.Int31diveucl - | KInt31 (_, Int31AddMulDiv) -> int31_op_from_const 3 Cbytecodes.Kaddmuldivint31 + | KInt31 Int31AddMulDiv -> int31_op_from_const 3 Cbytecodes.Kaddmuldivint31 CPrimitives.Int31addmuldiv - | KInt31 (_, Int31Compare) -> int31_binop_from_const Cbytecodes.Kcompareint31 + | KInt31 Int31Compare -> int31_binop_from_const Cbytecodes.Kcompareint31 CPrimitives.Int31compare - | KInt31 (_, Int31Head0) -> int31_unop_from_const Cbytecodes.Khead0int31 + | KInt31 Int31Head0 -> int31_unop_from_const Cbytecodes.Khead0int31 CPrimitives.Int31head0 - | KInt31 (_, Int31Tail0) -> int31_unop_from_const Cbytecodes.Ktail0int31 + | KInt31 Int31Tail0 -> int31_unop_from_const Cbytecodes.Ktail0int31 CPrimitives.Int31tail0 - | KInt31 (_, Int31Lor) -> int31_binop_from_const Cbytecodes.Klorint31 + | KInt31 Int31Lor -> int31_binop_from_const Cbytecodes.Klorint31 CPrimitives.Int31lor - | KInt31 (_, Int31Land) -> int31_binop_from_const Cbytecodes.Klandint31 + | KInt31 Int31Land -> int31_binop_from_const Cbytecodes.Klandint31 CPrimitives.Int31land - | KInt31 (_, Int31Lxor) -> int31_binop_from_const Cbytecodes.Klxorint31 + | KInt31 Int31Lxor -> int31_binop_from_const Cbytecodes.Klxorint31 CPrimitives.Int31lxor | _ -> empty_reactive_info diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 502e2970a1..08b97b718e 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -215,7 +215,7 @@ val retroknowledge : (retroknowledge-> 'a) -> safe_environment -> 'a [@@ocaml.deprecated "Use the projection of Environ.env"] val register : - field -> Retroknowledge.entry -> Constr.constr -> safe_transformer0 + field -> GlobRef.t -> safe_transformer0 val register_inline : Constant.t -> safe_transformer0 diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 43351737e5..f59e07098b 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -256,6 +256,8 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = let tyj = infer_type env typ in let proofterm = Future.chain body (fun ((body,uctx),side_eff) -> + (* don't redeclare universes which are declared for the type *) + let uctx = Univ.ContextSet.diff uctx univs in let j, uctx = match trust with | Pure -> let env = push_context_set uctx env in diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli index 9c6ef64b50..3fd40a7f42 100644 --- a/kernel/type_errors.mli +++ b/kernel/type_errors.mli @@ -12,7 +12,7 @@ open Names open Constr open Environ -(** Type errors. {% \label{%}typeerrors{% }%} *) +(** Type errors. {% \label{typeerrors} %} *) (*i Rem: NotEnoughAbstractionInFixBody should only occur with "/i" Fix notation i*) diff --git a/kernel/vm.ml b/kernel/vm.ml index d7eedc226c..9917e94a35 100644 --- a/kernel/vm.ml +++ b/kernel/vm.ml @@ -8,7 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Cbytecodes open Vmvalues external set_drawinstr : unit -> unit = "coq_set_drawinstr" diff --git a/kernel/vmvalues.ml b/kernel/vmvalues.ml index d6d9312938..8edd49f77f 100644 --- a/kernel/vmvalues.ml +++ b/kernel/vmvalues.ml @@ -9,8 +9,8 @@ (************************************************************************) open Names open Sorts -open Cbytecodes open Univ +open Constr (*******************************************) (* Initalization of the abstract machine ***) @@ -25,11 +25,124 @@ let _ = init_vm () (* Abstract data types and utility functions **********) (******************************************************) +(* The representation of values relies on this assertion *) +let _ = assert (Int.equal Obj.first_non_constant_constructor_tag 0) + (* Values of the abstract machine *) type values +type structured_values = values let val_of_obj v = ((Obj.obj v):values) let crazy_val = (val_of_obj (Obj.repr 0)) +type tag = int + +let accu_tag = 0 + +let type_atom_tag = 2 +let max_atom_tag = 2 +let proj_tag = 3 +let fix_app_tag = 4 +let switch_tag = 5 +let cofix_tag = 6 +let cofix_evaluated_tag = 7 + +(** Structured constants are constants whose construction is done once. Their +occurrences share the same value modulo kernel name substitutions (for functor +application). Structured values have the additional property that no +substitution will need to be performed, so their runtime value can directly be +shared without reallocating a more structured representation. *) +type structured_constant = + | Const_sort of Sorts.t + | Const_ind of inductive + | Const_b0 of tag + | Const_univ_level of Univ.Level.t + | Const_val of structured_values + +type reloc_table = (tag * int) array + +type annot_switch = + {ci : case_info; rtbl : reloc_table; tailcall : bool; max_stack_size : int} + +let rec eq_structured_values v1 v2 = + v1 == v2 || + let o1 = Obj.repr v1 in + let o2 = Obj.repr v2 in + if Obj.is_int o1 && Obj.is_int o2 then o1 == o2 + else + let t1 = Obj.tag o1 in + let t2 = Obj.tag o2 in + if Int.equal t1 t2 && + Int.equal (Obj.size o1) (Obj.size o2) + then begin + assert (t1 <= Obj.last_non_constant_constructor_tag && + t2 <= Obj.last_non_constant_constructor_tag); + let i = ref 0 in + while (!i < Obj.size o1 && eq_structured_values + (Obj.magic (Obj.field o1 !i) : structured_values) + (Obj.magic (Obj.field o2 !i) : structured_values)) do + incr i + done; + !i >= Obj.size o1 + end + else false + +let hash_structured_values (v : structured_values) = + (* We may want a better hash function here *) + Hashtbl.hash v + +let eq_structured_constant c1 c2 = match c1, c2 with +| Const_sort s1, Const_sort s2 -> Sorts.equal s1 s2 +| Const_sort _, _ -> false +| Const_ind i1, Const_ind i2 -> eq_ind i1 i2 +| Const_ind _, _ -> false +| Const_b0 t1, Const_b0 t2 -> Int.equal t1 t2 +| Const_b0 _, _ -> false +| Const_univ_level l1 , Const_univ_level l2 -> Univ.Level.equal l1 l2 +| Const_univ_level _ , _ -> false +| Const_val v1, Const_val v2 -> eq_structured_values v1 v2 +| Const_val v1, _ -> false + +let hash_structured_constant c = + let open Hashset.Combine in + match c with + | Const_sort s -> combinesmall 1 (Sorts.hash s) + | Const_ind i -> combinesmall 2 (ind_hash i) + | Const_b0 t -> combinesmall 3 (Int.hash t) + | Const_univ_level l -> combinesmall 4 (Univ.Level.hash l) + | Const_val v -> combinesmall 5 (hash_structured_values v) + +let eq_annot_switch asw1 asw2 = + let eq_ci ci1 ci2 = + eq_ind ci1.ci_ind ci2.ci_ind && + Int.equal ci1.ci_npar ci2.ci_npar && + CArray.equal Int.equal ci1.ci_cstr_ndecls ci2.ci_cstr_ndecls + in + let eq_rlc (i1, j1) (i2, j2) = Int.equal i1 i2 && Int.equal j1 j2 in + eq_ci asw1.ci asw2.ci && + CArray.equal eq_rlc asw1.rtbl asw2.rtbl && + (asw1.tailcall : bool) == asw2.tailcall + +let hash_annot_switch asw = + let open Hashset.Combine in + let h1 = Constr.case_info_hash asw.ci in + let h2 = Array.fold_left (fun h (t, i) -> combine3 h t i) 0 asw.rtbl in + let h3 = if asw.tailcall then 1 else 0 in + combine3 h1 h2 h3 + +let pp_sort s = + let open Sorts in + match s with + | Prop -> Pp.str "Prop" + | Set -> Pp.str "Set" + | Type u -> Pp.(str "Type@{" ++ Univ.pr_uni u ++ str "}") + +let pp_struct_const = function + | Const_sort s -> pp_sort s + | Const_ind (mind, i) -> Pp.(MutInd.print mind ++ str"#" ++ int i) + | Const_b0 i -> Pp.int i + | Const_univ_level l -> Univ.Level.pr l + | Const_val _ -> Pp.str "(value)" + (* Abstract data *) type vprod type vfun @@ -293,19 +406,21 @@ let obj_of_atom : atom -> Obj.t = res (* obj_of_str_const : structured_constant -> Obj.t *) -let rec obj_of_str_const str = +let obj_of_str_const str = match str with | Const_sort s -> obj_of_atom (Asort s) | Const_ind ind -> obj_of_atom (Aind ind) | Const_b0 tag -> Obj.repr tag - | Const_bn(tag, args) -> - let len = Array.length args in - let res = Obj.new_block tag len in - for i = 0 to len - 1 do - Obj.set_field res i (obj_of_str_const args.(i)) - done; - res | Const_univ_level l -> Obj.repr (Vuniv_level l) + | Const_val v -> Obj.repr v + +let val_of_block tag (args : structured_values array) = + let nargs = Array.length args in + let r = Obj.new_block tag nargs in + for i = 0 to nargs - 1 do + Obj.set_field r i (Obj.repr args.(i)) + done; + (Obj.magic r : structured_values) let val_of_obj o = ((Obj.obj o) : values) @@ -313,6 +428,8 @@ let val_of_str_const str = val_of_obj (obj_of_str_const str) let val_of_atom a = val_of_obj (obj_of_atom a) +let val_of_int i = (Obj.magic i : values) + let atom_of_proj kn v = let r = Obj.new_block proj_tag 2 in Obj.set_field r 0 (Obj.repr kn); @@ -514,10 +631,10 @@ let branch_arg k (tag,arity) = if Int.equal arity 0 then ((Obj.magic tag):values) else let b, ofs = - if tag < last_variant_tag then Obj.new_block tag arity, 0 + if tag < Obj.last_non_constant_constructor_tag then Obj.new_block tag arity, 0 else - let b = Obj.new_block last_variant_tag (arity+1) in - Obj.set_field b 0 (Obj.repr (tag-last_variant_tag)); + let b = Obj.new_block Obj.last_non_constant_constructor_tag (arity+1) in + Obj.set_field b 0 (Obj.repr (tag-Obj.last_non_constant_constructor_tag)); b,1 in for i = ofs to ofs + arity - 1 do Obj.set_field b i (Obj.repr (val_of_rel (k+i))) diff --git a/kernel/vmvalues.mli b/kernel/vmvalues.mli index 6eedcf1d37..ae1d416ed5 100644 --- a/kernel/vmvalues.mli +++ b/kernel/vmvalues.mli @@ -9,11 +9,12 @@ (************************************************************************) open Names -open Cbytecodes +open Constr (** Values *) type values +type structured_values type vm_env type vm_global type vprod @@ -25,6 +26,38 @@ type arguments type vstack = values array type to_update +type tag = int + +val accu_tag : tag + +val type_atom_tag : tag +val max_atom_tag : tag +val proj_tag : tag +val fix_app_tag : tag +val switch_tag : tag +val cofix_tag : tag +val cofix_evaluated_tag : tag + +type structured_constant = + | Const_sort of Sorts.t + | Const_ind of inductive + | Const_b0 of tag + | Const_univ_level of Univ.Level.t + | Const_val of structured_values + +val pp_struct_const : structured_constant -> Pp.t + +type reloc_table = (tag * int) array + +type annot_switch = + {ci : case_info; rtbl : reloc_table; tailcall : bool; max_stack_size : int} + +val eq_structured_constant : structured_constant -> structured_constant -> bool +val hash_structured_constant : structured_constant -> int + +val eq_annot_switch : annot_switch -> annot_switch -> bool +val hash_annot_switch : annot_switch -> int + val fun_val : vfun -> values val fix_val : vfix -> values val cofix_upd_val : to_update -> values @@ -110,6 +143,8 @@ val val_of_constant : Constant.t -> values val val_of_evar : Evar.t -> values val val_of_proj : Projection.Repr.t -> values -> values val val_of_atom : atom -> values +val val_of_int : int -> structured_values +val val_of_block : tag -> structured_values array -> structured_values external val_of_annot_switch : annot_switch -> values = "%identity" external val_of_proj_name : Projection.Repr.t -> values = "%identity" @@ -158,4 +193,4 @@ val bfield : vblock -> int -> values (** Switch *) val check_switch : vswitch -> vswitch -> bool -val branch_arg : int -> Cbytecodes.tag * int -> values +val branch_arg : int -> tag * int -> values diff --git a/lib/genarg.mli b/lib/genarg.mli index bb85f99e3c..52db3df088 100644 --- a/lib/genarg.mli +++ b/lib/genarg.mli @@ -13,7 +13,7 @@ (** The route of a generic argument, from parsing to evaluation. In the following diagram, "object" can be tactic_expr, constr, tactic_arg, etc. -{% \begin{%}verbatim{% }%} +{% \begin{verbatim} %} parsing in_raw out_raw char stream ---> raw_object ---> raw_object generic_argument -------+ encapsulation decaps| @@ -36,7 +36,7 @@ In the following diagram, "object" can be tactic_expr, constr, tactic_arg, etc. | V effective use -{% \end{%}verbatim{% }%} +{% \end{verbatim} %} To distinguish between the uninterpreted, globalized and interpreted worlds, we annotate the type [generic_argument] by a diff --git a/library/coqlib.ml b/library/coqlib.ml index 408e259196..36a9598f36 100644 --- a/library/coqlib.ml +++ b/library/coqlib.ml @@ -47,7 +47,7 @@ let gen_reference_in_modules locstr dirs s = let dirs = List.map make_dir dirs in let qualid = qualid_of_string s in let all = Nametab.locate_all qualid in - let all = List.sort_uniquize RefOrdered_env.compare all in + let all = List.sort_uniquize GlobRef.Ordered_env.compare all in let these = List.filter (has_suffix_in_dirs dirs) all in match these with | [x] -> x diff --git a/library/dischargedhypsmap.ml b/library/dischargedhypsmap.ml deleted file mode 100644 index abcdb93a27..0000000000 --- a/library/dischargedhypsmap.ml +++ /dev/null @@ -1,21 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -open Libnames - -type discharged_hyps = full_path list - -let discharged_hyps_map = Summary.ref Spmap.empty ~name:"discharged_hypothesis" - -let set_discharged_hyps sp hyps = - discharged_hyps_map := Spmap.add sp hyps !discharged_hyps_map - -let get_discharged_hyps sp = - try Spmap.find sp !discharged_hyps_map with Not_found -> [] diff --git a/library/dischargedhypsmap.mli b/library/dischargedhypsmap.mli deleted file mode 100644 index c70677225b..0000000000 --- a/library/dischargedhypsmap.mli +++ /dev/null @@ -1,19 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -open Libnames - -type discharged_hyps = full_path list - -(** Discharged hypothesis. Here we store the discharged hypothesis of each - constant or inductive type declaration. *) - -val set_discharged_hyps : full_path -> discharged_hyps -> unit -val get_discharged_hyps : full_path -> discharged_hyps diff --git a/library/global.ml b/library/global.ml index e833f71142..5872126a12 100644 --- a/library/global.ml +++ b/library/global.ml @@ -271,8 +271,8 @@ let with_global f = push_context_set false ctx; a (* spiwack: register/unregister functions for retroknowledge *) -let register field value by_clause = - globalize0 (Safe_typing.register field value by_clause) +let register field value = + globalize0 (Safe_typing.register field value) let register_inline c = globalize0 (Safe_typing.register_inline c) diff --git a/library/global.mli b/library/global.mli index 2819c187ed..6aeae9fd02 100644 --- a/library/global.mli +++ b/library/global.mli @@ -148,7 +148,7 @@ val universes_of_global : GlobRef.t -> Univ.AUContext.t (** {6 Retroknowledge } *) val register : - Retroknowledge.field -> Constr.constr -> Constr.constr -> unit + Retroknowledge.field -> GlobRef.t -> unit val register_inline : Constant.t -> unit diff --git a/library/globnames.ml b/library/globnames.ml index 6383a1f8f6..6bbdd36489 100644 --- a/library/globnames.ml +++ b/library/globnames.ml @@ -87,65 +87,14 @@ let printable_constr_of_global = function | ConstructRef sp -> mkConstruct sp | IndRef sp -> mkInd sp -let global_eq_gen eq_cst eq_ind eq_cons x y = - x == y || - match x, y with - | ConstRef cx, ConstRef cy -> eq_cst cx cy - | IndRef indx, IndRef indy -> eq_ind indx indy - | ConstructRef consx, ConstructRef consy -> eq_cons consx consy - | VarRef v1, VarRef v2 -> Id.equal v1 v2 - | (VarRef _ | ConstRef _ | IndRef _ | ConstructRef _), _ -> false - -let global_ord_gen ord_cst ord_ind ord_cons x y = - if x == y then 0 - else match x, y with - | VarRef v1, VarRef v2 -> Id.compare v1 v2 - | VarRef _, _ -> -1 - | _, VarRef _ -> 1 - | ConstRef cx, ConstRef cy -> ord_cst cx cy - | ConstRef _, _ -> -1 - | _, ConstRef _ -> 1 - | IndRef indx, IndRef indy -> ord_ind indx indy - | IndRef _, _ -> -1 - | _ , IndRef _ -> 1 - | ConstructRef consx, ConstructRef consy -> ord_cons consx consy - -let global_hash_gen hash_cst hash_ind hash_cons gr = - let open Hashset.Combine in - match gr with - | ConstRef c -> combinesmall 1 (hash_cst c) - | IndRef i -> combinesmall 2 (hash_ind i) - | ConstructRef c -> combinesmall 3 (hash_cons c) - | VarRef id -> combinesmall 4 (Id.hash id) - -(* By default, [global_reference] are ordered on their canonical part *) - -module RefOrdered = struct - open Constant.CanOrd - type t = global_reference - let compare gr1 gr2 = - global_ord_gen compare ind_ord constructor_ord gr1 gr2 - let equal gr1 gr2 = global_eq_gen equal eq_ind eq_constructor gr1 gr2 - let hash gr = global_hash_gen hash ind_hash constructor_hash gr -end - -module RefOrdered_env = struct - open Constant.UserOrd - type t = global_reference - let compare gr1 gr2 = - global_ord_gen compare ind_user_ord constructor_user_ord gr1 gr2 - let equal gr1 gr2 = - global_eq_gen equal eq_user_ind eq_user_constructor gr1 gr2 - let hash gr = global_hash_gen hash ind_user_hash constructor_user_hash gr -end - -module Refmap = HMap.Make(RefOrdered) -module Refset = Refmap.Set +module RefOrdered = Names.GlobRef.Ordered +module RefOrdered_env = Names.GlobRef.Ordered_env -(* Alternative sets and maps indexed by the user part of the kernel names *) +module Refmap = Names.GlobRef.Map +module Refset = Names.GlobRef.Set -module Refmap_env = HMap.Make(RefOrdered_env) -module Refset_env = Refmap_env.Set +module Refmap_env = Names.GlobRef.Map_env +module Refset_env = Names.GlobRef.Set_env (* Extended global references *) @@ -164,14 +113,14 @@ module ExtRefOrdered = struct let equal x y = x == y || match x, y with - | TrueGlobal rx, TrueGlobal ry -> RefOrdered_env.equal rx ry + | TrueGlobal rx, TrueGlobal ry -> GlobRef.Ordered_env.equal rx ry | SynDef knx, SynDef kny -> KerName.equal knx kny | (TrueGlobal _ | SynDef _), _ -> false let compare x y = if x == y then 0 else match x, y with - | TrueGlobal rx, TrueGlobal ry -> RefOrdered_env.compare rx ry + | TrueGlobal rx, TrueGlobal ry -> GlobRef.Ordered_env.compare rx ry | SynDef knx, SynDef kny -> KerName.compare knx kny | TrueGlobal _, SynDef _ -> -1 | SynDef _, TrueGlobal _ -> 1 @@ -179,7 +128,7 @@ module ExtRefOrdered = struct open Hashset.Combine let hash = function - | TrueGlobal gr -> combinesmall 1 (RefOrdered_env.hash gr) + | TrueGlobal gr -> combinesmall 1 (GlobRef.Ordered_env.hash gr) | SynDef kn -> combinesmall 2 (KerName.hash kn) end diff --git a/library/globnames.mli b/library/globnames.mli index 15fcd5bdd9..45ee069b06 100644 --- a/library/globnames.mli +++ b/library/globnames.mli @@ -8,7 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Util open Names open Constr open Mod_subst @@ -49,27 +48,21 @@ val printable_constr_of_global : GlobRef.t -> constr raise [Not_found] if not a global reference *) val global_of_constr : constr -> GlobRef.t -module RefOrdered : sig - type t = GlobRef.t - val compare : t -> t -> int - val equal : t -> t -> bool - val hash : t -> int -end +module RefOrdered = Names.GlobRef.Ordered +[@@ocaml.deprecated "Use Names.GlobRef.Ordered"] -module RefOrdered_env : sig - type t = GlobRef.t - val compare : t -> t -> int - val equal : t -> t -> bool - val hash : t -> int -end +module RefOrdered_env = Names.GlobRef.Ordered_env +[@@ocaml.deprecated "Use Names.GlobRef.Ordered_env"] -module Refset : CSig.SetS with type elt = GlobRef.t -module Refmap : Map.ExtS - with type key = GlobRef.t and module Set := Refset +module Refset = Names.GlobRef.Set +[@@ocaml.deprecated "Use Names.GlobRef.Set"] +module Refmap = Names.GlobRef.Map +[@@ocaml.deprecated "Use Names.GlobRef.Map"] -module Refset_env : CSig.SetS with type elt = GlobRef.t -module Refmap_env : Map.ExtS - with type key = GlobRef.t and module Set := Refset_env +module Refset_env = GlobRef.Set_env +[@@ocaml.deprecated "Use Names.GlobRef.Set_env"] +module Refmap_env = GlobRef.Map_env +[@@ocaml.deprecated "Use Names.GlobRef.Map_env"] (** {6 Extended global references } *) diff --git a/library/goptions.ml b/library/goptions.ml index eafcb8fea6..dcbc46ab72 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -412,7 +412,7 @@ let print_tables () = if depr then msg ++ str " [DEPRECATED]" ++ fnl () else msg ++ fnl () in - str "Synchronous options:" ++ fnl () ++ + str "Options:" ++ fnl () ++ OptionMap.fold (fun key (name, depr, (read,_,_)) p -> p ++ print_option key name (read ()) depr) diff --git a/library/keys.ml b/library/keys.ml index 3cadcb6472..a74d13c600 100644 --- a/library/keys.ml +++ b/library/keys.ml @@ -31,7 +31,7 @@ module KeyOrdered = struct let hash gr = match gr with - | KGlob gr -> 8 + RefOrdered.hash gr + | KGlob gr -> 8 + GlobRef.Ordered.hash gr | KLam -> 0 | KLet -> 1 | KProd -> 2 @@ -43,14 +43,14 @@ module KeyOrdered = struct let compare gr1 gr2 = match gr1, gr2 with - | KGlob gr1, KGlob gr2 -> RefOrdered.compare gr1 gr2 + | KGlob gr1, KGlob gr2 -> GlobRef.Ordered.compare gr1 gr2 | _, KGlob _ -> -1 | KGlob _, _ -> 1 | k, k' -> Int.compare (hash k) (hash k') let equal k1 k2 = match k1, k2 with - | KGlob gr1, KGlob gr2 -> RefOrdered.equal gr1 gr2 + | KGlob gr1, KGlob gr2 -> GlobRef.Ordered.equal gr1 gr2 | _, KGlob _ -> false | KGlob _, _ -> false | k, k' -> k == k' diff --git a/library/library.mllib b/library/library.mllib index 9cacaba4a7..8f694f4a31 100644 --- a/library/library.mllib +++ b/library/library.mllib @@ -11,7 +11,6 @@ Loadpath Library States Kindops -Dischargedhypsmap Goptions Decls Keys diff --git a/library/nametab.ml b/library/nametab.ml index a3b3ca6e74..840cf8e380 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -279,10 +279,10 @@ module ExtRefTab = Make(FullPath)(ExtRefEqual) module MPTab = Make(FullPath)(MPEqual) type ccitab = ExtRefTab.t -let the_ccitab = ref (ExtRefTab.empty : ccitab) +let the_ccitab = Summary.ref ~name:"ccitab" (ExtRefTab.empty : ccitab) type mptab = MPTab.t -let the_modtypetab = ref (MPTab.empty : mptab) +let the_modtypetab = Summary.ref ~name:"modtypetab" (MPTab.empty : mptab) module DirPath' = struct @@ -303,7 +303,7 @@ module DirTab = Make(DirPath')(GlobDir) (* If we have a (closed) module M having a submodule N, than N does not have the entry in [the_dirtab]. *) type dirtab = DirTab.t -let the_dirtab = ref (DirTab.empty : dirtab) +let the_dirtab = Summary.ref ~name:"dirtab" (DirTab.empty : dirtab) type universe_id = DirPath.t * int @@ -314,7 +314,7 @@ struct end module UnivTab = Make(FullPath)(UnivIdEqual) type univtab = UnivTab.t -let the_univtab = ref (UnivTab.empty : univtab) +let the_univtab = Summary.ref ~name:"univtab" (UnivTab.empty : univtab) (* Reversed name tables ***************************************************) @@ -322,14 +322,14 @@ let the_univtab = ref (UnivTab.empty : univtab) module Globrevtab = HMap.Make(ExtRefOrdered) type globrevtab = full_path Globrevtab.t -let the_globrevtab = ref (Globrevtab.empty : globrevtab) +let the_globrevtab = Summary.ref ~name:"globrevtab" (Globrevtab.empty : globrevtab) type mprevtab = DirPath.t MPmap.t -let the_modrevtab = ref (MPmap.empty : mprevtab) +let the_modrevtab = Summary.ref ~name:"modrevtab" (MPmap.empty : mprevtab) type mptrevtab = full_path MPmap.t -let the_modtyperevtab = ref (MPmap.empty : mptrevtab) +let the_modtyperevtab = Summary.ref ~name:"modtyperevtab" (MPmap.empty : mptrevtab) module UnivIdOrdered = struct @@ -344,7 +344,7 @@ end module UnivIdMap = HMap.Make(UnivIdOrdered) type univrevtab = full_path UnivIdMap.t -let the_univrevtab = ref (UnivIdMap.empty : univrevtab) +let the_univrevtab = Summary.ref ~name:"univrevtab" (UnivIdMap.empty : univrevtab) (* Push functions *********************************************************) @@ -546,38 +546,6 @@ let global_inductive qid = (********************************************************************) -(********************************************************************) -(* Registration of tables as a global table and rollback *) - -type frozen = ccitab * dirtab * mptab * univtab - * globrevtab * mprevtab * mptrevtab * univrevtab - -let freeze _ : frozen = - !the_ccitab, - !the_dirtab, - !the_modtypetab, - !the_univtab, - !the_globrevtab, - !the_modrevtab, - !the_modtyperevtab, - !the_univrevtab - -let unfreeze (ccit,dirt,mtyt,univt,globr,modr,mtyr,univr) = - the_ccitab := ccit; - the_dirtab := dirt; - the_modtypetab := mtyt; - the_univtab := univt; - the_globrevtab := globr; - the_modrevtab := modr; - the_modtyperevtab := mtyr; - the_univrevtab := univr - -let _ = - Summary.declare_summary "names" - { Summary.freeze_function = freeze; - Summary.unfreeze_function = unfreeze; - Summary.init_function = Summary.nop } - (* Deprecated synonyms *) let extended_locate = locate_extended diff --git a/plugins/btauto/Algebra.v b/plugins/btauto/Algebra.v index ee7341a4a2..f1095fc9f1 100644 --- a/plugins/btauto/Algebra.v +++ b/plugins/btauto/Algebra.v @@ -1,4 +1,4 @@ -Require Import Bool PArith DecidableClass Omega ROmega. +Require Import Bool PArith DecidableClass Omega Lia. Ltac bool := repeat match goal with @@ -84,9 +84,9 @@ Ltac case_decide := match goal with let H := fresh "H" in define (@decide P D) b H; destruct b; try_decide | [ |- context [Pos.compare ?x ?y] ] => - destruct (Pos.compare_spec x y); try (exfalso; zify; romega) + destruct (Pos.compare_spec x y); try lia | [ X : context [Pos.compare ?x ?y] |- _ ] => - destruct (Pos.compare_spec x y); try (exfalso; zify; romega) + destruct (Pos.compare_spec x y); try lia end. Section Definitions. @@ -325,13 +325,13 @@ Qed. Lemma linear_le_compat : forall k l p, linear k p -> (k <= l)%positive -> linear l p. Proof. -intros k l p H; revert l; induction H; constructor; eauto; zify; romega. +intros k l p H; revert l; induction H; constructor; eauto; lia. Qed. Lemma linear_valid_incl : forall k p, linear k p -> valid k p. Proof. intros k p H; induction H; constructor; auto. -eapply valid_le_compat; eauto; zify; romega. +eapply valid_le_compat; eauto; lia. Qed. End Validity. @@ -417,13 +417,13 @@ Qed. Hint Extern 5 => match goal with | [ |- (Pos.max ?x ?y <= ?z)%positive ] => - apply Pos.max_case_strong; intros; zify; romega + apply Pos.max_case_strong; intros; lia | [ |- (?z <= Pos.max ?x ?y)%positive ] => - apply Pos.max_case_strong; intros; zify; romega + apply Pos.max_case_strong; intros; lia | [ |- (Pos.max ?x ?y < ?z)%positive ] => - apply Pos.max_case_strong; intros; zify; romega + apply Pos.max_case_strong; intros; lia | [ |- (?z < Pos.max ?x ?y)%positive ] => - apply Pos.max_case_strong; intros; zify; romega + apply Pos.max_case_strong; intros; lia | _ => zify; omega end. Hint Resolve Pos.le_max_r Pos.le_max_l. @@ -445,8 +445,8 @@ intros kl kr pl pr Hl Hr; revert kr pr Hr; induction Hl; intros kr pr Hr; simpl. now rewrite <- (Pos.max_id i); intuition. destruct (Pos.compare_spec i i0); subst; try case_decide; repeat (constructor; intuition). + apply (valid_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; auto. - + apply (valid_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; zify; romega. - + apply (valid_le_compat (Pos.max (Pos.succ i0) (Pos.succ i0))); [now auto|]; rewrite Pos.max_id; zify; romega. + + apply (valid_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; lia. + + apply (valid_le_compat (Pos.max (Pos.succ i0) (Pos.succ i0))); [now auto|]; rewrite Pos.max_id; lia. + apply (valid_le_compat (Pos.max (Pos.succ i) i0)); intuition. + apply (valid_le_compat (Pos.max i (Pos.succ i0))); intuition. } @@ -456,7 +456,7 @@ Lemma poly_mul_cst_valid_compat : forall k v p, valid k p -> valid k (poly_mul_c Proof. intros k v p H; induction H; simpl; [now auto|]. case_decide; [|now auto]. -eapply (valid_le_compat i); [now auto|zify; romega]. +eapply (valid_le_compat i); [now auto|lia]. Qed. Lemma poly_mul_mon_null_compat : forall i p, null (poly_mul_mon i p) -> null p. diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index c2bc8c079c..b0f97c59b8 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -224,7 +224,7 @@ module Btauto = struct Tacticals.tclFAIL 0 msg gl let try_unification env = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let eq = Lazy.force eq in let concl = EConstr.Unsafe.to_constr concl in @@ -240,7 +240,7 @@ module Btauto = struct end let tac = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let concl = EConstr.Unsafe.to_constr concl in let sigma = Tacmach.New.project gl in diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 4ede11b5c9..5d3115d8d7 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -710,10 +710,10 @@ let structure_for_compute env sg c = init false false ~compute:true; let ast, mlt = Extraction.extract_constr env sg c in let ast = Mlutil.normalize ast in - let refs = ref Refset.empty in - let add_ref r = refs := Refset.add r !refs in + let refs = ref GlobRef.Set.empty in + let add_ref r = refs := GlobRef.Set.add r !refs in let () = ast_iter_references add_ref add_ref add_ref ast in - let refs = Refset.elements !refs in + let refs = GlobRef.Set.elements !refs in let struc = optimize_struct (refs,[]) (mono_environment refs []) in (flatten_structure struc), ast, mlt diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index c3f4cfe654..e05e82af6f 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -30,8 +30,8 @@ let capitalize = String.capitalize (** Sets and maps for [global_reference] that use the "user" [kernel_name] instead of the canonical one *) -module Refmap' = Refmap_env -module Refset' = Refset_env +module Refmap' = GlobRef.Map_env +module Refset' = GlobRef.Set_env (*S Utilities about [module_path] and [kernel_names] and [global_reference] *) @@ -213,12 +213,12 @@ let is_recursor = function (* NB: here, working modulo name equivalence is ok *) -let projs = ref (Refmap.empty : (inductive*int) Refmap.t) -let init_projs () = projs := Refmap.empty -let add_projection n kn ip = projs := Refmap.add (ConstRef kn) (ip,n) !projs -let is_projection r = Refmap.mem r !projs -let projection_arity r = snd (Refmap.find r !projs) -let projection_info r = Refmap.find r !projs +let projs = ref (GlobRef.Map.empty : (inductive*int) GlobRef.Map.t) +let init_projs () = projs := GlobRef.Map.empty +let add_projection n kn ip = projs := GlobRef.Map.add (ConstRef kn) (ip,n) !projs +let is_projection r = GlobRef.Map.mem r !projs +let projection_arity r = snd (GlobRef.Map.find r !projs) +let projection_info r = GlobRef.Map.find r !projs (*s Table of used axioms *) diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index 85f4939560..286021d68e 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -38,7 +38,7 @@ let compare_gr id1 id2 = if id1==id2 then 0 else if id1==dummy_id then 1 else if id2==dummy_id then -1 - else Globnames.RefOrdered.compare id1 id2 + else GlobRef.Ordered.compare id1 id2 module OrderedInstance= struct diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index b13580bc03..3ae777cc9a 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -34,7 +34,7 @@ type lseqtac= GlobRef.t -> seqtac type 'a with_backtracking = tactic -> 'a let wrap n b continue seq = - Proofview.Goal.nf_enter begin fun gls -> + Proofview.Goal.enter begin fun gls -> Control.check_for_interrupt (); let nc = Proofview.Goal.hyps gls in let env=pf_env gls in diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index 2a527da9be..5958fe8203 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -62,7 +62,7 @@ module Hitem= struct type t = h_item let compare (id1,co1) (id2,co2)= - let c = Globnames.RefOrdered.compare id1 id2 in + let c = GlobRef.Ordered.compare id1 id2 in if c = 0 then let cmp (i1, c1) (i2, c2) = let c = Int.compare i1 i2 in diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 5fc4293cbb..fd2d90e9cf 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -1469,7 +1469,7 @@ let do_build_inductive (rel_constructors) in let rel_ind i ext_rel_constructors = - (((CAst.make @@ relnames.(i)), None), + ((CAst.make @@ relnames.(i)), rel_params, Some rel_arities.(i), ext_rel_constructors),[] @@ -1499,14 +1499,14 @@ let do_build_inductive let _time2 = System.get_time () in try with_full_print - (Flags.silently (ComInductive.do_mutual_inductive rel_inds (Flags.is_universe_polymorphism ()) false false ~uniform:ComInductive.NonUniformParameters)) + (Flags.silently (ComInductive.do_mutual_inductive ~template:None None rel_inds (Flags.is_universe_polymorphism ()) false false ~uniform:ComInductive.NonUniformParameters)) Declarations.Finite with | UserError(s,msg) as e -> let _time3 = System.get_time () in (* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) let repacked_rel_inds = - List.map (fun ((a , b , c , l),ntn) -> ((false,a) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn ) + List.map (fun ((a , b , c , l),ntn) -> ((false,(a,None)) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn ) rel_inds in let msg = @@ -1521,7 +1521,7 @@ let do_build_inductive let _time3 = System.get_time () in (* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) let repacked_rel_inds = - List.map (fun ((a , b , c , l),ntn) -> ((false,a) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn ) + List.map (fun ((a , b , c , l),ntn) -> ((false,(a,None)) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn ) rel_inds in let msg = diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 489a40ed09..e114a0119e 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -98,7 +98,7 @@ let functional_induction with_clean c princl pat = List.map2 (fun c pat -> ((None, - Ltac_plugin.Tacexpr.ElimOnConstr (fun env sigma -> (sigma,(c,NoBindings)))), + Tactics.ElimOnConstr (fun env sigma -> (sigma,(c,NoBindings)))), (None,pat), None)) (args@c_list) diff --git a/plugins/ltac/evar_tactics.ml b/plugins/ltac/evar_tactics.ml index 84f13d2131..b0277e9cc2 100644 --- a/plugins/ltac/evar_tactics.ml +++ b/plugins/ltac/evar_tactics.ml @@ -94,12 +94,12 @@ let let_evar name typ = in let (sigma, evar) = Evarutil.new_evar env sigma ~src ~naming:(Namegen.IntroFresh id) typ in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) - (Tactics.letin_tac None (Name.Name id) evar None Locusops.nowhere) + (Tactics.pose_tac (Name.Name id) evar) end let hget_evar n = let open EConstr in - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in let evl = evar_list sigma concl in diff --git a/plugins/ltac/extraargs.ml4 b/plugins/ltac/extraargs.ml4 index 38600695dc..f4555509cc 100644 --- a/plugins/ltac/extraargs.ml4 +++ b/plugins/ltac/extraargs.ml4 @@ -311,78 +311,3 @@ let pr_lpar_id_colon _ _ _ _ = mt () ARGUMENT EXTEND test_lpar_id_colon TYPED AS unit PRINTED BY pr_lpar_id_colon | [ local_test_lpar_id_colon(x) ] -> [ () ] END - -(* spiwack: the print functions are incomplete, but I don't know what they are - used for *) -let pr_r_int31_field i31f = - str "int31 " ++ - match i31f with - | Retroknowledge.Int31Bits -> str "bits" - | Retroknowledge.Int31Type -> str "type" - | Retroknowledge.Int31Twice -> str "twice" - | Retroknowledge.Int31TwicePlusOne -> str "twice plus one" - | Retroknowledge.Int31Phi -> str "phi" - | Retroknowledge.Int31PhiInv -> str "phi inv" - | Retroknowledge.Int31Plus -> str "plus" - | Retroknowledge.Int31Times -> str "times" - | Retroknowledge.Int31Constructor -> assert false - | Retroknowledge.Int31PlusC -> str "plusc" - | Retroknowledge.Int31PlusCarryC -> str "pluscarryc" - | Retroknowledge.Int31Minus -> str "minus" - | Retroknowledge.Int31MinusC -> str "minusc" - | Retroknowledge.Int31MinusCarryC -> str "minuscarryc" - | Retroknowledge.Int31TimesC -> str "timesc" - | Retroknowledge.Int31Div21 -> str "div21" - | Retroknowledge.Int31Div -> str "div" - | Retroknowledge.Int31Diveucl -> str "diveucl" - | Retroknowledge.Int31AddMulDiv -> str "addmuldiv" - | Retroknowledge.Int31Compare -> str "compare" - | Retroknowledge.Int31Head0 -> str "head0" - | Retroknowledge.Int31Tail0 -> str "tail0" - | Retroknowledge.Int31Lor -> str "lor" - | Retroknowledge.Int31Land -> str "land" - | Retroknowledge.Int31Lxor -> str "lxor" - -let pr_retroknowledge_field f = - match f with - (* | Retroknowledge.KEq -> str "equality" - | Retroknowledge.KNat natf -> pr_r_nat_field () () () natf - | Retroknowledge.KN nf -> pr_r_n_field () () () nf *) - | Retroknowledge.KInt31 (group, i31f) -> (pr_r_int31_field i31f) ++ - spc () ++ str "in " ++ qs group - -VERNAC ARGUMENT EXTEND retroknowledge_int31 -PRINTED BY pr_r_int31_field -| [ "int31" "bits" ] -> [ Retroknowledge.Int31Bits ] -| [ "int31" "type" ] -> [ Retroknowledge.Int31Type ] -| [ "int31" "twice" ] -> [ Retroknowledge.Int31Twice ] -| [ "int31" "twice" "plus" "one" ] -> [ Retroknowledge.Int31TwicePlusOne ] -| [ "int31" "phi" ] -> [ Retroknowledge.Int31Phi ] -| [ "int31" "phi" "inv" ] -> [ Retroknowledge.Int31PhiInv ] -| [ "int31" "plus" ] -> [ Retroknowledge.Int31Plus ] -| [ "int31" "plusc" ] -> [ Retroknowledge.Int31PlusC ] -| [ "int31" "pluscarryc" ] -> [ Retroknowledge.Int31PlusCarryC ] -| [ "int31" "minus" ] -> [ Retroknowledge.Int31Minus ] -| [ "int31" "minusc" ] -> [ Retroknowledge.Int31MinusC ] -| [ "int31" "minuscarryc" ] -> [ Retroknowledge.Int31MinusCarryC ] -| [ "int31" "times" ] -> [ Retroknowledge.Int31Times ] -| [ "int31" "timesc" ] -> [ Retroknowledge.Int31TimesC ] -| [ "int31" "div21" ] -> [ Retroknowledge.Int31Div21 ] -| [ "int31" "div" ] -> [ Retroknowledge.Int31Div ] -| [ "int31" "diveucl" ] -> [ Retroknowledge.Int31Diveucl ] -| [ "int31" "addmuldiv" ] -> [ Retroknowledge.Int31AddMulDiv ] -| [ "int31" "compare" ] -> [ Retroknowledge.Int31Compare ] -| [ "int31" "head0" ] -> [ Retroknowledge.Int31Head0 ] -| [ "int31" "tail0" ] -> [ Retroknowledge.Int31Tail0 ] -| [ "int31" "lor" ] -> [ Retroknowledge.Int31Lor ] -| [ "int31" "land" ] -> [ Retroknowledge.Int31Land ] -| [ "int31" "lxor" ] -> [ Retroknowledge.Int31Lxor ] -END - -VERNAC ARGUMENT EXTEND retroknowledge_field -PRINTED BY pr_retroknowledge_field -(*| [ "equality" ] -> [ Retroknowledge.KEq ] -| [ retroknowledge_nat(n)] -> [ Retroknowledge.KNat n ] -| [ retroknowledge_binary_n (n)] -> [ Retroknowledge.KN n ]*) -| [ retroknowledge_int31 (i) "in" string(g)] -> [ Retroknowledge.KInt31(g,i) ] -END diff --git a/plugins/ltac/extraargs.mli b/plugins/ltac/extraargs.mli index e477b12cd3..fa70235975 100644 --- a/plugins/ltac/extraargs.mli +++ b/plugins/ltac/extraargs.mli @@ -72,11 +72,6 @@ val test_lpar_id_colon : unit Pcoq.Entry.t val wit_test_lpar_id_colon : (unit, unit, unit) Genarg.genarg_type -(** Spiwack: Primitive for retroknowledge registration *) - -val retroknowledge_field : Retroknowledge.field Pcoq.Entry.t -val wit_retroknowledge_field : (Retroknowledge.field, unit, unit) Genarg.genarg_type - val wit_in_clause : (lident Locus.clause_expr, lident Locus.clause_expr, diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4 index dc027c4041..ba3fa6fa0d 100644 --- a/plugins/ltac/extratactics.ml4 +++ b/plugins/ltac/extratactics.ml4 @@ -26,6 +26,7 @@ open Termops open Equality open Namegen open Tactypes +open Tactics open Proofview.Notations open Vernacinterp @@ -545,22 +546,6 @@ END (**********************************************************************) -(*spiwack : Vernac commands for retroknowledge *) - -VERNAC COMMAND EXTEND RetroknowledgeRegister CLASSIFIED AS SIDEFF - | [ "Register" constr(c) "as" retroknowledge_field(f) "by" constr(b)] -> - [ let env = Global.env () in - let evd = Evd.from_env env in - let tc,_ctx = Constrintern.interp_constr env evd c in - let tb,_ctx(*FIXME*) = Constrintern.interp_constr env evd b in - let tc = EConstr.to_constr evd tc in - let tb = EConstr.to_constr evd tb in - Global.register f tc tb ] -END - - - -(**********************************************************************) (* sozeau: abs/gen for induction on instantiated dependent inductives, using "Ford" induction as defined by Conor McBride *) TACTIC EXTEND generalize_eqs @@ -796,9 +781,9 @@ END (**********************************************************************) TACTIC EXTEND transparent_abstract -| [ "transparent_abstract" tactic3(t) ] -> [ Proofview.Goal.nf_enter begin fun gl -> +| [ "transparent_abstract" tactic3(t) ] -> [ Proofview.Goal.enter begin fun gl -> Tactics.tclABSTRACT ~opaque:false None (Tacinterp.tactic_of_value ist t) end ] -| [ "transparent_abstract" tactic3(t) "using" ident(id) ] -> [ Proofview.Goal.nf_enter begin fun gl -> +| [ "transparent_abstract" tactic3(t) "using" ident(id) ] -> [ Proofview.Goal.enter begin fun gl -> Tactics.tclABSTRACT ~opaque:false (Some id) (Tacinterp.tactic_of_value ist t) end ] END diff --git a/plugins/ltac/g_ltac.ml4 b/plugins/ltac/g_ltac.ml4 index c13bd69daf..929390b1c4 100644 --- a/plugins/ltac/g_ltac.ml4 +++ b/plugins/ltac/g_ltac.ml4 @@ -314,22 +314,23 @@ GEXTEND Gram range_selector_or_nth: [ [ n = natural ; "-" ; m = natural; l = OPT [","; l = LIST1 range_selector SEP "," -> l] -> - SelectList ((n, m) :: Option.default [] l) + Goal_select.SelectList ((n, m) :: Option.default [] l) | n = natural; l = OPT [","; l = LIST1 range_selector SEP "," -> l] -> + let open Goal_select in Option.cata (fun l -> SelectList ((n, n) :: l)) (SelectNth n) l ] ] ; selector_body: [ [ l = range_selector_or_nth -> l - | test_bracket_ident; "["; id = ident; "]" -> SelectId id ] ] + | test_bracket_ident; "["; id = ident; "]" -> Goal_select.SelectId id ] ] ; selector: [ [ IDENT "only"; sel = selector_body; ":" -> sel ] ] ; toplevel_selector: [ [ sel = selector_body; ":" -> sel - | "!"; ":" -> SelectAlreadyFocused - | IDENT "all"; ":" -> SelectAll ] ] + | "!"; ":" -> Goal_select.SelectAlreadyFocused + | IDENT "all"; ":" -> Goal_select.SelectAll ] ] ; tactic_mode: [ [ g = OPT toplevel_selector; tac = G_vernac.query_command -> tac g @@ -346,7 +347,7 @@ GEXTEND Gram hint: [ [ IDENT "Extern"; n = natural; c = OPT Constr.constr_pattern ; "=>"; tac = Pltac.tactic -> - Vernacexpr.HintsExtern (n,c, in_tac tac) ] ] + Hints.HintsExtern (n,c, in_tac tac) ] ] ; operconstr: LEVEL "0" [ [ IDENT "ltac"; ":"; "("; tac = Pltac.tactic_expr; ")" -> @@ -373,6 +374,7 @@ let _ = declare_int_option { } let vernac_solve n info tcom b = + let open Goal_select in let status = Proof_global.with_current_proof (fun etac p -> let with_end_tac = if b then Some etac else None in let global = match n with SelectAll | SelectList _ -> true | _ -> false in @@ -432,7 +434,7 @@ VERNAC tactic_mode EXTEND VernacSolve VtLater ] -> [ let t = rm_abstract t in - vernac_solve SelectAll n t def + vernac_solve Goal_select.SelectAll n t def ] END diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index 2e1ce814aa..571595be70 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -21,6 +21,8 @@ open Constrexpr open Libnames open Tok open Tactypes +open Tactics +open Inv open Locus open Decl_kinds diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 4357689ee2..803d35d07c 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -28,6 +28,7 @@ open Printer open Tacexpr open Tacarg +open Tactics module Tag = struct @@ -507,7 +508,7 @@ let string_of_genarg_arg (ArgumentType arg) = let pr_destruction_arg prc prlc (clear_flag,h) = pr_clear_flag clear_flag (pr_core_destruction_arg prc prlc) h - let pr_inversion_kind = function + let pr_inversion_kind = let open Inv in function | SimpleInversion -> primitive "simple inversion" | FullInversion -> primitive "inversion" | FullInversionClear -> primitive "inversion_clear" @@ -516,7 +517,7 @@ let string_of_genarg_arg (ArgumentType arg) = if Int.equal i j then int i else int i ++ str "-" ++ int j -let pr_goal_selector toplevel = function +let pr_goal_selector toplevel = let open Goal_select in function | SelectAlreadyFocused -> str "!:" | SelectNth i -> int i ++ str ":" | SelectList l -> prlist_with_sep (fun () -> str ", ") pr_range_selector l ++ str ":" diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 9f8cd2fc4e..5b8bd6d01a 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -520,11 +520,6 @@ let rewrite_db = "rewrite" let conv_transparent_state = (Id.Pred.empty, Cpred.full) -let _ = - Hints.add_hints_init - (fun () -> - Hints.create_hint_db false rewrite_db conv_transparent_state true) - let rewrite_transparent_state () = Hints.Hint_db.transparent_state (Hints.searchtable_map rewrite_db) diff --git a/plugins/ltac/tacexpr.ml b/plugins/ltac/tacexpr.ml index 59b748e25e..11d13d3a2f 100644 --- a/plugins/ltac/tacexpr.ml +++ b/plugins/ltac/tacexpr.ml @@ -37,16 +37,24 @@ type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use type goal_selector = Goal_select.t = | SelectAlreadyFocused + [@ocaml.deprecated "Use constructors in [Goal_select]"] | SelectNth of int + [@ocaml.deprecated "Use constructors in [Goal_select]"] | SelectList of (int * int) list + [@ocaml.deprecated "Use constructors in [Goal_select]"] | SelectId of Id.t + [@ocaml.deprecated "Use constructors in [Goal_select]"] | SelectAll -[@@ocaml.deprecated "Use Vernacexpr.goal_selector"] + [@ocaml.deprecated "Use constructors in [Goal_select]"] +[@@ocaml.deprecated "Use [Goal_select.t]"] type 'a core_destruction_arg = 'a Tactics.core_destruction_arg = | ElimOnConstr of 'a + [@ocaml.deprecated "Use constructors in [Tactics]"] | ElimOnIdent of lident + [@ocaml.deprecated "Use constructors in [Tactics]"] | ElimOnAnonHyp of int + [@ocaml.deprecated "Use constructors in [Tactics]"] [@@ocaml.deprecated "Use Tactics.core_destruction_arg"] type 'a destruction_arg = @@ -55,8 +63,11 @@ type 'a destruction_arg = type inversion_kind = Inv.inversion_kind = | SimpleInversion + [@ocaml.deprecated "Use constructors in [Inv]"] | FullInversion + [@ocaml.deprecated "Use constructors in [Inv]"] | FullInversionClear + [@ocaml.deprecated "Use constructors in [Inv]"] [@@ocaml.deprecated "Use Tactics.inversion_kind"] type ('c,'d,'id) inversion_strength = diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index 3a0badb28f..6b131edaac 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -37,16 +37,24 @@ type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use type goal_selector = Goal_select.t = | SelectAlreadyFocused + [@ocaml.deprecated "Use constructors in [Goal_select]"] | SelectNth of int + [@ocaml.deprecated "Use constructors in [Goal_select]"] | SelectList of (int * int) list + [@ocaml.deprecated "Use constructors in [Goal_select]"] | SelectId of Id.t + [@ocaml.deprecated "Use constructors in [Goal_select]"] | SelectAll + [@ocaml.deprecated "Use constructors in [Goal_select]"] [@@ocaml.deprecated "Use Vernacexpr.goal_selector"] type 'a core_destruction_arg = 'a Tactics.core_destruction_arg = | ElimOnConstr of 'a + [@ocaml.deprecated "Use constructors in [Tactics]"] | ElimOnIdent of lident + [@ocaml.deprecated "Use constructors in [Tactics]"] | ElimOnAnonHyp of int + [@ocaml.deprecated "Use constructors in [Tactics]"] [@@ocaml.deprecated "Use Tactics.core_destruction_arg"] type 'a destruction_arg = @@ -55,8 +63,11 @@ type 'a destruction_arg = type inversion_kind = Inv.inversion_kind = | SimpleInversion + [@ocaml.deprecated "Use constructors in [Inv]"] | FullInversion + [@ocaml.deprecated "Use constructors in [Inv]"] | FullInversionClear + [@ocaml.deprecated "Use constructors in [Inv]"] [@@ocaml.deprecated "Use Tactics.inversion_kind"] type ('c,'d,'id) inversion_strength = diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index 1444800624..5501cf92a5 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -29,6 +29,7 @@ open Stdarg open Tacarg open Namegen open Tactypes +open Tactics open Locus (** Globalization of tactic expressions : diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index a0446bd6a0..67ffae59cc 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -37,6 +37,7 @@ open Tacarg open Printer open Pretyping open Tactypes +open Tactics open Locus open Tacintern open Taccoerce @@ -1468,7 +1469,7 @@ and interp_genarg ist x : Val.t Ftactic.t = independently of goals. *) and interp_genarg_constr_list ist x = - Ftactic.nf_enter begin fun gl -> + Ftactic.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let lc = Genarg.out_gen (glbwit (wit_list wit_constr)) x in @@ -1600,7 +1601,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacMutualFix (id,n,l) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"<mutual fix>") begin - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = pf_env gl in let f sigma (id,n,c) = let (sigma,c_interp) = interp_type ist env sigma c in @@ -1615,7 +1616,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacMutualCofix (id,l) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"<mutual cofix>") begin - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = pf_env gl in let f sigma (id,c) = let (sigma,c_interp) = interp_type ist env sigma c in @@ -1664,16 +1665,18 @@ and interp_atomic ist tac : unit Proofview.tactic = (* We try to fully-typecheck the term *) let flags = open_constr_use_classes_flags () in let (sigma,c_interp) = interp_open_constr ~flags ist env sigma c in - let let_tac b na c cl eqpat = - let id = Option.default (make IntroAnonymous) eqpat in - let with_eq = if b then None else Some (true,id) in - Tactics.letin_tac with_eq na c None cl - in let na = interp_name ist env sigma na in + let let_tac = + if b then Tactics.pose_tac na c_interp + else + let id = Option.default (make IntroAnonymous) eqpat in + let with_eq = Some (true, id) in + Tactics.letin_tac with_eq na c_interp None Locusops.nowhere + in Tacticals.New.tclWITHHOLES ev (name_atomic ~env (TacLetTac(ev,na,c_interp,clp,b,eqpat)) - (let_tac b na c_interp clp eqpat)) sigma + let_tac) sigma else (* We try to keep the pattern structure as much as possible *) let let_pat_tac b na c cl eqpat = @@ -1693,7 +1696,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacInductionDestruct (isrec,ev,(l,el)) -> (* spiwack: some unknown part of destruct needs the goal to be prenormalised. *) - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let sigma,l = @@ -1720,7 +1723,7 @@ and interp_atomic ist tac : unit Proofview.tactic = (* Conversion *) | TacReduce (r,cl) -> - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let (sigma,r_interp) = interp_red_expr ist (pf_env gl) (project gl) r in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Tactics.reduce r_interp (interp_clause ist (pf_env gl) (project gl) cl)) @@ -2029,7 +2032,7 @@ let _ = let (c, sigma) = Pfedit.refine_by_tactic env sigma ty tac in (EConstr.of_constr c, sigma) in - Pretyping.register_constr_interp0 wit_tactic eval + GlobEnv.register_constr_interp0 wit_tactic eval let vernac_debug b = set_debug (if b then Tactic_debug.DebugOn 0 else Tactic_debug.DebugOff) diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index dd799dc131..4626378db6 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -15,6 +15,7 @@ open Genarg open Stdarg open Tacarg open Tactypes +open Tactics open Globnames open Genredexpr open Patternops diff --git a/plugins/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml index 105b5c59ae..48d677a864 100644 --- a/plugins/ltac/tactic_debug.ml +++ b/plugins/ltac/tactic_debug.ml @@ -58,7 +58,7 @@ let db_pr_goal gl = str" " ++ pc) ++ fnl () let db_pr_goal = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let pg = db_pr_goal gl in Proofview.tclLIFT (msg_tac_notice (str "Goal:" ++ fnl () ++ pg)) end diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index f22147f8b0..e0a369ca5f 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -1456,7 +1456,7 @@ let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic* let ff = dump_formula formula_typ (dump_cstr spec.coeff spec.dump_coeff) ff in let vm = dump_varmap (spec.typ) (vm_of_list env) in (* todo : directly generate the proof term - or generalize before conversion? *) - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> Tacticals.New.tclTHENLIST [ Tactics.change_concl @@ -1709,7 +1709,7 @@ let micromega_gen (normalise:'cst atom -> 'cst mc_cnf) unsat deduce spec dumpexpr prover tac = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let concl = Tacmach.New.pf_concl gl in let hyps = Tacmach.New.pf_hyps_types gl in @@ -1787,7 +1787,7 @@ let micromega_order_changer cert env ff = let formula_typ = (EConstr.mkApp (Lazy.force coq_Cstr,[| coeff|])) in let ff = dump_formula formula_typ (dump_cstr coeff dump_coeff) ff in let vm = dump_varmap (typ) (vm_of_list env) in - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> Tacticals.New.tclTHENLIST [ (Tactics.change_concl @@ -1817,7 +1817,7 @@ let micromega_genr prover tac = proof_typ = Lazy.force coq_QWitness ; dump_proof = dump_psatz coq_Q dump_q } in - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let concl = Tacmach.New.pf_concl gl in let hyps = Tacmach.New.pf_hyps_types gl in diff --git a/plugins/omega/PreOmega.v b/plugins/omega/PreOmega.v index 59fd9b8017..094adfda7a 100644 --- a/plugins/omega/PreOmega.v +++ b/plugins/omega/PreOmega.v @@ -85,6 +85,7 @@ Ltac zify_binop t thm a b:= Ltac zify_op_1 := match goal with + | x := ?t : Z |- _ => let h := fresh "heq_" x in pose proof (eq_refl : x = t) as h; clearbody x | |- context [ Z.max ?a ?b ] => zify_binop Z.max Z.max_spec a b | H : context [ Z.max ?a ?b ] |- _ => zify_binop Z.max Z.max_spec a b | |- context [ Z.min ?a ?b ] => zify_binop Z.min Z.min_spec a b @@ -114,6 +115,7 @@ Ltac hide_Z_of_nat t := Ltac zify_nat_rel := match goal with (* I: equalities *) + | x := ?t : nat |- _ => let h := fresh "heq_" x in pose proof (eq_refl : x = t) as h; clearbody x | |- (@eq nat ?a ?b) => apply (Nat2Z.inj a b) (* shortcut *) | H : context [ @eq nat ?a ?b ] |- _ => rewrite <- (Nat2Z.inj_iff a b) in H | |- context [ @eq nat ?a ?b ] => rewrite <- (Nat2Z.inj_iff a b) @@ -223,6 +225,7 @@ Ltac hide_Zpos t := Ltac zify_positive_rel := match goal with (* I: equalities *) + | x := ?t : positive |- _ => let h := fresh "heq_" x in pose proof (eq_refl : x = t) as h; clearbody x | |- (@eq positive ?a ?b) => apply Pos2Z.inj | H : context [ @eq positive ?a ?b ] |- _ => rewrite <- (Pos2Z.inj_iff a b) in H | |- context [ @eq positive ?a ?b ] => rewrite <- (Pos2Z.inj_iff a b) @@ -348,6 +351,7 @@ Ltac hide_Z_of_N t := Ltac zify_N_rel := match goal with (* I: equalities *) + | x := ?t : N |- _ => let h := fresh "heq_" x in pose proof (eq_refl : x = t) as h; clearbody x | |- (@eq N ?a ?b) => apply (N2Z.inj a b) (* shortcut *) | H : context [ @eq N ?a ?b ] |- _ => rewrite <- (N2Z.inj_iff a b) in H | |- context [ @eq N ?a ?b ] => rewrite <- (N2Z.inj_iff a b) diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index e14c4e2ec1..abae6940fa 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -588,7 +588,7 @@ let abstract_path sigma typ path t = let focused_simpl path = let open Tacmach.New in - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let newc = context (project gl) (fun i t -> pf_nf gl t) (List.rev path) (pf_concl gl) in convert_concl_no_check newc DEFAULTcast end @@ -656,7 +656,7 @@ let new_hole env sigma c = let clever_rewrite_base_poly typ p result theorem = let open Tacmach.New in - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let full = pf_concl gl in let env = pf_env gl in let (abstracted,occ) = abstract_path (project gl) typ (List.rev p) full in @@ -708,7 +708,7 @@ let refine_app gl t = let clever_rewrite p vpath t = let open Tacmach.New in - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let full = pf_concl gl in let (abstracted,occ) = abstract_path (project gl) (Lazy.force coq_Z) (List.rev p) full in let vargs = List.map (fun p -> occurrence (project gl) p occ) vpath in @@ -1763,7 +1763,7 @@ let onClearedName id tac = (* so renaming may be necessary *) tclTHEN (tclTRY (clear [id])) - (Proofview.Goal.nf_enter begin fun gl -> + (Proofview.Goal.enter begin fun gl -> let id = fresh_id Id.Set.empty id gl in tclTHEN (introduction id) (tac id) end) @@ -1771,7 +1771,7 @@ let onClearedName id tac = let onClearedName2 id tac = tclTHEN (tclTRY (clear [id])) - (Proofview.Goal.nf_enter begin fun gl -> + (Proofview.Goal.enter begin fun gl -> let id1 = fresh_id Id.Set.empty (add_suffix id "_left") gl in let id2 = fresh_id Id.Set.empty (add_suffix id "_right") gl in tclTHENLIST [ introduction id1; introduction id2; tac id1 id2 ] @@ -1956,7 +1956,7 @@ let destructure_goal = try let dec = decidability t in tclTHEN - (Proofview.Goal.nf_enter begin fun gl -> + (Proofview.Goal.enter begin fun gl -> refine_app gl (mkApp (Lazy.force coq_dec_not_not, [| t; dec |])) end) intro diff --git a/plugins/quote/Quote.v b/plugins/quote/Quote.v deleted file mode 100644 index 2d3d9170c1..0000000000 --- a/plugins/quote/Quote.v +++ /dev/null @@ -1,86 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Declare ML Module "quote_plugin". - -(*********************************************************************** - The "abstract" type index is defined to represent variables. - - index : Set - index_eq : index -> bool - index_eq_prop: (n,m:index)(index_eq n m)=true -> n=m - index_lt : index -> bool - varmap : Type -> Type. - varmap_find : (A:Type)A -> index -> (varmap A) -> A. - - The first arg. of varmap_find is the default value to take - if the object is not found in the varmap. - - index_lt defines a total well-founded order, but we don't prove that. - -***********************************************************************) - -Set Implicit Arguments. - -Section variables_map. - -Variable A : Type. - -Inductive varmap : Type := - | Empty_vm : varmap - | Node_vm : A -> varmap -> varmap -> varmap. - -Inductive index : Set := - | Left_idx : index -> index - | Right_idx : index -> index - | End_idx : index. - -Fixpoint varmap_find (default_value:A) (i:index) (v:varmap) {struct v} : A := - match i, v with - | End_idx, Node_vm x _ _ => x - | Right_idx i1, Node_vm x v1 v2 => varmap_find default_value i1 v2 - | Left_idx i1, Node_vm x v1 v2 => varmap_find default_value i1 v1 - | _, _ => default_value - end. - -Fixpoint index_eq (n m:index) {struct m} : bool := - match n, m with - | End_idx, End_idx => true - | Left_idx n', Left_idx m' => index_eq n' m' - | Right_idx n', Right_idx m' => index_eq n' m' - | _, _ => false - end. - -Fixpoint index_lt (n m:index) {struct m} : bool := - match n, m with - | End_idx, Left_idx _ => true - | End_idx, Right_idx _ => true - | Left_idx n', Right_idx m' => true - | Right_idx n', Right_idx m' => index_lt n' m' - | Left_idx n', Left_idx m' => index_lt n' m' - | _, _ => false - end. - -Lemma index_eq_prop : forall n m:index, index_eq n m = true -> n = m. - simple induction n; simple induction m; simpl; intros. - rewrite (H i0 H1); reflexivity. - discriminate. - discriminate. - discriminate. - rewrite (H i0 H1); reflexivity. - discriminate. - discriminate. - discriminate. - reflexivity. -Qed. - -End variables_map. - -Unset Implicit Arguments. diff --git a/plugins/quote/g_quote.mlg b/plugins/quote/g_quote.mlg deleted file mode 100644 index 749903c3ad..0000000000 --- a/plugins/quote/g_quote.mlg +++ /dev/null @@ -1,46 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -{ - -open Ltac_plugin -open Names -open Tacexpr -open Geninterp -open Quote -open Stdarg -open Tacarg - -} - -DECLARE PLUGIN "quote_plugin" - -{ - -let cont = Id.of_string "cont" -let x = Id.of_string "x" - -let make_cont (k : Val.t) (c : EConstr.t) = - let c = Tacinterp.Value.of_constr c in - let tac = TacCall (Loc.tag (Locus.ArgVar CAst.(make cont), [Reference (Locus.ArgVar CAst.(make x))])) in - let ist = { lfun = Id.Map.add cont k (Id.Map.singleton x c); extra = TacStore.empty; } in - Tacinterp.eval_tactic_ist ist (TacArg (Loc.tag tac)) - -} - -TACTIC EXTEND quote -| [ "quote" ident(f) ] -> { quote f [] } -| [ "quote" ident(f) "[" ne_ident_list(lc) "]"] -> { quote f lc } -| [ "quote" ident(f) "in" constr(c) "using" tactic(k) ] -> - { gen_quote (make_cont k) c f [] } -| [ "quote" ident(f) "[" ne_ident_list(lc) "]" - "in" constr(c) "using" tactic(k) ] -> - { gen_quote (make_cont k) c f lc } -END diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml deleted file mode 100644 index 7464b42dc5..0000000000 --- a/plugins/quote/quote.ml +++ /dev/null @@ -1,540 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(* The `Quote' tactic *) - -(* The basic idea is to automatize the inversion of interpretation functions - in 2-level approach - - Examples are given in \texttt{theories/DEMOS/DemoQuote.v} - - Suppose you have a langage \texttt{L} of 'abstract terms' - and a type \texttt{A} of 'concrete terms' - and a function \texttt{f : L -> (varmap A L) -> A}. - - Then, the tactic \texttt{quote f} will replace an - expression \texttt{e} of type \texttt{A} by \texttt{(f vm t)} - such that \texttt{e} and \texttt{(f vm t)} are convertible. - - The problem is then inverting the function \texttt{f}. - - The tactic works when: - - \begin{itemize} - \item L is a simple inductive datatype. The constructors of L may - have one of the three following forms: - - \begin{enumerate} - \item ordinary recursive constructors like: \verb|Cplus : L -> L -> L| - \item variable leaf like: \verb|Cvar : index -> L| - \item constant leaf like \verb|Cconst : A -> L| - \end{enumerate} - - The definition of \texttt{L} must contain at most one variable - leaf and at most one constant leaf. - - When there are both a variable leaf and a constant leaf, there is - an ambiguity on inversion. The term t can be either the - interpretation of \texttt{(Cconst t)} or the interpretation of - (\texttt{Cvar}~$i$) in a variable map containing the binding $i - \rightarrow$~\texttt{t}. How to discriminate between these - choices? - - To solve the dilemma, one gives to \texttt{quote} a list of - \emph{constant constructors}: a term will be considered as a - constant if it is either a constant constructor or the - application of a constant constructor to constants. For example - the list \verb+[S, O]+ defines the closed natural - numbers. \texttt{(S (S O))} is a constant when \texttt{(S x)} is - not. - - The definition of constants vary for each application of the - tactic, so it can even be different for two applications of - \texttt{quote} with the same function. - - \item \texttt{f} is a quite simple fixpoint on - \texttt{L}. In particular, \texttt{f} must verify: - -\begin{verbatim} - (f (Cvar i)) = (varmap_find vm default_value i) -\end{verbatim} -\begin{verbatim} - (f (Cconst c)) = c -\end{verbatim} - - where \texttt{index} and \texttt{varmap\_find} are those defined - the \texttt{Quote} module. \emph{The tactic won't work with - user's own variables map!!} It is mandatory to use the - variable map defined in module \texttt{Quote}. - - \end{itemize} - - The method to proceed is then clear: - - \begin{itemize} - \item Start with an empty hashtable of "registed leafs" - that maps constr to integers and a "variable counter" equal to 0. - \item Try to match the term with every right hand side of the - definition of \texttt{f}. - - If there is one match, returns the correponding left hand - side and call yourself recursively to get the arguments of this - left hand side. - - If there is no match, we are at a leaf. That is the - interpretation of either a variable or a constant. - - If it is a constant, return \texttt{Cconst} applied to that - constant. - - If not, it is a variable. Look in the hashtable - if this leaf has been already encountered. If not, increment - the variable counter and add an entry to the hashtable; then - return \texttt{(Cvar !variables\_counter)} - \end{itemize} -*) - - -(*i*) -open CErrors -open Util -open Names -open Constr -open EConstr -open Pattern -open Patternops -open Constr_matching -open Tacmach -open Proofview.Notations -(*i*) - -(*s First, we need to access some Coq constants - We do that lazily, because this code can be linked before - the constants are loaded in the environment *) - -let constant dir s = - EConstr.of_constr @@ UnivGen.constr_of_global @@ - Coqlib.coq_reference "Quote" ("quote"::dir) s - -let coq_Empty_vm = lazy (constant ["Quote"] "Empty_vm") -let coq_Node_vm = lazy (constant ["Quote"] "Node_vm") -let coq_varmap_find = lazy (constant ["Quote"] "varmap_find") -let coq_Right_idx = lazy (constant ["Quote"] "Right_idx") -let coq_Left_idx = lazy (constant ["Quote"] "Left_idx") -let coq_End_idx = lazy (constant ["Quote"] "End_idx") - -(*s Then comes the stuff to decompose the body of interpetation function - and pre-compute the inversion data. - -For a function like: - -\begin{verbatim} - Fixpoint interp (vm:varmap Prop) (f:form) := - match f with - | f_and f1 f1 f2 => (interp f1) /\ (interp f2) - | f_or f1 f1 f2 => (interp f1) \/ (interp f2) - | f_var i => varmap_find Prop default_v i vm - | f_const c => c - end. -\end{verbatim} - -With the constant constructors \texttt{C1}, \dots, \texttt{Cn}, the -corresponding scheme will be: - -\begin{verbatim} - {normal_lhs_rhs = - [ "(f_and ?1 ?2)", "?1 /\ ?2"; - "(f_or ?1 ?2)", " ?1 \/ ?2";]; - return_type = "Prop"; - constants = Some [C1,...Cn]; - variable_lhs = Some "(f_var ?1)"; - constant_lhs = Some "(f_const ?1)" - } -\end{verbatim} - -If there is no constructor for variables in the type \texttt{form}, -then [variable_lhs] is [None]. Idem for constants and -[constant_lhs]. Both cannot be equal to [None]. - -The metas in the RHS must correspond to those in the LHS (one cannot -exchange ?1 and ?2 in the example above) - -*) - -module ConstrSet = Set.Make(Constr) - -type inversion_scheme = { - normal_lhs_rhs : (constr * constr_pattern) list; - variable_lhs : constr option; - return_type : constr; - constants : ConstrSet.t; - constant_lhs : constr option } - -(*s [compute_ivs gl f cs] computes the inversion scheme associated to - [f:constr] with constants list [cs:constr list] in the context of - goal [gl]. This function uses the auxiliary functions - [i_can't_do_that], [decomp_term], [compute_lhs] and [compute_rhs]. *) - -let i_can't_do_that () = user_err Pp.(str "Quote: not a simple fixpoint") - -let decomp_term sigma c = EConstr.kind sigma (Termops.strip_outer_cast sigma c) - -(*s [compute_lhs typ i nargsi] builds the term \texttt{(C ?nargsi ... - ?2 ?1)}, where \texttt{C} is the [i]-th constructor of inductive - type [typ] *) - -let coerce_meta_out id = - let s = Id.to_string id in - int_of_string (String.sub s 1 (String.length s - 1)) -let coerce_meta_in n = - Id.of_string ("M" ^ string_of_int n) - -let compute_lhs sigma typ i nargsi = - match EConstr.kind sigma typ with - | Ind((sp,0),u) -> - let argsi = Array.init nargsi (fun j -> mkMeta (nargsi - j)) in - mkApp (mkConstructU (((sp,0),i+1),u), argsi) - | _ -> i_can't_do_that () - -(*s This function builds the pattern from the RHS. Recursive calls are - replaced by meta-variables ?i corresponding to those in the LHS *) - -let compute_rhs env sigma bodyi index_of_f = - let rec aux c = - match EConstr.kind sigma c with - | App (j, args) when isRel sigma j && Int.equal (destRel sigma j) index_of_f (* recursive call *) -> - let i = destRel sigma (Array.last args) in - PMeta (Some (coerce_meta_in i)) - | App (f,args) -> - PApp (pattern_of_constr env sigma (EConstr.to_constr sigma f), Array.map aux args) - | Cast (c,_,_) -> aux c - | _ -> pattern_of_constr env sigma (EConstr.to_constr sigma c) - in - aux bodyi - -(*s Now the function [compute_ivs] itself *) - -let compute_ivs f cs gl = - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let (cst, u) = try destConst sigma f with DestKO -> i_can't_do_that () in - let u = EInstance.kind sigma u in - let body = Environ.constant_value_in (Global.env()) (cst, u) in - let body = EConstr.of_constr body in - match decomp_term sigma body with - | Fix(([| len |], 0), ([| name |], [| typ |], [| body2 |])) -> - let (args3, body3) = decompose_lam sigma body2 in - let nargs3 = List.length args3 in - let is_conv = Reductionops.is_conv env sigma in - begin match decomp_term sigma body3 with - | Case(_,p,c,lci) -> (* <p> Case c of c1 ... cn end *) - let n_lhs_rhs = ref [] - and v_lhs = ref (None : constr option) - and c_lhs = ref (None : constr option) in - Array.iteri - (fun i ci -> - let argsi, bodyi = decompose_lam sigma ci in - let nargsi = List.length argsi in - (* REL (narg3 + nargsi + 1) is f *) - (* REL nargsi+1 to REL nargsi + nargs3 are arguments of f *) - (* REL 1 to REL nargsi are argsi (reverse order) *) - (* First we test if the RHS is the RHS for constants *) - if isRel sigma bodyi && Int.equal (destRel sigma bodyi) 1 then - c_lhs := Some (compute_lhs sigma (snd (List.hd args3)) - i nargsi) - (* Then we test if the RHS is the RHS for variables *) - else begin match decompose_app sigma bodyi with - | vmf, [_; _; a3; a4 ] - when isRel sigma a3 && isRel sigma a4 && is_conv vmf - (Lazy.force coq_varmap_find) -> - v_lhs := Some (compute_lhs sigma - (snd (List.hd args3)) - i nargsi) - (* Third case: this is a normal LHS-RHS *) - | _ -> - n_lhs_rhs := - (compute_lhs sigma (snd (List.hd args3)) i nargsi, - compute_rhs env sigma bodyi (nargs3 + nargsi + 1)) - :: !n_lhs_rhs - end) - lci; - - if Option.is_empty !c_lhs && Option.is_empty !v_lhs then i_can't_do_that (); - - (* The Cases predicate is a lambda; we assume no dependency *) - let p = match EConstr.kind sigma p with - | Lambda (_,_,p) -> Termops.pop p - | _ -> p - in - - { normal_lhs_rhs = List.rev !n_lhs_rhs; - variable_lhs = !v_lhs; - return_type = p; - constants = List.fold_right ConstrSet.add cs ConstrSet.empty; - constant_lhs = !c_lhs } - - | _ -> i_can't_do_that () - end - |_ -> i_can't_do_that () - -(* TODO for that function: -\begin{itemize} -\item handle the case where the return type is an argument of the - function -\item handle the case of simple mutual inductive (for example terms - and lists of terms) formulas with the corresponding mutual - recursvive interpretation functions. -\end{itemize} -*) - -(*s Stuff to build variables map, currently implemented as complete -binary search trees (see file \texttt{Quote.v}) *) - -(* First the function to distinghish between constants (closed terms) - and variables (open terms) *) - -let rec closed_under sigma cset t = - (ConstrSet.mem (EConstr.Unsafe.to_constr t) cset) || - (match EConstr.kind sigma t with - | Cast(c,_,_) -> closed_under sigma cset c - | App(f,l) -> closed_under sigma cset f && Array.for_all (closed_under sigma cset) l - | _ -> false) - -(*s [btree_of_array [| c1; c2; c3; c4; c5 |]] builds the complete - binary search tree containing the [ci], that is: - -\begin{verbatim} - c1 - / \ - c2 c3 - / \ - c4 c5 -\end{verbatim} - -The second argument is a constr (the common type of the [ci]) -*) - -let btree_of_array a ty = - let size_of_a = Array.length a in - let semi_size_of_a = size_of_a lsr 1 in - let node = Lazy.force coq_Node_vm - and empty = mkApp (Lazy.force coq_Empty_vm, [| ty |]) in - let rec aux n = - if n > size_of_a - then empty - else if n > semi_size_of_a - then mkApp (node, [| ty; a.(n-1); empty; empty |]) - else mkApp (node, [| ty; a.(n-1); aux (2*n); aux (2*n+1) |]) - in - aux 1 - -(*s [btree_of_array] and [path_of_int] verify the following invariant:\\ - {\tt (varmap\_find A dv }[(path_of_int n)] [(btree_of_array a ty)] - = [a.(n)]\\ - [n] must be [> 0] *) - -let path_of_int n = - (* returns the list of digits of n in reverse order with - initial 1 removed *) - let rec digits_of_int n = - if Int.equal n 1 then [] - else (Int.equal (n mod 2) 1)::(digits_of_int (n lsr 1)) - in - List.fold_right - (fun b c -> mkApp ((if b then Lazy.force coq_Right_idx - else Lazy.force coq_Left_idx), - [| c |])) - (List.rev (digits_of_int n)) - (Lazy.force coq_End_idx) - -(*s The tactic works with a list of subterms sharing the same - variables map. We need to sort terms in order to avoid than - strange things happen during replacement of terms by their - 'abstract' counterparties. *) - -(* [subterm t t'] tests if constr [t'] occurs in [t] *) -(* This function does not descend under binders (lambda and Cases) *) - -let rec subterm gl (t : constr) (t' : constr) = - (pf_conv_x gl t t') || - (match EConstr.kind (project gl) t with - | App (f,args) -> Array.exists (fun t -> subterm gl t t') args - | Cast(t,_,_) -> (subterm gl t t') - | _ -> false) - -(*s We want to sort the list according to reverse subterm order. *) -(* Since it's a partial order the algoritm of Sort.list won't work !! *) - -let rec sort_subterm gl l = - let sigma = project gl in - let rec insert c = function - | [] -> [c] - | (h::t as l) when EConstr.eq_constr sigma c h -> l (* Avoid doing the same work twice *) - | h::t -> if subterm gl c h then c::h::t else h::(insert c t) - in - match l with - | [] -> [] - | h::t -> insert h (sort_subterm gl t) - -module Constrhash = Hashtbl.Make(Constr) - -let subst_meta subst c = - let subst = List.map (fun (i, c) -> i, EConstr.Unsafe.to_constr c) subst in - EConstr.of_constr (Termops.subst_meta subst (EConstr.Unsafe.to_constr c)) - -(*s Now we are able to do the inversion itself. - We destructurate the term and use an imperative hashtable - to store leafs that are already encountered. - The type of arguments is:\\ - [ivs : inversion_scheme]\\ - [lc: constr list]\\ - [gl: goal sigma]\\ *) -let quote_terms env sigma ivs lc = - Coqlib.check_required_library ["Coq";"quote";"Quote"]; - let varhash = (Constrhash.create 17 : constr Constrhash.t) in - let varlist = ref ([] : constr list) in (* list of variables *) - let counter = ref 1 in (* number of variables created + 1 *) - let rec aux c = - let rec auxl l = - match l with - | (lhs, rhs)::tail -> - begin try - let s1 = Id.Map.bindings (matches env sigma rhs c) in - let s2 = List.map (fun (i,c_i) -> (coerce_meta_out i,aux c_i)) s1 - in - subst_meta s2 lhs - with PatternMatchingFailure -> auxl tail - end - | [] -> - begin match ivs.variable_lhs with - | None -> - begin match ivs.constant_lhs with - | Some c_lhs -> subst_meta [1, c] c_lhs - | None -> anomaly (Pp.str "invalid inversion scheme for quote.") - end - | Some var_lhs -> - begin match ivs.constant_lhs with - | Some c_lhs when closed_under sigma ivs.constants c -> - subst_meta [1, c] c_lhs - | _ -> - begin - try Constrhash.find varhash (EConstr.Unsafe.to_constr c) - with Not_found -> - let newvar = - subst_meta [1, (path_of_int !counter)] - var_lhs in - begin - incr counter; - varlist := c :: !varlist; - Constrhash.add varhash (EConstr.Unsafe.to_constr c) newvar; - newvar - end - end - end - end - in - auxl ivs.normal_lhs_rhs - in - let lp = List.map aux lc in - (lp, (btree_of_array (Array.of_list (List.rev !varlist)) - ivs.return_type )) - -(*s actually we could "quote" a list of terms instead of a single - term. Ring for example needs that, but Ring doesn't use Quote - yet. *) - -let pf_constrs_of_globals l = - let rec aux l acc = - match l with - [] -> Proofview.tclUNIT (List.rev acc) - | hd :: tl -> - Tacticals.New.pf_constr_of_global hd >>= fun g -> aux tl (g :: acc) - in aux l [] - -let quote f lid = - Proofview.Goal.enter begin fun gl -> - let fg = Tacmach.New.pf_global f gl in - let clg = List.map (fun id -> Tacmach.New.pf_global id gl) lid in - Tacticals.New.pf_constr_of_global fg >>= fun f -> - pf_constrs_of_globals clg >>= fun cl -> - Proofview.Goal.nf_enter begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let ivs = compute_ivs f (List.map (EConstr.to_constr sigma) cl) gl in - let concl = Proofview.Goal.concl gl in - let quoted_terms = quote_terms env sigma ivs [concl] in - let (p, vm) = match quoted_terms with - | [p], vm -> (p,vm) - | _ -> assert false - in - match ivs.variable_lhs with - | None -> Tactics.convert_concl (mkApp (f, [| p |])) DEFAULTcast - | Some _ -> Tactics.convert_concl (mkApp (f, [| vm; p |])) DEFAULTcast - end - end - -let gen_quote cont c f lid = - Proofview.Goal.enter begin fun gl -> - let fg = Tacmach.New.pf_global f gl in - let clg = List.map (fun id -> Tacmach.New.pf_global id gl) lid in - Tacticals.New.pf_constr_of_global fg >>= fun f -> - pf_constrs_of_globals clg >>= fun cl -> - Proofview.Goal.nf_enter begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let cl = List.map (EConstr.to_constr sigma) cl in - let ivs = compute_ivs f cl gl in - let quoted_terms = quote_terms env sigma ivs [c] in - let (p, vm) = match quoted_terms with - | [p], vm -> (p,vm) - | _ -> assert false - in - match ivs.variable_lhs with - | None -> cont (mkApp (f, [| p |])) - | Some _ -> cont (mkApp (f, [| vm; p |])) - end - end - -(*i - -Just testing ... - -#use "include.ml";; -open Quote;; - -let r = glob_constr_of_string;; - -let ivs = { - normal_lhs_rhs = - [ r "(f_and ?1 ?2)", r "?1/\?2"; - r "(f_not ?1)", r "~?1"]; - variable_lhs = Some (r "(f_atom ?1)"); - return_type = r "Prop"; - constants = ConstrSet.empty; - constant_lhs = (r "nat") -};; - -let t1 = r "True/\(True /\ ~False)";; -let t2 = r "True/\~~False";; - -quote_term ivs () t1;; -quote_term ivs () t2;; - -let ivs2 = - normal_lhs_rhs = - [ r "(f_and ?1 ?2)", r "?1/\?2"; - r "(f_not ?1)", r "~?1" - r "True", r "f_true"]; - variable_lhs = Some (r "(f_atom ?1)"); - return_type = r "Prop"; - constants = ConstrSet.empty; - constant_lhs = (r "nat") - -i*) diff --git a/plugins/quote/quote_plugin.mlpack b/plugins/quote/quote_plugin.mlpack deleted file mode 100644 index 2e9be09d8d..0000000000 --- a/plugins/quote/quote_plugin.mlpack +++ /dev/null @@ -1,2 +0,0 @@ -Quote -G_quote diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v index 51b99b9935..da86f4274d 100644 --- a/plugins/romega/ReflOmegaCore.v +++ b/plugins/romega/ReflOmegaCore.v @@ -8,6 +8,7 @@ *************************************************************************) Require Import List Bool Sumbool EqNat Setoid Ring_theory Decidable ZArith_base. +Declare Scope Int_scope. Delimit Scope Int_scope with I. (** * Abstract Integers. *) @@ -716,6 +717,7 @@ Inductive term : Set := | Topp : term -> term | Tvar : N -> term. +Declare Scope romega_scope. Bind Scope romega_scope with term. Delimit Scope romega_scope with term. Arguments Tint _%I. diff --git a/plugins/romega/g_romega.mlg b/plugins/romega/g_romega.mlg index c1ce30027e..ac4f30b1db 100644 --- a/plugins/romega/g_romega.mlg +++ b/plugins/romega/g_romega.mlg @@ -41,14 +41,22 @@ let romega_tactic unsafe l = (Tactics.intros) (total_reflexive_omega_tactic unsafe)) +let romega_depr = + Vernacinterp.mk_deprecation + ~since:(Some "8.9") + ~note:(Some "Use lia instead.") + () + } TACTIC EXTEND romega +DEPRECATED { romega_depr } | [ "romega" ] -> { romega_tactic false [] } | [ "unsafe_romega" ] -> { romega_tactic true [] } END TACTIC EXTEND romega' +DEPRECATED { romega_depr } | [ "romega" "with" ne_ident_list(l) ] -> { romega_tactic false (List.map Names.Id.to_string l) } | [ "romega" "with" "*" ] -> { romega_tactic false ["nat";"positive";"N";"Z"] } diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index e603480656..930048400a 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -1049,7 +1049,7 @@ let resolution unsafe sigma env (reified_concl,reified_hyps) systems_list = Tactics.apply (Lazy.force coq_I) let total_reflexive_omega_tactic unsafe = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> Coqlib.check_required_library ["Coq";"romega";"ROmega"]; rst_omega_eq (); rst_omega_var (); diff --git a/plugins/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v index d9e32dbbf8..ce115f564f 100644 --- a/plugins/setoid_ring/Field_theory.v +++ b/plugins/setoid_ring/Field_theory.v @@ -19,6 +19,7 @@ Section MakeFieldPol. (* Field elements : R *) Variable R:Type. +Declare Scope R_scope. Bind Scope R_scope with R. Delimit Scope R_scope with ring. Local Open Scope R_scope. @@ -94,6 +95,7 @@ Let rdistr_r := ARdistr_r Rsth Reqe ARth. (* Coefficients : C *) Variable C: Type. +Declare Scope C_scope. Bind Scope C_scope with C. Delimit Scope C_scope with coef. @@ -139,6 +141,7 @@ Let rpow_pow := pow_th.(rpow_pow_N). (* Polynomial expressions : (PExpr C) *) +Declare Scope PE_scope. Bind Scope PE_scope with PExpr. Delimit Scope PE_scope with poly. diff --git a/plugins/setoid_ring/Ncring_initial.v b/plugins/setoid_ring/Ncring_initial.v index 523c7b02eb..1ca6227f25 100644 --- a/plugins/setoid_ring/Ncring_initial.v +++ b/plugins/setoid_ring/Ncring_initial.v @@ -79,8 +79,9 @@ Context {R:Type}`{Ring R}. | Z0 => 0 | Zneg p => -(gen_phiPOS p) end. - Local Notation "[ x ]" := (gen_phiZ x) : ZMORPHISM. - Local Open Scope ZMORPHISM. + Declare Scope ZMORPHISM. + Notation "[ x ]" := (gen_phiZ x) : ZMORPHISM. + Open Scope ZMORPHISM. Definition get_signZ z := match z with diff --git a/plugins/setoid_ring/Ring_base.v b/plugins/setoid_ring/Ring_base.v index a9b4d9d6f4..920b13ef49 100644 --- a/plugins/setoid_ring/Ring_base.v +++ b/plugins/setoid_ring/Ring_base.v @@ -12,7 +12,6 @@ ring tactic. Abstract rings need more theory, depending on ZArith_base. *) -Require Import Quote. Declare ML Module "newring_plugin". Require Export Ring_theory. Require Export Ring_tac. diff --git a/plugins/setoid_ring/Ring_tac.v b/plugins/setoid_ring/Ring_tac.v index e8efb362e2..26fef99bb2 100644 --- a/plugins/setoid_ring/Ring_tac.v +++ b/plugins/setoid_ring/Ring_tac.v @@ -15,7 +15,6 @@ Require Import Ring_polynom. Require Import BinList. Require Export ListTactics. Require Import InitialRing. -Require Import Quote. Declare ML Module "newring_plugin". diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index a736eec5e7..b05e1e85b7 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -99,7 +99,7 @@ let protect_tac_in map id = let rec closed_under sigma cset t = try let (gr, _) = Termops.global_of_constr sigma t in - Refset_env.mem gr cset + GlobRef.Set_env.mem gr cset with Not_found -> match EConstr.kind sigma t with | Cast(c,_,_) -> closed_under sigma cset c @@ -111,7 +111,7 @@ let closed_term args _ = match args with let t = Option.get (Value.to_constr t) in let l = List.map (fun c -> Value.cast (Genarg.topwit Stdarg.wit_ref) c) (Option.get (Value.to_list l)) in Proofview.tclEVARMAP >>= fun sigma -> - let cs = List.fold_right Refset_env.add l Refset_env.empty in + let cs = List.fold_right GlobRef.Set_env.add l GlobRef.Set_env.empty in if closed_under sigma cs t then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (mt()) | _ -> assert false diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 1f3c758e5c..f2f236f448 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -1088,7 +1088,7 @@ let () = CLexer.set_keyword_state frozen_lexer ;; (** Basic tactics *) -let rec fst_prod red tac = Proofview.Goal.nf_enter begin fun gl -> +let rec fst_prod red tac = Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in match EConstr.kind (Proofview.Goal.sigma gl) concl with | Prod (id,_,tgt) | LetIn(id,_,_,tgt) -> tac id diff --git a/plugins/ssr/ssreflect.v b/plugins/ssr/ssreflect.v index b4144aa45e..460bdc6d23 100644 --- a/plugins/ssr/ssreflect.v +++ b/plugins/ssr/ssreflect.v @@ -86,6 +86,7 @@ Export SsrSyntax. (* recognize the expansion of the boolean if; using the default printer *) (* avoids a spurrious trailing %GEN_IF. *) +Declare Scope general_if_scope. Delimit Scope general_if_scope with GEN_IF. Notation "'if' c 'then' v1 'else' v2" := @@ -103,6 +104,7 @@ Notation "'if' c 'as' x 'return' t 'then' v1 'else' v2" := (* Force boolean interpretation of simple if expressions. *) +Declare Scope boolean_if_scope. Delimit Scope boolean_if_scope with BOOL_IF. Notation "'if' c 'return' t 'then' v1 'else' v2" := @@ -125,6 +127,7 @@ Open Scope boolean_if_scope. (* Non-ssreflect libraries that do not respect the form syntax (e.g., the Coq *) (* Lists library) should be loaded before ssreflect so that their notations *) (* do not mask all ssreflect forms. *) +Declare Scope form_scope. Delimit Scope form_scope with FORM. Open Scope form_scope. diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index fbe3b000fb..602fcfcab5 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -293,7 +293,8 @@ let ssrelim ?(ind=ref None) ?(is_case=false) deps what ?elim eqid elim_intro_tac let c, cl, ucst = match_pat env p occ h cl in let gl = pf_merge_uc ucst gl in let c = EConstr.of_constr c in - let gl = try pf_unify_HO gl inf_t c with _ -> error gl c inf_t in + let gl = try pf_unify_HO gl inf_t c + with exn when CErrors.noncritical exn -> error gl c inf_t in cl, gl, post with | NoMatch | NoProgress -> @@ -302,7 +303,8 @@ let ssrelim ?(ind=ref None) ?(is_case=false) deps what ?elim eqid elim_intro_tac let e = EConstr.of_constr e in let n, e, _, _ucst = pf_abs_evars gl (fst p, e) in let e, _, _, gl = pf_saturate ~beta:true gl e n in - let gl = try pf_unify_HO gl inf_t e with _ -> error gl e inf_t in + let gl = try pf_unify_HO gl inf_t e + with exn when CErrors.noncritical exn -> error gl e inf_t in cl, gl, post in let rec match_all concl gl patterns = diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index 23cbf49c05..f23433f2f4 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -115,7 +115,8 @@ let newssrcongrtac arg ist gl = (* utils *) let fs gl t = Reductionops.nf_evar (project gl) t in let tclMATCH_GOAL (c, gl_c) proj t_ok t_fail gl = - match try Some (pf_unify_HO gl_c (pf_concl gl) c) with _ -> None with + match try Some (pf_unify_HO gl_c (pf_concl gl) c) + with exn when CErrors.noncritical exn -> None with | Some gl_c -> tclTHEN (Proofview.V82.of_tactic (convert_concl (fs gl_c c))) (t_ok (proj gl_c)) gl diff --git a/plugins/ssr/ssrfun.v b/plugins/ssr/ssrfun.v index b2d5143e36..99ff943e61 100644 --- a/plugins/ssr/ssrfun.v +++ b/plugins/ssr/ssrfun.v @@ -216,6 +216,7 @@ Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. +Declare Scope fun_scope. Delimit Scope fun_scope with FUN. Open Scope fun_scope. @@ -225,6 +226,7 @@ Notation "f ^~ y" := (fun x => f x y) Notation "@^~ x" := (fun f => f x) (at level 10, x at level 8, no associativity, format "@^~ x") : fun_scope. +Declare Scope pair_scope. Delimit Scope pair_scope with PAIR. Open Scope pair_scope. diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index e367cd32d6..f67cf20e49 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -25,9 +25,7 @@ module RelDecl = Context.Rel.Declaration (** 8. Forward chaining tactics (pose, set, have, suffice, wlog) *) (** Defined identifier *) - -let settac id c = Tactics.letin_tac None (Name id) c None -let posetac id cl = Proofview.V82.of_tactic (settac id cl Locusops.nowhere) +let posetac id cl = Proofview.V82.of_tactic (Tactics.pose_tac (Name id) cl) let ssrposetac (id, (_, t)) gl = let ist, t = diff --git a/plugins/ssr/ssrparser.ml4 b/plugins/ssr/ssrparser.ml4 index 8b9c94f2db..a7aae5bd31 100644 --- a/plugins/ssr/ssrparser.ml4 +++ b/plugins/ssr/ssrparser.ml4 @@ -1949,7 +1949,7 @@ ARGUMENT EXTEND ssrexactarg TYPED AS ssrapplyarg PRINTED BY pr_ssraarg END let vmexacttac pf = - Goal.nf_enter begin fun gl -> + Goal.enter begin fun gl -> exact_no_check (EConstr.mkCast (pf, _vmcast, Tacmach.New.pf_concl gl)) end diff --git a/plugins/ssr/ssrtacticals.ml b/plugins/ssr/ssrtacticals.ml index 83581f3416..f12f9fac0f 100644 --- a/plugins/ssr/ssrtacticals.ml +++ b/plugins/ssr/ssrtacticals.ml @@ -14,7 +14,6 @@ open Names open Constr open Termops open Tacmach -open Locusops open Ssrast open Ssrcommon @@ -82,8 +81,7 @@ let pf_clauseids gl gens clseq = let hidden_clseq = function InHyps | InHypsSeq | InAllHyps -> true | _ -> false -let settac id c = Tactics.letin_tac None (Name id) c None -let posetac id cl = Proofview.V82.of_tactic (settac id cl nowhere) +let posetac id cl = Proofview.V82.of_tactic (Tactics.pose_tac (Name id) cl) let hidetacs clseq idhide cl0 = if not (hidden_clseq clseq) then [] else diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index 30a998c6ce..20ea8b3667 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -291,7 +291,10 @@ let unif_EQ_args env sigma pa a = prof_unif_eq_args.profile (unif_EQ_args env sigma pa) a ;; -let unif_HO env ise p c = Evarconv.the_conv_x env p c ise +let unif_HO env ise p c = + try Evarconv.the_conv_x env p c ise + with Evarconv.UnableToUnify(ise, err) -> + raise Pretype_errors.(PretypeError(env,ise,CannotUnify(p,c,Some err))) let unif_HO_args env ise0 pa i ca = let n = Array.length pa in diff --git a/plugins/ssrmatching/ssrmatching.v b/plugins/ssrmatching/ssrmatching.v index 829ee05e11..9a53e1dd1a 100644 --- a/plugins/ssrmatching/ssrmatching.v +++ b/plugins/ssrmatching/ssrmatching.v @@ -11,9 +11,11 @@ Reserved Notation "( a 'as' b )" (at level 0). Reserved Notation "( a 'in' b 'in' c )" (at level 0). Reserved Notation "( a 'as' b 'in' c )" (at level 0). +Declare Scope ssrpatternscope. +Delimit Scope ssrpatternscope with pattern. + (* Notation to define shortcuts for the "X in t" part of a pattern. *) Notation "( X 'in' t )" := (_ : fun X => t) : ssrpatternscope. -Delimit Scope ssrpatternscope with pattern. (* Some shortcuts for recurrent "X in t" parts. *) Notation RHS := (X in _ = X)%pattern. diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml index 5e36fbeb81..53153198f9 100644 --- a/plugins/syntax/ascii_syntax.ml +++ b/plugins/syntax/ascii_syntax.ml @@ -94,7 +94,7 @@ let _ = at_declare_ml_module enable_prim_token_interpretation { pt_local = false; pt_scope = sc; - pt_uid = sc; + pt_interp_info = Uid sc; pt_required = (ascii_path,ascii_module); pt_refs = [static_glob_Ascii]; pt_in_match = true } diff --git a/plugins/syntax/g_numeral.ml4 b/plugins/syntax/g_numeral.ml4 index ec14df3baa..55f61a58f9 100644 --- a/plugins/syntax/g_numeral.ml4 +++ b/plugins/syntax/g_numeral.ml4 @@ -10,6 +10,7 @@ DECLARE PLUGIN "numeral_notation_plugin" +open Notation open Numeral open Pp open Names diff --git a/plugins/syntax/int31_syntax.ml b/plugins/syntax/int31_syntax.ml index d3ffe936a9..e34a401c2c 100644 --- a/plugins/syntax/int31_syntax.ml +++ b/plugins/syntax/int31_syntax.ml @@ -108,7 +108,7 @@ let _ = at_declare_ml_module enable_prim_token_interpretation { pt_local = false; pt_scope = int31_scope; - pt_uid = int31_scope; + pt_interp_info = Uid int31_scope; pt_required = (int31_path,int31_module); pt_refs = [int31_construct]; pt_in_match = true } diff --git a/plugins/syntax/numeral.ml b/plugins/syntax/numeral.ml index fee93593d0..10a0af0b8f 100644 --- a/plugins/syntax/numeral.ml +++ b/plugins/syntax/numeral.ml @@ -15,351 +15,18 @@ open Libnames open Globnames open Constrexpr open Constrexpr_ops -open Constr +open Notation (** * Numeral notation *) -(** Reduction - - The constr [c] below isn't necessarily well-typed, since we - built it via an [mkApp] of a conversion function on a term - that starts with the right constructor but might be partially - applied. - - At least [c] is known to be evar-free, since it comes from - our own ad-hoc [constr_of_glob] or from conversions such - as [coqint_of_rawnum]. -*) - -let eval_constr env sigma (c : Constr.t) = - let c = EConstr.of_constr c in - let sigma,t = Typing.type_of env sigma c in - let c' = Vnorm.cbv_vm env sigma c t in - EConstr.Unsafe.to_constr c' - -(* For testing with "compute" instead of "vm_compute" : -let eval_constr env sigma (c : Constr.t) = - let c = EConstr.of_constr c in - let c' = Tacred.compute env sigma c in - EConstr.Unsafe.to_constr c' -*) - -let eval_constr_app env sigma c1 c2 = - eval_constr env sigma (mkApp (c1,[| c2 |])) - -exception NotANumber - -let warn_large_num = - CWarnings.create ~name:"large-number" ~category:"numbers" - (fun ty -> - strbrk "Stack overflow or segmentation fault happens when " ++ - strbrk "working with large numbers in " ++ pr_qualid ty ++ - strbrk " (threshold may vary depending" ++ - strbrk " on your system limits and on the command executed).") - -let warn_abstract_large_num = - CWarnings.create ~name:"abstract-large-number" ~category:"numbers" - (fun (ty,f) -> - strbrk "To avoid stack overflow, large numbers in " ++ - pr_qualid ty ++ strbrk " are interpreted as applications of " ++ - Printer.pr_global_env (Termops.vars_of_env (Global.env ())) f ++ strbrk ".") - let warn_abstract_large_num_no_op = CWarnings.create ~name:"abstract-large-number-no-op" ~category:"numbers" (fun f -> strbrk "The 'abstract after' directive has no effect when " ++ strbrk "the parsing function (" ++ - Printer.pr_global_env (Termops.vars_of_env (Global.env ())) f ++ strbrk ") targets an " ++ + Nametab.pr_global_env (Termops.vars_of_env (Global.env ())) f ++ strbrk ") targets an " ++ strbrk "option type.") -(** Comparing two raw numbers (base 10, big-endian, non-negative). - A bit nasty, but not critical: only used to decide when a - number is considered as large (see warnings above). *) - -exception Comp of int - -let rec rawnum_compare s s' = - let l = String.length s and l' = String.length s' in - if l < l' then - rawnum_compare s' s - else - let d = l-l' in - try - for i = 0 to d-1 do if s.[i] != '0' then raise (Comp 1) done; - for i = d to l-1 do - let c = Pervasives.compare s.[i] s'.[i-d] in - if c != 0 then raise (Comp c) - done; - 0 - with Comp c -> c - -(***********************************************************************) - -(** ** Conversion between Coq [Decimal.int] and internal raw string *) - -type int_ty = - { uint : Names.inductive; - int : Names.inductive } - -(** Decimal.Nil has index 1, then Decimal.D0 has index 2 .. Decimal.D9 is 11 *) - -let digit_of_char c = - assert ('0' <= c && c <= '9'); - Char.code c - Char.code '0' + 2 - -let char_of_digit n = - assert (2<=n && n<=11); - Char.chr (n-2 + Char.code '0') - -let coquint_of_rawnum uint str = - let nil = mkConstruct (uint,1) in - let rec do_chars s i acc = - if i < 0 then acc - else - let dg = mkConstruct (uint, digit_of_char s.[i]) in - do_chars s (i-1) (mkApp(dg,[|acc|])) - in - do_chars str (String.length str - 1) nil - -let coqint_of_rawnum inds (str,sign) = - let uint = coquint_of_rawnum inds.uint str in - mkApp (mkConstruct (inds.int, if sign then 1 else 2), [|uint|]) - -let rawnum_of_coquint c = - let rec of_uint_loop c buf = - match Constr.kind c with - | Construct ((_,1), _) (* Nil *) -> () - | App (c, [|a|]) -> - (match Constr.kind c with - | Construct ((_,n), _) (* D0 to D9 *) -> - let () = Buffer.add_char buf (char_of_digit n) in - of_uint_loop a buf - | _ -> raise NotANumber) - | _ -> raise NotANumber - in - let buf = Buffer.create 64 in - let () = of_uint_loop c buf in - if Int.equal (Buffer.length buf) 0 then - (* To avoid ambiguities between Nil and (D0 Nil), we choose - to not display Nil alone as "0" *) - raise NotANumber - else Buffer.contents buf - -let rawnum_of_coqint c = - match Constr.kind c with - | App (c,[|c'|]) -> - (match Constr.kind c with - | Construct ((_,1), _) (* Pos *) -> (rawnum_of_coquint c', true) - | Construct ((_,2), _) (* Neg *) -> (rawnum_of_coquint c', false) - | _ -> raise NotANumber) - | _ -> raise NotANumber - - -(***********************************************************************) - -(** ** Conversion between Coq [Z] and internal bigint *) - -type z_pos_ty = - { z_ty : Names.inductive; - pos_ty : Names.inductive } - -(** First, [positive] from/to bigint *) - -let rec pos_of_bigint posty n = - match Bigint.div2_with_rest n with - | (q, false) -> - let c = mkConstruct (posty, 2) in (* xO *) - mkApp (c, [| pos_of_bigint posty q |]) - | (q, true) when not (Bigint.equal q Bigint.zero) -> - let c = mkConstruct (posty, 1) in (* xI *) - mkApp (c, [| pos_of_bigint posty q |]) - | (q, true) -> - mkConstruct (posty, 3) (* xH *) - -let rec bigint_of_pos c = match Constr.kind c with - | Construct ((_, 3), _) -> (* xH *) Bigint.one - | App (c, [| d |]) -> - begin match Constr.kind c with - | Construct ((_, n), _) -> - begin match n with - | 1 -> (* xI *) Bigint.add_1 (Bigint.mult_2 (bigint_of_pos d)) - | 2 -> (* xO *) Bigint.mult_2 (bigint_of_pos d) - | n -> assert false (* no other constructor of type positive *) - end - | x -> raise NotANumber - end - | x -> raise NotANumber - -(** Now, [Z] from/to bigint *) - -let z_of_bigint { z_ty; pos_ty } n = - if Bigint.equal n Bigint.zero then - mkConstruct (z_ty, 1) (* Z0 *) - else - let (s, n) = - if Bigint.is_pos_or_zero n then (2, n) (* Zpos *) - else (3, Bigint.neg n) (* Zneg *) - in - let c = mkConstruct (z_ty, s) in - mkApp (c, [| pos_of_bigint pos_ty n |]) - -let bigint_of_z z = match Constr.kind z with - | Construct ((_, 1), _) -> (* Z0 *) Bigint.zero - | App (c, [| d |]) -> - begin match Constr.kind c with - | Construct ((_, n), _) -> - begin match n with - | 2 -> (* Zpos *) bigint_of_pos d - | 3 -> (* Zneg *) Bigint.neg (bigint_of_pos d) - | n -> assert false (* no other constructor of type Z *) - end - | _ -> raise NotANumber - end - | _ -> raise NotANumber - -(** The uninterp function below work at the level of [glob_constr] - which is too low for us here. So here's a crude conversion back - to [constr] for the subset that concerns us. *) - -let rec constr_of_glob env sigma g = match DAst.get g with - | Glob_term.GRef (ConstructRef c, _) -> - let sigma,c = Evd.fresh_constructor_instance env sigma c in - sigma,mkConstructU c - | Glob_term.GApp (gc, gcl) -> - let sigma,c = constr_of_glob env sigma gc in - let sigma,cl = List.fold_left_map (constr_of_glob env) sigma gcl in - sigma,mkApp (c, Array.of_list cl) - | _ -> - raise NotANumber - -let rec glob_of_constr ?loc c = match Constr.kind c with - | App (c, ca) -> - let c = glob_of_constr ?loc c in - let cel = List.map (glob_of_constr ?loc) (Array.to_list ca) in - DAst.make ?loc (Glob_term.GApp (c, cel)) - | Construct (c, _) -> DAst.make ?loc (Glob_term.GRef (ConstructRef c, None)) - | Const (c, _) -> DAst.make ?loc (Glob_term.GRef (ConstRef c, None)) - | Ind (ind, _) -> DAst.make ?loc (Glob_term.GRef (IndRef ind, None)) - | Var id -> DAst.make ?loc (Glob_term.GRef (VarRef id, None)) - | _ -> let (sigma, env) = Pfedit.get_current_context () in - CErrors.user_err ?loc - (strbrk "Unexpected term " ++ - Printer.pr_constr_env env sigma c ++ - strbrk " while parsing a numeral notation.") - -let no_such_number ?loc ty = - CErrors.user_err ?loc - (str "Cannot interpret this number as a value of type " ++ - pr_qualid ty) - -let interp_option ty ?loc c = - match Constr.kind c with - | App (_Some, [| _; c |]) -> glob_of_constr ?loc c - | App (_None, [| _ |]) -> no_such_number ?loc ty - | x -> let (sigma, env) = Pfedit.get_current_context () in - CErrors.user_err ?loc - (strbrk "Unexpected non-option term " ++ - Printer.pr_constr_env env sigma c ++ - strbrk " while parsing a numeral notation.") - -let uninterp_option c = - match Constr.kind c with - | App (_Some, [| _; x |]) -> x - | _ -> raise NotANumber - -let big2raw n = - if Bigint.is_pos_or_zero n then (Bigint.to_string n, true) - else (Bigint.to_string (Bigint.neg n), false) - -let raw2big (n,s) = - if s then Bigint.of_string n else Bigint.neg (Bigint.of_string n) - -type target_kind = - | Int of int_ty (* Coq.Init.Decimal.int + uint *) - | UInt of Names.inductive (* Coq.Init.Decimal.uint *) - | Z of z_pos_ty (* Coq.Numbers.BinNums.Z and positive *) - -type option_kind = Option | Direct -type conversion_kind = target_kind * option_kind - -type numnot_option = - | Nop - | Warning of raw_natural_number - | Abstract of raw_natural_number - -type numeral_notation_obj = - { to_kind : conversion_kind; - to_ty : GlobRef.t; - of_kind : conversion_kind; - of_ty : GlobRef.t; - num_ty : Libnames.qualid; (* for warnings / error messages *) - warning : numnot_option } - -let interp o ?loc n = - begin match o.warning with - | Warning threshold when snd n && rawnum_compare (fst n) threshold >= 0 -> - warn_large_num o.num_ty - | _ -> () - end; - let c = match fst o.to_kind with - | Int int_ty -> coqint_of_rawnum int_ty n - | UInt uint_ty when snd n -> coquint_of_rawnum uint_ty (fst n) - | UInt _ (* n <= 0 *) -> no_such_number ?loc o.num_ty - | Z z_pos_ty -> z_of_bigint z_pos_ty (raw2big n) - in - let env = Global.env () in - let sigma = Evd.from_env env in - let sigma,to_ty = Evd.fresh_global env sigma o.to_ty in - let to_ty = EConstr.Unsafe.to_constr to_ty in - match o.warning, snd o.to_kind with - | Abstract threshold, Direct when rawnum_compare (fst n) threshold >= 0 -> - warn_abstract_large_num (o.num_ty,o.to_ty); - glob_of_constr ?loc (mkApp (to_ty,[|c|])) - | _ -> - let res = eval_constr_app env sigma to_ty c in - match snd o.to_kind with - | Direct -> glob_of_constr ?loc res - | Option -> interp_option o.num_ty ?loc res - -let uninterp o (Glob_term.AnyGlobConstr n) = - let env = Global.env () in - let sigma = Evd.from_env env in - let sigma,of_ty = Evd.fresh_global env sigma o.of_ty in - let of_ty = EConstr.Unsafe.to_constr of_ty in - try - let sigma,n = constr_of_glob env sigma n in - let c = eval_constr_app env sigma of_ty n in - let c = if snd o.of_kind == Direct then c else uninterp_option c in - match fst o.of_kind with - | Int _ -> Some (rawnum_of_coqint c) - | UInt _ -> Some (rawnum_of_coquint c, true) - | Z _ -> Some (big2raw (bigint_of_z c)) - with - | Type_errors.TypeError _ | Pretype_errors.PretypeError _ -> None (* cf. eval_constr_app *) - | NotANumber -> None (* all other functions except big2raw *) - -(* Here we only register the interp and uninterp functions - for a particular Numeral Notation (determined by a unique - string). The actual activation of the notation will be done - later (cf. Notation.enable_prim_token_interpretation). - This registration of interp/uninterp must be added in the - libstack, otherwise this won't work through a Require. *) - -let load_numeral_notation _ (_, (uid,opts)) = - Notation.register_rawnumeral_interpretation - ~allow_overwrite:true uid (interp opts, uninterp opts) - -let cache_numeral_notation x = load_numeral_notation 1 x - -(* TODO: substitution ? - TODO: uid pas stable par substitution dans opts - *) - -let inNumeralNotation : string * numeral_notation_obj -> Libobject.obj = - Libobject.declare_object { - (Libobject.default_object "NUMERAL NOTATION") with - Libobject.cache_function = cache_numeral_notation; - Libobject.load_function = load_numeral_notation } - let get_constructors ind = let mib,oib = Global.lookup_inductive ind in let mc = oib.Declarations.mind_consnames in @@ -464,15 +131,12 @@ let vernac_numeral_notation local ty f g scope opts = (match opts, to_kind with | Abstract _, (_, Option) -> warn_abstract_large_num_no_op o.to_ty | _ -> ()); - (* TODO: un hash suffit-il ? *) - let uid = Marshal.to_string o [] in - let i = Notation.( + let i = { pt_local = local; pt_scope = scope; - pt_uid = uid; + pt_interp_info = NumeralNotation o; pt_required = Nametab.path_of_global (IndRef tyc),[]; pt_refs = constructors; - pt_in_match = true }) + pt_in_match = true } in - Lib.add_anonymous_leaf (inNumeralNotation (uid,o)); - Notation.enable_prim_token_interpretation i + enable_prim_token_interpretation i diff --git a/plugins/syntax/numeral.mli b/plugins/syntax/numeral.mli index 83ede6f48f..f96b8321f8 100644 --- a/plugins/syntax/numeral.mli +++ b/plugins/syntax/numeral.mli @@ -9,14 +9,9 @@ (************************************************************************) open Libnames -open Constrexpr open Vernacexpr +open Notation (** * Numeral notation *) -type numnot_option = - | Nop - | Warning of raw_natural_number - | Abstract of raw_natural_number - val vernac_numeral_notation : locality_flag -> qualid -> qualid -> qualid -> Notation_term.scope_name -> numnot_option -> unit diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 04946c158b..49497aef54 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -143,7 +143,7 @@ let _ = at_declare_ml_module enable_prim_token_interpretation { pt_local = false; pt_scope = r_scope; - pt_uid = r_scope; + pt_interp_info = Uid r_scope; pt_required = (r_path,["Coq";"Reals";"Rdefinitions"]); pt_refs = [glob_IZR]; pt_in_match = false } diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml index 640bcfde91..7478c1e978 100644 --- a/plugins/syntax/string_syntax.ml +++ b/plugins/syntax/string_syntax.ml @@ -75,7 +75,7 @@ let _ = at_declare_ml_module enable_prim_token_interpretation { pt_local = false; pt_scope = sc; - pt_uid = sc; + pt_interp_info = Uid sc; pt_required = (string_path,["Coq";"Strings";"String"]); pt_refs = [static_glob_String; static_glob_EmptyString]; pt_in_match = true } diff --git a/pretyping/arguments_renaming.ml b/pretyping/arguments_renaming.ml index 9d4badc60a..b8958ca944 100644 --- a/pretyping/arguments_renaming.ml +++ b/pretyping/arguments_renaming.ml @@ -21,7 +21,7 @@ module NamedDecl = Context.Named.Declaration (*i*) let name_table = - Summary.ref (Refmap.empty : Name.t list Refmap.t) + Summary.ref (GlobRef.Map.empty : Name.t list GlobRef.Map.t) ~name:"rename-arguments" type req = @@ -29,7 +29,7 @@ type req = | ReqGlobal of GlobRef.t * Name.t list let load_rename_args _ (_, (_, (r, names))) = - name_table := Refmap.add r names !name_table + name_table := GlobRef.Map.add r names !name_table let cache_rename_args o = load_rename_args 1 o @@ -68,7 +68,7 @@ let rename_arguments local r names = let req = if local then ReqLocal else ReqGlobal (r, names) in Lib.add_anonymous_leaf (inRenameArgs (req, (r, names))) -let arguments_names r = Refmap.find r !name_table +let arguments_names r = GlobRef.Map.find r !name_table let rec rename_prod c = function | [] -> c diff --git a/pretyping/cases.ml b/pretyping/cases.ml index ad33297f0a..81e8bd06f5 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -35,7 +35,7 @@ open Evarsolve open Evarconv open Evd open Context.Rel.Declaration -open Ltac_pretype +open GlobEnv module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration @@ -114,8 +114,10 @@ let rec relocate_index sigma n1 n2 k t = (**********************************************************************) (* Structures used in compiling pattern-matching *) +let (!!) env = GlobEnv.env env + type 'a rhs = - { rhs_env : env; + { rhs_env : GlobEnv.t; rhs_vars : Id.Set.t; avoid_ids : Id.Set.t; it : 'a option} @@ -247,8 +249,7 @@ let push_history_pattern n pci cont = *) type 'a pattern_matching_problem = - { env : env; - lvar : Ltac_pretype.ltac_var_map; + { env : GlobEnv.t; evdref : evar_map ref; pred : constr; tomatch : tomatch_stack; @@ -256,7 +257,7 @@ type 'a pattern_matching_problem = mat : 'a matrix; caseloc : Loc.t option; casestyle : case_style; - typing_function: type_constraint -> env -> evar_map ref -> 'a option -> unsafe_judgment } + typing_function: type_constraint -> GlobEnv.t -> evar_map ref -> 'a option -> unsafe_judgment } (*--------------------------------------------------------------------------* * A few functions to infer the inductive type from the patterns instead of * @@ -331,6 +332,10 @@ let binding_vars_of_inductive sigma = function | NotInd _ -> [] | IsInd (_,IndType(_,realargs),_) -> List.filter (isRel sigma) realargs +let set_tomatch_realnames names = function + | NotInd _ as t -> t + | IsInd (typ,ind,_) -> IsInd (typ,ind,names) + let extract_inductive_data env sigma decl = match decl with | LocalAssum (_,t) -> @@ -357,58 +362,58 @@ let find_tomatch_tycon evdref env loc = function | None -> empty_tycon,None -let make_return_predicate_ltac_lvar sigma na tm c lvar = +let make_return_predicate_ltac_lvar env sigma na tm c = + (* If we have an [x as x return ...] clause and [x] expands to [c], + we have to update the status of [x] in the substitution: + - if [c] is a variable [id'], then [x] should now become [id'] + - otherwise, [x] should be hidden *) match na, DAst.get tm with | Name id, (GVar id' | GRef (Globnames.VarRef id', _)) when Id.equal id id' -> - if Id.Map.mem id lvar.ltac_genargs then - let ltac_genargs = Id.Map.remove id lvar.ltac_genargs in - let ltac_idents = match kind sigma c with - | Var id' -> Id.Map.add id id' lvar.ltac_idents - | _ -> lvar.ltac_idents in - { lvar with ltac_genargs; ltac_idents } - else lvar - | _ -> lvar - -let ltac_interp_realnames lvar = function - | t, IsInd (ty,ind,realnal) -> t, IsInd (ty,ind,List.map (ltac_interp_name lvar) realnal) - | _ as x -> x + let expansion = match kind sigma c with + | Var id' -> Name id' + | _ -> Anonymous in + GlobEnv.hide_variable env expansion id + | _ -> env let is_patvar pat = match DAst.get pat with | PatVar _ -> true | _ -> false -let coerce_row typing_fun evdref env lvar pats (tomatch,(na,indopt)) = +let coerce_row typing_fun evdref env pats (tomatch,(na,indopt)) = let loc = loc_of_glob_constr tomatch in - let tycon,realnames = find_tomatch_tycon evdref env loc indopt in - let j = typing_fun tycon env evdref !lvar tomatch in - let j = evd_comb1 (Coercion.inh_coerce_to_base ?loc:(loc_of_glob_constr tomatch) env) evdref j in + let tycon,realnames = find_tomatch_tycon evdref !!env loc indopt in + let j = typing_fun tycon env evdref tomatch in + let j = evd_comb1 (Coercion.inh_coerce_to_base ?loc:(loc_of_glob_constr tomatch) !!env) evdref j in let typ = nf_evar !evdref j.uj_type in - lvar := make_return_predicate_ltac_lvar !evdref na tomatch j.uj_val !lvar; + let env = make_return_predicate_ltac_lvar env !evdref na tomatch j.uj_val in let t = if realnames = None && pats <> [] && List.for_all is_patvar pats then NotInd (None,typ) else - try try_find_ind env !evdref typ realnames + try try_find_ind !!env !evdref typ realnames with Not_found -> - unify_tomatch_with_patterns evdref env loc typ pats realnames in - (j.uj_val,t) + unify_tomatch_with_patterns evdref !!env loc typ pats realnames in + (env,(j.uj_val,t)) -let coerce_to_indtype typing_fun evdref env lvar matx tomatchl = +let coerce_to_indtype typing_fun evdref env matx tomatchl = let pats = List.map (fun r -> r.patterns) matx in let matx' = match matrix_transpose pats with | [] -> List.map (fun _ -> []) tomatchl (* no patterns at all *) | m -> m in - let lvar = ref lvar in - let tms = List.map2 (coerce_row typing_fun evdref env lvar) matx' tomatchl in - let tms = List.map (ltac_interp_realnames !lvar) tms in - !lvar,tms + let env,tms = List.fold_left2_map (fun env -> coerce_row typing_fun evdref env) env matx' tomatchl in + env,tms (************************************************************************) (* Utils *) let mkExistential env ?(src=(Loc.tag Evar_kinds.InternalHole)) evdref = - let (e, u) = evd_comb1 (new_type_evar env ~src:src) evdref univ_flexible_alg in + let (e, u) = evd_comb1 (new_type_evar env ~src:src) evdref univ_flexible_alg in e +let evd_comb2 f evdref x y = + let (evd',y) = f !evdref x y in + evdref := evd'; + y + let adjust_tomatch_to_pattern pb ((current,typ),deps,dep) = (* Ideally, we could find a common inductive type to which both the term to match and the patterns coerce *) @@ -418,7 +423,7 @@ let adjust_tomatch_to_pattern pb ((current,typ),deps,dep) = let typ,names = match typ with IsInd(t,_,names) -> t,Some names | NotInd(_,t) -> t,None in let tmtyp = - try try_find_ind pb.env !(pb.evdref) typ names + try try_find_ind !!(pb.env) !(pb.evdref) typ names with Not_found -> NotInd (None,typ) in match tmtyp with | NotInd (None,typ) -> @@ -426,17 +431,17 @@ let adjust_tomatch_to_pattern pb ((current,typ),deps,dep) = (match find_row_ind tm1 with | None -> (current,tmtyp) | Some (_,(ind,_)) -> - let indt = inductive_template pb.evdref pb.env None ind in + let indt = inductive_template pb.evdref !!(pb.env) None ind in let current = if List.is_empty deps && isEvar !(pb.evdref) typ then (* Don't insert coercions if dependent; only solve evars *) - let () = Option.iter ((:=) pb.evdref) (cumul pb.env !(pb.evdref) indt typ) in + let () = Option.iter ((:=) pb.evdref) (cumul !!(pb.env) !(pb.evdref) indt typ) in current else - (evd_comb2 (Coercion.inh_conv_coerce_to true pb.env) + (evd_comb2 (Coercion.inh_conv_coerce_to true !!(pb.env)) pb.evdref (make_judge current typ) indt).uj_val in let sigma = !(pb.evdref) in - (current,try_find_ind pb.env sigma indt names)) + (current,try_find_ind !!(pb.env) sigma indt names)) | _ -> (current,tmtyp) let type_of_tomatch = function @@ -466,10 +471,10 @@ let remove_current_pattern eqn = alias_stack = alias_of_pat pat :: eqn.alias_stack } | [] -> anomaly (Pp.str "Empty list of patterns.") -let push_current_pattern (cur,ty) eqn = +let push_current_pattern sigma (cur,ty) eqn = match eqn.patterns with | pat::pats -> - let rhs_env = push_rel (LocalDef (alias_of_pat pat,cur,ty)) eqn.rhs.rhs_env in + let _,rhs_env = push_rel sigma (LocalDef (alias_of_pat pat,cur,ty)) eqn.rhs.rhs_env in { eqn with rhs = { eqn.rhs with rhs_env = rhs_env }; patterns = pats } @@ -739,7 +744,7 @@ let merge_name get_name obj = function let merge_names get_name = List.map2 (merge_name get_name) -let get_names env sigma sign eqns = +let get_names avoid env sigma sign eqns = let names1 = List.make (Context.Rel.length sign) Anonymous in (* If any, we prefer names used in pats, from top to bottom *) let names2,aliasname = @@ -752,7 +757,7 @@ let get_names env sigma sign eqns = avoiding conflicts with user ids *) let allvars = List.fold_left (fun l (_,_,eqn) -> Id.Set.union l eqn.rhs.avoid_ids) - Id.Set.empty eqns in + avoid eqns in let names3,_ = List.fold_left2 (fun (l,avoid) d na -> @@ -774,7 +779,7 @@ let get_names env sigma sign eqns = let recover_initial_subpattern_names = List.map2 RelDecl.set_name -let recover_and_adjust_alias_names names sign = +let recover_and_adjust_alias_names (_,avoid) names sign = let rec aux = function | [],[] -> [] @@ -786,31 +791,31 @@ let recover_and_adjust_alias_names names sign = in List.split (aux (names,sign)) -let push_rels_eqn sign eqn = +let push_rels_eqn sigma sign eqn = {eqn with - rhs = {eqn.rhs with rhs_env = push_rel_context sign eqn.rhs.rhs_env} } + rhs = {eqn.rhs with rhs_env = snd (push_rel_context sigma sign eqn.rhs.rhs_env) } } -let push_rels_eqn_with_names sign eqn = +let push_rels_eqn_with_names sigma sign eqn = let subpats = List.rev (List.firstn (List.length sign) eqn.patterns) in let subpatnames = List.map alias_of_pat subpats in let sign = recover_initial_subpattern_names subpatnames sign in - push_rels_eqn sign eqn + push_rels_eqn sigma sign eqn -let push_generalized_decl_eqn env n decl eqn = +let push_generalized_decl_eqn env sigma n decl eqn = match RelDecl.get_name decl with | Anonymous -> - push_rels_eqn [decl] eqn + push_rels_eqn sigma [decl] eqn | Name _ -> - push_rels_eqn [RelDecl.set_name (RelDecl.get_name (Environ.lookup_rel n eqn.rhs.rhs_env)) decl] eqn + push_rels_eqn sigma [RelDecl.set_name (RelDecl.get_name (Environ.lookup_rel n !!(eqn.rhs.rhs_env))) decl] eqn let drop_alias_eqn eqn = { eqn with alias_stack = List.tl eqn.alias_stack } -let push_alias_eqn alias eqn = +let push_alias_eqn sigma alias eqn = let aliasname = List.hd eqn.alias_stack in let eqn = drop_alias_eqn eqn in let alias = RelDecl.set_name aliasname alias in - push_rels_eqn [alias] eqn + push_rels_eqn sigma [alias] eqn (**********************************************************************) (* Functions to deal with elimination predicate *) @@ -958,7 +963,7 @@ let rec extract_predicate ccl = function ccl let abstract_predicate env sigma indf cur realargs (names,na) tms ccl = - let sign = make_arity_signature env sigma true indf in + let sign = make_arity_signature !!env sigma true indf in (* n is the number of real args + 1 (+ possible let-ins in sign) *) let n = List.length sign in (* Before abstracting we generalize over cur and on those realargs *) @@ -979,7 +984,7 @@ let abstract_predicate env sigma indf cur realargs (names,na) tms ccl = let pred = extract_predicate ccl tms in (* Build the predicate properly speaking *) let sign = List.map2 set_name (na::names) sign in - it_mkLambda_or_LetIn_name env sigma pred sign + it_mkLambda_or_LetIn_name !!env sigma pred sign (* [expand_arg] is used by [specialize_predicate] if Yk denotes [Xk;xk] or [Xk], @@ -1208,7 +1213,7 @@ let first_clause_irrefutable env = function let group_equations pb ind current cstrs mat = let mat = - if first_clause_irrefutable pb.env mat then [List.hd mat] else mat in + if first_clause_irrefutable !!(pb.env) mat then [List.hd mat] else mat in let brs = Array.make (Array.length cstrs) [] in let only_default = ref None in let _ = @@ -1216,7 +1221,7 @@ let group_equations pb ind current cstrs mat = (fun eqn () -> let rest = remove_current_pattern eqn in let pat = current_pattern eqn in - match DAst.get (check_and_adjust_constructor pb.env ind cstrs pat) with + match DAst.get (check_and_adjust_constructor !!(pb.env) ind cstrs pat) with | PatVar name -> (* This is a default clause that we expand *) for i=1 to Array.length cstrs do @@ -1238,7 +1243,7 @@ let rec generalize_problem names pb = function | [] -> pb, [] | i::l -> let pb',deps = generalize_problem names pb l in - let d = map_constr (lift i) (lookup_rel i pb.env) in + let d = map_constr (lift i) (lookup_rel i !!(pb.env)) in begin match d with | LocalDef (Anonymous,_,_) -> pb', deps | _ -> @@ -1271,7 +1276,7 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn (* that had matched constructor C *) let cs_args = const_info.cs_args in let cs_args = List.map (fun d -> map_rel_decl EConstr.of_constr d) cs_args in - let names,aliasname = get_names pb.env !(pb.evdref) cs_args eqns in + let names,aliasname = get_names (GlobEnv.vars_of_env pb.env) !!(pb.env) !(pb.evdref) cs_args eqns in let typs = List.map2 RelDecl.set_name names cs_args in @@ -1279,7 +1284,7 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn (* This is a bit too strong I think, in the sense that what we would *) (* really like is to have beta-iota reduction only at the positions where *) (* parameters are substituted *) - let typs = List.map (map_type (nf_betaiota pb.env !(pb.evdref))) typs in + let typs = List.map (map_type (nf_betaiota !!(pb.env) !(pb.evdref))) typs in (* We build the matrix obtained by expanding the matching on *) (* "C x1..xn as x" followed by a residual matching on eqn into *) @@ -1291,11 +1296,11 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn let typs' = List.map_i (fun i d -> (mkRel i, map_constr (lift i) d)) 1 typs in - let extenv = push_rel_context typs pb.env in + let typs,extenv = push_rel_context !(pb.evdref) typs pb.env in let typs' = List.map (fun (c,d) -> - (c,extract_inductive_data extenv !(pb.evdref) d,d)) typs' in + (c,extract_inductive_data !!extenv !(pb.evdref) d,d)) typs' in (* We compute over which of x(i+1)..xn and x matching on xi will need a *) (* generalization *) @@ -1360,7 +1365,7 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn let submat = adjust_impossible_cases pb pred tomatch submat in let () = match submat with | [] -> - raise_pattern_matching_error (pb.env, Evd.empty, NonExhaustive (complete_history history)) + raise_pattern_matching_error (!!(pb.env), Evd.empty, NonExhaustive (complete_history history)) | _ -> () in @@ -1370,7 +1375,7 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn tomatch = tomatch; pred = pred; history = history; - mat = List.map (push_rels_eqn_with_names typs) submat } + mat = List.map (push_rels_eqn_with_names !(pb.evdref) typs) submat } (********************************************************************** INVARIANT: @@ -1400,13 +1405,13 @@ and match_current pb (initial,tomatch) = let ((current,typ),deps,dep) = tomatch in match typ with | NotInd (_,typ) -> - check_all_variables pb.env !(pb.evdref) typ pb.mat; + check_all_variables !!(pb.env) !(pb.evdref) typ pb.mat; compile_all_variables initial tomatch pb | IsInd (_,(IndType(indf,realargs) as indt),names) -> let mind,_ = dest_ind_family indf in - let mind = Tacred.check_privacy pb.env mind in - let cstrs = get_constructors pb.env indf in - let arsign, _ = get_arity pb.env indf in + let mind = Tacred.check_privacy !!(pb.env) mind in + let cstrs = get_constructors !!(pb.env) indf in + let arsign, _ = get_arity !!(pb.env) indf in let eqns,onlydflt = group_equations pb (fst mind) current cstrs pb.mat in let no_cstr = Int.equal (Array.length cstrs) 0 in if (not no_cstr || not (List.is_empty pb.mat)) && onlydflt then @@ -1423,18 +1428,17 @@ and match_current pb (initial,tomatch) = postprocess_dependencies !(pb.evdref) depstocheck brvals pb.tomatch pb.pred deps cstrs in let brvals = Array.map (fun (sign,body) -> - let sign = List.map (map_name (ltac_interp_name pb.lvar)) sign in it_mkLambda_or_LetIn body sign) brvals in let (pred,typ) = - find_predicate pb.caseloc pb.env pb.evdref + find_predicate pb.caseloc pb.env pb.evdref pred current indt (names,dep) tomatch in - let ci = make_case_info pb.env (fst mind) pb.casestyle in - let pred = nf_betaiota pb.env !(pb.evdref) pred in + let ci = make_case_info !!(pb.env) (fst mind) pb.casestyle in + let pred = nf_betaiota !!(pb.env) !(pb.evdref) pred in let case = - make_case_or_project pb.env !(pb.evdref) indf ci pred current brvals + make_case_or_project !!(pb.env) !(pb.evdref) indf ci pred current brvals in - let _ = Evarutil.evd_comb1 (Typing.type_of pb.env) pb.evdref pred in - Typing.check_allowed_sort pb.env !(pb.evdref) mind current pred; + let _ = Evarutil.evd_comb1 (Typing.type_of !!(pb.env)) pb.evdref pred in + Typing.check_allowed_sort !!(pb.env) !(pb.evdref) mind current pred; { uj_val = applist (case, inst); uj_type = prod_applist !(pb.evdref) typ inst } @@ -1444,14 +1448,15 @@ and match_current pb (initial,tomatch) = and shift_problem ((current,t),_,na) pb = let ty = type_of_tomatch t in let tomatch = lift_tomatch_stack 1 pb.tomatch in - let pred = specialize_predicate_var (current,t,na) pb.env pb.tomatch pb.pred in + let pred = specialize_predicate_var (current,t,na) !!(pb.env) pb.tomatch pb.pred in + let env = Name.fold_left (fun env id -> hide_variable env Anonymous id) pb.env na in let pb = { pb with - env = push_rel (LocalDef (na,current,ty)) pb.env; + env = snd (push_rel !(pb.evdref) (LocalDef (na,current,ty)) env); tomatch = tomatch; pred = lift_predicate 1 pred tomatch; history = pop_history pb.history; - mat = List.map (push_current_pattern (current,ty)) pb.mat } in + mat = List.map (push_current_pattern !(pb.evdref) (current,ty)) pb.mat } in let j = compile pb in { uj_val = subst1 current j.uj_val; uj_type = subst1 current j.uj_type } @@ -1461,7 +1466,7 @@ and shift_problem ((current,t),_,na) pb = are already introduced in the context, we avoid creating aliases to themselves by treating this case specially. *) and pop_problem ((current,t),_,na) pb = - let pred = specialize_predicate_var (current,t,na) pb.env pb.tomatch pb.pred in + let pred = specialize_predicate_var (current,t,na) !!(pb.env) pb.tomatch pb.pred in let pb = { pb with pred = pred; @@ -1483,9 +1488,9 @@ and compile_branch initial current realargs names deps pb arsign eqns cstr = and compile_generalization pb i d rest = let pb = { pb with - env = push_rel d pb.env; + env = snd (push_rel !(pb.evdref) d pb.env); tomatch = rest; - mat = List.map (push_generalized_decl_eqn pb.env i d) pb.mat } in + mat = List.map (push_generalized_decl_eqn pb.env !(pb.evdref) i d) pb.mat } in let j = compile pb in { uj_val = mkLambda_or_LetIn d j.uj_val; uj_type = mkProd_wo_LetIn d j.uj_type } @@ -1498,11 +1503,11 @@ and compile_alias initial pb (na,orig,(expanded,expanded_typ)) rest = let alias = LocalDef (na,c,t) in let pb = { pb with - env = push_rel alias pb.env; + env = snd (push_rel !(pb.evdref) alias pb.env); tomatch = lift_tomatch_stack 1 rest; pred = lift_predicate 1 pb.pred pb.tomatch; history = pop_history_pattern pb.history; - mat = List.map (push_alias_eqn alias) pb.mat } in + mat = List.map (push_alias_eqn !(pb.evdref) alias) pb.mat } in let j = compile pb in let sigma = !(pb.evdref) in { uj_val = @@ -1534,7 +1539,7 @@ and compile_alias initial pb (na,orig,(expanded,expanded_typ)) rest = if not (Flags.is_program_mode ()) && (isRel sigma orig || isVar sigma orig) then (* Try to compile first using non expanded alias *) try - if initial then f orig (Retyping.get_type_of pb.env sigma orig) + if initial then f orig (Retyping.get_type_of !!(pb.env) sigma orig) else just_pop () with e when precatchable_exception e -> (* Try then to compile using expanded alias *) @@ -1549,7 +1554,7 @@ and compile_alias initial pb (na,orig,(expanded,expanded_typ)) rest = (* Could be needed in case of a recursive call which requires to be on a variable for size reasons *) pb.evdref := sigma; - if initial then f orig (Retyping.get_type_of pb.env !(pb.evdref) orig) + if initial then f orig (Retyping.get_type_of !!(pb.env) !(pb.evdref) orig) else just_pop () @@ -1573,7 +1578,7 @@ substituer après par les initiaux *) * Syntactic correctness has already been done in constrintern *) let matx_of_eqns env eqns = let build_eqn {CAst.loc;v=(ids,initial_lpat,initial_rhs)} = - let avoid = ids_of_named_context_val (named_context_val env) in + let avoid = ids_of_named_context_val (named_context_val !!env) in let avoid = List.fold_left (fun accu id -> Id.Set.add id accu) avoid ids in let rhs = { rhs_env = env; @@ -1616,8 +1621,8 @@ let matx_of_eqns env eqns = *) let adjust_to_extended_env_and_remove_deps env extenv sigma subst t = - let n = Context.Rel.length (rel_context env) in - let n' = Context.Rel.length (rel_context extenv) in + let n = Context.Rel.length (rel_context !!env) in + let n' = Context.Rel.length (rel_context !!extenv) in (* We first remove the bindings that are dependently typed (they are difficult to manage and it is not sure these are so useful in practice); Notes: @@ -1630,22 +1635,22 @@ let adjust_to_extended_env_and_remove_deps env extenv sigma subst t = (* d1 ... dn dn+1 ... dn'-p+1 ... dn' *) (* \--env-/ (= x:ty) *) (* \--------------extenv------------/ *) - let (p, _, _) = lookup_rel_id x (rel_context extenv) in + let (p, _, _) = lookup_rel_id x (rel_context !!extenv) in let rec traverse_local_defs p = - match lookup_rel p extenv with + match lookup_rel p !!extenv with | LocalDef (_,c,_) -> assert (isRel sigma c); traverse_local_defs (p + destRel sigma c) | LocalAssum _ -> p in let p = traverse_local_defs p in let u = lift (n' - n) u in - try Some (p, u, expand_vars_in_term extenv sigma u) + try Some (p, u, expand_vars_in_term !!extenv sigma u) (* pedrot: does this really happen to raise [Failure _]? *) with Failure _ -> None in let subst0 = List.map_filter map subst in let t0 = lift (n' - n) t in (subst0, t0) -let push_binder d (k,env,subst) = - (k+1,push_rel d env,List.map (fun (na,u,d) -> (na,lift 1 u,d)) subst) +let push_binder sigma d (k,env,subst) = + (k+1,snd (push_rel sigma d env),List.map (fun (na,u,d) -> (na,lift 1 u,d)) subst) let rec list_assoc_in_triple x = function [] -> raise Not_found @@ -1667,7 +1672,7 @@ let rec list_assoc_in_triple x = function *) let abstract_tycon ?loc env evdref subst tycon extenv t = - let t = nf_betaiota env !evdref t in (* it helps in some cases to remove K-redex*) + let t = nf_betaiota !!env !evdref t in (* it helps in some cases to remove K-redex*) let src = match EConstr.kind !evdref t with | Evar (evk,_) -> (Loc.tag ?loc @@ Evar_kinds.SubEvar (None,evk)) | _ -> (Loc.tag ?loc @@ Evar_kinds.CasesType true) in @@ -1679,31 +1684,31 @@ let abstract_tycon ?loc env evdref subst tycon extenv t = convertible subterms of the substitution *) let rec aux (k,env,subst as x) t = match EConstr.kind !evdref t with - | Rel n when is_local_def (lookup_rel n env) -> t + | Rel n when is_local_def (lookup_rel n !!env) -> t | Evar ev -> - let ty = get_type_of env !evdref t in - let ty = Evarutil.evd_comb1 (refresh_universes (Some false) env) evdref ty in + let ty = get_type_of !!env !evdref t in + let ty = Evarutil.evd_comb1 (refresh_universes (Some false) !!env) evdref ty in let inst = List.map_i (fun i _ -> try list_assoc_in_triple i subst0 with Not_found -> mkRel i) - 1 (rel_context env) in - let ev' = evd_comb1 (Evarutil.new_evar env ~src) evdref ty in - begin match solve_simple_eqn (evar_conv_x full_transparent_state) env !evdref (None,ev,substl inst ev') with + 1 (rel_context !!env) in + let ev' = evd_comb1 (Evarutil.new_evar !!env ~src) evdref ty in + begin match solve_simple_eqn (evar_conv_x full_transparent_state) !!env !evdref (None,ev,substl inst ev') with | Success evd -> evdref := evd | UnifFailure _ -> assert false end; ev' | _ -> - let good = List.filter (fun (_,u,_) -> is_conv_leq env !evdref t u) subst in + let good = List.filter (fun (_,u,_) -> is_conv_leq !!env !evdref t u) subst in match good with | [] -> - map_constr_with_full_binders !evdref push_binder aux x t + map_constr_with_full_binders !evdref (push_binder !evdref) aux x t | (_, _, u) :: _ -> (* u is in extenv *) let vl = List.map pi1 good in let ty = - let ty = get_type_of env !evdref t in - Evarutil.evd_comb1 (refresh_universes (Some false) env) evdref ty + let ty = get_type_of !!env !evdref t in + Evarutil.evd_comb1 (refresh_universes (Some false) !!env) evdref ty in let dummy_subst = List.init k (fun _ -> mkProp) in let ty = substl dummy_subst (aux x ty) in @@ -1711,7 +1716,7 @@ let abstract_tycon ?loc env evdref subst tycon extenv t = let inst = List.map_i (fun i _ -> if Int.List.mem i vl then u else mkRel i) 1 - (rel_context extenv) in + (rel_context !!extenv) in let map a = match EConstr.kind !evdref a with | Rel n -> not (noccurn !evdref n u) || Int.Set.mem n depvl | _ -> true @@ -1719,10 +1724,10 @@ let abstract_tycon ?loc env evdref subst tycon extenv t = let rel_filter = List.map map inst in let named_filter = List.map (fun d -> local_occur_var !evdref (NamedDecl.get_id d) u) - (named_context extenv) in + (named_context !!extenv) in let filter = Filter.make (rel_filter @ named_filter) in - let candidates = u :: List.map mkRel vl in - let ev = evd_comb1 (Evarutil.new_evar extenv ~src ~filter ~candidates) evdref ty in + let candidates = List.rev (u :: List.map mkRel vl) in + let ev = evd_comb1 (Evarutil.new_evar !!extenv ~src ~filter ~candidates) evdref ty in lift k ev in aux (0,extenv,subst0) t0 @@ -1732,19 +1737,19 @@ let build_tycon ?loc env tycon_env s subst tycon extenv evdref t = | None -> (* This is the situation we are building a return predicate and we are in an impossible branch *) - let n = Context.Rel.length (rel_context env) in - let n' = Context.Rel.length (rel_context tycon_env) in + let n = Context.Rel.length (rel_context !!env) in + let n' = Context.Rel.length (rel_context !!tycon_env) in let impossible_case_type, u = evd_comb1 - (new_type_evar (reset_context env) ~src:(Loc.tag ?loc Evar_kinds.ImpossibleCase)) + (new_type_evar (reset_context !!env) ~src:(Loc.tag ?loc Evar_kinds.ImpossibleCase)) evdref univ_flexible_alg in (lift (n'-n) impossible_case_type, mkSort u) | Some t -> let t = abstract_tycon ?loc tycon_env evdref subst tycon extenv t in - let tt = evd_comb1 (Typing.type_of extenv) evdref t in + let tt = evd_comb1 (Typing.type_of !!extenv) evdref t in (t,tt) in - match cumul env !evdref tt (mkSort s) with + match cumul !!env !evdref tt (mkSort s) with | None -> anomaly (Pp.str "Build_tycon: should be a type."); | Some sigma -> evdref := sigma; { uj_val = t; uj_type = tt } @@ -1761,14 +1766,14 @@ let build_tycon ?loc env tycon_env s subst tycon extenv evdref t = let build_inversion_problem loc env sigma tms t = let make_patvar t (subst,avoid) = - let id = next_name_away (named_hd env sigma t Anonymous) avoid in + let id = next_name_away (named_hd !!env sigma t Anonymous) avoid in DAst.make @@ PatVar (Name id), ((id,t)::subst, Id.Set.add id avoid) in let rec reveal_pattern t (subst,avoid as acc) = - match EConstr.kind sigma (whd_all env sigma t) with + match EConstr.kind sigma (whd_all !!env sigma t) with | Construct (cstr,u) -> DAst.make (PatCstr (cstr,[],Anonymous)), acc | App (f,v) when isConstruct sigma f -> let cstr,u = destConstruct sigma f in - let n = constructor_nrealargs_env env cstr in + let n = constructor_nrealargs_env !!env cstr in let l = List.lastn n (Array.to_list v) in let l,acc = List.fold_right_map reveal_pattern l acc in DAst.make (PatCstr (cstr,l,Anonymous)), acc @@ -1780,19 +1785,19 @@ let build_inversion_problem loc env sigma tms t = let patl,acc = List.fold_right_map reveal_pattern realargs acc in let pat,acc = make_patvar t acc in let indf' = lift_inductive_family n indf in - let sign = make_arity_signature env sigma true indf' in + let sign = make_arity_signature !!env sigma true indf' in let patl = pat :: List.rev patl in - let patl,sign = recover_and_adjust_alias_names patl sign in + let patl,sign = recover_and_adjust_alias_names acc patl sign in let p = List.length patl in - let env' = push_rel_context sign env in + let _,env' = push_rel_context sigma sign env in let patl',acc_sign,acc = aux (n+p) env' (sign@acc_sign) tms acc in List.rev_append patl patl',acc_sign,acc | (t, NotInd (bo,typ)) :: tms -> let pat,acc = make_patvar t acc in let d = LocalAssum (alias_of_pat pat,typ) in - let patl,acc_sign,acc = aux (n+1) (push_rel d env) (d::acc_sign) tms acc in + let patl,acc_sign,acc = aux (n+1) (snd (push_rel sigma d env)) (d::acc_sign) tms acc in pat::patl,acc_sign,acc in - let avoid0 = vars_of_env env in + let avoid0 = GlobEnv.vars_of_env env in (* [patl] is a list of patterns revealing the substructure of constructors present in the constraints on the type of the multiple terms t1..tn that are matched in the original problem; @@ -1808,9 +1813,9 @@ let build_inversion_problem loc env sigma tms t = let decls = List.map_i (fun i d -> (mkRel i, map_constr (lift i) d)) 1 sign in - let pb_env = push_rel_context sign env in + let _,pb_env = push_rel_context sigma sign env in let decls = - List.map (fun (c,d) -> (c,extract_inductive_data pb_env sigma d,d)) decls in + List.map (fun (c,d) -> (c,extract_inductive_data !!(pb_env) sigma d,d)) decls in let decls = List.rev decls in let dep_sign = find_dependencies_signature sigma (List.make n true) decls in @@ -1843,7 +1848,7 @@ let build_inversion_problem loc env sigma tms t = constraints are incompatible with the constraints on the inductive types of the multiple terms matched in Xi *) let catch_all_eqn = - if List.for_all (irrefutable env) patl then + if List.for_all (irrefutable !!env) patl then (* No need for a catch all clause *) [] else @@ -1857,13 +1862,12 @@ let build_inversion_problem loc env sigma tms t = it = None } } ] in (* [pb] is the auxiliary pattern-matching serving as skeleton for the return type of the original problem Xi *) - let s' = Retyping.get_sort_of env sigma t in + let s' = Retyping.get_sort_of !!env sigma t in let sigma, s = Evd.new_sort_variable univ_flexible sigma in - let sigma = Evd.set_leq_sort env sigma s' s in + let sigma = Evd.set_leq_sort !!env sigma s' s in let evdref = ref sigma in let pb = { env = pb_env; - lvar = empty_lvar; evdref = evdref; pred = (*ty *) mkSort s; tomatch = sub_tms; @@ -1878,16 +1882,16 @@ let build_inversion_problem loc env sigma tms t = (* Here, [pred] is assumed to be in the context built from all *) (* realargs and terms to match *) let build_initial_predicate arsign pred = - let rec buildrec n pred tmnames = function + let rec buildrec pred tmnames = function | [] -> List.rev tmnames,pred | (decl::realdecls)::lnames -> let na = RelDecl.get_name decl in - let n' = n + List.length realdecls in - buildrec (n'+1) pred (force_name na::tmnames) lnames + let realnames = List.map RelDecl.get_name realdecls in + buildrec pred ((force_name na,realnames)::tmnames) lnames | _ -> assert false - in buildrec 0 pred [] (List.rev arsign) + in buildrec pred [] (List.rev arsign) -let extract_arity_signature ?(dolift=true) env0 lvar tomatchl tmsign = +let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = let lift = if dolift then lift else fun n t -> t in let get_one_sign n tm (na,t) = match tm with @@ -1895,7 +1899,7 @@ let extract_arity_signature ?(dolift=true) env0 lvar tomatchl tmsign = (match t with | None -> let sign = match bo with | None -> [LocalAssum (na, lift n typ)] - | Some b -> [LocalDef (na, lift n b, lift n typ)] in sign,sign + | Some b -> [LocalDef (na, lift n b, lift n typ)] in sign | Some {CAst.loc} -> user_err ?loc (str"Unexpected type annotation for a term of non inductive type.")) @@ -1905,31 +1909,23 @@ let extract_arity_signature ?(dolift=true) env0 lvar tomatchl tmsign = let nrealargs_ctxt = inductive_nrealdecls_env env0 ind in let arsign = fst (get_arity env0 indf') in let arsign = List.map (fun d -> map_rel_decl EConstr.of_constr d) arsign in - let realnal, realnal' = + let realnal = match t with | Some {CAst.loc;v=(ind',realnal)} -> if not (eq_ind ind ind') then user_err ?loc (str "Wrong inductive type."); if not (Int.equal nrealargs_ctxt (List.length realnal)) then anomaly (Pp.str "Ill-formed 'in' clause in cases."); - let realnal = List.rev realnal in - let realnal' = List.map (ltac_interp_name lvar) realnal in - realnal,realnal' + List.rev realnal | None -> - let realnal = List.make nrealargs_ctxt Anonymous in - realnal, realnal in - let na' = ltac_interp_name lvar na in + List.make nrealargs_ctxt Anonymous in let t = EConstr.of_constr (build_dependent_inductive env0 indf') in - (* Context with names for typing *) - let arsign1 = LocalAssum (na, t) :: List.map2 RelDecl.set_name realnal arsign in - (* Context with names for building the term *) - let arsign2 = LocalAssum (na', t) :: List.map2 RelDecl.set_name realnal' arsign in - arsign1,arsign2 in + LocalAssum (na, t) :: List.map2 RelDecl.set_name realnal arsign in let rec buildrec n = function | [],[] -> [] | (_,tm)::ltm, (_,x)::tmsign -> let l = get_one_sign n tm x in - l :: buildrec (n + List.length (fst l)) (ltm,tmsign) + l :: buildrec (n + List.length l) (ltm,tmsign) | _ -> assert false in List.rev (buildrec 0 (tomatchl,tmsign)) @@ -1986,9 +1982,9 @@ let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c = in assert (len == 0); let p = predicate 0 c in - let env' = List.fold_right push_rel_context arsign env in - try let sigma' = fst (Typing.type_of env' sigma p) in - Some (sigma', p) + let arsign,env' = List.fold_right_map (push_rel_context sigma) arsign env in + try let sigma' = fst (Typing.type_of !!env' sigma p) in + Some (sigma', p, arsign) with e when precatchable_exception e -> None (* Builds the predicate. If the predicate is dependent, its context is @@ -2017,15 +2013,14 @@ let noccur_with_meta sigma n m term = in try (occur_rec n term; true) with LocalOccur -> false -let prepare_predicate ?loc typing_fun env sigma lvar tomatchs arsign tycon pred = +let prepare_predicate ?loc typing_fun env sigma tomatchs arsign tycon pred = let refresh_tycon sigma t = (** If we put the typing constraint in the term, it has to be refreshed to preserve the invariant that no algebraic universe can appear in the term. *) refresh_universes ~status:Evd.univ_flexible ~onlyalg:true (Some true) - env sigma t + !!env sigma t in - let typing_arsign,building_arsign = List.split arsign in let preds = match pred, tycon with (* No return clause *) @@ -2035,12 +2030,12 @@ let prepare_predicate ?loc typing_fun env sigma lvar tomatchs arsign tycon pred (* First strategy: we abstract the tycon wrt to the dependencies *) let sigma, t = refresh_tycon sigma t in let p1 = - prepare_predicate_from_arsign_tycon env sigma loc tomatchs typing_arsign t in + prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign t in (* Second strategy: we build an "inversion" predicate *) let sigma2,pred2 = build_inversion_problem loc env sigma tomatchs t in (match p1 with - | Some (sigma1,pred1) -> [sigma1, pred1; sigma2, pred2] - | None -> [sigma2, pred2]) + | Some (sigma1,pred1,arsign) -> [sigma1, pred1, arsign; sigma2, pred2, arsign] + | None -> [sigma2, pred2, arsign]) | None, _ -> (* No dependent type constraint, or no constraints at all: *) (* we use two strategies *) @@ -2048,28 +2043,28 @@ let prepare_predicate ?loc typing_fun env sigma lvar tomatchs arsign tycon pred | Some t -> refresh_tycon sigma t | None -> let (sigma, (t, _)) = - new_type_evar env sigma univ_flexible_alg ~src:(Loc.tag ?loc @@ Evar_kinds.CasesType false) in + new_type_evar !!env sigma univ_flexible_alg ~src:(Loc.tag ?loc @@ Evar_kinds.CasesType false) in sigma, t in (* First strategy: we build an "inversion" predicate *) let sigma1,pred1 = build_inversion_problem loc env sigma tomatchs t in (* Second strategy: we directly use the evar as a non dependent pred *) - let pred2 = lift (List.length (List.flatten typing_arsign)) t in - [sigma1, pred1; sigma, pred2] + let pred2 = lift (List.length (List.flatten arsign)) t in + [sigma1, pred1, arsign; sigma, pred2, arsign] (* Some type annotation *) | Some rtntyp, _ -> (* We extract the signature of the arity *) - let envar = List.fold_right push_rel_context typing_arsign env in + let building_arsign,envar = List.fold_right_map (push_rel_context sigma) arsign env in let sigma, newt = new_sort_variable univ_flexible_alg sigma in let evdref = ref sigma in - let predcclj = typing_fun (mk_tycon (mkSort newt)) envar evdref lvar rtntyp in + let predcclj = typing_fun (mk_tycon (mkSort newt)) envar evdref rtntyp in let sigma = !evdref in let predccl = nf_evar sigma predcclj.uj_val in - [sigma, predccl] + [sigma, predccl, building_arsign] in List.map - (fun (sigma,pred) -> - let (nal,pred) = build_initial_predicate building_arsign pred in + (fun (sigma,pred,arsign) -> + let (nal,pred) = build_initial_predicate arsign pred in sigma,nal,pred) preds @@ -2152,7 +2147,7 @@ let constr_of_pat env evdref arsign pat avoid = typ env (substl args liftt, []) ua avoid in let args' = arg' :: List.map (lift n') args in - let env' = push_rel_context sign' env in + let env' = EConstr.push_rel_context sign' env in (pat' :: patargs, args', sign' @ sign, env', n' + n, succ m, avoid)) ci.cs_args (List.rev args) ([], [], [], env, 0, 0, avoid) in @@ -2172,8 +2167,8 @@ let constr_of_pat env evdref arsign pat avoid = let avoid = Id.Set.add id avoid in let sign, i, avoid = try - let env = push_rel_context sign env in - evdref := the_conv_x_leq (push_rel_context sign env) + let env = EConstr.push_rel_context sign env in + evdref := the_conv_x_leq (EConstr.push_rel_context sign env) (lift (succ m) ty) (lift 1 apptype) !evdref; let eq_t = mk_eq evdref (lift (succ m) ty) (mkRel 1) (* alias *) @@ -2240,7 +2235,6 @@ let lift_rel_context n l = full signature. However prevpatterns are in the original one signature per pattern form. *) let build_ineqs evdref prevpatterns pats liftsign = - let _tomatchs = List.length pats in let diffs = List.fold_left (fun c eqnpats -> @@ -2288,7 +2282,7 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity = let _, newpatterns, pats = List.fold_left2 (fun (idents, newpatterns, pats) pat arsign -> - let pat', cpat, idents = constr_of_pat env evdref arsign pat idents in + let pat', cpat, idents = constr_of_pat !!env evdref arsign pat idents in (idents, pat' :: newpatterns, cpat :: pats)) (Id.Set.empty, [], []) eqn.patterns sign in @@ -2315,7 +2309,7 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity = in let ineqs = build_ineqs evdref prevpatterns pats signlen in let rhs_rels' = rels_of_patsign !evdref rhs_rels in - let _signenv = push_rel_context rhs_rels' env in + let _signenv,_ = push_rel_context !evdref rhs_rels' env in let arity = let args, nargs = List.fold_right (fun (sign, c, (_, args), _) (allargs,n) -> @@ -2335,11 +2329,11 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity = let eqs_rels, arity = decompose_prod_n_assum !evdref neqs arity in eqs_rels @ neqs_rels @ rhs_rels', arity in - let rhs_env = push_rel_context rhs_rels' env in + let _,rhs_env = push_rel_context !evdref rhs_rels' env in let j = typing_fun (mk_tycon tycon) rhs_env eqn.rhs.it in let bbody = it_mkLambda_or_LetIn j.uj_val rhs_rels' and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' in - let _btype = evd_comb1 (Typing.type_of env) evdref bbody in + let _btype = evd_comb1 (Typing.type_of !!env) evdref bbody in let branch_name = Id.of_string ("program_branch_" ^ (string_of_int !i)) in let branch_decl = LocalDef (Name branch_name, lift !i bbody, lift !i btype) in let branch = @@ -2492,10 +2486,10 @@ let context_of_arsign l = l ([], 0) in x -let compile_program_cases ?loc style (typing_function, evdref) tycon env lvar +let compile_program_cases ?loc style (typing_function, evdref) tycon env (predopt, tomatchl, eqns) = let typing_fun tycon env = function - | Some t -> typing_function tycon env evdref lvar t + | Some t -> typing_function tycon env evdref t | None -> Evarutil.evd_comb0 use_unit_judge evdref in (* We build the matrix of patterns and right-hand side *) @@ -2503,29 +2497,28 @@ let compile_program_cases ?loc style (typing_function, evdref) tycon env lvar (* We build the vector of terms to match consistently with the *) (* constructors found in patterns *) - let predlvar,tomatchs = coerce_to_indtype typing_function evdref env lvar matx tomatchl in + let env,tomatchs = coerce_to_indtype typing_function evdref env matx tomatchl in let tycon = valcon_of_tycon tycon in let tomatchs, tomatchs_lets, tycon' = abstract_tomatch env !evdref tomatchs tycon in - let env = push_rel_context tomatchs_lets env in + let _,env = push_rel_context !evdref tomatchs_lets env in let len = List.length eqns in let sign, allnames, signlen, eqs, neqs, args = (* The arity signature *) - let arsign = extract_arity_signature ~dolift:false env predlvar tomatchs tomatchl in - let arsign = List.map fst arsign in (* Because no difference between the arity for typing and the arity for building *) + let arsign = extract_arity_signature ~dolift:false !!env tomatchs tomatchl in (* Build the dependent arity signature, the equalities which makes the first part of the predicate and their instantiations. *) let avoid = Id.Set.empty in - build_dependent_signature env evdref avoid tomatchs arsign + build_dependent_signature !!env evdref avoid tomatchs arsign in let tycon, arity = let nar = List.fold_left (fun n sign -> List.length sign + n) 0 sign in match tycon' with - | None -> let ev = mkExistential env evdref in ev, lift nar ev + | None -> let ev = mkExistential !!env evdref in ev, lift nar ev | Some t -> let pred = match prepare_predicate_from_arsign_tycon env !evdref loc tomatchs sign t with - | Some (evd, pred) -> evdref := evd; pred + | Some (evd, pred, arsign) -> evdref := evd; pred | None -> lift nar t in Option.get tycon, pred @@ -2541,7 +2534,7 @@ let compile_program_cases ?loc style (typing_function, evdref) tycon env lvar in let matx = List.rev matx in let _ = assert (Int.equal len (List.length lets)) in - let env = push_rel_context lets env in + let _,env = push_rel_context !evdref lets env in let matx = List.map (fun eqn -> { eqn with rhs = { eqn.rhs with rhs_env = env } }) matx in let tomatchs = List.map (fun (x, y) -> lift len x, lift_tomatch_type len y) tomatchs in let args = List.rev_map (lift len) args in @@ -2554,10 +2547,10 @@ let compile_program_cases ?loc style (typing_function, evdref) tycon env lvar let out_tmt na = function NotInd (None,t) -> LocalAssum (na,t) | NotInd (Some b, t) -> LocalDef (na,b,t) | IsInd (typ,_,_) -> LocalAssum (na,typ) in - let typs = List.map2 (fun na (tm,tmt) -> (tm,out_tmt na tmt)) nal tomatchs in + let typs = List.map2 (fun (na,_) (tm,tmt) -> (tm,out_tmt na tmt)) nal tomatchs in let typs = - List.map (fun (c,d) -> (c,extract_inductive_data env !evdref d,d)) typs in + List.map (fun (c,d) -> (c,extract_inductive_data !!env !evdref d,d)) typs in let dep_sign = find_dependencies_signature !evdref @@ -2566,20 +2559,20 @@ let compile_program_cases ?loc style (typing_function, evdref) tycon env lvar let typs' = List.map3 - (fun (tm,tmt) deps na -> + (fun (tm,tmt) deps (na,realnames) -> let deps = if not (isRel !evdref tm) then [] else deps in + let tmt = set_tomatch_realnames realnames tmt in ((tm,tmt),deps,na)) tomatchs dep_sign nal in let initial_pushed = List.map (fun x -> Pushed (true,x)) typs' in let typing_function tycon env evdref = function - | Some t -> typing_function tycon env evdref lvar t + | Some t -> typing_function tycon env evdref t | None -> evd_comb0 use_unit_judge evdref in let pb = { env = env; - lvar = lvar; evdref = evdref; pred = pred; tomatch = initial_pushed; @@ -2591,7 +2584,7 @@ let compile_program_cases ?loc style (typing_function, evdref) tycon env lvar let j = compile pb in (* We check for unused patterns *) - List.iter (check_unused_pattern env) matx; + List.iter (check_unused_pattern !!env) matx; let body = it_mkLambda_or_LetIn (applist (j.uj_val, args)) lets in let j = { uj_val = it_mkLambda_or_LetIn body tomatchs_lets; @@ -2602,10 +2595,10 @@ let compile_program_cases ?loc style (typing_function, evdref) tycon env lvar (**************************************************************************) (* Main entry of the matching compilation *) -let compile_cases ?loc style (typing_fun, evdref) tycon env lvar (predopt, tomatchl, eqns) = +let compile_cases ?loc style (typing_fun, evdref) tycon env (predopt, tomatchl, eqns) = if predopt == None && Flags.is_program_mode () && Program.is_program_cases () then compile_program_cases ?loc style (typing_fun, evdref) - tycon env lvar (predopt, tomatchl, eqns) + tycon env (predopt, tomatchl, eqns) else (* We build the matrix of patterns and right-hand side *) @@ -2613,15 +2606,13 @@ let compile_cases ?loc style (typing_fun, evdref) tycon env lvar (predopt, tomat (* We build the vector of terms to match consistently with the *) (* constructors found in patterns *) - let predlvar,tomatchs = coerce_to_indtype typing_fun evdref env lvar matx tomatchl in - - + let predenv,tomatchs = coerce_to_indtype typing_fun evdref env matx tomatchl in (* If an elimination predicate is provided, we check it is compatible with the type of arguments to match; if none is provided, we build alternative possible predicates *) - let arsign = extract_arity_signature env predlvar tomatchs tomatchl in - let preds = prepare_predicate ?loc typing_fun env !evdref predlvar tomatchs arsign tycon predopt in + let arsign = extract_arity_signature !!env tomatchs tomatchl in + let preds = prepare_predicate ?loc typing_fun predenv !evdref tomatchs arsign tycon predopt in let compile_for_one_predicate (sigma,nal,pred) = (* We push the initial terms to match and push their alias to rhs' envs *) @@ -2631,10 +2622,10 @@ let compile_cases ?loc style (typing_fun, evdref) tycon env lvar (predopt, tomat let out_tmt na = function NotInd (None,t) -> LocalAssum (na,t) | NotInd (Some b,t) -> LocalDef (na,b,t) | IsInd (typ,_,_) -> LocalAssum (na,typ) in - let typs = List.map2 (fun na (tm,tmt) -> (tm,out_tmt na tmt)) nal tomatchs in + let typs = List.map2 (fun (na,_) (tm,tmt) -> (tm,out_tmt na tmt)) nal tomatchs in let typs = - List.map (fun (c,d) -> (c,extract_inductive_data env sigma d,d)) typs in + List.map (fun (c,d) -> (c,extract_inductive_data !!env sigma d,d)) typs in let dep_sign = find_dependencies_signature !evdref @@ -2643,8 +2634,9 @@ let compile_cases ?loc style (typing_fun, evdref) tycon env lvar (predopt, tomat let typs' = List.map3 - (fun (tm,tmt) deps na -> + (fun (tm,tmt) deps (na,realnames) -> let deps = if not (isRel !evdref tm) then [] else deps in + let tmt = set_tomatch_realnames realnames tmt in ((tm,tmt),deps,na)) tomatchs dep_sign nal in @@ -2652,14 +2644,13 @@ let compile_cases ?loc style (typing_fun, evdref) tycon env lvar (predopt, tomat (* A typing function that provides with a canonical term for absurd cases*) let typing_fun tycon env evdref = function - | Some t -> typing_fun tycon env evdref lvar t + | Some t -> typing_fun tycon env evdref t | None -> evd_comb0 use_unit_judge evdref in let myevdref = ref sigma in let pb = { env = env; - lvar = lvar; evdref = myevdref; pred = pred; tomatch = initial_pushed; @@ -2672,7 +2663,7 @@ let compile_cases ?loc style (typing_fun, evdref) tycon env lvar (predopt, tomat let j = compile pb in (* We coerce to the tycon (if an elim predicate was provided) *) - let j = inh_conv_coerce_to_tycon ?loc env myevdref j tycon in + let j = inh_conv_coerce_to_tycon ?loc !!env myevdref j tycon in evdref := !myevdref; j in @@ -2681,6 +2672,6 @@ let compile_cases ?loc style (typing_fun, evdref) tycon env lvar (predopt, tomat let j = list_try_compile compile_for_one_predicate preds in (* We check for unused patterns *) - List.iter (check_unused_pattern env) matx; + List.iter (check_unused_pattern !!env) matx; j diff --git a/pretyping/cases.mli b/pretyping/cases.mli index 04a3464679..76b81a58c1 100644 --- a/pretyping/cases.mli +++ b/pretyping/cases.mli @@ -15,7 +15,6 @@ open Environ open EConstr open Inductiveops open Glob_term -open Ltac_pretype open Evardefine (** {5 Compilation of pattern-matching } *) @@ -42,9 +41,9 @@ val irrefutable : env -> cases_pattern -> bool val compile_cases : ?loc:Loc.t -> case_style -> - (type_constraint -> env -> evar_map ref -> ltac_var_map -> glob_constr -> unsafe_judgment) * evar_map ref -> + (type_constraint -> GlobEnv.t -> evar_map ref -> glob_constr -> unsafe_judgment) * evar_map ref -> type_constraint -> - env -> ltac_var_map -> glob_constr option * tomatch_tuples * cases_clauses -> + GlobEnv.t -> glob_constr option * tomatch_tuples * cases_clauses -> unsafe_judgment val constr_of_pat : @@ -59,7 +58,7 @@ val constr_of_pat : Names.Id.Set.t type 'a rhs = - { rhs_env : env; + { rhs_env : GlobEnv.t; rhs_vars : Id.Set.t; avoid_ids : Id.Set.t; it : 'a option} @@ -103,8 +102,7 @@ and pattern_continuation = | Result of cases_pattern list type 'a pattern_matching_problem = - { env : env; - lvar : Ltac_pretype.ltac_var_map; + { env : GlobEnv.t; evdref : evar_map ref; pred : constr; tomatch : tomatch_stack; @@ -112,21 +110,19 @@ type 'a pattern_matching_problem = mat : 'a matrix; caseloc : Loc.t option; casestyle : case_style; - typing_function: type_constraint -> env -> evar_map ref -> 'a option -> unsafe_judgment } - + typing_function: type_constraint -> GlobEnv.t -> evar_map ref -> 'a option -> unsafe_judgment } val compile : 'a pattern_matching_problem -> unsafe_judgment val prepare_predicate : ?loc:Loc.t -> (type_constraint -> - Environ.env -> Evd.evar_map ref -> ltac_var_map -> glob_constr -> unsafe_judgment) -> - Environ.env -> + GlobEnv.t -> Evd.evar_map ref -> glob_constr -> unsafe_judgment) -> + GlobEnv.t -> Evd.evar_map -> - Ltac_pretype.ltac_var_map -> (types * tomatch_type) list -> - (rel_context * rel_context) list -> + rel_context list -> constr option -> - glob_constr option -> (Evd.evar_map * Name.t list * constr) list + glob_constr option -> (Evd.evar_map * (Name.t * Name.t list) list * constr) list -val make_return_predicate_ltac_lvar : Evd.evar_map -> Name.t -> - Glob_term.glob_constr -> constr -> Ltac_pretype.ltac_var_map -> ltac_var_map +val make_return_predicate_ltac_lvar : GlobEnv.t -> Evd.evar_map -> Name.t -> + Glob_term.glob_constr -> constr -> GlobEnv.t diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 542fb5456c..b264e31474 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -16,7 +16,6 @@ open Constr open Libnames open Globnames open Nametab -open Environ open Libobject open Mod_subst @@ -39,7 +38,7 @@ type cl_info_typ = { type coe_typ = GlobRef.t -module CoeTypMap = Refmap_env +module CoeTypMap = GlobRef.Map_env type coe_info_typ = { coe_value : GlobRef.t; @@ -112,11 +111,18 @@ end type cl_index = Bijint.Index.t +let init_class_tab = + let open Bijint in + add CL_FUN { cl_param = 0 } (add CL_SORT { cl_param = 0 } empty) + let class_tab = - ref (Bijint.empty : cl_info_typ Bijint.t) + Summary.ref ~name:"class_tab" (init_class_tab : cl_info_typ Bijint.t) let coercion_tab = - ref (CoeTypMap.empty : coe_info_typ CoeTypMap.t) + Summary.ref ~name:"coercion_tab" (CoeTypMap.empty : coe_info_typ CoeTypMap.t) + +let coercions_in_scope = + Summary.ref ~name:"coercions_in_scope" GlobRef.Set_env.empty module ClPairOrd = struct @@ -129,14 +135,7 @@ end module ClPairMap = Map.Make(ClPairOrd) let inheritance_graph = - ref (ClPairMap.empty : inheritance_path ClPairMap.t) - -let freeze _ = (!class_tab, !coercion_tab, !inheritance_graph) - -let unfreeze (fcl,fco,fig) = - class_tab:=fcl; - coercion_tab:=fco; - inheritance_graph:=fig + Summary.ref ~name:"inheritance_graph" (ClPairMap.empty : inheritance_path ClPairMap.t) (* ajout de nouveaux "objets" *) @@ -150,21 +149,6 @@ let add_new_coercion coe s = let add_new_path x y = inheritance_graph := ClPairMap.add x y !inheritance_graph -let init () = - class_tab:= Bijint.empty; - add_new_class CL_FUN { cl_param = 0 }; - add_new_class CL_SORT { cl_param = 0 }; - coercion_tab:= CoeTypMap.empty; - inheritance_graph:= ClPairMap.empty - -let _ = - Summary.declare_summary "inh_graph" - { Summary.freeze_function = freeze; - Summary.unfreeze_function = unfreeze; - Summary.init_function = init } - -let _ = init() - (* class_info : cl_typ -> int * cl_info_typ *) let class_info cl = Bijint.revmap cl !class_tab @@ -316,16 +300,16 @@ let lookup_pattern_path_between env (s,t) = (* rajouter une coercion dans le graphe *) -let path_printer : (env -> Evd.evar_map -> (Bijint.Index.t * Bijint.Index.t) * inheritance_path -> Pp.t) ref = - ref (fun _ _ _ -> str "<a class path>") +let path_printer : ((Bijint.Index.t * Bijint.Index.t) * inheritance_path -> Pp.t) ref = + ref (fun _ -> str "<a class path>") let install_path_printer f = path_printer := f -let print_path env sigma x = !path_printer env sigma x +let print_path x = !path_printer x -let message_ambig env sigma l = +let message_ambig l = str"Ambiguous paths:" ++ spc () ++ - prlist_with_sep fnl (fun ijp -> print_path env sigma ijp) l + prlist_with_sep fnl print_path l (* add_coercion_in_graph : coe_index * cl_index * cl_index -> unit coercion,source,target *) @@ -339,7 +323,7 @@ let different_class_params i = | CL_CONST c -> Global.is_polymorphic (ConstRef c) | _ -> false -let add_coercion_in_graph env sigma (ic,source,target) = +let add_coercion_in_graph (ic,source,target) = let old_inheritance_graph = !inheritance_graph in let ambig_paths = (ref [] : ((cl_index * cl_index) * inheritance_path) list ref) in @@ -381,7 +365,7 @@ let add_coercion_in_graph env sigma (ic,source,target) = end; let is_ambig = match !ambig_paths with [] -> false | _ -> true in if is_ambig && not !Flags.quiet then - Feedback.msg_info (message_ambig env sigma !ambig_paths) + Feedback.msg_info (message_ambig !ambig_paths) type coercion = { coercion_type : coe_typ; @@ -426,7 +410,7 @@ let _ = optread = (fun () -> !automatically_import_coercions); optwrite = (:=) automatically_import_coercions } -let cache_coercion env sigma (_, c) = +let cache_coercion (_, c) = let () = add_class c.coercion_source in let () = add_class c.coercion_target in let is, _ = class_info c.coercion_source in @@ -439,15 +423,22 @@ let cache_coercion env sigma (_, c) = coe_param = c.coercion_params; } in let () = add_new_coercion c.coercion_type xf in - add_coercion_in_graph env sigma (xf,is,it) + add_coercion_in_graph (xf,is,it) let load_coercion _ o = if !automatically_import_coercions then - cache_coercion (Global.env ()) Evd.empty o + cache_coercion o + +let set_coercion_in_scope (_, c) = + let r = c.coercion_type in + coercions_in_scope := GlobRef.Set_env.add r !coercions_in_scope let open_coercion i o = - if Int.equal i 1 && not !automatically_import_coercions then - cache_coercion (Global.env ()) Evd.empty o + if Int.equal i 1 then begin + set_coercion_in_scope o; + if not !automatically_import_coercions then + cache_coercion o + end let subst_coercion (subst, c) = let coe = subst_coe_typ subst c.coercion_type in @@ -492,8 +483,8 @@ let inCoercion : coercion -> obj = open_function = open_coercion; load_function = load_coercion; cache_function = (fun objn -> - let env = Global.env () in cache_coercion env Evd.empty objn - ); + set_coercion_in_scope objn; + cache_coercion objn); subst_function = subst_coercion; classify_function = classify_coercion; discharge_function = discharge_coercion } @@ -535,7 +526,7 @@ let coercion_of_reference r = module CoercionPrinting = struct type t = coe_typ - let compare = RefOrdered.compare + let compare = GlobRef.Ordered.compare let encode = coercion_of_reference let subst = subst_coe_typ let printer x = pr_global_env Id.Set.empty x @@ -553,3 +544,6 @@ let hide_coercion coe = let coe_info = coercion_info coe in Some coe_info.coe_param else None + +let is_coercion_in_scope r = + GlobRef.Set_env.mem r !coercions_in_scope diff --git a/pretyping/classops.mli b/pretyping/classops.mli index af00c0a8dc..7c4842c8ae 100644 --- a/pretyping/classops.mli +++ b/pretyping/classops.mli @@ -99,7 +99,7 @@ val lookup_pattern_path_between : (**/**) (* Crade *) val install_path_printer : - (env -> evar_map -> (cl_index * cl_index) * inheritance_path -> Pp.t) -> unit + ((cl_index * cl_index) * inheritance_path -> Pp.t) -> unit (**/**) (** {6 This is for printing purpose } *) @@ -113,3 +113,5 @@ val coercions : unit -> coe_info_typ list (** [hide_coercion] returns the number of params to skip if the coercion must be hidden, [None] otherwise; it raises [Not_found] if not a coercion *) val hide_coercion : coe_typ -> int option + +val is_coercion_in_scope : GlobRef.t -> bool diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 5e3821edf1..e15c00f7dc 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -363,12 +363,20 @@ let saturate_evd env evd = Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~split:true ~fail:false env evd +let warn_coercion_not_in_scope = + CWarnings.create ~name:"coercion-not-in-scope" ~category:"deprecated" + Pp.(fun r -> str "Coercion used but not in scope: " ++ + Nametab.pr_global_env Id.Set.empty r ++ str ". If you want to use " + ++ str "this coercion, please Import the module that contains it.") + (* Apply coercion path from p to hj; raise NoCoercion if not applicable *) let apply_coercion env sigma p hj typ_cl = try let j,t,evd = List.fold_left (fun (ja,typ_cl,sigma) i -> + if not (is_coercion_in_scope i.coe_value) then + warn_coercion_not_in_scope i.coe_value; let isid = i.coe_is_identity in let isproj = i.coe_is_projection in let sigma, c = new_global sigma i.coe_value in @@ -386,7 +394,6 @@ let apply_coercion env sigma p hj typ_cl = (hj,typ_cl,sigma) p in evd, j with NoCoercion as e -> raise e - | e when CErrors.noncritical e -> anomaly (Pp.str "apply_coercion.") (* Try to coerce to a funclass; raise NoCoercion if not possible *) let inh_app_fun_core env evd j = diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 984fa92c0e..6c52dacaa9 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -1317,6 +1317,7 @@ let rec solve_unconstrained_evars_with_candidates ts evd = let rec aux = function | [] -> user_err Pp.(str "Unsolvable existential variables.") | a::l -> + (* In case of variables, most recent ones come first *) try let conv_algo = evar_conv_x ts in let evd = check_evar_instance evd evk a conv_algo in @@ -1327,9 +1328,9 @@ let rec solve_unconstrained_evars_with_candidates ts evd = with | IllTypedInstance _ -> aux l | e when Pretype_errors.precatchable_exception e -> aux l in - (* List.rev is there to favor most dependent solutions *) - (* and favor progress when used with the refine tactics *) - let evd = aux (List.rev l) in + (* 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 ts evd let solve_unconstrained_impossible_cases env evd = diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 3f5d186d4e..2dd3721980 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -599,11 +599,12 @@ let solve_pattern_eqn env sigma l c = let make_projectable_subst aliases sigma evi args = let sign = evar_filtered_context evi in let evar_aliases = compute_var_aliases sign sigma in - let (_,full_subst,cstr_subst) = - List.fold_right - (fun decl (args,all,cstrs) -> + let (_,full_subst,cstr_subst,_) = + List.fold_right_i + (fun i decl (args,all,cstrs,revmap) -> match decl,args with | LocalAssum (id,c), a::rest -> + let revmap = Id.Map.add id i revmap in let cstrs = let a',args = decompose_app_vect sigma a in match EConstr.kind sigma a' with @@ -611,22 +612,26 @@ let make_projectable_subst aliases sigma evi args = let l = try Constrmap.find (fst cstr) cstrs with Not_found -> [] in Constrmap.add (fst cstr) ((args,id)::l) cstrs | _ -> cstrs in - (rest,Id.Map.add id [a,normalize_alias_opt sigma aliases a,id] all,cstrs) + let all = Int.Map.add i [a,normalize_alias_opt sigma aliases a,id] all in + (rest,all,cstrs,revmap) | LocalDef (id,c,_), a::rest -> + let revmap = Id.Map.add id i revmap in (match EConstr.kind sigma c with | Var id' -> let idc = normalize_alias_var sigma evar_aliases id' in - let sub = try Id.Map.find idc all with Not_found -> [] in + let ic, sub = + try let ic = Id.Map.find idc revmap in ic, Int.Map.find ic all + with Not_found -> i, [] (* e.g. [idc] is a filtered variable: treat [id] as an assumption *) in if List.exists (fun (c,_,_) -> EConstr.eq_constr sigma a c) sub then - (rest,all,cstrs) + (rest,all,cstrs,revmap) else - (rest, - Id.Map.add idc ((a,normalize_alias_opt sigma aliases a,id)::sub) all, - cstrs) + let all = Int.Map.add ic ((a,normalize_alias_opt sigma aliases a,id)::sub) all in + (rest,all,cstrs,revmap) | _ -> - (rest,Id.Map.add id [a,normalize_alias_opt sigma aliases a,id] all,cstrs)) - | _ -> anomaly (Pp.str "Instance does not match its signature.")) - sign (Array.rev_to_list args,Id.Map.empty,Constrmap.empty) in + let all = Int.Map.add i [a,normalize_alias_opt sigma aliases a,id] all in + (rest,all,cstrs,revmap)) + | _ -> anomaly (Pp.str "Instance does not match its signature.")) 0 + sign (Array.rev_to_list args,Int.Map.empty,Constrmap.empty,Id.Map.empty) in (full_subst,cstr_subst) (*------------------------------------* @@ -793,11 +798,11 @@ let rec assoc_up_to_alias sigma aliases y yc = function let rec find_projectable_vars with_evars aliases sigma y subst = let yc = normalize_alias sigma aliases y in - let is_projectable idc idcl subst' = + let is_projectable idc idcl (subst1,subst2 as subst') = (* First test if some [id] aliased to [idc] is bound to [y] in [subst] *) try let id = assoc_up_to_alias sigma aliases y yc idcl in - (id,ProjectVar)::subst' + (id,ProjectVar)::subst1,subst2 with Not_found -> (* Then test if [idc] is (indirectly) bound in [subst] to some evar *) (* projectable on [y] *) @@ -812,14 +817,18 @@ let rec find_projectable_vars with_evars aliases sigma y subst = let subst,_ = make_projectable_subst aliases sigma evi argsv in let l = find_projectable_vars with_evars aliases sigma y subst in match l with - | [id',p] -> (id,ProjectEvar (t,evi,id',p))::subst' + | [id',p] -> (subst1,(id,ProjectEvar (t,evi,id',p))::subst2) | _ -> subst' end | [] -> subst' | _ -> anomaly (Pp.str "More than one non var in aliases class of evar instance.") else subst' in - Id.Map.fold is_projectable subst [] + let subst1,subst2 = Int.Map.fold is_projectable subst ([],[]) in + (* We return the substitution with ProjectVar first (from most + recent to oldest var), followed by ProjectEvar (from most recent + to oldest var too) *) + subst1 @ subst2 (* [filter_solution] checks if one and only one possible projection exists * among a set of solutions to a projection problem *) @@ -842,25 +851,6 @@ let rec find_solution_type evarenv = function | (id,ProjectEvar _)::l -> find_solution_type evarenv l | [] -> assert false -let is_preferred_projection_over sign (id,p) (id',p') = - (* We give priority to projection of variables over instantiation of - an evar considering that the latter is a stronger decision which - may even procude an incorrect (ill-typed) solution *) - match p, p' with - | ProjectEvar _, ProjectVar -> false - | ProjectVar, ProjectEvar _ -> true - | _, _ -> - List.index Id.equal id sign < List.index Id.equal id' sign - -let choose_projection evi sols = - let sign = List.map get_id (evar_filtered_context evi) in - match sols with - | y::l -> - List.fold_right (fun (id,p as x) (id',_ as y) -> - if is_preferred_projection_over sign x y then x else y) - l y - | _ -> assert false - (* In case the solution to a projection problem requires the instantiation of * subsidiary evars, [do_projection_effects] performs them; it * also try to instantiate the type of those subsidiary evars if their @@ -1447,12 +1437,8 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = let c, p = match sols with | [] -> raise Not_found | [id,p] -> (mkVar id, p) - | _ -> - if choose then - let (id,p) = choose_projection evi sols in - (mkVar id, p) - else - raise (NotUniqueInType sols) + | (id,p)::_ -> + if choose then (mkVar id, p) else raise (NotUniqueInType sols) in let ty = lazy (Retyping.get_type_of env !evdref (of_alias t)) in let evd = do_projection_effects (evar_define conv_algo ~choose) env ty !evdref p in @@ -1556,7 +1542,8 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = let t = map_constr_with_full_binders !evdref (fun d (env,k) -> push_rel d env, k+1) imitate envk t in - t::l + (* Less dependent solutions come last *) + l@[t] with e when CErrors.noncritical e -> l in (match candidates with | [x] -> x diff --git a/pretyping/globEnv.ml b/pretyping/globEnv.ml new file mode 100644 index 0000000000..12788e5ec5 --- /dev/null +++ b/pretyping/globEnv.ml @@ -0,0 +1,201 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Util +open Pp +open CErrors +open Names +open Environ +open EConstr +open Evarutil +open Termops +open Vars +open Ltac_pretype + +(** This files provides a level of abstraction for the kind of + environment used for type inference (so-called pretyping); in + particular: + - it supports that term variables can be interpreted as Ltac + variables pointing to the effective expected name + - it incrementally and lazily computes the renaming of rel + variables used to build purely-named evar contexts +*) + +type t = { + static_env : env; + (** For locating indices *) + renamed_env : env; + (** For name management *) + extra : ext_named_context Lazy.t; + (** Delay the computation of the evar extended environment *) + lvar : ltac_var_map; +} + +let make env sigma lvar = + let get_extra env sigma = + let avoid = Environ.ids_of_named_context_val (Environ.named_context_val env) in + Context.Rel.fold_outside (fun d acc -> push_rel_decl_to_named_context sigma d acc) + (rel_context env) ~init:(empty_csubst, avoid, named_context env) in + { + static_env = env; + renamed_env = env; + extra = lazy (get_extra env sigma); + lvar = lvar; + } + +let env env = env.static_env + +let vars_of_env env = + Id.Set.union (Id.Map.domain env.lvar.ltac_genargs) (vars_of_env env.static_env) + +let ltac_interp_name { ltac_idents ; ltac_genargs } = function + | Anonymous -> Anonymous + | Name id as na -> + try Name (Id.Map.find id ltac_idents) + with Not_found -> + if Id.Map.mem id ltac_genargs then + user_err (str "Ltac variable" ++ spc () ++ Id.print id ++ + spc () ++ str "is not bound to an identifier." ++ + spc () ++str "It cannot be used in a binder.") + else na + +let push_rel sigma d env = + let d' = Context.Rel.Declaration.map_name (ltac_interp_name env.lvar) d in + let env = { + static_env = push_rel d env.static_env; + renamed_env = push_rel d' env.renamed_env; + extra = lazy (push_rel_decl_to_named_context sigma d' (Lazy.force env.extra)); + lvar = env.lvar; + } in + d', env + +let push_rel_context ?(force_names=false) sigma ctx env = + let open Context.Rel.Declaration in + let ctx' = List.Smart.map (map_name (ltac_interp_name env.lvar)) ctx in + let ctx' = if force_names then Namegen.name_context env.renamed_env sigma ctx' else ctx' in + let env = { + static_env = push_rel_context ctx env.static_env; + renamed_env = push_rel_context ctx' env.renamed_env; + extra = lazy (List.fold_right (fun d acc -> push_rel_decl_to_named_context sigma d acc) ctx' (Lazy.force env.extra)); + lvar = env.lvar; + } in + ctx', env + +let push_rec_types sigma (lna,typarray) env = + let open Context.Rel.Declaration in + let ctxt = Array.map2_i (fun i na t -> Context.Rel.Declaration.LocalAssum (na, lift i t)) lna typarray in + let env,ctx = Array.fold_left_map (fun e assum -> let (d,e) = push_rel sigma assum e in (e,d)) env ctxt in + Array.map get_name ctx, env + +let e_new_evar env evdref ?src ?naming typ = + let open Context.Named.Declaration in + let inst_vars = List.map (get_id %> mkVar) (named_context env.renamed_env) in + let inst_rels = List.rev (rel_list 0 (nb_rel env.renamed_env)) in + let (subst, _, nc) = Lazy.force env.extra in + let typ' = csubst_subst subst typ in + let instance = inst_rels @ inst_vars in + let sign = val_of_named_context nc in + let sigma = !evdref in + let (sigma, e) = new_evar_instance sign sigma typ' ?src ?naming instance in + evdref := sigma; + e + +let e_new_type_evar env evdref ~src = + let (evd', s) = Evd.new_sort_variable Evd.univ_flexible_alg !evdref in + evdref := evd'; + e_new_evar env evdref ~src (EConstr.mkSort s) + +let hide_variable env expansion id = + let lvar = env.lvar in + if Id.Map.mem id lvar.ltac_genargs then + let lvar = match expansion with + | Name id' -> + (* We are typically in a situation [match id return P with ... end] + which we interpret as [match id' as id' return P with ... end], + with [P] interpreted in an environment where [id] is bound to [id']. + The variable is already bound to [id'], so nothing to do *) + lvar + | _ -> + (* We are typically in a situation [match id return P with ... end] + with [id] bound to a non-variable term [c]. We interpret as + [match c as id return P with ... end], and hides [id] while + interpreting [P], since it has become a binder and cannot be anymore be + substituted by a variable coming from the Ltac substitution. *) + { lvar with + ltac_uconstrs = Id.Map.remove id lvar.ltac_uconstrs; + ltac_constrs = Id.Map.remove id lvar.ltac_constrs; + ltac_genargs = Id.Map.remove id lvar.ltac_genargs } in + { env with lvar } + else + env + +let protected_get_type_of env sigma c = + try Retyping.get_type_of ~lax:true env sigma c + with Retyping.RetypeError _ -> + user_err + (str "Cannot reinterpret " ++ quote (print_constr c) ++ + str " in the current environment.") + +let invert_ltac_bound_name env id0 id = + try mkRel (pi1 (lookup_rel_id id (rel_context env.static_env))) + with Not_found -> + user_err (str "Ltac variable " ++ Id.print id0 ++ + str " depends on pattern variable name " ++ Id.print id ++ + str " which is not bound in current context.") + +let interp_ltac_variable ?loc typing_fun env sigma id = + (* Check if [id] is an ltac variable *) + try + let (ids,c) = Id.Map.find id env.lvar.ltac_constrs in + let subst = List.map (invert_ltac_bound_name env id) ids in + let c = substl subst c in + { uj_val = c; uj_type = protected_get_type_of env.renamed_env sigma c } + with Not_found -> + try + let {closure;term} = Id.Map.find id env.lvar.ltac_uconstrs in + let lvar = { + ltac_constrs = closure.typed; + ltac_uconstrs = closure.untyped; + ltac_idents = closure.idents; + ltac_genargs = Id.Map.empty; } + in + (* spiwack: I'm catching [Not_found] potentially too eagerly + here, as the call to the main pretyping function is caught + inside the try but I want to avoid refactoring this function + too much for now. *) + typing_fun {env with lvar} term + with Not_found -> + (* Check if [id] is a ltac variable not bound to a term *) + (* and build a nice error message *) + if Id.Map.mem id env.lvar.ltac_genargs then begin + let Geninterp.Val.Dyn (typ, _) = Id.Map.find id env.lvar.ltac_genargs in + user_err ?loc + (str "Variable " ++ Id.print id ++ str " should be bound to a term but is \ + bound to a " ++ Geninterp.Val.pr typ ++ str ".") + end; + raise Not_found + +module ConstrInterpObj = +struct + type ('r, 'g, 't) obj = + unbound_ltac_var_map -> env -> Evd.evar_map -> types -> 'g -> constr * Evd.evar_map + let name = "constr_interp" + let default _ = None +end + +module ConstrInterp = Genarg.Register(ConstrInterpObj) + +let register_constr_interp0 = ConstrInterp.register0 + +let interp_glob_genarg env sigma ty arg = + let open Genarg in + let GenArg (Glbwit tag, arg) = arg in + let interp = ConstrInterp.obj tag in + interp env.lvar.ltac_genargs env.renamed_env sigma ty arg diff --git a/pretyping/globEnv.mli b/pretyping/globEnv.mli new file mode 100644 index 0000000000..4038523211 --- /dev/null +++ b/pretyping/globEnv.mli @@ -0,0 +1,83 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Environ +open Evd +open EConstr +open Ltac_pretype + +(** To embed constr in glob_constr *) + +val register_constr_interp0 : + ('r, 'g, 't) Genarg.genarg_type -> + (unbound_ltac_var_map -> env -> evar_map -> types -> 'g -> constr * evar_map) -> unit + +(** {6 Pretyping name management} *) + +(** The following provides a level of abstraction for the kind of + environment used for type inference (so-called pretyping); in + particular: + - it supports that term variables can be interpreted as Ltac + variables pointing to the effective expected name + - it incrementally and lazily computes the renaming of rel + variables used to build purely-named evar contexts +*) + +(** Type of environment extended with naming and ltac interpretation data *) + +type t + +(** Build a pretyping environment from an ltac environment *) + +val make : env -> evar_map -> ltac_var_map -> t + +(** Export the underlying environement *) + +val env : t -> env + +val vars_of_env : t -> Id.Set.t + +(** Push to the environment, returning the declaration(s) with interpreted names *) + +val push_rel : evar_map -> rel_declaration -> t -> rel_declaration * t +val push_rel_context : ?force_names:bool -> evar_map -> rel_context -> t -> rel_context * t +val push_rec_types : evar_map -> Name.t array * constr array -> t -> Name.t array * t + +(** Declare an evar using renaming information *) + +val e_new_evar : t -> evar_map ref -> ?src:Evar_kinds.t Loc.located -> + ?naming:Namegen.intro_pattern_naming_expr -> constr -> constr + +val e_new_type_evar : t -> evar_map ref -> src:Evar_kinds.t Loc.located -> constr + +(** [hide_variable env na id] tells to hide the binding of [id] in + the ltac environment part of [env] and to additionally rebind + it to [id'] in case [na] is some [Name id']. It is useful e.g. + for the dual status of [y] as term and binder. This is the case + of [match y return p with ... end] which implicitly denotes + [match z as z return p with ... end] when [y] is bound to a + variable [z] and [match t as y return p with ... end] when [y] + is bound to a non-variable term [t]. In the latter case, the + binding of [y] to [t] should be hidden in [p]. *) + +val hide_variable : t -> Name.t -> Id.t -> t + +(** In case a variable is not bound by a term binder, look if it has + an interpretation as a term in the ltac_var_map *) + +val interp_ltac_variable : ?loc:Loc.t -> (t -> Glob_term.glob_constr -> unsafe_judgment) -> + t -> evar_map -> Id.t -> unsafe_judgment + +(** Interpreting a generic argument, typically a "ltac:(...)", taking + into account the possible renaming *) + +val interp_glob_genarg : t -> evar_map -> constr -> + Genarg.glob_generic_argument -> constr * evar_map diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index 24eb666828..bd13f1d00a 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -15,7 +15,6 @@ open Nameops open Globnames open Glob_term open Evar_kinds -open Ltac_pretype (* Untyped intermediate terms, after ASTs and before constr. *) @@ -577,22 +576,9 @@ let glob_constr_of_closed_cases_pattern p = match DAst.get p with let glob_constr_of_cases_pattern p = glob_constr_of_cases_pattern_aux false p -(**********************************************************************) -(* Interpreting ltac variables *) - -open Pp -open CErrors - -let ltac_interp_name { ltac_idents ; ltac_genargs } = function - | Anonymous -> Anonymous - | Name id as n -> - try Name (Id.Map.find id ltac_idents) - with Not_found -> - if Id.Map.mem id ltac_genargs then - user_err (str"Ltac variable"++spc()++ Id.print id ++ - spc()++str"is not bound to an identifier."++spc()++ - str"It cannot be used in a binder.") - else n +(* This has to be in some file... *) + +open Ltac_pretype let empty_lvar : ltac_var_map = { ltac_constrs = Id.Map.empty; diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli index c967f4e884..91a2ef9c1e 100644 --- a/pretyping/glob_ops.mli +++ b/pretyping/glob_ops.mli @@ -101,5 +101,4 @@ val glob_constr_of_cases_pattern : 'a cases_pattern_g -> 'a glob_constr_g val add_patterns_for_params_remove_local_defs : constructor -> 'a cases_pattern_g list -> 'a cases_pattern_g list -val ltac_interp_name : Ltac_pretype.ltac_var_map -> Name.t -> Name.t val empty_lvar : Ltac_pretype.ltac_var_map diff --git a/pretyping/inferCumulativity.ml b/pretyping/inferCumulativity.ml index eb283a0220..be79b8b07d 100644 --- a/pretyping/inferCumulativity.ml +++ b/pretyping/inferCumulativity.ml @@ -99,7 +99,7 @@ let rec infer_fterm cv_pb infos variances hd stk = | FEvar ((_,args),e) -> let variances = infer_stack infos variances stk in infer_vect infos variances (Array.map (mk_clos e) args) - | FRel _ -> variances + | FRel _ -> infer_stack infos variances stk | FFlex fl -> let variances = infer_table_key infos variances fl in infer_stack infos variances stk diff --git a/pretyping/ltac_pretype.ml b/pretyping/ltac_pretype.ml index be8579c2e5..ac59b96eef 100644 --- a/pretyping/ltac_pretype.ml +++ b/pretyping/ltac_pretype.ml @@ -64,5 +64,5 @@ type ltac_var_map = { ltac_idents: Id.t Id.Map.t; (** Ltac variables bound to identifiers *) ltac_genargs : unbound_ltac_var_map; - (** Ltac variables bound to other kinds of arguments *) + (** All Ltac variables (to pass on ltac subterms, and for error reporting) *) } diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 246acfc92e..20185363e6 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -123,7 +123,7 @@ let construct_of_constr_notnative const env tag (mind, _ as ind) u allargs = try if const then let ctyp = type_constructor mind mib u (mip.mind_nf_lc.(0)) params in - Retroknowledge.get_vm_decompile_constant_info env.retroknowledge (mkInd ind) tag, ctyp + Retroknowledge.get_vm_decompile_constant_info env.retroknowledge (GlobRef.IndRef ind) tag, ctyp else raise Not_found with Not_found -> diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index a315376aca..d10c00fa6e 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -38,19 +38,20 @@ open Reductionops open Type_errors open Typing open Globnames -open Nameops open Evarutil open Evardefine open Pretype_errors open Glob_term open Glob_ops +open GlobEnv open Evarconv -open Ltac_pretype module NamedDecl = Context.Named.Declaration type typing_constraint = OfType of types | IsType | WithoutTypeConstraint +let (!!) env = GlobEnv.env env + (************************************************************************) (* This concerns Cases *) open Inductive @@ -58,58 +59,6 @@ open Inductiveops (************************************************************************) -module ExtraEnv = -struct - -type t = { - env : Environ.env; - extra : Evarutil.ext_named_context Lazy.t; - (** Delay the computation of the evar extended environment *) -} - -let get_extra env sigma = - let avoid = Environ.ids_of_named_context_val (Environ.named_context_val env) in - Context.Rel.fold_outside (fun d acc -> push_rel_decl_to_named_context sigma d acc) - (rel_context env) ~init:(empty_csubst, avoid, named_context env) - -let make_env env sigma = { env = env; extra = lazy (get_extra env sigma) } -let rel_context env = rel_context env.env - -let push_rel sigma d env = { - env = push_rel d env.env; - extra = lazy (push_rel_decl_to_named_context sigma d (Lazy.force env.extra)); -} - -let pop_rel_context n env sigma = make_env (pop_rel_context n env.env) sigma - -let push_rel_context sigma ctx env = { - env = push_rel_context ctx env.env; - extra = lazy (List.fold_right (fun d acc -> push_rel_decl_to_named_context sigma d acc) ctx (Lazy.force env.extra)); -} - -let lookup_named id env = lookup_named id env.env - -let e_new_evar env evdref ?src ?naming typ = - let open Context.Named.Declaration in - let inst_vars = List.map (get_id %> mkVar) (named_context env.env) in - let inst_rels = List.rev (rel_list 0 (nb_rel env.env)) in - let (subst, _, nc) = Lazy.force env.extra in - let typ' = csubst_subst subst typ in - let instance = inst_rels @ inst_vars in - let sign = val_of_named_context nc in - let sigma = !evdref in - let (sigma, e) = new_evar_instance sign sigma typ' ?src ?naming instance in - evdref := sigma; - e - -let push_rec_types sigma (lna,typarray,_) env = - let ctxt = Array.map2_i (fun i na t -> Context.Rel.Declaration.LocalAssum (na, lift i t)) lna typarray in - Array.fold_left (fun e assum -> push_rel sigma assum e) env ctxt - -end - -open ExtraEnv - (* An auxiliary function for searching for fixpoint guard indexes *) exception Found of int array @@ -400,7 +349,7 @@ let adjust_evar_source evdref na c = let inh_conv_coerce_to_tycon ?loc resolve_tc env evdref j = function | None -> j | Some t -> - evd_comb2 (Coercion.inh_conv_coerce_to ?loc resolve_tc env.ExtraEnv.env) evdref j t + evd_comb2 (Coercion.inh_conv_coerce_to ?loc resolve_tc !!env) evdref j t let check_instance loc subst = function | [] -> () @@ -417,76 +366,21 @@ let orelse_name name name' = match name with | Anonymous -> name' | _ -> name -let ltac_interp_name_env k0 lvar env sigma = - (* envhd is the initial part of the env when pretype was called first *) - (* (in practice is is probably 0, but we have to grant the - specification of pretype which accepts to start with a non empty - rel_context) *) - (* tail is the part of the env enriched by pretyping *) - let n = Context.Rel.length (rel_context env) - k0 in - let ctxt,_ = List.chop n (rel_context env) in - let open Context.Rel.Declaration in - let ctxt' = List.Smart.map (map_name (ltac_interp_name lvar)) ctxt in - if List.equal (fun d1 d2 -> Name.equal (get_name d1) (get_name d2)) ctxt ctxt' then env - else push_rel_context sigma ctxt' (pop_rel_context n env sigma) - -let invert_ltac_bound_name lvar env id0 id = - let id' = Id.Map.find id lvar.ltac_idents in - try mkRel (pi1 (lookup_rel_id id' (rel_context env))) - with Not_found -> - user_err (str "Ltac variable " ++ Id.print id0 ++ - str " depends on pattern variable name " ++ Id.print id ++ - str " which is not bound in current context.") - -let protected_get_type_of env sigma c = - try Retyping.get_type_of ~lax:true env.ExtraEnv.env sigma c - with Retyping.RetypeError _ -> - user_err - (str "Cannot reinterpret " ++ quote (print_constr c) ++ - str " in the current environment.") - -let pretype_id pretype k0 loc env evdref lvar id = - let sigma = !evdref in +let pretype_id pretype k0 loc env evdref id = (* Look for the binder of [id] *) try - let (n,_,typ) = lookup_rel_id id (rel_context env) in + let (n,_,typ) = lookup_rel_id id (rel_context !!env) in { uj_val = mkRel n; uj_type = lift n typ } with Not_found -> - let env = ltac_interp_name_env k0 lvar env !evdref in - (* Check if [id] is an ltac variable *) - try - let (ids,c) = Id.Map.find id lvar.ltac_constrs in - let subst = List.map (invert_ltac_bound_name lvar env id) ids in - let c = substl subst c in - { uj_val = c; uj_type = protected_get_type_of env sigma c } - with Not_found -> try - let {closure;term} = Id.Map.find id lvar.ltac_uconstrs in - let lvar = { - ltac_constrs = closure.typed; - ltac_uconstrs = closure.untyped; - ltac_idents = closure.idents; - ltac_genargs = Id.Map.empty; } - in - (* spiwack: I'm catching [Not_found] potentially too eagerly - here, as the call to the main pretyping function is caught - inside the try but I want to avoid refactoring this function - too much for now. *) - pretype env evdref lvar term - with Not_found -> - (* Check if [id] is a ltac variable not bound to a term *) - (* and build a nice error message *) - if Id.Map.mem id lvar.ltac_genargs then begin - let Geninterp.Val.Dyn (typ, _) = Id.Map.find id lvar.ltac_genargs in - user_err ?loc - (str "Variable " ++ Id.print id ++ str " should be bound to a term but is \ - bound to a " ++ Geninterp.Val.pr typ ++ str ".") - end; - (* Check if [id] is a section or goal variable *) - try - { uj_val = mkVar id; uj_type = NamedDecl.get_type (lookup_named id env) } - with Not_found -> - (* [id] not found, standard error message *) - error_var_not_found ?loc id + try + GlobEnv.interp_ltac_variable ?loc (fun env -> pretype env evdref) env !evdref id + with Not_found -> + (* Check if [id] is a section or goal variable *) + try + { uj_val = mkVar id; uj_type = NamedDecl.get_type (lookup_named id !!env) } + with Not_found -> + (* [id] not found, standard error message *) + error_var_not_found ?loc id (*************************************************************************) (* Main pretyping function *) @@ -524,18 +418,18 @@ let pretype_global ?loc rigid env evd gr us = match us with | None -> evd, None | Some l -> - let _, ctx = Global.constr_of_global_in_context env.ExtraEnv.env gr in + let _, ctx = Global.constr_of_global_in_context !!env gr in let len = Univ.AUContext.size ctx in interp_instance ?loc evd ~len l in - let (sigma, c) = Evd.fresh_global ?loc ~rigid ?names:instance env.ExtraEnv.env evd gr in + let (sigma, c) = Evd.fresh_global ?loc ~rigid ?names:instance !!env evd gr in (sigma, c) let pretype_ref ?loc evdref env ref us = match ref with | VarRef id -> (* Section variable *) - (try make_judge (mkVar id) (NamedDecl.get_type (lookup_named id env)) + (try make_judge (mkVar id) (NamedDecl.get_type (lookup_named id !!env)) with Not_found -> (* This may happen if env is a goal env and section variables have been cleared - section variables should be different from goal @@ -544,7 +438,7 @@ let pretype_ref ?loc evdref env ref us = | ref -> let evd, c = pretype_global ?loc univ_flexible env !evdref ref us in let () = evdref := evd in - let ty = unsafe_type_of env.ExtraEnv.env evd c in + let ty = unsafe_type_of !!env evd c in make_judge c ty let judge_of_Type ?loc evd s = @@ -560,31 +454,13 @@ let pretype_sort ?loc evdref = function | GType s -> evd_comb1 (judge_of_Type ?loc) evdref s let new_type_evar env evdref loc = - let sigma = !evdref in - let (sigma, (e, _)) = - Evarutil.new_type_evar env.ExtraEnv.env sigma - univ_flexible_alg ~src:(loc,Evar_kinds.InternalHole) - in - evdref := sigma; - e - -module ConstrInterpObj = -struct - type ('r, 'g, 't) obj = - unbound_ltac_var_map -> env -> evar_map -> types -> 'g -> constr * evar_map - let name = "constr_interp" - let default _ = None -end - -module ConstrInterp = Genarg.Register(ConstrInterpObj) - -let register_constr_interp0 = ConstrInterp.register0 + e_new_type_evar env evdref ~src:(Loc.tag ?loc Evar_kinds.InternalHole) (* [pretype tycon env evdref lvar lmeta cstr] attempts to type [cstr] *) (* in environment [env], with existential variables [evdref] and *) (* the type constraint tycon *) -let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdref (lvar : ltac_var_map) t = +let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) evdref t = let inh_conv_coerce_to_tycon ?loc = inh_conv_coerce_to_tycon ?loc resolve_tc in let pretype_type = pretype_type k0 resolve_tc in let pretype = pretype k0 resolve_tc in @@ -598,7 +474,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre | GVar id -> inh_conv_coerce_to_tycon ?loc env evdref - (pretype_id (fun e r l t -> pretype tycon e r l t) k0 loc env evdref lvar id) + (pretype_id (fun e r t -> pretype tycon e r t) k0 loc env evdref id) tycon | GEvar (id, inst) -> @@ -609,13 +485,12 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre with Not_found -> user_err ?loc (str "Unknown existential variable.") in let hyps = evar_filtered_context (Evd.find !evdref evk) in - let args = pretype_instance k0 resolve_tc env evdref lvar loc hyps evk inst in + let args = pretype_instance k0 resolve_tc env evdref loc hyps evk inst in let c = mkEvar (evk, args) in - let j = (Retyping.get_judgment_of env.ExtraEnv.env !evdref c) in + let j = (Retyping.get_judgment_of !!env !evdref c) in inh_conv_coerce_to_tycon ?loc env evdref j tycon | GPatVar kind -> - let env = ltac_interp_name_env k0 lvar env !evdref in let ty = match tycon with | Some ty -> ty @@ -624,48 +499,40 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre { uj_val = e_new_evar env evdref ~src:(loc,k) ty; uj_type = ty } | GHole (k, naming, None) -> - let env = ltac_interp_name_env k0 lvar env !evdref in let ty = match tycon with | Some ty -> ty - | None -> - new_type_evar env evdref loc in + | None -> new_type_evar env evdref loc in { uj_val = e_new_evar env evdref ~src:(loc,k) ~naming ty; uj_type = ty } | GHole (k, _naming, Some arg) -> - let env = ltac_interp_name_env k0 lvar env !evdref in let ty = match tycon with | Some ty -> ty - | None -> - new_type_evar env evdref loc in - let open Genarg in - let ist = lvar.ltac_genargs in - let GenArg (Glbwit tag, arg) = arg in - let interp = ConstrInterp.obj tag in - let (c, sigma) = interp ist env.ExtraEnv.env !evdref ty arg in + | None -> new_type_evar env evdref loc in + let (c, sigma) = GlobEnv.interp_glob_genarg env !evdref ty arg in let () = evdref := sigma in { uj_val = c; uj_type = ty } | GRec (fixkind,names,bl,lar,vdef) -> let rec type_bl env ctxt = function - [] -> ctxt + | [] -> ctxt | (na,bk,None,ty)::bl -> - let ty' = pretype_type empty_valcon env evdref lvar ty in + let ty' = pretype_type empty_valcon env evdref ty in let dcl = LocalAssum (na, ty'.utj_val) in - let dcl' = LocalAssum (ltac_interp_name lvar na,ty'.utj_val) in - type_bl (push_rel !evdref dcl env) (Context.Rel.add dcl' ctxt) bl + let dcl', env = push_rel !evdref dcl env in + type_bl env (Context.Rel.add dcl' ctxt) bl | (na,bk,Some bd,ty)::bl -> - let ty' = pretype_type empty_valcon env evdref lvar ty in - let bd' = pretype (mk_tycon ty'.utj_val) env evdref lvar bd in + let ty' = pretype_type empty_valcon env evdref ty in + let bd' = pretype (mk_tycon ty'.utj_val) env evdref bd in let dcl = LocalDef (na, bd'.uj_val, ty'.utj_val) in - let dcl' = LocalDef (ltac_interp_name lvar na, bd'.uj_val, ty'.utj_val) in - type_bl (push_rel !evdref dcl env) (Context.Rel.add dcl' ctxt) bl in + let dcl', env = push_rel !evdref dcl env in + type_bl env (Context.Rel.add dcl' ctxt) bl in let ctxtv = Array.map (type_bl env Context.Rel.empty) bl in let larj = Array.map2 (fun e ar -> - pretype_type empty_valcon (push_rel_context !evdref e env) evdref lvar ar) + pretype_type empty_valcon (snd (push_rel_context !evdref e env)) evdref ar) ctxtv lar in let lara = Array.map (fun a -> a.utj_val) larj in let ftys = Array.map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in @@ -678,14 +545,14 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre | GFix (vn,i) -> i | GCoFix i -> i in - begin match conv env.ExtraEnv.env !evdref ftys.(fixi) t with + begin match conv !!env !evdref ftys.(fixi) t with | None -> () | Some sigma -> evdref := sigma end | None -> () in (* Note: bodies are not used by push_rec_types, so [||] is safe *) - let newenv = push_rec_types !evdref (names,ftys,[||]) env in + let names,newenv = push_rec_types !evdref (names,ftys) env in let vdefj = Array.map2_i (fun i ctxt def -> @@ -694,12 +561,12 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let (ctxt,ty) = decompose_prod_n_assum !evdref (Context.Rel.length ctxt) (lift nbfix ftys.(i)) in - let nenv = push_rel_context !evdref ctxt newenv in - let j = pretype (mk_tycon ty) nenv evdref lvar def in + let ctxt,nenv = push_rel_context !evdref ctxt newenv in + let j = pretype (mk_tycon ty) nenv evdref def in { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt; uj_type = it_mkProd_or_LetIn j.uj_type ctxt }) ctxtv vdef in - evdref := Typing.check_type_fixpoint ?loc env.ExtraEnv.env !evdref names ftys vdefj; + evdref := Typing.check_type_fixpoint ?loc !!env !evdref names ftys vdefj; let nf c = nf_evar !evdref c in let ftys = Array.map nf ftys in (** FIXME *) let fdefs = Array.map (fun x -> nf (j_val x)) vdefj in @@ -721,13 +588,13 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let fixdecls = (names,ftys,fdefs) in let indexes = search_guard - ?loc env.ExtraEnv.env possible_indexes (nf_fix !evdref fixdecls) + ?loc !!env possible_indexes (nf_fix !evdref fixdecls) in make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i) | GCoFix i -> let fixdecls = (names,ftys,fdefs) in let cofix = (i, fixdecls) in - (try check_cofix env.ExtraEnv.env (i, nf_fix !evdref fixdecls) + (try check_cofix !!env (i, nf_fix !evdref fixdecls) with reraise -> let (e, info) = CErrors.push reraise in let info = Option.cata (Loc.add_loc info) info loc in @@ -742,11 +609,11 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre | GProj (p, c) -> (* TODO: once GProj is used as an input syntax, use bidirectional typing here *) - let cj = pretype empty_tycon env evdref lvar c in - judge_of_projection env.ExtraEnv.env !evdref p cj + let cj = pretype empty_tycon env evdref c in + judge_of_projection !!env !evdref p cj | GApp (f,args) -> - let fj = pretype empty_tycon env evdref lvar f in + let fj = pretype empty_tycon env evdref f in let floc = loc_of_glob_constr f in let length = List.length args in let candargs = @@ -762,7 +629,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre if Int.equal npars 0 then [] else try - let IndType (indf, args) = find_rectype env.ExtraEnv.env !evdref ty in + let IndType (indf, args) = find_rectype !!env !evdref ty in let ((ind',u'),pars) = dest_ind_family indf in if eq_ind ind ind' then List.map EConstr.of_constr pars else (* Let the usual code throw an error *) [] @@ -784,17 +651,17 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre | [] -> resj | c::rest -> let argloc = loc_of_glob_constr c in - let resj = evd_comb1 (Coercion.inh_app_fun resolve_tc env.ExtraEnv.env) evdref resj in - let resty = whd_all env.ExtraEnv.env !evdref resj.uj_type in + let resj = evd_comb1 (Coercion.inh_app_fun resolve_tc !!env) evdref resj in + let resty = whd_all !!env !evdref resj.uj_type in match EConstr.kind !evdref resty with | Prod (na,c1,c2) -> let tycon = Some c1 in - let hj = pretype tycon env evdref lvar c in + let hj = pretype tycon env evdref c in let candargs, ujval = match candargs with | [] -> [], j_val hj | arg :: args -> - begin match conv env.ExtraEnv.env !evdref (j_val hj) arg with + begin match conv !!env !evdref (j_val hj) arg with | Some sigma -> evdref := sigma; args, nf_evar !evdref (j_val hj) | None -> @@ -807,104 +674,96 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre apply_rec env (n+1) j candargs rest | _ -> - let hj = pretype empty_tycon env evdref lvar c in + let hj = pretype empty_tycon env evdref c in error_cant_apply_not_functional - ?loc:(Loc.merge_opt floc argloc) env.ExtraEnv.env !evdref + ?loc:(Loc.merge_opt floc argloc) !!env !evdref resj [|hj|] in let resj = apply_rec env 1 fj candargs args in let resj = match EConstr.kind !evdref resj.uj_val with | App (f,args) -> - if is_template_polymorphic env.ExtraEnv.env !evdref f then + if is_template_polymorphic !!env !evdref f then (* Special case for inductive type applications that must be refreshed right away. *) let c = mkApp (f, args) in - let c = evd_comb1 (Evarsolve.refresh_universes (Some true) env.ExtraEnv.env) evdref c in - let t = Retyping.get_type_of env.ExtraEnv.env !evdref c in + let c = evd_comb1 (Evarsolve.refresh_universes (Some true) !!env) evdref c in + let t = Retyping.get_type_of !!env !evdref c in make_judge c (* use this for keeping evars: resj.uj_val *) t else resj | _ -> resj in inh_conv_coerce_to_tycon ?loc env evdref resj tycon - | GLambda(name,bk,c1,c2) -> + | GLambda(name,bk,c1,c2) -> let tycon' = evd_comb1 (fun evd tycon -> match tycon with | None -> evd, tycon | Some ty -> - let evd, ty' = Coercion.inh_coerce_to_prod ?loc env.ExtraEnv.env evd ty in + let evd, ty' = Coercion.inh_coerce_to_prod ?loc !!env evd ty in evd, Some ty') evdref tycon in - let (name',dom,rng) = evd_comb1 (split_tycon ?loc env.ExtraEnv.env) evdref tycon' in + let (name',dom,rng) = evd_comb1 (split_tycon ?loc !!env) evdref tycon' in let dom_valcon = valcon_of_tycon dom in - let j = pretype_type dom_valcon env evdref lvar c1 in - (* The name specified by ltac is used also to create bindings. So - the substitution must also be applied on variables before they are - looked up in the rel context. *) + let j = pretype_type dom_valcon env evdref c1 in let var = LocalAssum (name, j.utj_val) in - let j' = pretype rng (push_rel !evdref var env) evdref lvar c2 in - let name = ltac_interp_name lvar name in - let resj = judge_of_abstraction env.ExtraEnv.env (orelse_name name name') j j' in + let var',env' = push_rel !evdref var env in + let j' = pretype rng env' evdref c2 in + let name = get_name var' in + let resj = judge_of_abstraction !!env (orelse_name name name') j j' in inh_conv_coerce_to_tycon ?loc env evdref resj tycon - | GProd(name,bk,c1,c2) -> - let j = pretype_type empty_valcon env evdref lvar c1 in - (* The name specified by ltac is used also to create bindings. So - the substitution must also be applied on variables before they are - looked up in the rel context. *) - let j' = match name with + | GProd(name,bk,c1,c2) -> + let j = pretype_type empty_valcon env evdref c1 in + let name, j' = match name with | Anonymous -> - let j = pretype_type empty_valcon env evdref lvar c2 in - { j with utj_val = lift 1 j.utj_val } + let j = pretype_type empty_valcon env evdref c2 in + name, { j with utj_val = lift 1 j.utj_val } | Name _ -> let var = LocalAssum (name, j.utj_val) in - let env' = push_rel !evdref var env in - pretype_type empty_valcon env' evdref lvar c2 + let var, env' = push_rel !evdref var env in + get_name var, pretype_type empty_valcon env' evdref c2 in - let name = ltac_interp_name lvar name in let resj = try - judge_of_product env.ExtraEnv.env name j j' + judge_of_product !!env name j j' with TypeError _ as e -> 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 env evdref resj tycon - | GLetIn(name,c1,t,c2) -> + | GLetIn(name,c1,t,c2) -> let tycon1 = match t with | Some t -> - mk_tycon (pretype_type empty_valcon env evdref lvar t).utj_val + mk_tycon (pretype_type empty_valcon env evdref t).utj_val | None -> empty_tycon in - let j = pretype tycon1 env evdref lvar c1 in + let j = pretype tycon1 env evdref c1 in let t = evd_comb1 (Evarsolve.refresh_universes - ~onlyalg:true ~status:Evd.univ_flexible (Some false) env.ExtraEnv.env) + ~onlyalg:true ~status:Evd.univ_flexible (Some false) !!env) evdref j.uj_type in - (* The name specified by ltac is used also to create bindings. So - the substitution must also be applied on variables before they are - looked up in the rel context. *) let var = LocalDef (name, j.uj_val, t) in let tycon = lift_tycon 1 tycon in - let j' = pretype tycon (push_rel !evdref var env) evdref lvar c2 in - let name = ltac_interp_name lvar name in + let var, env = push_rel !evdref var env in + let j' = pretype tycon env evdref c2 in + let name = get_name var in { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ; uj_type = subst1 j.uj_val j'.uj_type } | GLetTuple (nal,(na,po),c,d) -> - let cj = pretype empty_tycon env evdref lvar c in + let cj = pretype empty_tycon env evdref c in let (IndType (indf,realargs)) = - try find_rectype env.ExtraEnv.env !evdref cj.uj_type + try find_rectype !!env !evdref cj.uj_type with Not_found -> let cloc = loc_of_glob_constr c in - error_case_not_inductive ?loc:cloc env.ExtraEnv.env !evdref cj + error_case_not_inductive ?loc:cloc !!env !evdref cj in let ind = fst (fst (dest_ind_family indf)) in - let cstrs = get_constructors env.ExtraEnv.env indf in + let cstrs = get_constructors !!env indf in if not (Int.equal (Array.length cstrs) 1) then user_err ?loc (str "Destructing let is only for inductive types" ++ str " with one constructor."); @@ -914,7 +773,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre int cs.cs_nargs ++ str " variables."); let fsign, record = let set_name na d = set_name na (map_rel_decl EConstr.of_constr d) in - match Environ.get_projections env.ExtraEnv.env ind with + match Environ.get_projections !!env ind with | None -> List.map2 set_name (List.rev nal) cs.cs_args, false | Some ps -> @@ -933,108 +792,97 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let fsign = if Flags.version_strictly_greater Flags.V8_6 then Context.Rel.map (whd_betaiota !evdref) fsign else fsign (* beta-iota-normalization regression in 8.5 and 8.6 *) in + let fsign,env_f = push_rel_context !evdref fsign env in let obj ind p v f = - if not record then - let nal = List.map (fun na -> ltac_interp_name lvar na) nal in - let nal = List.rev nal in - let fsign = List.map2 set_name nal fsign in + if not record then let f = it_mkLambda_or_LetIn f fsign in - let ci = make_case_info env.ExtraEnv.env (fst ind) LetStyle in + let ci = make_case_info !!env (fst ind) LetStyle in mkCase (ci, p, cj.uj_val,[|f|]) else it_mkLambda_or_LetIn f fsign in - let env_f = push_rel_context !evdref fsign env in - (* Make dependencies from arity signature impossible *) + (* Make dependencies from arity signature impossible *) let arsgn = - let arsgn,_ = get_arity env.ExtraEnv.env indf in + let arsgn,_ = get_arity !!env indf in List.map (set_name Anonymous) arsgn in - let indt = build_dependent_inductive env.ExtraEnv.env indf in + let indt = build_dependent_inductive !!env indf in let psign = LocalAssum (na, indt) :: arsgn in (* For locating names in [po] *) - let predlvar = Cases.make_return_predicate_ltac_lvar !evdref na c cj.uj_val lvar in - let psign' = LocalAssum (ltac_interp_name predlvar na, indt) :: arsgn in - let psign' = List.map (fun d -> map_rel_decl EConstr.of_constr d) psign' in - let psign' = Namegen.name_context env.ExtraEnv.env !evdref psign' in (* For naming abstractions in [po] *) let psign = List.map (fun d -> map_rel_decl EConstr.of_constr d) psign in + let predenv = Cases.make_return_predicate_ltac_lvar env !evdref na c cj.uj_val in let nar = List.length arsgn in + let psign',env_p = push_rel_context ~force_names:true !evdref psign predenv in (match po with | Some p -> - let env_p = push_rel_context !evdref psign env in - let pj = pretype_type empty_valcon env_p evdref predlvar p in + let pj = pretype_type empty_valcon env_p evdref p in let ccl = nf_evar !evdref pj.utj_val in let p = it_mkLambda_or_LetIn ccl psign' in let inst = (Array.map_to_list EConstr.of_constr cs.cs_concl_realargs) @[EConstr.of_constr (build_dependent_constructor cs)] in let lp = lift cs.cs_nargs p in - let fty = hnf_lam_applist env.ExtraEnv.env !evdref lp inst in - let fj = pretype (mk_tycon fty) env_f evdref lvar d in + let fty = hnf_lam_applist !!env !evdref lp inst in + let fj = pretype (mk_tycon fty) env_f evdref d in let v = let ind,_ = dest_ind_family indf in - Typing.check_allowed_sort env.ExtraEnv.env !evdref ind cj.uj_val p; + Typing.check_allowed_sort !!env !evdref ind cj.uj_val p; obj ind p cj.uj_val fj.uj_val in { uj_val = v; uj_type = (substl (realargs@[cj.uj_val]) ccl) } | None -> let tycon = lift_tycon cs.cs_nargs tycon in - let fj = pretype tycon env_f evdref predlvar d in + let fj = pretype tycon env_f evdref d in let ccl = nf_evar !evdref fj.uj_type in let ccl = if noccur_between !evdref 1 cs.cs_nargs ccl then lift (- cs.cs_nargs) ccl else - error_cant_find_case_type ?loc env.ExtraEnv.env !evdref + error_cant_find_case_type ?loc !!env !evdref cj.uj_val in (* let ccl = refresh_universes ccl in *) let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign' in let v = let ind,_ = dest_ind_family indf in - Typing.check_allowed_sort env.ExtraEnv.env !evdref ind cj.uj_val p; + Typing.check_allowed_sort !!env !evdref ind cj.uj_val p; obj ind p cj.uj_val fj.uj_val in { uj_val = v; uj_type = ccl }) | GIf (c,(na,po),b1,b2) -> - let cj = pretype empty_tycon env evdref lvar c in + let cj = pretype empty_tycon env evdref c in let (IndType (indf,realargs)) = - try find_rectype env.ExtraEnv.env !evdref cj.uj_type + try find_rectype !!env !evdref cj.uj_type with Not_found -> let cloc = loc_of_glob_constr c in - error_case_not_inductive ?loc:cloc env.ExtraEnv.env !evdref cj in - let cstrs = get_constructors env.ExtraEnv.env indf in + error_case_not_inductive ?loc:cloc !!env !evdref cj in + let cstrs = get_constructors !!env indf in if not (Int.equal (Array.length cstrs) 2) then user_err ?loc (str "If is only for inductive types with two constructors."); let arsgn = - let arsgn,_ = get_arity env.ExtraEnv.env indf in + let arsgn,_ = get_arity !!env indf in (* Make dependencies from arity signature impossible *) List.map (set_name Anonymous) arsgn in let nar = List.length arsgn in - let indt = build_dependent_inductive env.ExtraEnv.env indf in + let indt = build_dependent_inductive !!env indf in let psign = LocalAssum (na, indt) :: arsgn in (* For locating names in [po] *) - let predlvar = Cases.make_return_predicate_ltac_lvar !evdref na c cj.uj_val lvar in - let psign' = LocalAssum (ltac_interp_name predlvar na, indt) :: arsgn in - let psign' = List.map (fun d -> map_rel_decl EConstr.of_constr d) psign' in - let psign' = Namegen.name_context env.ExtraEnv.env !evdref psign' in (* For naming abstractions in [po] *) let psign = List.map (fun d -> map_rel_decl EConstr.of_constr d) psign in + let predenv = Cases.make_return_predicate_ltac_lvar env !evdref na c cj.uj_val in + let psign,env_p = push_rel_context !evdref psign predenv in let pred,p = match po with | Some p -> - let env_p = push_rel_context !evdref psign env in - let pj = pretype_type empty_valcon env_p evdref predlvar p in + let pj = pretype_type empty_valcon env_p evdref p in let ccl = nf_evar !evdref pj.utj_val in - let pred = it_mkLambda_or_LetIn ccl psign' in + let pred = it_mkLambda_or_LetIn ccl psign in let typ = lift (- nar) (beta_applist !evdref (pred,[cj.uj_val])) in pred, typ | None -> let p = match tycon with | Some ty -> ty - | None -> - let env = ltac_interp_name_env k0 lvar env !evdref in - new_type_evar env evdref loc + | None -> new_type_evar env evdref loc in - it_mkLambda_or_LetIn (lift (nar+1) p) psign', p in + it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in let pred = nf_evar !evdref pred in let p = nf_evar !evdref p in let f cs b = @@ -1049,85 +897,83 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let csgn = List.map (set_name Anonymous) cs_args in - let env_c = push_rel_context !evdref csgn env in - let bj = pretype (mk_tycon pi) env_c evdref lvar b in + let _,env_c = push_rel_context !evdref csgn env in + let bj = pretype (mk_tycon pi) env_c evdref b in it_mkLambda_or_LetIn bj.uj_val cs_args in let b1 = f cstrs.(0) b1 in let b2 = f cstrs.(1) b2 in let v = let ind,_ = dest_ind_family indf in - let ci = make_case_info env.ExtraEnv.env (fst ind) IfStyle in + let ci = make_case_info !!env (fst ind) IfStyle in let pred = nf_evar !evdref pred in - Typing.check_allowed_sort env.ExtraEnv.env !evdref ind cj.uj_val pred; + Typing.check_allowed_sort !!env !evdref ind cj.uj_val pred; mkCase (ci, pred, cj.uj_val, [|b1;b2|]) in let cj = { uj_val = v; uj_type = p } in inh_conv_coerce_to_tycon ?loc env evdref cj tycon | GCases (sty,po,tml,eqns) -> - Cases.compile_cases ?loc sty - ((fun vtyc env evdref -> pretype vtyc (make_env env !evdref) evdref),evdref) - tycon env.ExtraEnv.env (* loc *) lvar (po,tml,eqns) + Cases.compile_cases ?loc sty (pretype,evdref) tycon env (po,tml,eqns) | GCast (c,k) -> let cj = match k with | CastCoerce -> - let cj = pretype empty_tycon env evdref lvar c in - evd_comb1 (Coercion.inh_coerce_to_base ?loc env.ExtraEnv.env) evdref cj + let cj = pretype empty_tycon env evdref c in + evd_comb1 (Coercion.inh_coerce_to_base ?loc !!env) evdref cj | CastConv t | CastVM t | CastNative t -> let k = (match k with CastVM _ -> VMcast | CastNative _ -> NATIVEcast | _ -> DEFAULTcast) in - let tj = pretype_type empty_valcon env evdref lvar t in + let tj = pretype_type empty_valcon env evdref t in let tval = evd_comb1 (Evarsolve.refresh_universes - ~onlyalg:true ~status:Evd.univ_flexible (Some false) env.ExtraEnv.env) + ~onlyalg:true ~status:Evd.univ_flexible (Some false) !!env) evdref tj.utj_val in let tval = nf_evar !evdref tval in let cj, tval = match k with | VMcast -> - let cj = pretype empty_tycon env evdref lvar c in + let cj = pretype empty_tycon env evdref c in let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tval in if not (occur_existential !evdref cty || occur_existential !evdref tval) then - match Reductionops.vm_infer_conv env.ExtraEnv.env !evdref cty tval with + match Reductionops.vm_infer_conv !!env !evdref cty tval with | Some evd -> (evdref := evd; cj, tval) | None -> - error_actual_type ?loc env.ExtraEnv.env !evdref cj tval - (ConversionFailed (env.ExtraEnv.env,cty,tval)) + error_actual_type ?loc !!env !evdref cj tval + (ConversionFailed (!!env,cty,tval)) else user_err ?loc (str "Cannot check cast with vm: " ++ str "unresolved arguments remain.") | NATIVEcast -> - let cj = pretype empty_tycon env evdref lvar c in + let cj = pretype empty_tycon env evdref c in let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tval in begin - match Nativenorm.native_infer_conv env.ExtraEnv.env !evdref cty tval with + match Nativenorm.native_infer_conv !!env !evdref cty tval with | Some evd -> (evdref := evd; cj, tval) | None -> - error_actual_type ?loc env.ExtraEnv.env !evdref cj tval - (ConversionFailed (env.ExtraEnv.env,cty,tval)) + error_actual_type ?loc !!env !evdref cj tval + (ConversionFailed (!!env,cty,tval)) end | _ -> - pretype (mk_tycon tval) env evdref lvar c, tval + pretype (mk_tycon tval) env evdref c, tval in let v = mkCast (cj.uj_val, k, tval) in { uj_val = v; uj_type = tval } in inh_conv_coerce_to_tycon ?loc env evdref cj tycon -and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update = +and pretype_instance k0 resolve_tc env evdref loc hyps evk update = let f decl (subst,update) = let id = NamedDecl.get_id decl in let t = replace_vars subst (NamedDecl.get_type decl) in let c, update = try let c = List.assoc id update in - let c = pretype k0 resolve_tc (mk_tycon t) env evdref lvar c in + let c = pretype k0 resolve_tc (mk_tycon t) env evdref c in c.uj_val, List.remove_assoc id update with Not_found -> try - let (n,_,t') = lookup_rel_id id (rel_context env) in - if is_conv env.ExtraEnv.env !evdref t (lift n t') then mkRel n, update else raise Not_found + let (n,_,t') = lookup_rel_id id (rel_context !!env) in + if is_conv !!env !evdref t (lift n t') then mkRel n, update else raise Not_found with Not_found -> try - let t' = env |> lookup_named id |> NamedDecl.get_type in - if is_conv env.ExtraEnv.env !evdref t t' then mkVar id, update else raise Not_found + let t' = !!env |> lookup_named id |> NamedDecl.get_type in + if is_conv !!env !evdref t t' then mkVar id, update else raise Not_found with Not_found -> user_err ?loc (str "Cannot interpret " ++ pr_existential_key !evdref evk ++ @@ -1137,19 +983,19 @@ and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update = check_instance loc subst inst; Array.map_of_list snd subst -(* [pretype_type valcon env evdref lvar c] coerces [c] into a type *) -and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar c = match DAst.get c with +(* [pretype_type valcon env evdref c] coerces [c] into a type *) +and pretype_type k0 resolve_tc valcon (env : GlobEnv.t) evdref c = match DAst.get c with | GHole (knd, naming, None) -> let loc = loc_of_glob_constr c in (match valcon with | Some v -> let s = let sigma = !evdref in - let t = Retyping.get_type_of env.ExtraEnv.env sigma v in - match EConstr.kind sigma (whd_all env.ExtraEnv.env sigma t) with + let t = Retyping.get_type_of !!env sigma v in + match EConstr.kind sigma (whd_all !!env sigma t) with | Sort s -> ESorts.kind sigma s | Evar ev when is_Type sigma (existential_type sigma ev) -> - evd_comb1 (define_evar_as_sort env.ExtraEnv.env) evdref ev + evd_comb1 (define_evar_as_sort !!env) evdref ev | _ -> anomaly (Pp.str "Found a type constraint which is not a type.") in (* Correction of bug #5315 : we need to define an evar for *all* holes *) @@ -1160,40 +1006,39 @@ and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar c = match D { utj_val = v; utj_type = s } | None -> - let env = ltac_interp_name_env k0 lvar env !evdref in let s = evd_comb0 (new_sort_variable univ_flexible_alg) evdref in { utj_val = e_new_evar env evdref ~src:(loc, knd) ~naming (mkSort s); utj_type = s}) | _ -> - let j = pretype k0 resolve_tc empty_tycon env evdref lvar c in + let j = pretype k0 resolve_tc empty_tycon env evdref c in let loc = loc_of_glob_constr c in - let tj = evd_comb1 (Coercion.inh_coerce_to_sort ?loc env.ExtraEnv.env) evdref j in + let tj = evd_comb1 (Coercion.inh_coerce_to_sort ?loc !!env) evdref j in match valcon with | None -> tj | Some v -> - begin match cumul env.ExtraEnv.env !evdref v tj.utj_val with + begin match cumul !!env !evdref v tj.utj_val with | Some sigma -> evdref := sigma; tj | None -> error_unexpected_type - ?loc:(loc_of_glob_constr c) env.ExtraEnv.env !evdref tj.utj_val v + ?loc:(loc_of_glob_constr c) !!env !evdref tj.utj_val v end let ise_pretype_gen flags env sigma lvar kind c = - let env = make_env env sigma in + let env = GlobEnv.make env sigma lvar in let evdref = ref sigma in - let k0 = Context.Rel.length (rel_context env) in + let k0 = Context.Rel.length (rel_context !!env) in let c', c'_ty = match kind with | WithoutTypeConstraint -> - let j = pretype k0 flags.use_typeclasses empty_tycon env evdref lvar c in + let j = pretype k0 flags.use_typeclasses empty_tycon env evdref c in j.uj_val, j.uj_type | OfType exptyp -> - let j = pretype k0 flags.use_typeclasses (mk_tycon exptyp) env evdref lvar c in + let j = pretype k0 flags.use_typeclasses (mk_tycon exptyp) env evdref c in j.uj_val, j.uj_type | IsType -> - let tj = pretype_type k0 flags.use_typeclasses empty_valcon env evdref lvar c in + let tj = pretype_type k0 flags.use_typeclasses empty_valcon env evdref c in tj.utj_val, mkSort tj.utj_type in - process_inference_flags flags env.ExtraEnv.env sigma (!evdref,c',c'_ty) + process_inference_flags flags !!env sigma (!evdref,c',c'_ty) let default_inference_flags fail = { use_typeclasses = true; @@ -1236,7 +1081,7 @@ let understand_ltac flags env sigma lvar kind c = (sigma, c) let pretype k0 resolve_tc typcon env evdref lvar t = - pretype k0 resolve_tc typcon (make_env env !evdref) evdref lvar t + pretype k0 resolve_tc typcon (GlobEnv.make env !evdref lvar) evdref t let pretype_type k0 resolve_tc valcon env evdref lvar t = - pretype_type k0 resolve_tc valcon (make_env env !evdref) evdref lvar t + pretype_type k0 resolve_tc valcon (GlobEnv.make env !evdref lvar) evdref t diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index 73f5b77e0e..fcc361b16b 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -122,11 +122,3 @@ val pretype_type : val ise_pretype_gen : inference_flags -> env -> evar_map -> ltac_var_map -> typing_constraint -> glob_constr -> evar_map * constr * types - -(**/**) - -(** To embed constr in glob_constr *) - -val register_constr_interp0 : - ('r, 'g, 't) Genarg.genarg_type -> - (unbound_ltac_var_map -> env -> evar_map -> types -> 'g -> constr * evar_map) -> unit diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib index 5da5aff449..d0359b43f4 100644 --- a/pretyping/pretyping.mllib +++ b/pretyping/pretyping.mllib @@ -32,6 +32,7 @@ Program Coercion Detyping Indrec +GlobEnv Cases Pretyping Unification diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 2f861c117b..bd41e61b34 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -192,11 +192,11 @@ let rec assoc_pat a = function let object_table = - Summary.ref (Refmap.empty : ((cs_pattern * constr) * obj_typ) list Refmap.t) + Summary.ref (GlobRef.Map.empty : ((cs_pattern * constr) * obj_typ) list GlobRef.Map.t) ~name:"record-canonical-structs" let canonical_projections () = - Refmap.fold (fun x -> List.fold_right (fun ((y,_),c) acc -> ((x,y),c)::acc)) + GlobRef.Map.fold (fun x -> List.fold_right (fun ((y,_),c) acc -> ((x,y),c)::acc)) !object_table [] let keep_true_projections projs kinds = @@ -289,11 +289,11 @@ let warn_redundant_canonical_projection = let add_canonical_structure warn o = let lo = compute_canonical_projections warn o in List.iter (fun ((proj,(cs_pat,_ as pat)),s) -> - let l = try Refmap.find proj !object_table with Not_found -> [] in + let l = try GlobRef.Map.find proj !object_table with Not_found -> [] in let ocs = try Some (assoc_pat cs_pat l) with Not_found -> None in match ocs with - | None -> object_table := Refmap.add proj ((pat,s)::l) !object_table; + | None -> object_table := GlobRef.Map.add proj ((pat,s)::l) !object_table; | Some (c, cs) -> let old_can_s = (Termops.print_constr (EConstr.of_constr cs.o_DEF)) and new_can_s = (Termops.print_constr (EConstr.of_constr s.o_DEF)) in @@ -372,18 +372,18 @@ let declare_canonical_structure ref = add_canonical_structure (check_and_decompose_canonical_structure ref) let lookup_canonical_conversion (proj,pat) = - assoc_pat pat (Refmap.find proj !object_table) + assoc_pat pat (GlobRef.Map.find proj !object_table) let decompose_projection sigma c args = match EConstr.kind sigma c with | Const (c, u) -> let n = find_projection_nparams (ConstRef c) in (** Check if there is some canonical projection attached to this structure *) - let _ = Refmap.find (ConstRef c) !object_table in + let _ = GlobRef.Map.find (ConstRef c) !object_table in let arg = Stack.nth args n in arg | Proj (p, c) -> - let _ = Refmap.find (ConstRef (Projection.constant p)) !object_table in + let _ = GlobRef.Map.find (ConstRef (Projection.constant p)) !object_table in c | _ -> raise Not_found diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index ba40262815..f4c8a6cd66 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -88,6 +88,7 @@ let set_reduction_effect x funkey = (** Machinery to custom the behavior of the reduction *) module ReductionBehaviour = struct open Globnames + open Names open Libobject type t = { @@ -97,7 +98,7 @@ module ReductionBehaviour = struct } let table = - Summary.ref (Refmap.empty : t Refmap.t) ~name:"reductionbehaviour" + Summary.ref (GlobRef.Map.empty : t GlobRef.Map.t) ~name:"reductionbehaviour" type flag = [ `ReductionDontExposeCase | `ReductionNeverUnfold ] type req = @@ -105,7 +106,7 @@ module ReductionBehaviour = struct | ReqGlobal of GlobRef.t * (int list * int * flag list) let load _ (_,(_,(r, b))) = - table := Refmap.add r b !table + table := GlobRef.Map.add r b !table let cache o = load 1 o @@ -160,7 +161,7 @@ module ReductionBehaviour = struct let get r = try - let b = Refmap.find r !table in + let b = GlobRef.Map.find r !table in let flags = if Int.equal b.b_nargs max_int then [`ReductionNeverUnfold] else if b.b_dont_expose_case then [`ReductionDontExposeCase] else [] in @@ -628,6 +629,18 @@ let safe_meta_value sigma ev = try Some (Evd.meta_value sigma ev) with Not_found -> None +let strong_with_flags whdfun flags env sigma t = + let push_rel_check_zeta d env = + let open CClosure.RedFlags in + let d = match d with + | LocalDef (na,c,t) when not (red_set flags fZETA) -> LocalAssum (na,t) + | d -> d in + push_rel d env in + let rec strongrec env t = + map_constr_with_full_binders sigma + push_rel_check_zeta strongrec env (whdfun flags env sigma t) in + strongrec env t + let strong whdfun env sigma t = let rec strongrec env t = map_constr_with_full_binders sigma push_rel strongrec env (whdfun env sigma t) in diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 07eeec9276..dd3cd26f0f 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -144,6 +144,9 @@ val pr_state : state -> Pp.t (** {6 Reduction Function Operators } *) +val strong_with_flags : + (CClosure.RedFlags.reds -> reduction_function) -> + (CClosure.RedFlags.reds -> reduction_function) val strong : reduction_function -> reduction_function val local_strong : local_reduction_function -> local_reduction_function val strong_prodspine : local_reduction_function -> local_reduction_function diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli index e6065dda87..bf38c30a1f 100644 --- a/pretyping/tacred.mli +++ b/pretyping/tacred.mli @@ -23,7 +23,7 @@ type reduction_tactic_error = exception ReductionTacticError of reduction_tactic_error -(** {6 Reduction functions associated to tactics. {% \label{%}tacred{% }%} } *) +(** {6 Reduction functions associated to tactics. } *) (** Evaluable global reference *) diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index efb3c339ac..55d9838bbb 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -88,7 +88,7 @@ type typeclass = { cl_unique : bool; } -type typeclasses = typeclass Refmap.t +type typeclasses = typeclass GlobRef.Map.t type instance = { is_class: GlobRef.t; @@ -99,7 +99,7 @@ type instance = { is_impl: GlobRef.t; } -type instances = (instance Refmap.t) Refmap.t +type instances = (instance GlobRef.Map.t) GlobRef.Map.t let instance_impl is = is.is_impl @@ -121,8 +121,8 @@ let new_instance cl info glob impl = * states management *) -let classes : typeclasses ref = Summary.ref Refmap.empty ~name:"classes" -let instances : instances ref = Summary.ref Refmap.empty ~name:"instances" +let classes : typeclasses ref = Summary.ref GlobRef.Map.empty ~name:"classes" +let instances : instances ref = Summary.ref GlobRef.Map.empty ~name:"instances" let typeclass_univ_instance (cl, u) = assert (Univ.AUContext.size cl.cl_univs == Univ.Instance.length u); @@ -131,7 +131,7 @@ let typeclass_univ_instance (cl, u) = cl_props = subst_ctx cl.cl_props} let class_info c = - try Refmap.find c !classes + try GlobRef.Map.find c !classes with Not_found -> not_a_class (Global.env()) (EConstr.of_constr (printable_constr_of_global c)) let global_class_of_constr env sigma c = @@ -154,7 +154,7 @@ let class_of_constr sigma c = let is_class_constr sigma c = try let gr, u = Termops.global_of_constr sigma c in - Refmap.mem gr !classes + GlobRef.Map.mem gr !classes with Not_found -> false let rec is_class_type evd c = @@ -172,7 +172,7 @@ let is_class_evar evd evi = *) let load_class (_, cl) = - classes := Refmap.add cl.cl_impl cl !classes + classes := GlobRef.Map.add cl.cl_impl cl !classes let cache_class = load_class @@ -336,17 +336,17 @@ type instance_action = let load_instance inst = let insts = - try Refmap.find inst.is_class !instances - with Not_found -> Refmap.empty in - let insts = Refmap.add inst.is_impl inst insts in - instances := Refmap.add inst.is_class insts !instances + try GlobRef.Map.find inst.is_class !instances + with Not_found -> GlobRef.Map.empty in + let insts = GlobRef.Map.add inst.is_impl inst insts in + instances := GlobRef.Map.add inst.is_class insts !instances let remove_instance inst = let insts = - try Refmap.find inst.is_class !instances + try GlobRef.Map.find inst.is_class !instances with Not_found -> assert false in - let insts = Refmap.remove inst.is_impl insts in - instances := Refmap.add inst.is_class insts !instances + let insts = GlobRef.Map.remove inst.is_impl insts in + instances := GlobRef.Map.add inst.is_class insts !instances let cache_instance (_, (action, i)) = match action with @@ -464,23 +464,23 @@ let instance_constructor (cl,u) args = (term, applist (mkConstU cst, pars)) | _ -> assert false -let typeclasses () = Refmap.fold (fun _ l c -> l :: c) !classes [] +let typeclasses () = GlobRef.Map.fold (fun _ l c -> l :: c) !classes [] -let cmap_elements c = Refmap.fold (fun k v acc -> v :: acc) c [] +let cmap_elements c = GlobRef.Map.fold (fun k v acc -> v :: acc) c [] let instances_of c = - try cmap_elements (Refmap.find c.cl_impl !instances) with Not_found -> [] + try cmap_elements (GlobRef.Map.find c.cl_impl !instances) with Not_found -> [] let all_instances () = - Refmap.fold (fun k v acc -> - Refmap.fold (fun k v acc -> v :: acc) v acc) + GlobRef.Map.fold (fun k v acc -> + GlobRef.Map.fold (fun k v acc -> v :: acc) v acc) !instances [] let instances r = let cl = class_info r in instances_of cl let is_class gr = - Refmap.exists (fun _ v -> GlobRef.equal v.cl_impl gr) !classes + GlobRef.Map.exists (fun _ v -> GlobRef.equal v.cl_impl gr) !classes let is_instance = function | ConstRef c -> diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 255707dc7b..c30c4f0932 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -79,7 +79,7 @@ let construct_of_constr const env tag typ = (* spiwack : here be a branch for specific decompilation handled by retroknowledge *) try if const then - ((Retroknowledge.get_vm_decompile_constant_info env.retroknowledge (mkIndU indu) tag), + ((Retroknowledge.get_vm_decompile_constant_info env.retroknowledge (GlobRef.IndRef ind) tag), typ) (*spiwack: this may need to be changed in case there are parameters in the type which may cause a constant value to have an arity. (type_constructor seems to be all about parameters actually) @@ -161,9 +161,9 @@ and nf_whd env sigma whd typ = | Vconstr_block b -> let tag = btag b in let (tag,ofs) = - if tag = Cbytecodes.last_variant_tag then + if tag = Obj.last_non_constant_constructor_tag then match whd_val (bfield b 0) with - | Vconstr_const tag -> (tag+Cbytecodes.last_variant_tag, 1) + | Vconstr_const tag -> (tag+Obj.last_non_constant_constructor_tag, 1) | _ -> assert false else (tag, 0) in let capp,ctyp = construct_of_constr_block env tag typ in @@ -278,7 +278,7 @@ and nf_stk ?from:(from=0) env sigma c t stk = in let branchs = Array.mapi mkbranch bsw in let tcase = build_case_type p realargs c in - let ci = sw.sw_annot.Cbytecodes.ci in + let ci = sw.sw_annot.Vmvalues.ci in nf_stk env sigma (mkCase(ci, p, c, branchs)) tcase stk | Zproj p :: stk -> assert (from = 0) ; diff --git a/printing/prettyp.ml b/printing/prettyp.ml index 1810cc6588..9ed985195f 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -902,28 +902,28 @@ let inspect env sigma depth = open Classops -let print_coercion_value env sigma v = Printer.pr_global v.coe_value +let print_coercion_value v = Printer.pr_global v.coe_value let print_class i = let cl,_ = class_info_from_index i in pr_class cl -let print_path env sigma ((i,j),p) = +let print_path ((i,j),p) = hov 2 ( - str"[" ++ hov 0 (prlist_with_sep pr_semicolon (print_coercion_value env sigma) p) ++ + str"[" ++ hov 0 (prlist_with_sep pr_semicolon print_coercion_value p) ++ str"] : ") ++ print_class i ++ str" >-> " ++ print_class j let _ = Classops.install_path_printer print_path -let print_graph env sigma = - prlist_with_sep fnl (print_path env sigma) (inheritance_graph()) +let print_graph () = + prlist_with_sep fnl print_path (inheritance_graph()) let print_classes () = pr_sequence pr_class (classes()) -let print_coercions env sigma = - pr_sequence (print_coercion_value env sigma) (coercions()) +let print_coercions () = + pr_sequence print_coercion_value (coercions()) let index_of_class cl = try @@ -932,7 +932,7 @@ let index_of_class cl = user_err ~hdr:"index_of_class" (pr_class cl ++ spc() ++ str "not a defined class.") -let print_path_between env sigma cls clt = +let print_path_between cls clt = let i = index_of_class cls in let j = index_of_class clt in let p = @@ -943,7 +943,7 @@ let print_path_between env sigma cls clt = (str"No path between " ++ pr_class cls ++ str" and " ++ pr_class clt ++ str ".") in - print_path env sigma ((i,j),p) + print_path ((i,j),p) let print_canonical_projections env sigma = prlist_with_sep fnl diff --git a/printing/prettyp.mli b/printing/prettyp.mli index 1668bce297..58606db019 100644 --- a/printing/prettyp.mli +++ b/printing/prettyp.mli @@ -12,7 +12,6 @@ open Names open Environ open Reductionops open Libnames -open Evd (** A Pretty-Printer for the Calculus of Inductive Constructions. *) @@ -40,10 +39,10 @@ val print_about : env -> Evd.evar_map -> qualid Constrexpr.or_by_notation -> val print_impargs : qualid Constrexpr.or_by_notation -> Pp.t (** Pretty-printing functions for classes and coercions *) -val print_graph : env -> evar_map -> Pp.t +val print_graph : unit -> Pp.t val print_classes : unit -> Pp.t -val print_coercions : env -> Evd.evar_map -> Pp.t -val print_path_between : env -> evar_map -> Classops.cl_typ -> Classops.cl_typ -> 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 (** Pretty-printing functions for type classes and instances *) diff --git a/printing/printer.ml b/printing/printer.ml index 5b3ead181f..67d71332b0 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -494,17 +494,17 @@ let pr_transparent_state (ids, csts) = str"CONSTANTS: " ++ pr_cpred csts ++ fnl ()) (* display complete goal - prev_gs has info on the previous proof step for diffs - gs has info on the current proof step + og_s has goal+sigma on the previous proof step for diffs + g_s has goal+sigma on the current proof step *) -let pr_goal ?(diffs=false) ?prev_gs gs = - let g = sig_it gs in - let sigma = project gs in +let pr_goal ?(diffs=false) ?og_s g_s = + let g = sig_it g_s in + let sigma = project g_s in let env = Goal.V82.env sigma g in let concl = Goal.V82.concl sigma g in let goal = if diffs then - Proof_diffs.diff_goals ?prev_gs (Some gs) + Proof_diffs.diff_goal ?og_s g sigma else pr_context_of env sigma ++ cut () ++ str "============================" ++ cut () ++ @@ -525,13 +525,18 @@ let pr_goal_name sigma g = let pr_goal_header nme sigma g = let (g,sigma) = Goal.V82.nf_evar sigma g in str "subgoal " ++ nme ++ (if should_tag() then pr_goal_tag g else str"") - ++ (if should_gname() then str " " ++ Pp.surround (pr_existential_key sigma g) else mt ()) + ++ (if should_gname() then str " " ++ Pp.surround (pr_existential_key sigma g) else mt ()) (* display the conclusion of a goal *) -let pr_concl n sigma g = +let pr_concl n ?(diffs=false) ?og_s sigma g = let (g,sigma) = Goal.V82.nf_evar sigma g in let env = Goal.V82.env sigma g in - let pc = pr_goal_concl_style_env env sigma (Goal.V82.concl sigma g) in + let pc = + if diffs then + Proof_diffs.diff_concl ?og_s sigma g + else + pr_goal_concl_style_env env sigma (Goal.V82.concl sigma g) + in let header = pr_goal_header (int n) sigma g in header ++ str " is:" ++ cut () ++ str" " ++ pc @@ -698,13 +703,25 @@ let print_dependent_evars gl sigma seeds = in constraints ++ evars () +module GoalMap = Evar.Map + (* Print open subgoals. Checks for uninstantiated existential variables *) (* spiwack: [seeds] is for printing dependent evars in emacs mode. *) (* spiwack: [pr_first] is true when the first goal must be singled out and printed in its entirety. *) -(* [prev] is the previous proof step, used for diffs *) -let pr_subgoals ?(pr_first=true) ?(diffs=false) ?prev +(* [os_map] is derived from the previous proof step, used for diffs *) +let pr_subgoals ?(pr_first=true) ?(diffs=false) ?os_map close_cmd sigma ~seeds ~shelf ~stack ~unfocused ~goals = + let diff_goal_map = + match os_map with + | Some (_, diff_goal_map) -> diff_goal_map + | None -> GoalMap.empty + in + + let map_goal_for_diff ng = (* todo: move to proof_diffs.ml *) + try GoalMap.find ng diff_goal_map with Not_found -> ng + in + (** Printing functions for the extra informations. *) let rec print_stack a = function | [] -> Pp.int a @@ -738,23 +755,23 @@ let pr_subgoals ?(pr_first=true) ?(diffs=false) ?prev else str" " (* non-breakable space *) in + let get_ogs g = + match os_map with + | Some (osigma, _) -> Some { it = map_goal_for_diff g; sigma = osigma } + | None -> None + in let rec pr_rec n = function | [] -> (mt ()) | g::rest -> - let pc = pr_concl n sigma g in + let og_s = get_ogs g in + let pc = pr_concl n ~diffs ?og_s sigma g in let prest = pr_rec (n+1) rest in (cut () ++ pc ++ prest) in let print_multiple_goals g l = if pr_first then - let prev_gs = - match prev with - | Some (prev_goals, prev_sigma) -> - if prev_goals = [] then None - else Some { it = List.hd prev_goals; sigma = prev_sigma} - | None -> None - in - pr_goal ~diffs ?prev_gs { it = g ; sigma = sigma } + let og_s = get_ogs g in + pr_goal ~diffs ?og_s { it = g ; sigma = sigma } ++ (if l=[] then mt () else cut ()) ++ pr_rec 2 l else @@ -797,7 +814,7 @@ let pr_subgoals ?(pr_first=true) ?(diffs=false) ?prev ++ print_dependent_evars (Some g1) sigma seeds ) -let pr_open_subgoals_diff ?(quiet=false) ?(diffs=false) ?prev_proof proof = +let pr_open_subgoals_diff ?(quiet=false) ?(diffs=false) ?oproof proof = (* spiwack: it shouldn't be the job of the printer to look up stuff in the [evar_map], I did stuff that way because it was more straightforward, but seriously, [Proof.proof] should return @@ -833,15 +850,15 @@ let pr_open_subgoals_diff ?(quiet=false) ?(diffs=false) ?prev_proof proof = let { Evd.it = bgoals ; sigma = bsigma } = Proof.V82.background_subgoals p in let bgoals_focused, bgoals_unfocused = List.partition (fun x -> List.mem x goals) bgoals in let unfocused_if_needed = if should_unfoc() then bgoals_unfocused else [] in - let prev = match prev_proof with - | Some op -> - let (ogoals , _, _, _, _) = Proof.proof op in - let { Evd.it = obgoals; sigma = osigma } = Proof.V82.background_subgoals op in - let obgoals_focused = List.filter (fun x -> List.mem x ogoals) obgoals in - Some (obgoals_focused, osigma) - | None -> None + let os_map = match oproof with + | Some op when diffs -> + let (_,_,_,_, osigma) = Proof.proof op in + let diff_goal_map = Proof_diffs.make_goal_map oproof proof in + Some (osigma, diff_goal_map) + | _ -> None in - pr_subgoals ~pr_first:true ~diffs ?prev None bsigma ~seeds ~shelf ~stack:[] ~unfocused:unfocused_if_needed ~goals:bgoals_focused + pr_subgoals ~pr_first:true ~diffs ?os_map None bsigma ~seeds ~shelf ~stack:[] + ~unfocused:unfocused_if_needed ~goals:bgoals_focused end let pr_open_subgoals ~proof = @@ -930,8 +947,8 @@ let pr_assumptionset env sigma s = let mp,_,lab = Constant.repr3 kn in str (ModPath.to_string mp) ++ str "." ++ Label.print lab in - let safe_pr_ltype typ = - try str " : " ++ pr_ltype typ + let safe_pr_ltype env sigma typ = + try str " : " ++ pr_ltype_env env sigma typ with e when CErrors.noncritical e -> mt () in let safe_pr_ltype_relctx (rctx, typ) = @@ -942,7 +959,7 @@ let pr_assumptionset env sigma s = let pr_axiom env ax typ = match ax with | Constant kn -> - safe_pr_constant env kn ++ safe_pr_ltype typ + safe_pr_constant env kn ++ safe_pr_ltype env sigma typ | Positive m -> hov 2 (MutInd.print m ++ spc () ++ strbrk"is positive.") | Guarded kn -> @@ -952,7 +969,7 @@ let pr_assumptionset env sigma s = let (v, a, o, tr) = accu in match t with | Variable id -> - let var = pr_id id ++ str " : " ++ pr_ltype typ in + let var = pr_id id ++ str " : " ++ pr_ltype_env env sigma typ in (var :: v, a, o, tr) | Axiom (axiom, []) -> let ax = pr_axiom env axiom typ in @@ -966,10 +983,10 @@ let pr_assumptionset env sigma s = l in (v, ax :: a, o, tr) | Opaque kn -> - let opq = safe_pr_constant env kn ++ safe_pr_ltype typ in + let opq = safe_pr_constant env kn ++ safe_pr_ltype env sigma typ in (v, a, opq :: o, tr) | Transparent kn -> - let tran = safe_pr_constant env kn ++ safe_pr_ltype typ in + let tran = safe_pr_constant env kn ++ safe_pr_ltype env sigma typ in (v, a, o, tran :: tr) in let (vars, axioms, opaque, trans) = @@ -1023,22 +1040,14 @@ let print_and_diff oldp newp = | Some proof -> let output = if Proof_diffs.show_diffs () then - try pr_open_subgoals_diff ~diffs:true ?prev_proof:oldp proof + try pr_open_subgoals_diff ~diffs:true ?oproof:oldp proof with Pp_diff.Diff_Failure msg -> begin (* todo: print the unparsable string (if we know it) *) - Feedback.msg_warning Pp.(str ("Diff failure:" ^ msg ^ "; showing results without diff highlighting" )); + Feedback.msg_warning Pp.(str ("Diff failure: " ^ msg) ++ cut() + ++ str "Showing results without diff highlighting" ); pr_open_subgoals ~proof end else pr_open_subgoals ~proof in Feedback.msg_notice output;; - -(* Do diffs on the first goal returning a Pp. *) -let diff_pr_open_subgoals ?(quiet=false) o_proof n_proof = - match n_proof with - | None -> Pp.mt () - | Some proof -> - try pr_open_subgoals_diff ~quiet ~diffs:true ?prev_proof:o_proof proof - with Pp_diff.Diff_Failure _ -> pr_open_subgoals ~proof - (* todo: print the unparsable string (if we know it) *) diff --git a/printing/printer.mli b/printing/printer.mli index 971241d5f9..518c5b930b 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -171,26 +171,46 @@ val pr_transparent_state : transparent_state -> Pp.t (** Proofs, these functions obey [Hyps Limit] and [Compact contexts]. *) -val pr_goal : ?diffs:bool -> ?prev_gs:(goal sigma) -> goal sigma -> Pp.t - -(** [pr_subgoals ~pr_first ~prev_proof pp sigma seeds shelf focus_stack unfocused goals] - prints the goals of the list [goals] followed by the goals in - [unfocused], in a short way (typically only the conclusion) except - for the first goal if [pr_first] is true. Also, if [diffs] is true - and [pr_first] is true, then highlight diffs relative to [prev] in the - output for first goal. This function prints only the - focused goals unless the conrresponding option - [enable_unfocused_goal_printing] is set. [seeds] is for printing - dependent evars (mainly for emacs proof tree mode). *) -val pr_subgoals : ?pr_first:bool -> ?diffs:bool -> ?prev:(goal list * evar_map) -> Pp.t option -> evar_map +(** [pr_goal ~diffs ~og_s g_s] prints the goal specified by [g_s]. If [diffs] is true, + highlight the differences between the old goal, [og_s], and [g_s]. [g_s] and [og_s] are + records containing the goal and sigma for, respectively, the new and old proof steps, + e.g. [{ it = g ; sigma = sigma }]. +*) +val pr_goal : ?diffs:bool -> ?og_s:(goal sigma) -> goal sigma -> Pp.t + +(** [pr_subgoals ~pr_first ~diffs ~os_map close_cmd sigma ~seeds ~shelf ~stack ~unfocused ~goals] + prints the goals in [goals] followed by the goals in [unfocused] in a compact form + (typically only the conclusion). If [pr_first] is true, print the first goal in full. + [close_cmd] is printed afterwards verbatim. + + If [diffs] is true, then highlight diffs relative to [os_map] in the output for first goal. + [os_map] contains sigma for the old proof step and the goal map created by + [Proof_diffs.make_goal_map]. + + This function prints only the focused goals unless the corresponding option [enable_unfocused_goal_printing] is set. + [seeds] is for printing dependent evars (mainly for emacs proof tree mode). [shelf] is from + Proof.proof and is used to identify shelved goals in a message if there are no more subgoals but + there are non-instantiated existential variables. [stack] is used to print summary info on unfocused + goals. +*) +val pr_subgoals : ?pr_first:bool -> ?diffs:bool -> ?os_map:(evar_map * Evar.t Evar.Map.t) -> Pp.t option -> evar_map -> seeds:goal list -> shelf:goal list -> stack:int list -> unfocused: goal list -> goals:goal list -> Pp.t val pr_subgoal : int -> evar_map -> goal list -> Pp.t -val pr_concl : int -> evar_map -> goal -> Pp.t -val pr_open_subgoals_diff : ?quiet:bool -> ?diffs:bool -> ?prev_proof:Proof.t -> Proof.t -> Pp.t -val diff_pr_open_subgoals : ?quiet:bool -> Proof.t option -> Proof.t option -> Pp.t +(** [pr_concl n ~diffs ~og_s sigma g] prints the conclusion of the goal [g] using [sigma]. The output + is labelled "subgoal [n]". If [diffs] is true, highlight the differences between the old conclusion, + [og_s], and [g]+[sigma]. [og_s] is a record containing the old goal and sigma, e.g. [{ it = g ; sigma = sigma }]. +*) +val pr_concl : int -> ?diffs:bool -> ?og_s:(goal sigma) -> evar_map -> goal -> Pp.t + +(** [pr_open_subgoals_diff ~quiet ~diffs ~oproof proof] shows the context for [proof] as used by, for example, coqtop. + The first active goal is printed with all its antecedents and the conclusion. The other active goals only show their + conclusions. If [diffs] is true, highlight the differences between the old proof, [oproof], and [proof]. [quiet] + disables printing messages as Feedback. +*) +val pr_open_subgoals_diff : ?quiet:bool -> ?diffs:bool -> ?oproof:Proof.t -> Proof.t -> Pp.t val pr_open_subgoals : proof:Proof.t -> Pp.t val pr_nth_open_subgoal : proof:Proof.t -> int -> Pp.t val pr_evar : evar_map -> (Evar.t * evar_info) -> Pp.t @@ -200,13 +220,14 @@ val pr_ne_evar_set : Pp.t -> Pp.t -> evar_map -> Evar.Set.t -> Pp.t val pr_prim_rule : prim_rule -> Pp.t +[@@ocaml.deprecated "[pr_prim_rule] is scheduled to be removed along with the legacy proof engine"] val print_and_diff : Proof.t option -> Proof.t option -> unit (** Backwards compatibility *) val prterm : constr -> Pp.t (** = pr_lconstr *) - +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] (** Declarations for the "Print Assumption" command *) type axiom = diff --git a/printing/proof_diffs.ml b/printing/proof_diffs.ml index 3a81e908a7..5bb1053645 100644 --- a/printing/proof_diffs.ml +++ b/printing/proof_diffs.ml @@ -14,39 +14,26 @@ Proof General requires minor changes to make the diffs visible, but this code shouldn't break the existing version of PG. See pp_diff.ml for details on how the diff works. -Diffs are computed for the hypotheses and conclusion of the first goal between -the old and new proofs. +Diffs are computed for the hypotheses and conclusion of each goal in the new +proof with its matching goal in the old proof. -Diffs can be enabled with the Coq commmand "Set Diffs on|off|removed." or -'-diffs "on"|"off"|"removed"' on the OS command line. The "on" option shows only the -new item with added text, while "removed" shows each modified item twice--once -with the old value showing removed text and once with the new value showing -added text. +Diffs can be enabled in coqtop with 'Set Diffs "on"|"off"|"removed"' or +'-diffs on|off|removed' on the OS command line. In CoqIDE, they can be enabled +from the View menu. The "on" option shows only the new item with added text, +while "removed" shows each modified item twice--once with the old value showing +removed text and once with the new value showing added text. In CoqIDE, colors and highlights can be set in the Edit/Preferences/Tags panel. For coqtop, these can be set through the COQ_COLORS environment variable. Limitations/Possible enhancements: -- If you go back to a prior proof step, diffs are not shown on the new current -step. Diffs will be shown again once you do another proof step. - -- Diffs are done between the first active goal in the old and new proofs. -If, for example, the proof step completed a goal, then the new goal is a -different goal, not a transformation of the old goal, so a diff is probably -not appropriate. (There's currently no way to tell when this happens or to -accurately match goals across old and new proofs. -See https://github.com/coq/coq/issues/7653) This is also why only the -first goal is diffed. - -- "Set Diffs "xx"." should reprint the current goal using the new option. - - coqtop colors were chosen for white text on a black background. They're not the greatest. I didn't want to change the existing green highlight. Suggestions welcome. - coqtop underlines removed text because (per Wikipedia) the ANSI escape code -for strikeout is not commonly supported (it didn't work on mine). CoqIDE +for strikeout is not commonly supported (it didn't work on my system). CoqIDE uses strikeout on removed text. *) @@ -54,8 +41,6 @@ open Pp_diff let diff_option = ref `OFF -(* todo: Is there a way to persist the setting between sessions? - Eg if the user wants this as a permanent config setting? *) let read_diffs_option () = match !diff_option with | `OFF -> "off" | `ON -> "on" @@ -136,7 +121,8 @@ let diff_hyps o_line_idents o_map n_line_idents n_map = (* use the order from the old line in case it's changed in the new *) let old_ids = if old_ids_uo = [] then [] else let orig = (StringMap.find (List.hd old_ids_uo) o_map).idents in - List.concat (List.map (contains orig) old_ids_uo) in + List.concat (List.map (contains orig) old_ids_uo) + in let setup ids map = if ids = [] then ("", Pp.mt ()) else let open Pp in @@ -233,6 +219,12 @@ let to_tuple : Constr.compacted_declaration -> (Names.Id.t list * 'pc option * ' (* XXX: Very unfortunately we cannot use the Proofview interface as Proof is still using the "legacy" one. *) +let process_goal_concl sigma g : Constr.t * Environ.env = + let env = Goal.V82.env sigma g in + let ty = Goal.V82.concl sigma g in + let ty = EConstr.to_constr sigma ty in + (ty, env) + let process_goal sigma g : Constr.t reified_goal = let env = Goal.V82.env sigma g in let hyps = Goal.V82.hyps sigma g in @@ -256,14 +248,29 @@ let pr_leconstr_core goal_concl_style env sigma t = let pr_lconstr_env env sigma c = pr_leconstr_core false env sigma (EConstr.of_constr c) +let diff_concl ?og_s nsigma ng = + let open Evd in + let o_concl_pp = match og_s with + | Some { it=og; sigma=osigma } -> + let (oty, oenv) = process_goal_concl osigma og in + pp_of_type oenv osigma oty + | None -> Pp.mt() + in + let (nty, nenv) = process_goal_concl nsigma ng in + let n_concl_pp = pp_of_type nenv nsigma nty in + + let show_removed = Some (show_removed ()) in + + diff_pp_combined ~tokenize_string ?show_removed o_concl_pp n_concl_pp + (* fetch info from a goal, returning (idents, map, concl_pp) where -idents is a list with one entry for each hypothesis, each entry is the list of -idents on the lhs of the hypothesis. map is a map from ident to hyp_info -reoords. For example: for the hypotheses: +idents is a list with one entry for each hypothesis, in which each entry +is the list of idents on the lhs of the hypothesis. map is a map from +ident to hyp_info reoords. For example: for the hypotheses: b : bool n, m : nat -list will be [ ["b"]; ["n"; "m"] ] +idents will be [ ["b"]; ["n"; "m"] ] map will contain: "b" -> { ["b"], Pp.t for ": bool"; false } @@ -317,31 +324,314 @@ let hyp_list_to_pp hyps = | h :: tl -> List.fold_left (fun x y -> x ++ cut () ++ y) h tl | [] -> mt ();; -(* Special purpuse, use only for the IDE interface, *) -let diff_first_goal o_proof n_proof = - let first_goal_info proof = - match proof with - | None -> ([], StringMap.empty, Pp.mt ()) - | Some proof2 -> - let (goals,_,_,_,sigma) = Proof.proof proof2 in - match goals with - | hd :: tl -> goal_info hd sigma; - | _ -> ([], StringMap.empty, Pp.mt ()) - in - diff_goal_info (first_goal_info o_proof) (first_goal_info n_proof);; - -let diff_goals ?prev_gs n_gs = - let unwrap gs = - match gs with - | Some gs -> - let goal = Evd.sig_it gs in - let sigma = Refiner.project gs in - goal_info goal sigma - | None -> ([], StringMap.empty, Pp.mt ()) - in - let (hyps_pp_list, concl_pp) = diff_goal_info (unwrap prev_gs) (unwrap n_gs) in +let unwrap g_s = + match g_s with + | Some g_s -> + let goal = Evd.sig_it g_s in + let sigma = Refiner.project g_s in + goal_info goal sigma + | None -> ([], StringMap.empty, Pp.mt ()) + +let diff_goal_ide og_s ng nsigma = + diff_goal_info (unwrap og_s) (goal_info ng nsigma) + +let diff_goal ?og_s ng ns = + let (hyps_pp_list, concl_pp) = diff_goal_info (unwrap og_s) (goal_info ng ns) in let open Pp in v 0 ( (hyp_list_to_pp hyps_pp_list) ++ cut () ++ str "============================" ++ cut () ++ concl_pp);; + + +(*** Code to determine which calls to compare between the old and new proofs ***) + +open Constrexpr +open Glob_term +open Names +open CAst + +(* Compare the old and new proof trees to identify the correspondence between +new and old goals. Returns a map from the new evar name to the old, +e.g. "Goal2" -> "Goal1". Assumes that proof steps only rewrite CEvar nodes +and that CEvar nodes cannot contain other CEvar nodes. + +The comparison works this way: +1. Traverse the old and new trees together (ogname = "", ot != nt): +- if the old and new trees both have CEvar nodes, add an entry to the map from + the new evar name to the old evar name. (Position of goals is preserved but + evar names may not be--see below.) +- if the old tree has a CEvar node and the new tree has a different type of node, + we've found a changed goal. Set ogname to the evar name of the old goal and + go to step 2. +- any other mismatch violates the assumptions, raise an exception +2. Traverse the new tree from the point of the difference (ogname <> "", ot = nt). +- if the node is a CEvar, generate a map entry from the new evar name to ogname. + +Goal ids for unchanged goals appear to be preserved across proof steps. +However, the evar name associated with a goal id may change in a proof step +even if that goal is not changed by the tactic. You can see this by enabling +the call to db_goal_map and entering the following: + + Parameter P : nat -> Prop. + Goal (P 1 /\ P 2 /\ P 3) /\ P 4. + split. + Show Proof. + split. + Show Proof. + + Which gives you this summarized output: + + > split. + New Goals: 3 -> Goal 4 -> Goal0 <--- goal 4 is "Goal0" + Old Goals: 1 -> Goal + Goal map: 3 -> 1 4 -> 1 + > Show Proof. + (conj ?Goal ?Goal0) <--- goal 4 is the rightmost goal in the proof + > split. + New Goals: 6 -> Goal0 7 -> Goal1 4 -> Goal <--- goal 4 is now "Goal" + Old Goals: 3 -> Goal 4 -> Goal0 + Goal map: 6 -> 3 7 -> 3 + > Show Proof. + (conj (conj ?Goal0 ?Goal1) ?Goal) <--- goal 4 is still the rightmost goal in the proof + *) +let match_goals ot nt = + let nevar_to_oevar = ref StringMap.empty in + (* ogname is "" when there is no difference on the current path. + It's set to the old goal's evar name once a rewitten goal is found, + at which point the code only searches for the replacing goals + (and ot is set to nt). *) + let rec match_goals_r ogname ot nt = + let constr_expr ogname exp exp2 = + match_goals_r ogname exp.v exp2.v + in + let constr_expr_opt ogname exp exp2 = + match exp, exp2 with + | Some expa, Some expb -> constr_expr ogname expa expb + | None, None -> () + | _, _ -> raise (Diff_Failure "Unable to match goals betwen old and new proof states (1)") + in + let local_binder_expr ogname exp exp2 = + match exp, exp2 with + | CLocalAssum (nal,bk,ty), CLocalAssum(nal2,bk2,ty2) -> + constr_expr ogname ty ty2 + | CLocalDef (n,c,t), CLocalDef (n2,c2,t2) -> + constr_expr ogname c c2; + constr_expr_opt ogname t t2 + | CLocalPattern p, CLocalPattern p2 -> + let (p,ty), (p2,ty2) = p.v,p2.v in + constr_expr_opt ogname ty ty2 + | _, _ -> raise (Diff_Failure "Unable to match goals betwen old and new proof states (2)") + in + let recursion_order_expr ogname exp exp2 = + match exp, exp2 with + | CStructRec, CStructRec -> () + | CWfRec c, CWfRec c2 -> + constr_expr ogname c c2 + | CMeasureRec (m,r), CMeasureRec (m2,r2) -> + constr_expr ogname m m2; + constr_expr_opt ogname r r2 + | _, _ -> raise (Diff_Failure "Unable to match goals betwen old and new proof states (3)") + in + let fix_expr ogname exp exp2 = + let (l,(lo,ro),lb,ce1,ce2), (l2,(lo2,ro2),lb2,ce12,ce22) = exp,exp2 in + recursion_order_expr ogname ro ro2; + List.iter2 (local_binder_expr ogname) lb lb2; + constr_expr ogname ce1 ce12; + constr_expr ogname ce2 ce22 + in + let cofix_expr ogname exp exp2 = + let (l,lb,ce1,ce2), (l2,lb2,ce12,ce22) = exp,exp2 in + List.iter2 (local_binder_expr ogname) lb lb2; + constr_expr ogname ce1 ce12; + constr_expr ogname ce2 ce22 + in + let case_expr ogname exp exp2 = + let (ce,l,cp), (ce2,l2,cp2) = exp,exp2 in + constr_expr ogname ce ce2 + in + let branch_expr ogname exp exp2 = + let (cpe,ce), (cpe2,ce2) = exp.v,exp2.v in + constr_expr ogname ce ce2 + in + let constr_notation_substitution ogname exp exp2 = + let (ce, cel, cp, lb), (ce2, cel2, cp2, lb2) = exp, exp2 in + List.iter2 (constr_expr ogname) ce ce2; + List.iter2 (fun a a2 -> List.iter2 (constr_expr ogname) a a2) cel cel2; + List.iter2 (fun a a2 -> List.iter2 (local_binder_expr ogname) a a2) lb lb2 + in + begin + match ot, nt with + | CRef (ref,us), CRef (ref2,us2) -> () + | CFix (id,fl), CFix (id2,fl2) -> + List.iter2 (fix_expr ogname) fl fl2 + | CCoFix (id,cfl), CCoFix (id2,cfl2) -> + List.iter2 (cofix_expr ogname) cfl cfl2 + | CProdN (bl,c2), CProdN (bl2,c22) + | CLambdaN (bl,c2), CLambdaN (bl2,c22) -> + List.iter2 (local_binder_expr ogname) bl bl2; + constr_expr ogname c2 c22 + | CLetIn (na,c1,t,c2), CLetIn (na2,c12,t2,c22) -> + constr_expr ogname c1 c12; + constr_expr_opt ogname t t2; + constr_expr ogname c2 c22 + | CAppExpl ((isproj,ref,us),args), CAppExpl ((isproj2,ref2,us2),args2) -> + List.iter2 (constr_expr ogname) args args2 + | CApp ((isproj,f),args), CApp ((isproj2,f2),args2) -> + constr_expr ogname f f2; + List.iter2 (fun a a2 -> let (c, _) = a and (c2, _) = a2 in + constr_expr ogname c c2) args args2 + | CRecord fs, CRecord fs2 -> + List.iter2 (fun a a2 -> let (_, c) = a and (_, c2) = a2 in + constr_expr ogname c c2) fs fs2 + | CCases (sty,rtnpo,tms,eqns), CCases (sty2,rtnpo2,tms2,eqns2) -> + constr_expr_opt ogname rtnpo rtnpo2; + List.iter2 (case_expr ogname) tms tms2; + List.iter2 (branch_expr ogname) eqns eqns2 + | CLetTuple (nal,(na,po),b,c), CLetTuple (nal2,(na2,po2),b2,c2) -> + constr_expr_opt ogname po po2; + constr_expr ogname b b2; + constr_expr ogname c c2 + | CIf (c,(na,po),b1,b2), CIf (c2,(na2,po2),b12,b22) -> + constr_expr ogname c c2; + constr_expr_opt ogname po po2; + constr_expr ogname b1 b12; + constr_expr ogname b2 b22 + | CHole (k,naming,solve), CHole (k2,naming2,solve2) -> () + | CPatVar _, CPatVar _ -> () + | CEvar (n,l), CEvar (n2,l2) -> + let oevar = if ogname = "" then Id.to_string n else ogname in + nevar_to_oevar := StringMap.add (Id.to_string n2) oevar !nevar_to_oevar; + List.iter2 (fun x x2 -> let (_, g) = x and (_, g2) = x2 in constr_expr ogname g g2) l l2 + | CEvar (n,l), nt' -> + (* pass down the old goal evar name *) + match_goals_r (Id.to_string n) nt' nt' + | CSort s, CSort s2 -> () + | CCast (c,c'), CCast (c2,c'2) -> + constr_expr ogname c c2; + (match c', c'2 with + | CastConv a, CastConv a2 + | CastVM a, CastVM a2 + | CastNative a, CastNative a2 -> + constr_expr ogname a a2 + | CastCoerce, CastCoerce -> () + | _, _ -> raise (Diff_Failure "Unable to match goals betwen old and new proof states (4)")) + | CNotation (ntn,args), CNotation (ntn2,args2) -> + constr_notation_substitution ogname args args2 + | CGeneralization (b,a,c), CGeneralization (b2,a2,c2) -> + constr_expr ogname c c2 + | CPrim p, CPrim p2 -> () + | CDelimiters (key,e), CDelimiters (key2,e2) -> + constr_expr ogname e e2 + | CProj (pr,c), CProj (pr2,c2) -> + constr_expr ogname c c2 + | _, _ -> raise (Diff_Failure "Unable to match goals betwen old and new proof states (5)") + end + in + + (match ot with + | Some ot -> match_goals_r "" ot nt + | None -> ()); + !nevar_to_oevar + + +let to_constr p = + let open CAst in + let pprf = Proof.partial_proof p in + (* pprf generally has only one element, but it may have more in the derive plugin *) + let t = List.hd pprf in + let sigma, env = Pfedit.get_current_context ~p () in + let x = Constrextern.extern_constr false env sigma t in (* todo: right options?? *) + x.v + + +module GoalMap = Evar.Map + +let goal_to_evar g sigma = Id.to_string (Termops.pr_evar_suggested_name g sigma) + +[@@@ocaml.warning "-32"] +let db_goal_map op np ng_to_og = + Printf.printf "New Goals: "; + let (ngoals,_,_,_,nsigma) = Proof.proof np in + List.iter (fun ng -> Printf.printf "%d -> %s " (Evar.repr ng) (goal_to_evar ng nsigma)) ngoals; + (match op with + | Some op -> + let (ogoals,_,_,_,osigma) = Proof.proof op in + Printf.printf "\nOld Goals: "; + List.iter (fun og -> Printf.printf "%d -> %s " (Evar.repr og) (goal_to_evar og osigma)) ogoals + | None -> ()); + Printf.printf "\nGoal map: "; + GoalMap.iter (fun og ng -> Printf.printf "%d -> %d " (Evar.repr og) (Evar.repr ng)) ng_to_og; + Printf.printf "\n" +[@@@ocaml.warning "+32"] + +(* Create a map from new goals to old goals for proof diff. The map only + has entries for new goals that are not the same as the corresponding old + goal; there are no entries for unchanged goals. + + It proceeds as follows: + 1. Find the goal ids that were removed from the old proof and that were + added in the new proof. If the same goal id is present in both proofs + then conclude the goal is unchanged (assumption). + + 2. The code assumes that proof changes only take the form of replacing + one or more goal symbols (CEvars) with new terms. Therefore: + - if there are no removals, the proofs are the same. + - if there are removals but no additions, then there are no new goals + that aren't the same as their associated old goals. For the both of + these cases, the map is empty because there are no new goals that differ + from their old goals + - if there is only one removal, then any added goals should be mapped to + the removed goal. + - if there are more than 2 removals and more than one addition, call + match_goals to get a map between old and new evar names, then use this + to create the map from new goal ids to old goal ids for the differing goals. +*) +let make_goal_map_i op np = + let ng_to_og = ref GoalMap.empty in + match op with + | None -> !ng_to_og + | Some op -> + let open Goal.Set in + let ogs = Proof.all_goals op in + let ngs = Proof.all_goals np in + let rem_gs = diff ogs ngs in + let num_rems = cardinal rem_gs in + let add_gs = diff ngs ogs in + let num_adds = cardinal add_gs in + + if num_rems = 0 then + !ng_to_og (* proofs are the same *) + else if num_adds = 0 then + !ng_to_og (* only removals *) + else if num_rems = 1 then begin + (* only 1 removal, some additions *) + let removed_g = List.hd (elements rem_gs) in + Goal.Set.iter (fun x -> ng_to_og := GoalMap.add x removed_g !ng_to_og) add_gs; + !ng_to_og + end else begin + (* >= 2 removals, >= 1 addition, need to match *) + let nevar_to_oevar = match_goals (Some (to_constr op)) (to_constr np) in + + let oevar_to_og = ref StringMap.empty in + let (_,_,_,_,osigma) = Proof.proof op in + List.iter (fun og -> oevar_to_og := StringMap.add (goal_to_evar og osigma) og !oevar_to_og) + (Goal.Set.elements rem_gs); + + try + let (_,_,_,_,nsigma) = Proof.proof np in + let get_og ng = + let nevar = goal_to_evar ng nsigma in + let oevar = StringMap.find nevar nevar_to_oevar in + let og = StringMap.find oevar !oevar_to_og in + og + in + Goal.Set.iter (fun ng -> ng_to_og := GoalMap.add ng (get_og ng) !ng_to_og) add_gs; + !ng_to_og + with Not_found -> raise (Diff_Failure "Unable to match goals betwen old and new proof states (6)") + end + +let make_goal_map op np = + let ng_to_og = make_goal_map_i op np in + (*db_goal_map op np ng_to_og;*) + ng_to_og diff --git a/printing/proof_diffs.mli b/printing/proof_diffs.mli index 482f03b686..832393e15f 100644 --- a/printing/proof_diffs.mli +++ b/printing/proof_diffs.mli @@ -15,8 +15,13 @@ val write_diffs_option : string -> unit (** Returns true if the diffs option is "on" or "removed" *) val show_diffs : unit -> bool -(** Computes the diff between the first goal of two Proofs and returns -the highlighted hypotheses and conclusion. +open Evd +open Proof_type +open Environ +open Constr + +(** Computes the diff between the goals of two Proofs and returns +the highlighted lists of hypotheses and conclusions. If the strings used to display the goal are not lexable (this is believed unlikely), this routine will generate a Diff_Failure. This routine may also @@ -26,12 +31,7 @@ If you want to make your call especially bulletproof, catch these exceptions, print a user-visible message, then recall this routine with the first argument set to None, which will skip the diff. *) -val diff_first_goal : Proof.t option -> Proof.t option -> Pp.t list * Pp.t - -open Evd -open Proof_type -open Environ -open Constr +val diff_goal_ide : goal sigma option -> goal -> Evd.evar_map -> Pp.t list * Pp.t (** Computes the diff between two goals @@ -43,7 +43,7 @@ If you want to make your call especially bulletproof, catch these exceptions, print a user-visible message, then recall this routine with the first argument set to None, which will skip the diff. *) -val diff_goals : ?prev_gs:(goal sigma) -> goal sigma option -> Pp.t +val diff_goal : ?og_s:(goal sigma) -> goal -> Evd.evar_map -> Pp.t (** Convert a string to a list of token strings using the lexer *) val tokenize_string : string -> string list @@ -52,6 +52,17 @@ val pr_letype_core : bool -> Environ.env -> Evd.evar_map -> EConstr.type val pr_leconstr_core : bool -> Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t val pr_lconstr_env : env -> evar_map -> constr -> Pp.t +(** Computes diffs for a single conclusion *) +val diff_concl : ?og_s:goal sigma -> Evd.evar_map -> Goal.goal -> Pp.t + +(** Generates a map from [np] to [op] that maps changed goals to their prior +forms. The map doesn't include entries for unchanged goals; unchanged goals +will have the same goal id in both versions. + +[op] and [np] must be from the same proof document and [op] must be for a state +before [np]. *) +val make_goal_map : Proof.t option -> Proof.t -> Evar.t Evar.Map.t + (* Exposed for unit test, don't use these otherwise *) (* output channel for the test log file *) val log_out_ch : out_channel ref diff --git a/proofs/goal.ml b/proofs/goal.ml index 1440d1636b..c14c0a8a77 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -143,3 +143,5 @@ module V82 = struct ) ~init:(concl sigma gl) env end + +module Set = Set.Make(struct type t = goal let compare = Evar.compare end) diff --git a/proofs/goal.mli b/proofs/goal.mli index b8c979ad7a..a033d6daab 100644 --- a/proofs/goal.mli +++ b/proofs/goal.mli @@ -71,3 +71,5 @@ module V82 : sig val abstract_type : Evd.evar_map -> goal -> EConstr.types end + +module Set : sig include Set.S with type elt = goal end diff --git a/proofs/logic.ml b/proofs/logic.ml index e8ca719932..613581ade7 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -62,6 +62,7 @@ let is_unification_error = function let catchable_exception = function | CErrors.UserError _ | TypeError _ + | Notation.NumeralNotationError _ | RefinerError _ | Indrec.RecursionSchemeError _ | Nametab.GlobalizationError _ (* reduction errors *) diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index d971c28a26..e6507332b1 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -51,23 +51,22 @@ let _ = CErrors.register_handler begin function | _ -> raise CErrors.Unhandled end -let get_nth_V82_goal i = - let p = Proof_global.give_me_the_proof () in +let get_nth_V82_goal p i = let goals,_,_,_,sigma = Proof.proof p in try { it = List.nth goals (i-1) ; sigma } with Failure _ -> raise NoSuchGoal -let get_goal_context_gen i = - let { it=goal ; sigma=sigma; } = get_nth_V82_goal i in +let get_goal_context_gen p i = + let { it=goal ; sigma=sigma; } = get_nth_V82_goal p i in (sigma, Refiner.pf_env { it=goal ; sigma=sigma; }) let get_goal_context i = - try get_goal_context_gen i + try get_goal_context_gen (Proof_global.give_me_the_proof ()) i with Proof_global.NoCurrentProof -> CErrors.user_err Pp.(str "No focused proof.") | NoSuchGoal -> CErrors.user_err Pp.(str "No such goal.") let get_current_goal_context () = - try get_goal_context_gen 1 + try get_goal_context_gen (Proof_global.give_me_the_proof ()) 1 with Proof_global.NoCurrentProof -> CErrors.user_err Pp.(str "No focused proof.") | NoSuchGoal -> (* spiwack: returning empty evar_map, since if there is no goal, under focus, @@ -75,14 +74,18 @@ let get_current_goal_context () = let env = Global.env () in (Evd.from_env env, env) -let get_current_context () = - try get_goal_context_gen 1 +let get_current_context ?p () = + let current_proof_by_default = function + | Some p -> p + | None -> Proof_global.give_me_the_proof () + in + try get_goal_context_gen (current_proof_by_default p) 1 with Proof_global.NoCurrentProof -> let env = Global.env () in (Evd.from_env env, env) | NoSuchGoal -> (* No more focused goals ? *) - let p = Proof_global.give_me_the_proof () in + let p = (current_proof_by_default p) in let evd = Proof.in_proof p (fun x -> x) in (evd, Global.env ()) diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index e02b5ab956..5feb5bd645 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -60,7 +60,7 @@ val get_current_goal_context : unit -> Evd.evar_map * env If there is no pending proof then it returns the current global environment and empty evar_map. *) -val get_current_context : unit -> Evd.evar_map * env +val get_current_context : ?p:Proof.t -> unit -> Evd.evar_map * env (** [current_proof_statement] *) diff --git a/proofs/proof.ml b/proofs/proof.ml index 0d355890c5..8bbd82bb0a 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -488,3 +488,12 @@ module V82 = struct { pr with proofview ; shelf } end + +let all_goals p = + let add gs set = + List.fold_left (fun s g -> Goal.Set.add g s) set gs in + let (goals,stack,shelf,given_up,_) = proof p in + let set = add goals Goal.Set.empty in + let set = List.fold_left (fun s gs -> let (g1, g2) = gs in add g1 (add g2 set)) set stack in + let set = add shelf set in + add given_up set diff --git a/proofs/proof.mli b/proofs/proof.mli index 33addf13d7..511dcc2e00 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -210,3 +210,6 @@ module V82 : sig (* Implements the Existential command *) val instantiate_evar : int -> Constrexpr.constr_expr -> t -> t end + +(* returns the set of all goals in the proof *) +val all_goals : t -> Goal.Set.t diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml index 629b77be2a..44685d2bbd 100644 --- a/proofs/redexpr.ml +++ b/proofs/redexpr.ml @@ -52,7 +52,7 @@ let whd_cbn flags env sigma t = Reductionops.Stack.zip ~refold:true sigma state let strong_cbn flags = - strong (whd_cbn flags) + strong_with_flags whd_cbn flags let simplIsCbn = ref (false) let _ = Goptions.declare_bool_option { diff --git a/stm/stm.ml b/stm/stm.ml index 2e9bf71e49..b7ba163309 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1231,9 +1231,22 @@ end = struct (* {{{ *) let get_prev_proof ~doc id = try - let did = fold_until back_tactic 1 id in - get_proof ~doc did - with Not_found -> None + let np = get_proof ~doc id in + match np with + | None -> None + | Some cp -> + let did = ref id in + let rv = ref np in + let done_ = ref false in + while not !done_ do + did := fold_until back_tactic 1 !did; + rv := get_proof ~doc !did; + done_ := match !rv with + | Some rv -> not (Goal.Set.equal (Proof.all_goals rv) (Proof.all_goals cp)) + | None -> true + done; + !rv + with Not_found | Proof_global.NoCurrentProof -> None end (* }}} *) @@ -1996,7 +2009,7 @@ end = struct (* {{{ *) 1 goals in TaskQueue.join queue; let assign_tac : unit Proofview.tactic = - Proofview.(Goal.nf_enter begin fun g -> + Proofview.(Goal.enter begin fun g -> let gid = Goal.goal g in let f = try List.assoc gid res @@ -2288,7 +2301,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = | `Leaks -> Exninfo.iraise exn | `ValidBlock { base_state; goals_to_admit; recovery_command } -> begin let tac = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> if CList.mem_f Evar.equal (Proofview.Goal.goal gl) goals_to_admit then Proofview.give_up else Proofview.tclUNIT () diff --git a/stm/stm.mli b/stm/stm.mli index 7f70ea18da..1e5ceb7e23 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -111,7 +111,8 @@ val add : doc:doc -> ontop:Stateid.t -> ?newtip:Stateid.t -> doc * Stateid.t * [ `NewTip | `Unfocus of Stateid.t ] (* Returns the proof state before the last tactic that was applied at or before -the specified state. Used to compute proof diffs. *) +the specified state AND that has differences in the underlying proof (i.e., +ignoring proofview-only changes). Used to compute proof diffs. *) val get_prev_proof : doc:doc -> Stateid.t -> Proof.t option (* [query at ?report_with cmd] Executes [cmd] at a given state [at], diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 2170477938..85babd922b 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -168,7 +168,8 @@ let classify_vernac e = | VernacDeclareModuleType ({v=id},bl,_,_) -> VtSideff [id], if bl = [] then VtLater else VtNow (* These commands alter the parser *) - | VernacOpenCloseScope _ | VernacDelimiters _ | VernacBindScope _ + | VernacOpenCloseScope _ | VernacDeclareScope _ + | VernacDelimiters _ | VernacBindScope _ | VernacInfix _ | VernacNotation _ | VernacNotationAddFormat _ | VernacSyntaxExtension _ | VernacSyntacticDefinition _ diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index c8fd0b7a75..8e296de617 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -162,7 +162,7 @@ let gen_auto_multi_rewrite conds tac_main lbas cl = | None -> (* try to rewrite in all hypothesis (except maybe the rewritten one) *) - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let ids = Tacmach.New.pf_ids_of_hyps gl in try_do_hyps (fun id -> id) ids end) diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml index aca7f6c65e..bfee0422e7 100644 --- a/tactics/btermdn.ml +++ b/tactics/btermdn.ml @@ -28,7 +28,7 @@ type term_label = | SortLabel let compare_term_label t1 t2 = match t1, t2 with -| GRLabel gr1, GRLabel gr2 -> RefOrdered.compare gr1 gr2 +| GRLabel gr1, GRLabel gr2 -> GlobRef.Ordered.compare gr1 gr2 | _ -> Pervasives.compare t1 t2 (** OK *) type 'res lookup_res = 'res Dn.lookup_res = Label of 'res | Nothing | Everything diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 9c5fdcd1ce..3456d13bbe 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -416,7 +416,7 @@ and e_my_find_search db_list local_db secvars hdc complete only_classes env sigm if get_typeclasses_filtered_unification () then let tac = matches_pattern concl p <*> - Proofview.Goal.nf_enter + Proofview.Goal.enter (fun gl -> unify_resolve_refine poly flags gl (c,None,clenv)) in Tacticals.New.tclTHEN tac Proofview.shelve_unifiable else diff --git a/tactics/equality.ml b/tactics/equality.ml index 0e39215701..d0f4b2c680 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -249,7 +249,7 @@ let rewrite_elim with_evars frzevars cls c e = let tclNOTSAMEGOAL tac = let goal gl = Proofview.Goal.goal gl in - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = project gl in let ev = goal gl in tac >>= fun () -> diff --git a/tactics/hints.ml b/tactics/hints.ml index 43a450ea71..3835dee299 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -288,7 +288,7 @@ let lookup_tacs sigma concl st se = let sl' = List.stable_sort pri_order_int l' in List.merge pri_order_int se.sentry_nopat sl' -module Constr_map = Map.Make(RefOrdered) +module Constr_map = Map.Make(GlobRef.Ordered) let is_transparent_gr (ids, csts) = function | VarRef id -> Id.Pred.mem id ids @@ -734,8 +734,6 @@ module Hintdbmap = String.Map type hint_db = Hint_db.t -type hint_db_table = hint_db Hintdbmap.t ref - (** Initially created hint databases, for typeclasses and rewrite *) let typeclasses_db = "typeclass_instances" @@ -746,8 +744,8 @@ let auto_init_db = (Hintdbmap.add rewrite_db (Hint_db.empty cst_full_transparent_state true) Hintdbmap.empty) -let searchtable : hint_db_table = ref auto_init_db -let statustable = ref KNmap.empty +let searchtable = Summary.ref ~name:"searchtable" auto_init_db +let statustable = Summary.ref ~name:"statustable" KNmap.empty let searchtable_map name = Hintdbmap.find name !searchtable @@ -762,25 +760,6 @@ let error_no_such_hint_database x = user_err ~hdr:"Hints" (str "No such Hint database: " ++ str x ++ str ".") (**************************************************************************) -(* Definition of the summary *) -(**************************************************************************) - -let hints_init : (unit -> unit) ref = ref (fun () -> ()) -let add_hints_init f = - let init = !hints_init in - hints_init := (fun () -> init (); f ()) - -let init () = - searchtable := auto_init_db; statustable := KNmap.empty; !hints_init () -let freeze _ = (!searchtable, !statustable) -let unfreeze (fs, st) = searchtable := fs; statustable := st - -let _ = Summary.declare_summary "search" - { Summary.freeze_function = freeze; - Summary.unfreeze_function = unfreeze; - Summary.init_function = init } - -(**************************************************************************) (* Auxiliary functions to prepare AUTOHINT objects *) (**************************************************************************) diff --git a/tactics/hints.mli b/tactics/hints.mli index 9bf6c175a5..c49ca2094a 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -293,8 +293,5 @@ val pr_hint_db : Hint_db.t -> Pp.t [@@ocaml.deprecated "please used pr_hint_db_env"] val pr_hint : env -> evar_map -> hint -> Pp.t -(** Hook for changing the initialization of auto *) -val add_hints_init : (unit -> unit) -> unit - type nonrec hint_info = hint_info [@@ocaml.deprecated "Use [Typeclasses.hint_info]"] diff --git a/tactics/tactics.ml b/tactics/tactics.ml index d536204ec3..6999b17d8e 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -2690,6 +2690,34 @@ let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = let (sigma, x) = new_evar newenv sigma ~principal:true ~store ccl in (sigma, mkNamedLetIn id c t x) +let pose_tac na c = + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env gl in + let hyps = named_context_val env in + let concl = Proofview.Goal.concl gl in + let t = typ_of env sigma c in + let (sigma, t) = Evarsolve.refresh_universes ~onlyalg:true (Some false) env sigma t in + let id = match na with + | Name id -> + let () = if mem_named_context_val id hyps then + user_err (str "Variable " ++ Id.print id ++ str " is already declared.") + in + id + | Anonymous -> + let id = id_of_name_using_hdchar env sigma t Anonymous in + next_ident_away_in_goal id (ids_of_named_context_val hyps) + in + Proofview.Unsafe.tclEVARS sigma <*> + Refine.refine ~typecheck:false begin fun sigma -> + let nhyps = EConstr.push_named_context_val (NamedDecl.LocalDef (id, c, t)) hyps in + let (sigma, ev) = Evarutil.new_pure_evar nhyps sigma concl in + let inst = Array.map_of_list (fun d -> mkVar (get_id d)) (named_context env) in + let body = mkEvar (ev, Array.append [|mkRel 1|] inst) in + (sigma, mkLetIn (Name id, c, t, body)) + end + end + let letin_tac with_eq id c ty occs = Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in @@ -2796,7 +2824,7 @@ let generalize_goal gl i ((occs,c,b),na as o) (cl,sigma) = let generalize_dep ?(with_let=false) c = let open Tacmach.New in let open Tacticals.New in - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = pf_env gl in let sign = Proofview.Goal.hyps gl in let sigma = project gl in diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 57f20d2ff2..c088e404b0 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -390,6 +390,8 @@ val cut : types -> unit Proofview.tactic (** {6 Tactics for adding local definitions. } *) +val pose_tac : Name.t -> constr -> unit Proofview.tactic + val letin_tac : (bool * intro_pattern_naming) option -> Name.t -> constr -> types option -> clause -> unit Proofview.tactic diff --git a/tactics/term_dnet.ml b/tactics/term_dnet.ml index 8bdcc63215..03d2a17eee 100644 --- a/tactics/term_dnet.ml +++ b/tactics/term_dnet.ml @@ -100,7 +100,7 @@ struct | DRel, _ -> -1 | _, DRel -> 1 | DSort, DSort -> 0 | DSort, _ -> -1 | _, DSort -> 1 - | DRef gr1, DRef gr2 -> RefOrdered.compare gr1 gr2 + | DRef gr1, DRef gr2 -> GlobRef.Ordered.compare gr1 gr2 | DRef _, _ -> -1 | _, DRef _ -> 1 | DCtx (tl1, tr1), DCtx (tl2, tr2) diff --git a/test-suite/Makefile b/test-suite/Makefile index b8aac8b6f8..93ce519350 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -106,7 +106,8 @@ SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide vio coqchk coqwc coq-makefile unit-te PREREQUISITELOG = prerequisite/admit.v.log \ prerequisite/make_local.v.log prerequisite/make_notation.v.log \ - prerequisite/bind_univs.v.log + prerequisite/bind_univs.v.log prerequisite/module_bug8416.v.log \ + prerequisite/module_bug7192.v.log ####################################################################### # Phony targets @@ -126,14 +127,14 @@ clean: $(SHOW) 'RM <**/*.stamp> <**/*.vo> <**/*.vio> <**/*.log> <**/*.glob>' $(HIDE)find . \( \ -name '*.stamp' -o -name '*.vo' -o -name '*.vio' -o -name '*.log' -o -name '*.glob' \ - \) -print0 | xargs -0 rm -f + \) -exec rm -f {} + $(SHOW) 'RM <**/*.cmx> <**/*.cmi> <**/*.o> <**/*.test>' $(HIDE)find unit-tests \( \ -name '*.cmx' -o -name '*.cmi' -o -name '*.o' -o -name '*.test' \ - \) -print0 | xargs -0 rm -f + \) -exec rm -f {} + distclean: clean $(SHOW) 'RM <**/*.aux>' - $(HIDE)find . -name '*.aux' -print0 | xargs -0 rm -f + $(HIDE)find . -name '*.aux' -exec rm -f {} + ####################################################################### # Per-subsystem targets @@ -195,10 +196,7 @@ PRINT_LOGS:=APPVEYOR endif #APPVEYOR report: summary.log - $(HIDE)bash save-logs.sh - $(HIDE)if [ -n "${TRAVIS}" ]; then find logs/ -name '*.log' -not -name 'summary.log' -exec 'bash' '-c' 'echo "travis_fold:start:coq.logs.$$(echo '{}' | sed s,/,.,g)"' ';' -exec cat '{}' ';' -exec 'bash' '-c' 'echo "travis_fold:end:coq.logs.$$(echo '{}' | sed s,/,.,g)"' ';'; fi - $(HIDE)if [ -n "${PRINT_LOGS}" ]; then find logs/ -name '*.log' -not -name 'summary.log' -exec 'bash' '-c' 'echo {}' ';' -exec cat '{}' ';' -exec 'bash' '-c' 'echo' ';'; fi - $(HIDE)if grep -q -F 'Error!' summary.log ; then echo FAILURES; grep -F 'Error!' summary.log; false; else echo NO FAILURES; fi + $(HIDE)bash report.sh ####################################################################### # Regression (and progression) tests diff --git a/test-suite/bugs/2428.v b/test-suite/bugs/closed/2428.v index a4f587a58d..b398a76d91 100644 --- a/test-suite/bugs/2428.v +++ b/test-suite/bugs/closed/2428.v @@ -5,6 +5,6 @@ Definition myFact := forall x, P x. Hint Extern 1 (P _) => progress (unfold myFact in *). Lemma test : (True -> myFact) -> P 3. -Proof. +Proof. intros. debug eauto. Qed. diff --git a/test-suite/bugs/closed/2670.v b/test-suite/bugs/closed/2670.v index c401420e94..791889b24b 100644 --- a/test-suite/bugs/closed/2670.v +++ b/test-suite/bugs/closed/2670.v @@ -15,6 +15,14 @@ Proof. refine (match e return _ with refl_equal => _ end). reflexivity. Undo 2. + (** Check insensitivity to alphabetic order *) + refine (match e as a in _ = b return _ with refl_equal => _ end). + reflexivity. + Undo 2. + (** Check insensitivity to alphabetic order *) + refine (match e as z in _ = y return _ with refl_equal => _ end). + reflexivity. + Undo 2. (* Next line similarly has a dependent and a non dependent solution *) refine (match e with refl_equal => _ end). reflexivity. diff --git a/test-suite/bugs/4623.v b/test-suite/bugs/closed/4623.v index 7ecfd98b67..7ecfd98b67 100644 --- a/test-suite/bugs/4623.v +++ b/test-suite/bugs/closed/4623.v diff --git a/test-suite/bugs/4624.v b/test-suite/bugs/closed/4624.v index f5ce981cd0..f5ce981cd0 100644 --- a/test-suite/bugs/4624.v +++ b/test-suite/bugs/closed/4624.v diff --git a/test-suite/bugs/7333.v b/test-suite/bugs/closed/7333.v index fba5b9029d..fba5b9029d 100644 --- a/test-suite/bugs/7333.v +++ b/test-suite/bugs/closed/7333.v diff --git a/test-suite/bugs/closed/7754.v b/test-suite/bugs/closed/7754.v new file mode 100644 index 0000000000..229df93773 --- /dev/null +++ b/test-suite/bugs/closed/7754.v @@ -0,0 +1,21 @@ + +Set Universe Polymorphism. + +Module OK. + + Inductive one@{i j} : Type@{i} := + with two : Type@{j} := . + Check one@{Set Type} : Set. + Fail Check two@{Set Type} : Set. + +End OK. + +Module Bad. + + Fail Inductive one := + with two@{i +} : Type@{i} := . + + Fail Inductive one@{i +} := + with two@{i +} := . + +End Bad. diff --git a/test-suite/bugs/closed/8270.v b/test-suite/bugs/closed/8270.v new file mode 100644 index 0000000000..f36f757f10 --- /dev/null +++ b/test-suite/bugs/closed/8270.v @@ -0,0 +1,15 @@ +(* Don't do zeta in cbn when not asked for *) + +Goal let x := 0 in + let y := x in + y = 0. + (* We use "cofix" as an example because there are obviously no + cofixpoints in sight. This problem arises with any set of + reduction flags (not including zeta where the lets are of course reduced away) *) + cbn cofix. + intro x. + unfold x at 1. (* Should succeed *) + Undo 2. + cbn zeta. + Fail unfold x at 1. +Abort. diff --git a/test-suite/bugs/closed/8288.v b/test-suite/bugs/closed/8288.v new file mode 100644 index 0000000000..0350be9c06 --- /dev/null +++ b/test-suite/bugs/closed/8288.v @@ -0,0 +1,7 @@ +Set Universe Polymorphism. +Set Printing Universes. + +Set Polymorphic Inductive Cumulativity. + +Inductive foo := C : (forall A : Type -> Type, A Type) -> foo. +(* anomaly invalid subtyping relation *) diff --git a/test-suite/bugs/closed/8432.v b/test-suite/bugs/closed/8432.v new file mode 100644 index 0000000000..844ee12668 --- /dev/null +++ b/test-suite/bugs/closed/8432.v @@ -0,0 +1,39 @@ +Require Import Program.Tactics. + +Obligation Tactic := idtac. +Set Universe Polymorphism. + +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Inductive Empty : Type :=. +Inductive Unit : Type := tt. +Definition not (A : Type) := A -> Empty. + + Lemma nat_path_O_S (n : nat) (H : paths O (S n)) : Empty. + Proof. refine ( + match H in paths _ i return + match i with + | O => Unit + | S _ => Empty + end + with + | idpath _ => tt + end + ). Defined. + Lemma symmetry {A} (x y : A) (p : paths x y) : paths y x. + Proof. + destruct p. apply idpath. + Defined. + Lemma nat_path_S_O (n : nat) (H : paths (S n) O) : Empty. + Proof. eapply nat_path_O_S. exact (symmetry _ _ H). Defined. +Set Printing Universes. +Program Fixpoint succ_not_zero (n:nat) : not (paths (S n) 0) := +match n as n return not (paths (S n) 0) with +| 0 => nat_path_S_O _ +| S n' => let dummy := succ_not_zero n' in _ +end. +Next Obligation. + intros f _ n dummy H. exact (nat_path_S_O _ H). + Show Universes. +Defined. diff --git a/test-suite/misc/poly-capture-global-univs.sh b/test-suite/misc/poly-capture-global-univs.sh new file mode 100755 index 0000000000..e066ac039b --- /dev/null +++ b/test-suite/misc/poly-capture-global-univs.sh @@ -0,0 +1,19 @@ +#!/usr/bin/env bash + +set -e + +export COQBIN=$BIN +export PATH=$COQBIN:$PATH + +cd misc/poly-capture-global-univs/ + +coq_makefile -f _CoqProject -o Makefile + +make clean + +make src/evil_plugin.cmxs + +if make; then + >&2 echo 'Should have failed!' + exit 1 +fi diff --git a/test-suite/misc/poly-capture-global-univs/.gitignore b/test-suite/misc/poly-capture-global-univs/.gitignore new file mode 100644 index 0000000000..f5a6d22b8e --- /dev/null +++ b/test-suite/misc/poly-capture-global-univs/.gitignore @@ -0,0 +1 @@ +/Makefile* diff --git a/test-suite/misc/poly-capture-global-univs/_CoqProject b/test-suite/misc/poly-capture-global-univs/_CoqProject new file mode 100644 index 0000000000..70ec246062 --- /dev/null +++ b/test-suite/misc/poly-capture-global-univs/_CoqProject @@ -0,0 +1,9 @@ +-Q theories Evil +-I src + +src/evil.ml4 +src/evilImpl.ml +src/evilImpl.mli +src/evil_plugin.mlpack +theories/evil.v + diff --git a/test-suite/misc/poly-capture-global-univs/src/evil.ml4 b/test-suite/misc/poly-capture-global-univs/src/evil.ml4 new file mode 100644 index 0000000000..565e979aaa --- /dev/null +++ b/test-suite/misc/poly-capture-global-univs/src/evil.ml4 @@ -0,0 +1,9 @@ + +open Stdarg +open EvilImpl + +DECLARE PLUGIN "evil_plugin" + +VERNAC COMMAND FUNCTIONAL EXTEND VernacEvil CLASSIFIED AS SIDEFF +| [ "Evil" ident(x) ident(y) ] -> [ fun ~atts ~st -> evil x y; st ] +END diff --git a/test-suite/misc/poly-capture-global-univs/src/evilImpl.ml b/test-suite/misc/poly-capture-global-univs/src/evilImpl.ml new file mode 100644 index 0000000000..6d8ce7c5d7 --- /dev/null +++ b/test-suite/misc/poly-capture-global-univs/src/evilImpl.ml @@ -0,0 +1,22 @@ +open Names + +let evil t f = + let open Univ in + let open Entries in + let open Decl_kinds in + let open Constr in + let k = IsDefinition Definition in + let u = Level.var 0 in + let tu = mkType (Universe.make u) in + let te = Declare.definition_entry + ~univs:(Monomorphic_const_entry (ContextSet.singleton u)) tu + in + let tc = Declare.declare_constant t (DefinitionEntry te, k) in + let tc = mkConst tc in + + let fe = Declare.definition_entry + ~univs:(Polymorphic_const_entry (UContext.make (Instance.of_array [|u|],Constraint.empty))) + ~types:(Term.mkArrow tc tu) + (mkLambda (Name.Name (Id.of_string "x"), tc, mkRel 1)) + in + ignore (Declare.declare_constant f (DefinitionEntry fe, k)) diff --git a/test-suite/misc/poly-capture-global-univs/src/evilImpl.mli b/test-suite/misc/poly-capture-global-univs/src/evilImpl.mli new file mode 100644 index 0000000000..97c7e3dadd --- /dev/null +++ b/test-suite/misc/poly-capture-global-univs/src/evilImpl.mli @@ -0,0 +1,2 @@ + +val evil : Names.Id.t -> Names.Id.t -> unit diff --git a/test-suite/misc/poly-capture-global-univs/src/evil_plugin.mlpack b/test-suite/misc/poly-capture-global-univs/src/evil_plugin.mlpack new file mode 100644 index 0000000000..0093328a40 --- /dev/null +++ b/test-suite/misc/poly-capture-global-univs/src/evil_plugin.mlpack @@ -0,0 +1,2 @@ +EvilImpl +Evil diff --git a/test-suite/misc/poly-capture-global-univs/theories/evil.v b/test-suite/misc/poly-capture-global-univs/theories/evil.v new file mode 100644 index 0000000000..7fd98c2773 --- /dev/null +++ b/test-suite/misc/poly-capture-global-univs/theories/evil.v @@ -0,0 +1,13 @@ + +Declare ML Module "evil_plugin". + +Evil T f. (* <- if this doesn't fail then the rest goes through *) + +Definition g : Type -> Set := f. + +Require Import Hurkens. + +Lemma absurd : False. +Proof. + exact (TypeNeqSmallType.paradox (g Type) eq_refl). +Qed. diff --git a/test-suite/output/Arguments.v b/test-suite/output/Arguments.v index bd9240476f..b67ac4f0df 100644 --- a/test-suite/output/Arguments.v +++ b/test-suite/output/Arguments.v @@ -10,6 +10,8 @@ Arguments Nat.sub !n !m. About Nat.sub. Definition pf (D1 C1 : Type) (f : D1 -> C1) (D2 C2 : Type) (g : D2 -> C2) := fun x => (f (fst x), g (snd x)). +Declare Scope foo_scope. +Declare Scope bar_scope. Delimit Scope foo_scope with F. Arguments pf {D1%F C1%type} f [D2 C2] g x : simpl never. About pf. diff --git a/test-suite/output/Notations.out b/test-suite/output/Notations.out index b60b1ee863..94b86fc222 100644 --- a/test-suite/output/Notations.out +++ b/test-suite/output/Notations.out @@ -125,13 +125,15 @@ s : nat fun _ : nat => 9 : nat -> nat -fun (x : nat) (p : x = x) => match p with - | ONE => ONE - end = p +fun (x : nat) (p : x = x) => +match p in (_ = n) return (n = n) with +| ONE => ONE +end = p : forall x : nat, x = x -> Prop -fun (x : nat) (p : x = x) => match p with - | 1 => 1 - end = p +fun (x : nat) (p : x = x) => +match p in (_ = n) return (n = n) with +| 1 => 1 +end = p : forall x : nat, x = x -> Prop bar 0 : nat diff --git a/test-suite/output/Notations.v b/test-suite/output/Notations.v index fe6c05c39e..adab324cf0 100644 --- a/test-suite/output/Notations.v +++ b/test-suite/output/Notations.v @@ -76,6 +76,7 @@ Open Scope nat_scope. Inductive znat : Set := Zpos (n : nat) | Zneg (m : nat). Coercion Zpos: nat >-> znat. +Declare Scope znat_scope. Delimit Scope znat_scope with znat. Open Scope znat_scope. diff --git a/test-suite/output/PrintAssumptions.out b/test-suite/output/PrintAssumptions.out index 34f44cd246..3f4d5ef58c 100644 --- a/test-suite/output/PrintAssumptions.out +++ b/test-suite/output/PrintAssumptions.out @@ -20,3 +20,5 @@ Axioms: M.foo : False Closed under the global context Closed under the global context +Closed under the global context +Closed under the global context diff --git a/test-suite/output/PrintAssumptions.v b/test-suite/output/PrintAssumptions.v index ea1ab63786..3d4dfe603d 100644 --- a/test-suite/output/PrintAssumptions.v +++ b/test-suite/output/PrintAssumptions.v @@ -137,3 +137,13 @@ Module F (X : T). End F. End SUBMODULES. + +(* Testing a variant of #7192 across files *) +(* This was missing in the original fix to #7192 *) +Require Import module_bug7192. +Print Assumptions M7192.D.f. + +(* Testing reporting assumptions from modules in files *) +(* A regression introduced in the original fix to #7192 was missing implementations *) +Require Import module_bug8416. +Print Assumptions M8416.f. diff --git a/test-suite/output/Quote.v b/test-suite/output/Quote.v deleted file mode 100644 index 2c373d5052..0000000000 --- a/test-suite/output/Quote.v +++ /dev/null @@ -1,36 +0,0 @@ -Require Import Quote. - -Parameter A B : Prop. - -Inductive formula : Type := - | f_and : formula -> formula -> formula - | f_or : formula -> formula -> formula - | f_not : formula -> formula - | f_true : formula - | f_atom : index -> formula - | f_const : Prop -> formula. - -Fixpoint interp_f (vm: - varmap Prop) (f:formula) {struct f} : Prop := - match f with - | f_and f1 f2 => interp_f vm f1 /\ interp_f vm f2 - | f_or f1 f2 => interp_f vm f1 \/ interp_f vm f2 - | f_not f1 => ~ interp_f vm f1 - | f_true => True - | f_atom i => varmap_find True i vm - | f_const c => c - end. - -Goal A \/ B -> A /\ (B \/ A) /\ (A \/ ~ B). -intro H. -match goal with - | H : ?a \/ ?b |- _ => quote interp_f in a using (fun x => idtac x; change (x \/ b) in H) -end. -match goal with - |- ?g => quote interp_f [ A ] in g using (fun x => idtac x) -end. -quote interp_f. -Show. -simpl; quote interp_f [ A ]. -Show. -Admitted. diff --git a/test-suite/output/ltac.out b/test-suite/output/ltac.out index eb9f571022..efdc94fb1e 100644 --- a/test-suite/output/ltac.out +++ b/test-suite/output/ltac.out @@ -38,3 +38,14 @@ Ltac foo := let w := () in let z := 1 in pose v +2 subgoals + + n : nat + ============================ + (fix a (n0 : nat) : nat := match n0 with + | 0 => 0 + | S n1 => a n1 + end) n = n + +subgoal 2 is: + forall a : nat, a = 0 diff --git a/test-suite/output/ltac.v b/test-suite/output/ltac.v index 901b1e3aa6..40e743c3f0 100644 --- a/test-suite/output/ltac.v +++ b/test-suite/output/ltac.v @@ -71,3 +71,13 @@ Ltac foo := let z := 1 in pose v. Print Ltac foo. + +(* Ltac renaming was not applied to "fix" and "cofix" *) + +Goal forall a, a = 0. +match goal with +|- (forall x, x = _) => assert (forall n, (fix x n := match n with O => O | S n => x n end) n = n) +end. +intro. +Show. +Abort. diff --git a/test-suite/prerequisite/module_bug7192.v b/test-suite/prerequisite/module_bug7192.v new file mode 100644 index 0000000000..82cfe560af --- /dev/null +++ b/test-suite/prerequisite/module_bug7192.v @@ -0,0 +1,9 @@ +(* Variant of #7192 to be tested in a file requiring this file *) +(* #7192 is about Print Assumptions not entering implementation of submodules *) + +Definition a := True. +Module Type B. Axiom f : Prop. End B. +Module Type C. Declare Module D : B. End C. +Module M7192: C. + Module D <: B. Definition f := a. End D. +End M7192. diff --git a/test-suite/prerequisite/module_bug8416.v b/test-suite/prerequisite/module_bug8416.v new file mode 100644 index 0000000000..70f43d132a --- /dev/null +++ b/test-suite/prerequisite/module_bug8416.v @@ -0,0 +1,2 @@ +Module Type A. Axiom f : True. End A. +Module M8416 : A. Definition f := I. End M8416. diff --git a/test-suite/report.sh b/test-suite/report.sh new file mode 100755 index 0000000000..05f39b4b02 --- /dev/null +++ b/test-suite/report.sh @@ -0,0 +1,55 @@ +#!/usr/bin/env bash + +# save failed logs to logs/, then print failure information +# returns failure code if any failed logs exist + +# save step + +SAVEDIR="logs" + +# reset for local builds +rm -rf "$SAVEDIR" +mkdir "$SAVEDIR" + +# keep this synced with test-suite/Makefile +FAILMARK="==========> FAILURE <==========" + +FAILED=$(mktemp /tmp/coq-check-XXXXXX) +find . '(' -path ./bugs/opened -prune ')' -o '(' -name '*.log' -exec grep "$FAILMARK" -q '{}' ';' -print0 ')' > "$FAILED" + +rsync -a --from0 --files-from="$FAILED" . "$SAVEDIR" +cp summary.log "$SAVEDIR"/ + +# cleanup +rm "$FAILED" + +# print info +if [ -n "$TRAVIS" ] || [ -n "$PRINT_LOGS" ]; then + find logs/ -name '*.log' -not -name 'summary.log' -print0 | while IFS= read -r -d '' file; do + if [ -n "$TRAVIS" ]; then + # ${foo////.} replaces every / by . in $foo + printf 'travis_fold:start:coq.logs.%s\n' "${file////.}"; + else printf '%s\n' "$file" + fi + + cat "$file" + + if [ -n "$TRAVIS" ]; then + # ${foo////.} replaces every / by . in $foo + printf 'travis_fold:end:coq.logs.%s\n' "${file////.}"; + else printf '\n' + fi + done +fi + +if grep -q -F 'Error!' summary.log ; then + echo FAILURES; + grep -F 'Error!' summary.log; + if [ -z "$TRAVIS" ] && [ -z "$PRINT_LOGS" ]; then + echo 'To print details of failed tests, rerun with environment variable PRINT_LOGS=1' + echo 'eg "make report PRINT_LOGS=1" from the test suite directory"' + echo 'See README.md in the test suite directory for more information.' + fi + false +else echo NO FAILURES; +fi diff --git a/test-suite/save-logs.sh b/test-suite/save-logs.sh deleted file mode 100755 index 9b8fff09f8..0000000000 --- a/test-suite/save-logs.sh +++ /dev/null @@ -1,19 +0,0 @@ -#!/usr/bin/env bash - -SAVEDIR="logs" - -# reset for local builds -rm -rf "$SAVEDIR" -mkdir "$SAVEDIR" - -# keep this synced with test-suite/Makefile -FAILMARK="==========> FAILURE <==========" - -FAILED=$(mktemp /tmp/coq-check-XXXXXX) -find . '(' -path ./bugs/opened -prune ')' -o '(' -name '*.log' -exec grep "$FAILMARK" -q '{}' ';' -print0 ')' > "$FAILED" - -rsync -a --from0 --files-from="$FAILED" . "$SAVEDIR" -cp summary.log "$SAVEDIR"/ - -# cleanup -rm "$FAILED" diff --git a/test-suite/success/ROmega4.v b/test-suite/success/ROmega4.v index 58ae5b8fb8..a724592749 100644 --- a/test-suite/success/ROmega4.v +++ b/test-suite/success/ROmega4.v @@ -3,12 +3,12 @@ See also #148 for the corresponding improvement in Omega. *) -Require Import ZArith ROmega. +Require Import ZArith Lia. Open Scope Z. Goal let x := 3 in x = 3. intros. -romega. +lia. Qed. (** Example seen in #4132 @@ -22,5 +22,5 @@ Lemma foo (H : - zxy' <= zxy) (H' : zxy' <= x') : - b <= zxy. Proof. -romega. +lia. Qed. diff --git a/test-suite/success/Template.v b/test-suite/success/Template.v new file mode 100644 index 0000000000..1c6e2d81d8 --- /dev/null +++ b/test-suite/success/Template.v @@ -0,0 +1,48 @@ +Set Printing Universes. + +Module AutoYes. + Inductive Box (A:Type) : Type := box : A -> Box A. + + About Box. + + (* This checks that Box is template poly, see module No for how it fails *) + Universe i j. Constraint i < j. + Definition j_lebox (A:Type@{j}) := Box A. + Definition box_lti A := Box A : Type@{i}. + +End AutoYes. + +Module AutoNo. + Unset Auto Template Polymorphism. + Inductive Box (A:Type) : Type := box : A -> Box A. + + About Box. + + Universe i j. Constraint i < j. + Definition j_lebox (A:Type@{j}) := Box A. + Fail Definition box_lti A := Box A : Type@{i}. + +End AutoNo. + +Module Yes. + #[template] + Inductive Box@{i} (A:Type@{i}) : Type@{i} := box : A -> Box A. + + About Box. + + Universe i j. Constraint i < j. + Definition j_lebox (A:Type@{j}) := Box A. + Definition box_lti A := Box A : Type@{i}. + +End Yes. + +Module No. + #[notemplate] + Inductive Box (A:Type) : Type := box : A -> Box A. + + About Box. + + Universe i j. Constraint i < j. + Definition j_lebox (A:Type@{j}) := Box A. + Fail Definition box_lti A := Box A : Type@{i}. +End No. diff --git a/test-suite/success/apply.v b/test-suite/success/apply.v index b287b5facf..e1df9ba84a 100644 --- a/test-suite/success/apply.v +++ b/test-suite/success/apply.v @@ -559,3 +559,26 @@ split. - (* clear b:True *) match goal with H:_ |- _ => clear H end. (* use a:0=0 *) match goal with H:_ |- _ => exact H end. Qed. + +(* Test choice of most dependent solution *) +Goal forall n, n = 0 -> exists p, p = n /\ p = 0. +intros. eexists ?[p]. split. rewrite H. +reflexivity. (* Compatibility tells [?p:=n] rather than [?p:=0] *) +exact H. (* this checks that the goal is [n=0], not [0=0] *) +Qed. + +(* Check insensitivity to alphabetic order of names*) +(* In both cases, the last name is conventionally chosen *) +(* Before 8.9, the name coming first in alphabetic order *) +(* was chosen. *) +Goal forall m n, m = n -> n = 0 -> exists p, p = n /\ p = 0. +intros. eexists ?[p]. split. rewrite H. +reflexivity. +exact H0. +Qed. + +Goal forall n m, n = m -> m = 0 -> exists p, p = m /\ p = 0. +intros. eexists ?[p]. split. rewrite H. +reflexivity. +exact H0. +Qed. diff --git a/test-suite/success/ltac.v b/test-suite/success/ltac.v index 0f22a1f0a0..4404ff3f16 100644 --- a/test-suite/success/ltac.v +++ b/test-suite/success/ltac.v @@ -348,3 +348,32 @@ symmetry in H. match goal with h:_ |- _ => assert (h=h) end. (* h should be H0 *) exact (eq_refl H0). Abort. + +(* Check that internal names used in "match" compilation to push "term + to match" on the environment are not interpreted as ltac variables *) + +Module ToMatchNames. +Ltac g c := let r := constr:(match c return _ with a => 1 end) in idtac. +Goal True. +g 1. +Abort. +End ToMatchNames. + +(* An example where internal names used to build the return predicate + (here "n" because "a" is bound to "nil" and "n" is the first letter + of "nil") by small inversion should be taken distinct from Ltac names. *) + +Module LtacNames. +Inductive t (A : Type) : nat -> Type := + nil : t A 0 | cons : A -> forall n : nat, t A n -> t A (S n). + +Ltac f a n := + let x := constr:(match a with nil _ => true | cons _ _ _ _ => I end) in + assert (x=x/\n=n). + +Goal forall (y:t nat 0), True. +intros. +f y true. +Abort. + +End LtacNames. diff --git a/test-suite/vio/numeral.v b/test-suite/vio/numeral.v new file mode 100644 index 0000000000..f28355bb29 --- /dev/null +++ b/test-suite/vio/numeral.v @@ -0,0 +1,21 @@ +Lemma foo : True. +Proof. +Check 0 : nat. +Check 0 : nat. +exact I. +Qed. + +Lemma bar : True. +Proof. +pose (0 : nat). +exact I. +Qed. + +Require Import Coq.Strings.Ascii. +Open Scope char_scope. + +Lemma baz : True. +Proof. +pose "s". +exact I. +Qed. diff --git a/theories/Bool/Bool.v b/theories/Bool/Bool.v index 66a82008d8..42af3583d4 100644 --- a/theories/Bool/Bool.v +++ b/theories/Bool/Bool.v @@ -757,6 +757,8 @@ Qed. with lazy behavior (for vm_compute) *) (*****************************************) +Declare Scope lazy_bool_scope. + Notation "a &&& b" := (if a then b else false) (at level 40, left associativity) : lazy_bool_scope. Notation "a ||| b" := (if a then true else b) diff --git a/theories/Classes/CEquivalence.v b/theories/Classes/CEquivalence.v index 03e611f549..c376efef2e 100644 --- a/theories/Classes/CEquivalence.v +++ b/theories/Classes/CEquivalence.v @@ -35,6 +35,8 @@ Definition equiv `{Equivalence A R} : crelation A := R. (** Overloaded notations for setoid equivalence and inequivalence. Not to be confused with [eq] and [=]. *) +Declare Scope equiv_scope. + Notation " x === y " := (equiv x y) (at level 70, no associativity) : equiv_scope. Notation " x =/= y " := (complement equiv x y) (at level 70, no associativity) : equiv_scope. diff --git a/theories/Classes/CMorphisms.v b/theories/Classes/CMorphisms.v index 09b35ca75d..97510578ae 100644 --- a/theories/Classes/CMorphisms.v +++ b/theories/Classes/CMorphisms.v @@ -87,6 +87,7 @@ Hint Extern 2 (ProperProxy ?R _) => not_evar R; class_apply @proper_proper_proxy : typeclass_instances. (** Notations reminiscent of the old syntax for declaring morphisms. *) +Declare Scope signature_scope. Delimit Scope signature_scope with signature. Module ProperNotations. diff --git a/theories/Classes/Equivalence.v b/theories/Classes/Equivalence.v index 5217aedb88..516ea12099 100644 --- a/theories/Classes/Equivalence.v +++ b/theories/Classes/Equivalence.v @@ -35,6 +35,8 @@ Definition equiv `{Equivalence A R} : relation A := R. (** Overloaded notations for setoid equivalence and inequivalence. Not to be confused with [eq] and [=]. *) +Declare Scope equiv_scope. + Notation " x === y " := (equiv x y) (at level 70, no associativity) : equiv_scope. Notation " x =/= y " := (complement equiv x y) (at level 70, no associativity) : equiv_scope. diff --git a/theories/Classes/Morphisms.v b/theories/Classes/Morphisms.v index 1858ba76ae..001b7dfdfd 100644 --- a/theories/Classes/Morphisms.v +++ b/theories/Classes/Morphisms.v @@ -88,6 +88,7 @@ Hint Extern 2 (ProperProxy ?R _) => not_evar R; class_apply @proper_proper_proxy : typeclass_instances. (** Notations reminiscent of the old syntax for declaring morphisms. *) +Declare Scope signature_scope. Delimit Scope signature_scope with signature. Module ProperNotations. diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v index 2ab3af2029..86a3a88be9 100644 --- a/theories/Classes/RelationClasses.v +++ b/theories/Classes/RelationClasses.v @@ -357,6 +357,8 @@ Definition predicate_implication {l : Tlist} := (** Notations for pointwise equivalence and implication of predicates. *) +Declare Scope predicate_scope. + Infix "<∙>" := predicate_equivalence (at level 95, no associativity) : predicate_scope. Infix "-∙>" := predicate_implication (at level 70, right associativity) : predicate_scope. diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v index 3485b9c68d..b0d1824827 100644 --- a/theories/FSets/FMapAVL.v +++ b/theories/FSets/FMapAVL.v @@ -25,6 +25,7 @@ Unset Strict Implicit. (** Notations and helper lemma about pairs *) +Declare Scope pair_scope. Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope. Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope. diff --git a/theories/FSets/FMapFullAVL.v b/theories/FSets/FMapFullAVL.v index 3452967821..c0db8646c7 100644 --- a/theories/FSets/FMapFullAVL.v +++ b/theories/FSets/FMapFullAVL.v @@ -27,7 +27,7 @@ *) -Require Import FunInd Recdef FMapInterface FMapList ZArith Int FMapAVL ROmega. +Require Import FunInd Recdef FMapInterface FMapList ZArith Int FMapAVL Lia. Set Implicit Arguments. Unset Strict Implicit. @@ -39,7 +39,7 @@ Import Raw.Proofs. Local Open Scope pair_scope. Local Open Scope Int_scope. -Ltac omega_max := i2z_refl; romega with Z. +Ltac omega_max := i2z_refl; lia. Section Elt. Variable elt : Type. @@ -697,7 +697,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: end. Proof. intros; unfold cardinal_e_2; simpl; - abstract (do 2 rewrite cons_cardinal_e; romega with * ). + abstract (do 2 rewrite cons_cardinal_e; lia ). Defined. Definition Cmp c := diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index 1e6843d511..76c39f275d 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -37,8 +37,8 @@ Inductive bool : Set := Add Printing If bool. +Declare Scope bool_scope. Delimit Scope bool_scope with bool. - Bind Scope bool_scope with bool. (** Basic boolean operators *) @@ -136,6 +136,7 @@ Inductive nat : Set := | O : nat | S : nat -> nat. +Declare Scope nat_scope. Delimit Scope nat_scope with nat. Bind Scope nat_scope with nat. Arguments S _%nat. @@ -228,10 +229,13 @@ Inductive list (A : Type) : Type := Arguments nil {A}. Arguments cons {A} a l. -Infix "::" := cons (at level 60, right associativity) : list_scope. + +Declare Scope list_scope. Delimit Scope list_scope with list. Bind Scope list_scope with list. +Infix "::" := cons (at level 60, right associativity) : list_scope. + Local Open Scope list_scope. Definition length (A : Type) : list A -> nat := diff --git a/theories/Init/Decimal.v b/theories/Init/Decimal.v index 1ff00ec11c..537400fb05 100644 --- a/theories/Init/Decimal.v +++ b/theories/Init/Decimal.v @@ -42,8 +42,11 @@ Notation zero := (D0 Nil). Inductive int := Pos (d:uint) | Neg (d:uint). +Declare Scope dec_uint_scope. Delimit Scope dec_uint_scope with uint. Bind Scope dec_uint_scope with uint. + +Declare Scope dec_int_scope. Delimit Scope dec_int_scope with int. Bind Scope dec_int_scope with int. diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v index 72073bb4f6..8f8e639187 100644 --- a/theories/Init/Notations.v +++ b/theories/Init/Notations.v @@ -108,13 +108,17 @@ End IfNotations. (** Scopes *) -Delimit Scope type_scope with type. -Delimit Scope function_scope with function. +Declare Scope core_scope. Delimit Scope core_scope with core. -Bind Scope type_scope with Sortclass. +Declare Scope function_scope. +Delimit Scope function_scope with function. Bind Scope function_scope with Funclass. +Declare Scope type_scope. +Delimit Scope type_scope with type. +Bind Scope type_scope with Sortclass. + Open Scope core_scope. Open Scope function_scope. Open Scope type_scope. diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v index b6afba29a0..db8857df64 100644 --- a/theories/Init/Specif.v +++ b/theories/Init/Specif.v @@ -697,7 +697,7 @@ End Choice_lemmas. Section Dependent_choice_lemmas. - Variables X : Set. + Variable X : Set. Variable R : X -> X -> Prop. Lemma dependent_choice : diff --git a/theories/MSets/MSetAVL.v b/theories/MSets/MSetAVL.v index b966f217aa..aec88f93bf 100644 --- a/theories/MSets/MSetAVL.v +++ b/theories/MSets/MSetAVL.v @@ -340,6 +340,8 @@ Functional Scheme union_ind := Induction for union Sort Prop. (** Notations and helper lemma about pairs and triples *) +Declare Scope pair_scope. + Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope. Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope. Notation "t #l" := (t_left t) (at level 9, format "t '#l'") : pair_scope. diff --git a/theories/Numbers/BinNums.v b/theories/Numbers/BinNums.v index 3ba9d1f5ed..7b6740e94b 100644 --- a/theories/Numbers/BinNums.v +++ b/theories/Numbers/BinNums.v @@ -23,6 +23,7 @@ Inductive positive : Set := | xO : positive -> positive | xH : positive. +Declare Scope positive_scope. Delimit Scope positive_scope with positive. Bind Scope positive_scope with positive. Arguments xO _%positive. @@ -37,6 +38,7 @@ Inductive N : Set := | N0 : N | Npos : positive -> N. +Declare Scope N_scope. Delimit Scope N_scope with N. Bind Scope N_scope with N. Arguments Npos _%positive. @@ -53,6 +55,7 @@ Inductive Z : Set := | Zpos : positive -> Z | Zneg : positive -> Z. +Declare Scope Z_scope. Delimit Scope Z_scope with Z. Bind Scope Z_scope with Z. Arguments Zpos _%positive. diff --git a/theories/Numbers/Cyclic/Int31/Cyclic31.v b/theories/Numbers/Cyclic/Int31/Cyclic31.v index ec480bb1eb..4a1f24b95e 100644 --- a/theories/Numbers/Cyclic/Int31/Cyclic31.v +++ b/theories/Numbers/Cyclic/Int31/Cyclic31.v @@ -21,7 +21,7 @@ Require Import Znumtheory. Require Import Zgcd_alt. Require Import Zpow_facts. Require Import CyclicAxioms. -Require Import ROmega. +Require Import Lia. Local Open Scope nat_scope. Local Open Scope int31_scope. @@ -1237,7 +1237,7 @@ Section Int31_Specs. destruct (Z_lt_le_dec (X+Y) wB). contradict H1; auto using Zmod_small with zarith. rewrite <- (Z_mod_plus_full (X+Y) (-1) wB). - rewrite Zmod_small; romega. + rewrite Zmod_small; lia. generalize (Z.compare_eq ((X+Y) mod wB) (X+Y)); intros Heq. destruct Z.compare; intros; @@ -1261,7 +1261,7 @@ Section Int31_Specs. destruct (Z_lt_le_dec (X+Y+1) wB). contradict H1; auto using Zmod_small with zarith. rewrite <- (Z_mod_plus_full (X+Y+1) (-1) wB). - rewrite Zmod_small; romega. + rewrite Zmod_small; lia. generalize (Z.compare_eq ((X+Y+1) mod wB) (X+Y+1)); intros Heq. destruct Z.compare; intros; @@ -1299,8 +1299,8 @@ Section Int31_Specs. unfold interp_carry; rewrite phi_phi_inv, Z.compare_eq_iff; intros. destruct (Z_lt_le_dec (X-Y) 0). rewrite <- (Z_mod_plus_full (X-Y) 1 wB). - rewrite Zmod_small; romega. - contradict H1; apply Zmod_small; romega. + rewrite Zmod_small; lia. + contradict H1; apply Zmod_small; lia. generalize (Z.compare_eq ((X-Y) mod wB) (X-Y)); intros Heq. destruct Z.compare; intros; @@ -1318,8 +1318,8 @@ Section Int31_Specs. unfold interp_carry; rewrite phi_phi_inv, Z.compare_eq_iff; intros. destruct (Z_lt_le_dec (X-Y-1) 0). rewrite <- (Z_mod_plus_full (X-Y-1) 1 wB). - rewrite Zmod_small; romega. - contradict H1; apply Zmod_small; romega. + rewrite Zmod_small; lia. + contradict H1; apply Zmod_small; lia. generalize (Z.compare_eq ((X-Y-1) mod wB) (X-Y-1)); intros Heq. destruct Z.compare; intros; @@ -1356,7 +1356,7 @@ Section Int31_Specs. change [|1|] with 1; change [|0|] with 0. rewrite <- (Z_mod_plus_full (0-[|x|]) 1 wB). rewrite Zminus_mod_idemp_l. - rewrite Zmod_small; generalize (phi_bounded x); romega. + rewrite Zmod_small; generalize (phi_bounded x); lia. Qed. Lemma spec_pred_c : forall x, [-|sub31c x 1|] = [|x|] - 1. diff --git a/theories/Numbers/Cyclic/Int31/Int31.v b/theories/Numbers/Cyclic/Int31/Int31.v index 39af62c32f..3a2503d6b7 100644 --- a/theories/Numbers/Cyclic/Int31/Int31.v +++ b/theories/Numbers/Cyclic/Int31/Int31.v @@ -15,13 +15,11 @@ Require Import Wf_nat. Require Export ZArith. Require Export DoubleType. -Declare ML Module "int31_syntax_plugin". - (** * 31-bit integers *) (** This file contains basic definitions of a 31-bit integer arithmetic. In fact it is more general than that. The only reason - for this use of 31 is the underlying mecanism for hardware-efficient + for this use of 31 is the underlying mechanism for hardware-efficient computations by A. Spiwack. Apart from this, a switch to, say, 63-bit integers is now just a matter of replacing every occurrences of 31 by 63. This is actually made possible by the use of @@ -47,9 +45,11 @@ Inductive int31 : Type := I31 : digits31 int31. (* spiwack: Registration of the type of integers, so that the matchs in the functions below perform dynamic decompilation (otherwise some segfault occur when they are applied to one non-closed term and one closed term). *) -Register digits as int31 bits in "coq_int31" by True. -Register int31 as int31 type in "coq_int31" by True. +Register digits as int31.bits. +Register int31 as int31.type. +Declare Scope int31_scope. +Declare ML Module "int31_syntax_plugin". Delimit Scope int31_scope with int31. Bind Scope int31_scope with int31. Local Open Scope int31_scope. @@ -345,21 +345,21 @@ Definition lor31 n m := phi_inv (Z.lor (phi n) (phi m)). Definition land31 n m := phi_inv (Z.land (phi n) (phi m)). Definition lxor31 n m := phi_inv (Z.lxor (phi n) (phi m)). -Register add31 as int31 plus in "coq_int31" by True. -Register add31c as int31 plusc in "coq_int31" by True. -Register add31carryc as int31 pluscarryc in "coq_int31" by True. -Register sub31 as int31 minus in "coq_int31" by True. -Register sub31c as int31 minusc in "coq_int31" by True. -Register sub31carryc as int31 minuscarryc in "coq_int31" by True. -Register mul31 as int31 times in "coq_int31" by True. -Register mul31c as int31 timesc in "coq_int31" by True. -Register div3121 as int31 div21 in "coq_int31" by True. -Register div31 as int31 diveucl in "coq_int31" by True. -Register compare31 as int31 compare in "coq_int31" by True. -Register addmuldiv31 as int31 addmuldiv in "coq_int31" by True. -Register lor31 as int31 lor in "coq_int31" by True. -Register land31 as int31 land in "coq_int31" by True. -Register lxor31 as int31 lxor in "coq_int31" by True. +Register add31 as int31.plus. +Register add31c as int31.plusc. +Register add31carryc as int31.pluscarryc. +Register sub31 as int31.minus. +Register sub31c as int31.minusc. +Register sub31carryc as int31.minuscarryc. +Register mul31 as int31.times. +Register mul31c as int31.timesc. +Register div3121 as int31.div21. +Register div31 as int31.diveucl. +Register compare31 as int31.compare. +Register addmuldiv31 as int31.addmuldiv. +Register lor31 as int31.lor. +Register land31 as int31.land. +Register lxor31 as int31.lxor. Definition lnot31 n := lxor31 Tn n. Definition ldiff31 n m := land31 n (lnot31 m). @@ -485,5 +485,5 @@ Definition tail031 (i:int31) := end) i On. -Register head031 as int31 head0 in "coq_int31" by True. -Register tail031 as int31 tail0 in "coq_int31" by True. +Register head031 as int31.head0. +Register tail031 as int31.tail0. diff --git a/theories/Numbers/Integer/Abstract/ZDivEucl.v b/theories/Numbers/Integer/Abstract/ZDivEucl.v index d7f25a6613..a70ecd19d8 100644 --- a/theories/Numbers/Integer/Abstract/ZDivEucl.v +++ b/theories/Numbers/Integer/Abstract/ZDivEucl.v @@ -13,7 +13,7 @@ Require Import ZAxioms ZMulOrder ZSgnAbs NZDiv. (** * Euclidean Division for integers, Euclid convention We use here the "usual" formulation of the Euclid Theorem - [forall a b, b<>0 -> exists b q, a = b*q+r /\ 0 < r < |b| ] + [forall a b, b<>0 -> exists r q, a = b*q+r /\ 0 <= r < |b| ] The outcome of the modulo function is hence always positive. This corresponds to convention "E" in the following paper: @@ -46,6 +46,7 @@ Module ZEuclidProp (** We put notations in a scope, to avoid warnings about redefinitions of notations *) + Declare Scope euclid. Infix "/" := D.div : euclid. Infix "mod" := D.modulo : euclid. Local Open Scope euclid. diff --git a/theories/Numbers/Integer/NatPairs/ZNatPairs.v b/theories/Numbers/Integer/NatPairs/ZNatPairs.v index 4b2d5c13b5..995d96b314 100644 --- a/theories/Numbers/Integer/NatPairs/ZNatPairs.v +++ b/theories/Numbers/Integer/NatPairs/ZNatPairs.v @@ -13,15 +13,18 @@ Require Import NSub ZAxioms. Require Export Ring. +Declare Scope pair_scope. +Local Open Scope pair_scope. + Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope. Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope. -Local Open Scope pair_scope. Module ZPairsAxiomsMod (Import N : NAxiomsMiniSig) <: ZAxiomsMiniSig. Module Import NProp. Include NSubProp N. End NProp. +Declare Scope NScope. Delimit Scope NScope with N. Bind Scope NScope with N.t. Infix "==" := N.eq (at level 70) : NScope. @@ -73,6 +76,7 @@ Definition max (n m : t) : t := (max (n#1 + m#2) (m#1 + n#2), n#2 + m#2). End Z. +Declare Scope ZScope. Delimit Scope ZScope with Z. Bind Scope ZScope with Z.t. Infix "==" := Z.eq (at level 70) : ZScope. diff --git a/theories/Numbers/NatInt/NZDomain.v b/theories/Numbers/NatInt/NZDomain.v index 3d0c005fd1..acebfcf1d2 100644 --- a/theories/Numbers/NatInt/NZDomain.v +++ b/theories/Numbers/NatInt/NZDomain.v @@ -220,8 +220,10 @@ End NZDomainProp. Module NZOfNat (Import NZ:NZDomainSig'). Definition ofnat (n : nat) : t := (S^n) 0. -Notation "[ n ]" := (ofnat n) (at level 7) : ofnat. + +Declare Scope ofnat. Local Open Scope ofnat. +Notation "[ n ]" := (ofnat n) (at level 7) : ofnat. Lemma ofnat_zero : [O] == 0. Proof. diff --git a/theories/Program/Basics.v b/theories/Program/Basics.v index f55093ed48..c2316689fc 100644 --- a/theories/Program/Basics.v +++ b/theories/Program/Basics.v @@ -28,6 +28,8 @@ Definition compose {A B C} (g : B -> C) (f : A -> B) := Hint Unfold compose. +Declare Scope program_scope. + Notation " g ∘ f " := (compose g f) (at level 40, left associativity) : program_scope. diff --git a/theories/Program/Tactics.v b/theories/Program/Tactics.v index bc83881849..edbae6534a 100644 --- a/theories/Program/Tactics.v +++ b/theories/Program/Tactics.v @@ -326,7 +326,7 @@ Ltac program_solve_wf := Create HintDb program discriminated. -Ltac program_simpl := program_simplify ; try typeclasses eauto with program ; try program_solve_wf. +Ltac program_simpl := program_simplify ; try typeclasses eauto 10 with program ; try program_solve_wf. Obligation Tactic := program_simpl. diff --git a/theories/Program/Utils.v b/theories/Program/Utils.v index 78c36dc7d1..c51cacac68 100644 --- a/theories/Program/Utils.v +++ b/theories/Program/Utils.v @@ -20,12 +20,13 @@ Notation "{ ( x , y ) : A | P }" := (sig (fun anonymous : A => let (x,y) := anonymous in P)) (x ident, y ident, at level 10) : type_scope. +Declare Scope program_scope. +Delimit Scope program_scope with prg. + (** Generates an obligation to prove False. *) Notation " ! " := (False_rect _ _) : program_scope. -Delimit Scope program_scope with prg. - (** Abbreviation for first projection and hiding of proofs of subset objects. *) Notation " ` t " := (proj1_sig t) (at level 10, t at next level) : program_scope. diff --git a/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v index 35706e7fa2..139c4bf432 100644 --- a/theories/QArith/QArith_base.v +++ b/theories/QArith/QArith_base.v @@ -18,6 +18,7 @@ Require Export Morphisms Setoid Bool. Record Q : Set := Qmake {Qnum : Z; Qden : positive}. +Declare Scope Q_scope. Delimit Scope Q_scope with Q. Bind Scope Q_scope with Q. Arguments Qmake _%Z _%positive. diff --git a/theories/QArith/Qcanon.v b/theories/QArith/Qcanon.v index 1510a7b825..81c318138e 100644 --- a/theories/QArith/Qcanon.v +++ b/theories/QArith/Qcanon.v @@ -18,6 +18,7 @@ Require Import Eqdep_dec. Record Qc : Set := Qcmake { this :> Q ; canon : Qred this = this }. +Declare Scope Qc_scope. Delimit Scope Qc_scope with Qc. Bind Scope Qc_scope with Qc. Arguments Qcmake this%Q _. diff --git a/theories/Reals/Ranalysis1.v b/theories/Reals/Ranalysis1.v index 36ac738ca6..9f8039ec9d 100644 --- a/theories/Reals/Ranalysis1.v +++ b/theories/Reals/Ranalysis1.v @@ -28,6 +28,7 @@ Definition div_real_fct (a:R) f (x:R) : R := a / f x. Definition comp f1 f2 (x:R) : R := f1 (f2 x). Definition inv_fct f (x:R) : R := / f x. +Declare Scope Rfun_scope. Delimit Scope Rfun_scope with F. Arguments plus_fct (f1 f2)%F x%R. diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v index 6019d4faf1..a2818371e9 100644 --- a/theories/Reals/Raxioms.v +++ b/theories/Reals/Raxioms.v @@ -14,6 +14,7 @@ Require Export ZArith_base. Require Export Rdefinitions. +Declare Scope R_scope. Local Open Scope R_scope. (*********************************************************) diff --git a/theories/Reals/Rdefinitions.v b/theories/Reals/Rdefinitions.v index 857b4ec33b..932fcddaf5 100644 --- a/theories/Reals/Rdefinitions.v +++ b/theories/Reals/Rdefinitions.v @@ -12,12 +12,15 @@ (** Definitions for the axiomatization *) (*********************************************************) -Declare ML Module "r_syntax_plugin". Require Export ZArith_base. Parameter R : Set. -(* Declare Scope positive_scope with Key R *) +(* Declare primitive numeral notations for Scope R_scope *) +Declare Scope R_scope. +Declare ML Module "r_syntax_plugin". + +(* Declare Scope R_scope with Key R *) Delimit Scope R_scope with R. (* Automatically open scope R_scope for arguments of type R *) diff --git a/theories/Strings/Ascii.v b/theories/Strings/Ascii.v index 31a7fb8ad6..3f676c1888 100644 --- a/theories/Strings/Ascii.v +++ b/theories/Strings/Ascii.v @@ -13,7 +13,6 @@ Adapted to Coq V8 by the Coq Development Team *) Require Import Bool BinPos BinNat PeanoNat Nnat. -Declare ML Module "ascii_syntax_plugin". (** * Definition of ascii characters *) @@ -21,6 +20,8 @@ Declare ML Module "ascii_syntax_plugin". Inductive ascii : Set := Ascii (_ _ _ _ _ _ _ _ : bool). +Declare Scope char_scope. +Declare ML Module "ascii_syntax_plugin". Delimit Scope char_scope with char. Bind Scope char_scope with ascii. diff --git a/theories/Strings/String.v b/theories/Strings/String.v index be9a10c6dc..b27474ef25 100644 --- a/theories/Strings/String.v +++ b/theories/Strings/String.v @@ -15,7 +15,6 @@ Require Import Arith. Require Import Ascii. Require Import Bool. -Declare ML Module "string_syntax_plugin". (** *** Definition of strings *) @@ -25,6 +24,8 @@ Inductive string : Set := | EmptyString : string | String : ascii -> string -> string. +Declare Scope string_scope. +Declare ML Module "string_syntax_plugin". Delimit Scope string_scope with string. Bind Scope string_scope with string. Local Open Scope string_scope. diff --git a/theories/Structures/OrdersFacts.v b/theories/Structures/OrdersFacts.v index 87df6b479d..60c64d306b 100644 --- a/theories/Structures/OrdersFacts.v +++ b/theories/Structures/OrdersFacts.v @@ -132,6 +132,7 @@ Module OrderedTypeFacts (Import O: OrderedType'). Module OrderTac := OT_to_OrderTac O. Ltac order := OrderTac.order. + Declare Scope order. Notation "x <= y" := (~lt y x) : order. Infix "?=" := compare (at level 70, no associativity) : order. diff --git a/theories/Vectors/VectorDef.v b/theories/Vectors/VectorDef.v index ba3e411091..390ca78c0e 100644 --- a/theories/Vectors/VectorDef.v +++ b/theories/Vectors/VectorDef.v @@ -305,6 +305,7 @@ Eval cbv delta beta in fold_right (fun h H => Datatypes.cons h H) v Datatypes.ni End VECTORLIST. Module VectorNotations. +Declare Scope vector_scope. Delimit Scope vector_scope with vector. Notation "[ ]" := [] (format "[ ]") : vector_scope. Notation "h :: t" := (h :: t) (at level 60, right associativity) diff --git a/theories/ZArith/Int.v b/theories/ZArith/Int.v index 2f3bf9a32a..1e35370d29 100644 --- a/theories/ZArith/Int.v +++ b/theories/ZArith/Int.v @@ -17,6 +17,7 @@ *) Require Import BinInt. +Declare Scope Int_scope. Delimit Scope Int_scope with I. Local Open Scope Int_scope. diff --git a/theories/ZArith/Zquot.v b/theories/ZArith/Zquot.v index e93ebb1ad5..0c9aca2657 100644 --- a/theories/ZArith/Zquot.v +++ b/theories/ZArith/Zquot.v @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -Require Import Nnat ZArith_base ROmega ZArithRing Zdiv Morphisms. +Require Import Nnat ZArith_base Lia ZArithRing Zdiv Morphisms. Local Open Scope Z_scope. @@ -129,33 +129,33 @@ Qed. Theorem Zrem_lt_pos a b : 0<=a -> b<>0 -> 0 <= Z.rem a b < Z.abs b. Proof. intros; generalize (Z.rem_nonneg a b) (Z.rem_bound_abs a b); - romega with *. + lia. Qed. Theorem Zrem_lt_neg a b : a<=0 -> b<>0 -> -Z.abs b < Z.rem a b <= 0. Proof. intros; generalize (Z.rem_nonpos a b) (Z.rem_bound_abs a b); - romega with *. + lia. Qed. Theorem Zrem_lt_pos_pos a b : 0<=a -> 0<b -> 0 <= Z.rem a b < b. Proof. - intros; generalize (Zrem_lt_pos a b); romega with *. + intros; generalize (Zrem_lt_pos a b); lia. Qed. Theorem Zrem_lt_pos_neg a b : 0<=a -> b<0 -> 0 <= Z.rem a b < -b. Proof. - intros; generalize (Zrem_lt_pos a b); romega with *. + intros; generalize (Zrem_lt_pos a b); lia. Qed. Theorem Zrem_lt_neg_pos a b : a<=0 -> 0<b -> -b < Z.rem a b <= 0. Proof. - intros; generalize (Zrem_lt_neg a b); romega with *. + intros; generalize (Zrem_lt_neg a b); lia. Qed. Theorem Zrem_lt_neg_neg a b : a<=0 -> b<0 -> b < Z.rem a b <= 0. Proof. - intros; generalize (Zrem_lt_neg a b); romega with *. + intros; generalize (Zrem_lt_neg a b); lia. Qed. @@ -171,12 +171,12 @@ Lemma Remainder_equiv : forall a b r, Remainder a b r <-> Remainder_alt a b r. Proof. unfold Remainder, Remainder_alt; intuition. - - romega with *. - - romega with *. - - rewrite <-(Z.mul_opp_opp). apply Z.mul_nonneg_nonneg; romega. + - lia. + - lia. + - rewrite <-(Z.mul_opp_opp). apply Z.mul_nonneg_nonneg; lia. - assert (0 <= Z.sgn r * Z.sgn a). { rewrite <-Z.sgn_mul, Z.sgn_nonneg; auto. } - destruct r; simpl Z.sgn in *; romega with *. + destruct r; simpl Z.sgn in *; lia. Qed. Theorem Zquot_mod_unique_full a b q r : @@ -185,7 +185,7 @@ Proof. destruct 1 as [(H,H0)|(H,H0)]; intros. apply Zdiv_mod_unique with b; auto. apply Zrem_lt_pos; auto. - romega with *. + lia. rewrite <- H1; apply Z.quot_rem'. rewrite <- (Z.opp_involutive a). @@ -193,7 +193,7 @@ Proof. generalize (Zdiv_mod_unique b (-q) (-a÷b) (-r) (Z.rem (-a) b)). generalize (Zrem_lt_pos (-a) b). rewrite <-Z.quot_rem', Z.mul_opp_r, <-Z.opp_add_distr, <-H1. - romega with *. + lia. Qed. Theorem Zquot_unique_full a b q r : diff --git a/tools/coqdoc/dune b/tools/coqdoc/dune new file mode 100644 index 0000000000..8e05c7d97e --- /dev/null +++ b/tools/coqdoc/dune @@ -0,0 +1,6 @@ +(executable + (name main) + (public_name coqdoc) + (libraries str coq.config)) + +(ocamllex cpretty) diff --git a/tools/dune b/tools/dune index 2ba0e3fe8a..05a620fb07 100644 --- a/tools/dune +++ b/tools/dune @@ -10,6 +10,10 @@ (modules coq_makefile) (libraries coq.lib)) +(install + (section lib) + (files (CoqMakefile.in as tools/CoqMakefile.in))) + (executable (name coqdep) (public_name coqdep) @@ -19,6 +23,14 @@ (ocamllex coqdep_lexer) (executable + (name coqwc) + (public_name coqwc) + (modules coqwc) + (libraries)) + +(ocamllex coqwc) + +(executable (name coq_tex) (public_name coq_tex) (modules coq_tex) diff --git a/vernac/assumptions.ml b/vernac/assumptions.ml index 765f962e99..0bcd3c64eb 100644 --- a/vernac/assumptions.ml +++ b/vernac/assumptions.ml @@ -70,7 +70,7 @@ let rec fields_of_functor f subs mp0 args = function let rec lookup_module_in_impl mp = match mp with - | MPfile _ -> raise Not_found + | MPfile _ -> Global.lookup_module mp | MPbound _ -> assert false | MPdot (mp',lab') -> if ModPath.equal mp' (Global.current_modpath ()) then @@ -213,25 +213,25 @@ let rec traverse current ctx accu t = match Constr.kind t with and traverse_object ?inhabits (curr, data, ax2ty) body obj = let data, ax2ty = - let already_in = Refmap_env.mem obj data in + let already_in = GlobRef.Map_env.mem obj data in match body () with | None -> let data = - if not already_in then Refmap_env.add obj Refset_env.empty data else data in + if not already_in then GlobRef.Map_env.add obj GlobRef.Set_env.empty data else data in let ax2ty = if Option.is_empty inhabits then ax2ty else let ty = Option.get inhabits in - try let l = Refmap_env.find obj ax2ty in Refmap_env.add obj (ty::l) ax2ty - with Not_found -> Refmap_env.add obj [ty] ax2ty in + try let l = GlobRef.Map_env.find obj ax2ty in GlobRef.Map_env.add obj (ty::l) ax2ty + with Not_found -> GlobRef.Map_env.add obj [ty] ax2ty in data, ax2ty | Some body -> if already_in then data, ax2ty else let contents,data,ax2ty = traverse (label_of obj) Context.Rel.empty - (Refset_env.empty,data,ax2ty) body in - Refmap_env.add obj contents data, ax2ty + (GlobRef.Set_env.empty,data,ax2ty) body in + GlobRef.Map_env.add obj contents data, ax2ty in - (Refset_env.add obj curr, data, ax2ty) + (GlobRef.Set_env.add obj curr, data, ax2ty) (** Collects the references occurring in the declaration of mutual inductive definitions. All the constructors and names of a mutual inductive @@ -244,14 +244,14 @@ and traverse_inductive (curr, data, ax2ty) mind obj = (* Invariant : I_0 \in data iff I_i \in data iff c_ij \in data where I_0, I_1, ... are in the same mutual definition and c_ij are all their constructors. *) - if Refmap_env.mem firstind_ref data then data, ax2ty else + if GlobRef.Map_env.mem firstind_ref data then data, ax2ty else let mib = lookup_mind mind in (* Collects references of parameters *) let param_ctx = mib.mind_params_ctxt in let nparam = List.length param_ctx in let accu = traverse_context label Context.Rel.empty - (Refset_env.empty, data, ax2ty) param_ctx + (GlobRef.Set_env.empty, data, ax2ty) param_ctx in (* Build the context of all arities *) let arities_ctx = @@ -283,14 +283,14 @@ and traverse_inductive (curr, data, ax2ty) mind obj = (* Maps all these dependencies to inductives and constructors*) let data = Array.fold_left_i (fun n data oib -> let ind = (mind, n) in - let data = Refmap_env.add (IndRef ind) contents data in + let data = GlobRef.Map_env.add (IndRef ind) contents data in Array.fold_left_i (fun k data _ -> - Refmap_env.add (ConstructRef (ind, k+1)) contents data + GlobRef.Map_env.add (ConstructRef (ind, k+1)) contents data ) data oib.mind_consnames) data mib.mind_packets in data, ax2ty in - (Refset_env.add obj curr, data, ax2ty) + (GlobRef.Set_env.add obj curr, data, ax2ty) (** Collects references in a rel_context. *) and traverse_context current ctx accu ctxt = @@ -307,7 +307,7 @@ and traverse_context current ctx accu ctxt = let traverse current t = let () = modcache := MPmap.empty in - traverse current Context.Rel.empty (Refset_env.empty, Refmap_env.empty, Refmap_env.empty) t + traverse current Context.Rel.empty (GlobRef.Set_env.empty, GlobRef.Map_env.empty, GlobRef.Map_env.empty) t (** Hopefully bullet-proof function to recover the type of a constant. It just ignores all the universe stuff. There are many issues that can arise when @@ -330,12 +330,12 @@ let assumptions ?(add_opaque=false) ?(add_transparent=false) st gr t = let accu = if cb.const_typing_flags.check_guarded then accu else - let l = try Refmap_env.find obj ax2ty with Not_found -> [] in + let l = try GlobRef.Map_env.find obj ax2ty with Not_found -> [] in ContextObjectMap.add (Axiom (Guarded kn, l)) Constr.mkProp accu in if not (Declareops.constant_has_body cb) || not cb.const_typing_flags.check_universes then let t = type_of_constant cb in - let l = try Refmap_env.find obj ax2ty with Not_found -> [] in + let l = try GlobRef.Map_env.find obj ax2ty with Not_found -> [] in ContextObjectMap.add (Axiom (Constant kn,l)) t accu else if add_opaque && (Declareops.is_opaque cb || not (Cpred.mem kn knst)) then let t = type_of_constant cb in @@ -350,7 +350,7 @@ let assumptions ?(add_opaque=false) ?(add_transparent=false) st gr t = if mind.mind_typing_flags.check_guarded then accu else - let l = try Refmap_env.find obj ax2ty with Not_found -> [] in + let l = try GlobRef.Map_env.find obj ax2ty with Not_found -> [] in ContextObjectMap.add (Axiom (Positive m, l)) Constr.mkProp accu in - Refmap_env.fold fold graph ContextObjectMap.empty + GlobRef.Map_env.fold fold graph ContextObjectMap.empty diff --git a/vernac/assumptions.mli b/vernac/assumptions.mli index 751e79d89c..aead345d8c 100644 --- a/vernac/assumptions.mli +++ b/vernac/assumptions.mli @@ -10,7 +10,6 @@ open Names open Constr -open Globnames open Printer (** Collects all the objects on which a term directly relies, bypassing kernel @@ -22,8 +21,8 @@ open Printer *) val traverse : Label.t -> constr -> - (Refset_env.t * Refset_env.t Refmap_env.t * - (Label.t * Constr.rel_context * types) list Refmap_env.t) + (GlobRef.Set_env.t * GlobRef.Set_env.t GlobRef.Map_env.t * + (Label.t * Constr.rel_context * types) list GlobRef.Map_env.t) (** Collects all the assumptions (optionally including opaque definitions) on which a term relies (together with their type). The above warning of diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index 716c40dbff..7b28895814 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -35,6 +35,18 @@ module RelDecl = Context.Rel.Declaration (* 3b| Mutual inductive definitions *) +let should_auto_template = + let open Goptions in + let auto = ref true in + let _ = declare_bool_option + { optdepr = false; + optname = "Automatically make some inductive types template polymorphic"; + optkey = ["Auto";"Template";"Polymorphism"]; + optread = (fun () -> !auto); + optwrite = (fun b -> auto := b); } + in + fun () -> !auto + let rec complete_conclusion a cs = CAst.map_with_loc (fun ?loc -> function | CProdN (bl,c) -> CProdN (bl,complete_conclusion a cs c) | CLetIn (na,b,t,c) -> CLetIn (na,b,t,complete_conclusion a cs c) @@ -55,7 +67,6 @@ let push_types env idl tl = type structured_one_inductive_expr = { ind_name : Id.t; - ind_univs : universe_decl_expr option; ind_arity : constr_expr; ind_lc : (Id.t * constr_expr) list } @@ -113,17 +124,16 @@ let rec check_anonymous_type ind = | GCast (e, _) -> check_anonymous_type e | _ -> false -let make_conclusion_flexible sigma ty poly = - if poly && Term.isArity ty then - let _, concl = Term.destArity ty in - match concl with - | Type u -> - (match Univ.universe_level u with +let make_conclusion_flexible sigma = function + | None -> sigma + | Some s -> + (match EConstr.ESorts.kind sigma s with + | Type u -> + (match Univ.universe_level u with | Some u -> Evd.make_flexible_variable sigma ~algebraic:true u | None -> sigma) - | _ -> sigma - else sigma + | _ -> sigma) let is_impredicative env u = u = Prop || (is_impredicative_set env && u = Set) @@ -133,10 +143,12 @@ let interp_ind_arity env sigma ind = let impls = Implicit_quantifiers.implicits_of_glob_constr ~with_products:true c in let sigma,t = understand_tcc env sigma ~expected_type:IsType c in let pseudo_poly = check_anonymous_type c in - let () = if not (Reductionops.is_arity env sigma t) then + match Reductionops.sort_of_arity env sigma t with + | exception Invalid_argument _ -> user_err ?loc:(constr_loc ind.ind_arity) (str "Not an arity") - in - sigma, (t, pseudo_poly, impls) + | s -> + let concl = if pseudo_poly then Some s else None in + sigma, (t, concl, impls) let interp_cstrs env sigma impls mldata arity ind = let cnames,ctyps = List.split ind.ind_lc in @@ -335,13 +347,12 @@ let restrict_inductive_universes sigma ctx_params arities constructors = let uvars = List.fold_right (fun (_,ctypes,_) -> List.fold_right merge_universes_of_constr ctypes) constructors uvars in Evd.restrict_universe_context sigma uvars -let interp_mutual_inductive_gen env0 (uparamsl,paramsl,indl) notations cum poly prv finite = +let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) notations cum poly prv finite = check_all_names_different indl; List.iter check_param paramsl; if not (List.is_empty uparamsl) && not (List.is_empty notations) then user_err (str "Inductives with uniform parameters may not have attached notations."); - let pl = (List.hd indl).ind_univs in - let sigma, decl = interp_univ_decl_opt env0 pl in + let sigma, udecl = interp_univ_decl_opt env0 udecl in let sigma, (uimpls, ((env_uparams, ctx_uparams), useruimpls)) = interp_context_evars env0 sigma uparamsl in let sigma, (impls, ((env_params, ctx_params), userimpls)) = @@ -363,7 +374,7 @@ let interp_mutual_inductive_gen env0 (uparamsl,paramsl,indl) notations cum poly (* Compute interpretation metadatas *) let indimpls = List.map (fun (_, _, impls) -> userimpls @ lift_implicits (Context.Rel.nhyps ctx_params) impls) arities in - let arities = List.map pi1 arities and aritypoly = List.map pi2 arities in + let arities = List.map pi1 arities and arityconcl = List.map pi2 arities in let impls = compute_internalization_env env_uparams sigma ~impls (Inductive (params,true)) indnames fullarities indimpls in let ntn_impls = compute_internalization_env env_uparams sigma (Inductive (params,true)) indnames fullarities indimpls in let mldatas = List.map2 (mk_mltype_data sigma env_params params) arities indnames in @@ -402,15 +413,16 @@ let interp_mutual_inductive_gen env0 (uparamsl,paramsl,indl) notations cum poly let nf = Evarutil.nf_evars_universes sigma in let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf cl,impsl)) constructors in let arities = List.map EConstr.(to_constr sigma) arities in - let sigma = List.fold_left2 (fun sigma ty poly -> make_conclusion_flexible sigma ty poly) sigma arities aritypoly in + let sigma = List.fold_left make_conclusion_flexible sigma arityconcl in let sigma, arities = inductive_levels env_ar_params sigma poly arities constructors in let sigma = Evd.minimize_universes sigma in let nf = Evarutil.nf_evars_universes sigma in let arities = List.map nf arities in let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf cl,impsl)) constructors in let ctx_params = List.map Termops.(map_rel_decl (EConstr.to_constr sigma)) ctx_params in + let arityconcl = List.map (Option.map (EConstr.ESorts.kind sigma)) arityconcl in let sigma = restrict_inductive_universes sigma ctx_params arities constructors in - let uctx = Evd.check_univ_decl ~poly sigma decl in + let uctx = Evd.check_univ_decl ~poly sigma udecl in List.iter (fun c -> check_evars env_params (Evd.from_env env_params) sigma (EConstr.of_constr c)) arities; Context.Rel.iter (fun c -> check_evars env0 (Evd.from_env env0) sigma (EConstr.of_constr c)) ctx_params; List.iter (fun (_,ctyps,_) -> @@ -418,13 +430,23 @@ let interp_mutual_inductive_gen env0 (uparamsl,paramsl,indl) notations cum poly constructors; (* Build the inductive entries *) - let entries = List.map4 (fun ind arity template (cnames,ctypes,cimpls) -> { - mind_entry_typename = ind.ind_name; - mind_entry_arity = arity; - mind_entry_template = template; - mind_entry_consnames = cnames; - mind_entry_lc = ctypes - }) indl arities aritypoly constructors in + let entries = List.map4 (fun ind arity concl (cnames,ctypes,cimpls) -> + let template = match template with + | Some template -> + if poly && template then user_err Pp.(strbrk "template and polymorphism not compatible"); + template + | None -> + should_auto_template () && not poly && + Option.cata (fun s -> not (Sorts.is_small s)) false concl + in + { mind_entry_typename = ind.ind_name; + mind_entry_arity = arity; + mind_entry_template = template; + mind_entry_consnames = cnames; + mind_entry_lc = ctypes + }) + indl arities arityconcl constructors + in let impls = let len = Context.Rel.nhyps ctx_params in List.map2 (fun indimpls (_,_,cimpls) -> @@ -454,8 +476,8 @@ let interp_mutual_inductive_gen env0 (uparamsl,paramsl,indl) notations cum poly InferCumulativity.infer_inductive env_ar mind_ent else mind_ent), Evd.universe_binders sigma, impls -let interp_mutual_inductive (paramsl,indl) notations cum poly prv finite = - interp_mutual_inductive_gen (Global.env()) ([],paramsl,indl) notations cum poly prv finite +let interp_mutual_inductive ~template udecl (paramsl,indl) notations cum poly prv finite = + interp_mutual_inductive_gen (Global.env()) ~template udecl ([],paramsl,indl) notations cum poly prv finite (* Very syntactical equality *) let eq_local_binders bl1 bl2 = @@ -476,8 +498,8 @@ let extract_params indl = params let extract_inductive indl = - List.map (fun (({CAst.v=indname},pl),_,ar,lc) -> { - ind_name = indname; ind_univs = pl; + List.map (fun ({CAst.v=indname},_,ar,lc) -> { + ind_name = indname; ind_arity = Option.cata (fun x -> x) (CAst.make @@ CSort (Glob_term.GType [])) ar; ind_lc = List.map (fun (_,({CAst.v=id},t)) -> (id,t)) lc }) indl @@ -543,11 +565,11 @@ type uniform_inductive_flag = | UniformParameters | NonUniformParameters -let do_mutual_inductive indl cum poly prv ~uniform finite = +let do_mutual_inductive ~template udecl indl cum poly prv ~uniform finite = let (params,indl),coes,ntns = extract_mutual_inductive_declaration_components indl in (* Interpret the types *) let indl = match uniform with UniformParameters -> (params, [], indl) | NonUniformParameters -> ([], params, indl) in - let mie,pl,impls = interp_mutual_inductive_gen (Global.env()) indl ntns cum poly prv finite in + let mie,pl,impls = interp_mutual_inductive_gen (Global.env()) ~template udecl indl ntns cum poly prv finite in (* Declare the mutual inductive block with its associated schemes *) ignore (declare_mutual_inductive_with_eliminations mie pl impls); (* Declare the possible notations of inductive types *) diff --git a/vernac/comInductive.mli b/vernac/comInductive.mli index 4e30ed7de5..f23085a538 100644 --- a/vernac/comInductive.mli +++ b/vernac/comInductive.mli @@ -24,6 +24,7 @@ type uniform_inductive_flag = | NonUniformParameters val do_mutual_inductive : + template:bool option -> universe_decl_expr option -> (one_inductive_expr * decl_notation list) list -> cumulative_inductive_flag -> polymorphic -> private_flag -> uniform:uniform_inductive_flag -> Declarations.recursivity_kind -> unit @@ -45,6 +46,8 @@ val declare_mutual_inductive_with_eliminations : mutual_inductive_entry -> UnivNames.universe_binders -> one_inductive_impls list -> MutInd.t +val should_auto_template : unit -> bool + (** Exported for Funind *) (** Extracting the semantical components out of the raw syntax of mutual @@ -52,7 +55,6 @@ val declare_mutual_inductive_with_eliminations : type structured_one_inductive_expr = { ind_name : Id.t; - ind_univs : universe_decl_expr option; ind_arity : constr_expr; ind_lc : (Id.t * constr_expr) list } @@ -67,6 +69,7 @@ val extract_mutual_inductive_declaration_components : (** Typing mutual inductive definitions *) val interp_mutual_inductive : - structured_inductive_expr -> decl_notation list -> cumulative_inductive_flag -> + template:bool option -> universe_decl_expr option -> structured_inductive_expr -> + decl_notation list -> cumulative_inductive_flag -> polymorphic -> private_flag -> Declarations.recursivity_kind -> mutual_inductive_entry * UnivNames.universe_binders * one_inductive_impls list diff --git a/vernac/explainErr.ml b/vernac/explainErr.ml index 504e7095b0..7cf4e64805 100644 --- a/vernac/explainErr.ml +++ b/vernac/explainErr.ml @@ -64,6 +64,8 @@ let process_vernac_interp_error exn = match fst exn with wrap_vernac_error exn (Himsg.explain_type_error ctx Evd.empty te) | PretypeError(ctx,sigma,te) -> wrap_vernac_error exn (Himsg.explain_pretype_error ctx sigma te) + | Notation.NumeralNotationError(ctx,sigma,te) -> + wrap_vernac_error exn (Himsg.explain_numeral_notation_error ctx sigma te) | Typeclasses_errors.TypeClassError(env, te) -> wrap_vernac_error exn (Himsg.explain_typeclass_error env te) | Implicit_quantifiers.MismatchedContextInstance(e,c,l,x) -> diff --git a/vernac/g_proofs.mlg b/vernac/g_proofs.mlg index dacef6e211..ecc7d3ff88 100644 --- a/vernac/g_proofs.mlg +++ b/vernac/g_proofs.mlg @@ -13,6 +13,7 @@ open Glob_term open Constrexpr open Vernacexpr +open Hints open Proof_global open Pcoq diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 74516e320c..650b28ea67 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -212,8 +212,10 @@ GRAMMAR EXTEND Gram | IDENT "Scheme"; l = LIST1 scheme SEP "with" -> { VernacScheme l } | IDENT "Combined"; IDENT "Scheme"; id = identref; IDENT "from"; l = LIST1 identref SEP "," -> { VernacCombinedScheme (id, l) } - | IDENT "Register"; IDENT "Inline"; id = identref -> - { VernacRegister(id, RegisterInline) } + | IDENT "Register"; g = global; "as"; quid = qualid -> + { VernacRegister(g, RegisterRetroknowledge quid) } + | IDENT "Register"; IDENT "Inline"; g = global -> + { VernacRegister(g, RegisterInline) } | IDENT "Universe"; l = LIST1 identref -> { VernacUniverse l } | IDENT "Universes"; l = LIST1 identref -> { VernacUniverse l } | IDENT "Constraint"; l = LIST1 univ_constraint SEP "," -> { VernacConstraint l } @@ -846,6 +848,10 @@ GRAMMAR EXTEND Gram info = hint_info -> { VernacInstance (true, snd namesup, (fst namesup, expl, t), None, info) } + (* Should be in syntax, but camlp5 would not factorize *) + | IDENT "Declare"; IDENT "Scope"; sc = IDENT -> + { VernacDeclareScope sc } + (* System directory *) | IDENT "Pwd" -> { VernacChdir None } | IDENT "Cd" -> { VernacChdir None } @@ -1141,8 +1147,8 @@ GRAMMAR EXTEND Gram l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> { l } | -> { [] } ] -> { VernacSyntaxExtension (false, (s,l)) } - (* "Print" "Grammar" should be here but is in "command" entry in order - to factorize with other "Print"-based vernac entries *) + (* "Print" "Grammar" and "Declare" "Scope" should be here but are in "command" entry in order + to factorize with other "Print"-based or "Declare"-based vernac entries *) ] ] ; only_parsing: diff --git a/vernac/himsg.ml b/vernac/himsg.ml index a4650cfd92..e7b2a0e8a6 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -1315,3 +1315,13 @@ let explain_reduction_tactic_error = function quote (pr_goal_concl_style_env env sigma c) ++ spc () ++ str "is not well typed." ++ fnl () ++ explain_type_error env' (Evd.from_env env') e + +let explain_numeral_notation_error env sigma = function + | Notation.UnexpectedTerm c -> + (strbrk "Unexpected term " ++ + pr_constr_env env sigma c ++ + strbrk " while parsing a numeral notation.") + | Notation.UnexpectedNonOptionTerm c -> + (strbrk "Unexpected non-option term " ++ + pr_constr_env env sigma c ++ + strbrk " while parsing a numeral notation.") diff --git a/vernac/himsg.mli b/vernac/himsg.mli index 91caddcf13..02b3c45501 100644 --- a/vernac/himsg.mli +++ b/vernac/himsg.mli @@ -46,3 +46,5 @@ val explain_module_internalization_error : val map_pguard_error : ('c -> 'd) -> 'c pguard_error -> 'd pguard_error val map_ptype_error : ('c -> 'd) -> ('c, 'c) ptype_error -> ('d, 'd) ptype_error + +val explain_numeral_notation_error : env -> Evd.evar_map -> Notation.numeral_notation_error -> Pp.t diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index d66a121437..2e5e11bb09 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -1306,8 +1306,18 @@ type notation_obj = { notobj_notation : notation * notation_location; } -let load_notation _ (_, nobj) = - Option.iter Notation.declare_scope nobj.notobj_scope +let load_notation_common silently_define_scope_if_undefined _ (_, nobj) = + (* When the default shall be to require that a scope already exists *) + (* the call to ensure_scope will have to be removed *) + if silently_define_scope_if_undefined then + (* Don't warn if the scope is not defined: *) + (* there was already a warning at "cache" time *) + Option.iter Notation.declare_scope nobj.notobj_scope + else + Option.iter Notation.ensure_scope nobj.notobj_scope + +let load_notation = + load_notation_common true let open_notation i (_, nobj) = let scope = nobj.notobj_scope in @@ -1331,7 +1341,7 @@ let open_notation i (_, nobj) = end let cache_notation o = - load_notation 1 o; + load_notation_common false 1 o; open_notation 1 o let subst_notation (subst, nobj) = @@ -1566,52 +1576,72 @@ let add_infix local env ({CAst.loc;v=inf},modifiers) pr sc = add_notation local env c (df,modifiers) sc (**********************************************************************) -(* Delimiters and classes bound to scopes *) +(* Scopes, delimiters and classes bound to scopes *) type scope_command = - | ScopeDelim of string + | ScopeDeclare + | ScopeDelimAdd of string + | ScopeDelimRemove | ScopeClasses of scope_class list - | ScopeRemove - -let load_scope_command _ (_,(scope,dlm)) = - Notation.declare_scope scope -let open_scope_command i (_,(scope,o)) = +let load_scope_command_common silently_define_scope_if_undefined _ (_,(local,scope,o)) = + let declare_scope_if_needed = + if silently_define_scope_if_undefined then Notation.declare_scope + else Notation.ensure_scope in + match o with + | ScopeDeclare -> Notation.declare_scope scope + (* When the default shall be to require that a scope already exists *) + (* the call to declare_scope_if_needed will have to be removed below *) + | ScopeDelimAdd dlm -> declare_scope_if_needed scope + | ScopeDelimRemove -> declare_scope_if_needed scope + | ScopeClasses cl -> declare_scope_if_needed scope + +let load_scope_command = + load_scope_command_common true + +let open_scope_command i (_,(local,scope,o)) = if Int.equal i 1 then match o with - | ScopeDelim dlm -> Notation.declare_delimiters scope dlm + | ScopeDeclare -> () + | ScopeDelimAdd dlm -> Notation.declare_delimiters scope dlm + | ScopeDelimRemove -> Notation.remove_delimiters scope | ScopeClasses cl -> List.iter (Notation.declare_scope_class scope) cl - | ScopeRemove -> Notation.remove_delimiters scope let cache_scope_command o = - load_scope_command 1 o; + load_scope_command_common false 1 o; open_scope_command 1 o -let subst_scope_command (subst,(scope,o as x)) = match o with +let subst_scope_command (subst,(local,scope,o as x)) = match o with | ScopeClasses cl -> let cl' = List.map_filter (subst_scope_class subst) cl in let cl' = if List.for_all2eq (==) cl cl' then cl else cl' in - scope, ScopeClasses cl' + local, scope, ScopeClasses cl' | _ -> x -let inScopeCommand : scope_name * scope_command -> obj = +let classify_scope_command (local, _, _ as o) = + if local then Dispose else Substitute o + +let inScopeCommand : locality_flag * scope_name * scope_command -> obj = declare_object {(default_object "DELIMITERS") with cache_function = cache_scope_command; open_function = open_scope_command; load_function = load_scope_command; subst_function = subst_scope_command; - classify_function = (fun obj -> Substitute obj)} + classify_function = classify_scope_command} + +let declare_scope local scope = + Lib.add_anonymous_leaf (inScopeCommand(local,scope,ScopeDeclare)) -let add_delimiters scope key = - Lib.add_anonymous_leaf (inScopeCommand(scope,ScopeDelim key)) +let add_delimiters local scope key = + Lib.add_anonymous_leaf (inScopeCommand(local,scope,ScopeDelimAdd key)) -let remove_delimiters scope = - Lib.add_anonymous_leaf (inScopeCommand(scope,ScopeRemove)) +let remove_delimiters local scope = + Lib.add_anonymous_leaf (inScopeCommand(local,scope,ScopeDelimRemove)) -let add_class_scope scope cl = - Lib.add_anonymous_leaf (inScopeCommand(scope,ScopeClasses cl)) +let add_class_scope local scope cl = + Lib.add_anonymous_leaf (inScopeCommand(local,scope,ScopeClasses cl)) (* Check if abbreviation to a name and avoid early insertion of maximal implicit arguments *) diff --git a/vernac/metasyntax.mli b/vernac/metasyntax.mli index 73bee7121b..38dbdf7e41 100644 --- a/vernac/metasyntax.mli +++ b/vernac/metasyntax.mli @@ -27,11 +27,12 @@ val add_notation : locality_flag -> env -> constr_expr -> val add_notation_extra_printing_rule : string -> string -> string -> unit -(** Declaring delimiter keys and default scopes *) +(** Declaring scopes, delimiter keys and default scopes *) -val add_delimiters : scope_name -> string -> unit -val remove_delimiters : scope_name -> unit -val add_class_scope : scope_name -> scope_class list -> unit +val declare_scope : locality_flag -> scope_name -> unit +val add_delimiters : locality_flag -> scope_name -> string -> unit +val remove_delimiters : locality_flag -> scope_name -> unit +val add_class_scope : locality_flag -> scope_name -> scope_class list -> unit (** Add only the interpretation of a notation that already has pa/pp rules *) diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 14d7642328..3987e53bc7 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -523,11 +523,11 @@ let declare_mutual_definition l = (List.map (fun x -> let subs, typ = (subst_body true x) in let env = Global.env () in - let sigma = Evd.from_env env in + let sigma = Evd.from_ctx x.prg_ctx in let term = snd (Reductionops.splay_lam_n env sigma len (EConstr.of_constr subs)) in let typ = snd (Reductionops.splay_prod_n env sigma len (EConstr.of_constr typ)) in - let term = EConstr.Unsafe.to_constr term in - let typ = EConstr.Unsafe.to_constr typ in + let term = EConstr.to_constr sigma term in + let typ = EConstr.to_constr sigma typ in x.prg_reduce term, x.prg_reduce typ, x.prg_implicits) l) in (* let fixdefs = List.map reduce_fix fixdefs in *) diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 93e4e89a12..b4b3aead91 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -178,11 +178,11 @@ open Pputils | [] -> mt() | _ as z -> str":" ++ spc() ++ prlist_with_sep sep str z - let pr_reference_or_constr pr_c = function + let pr_reference_or_constr pr_c = let open Hints in function | HintsReference r -> pr_qualid r | HintsConstr c -> pr_c c - let pr_hint_mode = function + let pr_hint_mode = let open Hints in function | ModeInput -> str"+" | ModeNoHeadEvar -> str"!" | ModeOutput -> str"-" @@ -194,6 +194,7 @@ open Pputils let pr_hints db h pr_c pr_pat = let opth = pr_opt_hintbases db in let pph = + let open Hints in match h with | HintsResolve l -> keyword "Resolve " ++ prlist_with_sep sep @@ -635,6 +636,10 @@ open Pputils keyword (if opening then "Open " else "Close ") ++ keyword "Scope" ++ spc() ++ str sc ) + | VernacDeclareScope sc -> + return ( + keyword "Declare Scope" ++ spc () ++ str sc + ) | VernacDelimiters (sc,Some key) -> return ( keyword "Delimit Scope" ++ spc () ++ str sc ++ @@ -1157,7 +1162,11 @@ open Pputils | VernacRegister (id, RegisterInline) -> return ( hov 2 - (keyword "Register Inline" ++ spc() ++ pr_lident id) + (keyword "Register Inline" ++ spc() ++ pr_qualid id) + ) + | VernacRegister (id, RegisterRetroknowledge n) -> + return ( + hov 2 (keyword "Register" ++ spc () ++ pr_qualid id ++ spc () ++ keyword "as" ++ pr_qualid n) ) | VernacComments l -> return ( diff --git a/vernac/record.ml b/vernac/record.ml index 6b5c538df2..724b6e62fe 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -393,14 +393,14 @@ open Typeclasses let declare_structure finite ubinders univs paramimpls params template ?(kind=StructureComponent) ?name record_data = let nparams = List.length params in - let template, ctx = + let poly, ctx = match univs with | Monomorphic_ind_entry ctx -> - template, Monomorphic_const_entry Univ.ContextSet.empty + false, Monomorphic_const_entry Univ.ContextSet.empty | Polymorphic_ind_entry ctx -> - false, Polymorphic_const_entry ctx + true, Polymorphic_const_entry ctx | Cumulative_ind_entry cumi -> - false, Polymorphic_const_entry (Univ.CumulativityInfo.univ_context cumi) + true, Polymorphic_const_entry (Univ.CumulativityInfo.univ_context cumi) in let binder_name = match name with @@ -417,6 +417,18 @@ let declare_structure finite ubinders univs paramimpls params template ?(kind=St let args = Context.Rel.to_extended_list mkRel nfields params in let ind = applist (mkRel (ntypes - i + nparams + nfields), args) in let type_constructor = it_mkProd_or_LetIn ind fields in + let template = + match template with + | Some template, _ -> + (* templateness explicitly requested *) + if poly && template then user_err Pp.(strbrk "template and polymorphism not compatible"); + template + | None, template -> + (* auto detect template *) + ComInductive.should_auto_template () && template && not poly && + let _, s = Reduction.dest_arity (Global.env()) arity in + not (Sorts.is_small s) + in { mind_entry_typename = id; mind_entry_arity = arity; mind_entry_template = template; @@ -441,7 +453,6 @@ let declare_structure finite ubinders univs paramimpls params template ?(kind=St let cstr = (rsp, 1) in let kinds,sp_projs = declare_projections rsp ctx ~kind binder_name.(i) coers ubinders fieldimpls fields in let build = ConstructRef cstr in - let poly = match ctx with | Polymorphic_const_entry _ -> true | Monomorphic_const_entry _ -> false in let () = if is_coe then Class.try_add_new_coercion build ~local:false poly in let () = Recordops.declare_structure(rsp,cstr,List.rev kinds,List.rev sp_projs) in rsp @@ -476,10 +487,11 @@ let declare_class finite def cum ubinders univs id idbuild paramimpls params ari let cst = Declare.declare_constant id (DefinitionEntry class_entry, IsDefinition Definition) in - let cstu = (cst, match univs with - | Polymorphic_const_entry univs -> Univ.UContext.instance univs - | Monomorphic_const_entry _ -> Univ.Instance.empty) + let inst, univs = match univs with + | Polymorphic_const_entry uctx -> Univ.UContext.instance uctx, univs + | Monomorphic_const_entry _ -> Univ.Instance.empty, Monomorphic_const_entry Univ.ContextSet.empty in + let cstu = (cst, inst) in let inst_type = appvectc (mkConstU cstu) (Termops.rel_vect 0 (List.length params)) in let proj_type = @@ -616,7 +628,7 @@ let check_unique_names records = | Vernacexpr.DefExpr ({CAst.v=Name id},_,_) -> id::acc | _ -> acc in let allnames = - List.fold_left (fun acc (_, id, _, _, cfs, _, _) -> + List.fold_left (fun acc (_, id, _, cfs, _, _) -> id.CAst.v :: (List.fold_left extract_name acc cfs)) [] records in match List.duplicates Id.equal allnames with @@ -625,19 +637,19 @@ let check_unique_names records = let check_priorities kind records = let isnot_class = match kind with Class false -> false | _ -> true in - let has_priority (_, _, _, _, cfs, _, _) = + let has_priority (_, _, _, cfs, _, _) = List.exists (fun ((_, pri), _) -> not (Option.is_empty pri)) cfs in if isnot_class && List.exists has_priority records then user_err Pp.(str "Priorities only allowed for type class substructures") let extract_record_data records = - let map (is_coe, id, _, _, cfs, idbuild, s) = + let map (is_coe, id, _, cfs, idbuild, s) = let fs = List.map (fun (((_, f), _), _) -> f) cfs in id.CAst.v, s, List.map snd cfs, fs in let data = List.map map records in - let pss = List.map (fun (_, _, _, ps, _, _, _) -> ps) records in + let pss = List.map (fun (_, _, ps, _, _, _) -> ps) records in let ps = match pss with | [] -> CErrors.anomaly (str "Empty record block") | ps :: rem -> @@ -649,29 +661,28 @@ let extract_record_data records = in ps in - (** FIXME: Same issue as #7754 *) - let _, _, pl, _, _, _, _ = List.hd records in - pl, ps, data + ps, data (* [fs] corresponds to fields and [ps] to parameters; [coers] is a list telling if the corresponding fields must me declared as coercions or subinstances. *) -let definition_structure kind cum poly finite records = +let definition_structure udecl kind ~template cum poly finite records = let () = check_unique_names records in let () = check_priorities kind records in - let pl, ps, data = extract_record_data records in - let pl, univs, template, params, implpars, data = + let ps, data = extract_record_data records in + let ubinders, univs, auto_template, params, implpars, data = States.with_state_protection (fun () -> - typecheck_params_and_fields finite (kind = Class true) poly pl ps data) () in + typecheck_params_and_fields finite (kind = Class true) poly udecl ps data) () in + let template = template, auto_template in match kind with | Class def -> - let (_, id, _, _, cfs, idbuild, _), (arity, implfs, fields) = match records, data with + let (_, id, _, cfs, idbuild, _), (arity, implfs, fields) = match records, data with | [r], [d] -> r, d | _, _ -> CErrors.user_err (str "Mutual definitional classes are not handled") in let priorities = List.map (fun ((_, id), _) -> {hint_priority = id; hint_pattern = None}) cfs in let coers = List.map (fun (((coe, _), _), _) -> coe) cfs in - declare_class finite def cum pl univs id.CAst.v idbuild + declare_class finite def cum ubinders univs id.CAst.v idbuild implpars params arity template implfs fields coers priorities | _ -> let map impls = implpars @ Impargs.lift_implicits (succ (List.length params)) impls in @@ -686,11 +697,11 @@ let definition_structure kind cum poly finite records = | Monomorphic_const_entry univs -> Monomorphic_ind_entry univs in - let map (arity, implfs, fields) (is_coe, id, _, _, cfs, idbuild, _) = + let map (arity, implfs, fields) (is_coe, id, _, cfs, idbuild, _) = let coers = List.map (fun (((coe, _), _), _) -> coe) cfs in let coe = List.map (fun coe -> not (Option.is_empty coe)) coers in id.CAst.v, idbuild, arity, implfs, fields, is_coe, coe in let data = List.map2 map data records in - let inds = declare_structure finite pl univs implpars params template data in + let inds = declare_structure finite ubinders univs implpars params template data in List.map (fun ind -> IndRef ind) inds diff --git a/vernac/record.mli b/vernac/record.mli index 567f2b3138..953d5ec3b6 100644 --- a/vernac/record.mli +++ b/vernac/record.mli @@ -26,11 +26,11 @@ val declare_projections : (Name.t * bool) list * Constant.t option list val definition_structure : - inductive_kind -> Decl_kinds.cumulative_inductive_flag -> Decl_kinds.polymorphic -> + universe_decl_expr option -> inductive_kind -> template:bool option -> + Decl_kinds.cumulative_inductive_flag -> Decl_kinds.polymorphic -> Declarations.recursivity_kind -> (coercion_flag * Names.lident * - universe_decl_expr option * local_binder_expr list * (local_decl_expr with_instance with_priority with_notation) list * Id.t * constr_expr option) list -> diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index f7ba305374..015d5fabef 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -403,17 +403,24 @@ let dump_global r = (**********) (* Syntax *) -let vernac_syntax_extension atts infix l = +let vernac_syntax_extension ~atts infix l = let local = enforce_module_locality atts.locality in if infix then Metasyntax.check_infix_modifiers (snd l); Metasyntax.add_syntax_extension local l -let vernac_delimiters sc = function - | Some lr -> Metasyntax.add_delimiters sc lr - | None -> Metasyntax.remove_delimiters sc +let vernac_declare_scope ~atts sc = + let local = enforce_module_locality atts.locality in + Metasyntax.declare_scope local sc + +let vernac_delimiters ~atts sc action = + let local = enforce_module_locality atts.locality in + match action with + | Some lr -> Metasyntax.add_delimiters local sc lr + | None -> Metasyntax.remove_delimiters local sc -let vernac_bind_scope sc cll = - Metasyntax.add_class_scope sc (List.map scope_class_of_qualid cll) +let vernac_bind_scope ~atts sc cll = + let local = enforce_module_locality atts.locality in + Metasyntax.add_class_scope local sc (List.map scope_class_of_qualid cll) let vernac_open_close_scope ~atts (b,s) = let local = enforce_section_locality atts.locality in @@ -548,9 +555,9 @@ let should_treat_as_uniform () = then ComInductive.UniformParameters else ComInductive.NonUniformParameters -let vernac_record cum k poly finite records = +let vernac_record ~template udecl cum k poly finite records = let is_cumulative = should_treat_as_cumulative cum poly in - let map ((coe, (id, pl)), binders, sort, nameopt, cfs) = + let map ((coe, id), binders, sort, nameopt, cfs) = let const = match nameopt with | None -> add_prefix "Build_" id.v | Some lid -> @@ -567,10 +574,22 @@ let vernac_record cum k poly finite records = in List.iter iter cfs in - coe, id, pl, binders, cfs, const, sort + coe, id, binders, cfs, const, sort in let records = List.map map records in - ignore(Record.definition_structure k is_cumulative poly finite records) + ignore(Record.definition_structure ~template udecl k is_cumulative poly finite records) + +let extract_inductive_udecl (indl:(inductive_expr * decl_notation list) list) = + match indl with + | [] -> assert false + | (((coe,(id,udecl)),b,c,k,d),e) :: rest -> + let rest = List.map (fun (((coe,(id,udecl)),b,c,k,d),e) -> + if Option.has_some udecl + then user_err ~hdr:"inductive udecl" Pp.(strbrk "Universe binders must be on the first inductive of the block.") + else (((coe,id),b,c,k,d),e)) + rest + in + udecl, (((coe,id),b,c,k,d),e) :: rest (** When [poly] is true the type is declared polymorphic. When [lo] is true, then the type is declared private (as per the [Private] keyword). [finite] @@ -578,8 +597,9 @@ let vernac_record cum k poly finite records = neither. *) let vernac_inductive ~atts cum lo finite indl = let open Pp in + let udecl, indl = extract_inductive_udecl indl in if Dumpglob.dump () then - List.iter (fun (((coe,(lid,_)), _, _, _, cstrs), _) -> + List.iter (fun (((coe,lid), _, _, _, cstrs), _) -> match cstrs with | Constructors cstrs -> Dumpglob.dump_definition lid false "ind"; @@ -587,6 +607,7 @@ let vernac_inductive ~atts cum lo finite indl = Dumpglob.dump_definition lid false "constr") cstrs | _ -> () (* dumping is done by vernac_record (called below) *) ) indl; + let is_record = function | ((_ , _ , _ , _, RecordDecl _), _) -> true | _ -> false @@ -599,13 +620,14 @@ let vernac_inductive ~atts cum lo finite indl = | [ ( id , bl , c , Class _, Constructors [l]), [] ] -> Some (id, bl, c, l) | _ -> None in + let template = atts.template in if Option.has_some is_defclass then (** Definitional class case *) let (id, bl, c, l) = Option.get is_defclass in let (coe, (lid, ce)) = l in let coe' = if coe then Some true else None in let f = (((coe', AssumExpr ((make ?loc:lid.loc @@ Name lid.v), ce)), None), []) in - vernac_record cum (Class true) atts.polymorphic finite [id, bl, c, None, [f]] + vernac_record ~template udecl cum (Class true) atts.polymorphic finite [id, bl, c, None, [f]] else if List.for_all is_record indl then (** Mutual record case *) let check_kind ((_, _, _, kind, _), _) = match kind with @@ -628,7 +650,7 @@ let vernac_inductive ~atts cum lo finite indl = let ((_, _, _, kind, _), _) = List.hd indl in let kind = match kind with Class _ -> Class false | _ -> kind in let recordl = List.map unpack indl in - vernac_record cum kind atts.polymorphic finite recordl + vernac_record ~template udecl cum kind atts.polymorphic finite recordl else if List.for_all is_constructor indl then (** Mutual inductive case *) let check_kind ((_, _, _, kind, _), _) = match kind with @@ -654,7 +676,7 @@ let vernac_inductive ~atts cum lo finite indl = let indl = List.map unpack indl in let is_cumulative = should_treat_as_cumulative cum atts.polymorphic in let uniform = should_treat_as_uniform () in - ComInductive.do_mutual_inductive indl is_cumulative atts.polymorphic lo ~uniform finite + ComInductive.do_mutual_inductive ~template udecl indl is_cumulative atts.polymorphic lo ~uniform finite else user_err (str "Mixed record-inductive definitions are not allowed") (* @@ -1802,13 +1824,13 @@ let vernac_print ~atts env sigma = | PrintName (qid,udecl) -> dump_global qid; print_name env sigma qid udecl - | PrintGraph -> Prettyp.print_graph env sigma + | PrintGraph -> Prettyp.print_graph () | PrintClasses -> Prettyp.print_classes() | PrintTypeClasses -> Prettyp.print_typeclasses() | PrintInstances c -> Prettyp.print_instances (smart_global c) - | PrintCoercions -> Prettyp.print_coercions env sigma + | PrintCoercions -> Prettyp.print_coercions () | PrintCoercionPaths (cls,clt) -> - Prettyp.print_path_between env sigma (cl_of_qualid cls) (cl_of_qualid clt) + Prettyp.print_path_between (cl_of_qualid cls) (cl_of_qualid clt) | PrintCanonicalConversions -> Prettyp.print_canonical_projections env sigma | PrintUniverses (b, dst) -> let univ = Global.universes () in @@ -1942,14 +1964,23 @@ let vernac_locate = function | LocateOther (s, qid) -> print_located_other s qid | LocateFile f -> locate_file f -let vernac_register id r = +let vernac_register qid r = + let gr = Smartlocate.global_with_alias qid in if Proof_global.there_are_pending_proofs () then user_err Pp.(str "Cannot register a primitive while in proof editing mode."); - let kn = Constrintern.global_reference id.v in - if not (isConstRef kn) then - user_err Pp.(str "Register inline: a constant is expected"); match r with - | RegisterInline -> Global.register_inline (destConstRef kn) + | RegisterInline -> + if not (isConstRef gr) then + user_err Pp.(str "Register inline: a constant is expected"); + Global.register_inline (destConstRef gr) + | RegisterRetroknowledge n -> + let path, id = Libnames.repr_qualid n in + if DirPath.equal path Retroknowledge.int31_path + then + let f = Retroknowledge.(KInt31 (int31_field_of_string (Id.to_string id))) in + Global.register f gr + else + user_err Pp.(str "Register in unknown namespace: " ++ str (DirPath.to_string path)) (********************) (* Proof management *) @@ -2093,9 +2124,10 @@ let interp ?proof ~atts ~st c = (* Syntax *) | VernacSyntaxExtension (infix, sl) -> - vernac_syntax_extension atts infix sl - | VernacDelimiters (sc,lr) -> vernac_delimiters sc lr - | VernacBindScope (sc,rl) -> vernac_bind_scope sc rl + vernac_syntax_extension ~atts infix sl + | VernacDeclareScope sc -> vernac_declare_scope ~atts sc + | VernacDelimiters (sc,lr) -> vernac_delimiters ~atts sc lr + | VernacBindScope (sc,rl) -> vernac_bind_scope ~atts sc rl | VernacOpenCloseScope (b, s) -> vernac_open_close_scope ~atts (b,s) | VernacInfix (mv,qid,sc) -> vernac_infix ~atts mv qid sc | VernacNotation (c,infpl,sc) -> @@ -2232,6 +2264,7 @@ let check_vernac_supports_locality c l = | Some _, ( VernacOpenCloseScope _ | VernacSyntaxExtension _ | VernacInfix _ | VernacNotation _ + | VernacDeclareScope _ | VernacDelimiters _ | VernacBindScope _ | VernacDeclareCustomEntry _ | VernacDefinition _ | VernacFixpoint _ | VernacCoFixpoint _ | VernacAssumption _ | VernacStartTheoremProof _ @@ -2349,6 +2382,14 @@ let attributes_of_flags f atts = (Some false, atts) | ("polymorphic" | "monomorphic") -> user_err Pp.(str "Polymorphism specified twice") + | "template" when atts.template = None -> + assert_empty k v; + polymorphism, { atts with template = Some true } + | "notemplate" when atts.template = None -> + assert_empty k v; + polymorphism, { atts with template = Some false } + | "template" | "notemplate" -> + user_err Pp.(str "Templateness specified twice") | "local" when Option.is_empty atts.locality -> assert_empty k v; (polymorphism, { atts with locality = Some true }) diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index 8fb74e6d78..13c8830b84 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -16,11 +16,11 @@ open Libnames type class_rawexpr = FunClass | SortClass | RefClass of qualid or_by_notation type goal_selector = Goal_select.t = - | SelectAlreadyFocused - | SelectNth of int - | SelectList of (int * int) list - | SelectId of Id.t - | SelectAll + | SelectAlreadyFocused [@ocaml.deprecated "Use Goal_select.SelectAlreadyFocused"] + | SelectNth of int [@ocaml.deprecated "Use Goal_select.SelectNth"] + | SelectList of (int * int) list [@ocaml.deprecated "Use Goal_select.SelectList"] + | SelectId of Id.t [@ocaml.deprecated "Use Goal_select.SelectId"] + | SelectAll [@ocaml.deprecated "Use Goal_select.SelectAll"] [@@ocaml.deprecated "Use Goal_select.t"] type goal_identifier = string @@ -103,14 +103,14 @@ type comment = | CommentInt of int type reference_or_constr = Hints.reference_or_constr = - | HintsReference of qualid - | HintsConstr of constr_expr + | HintsReference of qualid [@ocaml.deprecated "Use Hints.HintsReference"] + | HintsConstr of constr_expr [@ocaml.deprecated "Use Hints.HintsConstr"] [@@ocaml.deprecated "Please use [Hints.reference_or_constr]"] type hint_mode = Hints.hint_mode = - | ModeInput (* No evars *) - | ModeNoHeadEvar (* No evar at the head *) - | ModeOutput (* Anything *) + | ModeInput [@ocaml.deprecated "Use Hints.ModeInput"] + | ModeNoHeadEvar [@ocaml.deprecated "Use Hints.ModeNoHeadEvar"] + | ModeOutput [@ocaml.deprecated "Use Hints.ModeOutput"] [@@ocaml.deprecated "Please use [Hints.hint_mode]"] type 'a hint_info_gen = 'a Typeclasses.hint_info_gen = @@ -128,13 +128,21 @@ type 'a hints_transparency_target = 'a Hints.hints_transparency_target = type hints_expr = Hints.hints_expr = | HintsResolve of (Hints.hint_info_expr * bool * Hints.reference_or_constr) list + [@ocaml.deprecated "Use the constructor in module [Hints]"] | HintsResolveIFF of bool * qualid list * int option + [@ocaml.deprecated "Use the constructor in module [Hints]"] | HintsImmediate of Hints.reference_or_constr list + [@ocaml.deprecated "Use the constructor in module [Hints]"] | HintsUnfold of qualid list + [@ocaml.deprecated "Use the constructor in module [Hints]"] | HintsTransparency of qualid hints_transparency_target * bool + [@ocaml.deprecated "Use the constructor in module [Hints]"] | HintsMode of qualid * Hints.hint_mode list + [@ocaml.deprecated "Use the constructor in module [Hints]"] | HintsConstructors of qualid list + [@ocaml.deprecated "Use the constructor in module [Hints]"] | HintsExtern of int * constr_expr option * Genarg.raw_generic_argument + [@ocaml.deprecated "Use the constructor in module [Hints]"] [@@ocaml.deprecated "Please use [Hints.hints_expr]"] type search_restriction = @@ -202,7 +210,7 @@ type inductive_expr = constructor_list_or_record_decl_expr type one_inductive_expr = - ident_decl * local_binder_expr list * constr_expr option * constructor_expr list + lident * local_binder_expr list * constr_expr option * constructor_expr list type typeclass_constraint = name_decl * Decl_kinds.binding_kind * constr_expr and typeclass_context = typeclass_constraint list @@ -278,6 +286,7 @@ type extend_name = It will be extended with primitive inductive types and operators *) type register_kind = | RegisterInline + | RegisterRetroknowledge of qualid type bullet = Proof_bullet.t [@@ocaml.deprecated "Alias type, please use [Proof_bullet.t]"] @@ -288,7 +297,9 @@ type bullet = Proof_bullet.t type 'a module_signature = 'a Declaremods.module_signature = | Enforce of 'a (** ... : T *) + [@ocaml.deprecated "Use the constructor in module [Declaremods]"] | Check of 'a list (** ... <: T1 <: T2, possibly empty *) + [@ocaml.deprecated "Use the constructor in module [Declaremods]"] [@@ocaml.deprecated "please use [Declaremods.module_signature]."] (** Which module inline annotations should we honor, @@ -297,8 +308,11 @@ type 'a module_signature = 'a Declaremods.module_signature = type inline = Declaremods.inline = | NoInline + [@ocaml.deprecated "Use the constructor in module [Declaremods]"] | DefaultInline + [@ocaml.deprecated "Use the constructor in module [Declaremods]"] | InlineAt of int + [@ocaml.deprecated "Use the constructor in module [Declaremods]"] [@@ocaml.deprecated "please use [Declaremods.inline]."] type module_ast_inl = module_ast * Declaremods.inline @@ -325,6 +339,7 @@ type nonrec vernac_expr = (* Syntax *) | VernacSyntaxExtension of bool * (lstring * syntax_modifier list) | VernacOpenCloseScope of bool * scope_name + | VernacDeclareScope of scope_name | VernacDelimiters of scope_name * string option | VernacBindScope of scope_name * class_rawexpr list | VernacInfix of (lstring * syntax_modifier list) * @@ -437,7 +452,7 @@ type nonrec vernac_expr = | VernacPrint of printable | VernacSearch of searchable * Goal_select.t option * search_restriction | VernacLocate of locatable - | VernacRegister of lident * register_kind + | VernacRegister of qualid * register_kind | VernacComments of comment list (* Proof management *) diff --git a/vernac/vernacinterp.ml b/vernac/vernacinterp.ml index 1bb1414f3d..2746cbd144 100644 --- a/vernac/vernacinterp.ml +++ b/vernac/vernacinterp.ml @@ -21,12 +21,13 @@ type atts = { loc : Loc.t option; locality : bool option; polymorphic : bool; + template : bool option; program : bool; deprecated : deprecation option; } -let mk_atts ?(loc=None) ?(locality=None) ?(polymorphic=false) ?(program=false) ?(deprecated=None) () : atts = - { loc ; locality ; polymorphic ; program ; deprecated } +let mk_atts ?(loc=None) ?(locality=None) ?(polymorphic=false) ?(template=None) ?(program=false) ?(deprecated=None) () : atts = + { loc ; locality ; polymorphic ; program ; deprecated; template } type 'a vernac_command = 'a -> atts:atts -> st:Vernacstate.t -> Vernacstate.t diff --git a/vernac/vernacinterp.mli b/vernac/vernacinterp.mli index 46468b3098..62a178b555 100644 --- a/vernac/vernacinterp.mli +++ b/vernac/vernacinterp.mli @@ -18,12 +18,14 @@ type atts = { loc : Loc.t option; locality : bool option; polymorphic : bool; + template : bool option; program : bool; deprecated : deprecation option; } val mk_atts : ?loc: Loc.t option -> ?locality: bool option -> - ?polymorphic: bool -> ?program: bool -> ?deprecated: deprecation option -> unit -> atts + ?polymorphic: bool -> ?template:bool option -> + ?program: bool -> ?deprecated: deprecation option -> unit -> atts type 'a vernac_command = 'a -> atts:atts -> st:Vernacstate.t -> Vernacstate.t |