diff options
270 files changed, 4158 insertions, 1927 deletions
diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 3582d18cf6..525ced7fee 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -828,7 +828,12 @@ organization, because of a limitation of GitHub). - the overlays that are backward-compatible (normally the case for overlays fixing Coq code) should have been merged *before* the PR - can be merged; + can be merged; it might be a good idea to ask the PR author to + remove the overlay information from the PR to get a fresh CI run + and ensure that all the overlays have been merged; the PR assignee + may also push a commit removing the overlay information (in that + case the assignee is not considered a co-author, hence no need to + change the assignee) - the overlays that are not backward-compatible (normally only the case for overlays fixing OCaml code) should be merged *just after* diff --git a/INSTALL.md b/INSTALL.md index 2397f2c5c2..c44c3dde7d 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -77,3 +77,20 @@ Please see [INSTALL.make.md](dev/doc/INSTALL.make.md) for build and installation instructions using `make`. If you wish to experiment with the Dune-based system see the [dune guide for developers](dev/doc/build-system.dune.md). + +Run-time dependencies of native compilation +------------------------------------------- + +The OCaml compiler and findlib are build-time dependencies, but also +run-time dependencies if you wish to use the native compiler. + +OCaml toolchain advisory +------------------------ + +When loading plugins or `vo` files, you should make sure that these +were compiled with the same OCaml setup (version, flags, +dependencies...) as Coq. Distribution of pre-compiled plugins and +`.vo` files is only possible if users are guaranteed to have the same +Coq version compiled with the same OCaml toolchain. An OCaml setup +mismatch is the most probable cause for an `Error while loading ...: +implementation mismatch on ...`. diff --git a/checker/check.ml b/checker/check.ml index 31bfebc3d5..6d307b3c5e 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -263,6 +263,7 @@ let raw_intern_library f = type summary_disk = { md_name : compilation_unit_name; md_deps : (compilation_unit_name * Safe_typing.vodigest) array; + md_ocaml : string; } module Dyn = Dyn.Make () @@ -345,6 +346,7 @@ let intern_from_file ~intern_mode (dir, f) = let () = close_in ch in let ch = open_in_bin f in let () = close_in ch in + let () = System.check_caml_version ~caml:sd.md_ocaml ~file:f in if dir <> sd.md_name then user_err ~hdr:"intern_from_file" (name_clash_message dir sd.md_name f); diff --git a/checker/values.ml b/checker/values.ml index 76e3ab0d45..cce0ce7203 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -435,7 +435,7 @@ let v_stm_seg = v_pair v_tasks v_counters (** Toplevel structures in a vo (see Cic.mli) *) let v_libsum = - Tuple ("summary", [|v_dp;v_deps|]) + Tuple ("summary", [|v_dp;v_deps;String|]) let v_lib = Tuple ("library",[|v_compiled_lib;v_libraryobjs|]) diff --git a/clib/exninfo.ml b/clib/exninfo.ml index 621f7e615f..07b7f47529 100644 --- a/clib/exninfo.ml +++ b/clib/exninfo.ml @@ -117,3 +117,10 @@ let capture e = e, add info backtrace_info bt else e, info e + +let reify () = + if !is_recording then + let bt = Printexc.get_callstack 50 in + add null backtrace_info bt + else + null diff --git a/clib/exninfo.mli b/clib/exninfo.mli index 55f0662431..08395f59f4 100644 --- a/clib/exninfo.mli +++ b/clib/exninfo.mli @@ -79,3 +79,5 @@ val capture : exn -> iexn val iraise : iexn -> 'a (** Raise the given enriched exception. *) + +val reify : unit -> info diff --git a/dev/build/windows/MakeCoq_trunk_installer.bat b/dev/build/windows/MakeCoq_master_installer.bat index f4f5827328..72640d5d79 100755 --- a/dev/build/windows/MakeCoq_trunk_installer.bat +++ b/dev/build/windows/MakeCoq_master_installer.bat @@ -16,7 +16,7 @@ call MakeCoq_SetRootPath call MakeCoq_MinGW.bat ^
-arch=64 ^
-installer=Y ^
- -coqver=git-trunk ^
+ -coqver=git-master ^
-destcyg="%ROOTPATH%\cygwin_coq64_trunk_inst" ^
-destcoq="%ROOTPATH%\coq64_trunk_inst"
diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index 859b3e3166..963b0e6387 100755 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -983,6 +983,15 @@ function make_ocaml { cp Changes "$PREFIXOCAML/license_readme/ocaml/Changes.txt" fi + # Since 4.07 this library is part of ocaml + mkdir -p "$PREFIXOCAML/libocaml/site-lib/seq/" + cat > "$PREFIXOCAML/libocaml/site-lib/seq/META" <<EOT +name="seq" +version="[distributed with OCaml 4.07 or above]" +description="dummy backward-compatibility package for iterators" +requires="" +EOT + build_post fi } @@ -1093,13 +1102,14 @@ function make_camlp5 { make_ocaml make_findlib - if build_prep https://github.com/camlp5/camlp5/archive rel707 tar.gz 1 camlp5-rel707; then + if build_prep https://github.com/camlp5/camlp5/archive rel711 tar.gz 1 camlp5-rel711; then logn configure ./configure # Somehow my virus scanner has the boot.new/SAVED directory locked after the move for a second => repeat until success sed -i 's/mv boot.new boot/until mv boot.new boot; do sleep 1; done/' Makefile # shellcheck disable=SC2086 log1 make world.opt $MAKE_OPT log2 make install + cp lib/*.a "$PREFIXOCAML/libocaml/camlp5/" log2 make clean # For some reason META is not built / copied, but it is required log2 make -C etc META @@ -1154,6 +1164,47 @@ function make_lablgtk { fi } +##### Elpi ##### + +function make_seq { + make_ocaml + # since 4.07 this package is part of ocaml + +} + +function make_re { + make_ocaml + make_dune + make_seq + + if build_prep https://github.com/ocaml/ocaml-re/archive 1.9.0 tar.gz 1 ocaml-re; then + + log2 dune build -p re + log2 dune install re + + build_post + fi + +} + +function make_elpi { + make_ocaml + make_findlib + make_camlp5 + make_dune + make_re + + if build_prep https://github.com/LPCIC/elpi/archive v1.11.0 tar.gz; then + + log2 make build DUNE_OPTS="-p elpi" + log2 make install DUNE_OPTS="-p elpi" + + build_post + + fi + +} + ##### COQ ##### # Copy one DLLfrom cygwin MINGW packages to Coq install folder @@ -1904,6 +1955,36 @@ function make_addon_gappa { fi } +# Elpi: extension language for Coq based. It lets one define commands in tactics +# in a high level programming language with support for binders and unification +# variables. + +function make_addon_elpi { + make_elpi + installer_addon_dependency elpi + if build_prep_overlay elpi ; then + installer_addon_section elpi "Elpi extension language" "Coq plugin for the Elpi extension language" "" + logn build make + logn installe make install + build_post + fi +} + +# Hierarchy Builder: high level language to declare a hierarchy of structures +# compiled down to records and canonical structures. + +function make_addon_HB { + installer_addon_dependency_beg elpi_hb + make_addon_elpi + installer_addon_dependency_end + if build_prep_overlay elpi_hb ; then + installer_addon_section elpi_hb "Hierarchy Builder" "Coq library to declare algebraic hierarchies" "" + logn build make + logn install make install VFILES=structures.v + build_post + fi +} + # Main function for building addons function make_addons { diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index b87a9c0392..5f7d0b5789 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -351,3 +351,10 @@ : "${metacoq_CI_REF:=master}" : "${metacoq_CI_GITURL:=https://github.com/MetaCoq/metacoq}" : "${metacoq_CI_ARCHIVEURL:=${metacoq_CI_GITURL}/archive}" + +######################################################################## +# SF suite +######################################################################## +: "${sf_CI_REF:=master}" +: "${sf_CI_GITURL:=https://github.com/DeepSpec/sf}" +: "${sf_CI_ARCHIVEURL:=${sf_CI_GITURL}/archive}" diff --git a/dev/ci/ci-sf.sh b/dev/ci/ci-sf.sh index b9d6215e60..d46e53717f 100755 --- a/dev/ci/ci-sf.sh +++ b/dev/ci/ci-sf.sh @@ -3,22 +3,9 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" -CIRCLE_SF_TOKEN=00127070c10f5f09574b050e4f08e924764680d2 +git_download sf -# "latest" is disabled due to lack of build credits upstream, thus artifacts fail -# data=$(wget https://circleci.com/api/v1.1/project/gh/DeepSpec/sfdev/latest/artifacts?circle-token=${CIRCLE_SF_TOKEN} -O -) -data=$(wget https://circleci.com/api/v1.1/project/gh/DeepSpec/sfdev/1411/artifacts?circle-token=${CIRCLE_SF_TOKEN} -O -) - -mkdir -p "${CI_BUILD_DIR}" && cd "${CI_BUILD_DIR}" - -sf_lf_CI_TARURL=$(echo "$data" | jq -rc '.[] | select (.path == "lf.tgz") | .url') -sf_plf_CI_TARURL=$(echo "$data" | jq -rc '.[] | select (.path == "plf.tgz") | .url') -sf_vfa_CI_TARURL=$(echo "$data" | jq -rc '.[] | select (.path == "vfa.tgz") | .url') - -wget -O - "${sf_lf_CI_TARURL}?circle-token=${CIRCLE_SF_TOKEN}" | tar xvz -wget -O - "${sf_plf_CI_TARURL}?circle-token=${CIRCLE_SF_TOKEN}" | tar xvz -wget -O - "${sf_vfa_CI_TARURL}?circle-token=${CIRCLE_SF_TOKEN}" | tar xvz - -( cd lf && make clean && make ) -( cd plf && make clean && make ) -( cd vfa && make clean && make ) +( cd lf-current && make clean && make ) +( cd plf-current && make clean && make ) +( cd vfa-current && make clean && make ) +# ( cd qc-current && make clean && make ) diff --git a/dev/ci/gitlab.bat b/dev/ci/gitlab.bat index 3998fc6514..dc6423332f 100755 --- a/dev/ci/gitlab.bat +++ b/dev/ci/gitlab.bat @@ -54,7 +54,9 @@ IF "%WINDOWS%" == "enabled_all_addons" ( -addon=flocq ^
-addon=interval ^
-addon=gappa_tool ^
- -addon=gappa
+ -addon=gappa ^
+ -addon=elpi ^
+ -addon=HB
) ELSE (
SET "EXTRA_ADDONS= "
)
diff --git a/dev/ci/user-overlays/11922-ppedrot-rm-local-reductionops.sh b/dev/ci/user-overlays/11922-ppedrot-rm-local-reductionops.sh new file mode 100644 index 0000000000..c9ddb3fb9f --- /dev/null +++ b/dev/ci/user-overlays/11922-ppedrot-rm-local-reductionops.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "11922" ] || [ "$CI_BRANCH" = "rm-local-reductionops" ]; then + + equations_CI_REF="rm-local-reductionops" + equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations + + unicoq_CI_REF="rm-local-reductionops" + unicoq_CI_GITURL=https://github.com/ppedrot/unicoq + +fi diff --git a/dev/ci/user-overlays/8808-herbelin-master+support-binder+term-in-abbrev.sh b/dev/ci/user-overlays/8808-herbelin-master+support-binder+term-in-abbrev.sh new file mode 100644 index 0000000000..50eaf0b109 --- /dev/null +++ b/dev/ci/user-overlays/8808-herbelin-master+support-binder+term-in-abbrev.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "8808" ] || [ "$CI_BRANCH" = "master+support-binder+term-in-abbrev" ]; then + + elpi_CI_REF=master+adapt-coq8808-syndef-same-expressiveness-notation + elpi_CI_GITURL=https://github.com/herbelin/coq-elpi + +fi diff --git a/dev/doc/release-process.md b/dev/doc/release-process.md index ceb390c02c..340b66bbd0 100644 --- a/dev/doc/release-process.md +++ b/dev/doc/release-process.md @@ -96,6 +96,8 @@ in time. - [ ] Delay non-blocking issues to the appropriate milestone and ensure blocking issues are solved. If required to solve some blocking issues, it is possible to revert some feature PRs in the version branch only. +- [ ] Add a new link to the ``'versions'`` list of the refman (in + ``html_context`` in ``doc/sphinx/conf.py``). ## Before the beta release date ## diff --git a/doc/LICENSE b/doc/LICENSE index 9f3a6b3f4c..a327156144 100644 --- a/doc/LICENSE +++ b/doc/LICENSE @@ -6,13 +6,16 @@ copyright (c) 1999-2019, Inria, CNRS and contributors, with the exception of the Ubuntu font file UbuntuMono-B.ttf, which is Copyright 2010,2011 Canonical Ltd and licensed under the Ubuntu font license, version 1.0 -(https://www.ubuntu.com/legal/terms-and-policies/font-licence), and +(https://www.ubuntu.com/legal/terms-and-policies/font-licence), its derivative CoqNotations.ttf distributed under the same -license. The material connected to the 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, and the _templates/versions.html file derived from +sphinx_rtd_theme, which is Copyright 2013-2018 Dave Snider, Read the +Docs, Inc. & contributors and distributed under the MIT License +included in that file. The material connected to the 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. The Coq Standard Library is a collective work from the Coq Development Team whose members are listed in the file CREDITS of the Coq source diff --git a/doc/changelog/01-kernel/11972-fix-require-in-section.rst b/doc/changelog/01-kernel/11972-fix-require-in-section.rst deleted file mode 100644 index 7a2fa9185f..0000000000 --- a/doc/changelog/01-kernel/11972-fix-require-in-section.rst +++ /dev/null @@ -1,6 +0,0 @@ -- **Fixed:** - Using :cmd:`Require` inside a section caused an anomaly when closing - the section. (`#11972 <https://github.com/coq/coq/pull/11972>`_, by - Gaëtan Gilbert, fixing `#11783 - <https://github.com/coq/coq/issues/11783>`_, reported by Attila - Boros). diff --git a/doc/changelog/03-notations/8808-master+support-binder+term-in-abbrev.rst b/doc/changelog/03-notations/8808-master+support-binder+term-in-abbrev.rst new file mode 100644 index 0000000000..e1fcfb78c4 --- /dev/null +++ b/doc/changelog/03-notations/8808-master+support-binder+term-in-abbrev.rst @@ -0,0 +1,4 @@ +- **Added:** + Abbreviations support arguments occurring both in term and binder position + (`#8808 <https://github.com/coq/coq/pull/8808>`_, + by Hugo Herbelin). diff --git a/doc/changelog/04-tactics/12116-master+fix12045-missing-reduction-in-using-ind-scheme.rst b/doc/changelog/04-tactics/12116-master+fix12045-missing-reduction-in-using-ind-scheme.rst deleted file mode 100644 index 7af2b4d97b..0000000000 --- a/doc/changelog/04-tactics/12116-master+fix12045-missing-reduction-in-using-ind-scheme.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Fixed:** - Anomaly with induction schemes whose conclusion is not normalized - (`#12116 <https://github.com/coq/coq/pull/12116>`_, - by Hugo Herbelin; fixes - `#12045 <https://github.com/coq/coq/pull/12045>`_) diff --git a/doc/changelog/04-tactics/12129-add-with-strategy.rst b/doc/changelog/04-tactics/12129-add-with-strategy.rst new file mode 100644 index 0000000000..68558c0cf4 --- /dev/null +++ b/doc/changelog/04-tactics/12129-add-with-strategy.rst @@ -0,0 +1,4 @@ +- **Added:** + New tactical :tacn:`with_strategy` added which behaves like the + command :cmd:`Strategy`, with effects local to the given tactic + (`#12129 <https://github.com/coq/coq/pull/12129>`_, by Jason Gross). diff --git a/doc/changelog/04-tactics/12146-master+fix10812-subst-failure-section-variables.rst b/doc/changelog/04-tactics/12146-master+fix10812-subst-failure-section-variables.rst new file mode 100644 index 0000000000..055006d3b4 --- /dev/null +++ b/doc/changelog/04-tactics/12146-master+fix10812-subst-failure-section-variables.rst @@ -0,0 +1,9 @@ +- **Changed:** + Tactic :tacn:`subst` :n:`@ident` now fails over a section variable which is + indirectly dependent in the goal; the incompatibility can generally + be fixed by first clearing the hypotheses causing an indirect + dependency, as reported by the error message, or by using :tacn:`rewrite` :n:`in *` + instead; similarly, :tacn:`subst` has no more effect on such variables + (`#12146 <https://github.com/coq/coq/pull/12146>`_, + by Hugo Herbelin; fixes `#10812 <https://github.com/coq/coq/pull/10812>`_; + fixes `#12139 <https://github.com/coq/coq/pull/12139>`_). diff --git a/doc/changelog/04-tactics/12256-unfold-dyn-check.rst b/doc/changelog/04-tactics/12256-unfold-dyn-check.rst new file mode 100644 index 0000000000..c2f7065f4c --- /dev/null +++ b/doc/changelog/04-tactics/12256-unfold-dyn-check.rst @@ -0,0 +1,4 @@ +- **Changed:** + The check that unfold arguments were indeed unfoldable has been moved to runtime + (`#12256 <https://github.com/coq/coq/pull/12256>`_, + by Pierre-Marie Pédrot). diff --git a/doc/changelog/05-tactic-language/11503-ltac2-rebind-with-value.rst b/doc/changelog/05-tactic-language/11503-ltac2-rebind-with-value.rst new file mode 100644 index 0000000000..0dd0fed4e2 --- /dev/null +++ b/doc/changelog/05-tactic-language/11503-ltac2-rebind-with-value.rst @@ -0,0 +1,6 @@ +- **Added:** + The Ltac2 rebinding command :cmd:`Ltac2 Set` has been extended with the ability to + give a name to the old value so as to be able to reuse it inside the + new one + (`#11503 <https://github.com/coq/coq/pull/11503>`_, + by Pierre-Marie Pédrot). diff --git a/doc/changelog/05-tactic-language/12254-wit-ref-dyn.rst b/doc/changelog/05-tactic-language/12254-wit-ref-dyn.rst new file mode 100644 index 0000000000..69632fd202 --- /dev/null +++ b/doc/changelog/05-tactic-language/12254-wit-ref-dyn.rst @@ -0,0 +1,5 @@ +- **Changed:** + The "reference" tactic generic argument now accepts arbitrary + variables of the goal context + (`#12254 <https://github.com/coq/coq/pull/12254>`_, + by Pierre-Marie Pédrot). diff --git a/doc/changelog/07-commands-and-options/11828-obligations+depr_hide_obligation.rst b/doc/changelog/07-commands-and-options/11828-obligations+depr_hide_obligation.rst new file mode 100644 index 0000000000..5ab2941446 --- /dev/null +++ b/doc/changelog/07-commands-and-options/11828-obligations+depr_hide_obligation.rst @@ -0,0 +1,9 @@ +- **Deprecated:** + Option :flag:`Hide Obligations` has been deprecated + (`#11828 <https://github.com/coq/coq/pull/11828>`_, + by Emilio Jesus Gallego Arias). + +- **Removed:** + Deprecated option ``Shrink Obligations`` has been removed + (`#11828 <https://github.com/coq/coq/pull/11828>`_, + by Emilio Jesus Gallego Arias). diff --git a/doc/changelog/07-commands-and-options/12070-native-compiler-disabled.rst b/doc/changelog/07-commands-and-options/12070-native-compiler-disabled.rst deleted file mode 100644 index 0f30b5f5e8..0000000000 --- a/doc/changelog/07-commands-and-options/12070-native-compiler-disabled.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Changed:** - Ignore -native-compiler option when built without native compute - support. - (`#12070 <https://github.com/coq/coq/pull/12070>`_, - by Pierre Roux). diff --git a/doc/changelog/07-commands-and-options/12296-master+fix12234-show-proof-proper.rst b/doc/changelog/07-commands-and-options/12296-master+fix12234-show-proof-proper.rst new file mode 100644 index 0000000000..dc71a27eb8 --- /dev/null +++ b/doc/changelog/07-commands-and-options/12296-master+fix12234-show-proof-proper.rst @@ -0,0 +1,5 @@ +- **Fixed:** + Anomalies with :cmd:`Show Proof` + (`#12296 <https://github.com/coq/coq/pull/12296>`_, + by Hugo Herbelin; fixes + `#12234 <https://github.com/coq/coq/pull/12234>`_). diff --git a/doc/changelog/08-tools/11851-coqc-flags-fix.rst b/doc/changelog/08-tools/11851-coqc-flags-fix.rst index a07e48d2d8..ff736641b4 100644 --- a/doc/changelog/08-tools/11851-coqc-flags-fix.rst +++ b/doc/changelog/08-tools/11851-coqc-flags-fix.rst @@ -1,6 +1,9 @@ - **Changed:** - The order in which the require/load flags `-l`, `-ri`, `-re`, `-rfrom`, etc. - and the option set flags `-set`, `-unset` are processed have been reversed. - In the new behavior, require/load flags are processed before option flags. - (`#11851 <https://github.com/coq/coq/pull/11851>`_, + The order in which the require flags `-ri`, `-re`, `-rfrom`, etc. + and the option flags `-set`, `-unset` are given now matters. In + particular, it is now possible to interleave the loading of plugins + and the setting of options by choosing the right order for these + flags. The load flags `-l` and `-lv` are still processed afterward + for now (`#11851 <https://github.com/coq/coq/pull/11851>`_ and + `#12097 <https://github.com/coq/coq/pull/12097>`_, by Lasse Blaauwbroek). diff --git a/doc/changelog/09-coqide/12060-ide-disable-csd.rst b/doc/changelog/09-coqide/12060-ide-disable-csd.rst deleted file mode 100644 index b61ab26007..0000000000 --- a/doc/changelog/09-coqide/12060-ide-disable-csd.rst +++ /dev/null @@ -1,6 +0,0 @@ -- **Changed:** - CoqIDE now uses native window frames by default on Windows. - The GTK window frames can be restored by setting the `GTK_CSD` environment variable to `1` - (`#12060 <https://github.com/coq/coq/pull/12060>`_, - fixes `#11080 <https://github.com/coq/coq/issues/11080>`_, - by Attila Gáspár). diff --git a/doc/changelog/09-coqide/12068-master+coqide-completion-no-matched.rst b/doc/changelog/09-coqide/12068-master+coqide-completion-no-matched.rst deleted file mode 100644 index dbb4bdecab..0000000000 --- a/doc/changelog/09-coqide/12068-master+coqide-completion-no-matched.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Fixed:** - New patch presumably fixing the random Coq 8.11 segfault issue with CoqIDE completion - (`#12068 <https://github.com/coq/coq/pull/12068>`_, - by Hugo Herbelin, presumably fixing - `#11943 <https://github.com/coq/coq/pull/11943>`_). diff --git a/doc/changelog/09-coqide/12106-master+coqide-style-apply-all-windows.rst b/doc/changelog/09-coqide/12106-master+coqide-style-apply-all-windows.rst deleted file mode 100644 index 6b1148a9a8..0000000000 --- a/doc/changelog/09-coqide/12106-master+coqide-style-apply-all-windows.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Fixed:** - Highlighting style consistently applied to all three buffers of CoqIDE - (`#12106 <https://github.com/coq/coq/pull/12106>`_, - by Hugo Herbelin; fixes - `#11506 <https://github.com/coq/coq/pull/11506>`_). diff --git a/doc/changelog/10-standard-library/11249-ollibs-list-changelog.rst b/doc/changelog/10-standard-library/11249-ollibs-list-changelog.rst index be15fbf8f5..be54e45808 100644 --- a/doc/changelog/10-standard-library/11249-ollibs-list-changelog.rst +++ b/doc/changelog/10-standard-library/11249-ollibs-list-changelog.rst @@ -7,11 +7,12 @@ - properties of ``remove``: ``remove_cons``, ``remove_app``, ``notin_remove``, ``in_remove``, ``in_in_remove``, ``remove_remove_comm``, ``remove_remove_eq``, ``remove_length_le``, ``remove_length_lt`` - properties of ``concat``: ``in_concat``, ``remove_concat`` - properties of ``map`` and ``flat_map``: ``map_last``, ``map_eq_cons``, ``map_eq_app``, ``flat_map_app``, ``flat_map_ext``, ``nth_nth_nth_map`` - - properties of ``incl``: ``incl_nil_l``, ``incl_l_nil``, ``incl_cons_inv``, ``incl_app_app``, ``incl_app_inv``, ``remove_incl`` + - properties of ``incl``: ``incl_nil_l``, ``incl_l_nil``, ``incl_cons_inv``, ``incl_app_app``, ``incl_app_inv``, ``remove_incl``, ``incl_map``, ``incl_filter``, ``incl_Forall_in_iff`` + - properties of ``NoDup`` and ``nodup``: ``NoDup_rev``, ``NoDup_filter``, ``nodup_incl`` - properties of ``Exists`` and ``Forall``: ``Exists_nth``, ``Exists_app``, ``Exists_rev``, ``Exists_fold_right``, ``incl_Exists``, ``Forall_nth``, ``Forall_app``, ``Forall_elt``, ``Forall_rev``, ``Forall_fold_right``, ``incl_Forall``, ``map_ext_Forall``, ``Exists_or``, ``Exists_or_inv``, ``Forall_and``, ``Forall_and_inv``, ``exists_Forall``, ``Forall_image``, ``concat_nil_Forall``, ``in_flat_map_Exists``, ``notin_flat_map_Forall`` - properties of ``repeat``: ``repeat_cons``, ``repeat_to_concat`` - definitions and properties of ``list_sum`` and ``list_max``: ``list_sum_app``, ``list_max_app``, ``list_max_le``, ``list_max_lt`` - - misc: ``elt_eq_unit``, ``last_length``, ``rev_eq_app``, ``removelast_firstn_len``, ``NoDup_rev``, ``nodup_incl``, ``cons_seq``, ``seq_S`` + - misc: ``elt_eq_unit``, ``last_length``, ``rev_eq_app``, ``removelast_firstn_len``, ``cons_seq``, ``seq_S`` - (`#11249 <https://github.com/coq/coq/pull/11249>`_, + (`#11249 <https://github.com/coq/coq/pull/11249>`_, `#12237 <https://github.com/coq/coq/pull/12237>`_, by Olivier Laurent). diff --git a/doc/changelog/10-standard-library/11992-no-reexports.rst b/doc/changelog/10-standard-library/11992-no-reexports.rst new file mode 100644 index 0000000000..3f46bfd501 --- /dev/null +++ b/doc/changelog/10-standard-library/11992-no-reexports.rst @@ -0,0 +1,4 @@ +- **Changed:** + No longer re-export ``ListNotations`` from ``Program`` (``Program.Syntax``) + (`#11992 <https://github.com/coq/coq/pull/11992>`_, + by Antonio Nikishaev). diff --git a/doc/changelog/10-standard-library/12008-ollibs-bool.rst b/doc/changelog/10-standard-library/12008-ollibs-bool.rst index 7c10d261a7..42e5eb96eb 100644 --- a/doc/changelog/10-standard-library/12008-ollibs-bool.rst +++ b/doc/changelog/10-standard-library/12008-ollibs-bool.rst @@ -1,5 +1,5 @@ - **Added:** - Order relations ``ltb`` and ``compareb`` added in ``Bool.Bool``. + Order relations ``lt`` and ``compare`` added in ``Bool.Bool``. Order properties for ``bool`` added in ``Bool.BoolOrder`` as well as two modules ``Bool_as_OT`` and ``Bool_as_DT`` in ``Structures.OrdersEx`` (`#12008 <https://github.com/coq/coq/pull/12008>`_, by Olivier Laurent). diff --git a/doc/changelog/10-standard-library/12162-bool-leb.rst b/doc/changelog/10-standard-library/12162-bool-leb.rst new file mode 100644 index 0000000000..6a4070a82e --- /dev/null +++ b/doc/changelog/10-standard-library/12162-bool-leb.rst @@ -0,0 +1,4 @@ +- **Deprecated:** + ``Bool.leb`` in favor of ``Bool.le``. The definition of ``Bool.le`` is made local to avoid conflicts with ``Nat.le``. As a consequence, previous calls to ``leb`` based on importing ``Bool`` should now be qualified into ``Bool.le`` even if ``Bool`` is imported. + (`#12162 <https://github.com/coq/coq/pull/12162>`_, + by Olivier Laurent). diff --git a/doc/changelog/10-standard-library/12237-list-more-filter-incl.rst b/doc/changelog/10-standard-library/12237-list-more-filter-incl.rst deleted file mode 100644 index 37aaf697b5..0000000000 --- a/doc/changelog/10-standard-library/12237-list-more-filter-incl.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Added:** - new lemmas in ``List``: ``incl_map``, ``incl_filter``, ``NoDup_filter``, ``incl_Forall_in_iff`` - (`#12237 <https://github.com/coq/coq/pull/12237>`_, - by Olivier Laurent). diff --git a/doc/changelog/12-misc/11755-exn+tclfail.rst b/doc/changelog/12-misc/11755-exn+tclfail.rst new file mode 100644 index 0000000000..800cc09e01 --- /dev/null +++ b/doc/changelog/12-misc/11755-exn+tclfail.rst @@ -0,0 +1,4 @@ +- **Added:** + Backtrace information for tactics has been improved + (`#11755 <https://github.com/coq/coq/pull/11755>`_, + by Emilio Jesus Gallego Arias). diff --git a/doc/plugin_tutorial/tuto1/src/simple_declare.ml b/doc/plugin_tutorial/tuto1/src/simple_declare.ml index b94b1fc657..e9e866c5fb 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_declare.ml +++ b/doc/plugin_tutorial/tuto1/src/simple_declare.ml @@ -1,6 +1,6 @@ let declare_definition ~poly name sigma body = let udecl = UState.default_univ_decl in - let scope = DeclareDef.Global Declare.ImportDefaultBehavior in + let scope = Declare.Global Declare.ImportDefaultBehavior in let kind = Decls.(IsDefinition Definition) in - DeclareDef.declare_definition ~name ~scope ~kind ~impargs:[] ~udecl + Declare.declare_definition ~name ~scope ~kind ~impargs:[] ~udecl ~opaque:false ~poly ~types:None ~body sigma diff --git a/doc/sphinx/_templates/versions.html b/doc/sphinx/_templates/versions.html new file mode 100644 index 0000000000..967d00d2bf --- /dev/null +++ b/doc/sphinx/_templates/versions.html @@ -0,0 +1,48 @@ +{# Forked from versions.html in sphinx_rtd_theme 0.4.3 #} + +{# +The MIT License (MIT) + +Copyright (c) 2013-2018 Dave Snider, Read the Docs, Inc. & contributors + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of +the Software, and to permit persons to whom the Software is furnished to do so, +subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS +FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR +COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER +IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +#} + +{% if not READTHEDOCS %} + <div class="rst-versions" data-toggle="rst-versions" role="note" aria-label="versions"> + <span class="rst-current-version" data-toggle="rst-current-version"> + <span class="fa fa-book"> Other versions</span> + v: {{ version }} + <span class="fa fa-caret-down"></span> + </span> + <div class="rst-other-versions"> + <dl> + <dt>{{ _('Versions') }}</dt> + {% for slug, url in versions %} + <dd><a href="{{ url }}">{{ slug }}</a></dd> + {% endfor %} + </dl> + <dl> + <dt>{{ _('Downloads') }}</dt> + {% for type, url in downloads %} + <dd><a href="{{ url }}">{{ type }}</a></dd> + {% endfor %} + </dl> + </div> + </div> +{% endif %} diff --git a/doc/sphinx/addendum/program.rst b/doc/sphinx/addendum/program.rst index 52862dea47..b5618c5721 100644 --- a/doc/sphinx/addendum/program.rst +++ b/doc/sphinx/addendum/program.rst @@ -342,17 +342,11 @@ optional tactic is replaced by the default one if not specified. .. flag:: Hide Obligations + .. deprecated:: 8.12 + Controls whether obligations appearing in the term should be hidden as implicit arguments of the special - constantProgram.Tactics.obligation. - -.. flag:: Shrink Obligations - - .. deprecated:: 8.7 - - This flag (on by default) controls whether obligations should have - their context minimized to the set of variables used in the proof of - the obligation, to avoid unnecessary dependencies. + constant ``Program.Tactics.obligation``. The module :g:`Coq.Program.Tactics` defines the default tactic for solving obligations called :g:`program_simpl`. Importing :g:`Coq.Program.Program` also diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 453b8597f9..5954ded67f 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -701,6 +701,59 @@ Changes in 8.11.1 (`#11329 <https://github.com/coq/coq/pull/11329>`_, by Hugo Herbelin, fixes `#11114 <https://github.com/coq/coq/pull/11114>`_). +Changes in 8.11.2 +~~~~~~~~~~~~~~~~~ + +**Kernel** + +- **Fixed:** + Using :cmd:`Require` inside a section caused an anomaly when closing + the section. (`#11972 <https://github.com/coq/coq/pull/11972>`_, by + Gaëtan Gilbert, fixing `#11783 + <https://github.com/coq/coq/issues/11783>`_, reported by Attila + Boros). + +**Tactics** + +- **Fixed:** + Anomaly with induction schemes whose conclusion is not normalized + (`#12116 <https://github.com/coq/coq/pull/12116>`_, + by Hugo Herbelin; fixes + `#12045 <https://github.com/coq/coq/pull/12045>`_) +- **Fixed:** + Loss of location of some tactic errors + (`#12223 <https://github.com/coq/coq/pull/12223>`_, + by Hugo Herbelin; fixes + `#12152 <https://github.com/coq/coq/pull/12152>`_ and + `#12255 <https://github.com/coq/coq/pull/12255>`_). + +**Commands and options** + +- **Changed:** + Ignore -native-compiler option when built without native compute + support. + (`#12070 <https://github.com/coq/coq/pull/12070>`_, + by Pierre Roux). + +**CoqIDE** + +- **Changed:** + CoqIDE now uses native window frames by default on Windows. + The GTK window frames can be restored by setting the `GTK_CSD` environment variable to `1` + (`#12060 <https://github.com/coq/coq/pull/12060>`_, + fixes `#11080 <https://github.com/coq/coq/issues/11080>`_, + by Attila Gáspár). +- **Fixed:** + New patch presumably fixing the random Coq 8.11 segfault issue with CoqIDE completion + (`#12068 <https://github.com/coq/coq/pull/12068>`_, + by Hugo Herbelin, presumably fixing + `#11943 <https://github.com/coq/coq/pull/11943>`_). +- **Fixed:** + Highlighting style consistently applied to all three buffers of CoqIDE + (`#12106 <https://github.com/coq/coq/pull/12106>`_, + by Hugo Herbelin; fixes + `#11506 <https://github.com/coq/coq/pull/11506>`_). + Version 8.10 ------------ diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py index dbe582df95..4136b406de 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -202,6 +202,7 @@ html_theme = 'sphinx_rtd_theme' # Theme options are theme-specific and customize the look and feel of a theme # further. For a list of options available for each theme, see the # documentation. +PDF_URL = "https://github.com/coq/coq/releases/download/V{version}/coq-{version}-reference-manual.pdf" html_theme_options = { 'collapse_navigation': False } @@ -210,7 +211,26 @@ html_context = { 'github_user': 'coq', 'github_repo': 'coq', 'github_version': 'master', - 'conf_py_path': '/doc/sphinx/' + 'conf_py_path': '/doc/sphinx/', + # Versions and downloads listed in the versions menu (see _templates/versions.html) + 'versions': [ + ("master", "https://coq.github.io/doc/master/refman/"), + ("stable", "https://coq.inria.fr/distrib/current/refman/"), + ("v8.11", "https://coq.github.io/doc/v8.11/refman/"), + ("v8.10", "https://coq.github.io/doc/v8.10/refman/"), + ("v8.9", "https://coq.github.io/doc/v8.9/refman/"), + ("8.8", "https://coq.inria.fr/distrib/V8.8.2/refman/"), + ("8.7", "https://coq.inria.fr/distrib/V8.7.2/refman/"), + ("8.6", "https://coq.inria.fr/distrib/V8.6.1/refman/"), + ("8.5", "https://coq.inria.fr/distrib/V8.5pl3/refman/"), + ("8.4", "https://coq.inria.fr/distrib/V8.4pl6/refman/"), + ("8.3", "https://coq.inria.fr/distrib/V8.3pl5/refman/"), + ("8.2", "https://coq.inria.fr/distrib/V8.2pl3/refman/"), + ("8.1", "https://coq.inria.fr/distrib/V8.1pl6/refman/"), + ("8.0", "https://coq.inria.fr/distrib/V8.0/doc/") + ], + 'downloads': ([("PDF", PDF_URL.format(version=version))] + if coq_config.is_a_released_version else []) } # Add any paths that contain custom themes here, relative to this directory. diff --git a/doc/sphinx/language/coq-library.rst b/doc/sphinx/language/coq-library.rst index acdd4408ed..899173a83a 100644 --- a/doc/sphinx/language/coq-library.rst +++ b/doc/sphinx/language/coq-library.rst @@ -9,11 +9,11 @@ The |Coq| library The |Coq| library has two parts: - * **The basic library**: definitions and theorems for + * The :gdef:`prelude`: definitions and theorems for the most commonly used elementary logical notions and data types. |Coq| normally loads these files automatically when it starts. - * **The standard library**: general-purpose libraries with + * The :gdef:`standard library`: general-purpose libraries with definitions and theorems for sets, lists, sorting, arithmetic, etc. To use these files, users must load them explicitly with the ``Require`` command (see :ref:`compiled-files`) @@ -28,8 +28,8 @@ also be browsed at http://coq.inria.fr/stdlib/. -The basic library ------------------ +The prelude +----------- This section lists the basic notions and results which are directly available in the standard |Coq| system. Most of these constructions diff --git a/doc/sphinx/language/core/basic.rst b/doc/sphinx/language/core/basic.rst index 50e68276d2..250a0f0326 100644 --- a/doc/sphinx/language/core/basic.rst +++ b/doc/sphinx/language/core/basic.rst @@ -139,30 +139,37 @@ Strings identified with :production:`string`. Keywords - The following character sequences are reserved keywords that cannot be - used as identifiers:: + The following character sequences are keywords defined in the main Coq grammar + that cannot be used as identifiers (even when starting Coq with the `-noinit` + command-line flag):: _ Axiom CoFixpoint Definition Fixpoint Hypothesis Parameter Prop - SProp Set Theorem Type Variable as at cofix discriminated else end + SProp Set Theorem Type Variable as at cofix else end fix for forall fun if in let match return then where with - Note that notations and plugins may define additional keywords. + The following are keywords defined in notations or plugins loaded in the :term:`prelude`:: -Other tokens - The set of - tokens defined at any given time can vary because the :cmd:`Notation` - command can define new tokens. A :cmd:`Require` command may load more notation definitions, - while the end of a :cmd:`Section` may remove notations. Some notations - are defined in the standard library (see :ref:`thecoqlibrary`) and are generally - loaded automatically at startup time. + IF by exists exists2 using + + Note that loading additional modules or plugins may expand the set of reserved + keywords. - Here are the character sequences that |Coq| directly defines as tokens - without using :cmd:`Notation`:: +Other tokens + The following character sequences are tokens defined in the main Coq grammar + (even when starting Coq with the `-noinit` command-line flag):: - ! #[ % & ' ( () (bfs) (dfs) ) * ** + , - -> + ! #[ % & ' ( () ) * + , - -> . .( .. ... / : ::= := :> :>> ; < <+ <- <: - <<: <= = => > >-> >= ? @ @{ [ [= ] _ - `( `{ { {| | |- || } + <<: <= = => > >-> >= ? @ @{ [ ] _ + `( `{ { {| | } + + The following character sequences are tokens defined in notations or plugins + loaded in the :term:`prelude`:: + + ** [= |- || -> + + Note that loading additional modules or plugins may expand the set of defined + tokens. When multiple tokens match the beginning of a sequence of characters, the longest matching token is used. diff --git a/doc/sphinx/practical-tools/coq-commands.rst b/doc/sphinx/practical-tools/coq-commands.rst index 545bba4930..d4ceffac9f 100644 --- a/doc/sphinx/practical-tools/coq-commands.rst +++ b/doc/sphinx/practical-tools/coq-commands.rst @@ -151,7 +151,7 @@ and ``coqtop``, unless stated otherwise: while processing options such as -R and -Q. By default, only the conventional version control management directories named CVS and_darcs are excluded. -:-nois: Start from an empty state instead of loading the Init.Prelude +:-nois, -noinit: Start from an empty state instead of loading the `Init.Prelude` module. :-init-file *file*: Load *file* as the resource file instead of loading the default resource file from the standard configuration @@ -163,32 +163,53 @@ and ``coqtop``, unless stated otherwise: |Coq| script from *file.v*. Write its contents to the standard output as it is executed. :-load-vernac-object *qualid*: Load |Coq| compiled library :n:`@qualid`. This - is equivalent to running :cmd:`Require` :n:`qualid`. + is equivalent to running :cmd:`Require` :n:`@qualid`. + + .. _interleave-command-line: + + .. note:: + + Note that the relative order of this command-line option and its + variants (`-rfrom`, `-ri`, `-re`, etc.) and of the `-set` and + `-unset` options matters since the various :cmd:`Require`, + :cmd:`Require Import`, :cmd:`Require Export`, :cmd:`Set` and + :cmd:`Unset` commands will be executed in the order specified on + the command-line. + :-rfrom *dirpath* *qualid*: Load |Coq| compiled library :n:`@qualid`. - This is equivalent to running :n:`From` :n:`@dirpath` :cmd:`Require Import` :n:`@qualid`. + This is equivalent to running :cmd:`From <From ... Require>` + :n:`@dirpath` :cmd:`Require <From ... Require>` :n:`@qualid`. + See the :ref:`note above <interleave-command-line>` regarding the order + of command-line options. :-ri *qualid*, -require-import *qualid*: Load |Coq| compiled library :n:`@qualid` and import it. This is equivalent to running :cmd:`Require Import` :n:`@qualid`. + See the :ref:`note above <interleave-command-line>` regarding the order + of command-line options. :-re *qualid*, -require-export *qualid*: Load |Coq| compiled library :n:`@qualid` and transitively import it. This is equivalent to running :cmd:`Require Export` :n:`@qualid`. -:-rifrom *dirpath* *qualid*, -require-import-from *dirpath* *qualid*: Load |Coq| compiled library :n:`@qualid` and import it. - This is equivalent to running :n:`From` :n:`@dirpath` :cmd:`Require Import` :n:`@qualid`. -:-refrom *dirpath* *qualid*, -require-export-from *dirpath* *qualid*: Load |Coq| compiled library :n:`@qualid` and transitively import it. - This is equivalent to running :n:`From` :n:`@dirpath` :cmd:`Require Export` :n:`@qualid`. + See the :ref:`note above <interleave-command-line>` regarding the order + of command-line options. +:-rifrom *dirpath* *qualid*, -require-import-from *dirpath* *qualid*: + Load |Coq| compiled library :n:`@qualid` and import it. This is + equivalent to running :cmd:`From <From ... Require>` :n:`@dirpath` + :cmd:`Require Import <From ... Require>` :n:`@qualid`. See the + :ref:`note above <interleave-command-line>` regarding the order of + command-line options. +:-refrom *dirpath* *qualid*, -require-export-from *dirpath* *qualid*: + Load |Coq| compiled library :n:`@qualid` and transitively import it. + This is equivalent to running :cmd:`From <From ... Require>` + :n:`@dirpath` :cmd:`Require Export <From ... Require>` :n:`@qualid`. + See the :ref:`note above <interleave-command-line>` regarding the + order of command-line options. :-batch: Exit just after argument parsing. Available for ``coqtop`` only. -:-compile *file.v*: Deprecated; use ``coqc`` instead. Compile file *file.v* into *file.vo*. This option - implies -batch (exit just after argument parsing). It is available only - for `coqtop`, as this behavior is the purpose of ``coqc``. -:-compile-verbose *file.v*: Deprecated. Use ``coqc -verbose``. Same as -compile but also output the - content of *file.v* as it is compiled. :-verbose: Output the content of the input file as it is compiled. - This option is available for ``coqc`` only; it is the counterpart of - -compile-verbose. + This option is available for ``coqc`` only. :-vos: Indicate |Coq| to skip the processing of opaque proofs - (i.e., proofs ending with ``Qed`` or ``Admitted``), output a ``.vos`` files + (i.e., proofs ending with :cmd:`Qed` or :cmd:`Admitted`), output a ``.vos`` files instead of a ``.vo`` file, and to load ``.vos`` files instead of ``.vo`` files - when interpreting ``Require`` commands. + when interpreting :cmd:`Require` commands. :-vok: Indicate |Coq| to check a file completely, to load ``.vos`` files instead - of ``.vo`` files when interpreting ``Require`` commands, and to output an empty + of ``.vo`` files when interpreting :cmd:`Require` commands, and to output an empty ``.vok`` files upon success instead of writing a ``.vo`` file. :-w (all|none|w₁,…,wₙ): Configure the display of warnings. This option expects all, none or a comma-separated list of warning names or @@ -198,7 +219,7 @@ and ``coqtop``, unless stated otherwise: the output channel supports ANSI escape sequences. :-diffs (on|off|removed): *Coqtop only*. Controls highlighting of differences between proof steps. ``on`` highlights added tokens, ``removed`` highlights both added and - removed tokens. Requires that ``–color`` is enabled. (see Section + removed tokens. Requires that ``-color`` is enabled. (see Section :ref:`showing_diffs`). :-beautify: Pretty-print each command to *file.beautified* when compiling *file.v*, in order to get old-fashioned @@ -224,17 +245,25 @@ and ``coqtop``, unless stated otherwise: changes in the auto-generated name scheme. The options are provided to facilitate tracking down problems. :-set *string*: Enable flags and set options. *string* should be - ``Option Name=value``, the value is interpreted according to the - type of the option. For flags ``Option Name`` is equivalent to - ``Option Name=true``. For instance ``-set "Universe Polymorphism"`` + :n:`@setting_name=value`, the value is interpreted according to the + type of the option. For flags :n:`@setting_name` is equivalent to + :n:`@setting_name=true`. For instance ``-set "Universe Polymorphism"`` will enable :flag:`Universe Polymorphism`. Note that the quotes are - shell syntax, Coq does not see them. Flags are processed after initialization - of the document. This includes the `Prelude` if loaded and any libraries loaded - through the `-l`, `-lv`, `-r`, `-re`, `-ri`, `rfrom`, `-refrom` and `-rifrom` - options. + shell syntax, Coq does not see them. + See the :ref:`note above <interleave-command-line>` regarding the order + of command-line options. :-unset *string*: As ``-set`` but used to disable options and flags. -:-compat *version*: Attempt to maintain some backward-compatibility - with a previous version. + *string* must be :n:`"@setting_name"`. + See the :ref:`note above <interleave-command-line>` regarding the order + of command-line options. +:-compat *version*: Load a file that sets a few options to maintain + partial backward-compatibility with a previous version. This is + equivalent to :cmd:`Require Import` `Coq.Compat.CoqXXX` with `XXX` + one of the last three released versions (including the current + version). Note that the :ref:`explanations above + <interleave-command-line>` regarding the order of command-line + options apply, and this could be relevant if you are resetting some + of the compatibility options. :-dump-glob *file*: Dump references for global names in file *file* (to be used by coqdoc, see :ref:`coqdoc`). By default, if *file.v* is being compiled, *file.glob* is used. diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index b184311bef..90173d65bf 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -57,6 +57,8 @@ mode but it can also be used in toplevel definitions as shown below. .. note:: + - The grammar reserves the token ``||``. + - The infix tacticals ``… || …`` , ``… + …`` , and ``… ; …`` are associative. .. example:: diff --git a/doc/sphinx/proof-engine/ltac2.rst b/doc/sphinx/proof-engine/ltac2.rst index 35062e0057..1e35160205 100644 --- a/doc/sphinx/proof-engine/ltac2.rst +++ b/doc/sphinx/proof-engine/ltac2.rst @@ -213,25 +213,63 @@ There is dedicated syntax for list and array literals. Ltac Definitions ~~~~~~~~~~~~~~~~ -.. cmd:: Ltac2 {? mutable} {? rec} @lident := @ltac2_term +.. cmd:: Ltac2 {? mutable} {? rec} @lident := @ltac2_value :name: Ltac2 This command defines a new global Ltac2 value. - For semantic reasons, the body of the Ltac2 definition must be a syntactical - value, that is, a function, a constant or a pure constructor recursively applied to - values. + The body of an Ltac2 definition is required to be a syntactical value + that is, a function, a constant, a pure constructor recursively applied to + values or a (non-recursive) let binding of a value in a value. + + .. productionlist:: coq + ltac2_value: fun `ltac2_var` => `ltac2_term` + : `ltac2_qualid` + : `ltac2_constructor` `ltac2_value` ... `ltac2_value` + : `ltac2_var` + : let `ltac2_var` := `ltac2_value` in `ltac2_value` If ``rec`` is set, the tactic is expanded into a recursive binding. If ``mutable`` is set, the definition can be redefined at a later stage (see below). -.. cmd:: Ltac2 Set @qualid := @ltac2_term +.. cmd:: Ltac2 Set @qualid {? as @lident} := @ltac2_term :name: Ltac2 Set This command redefines a previous ``mutable`` definition. Mutable definitions act like dynamic binding, i.e. at runtime, the last defined value for this entry is chosen. This is useful for global flags and the like. + The previous value of the binding can be optionally accessed using the `as` + binding syntax. + + .. example:: Dynamic nature of mutable cells + + .. coqtop:: all + + Ltac2 mutable x := true. + Ltac2 y := x. + Ltac2 Eval y. + Ltac2 Set x := false. + Ltac2 Eval y. + + .. example:: Interaction with recursive calls + + + .. coqtop:: all + + Ltac2 mutable rec f b := match b with true => 0 | _ => f true end. + Ltac2 Set f := fun b => + match b with true => 1 | _ => f true end. + Ltac2 Eval (f false). + Ltac2 Set f as oldf := fun b => + match b with true => 2 | _ => oldf false end. + Ltac2 Eval (f false). + + In the definition, the `f` in the body is resolved statically + because the definition is marked recursive. In the first re-definition, + the `f` in the body is resolved dynamically. This is witnessed by + the second re-definition. + Reduction ~~~~~~~~~ diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 8989dd29ab..ad799fbbcd 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -36,6 +36,18 @@ language will be described in Chapter :ref:`ltac`. Common elements of tactics -------------------------- +Reserved keywords +~~~~~~~~~~~~~~~~~ + +The tactics described in this chapter reserve the following keywords:: + + by using + +Thus, these keywords cannot be used as identifiers. It also declares +the following character sequences as tokens:: + + ** [= |- + .. _invocation-of-tactics: Invocation of tactics @@ -2832,6 +2844,11 @@ simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. If :n:`@ident` is a local definition of the form :n:`@ident := t`, it is also unfolded and cleared. + If :n:`@ident` is a section variable it is expected to have no + indirect occurrences in the goal, i.e. that no global declarations + implicitly depending on the section variable must be present in the + goal. + .. note:: + When several hypotheses have the form :n:`@ident = t` or :n:`t = @ident`, the first one is used. @@ -2845,9 +2862,11 @@ simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. .. tacv:: subst - This applies subst repeatedly from top to bottom to all identifiers of the + This applies :tacn:`subst` repeatedly from top to bottom to all hypotheses of the 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``. + or :n:`@ident := t` exists, with :n:`@ident` not occurring in + ``t`` and :n:`@ident` not a section variable with indirect + dependencies in the goal. .. flag:: Regular Subst Tactic @@ -2873,6 +2892,15 @@ simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. hypotheses, which without the flag it may break. default. + .. exn:: Cannot find any non-recursive equality over :n:`@ident`. + :undocumented: + + .. exn:: Section variable :n:`@ident` occurs implicitly in global declaration :n:`@qualid` present in hypothesis :n:`@ident`. + Section variable :n:`@ident` occurs implicitly in global declaration :n:`@qualid` present in the conclusion. + + Raised when the variable is a section variable with indirect + dependencies in the goal. + .. tacn:: stepl @term :name: stepl @@ -3355,6 +3383,116 @@ the conversion in hypotheses :n:`{+ @ident}`. This is the most general syntax that combines the different variants. +.. tacn:: with_strategy @strategy_level_or_var [ {+ @smart_qualid } ] @ltac_expr3 + :name: with_strategy + + Executes :token:`ltac_expr3`, applying the alternate unfolding + behavior that the :cmd:`Strategy` command controls, but only for + :token:`ltac_expr3`. This can be useful for guarding calls to + reduction in tactic automation to ensure that certain constants are + never unfolded by tactics like :tacn:`simpl` and :tacn:`cbn` or to + ensure that unfolding does not fail. + + .. example:: + + .. coqtop:: all reset abort + + Opaque id. + Goal id 10 = 10. + Fail unfold id. + with_strategy transparent [id] unfold id. + + .. warning:: + + Use this tactic with care, as effects do not persist past the + end of the proof script. Notably, this fine-tuning of the + conversion strategy is not in effect during :cmd:`Qed` nor + :cmd:`Defined`, so this tactic is most useful either in + combination with :tacn:`abstract`, which will check the proof + early while the fine-tuning is still in effect, or to guard + calls to conversion in tactic automation to ensure that, e.g., + :tacn:`unfold` does not fail just because the user made a + constant :cmd:`Opaque`. + + This can be illustrated with the following example involving the + factorial function. + + .. coqtop:: in reset + + Fixpoint fact (n : nat) : nat := + match n with + | 0 => 1 + | S n' => n * fact n' + end. + + Suppose now that, for whatever reason, we want in general to + unfold the :g:`id` function very late during conversion: + + .. coqtop:: in + + Strategy 1000 [id]. + + If we try to prove :g:`id (fact n) = fact n` by + :tacn:`reflexivity`, it will now take time proportional to + :math:`n!`, because |Coq| will keep unfolding :g:`fact` and + :g:`*` and :g:`+` before it unfolds :g:`id`, resulting in a full + computation of :g:`fact n` (in unary, because we are using + :g:`nat`), which takes time :math:`n!`. We can see this cross + the relevant threshold at around :math:`n = 9`: + + .. coqtop:: all abort + + Goal True. + Time assert (id (fact 8) = fact 8) by reflexivity. + Time assert (id (fact 9) = fact 9) by reflexivity. + + Note that behavior will be the same if you mark :g:`id` as + :g:`Opaque` because while most reduction tactics refuse to + unfold :g:`Opaque` constants, conversion treats :g:`Opaque` as + merely a hint to unfold this constant last. + + We can get around this issue by using :tacn:`with_strategy`: + + .. coqtop:: all + + Goal True. + Fail Timeout 1 assert (id (fact 100) = fact 100) by reflexivity. + Time assert (id (fact 100) = fact 100) by with_strategy -1 [id] reflexivity. + + However, when we go to close the proof, we will run into + trouble, because the reduction strategy changes are local to the + tactic passed to :tacn:`with_strategy`. + + .. coqtop:: all abort fail + + exact I. + Timeout 1 Defined. + + We can fix this issue by using :tacn:`abstract`: + + .. coqtop:: all + + Goal True. + Time assert (id (fact 100) = fact 100) by with_strategy -1 [id] abstract reflexivity. + exact I. + Time Defined. + + On small examples this sort of behavior doesn't matter, but + because |Coq| is a super-linear performance domain in so many + places, unless great care is taken, tactic automation using + :tacn:`with_strategy` may not be robustly performant when + scaling the size of the input. + + .. warning:: + + In much the same way this tactic does not play well with + :cmd:`Qed` and :cmd:`Defined` without using :tacn:`abstract` as + an intermediary, this tactic does not play well with ``coqchk``, + even when used with :tacn:`abstract`, due to the inability of + tactics to persist information about conversion hints in the + proof term. See `#12200 + <https://github.com/coq/coq/issues/12200>`_ for more details. + Conversion tactics applied to hypotheses ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index 1759264e87..7191444bac 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -817,13 +817,15 @@ described first. .. cmd:: Strategy {+ @strategy_level [ {+ @smart_qualid } ] } - .. insertprodn strategy_level strategy_level + .. insertprodn strategy_level strategy_level_or_var .. prodn:: strategy_level ::= opaque | @int | expand | transparent + strategy_level_or_var ::= @strategy_level + | @ident This command accepts the :attr:`local` attribute, which limits its effect to the current section or module, in which case the section and module diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index 4d722b6615..60cd4c4ad8 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -618,6 +618,41 @@ the next command fails because p does not bind in the instance of n. Notation "[> a , .. , b <]" := (cons a .. (cons b nil) .., cons b .. (cons a nil) ..). +Notations with expressions used both as binder and term ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +It is possible to use parameters of the notation both in term and +binding position. Here is an example: + +.. coqtop:: in + + Definition force n (P:nat -> Prop) := forall n', n' >= n -> P n'. + Notation "▢_ n P" := (force n (fun n => P)) + (at level 0, n ident, P at level 9, format "▢_ n P"). + +.. coqtop:: all + + Check exists p, ▢_p (p >= 1). + +More generally, the parameter can be a pattern, as in the following +variant: + +.. coqtop:: in reset + + Definition force2 q (P:nat*nat -> Prop) := + (forall n', n' >= fst q -> forall p', p' >= snd q -> P q). + + Notation "▢_ p P" := (force2 p (fun p => P)) + (at level 0, p pattern at level 0, P at level 9, format "▢_ p P"). + +.. coqtop:: all + + Check exists x y, ▢_(x,y) (x >= 1 /\ y >= 2). + +This support is experimental. For instance, the notation is used for +printing only if the occurrence of the parameter in term position +comes in the right-hand side before the occurrence in binding position. + .. _RecursiveNotations: Notations with recursive patterns @@ -1383,6 +1418,17 @@ Abbreviations exception, if the right-hand side is just of the form :n:`@@qualid`, this conventionally stops the inheritance of implicit arguments. + Like for notations, it is possible to bind binders in + abbreviations. Here is an example: + + .. coqtop:: in reset + + Definition force2 q (P:nat*nat -> Prop) := + (forall n', n' >= fst q -> forall p', p' >= snd q -> P q). + + Notation F p P := (force2 p (fun p => P)). + Check exists x y, F (x,y) (x >= 1 /\ y >= 2). + .. _numeral-notations: Numeral notations @@ -1721,6 +1767,11 @@ Tactic notations allow customizing the syntax of tactics. - a global reference of term - :tacn:`unfold` + * - ``smart_global`` + - :token:`smart_qualid` + - a global reference of term + - :tacn:`with_strategy` + * - ``constr`` - :token:`term` - a term @@ -1741,6 +1792,16 @@ Tactic notations allow customizing the syntax of tactics. - an integer - :tacn:`do` + * - ``strategy_level`` + - :token:`strategy_level` + - a strategy level + - + + * - ``strategy_level_or_var`` + - :token:`strategy_level_or_var` + - a strategy level + - :tacn:`with_strategy` + * - ``tactic`` - :token:`ltac_expr` - a tactic @@ -1773,18 +1834,24 @@ Tactic notations allow customizing the syntax of tactics. .. todo: notation doesn't support italics - .. note:: In order to be bound in tactic definitions, each syntactic - entry for argument type must include the case of a simple |Ltac| - identifier as part of what it parses. This is naturally the case for - ``ident``, ``simple_intropattern``, ``reference``, ``constr``, ... but not for ``integer``. - This is the reason for introducing a special entry ``int_or_var`` which - evaluates to integers only but which syntactically includes + .. note:: In order to be bound in tactic definitions, each + syntactic entry for argument type must include the case + of a simple |Ltac| identifier as part of what it + parses. This is naturally the case for ``ident``, + ``simple_intropattern``, ``reference``, ``constr``, ... + but not for ``integer`` nor for ``strategy_level``. This + is the reason for introducing special entries + ``int_or_var`` and ``strategy_level_or_var`` which + evaluate to integers or strategy levels only, + respectively, but which syntactically includes identifiers in order to be usable in tactic definitions. - .. note:: The *entry*\ ``_list*`` and ``ne_``\ *entry*\ ``_list*`` entries can be used in - primitive tactics or in other notations at places where a list of the - underlying entry can be used: entry is either ``constr``, ``hyp``, ``integer`` - or ``int_or_var``. + .. note:: The *entry*\ ``_list*`` and ``ne_``\ *entry*\ ``_list*`` + entries can be used in primitive tactics or in other + notations at places where a list of the underlying entry + can be used: entry is either ``constr``, ``hyp``, + ``integer``, ``smart_qualid``, ``strategy_level``, + ``strategy_level_or_var``, or ``int_or_var``. .. rubric:: Footnotes diff --git a/doc/tools/docgram/common.edit_mlg b/doc/tools/docgram/common.edit_mlg index c7e3ee18ad..62cc8ea86b 100644 --- a/doc/tools/docgram/common.edit_mlg +++ b/doc/tools/docgram/common.edit_mlg @@ -1839,3 +1839,7 @@ sentence: [ document: [ | LIST0 sentence ] + +strategy_level: [ +| DELETE strategy_level0 +] diff --git a/doc/tools/docgram/fullGrammar b/doc/tools/docgram/fullGrammar index 4274dccb40..92e9df51d5 100644 --- a/doc/tools/docgram/fullGrammar +++ b/doc/tools/docgram/fullGrammar @@ -451,6 +451,14 @@ bar_cbrace: [ | test_pipe_closedcurly "|" "}" ] +strategy_level: [ +| "expand" +| "opaque" +| integer +| "transparent" +| strategy_level0 +] + vernac_toplevel: [ | "Drop" "." | "Quit" "." @@ -1213,13 +1221,6 @@ more_implicits_block: [ | "{" LIST1 name "}" ] -strategy_level: [ -| "expand" -| "opaque" -| integer -| "transparent" -] - instance_name: [ | ident_decl binders | @@ -1598,6 +1599,7 @@ simple_tactic: [ | "guard" test | "decompose" "[" LIST1 constr "]" constr | "optimize_heap" +| "with_strategy" strategy_level_or_var "[" LIST1 smart_global "]" tactic3 | "eassumption" | "eexact" constr | "trivial" auto_using hintbases @@ -1855,6 +1857,11 @@ test_lpar_id_colon: [ | local_test_lpar_id_colon ] +strategy_level_or_var: [ +| strategy_level +| identref +] + comparison: [ | "=" | "<" diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index df4e5a22e3..11f06b7b8a 100644 --- a/doc/tools/docgram/orderedGrammar +++ b/doc/tools/docgram/orderedGrammar @@ -659,6 +659,11 @@ strategy_level: [ | "transparent" ] +strategy_level_or_var: [ +| strategy_level +| ident +] + reserv_list: [ | LIST1 ( "(" simple_reserv ")" ) | simple_reserv @@ -1234,6 +1239,7 @@ simple_tactic: [ | "guard" int_or_var comparison int_or_var | "decompose" "[" LIST1 one_term "]" one_term | "optimize_heap" +| "with_strategy" strategy_level_or_var "[" LIST1 smart_qualid "]" ltac_expr3 | "start" "ltac" "profiling" | "stop" "ltac" "profiling" | "reset" "ltac" "profile" diff --git a/engine/proofview.ml b/engine/proofview.ml index 2e036be9e3..de38104ecd 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -261,13 +261,9 @@ module Monad = Proof (** [tclZERO e] fails with exception [e]. It has no success. *) -let tclZERO ?info e = +let tclZERO ?(info=Exninfo.null) e = if not (CErrors.noncritical e) then CErrors.anomaly (Pp.str "tclZERO receiving critical error: " ++ CErrors.print e); - let info = match info with - | None -> Exninfo.null - | Some info -> info - in Proof.zero (e, info) (** [tclOR t1 t2] behaves like [t1] as long as [t1] succeeds. Whenever @@ -323,9 +319,10 @@ let tclEXACTLY_ONCE e t = split t >>= function | Nil (e, info) -> tclZERO ~info e | Cons (x,k) -> - Proof.split (k (e, Exninfo.null)) >>= function - | Nil _ -> tclUNIT x - | _ -> tclZERO MoreThanOneSuccess + let info = Exninfo.null in + Proof.split (k (e, Exninfo.null)) >>= function + | Nil _ -> tclUNIT x + | _ -> tclZERO ~info MoreThanOneSuccess (** [tclCASE t] wraps the {!Proofview_monad.Logical.split} primitive. *) @@ -359,7 +356,7 @@ end is restored at the end of the tactic). If the range [i]-[j] is not valid, then it [tclFOCUS_gen nosuchgoal i j t] is [nosuchgoal]. *) let tclFOCUS ?nosuchgoal i j t = - let nosuchgoal = Option.default (tclZERO (NoSuchGoals (j+1-i))) nosuchgoal in + let nosuchgoal ~info = Option.default (tclZERO ~info (NoSuchGoals (j+1-i))) nosuchgoal in let open Proof in Pv.get >>= fun initial -> try @@ -368,7 +365,9 @@ let tclFOCUS ?nosuchgoal i j t = t >>= fun result -> Pv.modify (fun next -> unfocus context next) >> return result - with CList.IndexOutOfRange -> nosuchgoal + with CList.IndexOutOfRange as exn -> + let _, info = Exninfo.capture exn in + nosuchgoal ~info let tclTRYFOCUS i j t = tclFOCUS ~nosuchgoal:(tclUNIT ()) i j t @@ -907,7 +906,8 @@ let tclPROGRESS t = if not test then tclUNIT res else - tclZERO (CErrors.UserError (Some "Proofview.tclPROGRESS", Pp.str "Failed to progress.")) + let info = Exninfo.reify () in + tclZERO ~info (CErrors.UserError (Some "Proofview.tclPROGRESS", Pp.str "Failed to progress.")) let _ = CErrors.register_handler begin function | Logic_monad.Tac_Timeout -> diff --git a/engine/termops.ml b/engine/termops.ml index 6d779e6a35..c51e753d46 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -803,23 +803,29 @@ let occur_evar sigma n c = let occur_in_global env id constr = let vars = vars_of_global env constr in - if Id.Set.mem id vars then raise Occur + Id.Set.mem id vars let occur_var env sigma id c = let rec occur_rec c = match EConstr.destRef sigma c with - | gr, _ -> occur_in_global env id gr + | gr, _ -> if occur_in_global env id gr then raise Occur | exception DestKO -> EConstr.iter sigma occur_rec c in try occur_rec c; false with Occur -> true +exception OccurInGlobal of GlobRef.t + +let occur_var_indirectly env sigma id c = + let var = GlobRef.VarRef id in + let rec occur_rec c = + match EConstr.destRef sigma c with + | gr, _ -> if not (GlobRef.equal gr var) && occur_in_global env id gr then raise (OccurInGlobal gr) + | exception DestKO -> EConstr.iter sigma occur_rec c + in + try occur_rec c; None with OccurInGlobal gr -> Some gr + let occur_var_in_decl env sigma hyp decl = - let open NamedDecl in - match decl with - | LocalAssum (_,typ) -> occur_var env sigma hyp typ - | LocalDef (_, body, typ) -> - occur_var env sigma hyp typ || - occur_var env sigma hyp body + NamedDecl.exists (occur_var env sigma hyp) decl let local_occur_var sigma id c = let rec occur c = match EConstr.kind sigma c with @@ -828,6 +834,9 @@ let local_occur_var sigma id c = in try occur c; false with Occur -> true +let local_occur_var_in_decl sigma hyp decl = + NamedDecl.exists (local_occur_var sigma hyp) decl + (* returns the list of free debruijn indices in a term *) let free_rels sigma m = diff --git a/engine/termops.mli b/engine/termops.mli index 4e77aa9b3b..709fa361a9 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -92,12 +92,14 @@ val occur_meta_or_existential : Evd.evar_map -> constr -> bool val occur_metavariable : Evd.evar_map -> metavariable -> constr -> bool val occur_evar : Evd.evar_map -> Evar.t -> constr -> bool val occur_var : env -> Evd.evar_map -> Id.t -> constr -> bool +val occur_var_indirectly : env -> Evd.evar_map -> Id.t -> constr -> GlobRef.t option val occur_var_in_decl : env -> Evd.evar_map -> Id.t -> named_declaration -> bool (** As {!occur_var} but assume the identifier not to be a section variable *) val local_occur_var : Evd.evar_map -> Id.t -> constr -> bool +val local_occur_var_in_decl : Evd.evar_map -> Id.t -> named_declaration -> bool val free_rels : Evd.evar_map -> constr -> Int.Set.t diff --git a/engine/uState.ml b/engine/uState.ml index 00649ce042..99ac5f2ce8 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -34,7 +34,7 @@ type t = (** The subset of unification variables that can be instantiated with algebraic universes as they appear in inferred types only. *) uctx_universes : UGraph.t; (** The current graph extended with the local constraints *) - uctx_universes_lbound : Univ.Level.t; (** The lower bound on universes (e.g. Set or Prop) *) + uctx_universes_lbound : UGraph.Bound.t; (** The lower bound on universes (e.g. Set or Prop) *) uctx_initial_universes : UGraph.t; (** The graph at the creation of the evar_map *) uctx_weak_constraints : UPairSet.t } @@ -48,7 +48,7 @@ let empty = uctx_univ_variables = LMap.empty; uctx_univ_algebraic = LSet.empty; uctx_universes = initial_sprop_cumulative; - uctx_universes_lbound = Univ.Level.set; + uctx_universes_lbound = UGraph.Bound.Set; uctx_initial_universes = initial_sprop_cumulative; uctx_weak_constraints = UPairSet.empty; } @@ -443,6 +443,10 @@ let check_univ_decl ~poly uctx decl = (ContextSet.constraints uctx.uctx_local); ctx +let is_bound l lbound = match lbound with +| UGraph.Bound.Prop -> Level.is_prop l +| UGraph.Bound.Set -> Level.is_set l + let restrict_universe_context ~lbound (univs, csts) keep = let removed = LSet.diff univs keep in if LSet.is_empty removed then univs, csts @@ -455,7 +459,7 @@ let restrict_universe_context ~lbound (univs, csts) keep = let allkept = LSet.union (UGraph.domain UGraph.initial_universes) (LSet.diff allunivs removed) in let csts = UGraph.constraints_for ~kept:allkept g in let csts = Constraint.filter (fun (l,d,r) -> - not ((Level.equal l lbound && d == Le) || (Level.is_prop l && d == Lt && Level.is_set r))) csts in + not ((is_bound l lbound && d == Le) || (Level.is_prop l && d == Lt && Level.is_set r))) csts in (LSet.inter univs keep, csts) let restrict ctx vars = @@ -600,10 +604,10 @@ let make_with_initial_binders ~lbound e us = let add_global_univ uctx u = let initial = - UGraph.add_universe ~lbound:Univ.Level.set ~strict:true u uctx.uctx_initial_universes + UGraph.add_universe ~lbound:UGraph.Bound.Set ~strict:true u uctx.uctx_initial_universes in let univs = - UGraph.add_universe ~lbound:Univ.Level.set ~strict:true u uctx.uctx_universes + UGraph.add_universe ~lbound:UGraph.Bound.Set ~strict:true u uctx.uctx_universes in { uctx with uctx_local = ContextSet.add_universe u uctx.uctx_local; uctx_initial_universes = initial; diff --git a/engine/uState.mli b/engine/uState.mli index 6707826aae..533a501b59 100644 --- a/engine/uState.mli +++ b/engine/uState.mli @@ -25,9 +25,9 @@ type t val empty : t -val make : lbound:Univ.Level.t -> UGraph.t -> t +val make : lbound:UGraph.Bound.t -> UGraph.t -> t -val make_with_initial_binders : lbound:Univ.Level.t -> UGraph.t -> lident list -> t +val make_with_initial_binders : lbound:UGraph.Bound.t -> UGraph.t -> lident list -> t val is_empty : t -> bool @@ -90,7 +90,7 @@ val universe_of_name : t -> Id.t -> Univ.Level.t the universes in [keep]. The constraints [csts] are adjusted so that transitive constraints between remaining universes (those in [keep] and those not in [univs]) are preserved. *) -val restrict_universe_context : lbound:Univ.Level.t -> ContextSet.t -> LSet.t -> ContextSet.t +val restrict_universe_context : lbound:UGraph.Bound.t -> ContextSet.t -> LSet.t -> ContextSet.t (** [restrict uctx ctx] restricts the local universes of [uctx] to [ctx] extended by local named universes and side effect universes diff --git a/engine/univMinim.ml b/engine/univMinim.ml index c05a7a800d..4dd7fe7e70 100644 --- a/engine/univMinim.ml +++ b/engine/univMinim.ml @@ -267,12 +267,16 @@ let minimize_univ_variables ctx us algs left right cstrs = module UPairs = OrderedType.UnorderedPair(Univ.Level) module UPairSet = Set.Make (UPairs) +let is_bound l lbound = match lbound with +| UGraph.Bound.Prop -> Level.is_prop l +| UGraph.Bound.Set -> Level.is_set l + (* TODO check is_small/sprop *) let normalize_context_set ~lbound g ctx us algs weak = let (ctx, csts) = ContextSet.levels ctx, ContextSet.constraints ctx in (* Keep the Prop/Set <= i constraints separate for minimization *) let smallles, csts = - Constraint.partition (fun (l,d,r) -> d == Le && (Level.equal l lbound || Level.is_sprop l)) csts + Constraint.partition (fun (l,d,r) -> d == Le && (is_bound l lbound || Level.is_sprop l)) csts in let smallles = if get_set_minimization () then Constraint.filter (fun (l,d,r) -> LMap.mem r us && not (Level.is_sprop l)) smallles @@ -299,7 +303,7 @@ let normalize_context_set ~lbound g ctx us algs weak = (* We ignore the trivial Prop/Set <= i constraints. *) let noneqs = Constraint.filter - (fun (l,d,r) -> not ((d == Le && Level.equal l lbound) || + (fun (l,d,r) -> not ((d == Le && is_bound l lbound) || (Level.is_prop l && d == Lt && Level.is_set r))) csts in diff --git a/engine/univMinim.mli b/engine/univMinim.mli index 2a46d87609..58853e47b8 100644 --- a/engine/univMinim.mli +++ b/engine/univMinim.mli @@ -25,7 +25,7 @@ module UPairSet : CSet.S with type elt = (Level.t * Level.t) (a global one if there is one) and transitively saturate the constraints w.r.t to the equalities. *) -val normalize_context_set : lbound:Univ.Level.t -> UGraph.t -> ContextSet.t -> +val normalize_context_set : lbound:UGraph.Bound.t -> UGraph.t -> ContextSet.t -> universe_opt_subst (* The defined and undefined variables *) -> LSet.t (* univ variables that can be substituted by algebraics *) -> UPairSet.t (* weak equality constraints *) -> diff --git a/engine/univops.mli b/engine/univops.mli index 02a731ad49..d0145f5643 100644 --- a/engine/univops.mli +++ b/engine/univops.mli @@ -15,5 +15,5 @@ open Univ val universes_of_constr : constr -> LSet.t [@@ocaml.deprecated "Use [Vars.universes_of_constr]"] -val restrict_universe_context : lbound:Univ.Level.t -> ContextSet.t -> LSet.t -> ContextSet.t +val restrict_universe_context : lbound:UGraph.Bound.t -> ContextSet.t -> LSet.t -> ContextSet.t [@@ocaml.deprecated "Use [UState.restrict_universe_context]"] diff --git a/interp/constrintern.ml b/interp/constrintern.ml index f82783f47d..5ad8af6d57 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -187,7 +187,7 @@ let empty_internalization_env = Id.Map.empty let compute_internalization_data env sigma id ty typ impl = let impl = compute_implicits_with_manual env sigma typ (is_implicit_args()) impl in - (ty, impl, compute_arguments_scope sigma typ, var_uid id) + (ty, impl, compute_arguments_scope env sigma typ, var_uid id) let compute_internalization_env env sigma ?(impls=empty_internalization_env) ty = List.fold_left3 @@ -976,10 +976,6 @@ let split_by_type_pat ?loc ids subst = assert (terms = [] && termlists = []); subst -let make_subst ids l = - let fold accu (id, scopes) a = Id.Map.add id (a, scopes) accu in - List.fold_left2 fold Id.Map.empty ids l - let intern_notation intern env ntnvars loc ntn fullargs = (* Adjust to parsing of { } *) let ntn,fullargs = contract_curly_brackets ntn fullargs in @@ -1113,8 +1109,7 @@ let intern_qualid ?(no_secvar=false) qid intern env ntnvars us args = if List.length args < nids then error_not_enough_arguments ?loc; let args1,args2 = List.chop nids args in check_no_explicitation args1; - let terms = make_subst ids (List.map fst args1) in - let subst = (terms, Id.Map.empty, Id.Map.empty, Id.Map.empty) in + let subst = split_by_type ids (List.map fst args1,[],[],[]) in let infos = (Id.Map.empty, env) in let c = instantiate_notation_constr loc intern intern_cases_pattern_as_binder ntnvars subst infos c in let loc = c.loc in @@ -1624,8 +1619,8 @@ let drop_notations_pattern looked_for genv = let nvars = List.length vars in if List.length pats < nvars then error_not_enough_arguments ?loc:qid.loc; let pats1,pats2 = List.chop nvars pats in - let subst = make_subst vars pats1 in - let idspl1 = List.map (in_not false qid.loc scopes (subst, Id.Map.empty) []) args in + let subst = split_by_type_pat vars (pats1,[]) in + let idspl1 = List.map (in_not false qid.loc scopes subst []) args in let (_,argscs) = find_remaining_scopes pats1 pats2 g in Some (g, idspl1, List.map2 (in_pat_sc scopes) argscs pats2) | _ -> raise Not_found @@ -2358,9 +2353,9 @@ let extract_ids env = (Termops.ids_of_rel_context (Environ.rel_context env)) Id.Set.empty -let scope_of_type_kind sigma = function +let scope_of_type_kind env sigma = function | IsType -> Notation.current_type_scope_name () - | OfType typ -> compute_type_scope sigma typ + | OfType typ -> compute_type_scope env sigma typ | WithoutTypeConstraint | UnknownIfTermOrType -> None let allowed_binder_kind_of_type_kind = function @@ -2377,7 +2372,7 @@ let empty_ltac_sign = { let intern_gen kind env sigma ?(impls=empty_internalization_env) ?(pattern_mode=false) ?(ltacvars=empty_ltac_sign) c = - let tmp_scope = scope_of_type_kind sigma kind in + let tmp_scope = scope_of_type_kind env sigma kind in let k = allowed_binder_kind_of_type_kind kind in internalize env {ids = extract_ids env; unb = false; tmp_scope = tmp_scope; scopes = []; @@ -2462,7 +2457,7 @@ let intern_constr_pattern env sigma ?(as_type=false) ?(ltacvars=empty_ltac_sign) let intern_core kind env sigma ?(pattern_mode=false) ?(ltacvars=empty_ltac_sign) { Genintern.intern_ids = ids; Genintern.notation_variable_status = vl } c = - let tmp_scope = scope_of_type_kind sigma kind in + let tmp_scope = scope_of_type_kind env sigma kind in let impls = empty_internalization_env in let k = allowed_binder_kind_of_type_kind kind in internalize env diff --git a/interp/notation.ml b/interp/notation.ml index 9766b12ea1..3f13476355 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -1540,8 +1540,8 @@ type scope_class = cl_typ let scope_class_compare : scope_class -> scope_class -> int = cl_typ_ord -let compute_scope_class sigma t = - let (cl,_,_) = find_class_type sigma t in +let compute_scope_class env sigma t = + let (cl,_,_) = find_class_type env sigma t in cl module ScopeClassOrd = @@ -1570,22 +1570,23 @@ let find_scope_class_opt = function (**********************************************************************) (* Special scopes associated to arguments of a global reference *) -let rec compute_arguments_classes sigma t = - match EConstr.kind sigma (Reductionops.whd_betaiotazeta sigma t) with - | Prod (_,t,u) -> - let cl = try Some (compute_scope_class sigma t) with Not_found -> None in - cl :: compute_arguments_classes sigma u +let rec compute_arguments_classes env sigma t = + match EConstr.kind sigma (Reductionops.whd_betaiotazeta env sigma t) with + | Prod (na, t, u) -> + let env = EConstr.push_rel (Context.Rel.Declaration.LocalAssum (na, t)) env in + let cl = try Some (compute_scope_class env sigma t) with Not_found -> None in + cl :: compute_arguments_classes env sigma u | _ -> [] -let compute_arguments_scope_full sigma t = - let cls = compute_arguments_classes sigma t in +let compute_arguments_scope_full env sigma t = + let cls = compute_arguments_classes env sigma t in let scs = List.map find_scope_class_opt cls in scs, cls -let compute_arguments_scope sigma t = fst (compute_arguments_scope_full sigma t) +let compute_arguments_scope env sigma t = fst (compute_arguments_scope_full env sigma t) -let compute_type_scope sigma t = - find_scope_class_opt (try Some (compute_scope_class sigma t) with Not_found -> None) +let compute_type_scope env sigma t = + find_scope_class_opt (try Some (compute_scope_class env sigma t) with Not_found -> None) let current_type_scope_name () = find_scope_class_opt (Some CL_SORT) @@ -1623,15 +1624,16 @@ let load_arguments_scope _ (_,(_,r,n,scl,cls)) = let cache_arguments_scope o = load_arguments_scope 1 o -let subst_scope_class subst cs = - try Some (subst_cl_typ subst cs) with Not_found -> None +let subst_scope_class env subst cs = + try Some (subst_cl_typ env subst cs) with Not_found -> None let subst_arguments_scope (subst,(req,r,n,scl,cls)) = let r' = fst (subst_global subst r) in let subst_cl ocl = match ocl with | None -> ocl | Some cl -> - match subst_scope_class subst cl with + let env = Global.env () in + match subst_scope_class env subst cl with | Some cl' as ocl' when cl' != cl -> ocl' | _ -> ocl in let cls' = List.Smart.map subst_cl cls in @@ -1657,7 +1659,7 @@ let rebuild_arguments_scope sigma (req,r,n,l,_) = | ArgsScopeAuto -> let env = Global.env () in (*FIXME?*) let typ = EConstr.of_constr @@ fst (Typeops.type_of_global_in_context env r) in - let scs,cls = compute_arguments_scope_full sigma typ in + let scs,cls = compute_arguments_scope_full env sigma typ in (req,r,List.length scs,scs,cls) | ArgsScopeManual -> (* Add to the manually given scopes the one found automatically @@ -1665,7 +1667,7 @@ let rebuild_arguments_scope sigma (req,r,n,l,_) = of the manually given scopes to avoid further re-computations. *) let env = Global.env () in (*FIXME?*) let typ = EConstr.of_constr @@ fst (Typeops.type_of_global_in_context env r) in - let l',cls = compute_arguments_scope_full sigma typ in + let l',cls = compute_arguments_scope_full env sigma typ in let l1 = List.firstn n l' in let cls1 = List.firstn n cls in (req,r,0,l1@l,cls1) @@ -1712,7 +1714,7 @@ let find_arguments_scope r = let declare_ref_arguments_scope sigma ref = let env = Global.env () in (* FIXME? *) let typ = EConstr.of_constr @@ fst @@ Typeops.type_of_global_in_context env ref in - let (scs,cls as o) = compute_arguments_scope_full sigma typ in + let (scs,cls as o) = compute_arguments_scope_full env sigma typ in declare_arguments_scope_gen ArgsScopeAuto ref (List.length scs) o (********************************) @@ -1899,10 +1901,10 @@ let browse_notation strict ntn map = map [] in List.sort (fun x y -> String.compare (snd (fst x)) (snd (fst y))) l -let global_reference_of_notation test (ntn,(sc,c,_)) = +let global_reference_of_notation ~head test (ntn,(sc,c,_)) = match c with | NRef ref when test ref -> Some (ntn,sc,ref) - | NApp (NRef ref, l) when List.for_all isNVar_or_NHole l && test ref -> + | NApp (NRef ref, l) when head || List.for_all isNVar_or_NHole l && test ref -> Some (ntn,sc,ref) | _ -> None @@ -1914,14 +1916,14 @@ let error_notation_not_reference ?loc ntn = (str "Unable to interpret " ++ quote (str ntn) ++ str " as a reference.") -let interp_notation_as_global_reference ?loc test ntn sc = +let interp_notation_as_global_reference ?loc ~head test ntn sc = let scopes = match sc with | Some sc -> let scope = find_scope (find_delimiters_scope sc) in String.Map.add sc scope String.Map.empty | None -> !scope_map in let ntns = browse_notation true ntn scopes in - let refs = List.map (global_reference_of_notation test) ntns in + let refs = List.map (global_reference_of_notation ~head test) ntns in match Option.List.flatten refs with | [_,_,ref] -> ref | [] -> error_notation_not_reference ?loc ntn diff --git a/interp/notation.mli b/interp/notation.mli index a6b7e81841..e7e917463b 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -254,7 +254,8 @@ val availability_of_notation : specific_notation -> subscopes -> (** {6 Miscellaneous} *) -val interp_notation_as_global_reference : ?loc:Loc.t -> (GlobRef.t -> bool) -> +(** If head is true, also allows applied global references. *) +val interp_notation_as_global_reference : ?loc:Loc.t -> head:bool -> (GlobRef.t -> bool) -> notation_key -> delimiters option -> GlobRef.t (** Checks for already existing notations *) @@ -273,13 +274,13 @@ type scope_class val scope_class_compare : scope_class -> scope_class -> int val subst_scope_class : - Mod_subst.substitution -> scope_class -> scope_class option + Environ.env -> Mod_subst.substitution -> scope_class -> scope_class option val declare_scope_class : scope_name -> scope_class -> unit val declare_ref_arguments_scope : Evd.evar_map -> GlobRef.t -> unit -val compute_arguments_scope : Evd.evar_map -> EConstr.types -> scope_name option list -val compute_type_scope : Evd.evar_map -> EConstr.types -> scope_name option +val compute_arguments_scope : Environ.env -> Evd.evar_map -> EConstr.types -> scope_name option list +val compute_type_scope : Environ.env -> Evd.evar_map -> EConstr.types -> scope_name option (** Get the current scope bound to Sortclass, if it exists *) val current_type_scope_name : unit -> scope_name option diff --git a/interp/smartlocate.ml b/interp/smartlocate.ml index 98fa71e15d..03977fcb4e 100644 --- a/interp/smartlocate.ml +++ b/interp/smartlocate.ml @@ -62,15 +62,15 @@ let global_with_alias ?head qid = try locate_global_with_alias ?head qid with Not_found -> Nametab.error_global_not_found qid -let smart_global ?head = let open Constrexpr in CAst.with_loc_val (fun ?loc -> function +let smart_global ?(head = false) = let open Constrexpr in CAst.with_loc_val (fun ?loc -> function | AN r -> - global_with_alias ?head r + global_with_alias ~head r | ByNotation (ntn,sc) -> - Notation.interp_notation_as_global_reference ?loc (fun _ -> true) ntn sc) + Notation.interp_notation_as_global_reference ?loc ~head (fun _ -> true) ntn sc) let smart_global_inductive = let open Constrexpr in CAst.with_loc_val (fun ?loc -> function | AN r -> global_inductive_with_alias r | ByNotation (ntn,sc) -> destIndRef - (Notation.interp_notation_as_global_reference ?loc isIndRef ntn sc)) + (Notation.interp_notation_as_global_reference ?loc ~head:false isIndRef ntn sc)) diff --git a/interp/stdarg.ml b/interp/stdarg.ml index 492671fff0..d5f104b7f8 100644 --- a/interp/stdarg.ml +++ b/interp/stdarg.ml @@ -42,6 +42,8 @@ let wit_var = let wit_ref = make0 "ref" +let wit_smart_global = make0 ~dyn:(val_tag (topwit wit_ref)) "smart_global" + let wit_sort_family = make0 "sort_family" let wit_constr = diff --git a/interp/stdarg.mli b/interp/stdarg.mli index 35de3693cb..89bdd78c70 100644 --- a/interp/stdarg.mli +++ b/interp/stdarg.mli @@ -39,6 +39,8 @@ val wit_var : (lident, lident, Id.t) genarg_type val wit_ref : (qualid, GlobRef.t located or_var, GlobRef.t) genarg_type +val wit_smart_global : (qualid or_by_notation, GlobRef.t located or_var, GlobRef.t) genarg_type + val wit_sort_family : (Sorts.family, unit, unit) genarg_type val wit_constr : (constr_expr, glob_constr_and_expr, constr) genarg_type diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml index 7184f5ea29..bd3e234a91 100644 --- a/interp/syntax_def.ml +++ b/interp/syntax_def.ml @@ -8,7 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Util open Pp open CErrors open Names @@ -82,16 +81,9 @@ let in_syntax_constant : (bool * syndef) -> obj = subst_function = subst_syntax_constant; classify_function = classify_syntax_constant } -type syndef_interpretation = (Id.t * subscopes) list * notation_constr - -(* Coercions to the general format of notation that also supports - variables bound to list of expressions *) -let in_pat (ids,ac) = (List.map (fun (id,sc) -> (id,((Constrexpr.InConstrEntrySomeLevel,sc),NtnTypeConstr))) ids,ac) -let out_pat (ids,ac) = (List.map (fun (id,((_,sc),typ)) -> (id,sc)) ids,ac) - let declare_syntactic_definition ~local deprecation id ~onlyparsing pat = let syndef = - { syndef_pattern = in_pat pat; + { syndef_pattern = pat; syndef_onlyparsing = onlyparsing; syndef_deprecation = deprecation; } @@ -106,14 +98,12 @@ let warn_deprecated_syntactic_definition = let search_syntactic_definition ?loc kn = let syndef = KNmap.find kn !syntax_table in - let def = out_pat syndef.syndef_pattern in Option.iter (fun d -> warn_deprecated_syntactic_definition ?loc (kn,d)) syndef.syndef_deprecation; - def + syndef.syndef_pattern let search_filtered_syntactic_definition ?loc filter kn = let syndef = KNmap.find kn !syntax_table in - let def = out_pat syndef.syndef_pattern in - let res = filter def in + let res = filter syndef.syndef_pattern in if Option.has_some res then Option.iter (fun d -> warn_deprecated_syntactic_definition ?loc (kn,d)) syndef.syndef_deprecation; res diff --git a/interp/syntax_def.mli b/interp/syntax_def.mli index 8b323462a1..66a3132f2a 100644 --- a/interp/syntax_def.mli +++ b/interp/syntax_def.mli @@ -13,12 +13,10 @@ open Notation_term (** Syntactic definitions. *) -type syndef_interpretation = (Id.t * subscopes) list * notation_constr - val declare_syntactic_definition : local:bool -> Deprecation.t option -> Id.t -> - onlyparsing:bool -> syndef_interpretation -> unit + onlyparsing:bool -> interpretation -> unit -val search_syntactic_definition : ?loc:Loc.t -> KerName.t -> syndef_interpretation +val search_syntactic_definition : ?loc:Loc.t -> KerName.t -> interpretation val search_filtered_syntactic_definition : ?loc:Loc.t -> - (syndef_interpretation -> 'a option) -> KerName.t -> 'a option + (interpretation -> 'a option) -> KerName.t -> 'a option diff --git a/kernel/conv_oracle.ml b/kernel/conv_oracle.ml index 9b87c194c5..3ee1d2fb1f 100644 --- a/kernel/conv_oracle.ml +++ b/kernel/conv_oracle.ml @@ -19,6 +19,12 @@ open Names * The default value is [Level 100]. *) type level = Expand | Level of int | Opaque +let pr_level = function + | Expand -> Pp.str "expand" + | Level 0 -> Pp.str "transparent" + | Level n -> Pp.int n + | Opaque -> Pp.str "opaque" + let default = Level 0 let is_default = function | Level 0 -> true diff --git a/kernel/conv_oracle.mli b/kernel/conv_oracle.mli index b25488d94a..930edf6c49 100644 --- a/kernel/conv_oracle.mli +++ b/kernel/conv_oracle.mli @@ -27,6 +27,7 @@ val oracle_order : ('a -> Constant.t) -> oracle -> bool -> * The default value (transparent constants) is [Level 0]. *) type level = Expand | Level of int | Opaque +val pr_level : level -> Pp.t val transparent : level (** Check whether a level is transparent *) @@ -42,4 +43,3 @@ val set_strategy : oracle -> Constant.t tableKey -> level -> oracle val fold_strategy : (Constant.t tableKey -> level -> 'a -> 'a) -> oracle -> 'a -> 'a val get_transp_state : oracle -> TransparentState.t - diff --git a/kernel/environ.ml b/kernel/environ.ml index d6d52dbc2b..182ed55d0e 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -67,7 +67,7 @@ end type stratification = { env_universes : UGraph.t; env_sprop_allowed : bool; - env_universes_lbound : Univ.Level.t; + env_universes_lbound : UGraph.Bound.t; env_engagement : engagement } @@ -129,7 +129,7 @@ let empty_env = { env_stratification = { env_universes = UGraph.initial_universes; env_sprop_allowed = true; - env_universes_lbound = Univ.Level.set; + env_universes_lbound = UGraph.Bound.Set; env_engagement = PredicativeSet }; env_typing_flags = Declareops.safe_flags Conv_oracle.empty; retroknowledge = Retroknowledge.empty; diff --git a/kernel/environ.mli b/kernel/environ.mli index 7a46538772..79e632daa0 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -62,7 +62,7 @@ end type stratification = { env_universes : UGraph.t; env_sprop_allowed : bool; - env_universes_lbound : Univ.Level.t; + env_universes_lbound : UGraph.Bound.t; env_engagement : engagement } @@ -96,8 +96,8 @@ val eq_named_context_val : named_context_val -> named_context_val -> bool val empty_env : env val universes : env -> UGraph.t -val universes_lbound : env -> Univ.Level.t -val set_universes_lbound : env -> Univ.Level.t -> env +val universes_lbound : env -> UGraph.Bound.t +val set_universes_lbound : env -> UGraph.Bound.t -> env val rel_context : env -> Constr.rel_context val named_context : env -> Constr.named_context val named_context_val : env -> named_context_val diff --git a/kernel/indTyping.ml b/kernel/indTyping.ml index 8ac96a6481..e9687991c0 100644 --- a/kernel/indTyping.ml +++ b/kernel/indTyping.ml @@ -321,7 +321,7 @@ let typecheck_inductive env ~sec_univs (mie:mutual_inductive_entry) = if has_template_poly then (* For that particular case, we typecheck the inductive in an environment where the universes introduced by the definition are only [>= Prop] *) - let env = set_universes_lbound env Univ.Level.prop in + let env = set_universes_lbound env UGraph.Bound.Prop in push_context_set ~strict:false ctx env else (* In the regular case, all universes are [> Set] *) diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index 5f5f0ef8cd..927db9e9e6 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -148,8 +148,14 @@ let enforce_leq_alg u v g = assert (check_leq g u v); cg +module Bound = +struct + type t = Prop | Set +end + exception AlreadyDeclared = G.AlreadyDeclared let add_universe u ~lbound ~strict g = + let lbound = match lbound with Bound.Prop -> Level.prop | Bound.Set -> Level.set in let graph = G.add u g.graph in let d = if strict then Lt else Le in enforce_constraint (lbound,d,u) {g with graph} diff --git a/kernel/uGraph.mli b/kernel/uGraph.mli index 8d9afb0990..c9fbd7f694 100644 --- a/kernel/uGraph.mli +++ b/kernel/uGraph.mli @@ -48,7 +48,13 @@ val enforce_leq_alg : Universe.t -> Universe.t -> t -> Constraint.t * t exception AlreadyDeclared -val add_universe : Level.t -> lbound:Level.t -> strict:bool -> t -> t +module Bound : +sig + type t = Prop | Set + (** The [Prop] bound is only used for template polymorphic inductive types. *) +end + +val add_universe : Level.t -> lbound:Bound.t -> strict:bool -> t -> t (** Add a universe without (Prop,Set) <= u *) val add_universe_unconstrained : Level.t -> t -> t @@ -86,7 +92,7 @@ val constraints_for : kept:LSet.t -> t -> Constraint.t val domain : t -> LSet.t (** Known universes *) -val check_subtype : lbound:Level.t -> AUContext.t check_function +val check_subtype : lbound:Bound.t -> AUContext.t check_function (** [check_subtype univ ctx1 ctx2] checks whether [ctx2] is an instance of [ctx1]. *) diff --git a/lib/system.ml b/lib/system.ml index 4e98651d6e..e25f758865 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -168,6 +168,15 @@ let try_remove filename = let error_corrupted file s = CErrors.user_err ~hdr:"System" (str file ++ str ": " ++ str s ++ str ". Try to rebuild it.") +let check_caml_version ~caml:s ~file:f = + if not (String.equal Coq_config.caml_version s) then + CErrors.user_err (str ("The file " ^ f ^ " was compiled with OCaml") ++ + spc () ++ str s ++ spc () ++ str "while this instance of Coq was compiled \ + with OCaml" ++ spc() ++ str Coq_config.caml_version ++ str "." ++ spc () ++ + str "Coq object files need to be compiled with the same OCaml toolchain to \ + be compatible.") + else () + let input_binary_int f ch = try input_binary_int ch with diff --git a/lib/system.mli b/lib/system.mli index 4a8c35b6ea..1e2f519327 100644 --- a/lib/system.mli +++ b/lib/system.mli @@ -88,6 +88,8 @@ val with_magic_number_check : ('a -> 'b) -> 'a -> 'b val marshal_out : out_channel -> 'a -> unit val marshal_in : string -> in_channel -> 'a +val check_caml_version : caml:string -> file:string -> unit + (** {6 Time stamps.} *) type time diff --git a/library/global.mli b/library/global.mli index 2acd7e2a67..2767594171 100644 --- a/library/global.mli +++ b/library/global.mli @@ -22,7 +22,7 @@ val env : unit -> Environ.env val env_is_initial : unit -> bool val universes : unit -> UGraph.t -val universes_lbound : unit -> Univ.Level.t +val universes_lbound : unit -> UGraph.Bound.t val named_context_val : unit -> Environ.named_context_val val named_context : unit -> Constr.named_context diff --git a/man/coq-tex.1 b/man/coq-tex.1 index 7e0a2f81e2..e4cea24c55 100644 --- a/man/coq-tex.1 +++ b/man/coq-tex.1 @@ -1,4 +1,4 @@ -.TH COQ-TEX 1 "29 March 1995" +.TH COQ-TEX 1 .SH NAME coq-tex \- Process Coq phrases embedded in LaTeX files @@ -66,7 +66,7 @@ with `.v.tex' appended. The files produced by .B coq-tex -can be directly processed by LaTeX. +can be directly processed by LaTeX. Both the Coq phrases and the toplevel output are typeset in typewriter font. @@ -86,7 +86,7 @@ folding is performed on the Coq input text. Cause the file .IR coq-image to be executed to evaluate the Coq phrases. By default, -this is the command +this is the command .IR coqtop without specifying any path which is used to evaluate the Coq phrases. .TP diff --git a/man/coq_makefile.1 b/man/coq_makefile.1 index b5de6d367d..0f5912a4bb 100644 --- a/man/coq_makefile.1 +++ b/man/coq_makefile.1 @@ -1,4 +1,4 @@ -.TH COQ 1 "April 25, 2001" +.TH COQ 1 .SH NAME coq_makefile \- The Coq Proof Assistant makefile generator diff --git a/man/coqc.1 b/man/coqc.1 index 1e597afd99..a7be343fa0 100644 --- a/man/coqc.1 +++ b/man/coqc.1 @@ -1,4 +1,4 @@ -.TH COQ 1 "April 25, 2001" +.TH COQ 1 .SH NAME coqc \- The Coq Proof Assistant compiler @@ -19,14 +19,14 @@ is the batch compiler for the Coq Proof Assistant. The options are basically the same as coqtop(1). .IR file.v \& is the vernacular file to compile. -.IR file \& +.IR file \& must be formed only with the characters `a` to `Z`, `0`-`9` or `_` and must begin with a letter. The compiler produces an object file .IR file.vo \&. -For interactive use of Coq, see +For interactive use of Coq, see .BR coqtop(1). @@ -35,7 +35,7 @@ For interactive use of Coq, see .B coqc is a script that simply runs .B coqtop -with option +with option .B \-compile it accepts the same options as .B coqtop. diff --git a/man/coqchk.1 b/man/coqchk.1 index f9241c0d47..2f9e1fd84d 100644 --- a/man/coqchk.1 +++ b/man/coqchk.1 @@ -1,4 +1,4 @@ -.TH COQ 1 "July 7, 201" +.TH COQ 1 .SH NAME coqchk \- The Coq Proof Checker compiled libraries verifier @@ -29,7 +29,7 @@ short or qualified logical name, or by their filename. .TP .BI \-I \ dir, \ \-\-include \ dir -add directory +add directory .I dir in the include path diff --git a/man/coqdep.1 b/man/coqdep.1 index 0770ce88c8..b0d9606969 100644 --- a/man/coqdep.1 +++ b/man/coqdep.1 @@ -1,4 +1,4 @@ -.TH COQ 1 "28 March 1995" "Coq tools" +.TH COQ 1 .SH NAME coqdep \- Compute inter-module dependencies for Coq and Caml programs @@ -31,13 +31,13 @@ When a directory is given as argument, it is recursively looked at. Dependencies of Coq modules are computed by looking at .IR Require \& commands (Require, Require Export, Require Import), -.IR Declare \& -.IR ML \& +.IR Declare \& +.IR ML \& .IR Module \& commands and .IR Load \& commands. Dependencies relative to modules from the Coq library are not -printed except if +printed except if .BR \-boot \& is given. @@ -51,27 +51,27 @@ directives and the dot notation .TP .BI \-f \ file Read filenames and options -I, -R and -Q from a _CoqProject FILE. -.TP +.TP .BI \-I/\-Q/\-R \ options Have the same effects on load path and modules names as for other coq commands (coqtop, coqc). -.TP +.TP .BI \-coqlib \ directory Indicates where is the Coq library. The default value has been determined at installation time, and therefore this option should not be used under normal circumstances. -.TP +.TP .BI \-exclude-dir \ dir Skips subdirectory .IR dir \ during .BR -R/-Q \ search. -.TP +.TP .B \-sort Output the given file name ordered by dependencies. .TP .B \-vos Output dependencies for .vos files (this is not the default as it breaks dune's Coq mode) -.TP +.TP .B \-boot For coq developers, prints dependencies over coq library files (omitted by default). @@ -106,7 +106,7 @@ Consider the files (in the same directory): where .TP -.BI \+ +.BI \+ D.ml contains the commands `open A', `open B' and `type t = C.t' ; .TP .BI \+ diff --git a/man/coqdoc.1 b/man/coqdoc.1 index 8d71a8746d..e8a58611f0 100644 --- a/man/coqdoc.1 +++ b/man/coqdoc.1 @@ -1,4 +1,4 @@ -.TH coqdoc 1 "April, 2006" +.TH coqdoc 1 .SH NAME coqdoc \- A documentation tool for the Coq proof assistant @@ -47,12 +47,12 @@ Select a TeXmacs output. Redirect the output to stdout .TP .BI \-o \ file, \-\-output \ file -Redirect the output into the file +Redirect the output into the file .I file. .TP .BI \-d \ dir, \ \-\-directory \ dir -Output files into directory -.I dir +Output files into directory +.I dir instead of current directory (option \-d does not change the filename specified with option \-o, if any). .TP @@ -102,7 +102,7 @@ Generate one page for each category and each letter in the index, together with a top page index.html. .SS Table of contents option - + .TP .B \-toc, \ \-\-table\-of\-contents Insert a table of contents. For a LATEX output, it inserts a @@ -136,7 +136,7 @@ Set the base path where the Coq files are installed, especially style files coqd .BI \-R \ dir \ coqdir Map physical directory dir to Coq logical directory coqdir (similarly to Coq option \-R). -.B Note: +.B Note: option \-R only has effect on the files following it on the command line, so you will probably need to put this option first. @@ -155,26 +155,26 @@ Light mode. Suppress proofs (as with \-g) and the following commands: * Require * Transparent / Opaque * Implicit Argument / Implicits - * Section / Variable / Hypothesis / End + * Section / Variable / Hypothesis / End The behavior of options \-g and \-l can be locally overridden using the (* begin show *) ... (* end show *) environment (see above). .SS Language options - + Default behavior is to assume ASCII 7 bits input files. -.TP +.TP .B \-latin1, \ \-\-latin1 Select ISO-8859-1 input files. It is equivalent to \-\-inputenc latin1 \-\-charset iso\-8859\-1. -.TP +.TP .B \-utf8, \ \-\-utf8 Select UTF-8 (Unicode) input files. It is equivalent to \-\-inputenc utf8 \-\-charset utf\-8. LATEX UTF-8 support can be found at http://www.ctan.org/tex\-archive/macros/latex/contrib/supported/unicode/. -.TP +.TP .BI \-\-inputenc \ string Give a LATEX input encoding, as an option to LATEX package inputenc. @@ -187,4 +187,3 @@ Specify the HTML character set, to be inserted in the HTML header. .I The Coq Reference Manual from http://coq.inria.fr/ - diff --git a/man/coqide.1 b/man/coqide.1 index c1af046019..267f8a8d4b 100644 --- a/man/coqide.1 +++ b/man/coqide.1 @@ -1,4 +1,4 @@ -.TH COQIDE 1 "July 16, 2004" +.TH COQIDE 1 .SH NAME coqide \- The Coq Proof Assistant graphical interface @@ -17,7 +17,7 @@ is a gtk graphical interface for the Coq proof assistant. For command-line-oriented use of Coq, see .BR coqtop (1) -; for batch-oriented use of Coq, see +; for batch-oriented use of Coq, see .BR coqc (1). diff --git a/man/coqtop.1 b/man/coqtop.1 index e799bc7748..74380f9679 100644 --- a/man/coqtop.1 +++ b/man/coqtop.1 @@ -1,4 +1,4 @@ -.TH COQ 1 "October 11, 2006" +.TH COQ 1 .SH NAME coqtop \- The Coq Proof Assistant toplevel system @@ -17,7 +17,7 @@ is the toplevel system of Coq, for interactive use. It reads phrases on the standard input, and prints results on the standard output. -For batch-oriented use of Coq, see +For batch-oriented use of Coq, see .BR coqc(1). @@ -29,12 +29,12 @@ Help. Will give you the complete list of options accepted by coqtop. .TP .BI \-I \ dir, \ \-\-include \ dir -add directory +add directory .I dir in the include path .TP -.BI \-R \ dir\ coqdir +.BI \-R \ dir\ coqdir recursively map physical .I dir to logical @@ -67,7 +67,7 @@ load Coq file (Load filename.) .TP -.BI \-load\-vernac\-source\-verbose \ filename, \ \-lv \ filename +.BI \-load\-vernac\-source\-verbose \ filename, \ \-lv \ filename load verbosely Coq file .I filename.v (Load Verbose filename.) diff --git a/man/coqtop.byte.1 b/man/coqtop.byte.1 index ad1a358c32..4ef317749d 100644 --- a/man/coqtop.byte.1 +++ b/man/coqtop.byte.1 @@ -1,4 +1,4 @@ -.TH COQ 1 "April 25, 2001" +.TH COQ 1 .SH NAME coqtop.byte \- The bytecode Coq toplevel @@ -31,5 +31,3 @@ and The Coq Reference Manual. .I The Coq web site: http://coq.inria.fr - - diff --git a/man/coqtop.opt.1 b/man/coqtop.opt.1 index 17c763da33..fc097a2ecf 100644 --- a/man/coqtop.opt.1 +++ b/man/coqtop.opt.1 @@ -1,4 +1,4 @@ -.TH COQ 1 "April 25, 2001" +.TH COQ 1 .SH NAME coqtop.opt \- The native-code Coq toplevel @@ -31,5 +31,3 @@ and The Coq Reference Manual. .I The Coq web site: http://coq.inria.fr - - diff --git a/man/coqwc.1 b/man/coqwc.1 index eee37f3d1f..344b1fecc5 100644 --- a/man/coqwc.1 +++ b/man/coqwc.1 @@ -1,4 +1,4 @@ -.TH COQ 1 "16 March 2004" "Coq tools" +.TH COQ 1 .SH NAME coqwc \- print the number of specification, proof and comment lines in diff --git a/parsing/g_constr.mlg b/parsing/g_constr.mlg index 963f029766..c19dd00b38 100644 --- a/parsing/g_constr.mlg +++ b/parsing/g_constr.mlg @@ -26,16 +26,6 @@ open Pcoq.Constr (* TODO: avoid this redefinition without an extra dep to Notation_ops *) let ldots_var = Id.of_string ".." -let constr_kw = - [ "forall"; "fun"; "match"; "fix"; "cofix"; "with"; "in"; "for"; - "end"; "as"; "let"; "if"; "then"; "else"; "return"; - "SProp"; "Prop"; "Set"; "Type"; - ":="; "=>"; "->"; ".."; "<:"; "<<:"; ":>"; - ".("; "()"; "`{"; "`("; "@{"; "{|"; - "_"; "@"; "+"; "!"; "?"; ";"; ","; ":" ] - -let _ = List.iter CLexer.add_keyword constr_kw - let mk_cast = function (c,(_,None)) -> c | (c,(_,Some ty)) -> diff --git a/parsing/g_prim.mlg b/parsing/g_prim.mlg index 9c50109bb3..cc59b2175b 100644 --- a/parsing/g_prim.mlg +++ b/parsing/g_prim.mlg @@ -15,10 +15,6 @@ open Libnames open Pcoq.Prim -let prim_kw = ["{"; "}"; "["; "]"; "("; ")"; "'"; "%"; "|"] -let _ = List.iter CLexer.add_keyword prim_kw - - let local_make_qualid loc l id = make_qualid ~loc (DirPath.make l) id let my_int_of_string ?loc s = @@ -53,7 +49,7 @@ GRAMMAR EXTEND Gram bignat bigint natural integer identref name ident var preident fullyqualid qualid reference dirpath ne_lstring ne_string string lstring pattern_ident pattern_identref by_notation - smart_global bar_cbrace; + smart_global bar_cbrace strategy_level; preident: [ [ s = IDENT -> { s } ] ] ; @@ -140,4 +136,10 @@ GRAMMAR EXTEND Gram bar_cbrace: [ [ test_pipe_closedcurly; "|"; "}" -> { () } ] ] ; + strategy_level: + [ [ IDENT "expand" -> { Conv_oracle.Expand } + | IDENT "opaque" -> { Conv_oracle.Opaque } + | n=integer -> { Conv_oracle.Level n } + | IDENT "transparent" -> { Conv_oracle.transparent } ] ] + ; END diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 5b0562fb0d..2cc16f85d5 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -276,6 +276,7 @@ module Prim = let reference = make_gen_entry uprim "reference" let by_notation = Entry.create "by_notation" let smart_global = Entry.create "smart_global" + let strategy_level = gec_gen "strategy_level" (* parsed like ident but interpreted as a term *) let var = gec_gen "var" @@ -505,6 +506,7 @@ let () = Grammar.register0 wit_ident (Prim.ident); Grammar.register0 wit_var (Prim.var); Grammar.register0 wit_ref (Prim.reference); + Grammar.register0 wit_smart_global (Prim.smart_global); Grammar.register0 wit_sort_family (Constr.sort_family); Grammar.register0 wit_constr (Constr.constr); () diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 90088be307..bd64d21518 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -170,6 +170,7 @@ module Prim : val ne_lstring : lstring Entry.t val var : lident Entry.t val bar_cbrace : unit Entry.t + val strategy_level : Conv_oracle.level Entry.t end module Constr : diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 0c305d09e8..c485c38009 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -290,7 +290,6 @@ let constr_of_term c = EConstr.of_constr (constr_of_term c) let rec proof_tac p : unit Proofview.tactic = Proofview.Goal.enter begin fun gl -> - try (* type_of can raise exceptions *) match p.p_rule with Ax c -> exact_check (EConstr.of_constr c) | SymAx c -> @@ -350,7 +349,6 @@ let rec proof_tac p : unit Proofview.tactic = app_global_with_holes _f_equal [|intype;outtype;proj;ti;tj|] 1 in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Tacticals.New.tclTHEN injt (proof_tac prf)))) - with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e end let refute_tac c t1 t2 p = @@ -508,11 +506,9 @@ let f_equal = let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in let cut_eq c1 c2 = - try (* type_of can raise an exception *) Tacticals.New.tclTHENS (mk_eq _eq c1 c2 Tactics.cut) [Proofview.tclUNIT ();Tacticals.New.tclTRY ((app_global _refl_equal [||]) apply)] - with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e in Proofview.tclORELSE begin match EConstr.kind sigma concl with diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index afc83b780b..0f96b9bbe8 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -259,7 +259,7 @@ let parse_ind_args si args relmax = let rec extract_type env sg db j c args = - match EConstr.kind sg (whd_betaiotazeta sg c) with + match EConstr.kind sg (whd_betaiotazeta env sg c) with | App (d, args') -> (* We just accumulate the arguments. *) extract_type env sg db j d (Array.to_list args' @ args) @@ -380,7 +380,7 @@ and extract_type_app env sg db (r,s) args = and extract_type_scheme env sg db c p = if Int.equal p 0 then extract_type env sg db 0 c [] else - let c = whd_betaiotazeta sg c in + let c = whd_betaiotazeta env sg c in match EConstr.kind sg c with | Lambda (n,t,d) -> extract_type_scheme (push_rel_assum (n,t) env) sg db d (p-1) diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index 834e4251d3..f13901c36d 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -57,12 +57,12 @@ let make_simple_atoms seq= | None->[] in {negative=seq.latoms;positive=ratoms} -let do_sequent sigma setref triv id seq i dom atoms= +let do_sequent env sigma setref triv id seq i dom atoms= let flag=ref true in let phref=ref triv in let do_atoms a1 a2 = let do_pair t1 t2 = - match unif_atoms sigma i dom t1 t2 with + match unif_atoms env sigma i dom t1 t2 with None->() | Some (Phantom _) ->phref:=true | Some c ->flag:=false;setref:=IS.add (c,id) !setref in @@ -72,16 +72,16 @@ let do_sequent sigma setref triv id seq i dom atoms= do_atoms atoms (make_simple_atoms seq); !flag && !phref -let match_one_quantified_hyp sigma setref seq lf= +let match_one_quantified_hyp env sigma setref seq lf= match lf.pat with Left(Lforall(i,dom,triv))|Right(Rexists(i,dom,triv))-> - if do_sequent sigma setref triv lf.id seq i dom lf.atoms then + if do_sequent env sigma setref triv lf.id seq i dom lf.atoms then setref:=IS.add ((Phantom dom),lf.id) !setref | _ -> anomaly (Pp.str "can't happen.") -let give_instances sigma lf seq= +let give_instances env sigma lf seq= let setref=ref IS.empty in - List.iter (match_one_quantified_hyp sigma setref seq) lf; + List.iter (match_one_quantified_hyp env sigma setref seq) lf; IS.elements !setref (* collector for the engine *) @@ -129,9 +129,10 @@ let left_instance_tac (inst,id) continue seq= let open EConstr in Proofview.Goal.enter begin fun gl -> let sigma = project gl in + let env = Proofview.Goal.env gl in match inst with Phantom dom-> - if lookup sigma (id,None) seq then + if lookup env sigma (id,None) seq then tclFAIL 0 (Pp.str "already done") else tclTHENS (cut dom) @@ -148,7 +149,7 @@ let left_instance_tac (inst,id) continue seq= tclTRY assumption] | Real((m,t),_)-> let c = (m, EConstr.to_constr sigma t) in - if lookup sigma (id,Some c) seq then + if lookup env sigma (id,Some c) seq then tclFAIL 0 (Pp.str "already done") else let special_generalize= @@ -205,7 +206,8 @@ let instance_tac inst= let quantified_tac lf backtrack continue seq = Proofview.Goal.enter begin fun gl -> - let insts=give_instances (project gl) lf seq in + let env = Proofview.Goal.env gl in + let insts=give_instances env (project gl) lf seq in tclORELSE (tclFIRST (List.map (fun inst->instance_tac inst continue seq) insts)) backtrack diff --git a/plugins/firstorder/instances.mli b/plugins/firstorder/instances.mli index c0f4c78ff3..08c2c4d916 100644 --- a/plugins/firstorder/instances.mli +++ b/plugins/firstorder/instances.mli @@ -13,7 +13,7 @@ open Rules val collect_quantified : Evd.evar_map -> Sequent.t -> Formula.t list * Sequent.t -val give_instances : Evd.evar_map -> Formula.t list -> Sequent.t -> +val give_instances : Environ.env -> Evd.evar_map -> Formula.t list -> Sequent.t -> (Unify.instance * GlobRef.t) list val quantified_tac : Formula.t list -> seqtac with_backtracking diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index 7bf13fd25b..3dd5059e5d 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -109,7 +109,7 @@ let deepen seq={seq with depth=seq.depth-1} let record item seq={seq with history=History.add item seq.history} -let lookup sigma item seq= +let lookup env sigma item seq= History.mem item seq.history || match item with (_,None)->false @@ -117,7 +117,7 @@ let lookup sigma item seq= let p (id2,o)= match o with None -> false - | Some (m2, t2)-> GlobRef.equal id id2 && m2>m && more_general sigma (m2, EConstr.of_constr t2) (m, EConstr.of_constr t) in + | Some (m2, t2)-> GlobRef.equal id id2 && m2>m && more_general env sigma (m2, EConstr.of_constr t2) (m, EConstr.of_constr t) in History.exists p seq.history let add_formula env sigma side nam t seq = diff --git a/plugins/firstorder/sequent.mli b/plugins/firstorder/sequent.mli index 3a5da6ad14..bba89c823c 100644 --- a/plugins/firstorder/sequent.mli +++ b/plugins/firstorder/sequent.mli @@ -39,7 +39,7 @@ val deepen: t -> t val record: h_item -> t -> t -val lookup: Evd.evar_map -> h_item -> t -> bool +val lookup: Environ.env -> Evd.evar_map -> h_item -> t -> bool val add_formula : Environ.env -> Evd.evar_map -> side -> GlobRef.t -> constr -> t -> t diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml index e58e80116d..9c3debe48f 100644 --- a/plugins/firstorder/unify.ml +++ b/plugins/firstorder/unify.ml @@ -29,7 +29,7 @@ let subst_meta subst t = let subst = List.map (fun (m, c) -> (m, EConstr.Unsafe.to_constr c)) subst in EConstr.of_constr (subst_meta subst (EConstr.Unsafe.to_constr t)) -let unif evd t1 t2= +let unif env evd t1 t2= let bige=Queue.create () and sigma=ref [] in let bind i t= @@ -46,8 +46,8 @@ let unif evd t1 t2= Queue.add (t1,t2) bige; try while true do let t1,t2=Queue.take bige in - let nt1=head_reduce (whd_betaiotazeta evd t1) - and nt2=head_reduce (whd_betaiotazeta evd t2) in + let nt1=head_reduce (whd_betaiotazeta env evd t1) + and nt2=head_reduce (whd_betaiotazeta env evd t2) in match (EConstr.kind evd nt1),(EConstr.kind evd nt2) with Meta i,Meta j-> if not (Int.equal i j) then @@ -123,9 +123,9 @@ let mk_rel_inst evd t= in let nt=renum_rec 0 t in (!new_rel - 1,nt) -let unif_atoms evd i dom t1 t2= +let unif_atoms env evd i dom t1 t2= try - let t=Int.List.assoc i (unif evd t1 t2) in + let t=Int.List.assoc i (unif env evd t1 t2) in if isMeta evd t then Some (Phantom dom) else Some (Real(mk_rel_inst evd t,value evd i t1)) with @@ -136,11 +136,11 @@ let renum_metas_from k n t= (* requires n = max (free_rels t) *) let l=List.init n (fun i->mkMeta (k+i)) in substl l t -let more_general evd (m1,t1) (m2,t2)= +let more_general env evd (m1,t1) (m2,t2)= let mt1=renum_metas_from 0 m1 t1 and mt2=renum_metas_from m1 m2 t2 in try - let sigma=unif evd mt1 mt2 in + let sigma=unif env evd mt1 mt2 in let p (n,t)= n<m1 || isMeta evd t in List.for_all p sigma with UFAIL(_,_)->false diff --git a/plugins/firstorder/unify.mli b/plugins/firstorder/unify.mli index 71e786eb90..c6767f04ac 100644 --- a/plugins/firstorder/unify.mli +++ b/plugins/firstorder/unify.mli @@ -13,12 +13,12 @@ open EConstr exception UFAIL of constr*constr -val unif : Evd.evar_map -> constr -> constr -> (int*constr) list +val unif : Environ.env -> Evd.evar_map -> constr -> constr -> (int*constr) list type instance= Real of (int*constr)*int (* nb trous*terme*valeur heuristique *) | Phantom of constr (* domaine de quantification *) -val unif_atoms : Evd.evar_map -> metavariable -> constr -> constr -> constr -> instance option +val unif_atoms : Environ.env -> Evd.evar_map -> metavariable -> constr -> constr -> constr -> instance option -val more_general : Evd.evar_map -> (int*constr) -> (int*constr) -> bool +val more_general : Environ.env -> Evd.evar_map -> (int*constr) -> (int*constr) -> bool diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index f4200854c2..b864b18887 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -116,7 +116,7 @@ let prove_trivial_eq h_id context (constructor, type_of_term, term) = refine to_refine g) ] let find_rectype env sigma c = - let t, l = decompose_app sigma (Reductionops.whd_betaiotazeta sigma c) in + let t, l = decompose_app sigma (Reductionops.whd_betaiotazeta env sigma c) in match EConstr.kind sigma t with | Ind ind -> (t, l) | Construct _ -> (t, l) @@ -243,19 +243,25 @@ let change_eq env sigma hyp_id (context : rel_context) x t end_of_type = let new_ctxt, new_end_of_type = decompose_prod_n_assum sigma ctxt_size new_type_of_hyp in - let prove_new_hyp : tactic = - tclTHEN - (tclDO ctxt_size (Proofview.V82.of_tactic intro)) - (fun g -> - let all_ids = pf_ids_of_hyps g in - let new_ids, _ = list_chop ctxt_size all_ids in - let to_refine = applist (witness_fun, List.rev_map mkVar new_ids) in - let evm, _ = pf_apply Typing.type_of g to_refine in - tclTHEN (Refiner.tclEVARS evm) (refine to_refine) g) + let prove_new_hyp = + let open Tacticals.New in + let open Tacmach.New in + tclTHEN (tclDO ctxt_size intro) + (Proofview.Goal.enter (fun g -> + let all_ids = pf_ids_of_hyps g in + let new_ids, _ = list_chop ctxt_size all_ids in + let to_refine = applist (witness_fun, List.rev_map mkVar new_ids) in + let evm, _ = + Typing.type_of (Proofview.Goal.env g) (Proofview.Goal.sigma g) + to_refine + in + tclTHEN + (Proofview.Unsafe.tclEVARS evm) + (Proofview.V82.tactic (refine to_refine)))) in let simpl_eq_tac = change_hyp_with_using "prove_pattern_simplification" hyp_id new_type_of_hyp - prove_new_hyp + (Proofview.V82.of_tactic prove_new_hyp) in (* observe (str "In " ++ Ppconstr.pr_id hyp_id ++ *) (* str "removing an equation " ++ fnl ()++ *) @@ -534,11 +540,13 @@ let instantiate_hyps_with_args (do_prove : Id.t list -> tactic) hyps args_id = let prov_hid = pf_get_new_id hid g in let c = mkApp (mkVar hid, args) in let evm, _ = pf_apply Typing.type_of g c in - tclTHENLIST - [ Refiner.tclEVARS evm - ; Proofview.V82.of_tactic (pose_proof (Name prov_hid) c) - ; thin [hid] - ; Proofview.V82.of_tactic (rename_hyp [(prov_hid, hid)]) ] + let open Tacticals.New in + Proofview.V82.of_tactic + (tclTHENLIST + [ Proofview.Unsafe.tclEVARS evm + ; pose_proof (Name prov_hid) c + ; clear [hid] + ; rename_hyp [(prov_hid, hid)] ]) g) (fun (* if not then we are in a mutual function block diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml index c53dcc7edd..608155eb71 100644 --- a/plugins/funind/gen_principle.ml +++ b/plugins/funind/gen_principle.ml @@ -218,7 +218,7 @@ let build_functional_principle (sigma : Evd.evar_map) old_princ_type sorts funs Declare.build_by_tactic env ~uctx ~poly:false ~typ ftac in (* uctx was ignored before *) - let hook = DeclareDef.Hook.make (hook new_principle_type) in + let hook = Declare.Hook.make (hook new_principle_type) in (body, typ, univs, hook, sigma) let change_property_sort evd toSort princ princName = @@ -318,8 +318,8 @@ let generate_functional_principle (evd : Evd.evar_map ref) old_princ_type sorts let uctx = Evd.evar_universe_context sigma in let entry = Declare.definition_entry ~univs ?types body in let (_ : Names.GlobRef.t) = - DeclareDef.declare_entry ~name:new_princ_name ~hook - ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) + Declare.declare_entry ~name:new_princ_name ~hook + ~scope:(Declare.Global Declare.ImportDefaultBehavior) ~kind:Decls.(IsProof Theorem) ~impargs:[] ~uctx entry in @@ -400,7 +400,7 @@ let register_struct is_rec fixpoint_exprl = Pp.(str "Body of Function must be given") in ComDefinition.do_definition ~name:fname.CAst.v ~poly:false - ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) + ~scope:(Declare.Global Declare.ImportDefaultBehavior) ~kind:Decls.Definition univs binders None body (Some rtype); let evd, rev_pconstants = List.fold_left @@ -419,7 +419,7 @@ let register_struct is_rec fixpoint_exprl = (None, evd, List.rev rev_pconstants) | _ -> ComFixpoint.do_fixpoint - ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) ~poly:false + ~scope:(Declare.Global Declare.ImportDefaultBehavior) ~poly:false fixpoint_exprl; let evd, rev_pconstants = List.fold_left diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index e83fe56cc9..af53f16e1f 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -2,7 +2,7 @@ open Names open Pp open Constr open Libnames -open Refiner +open Tacmach let mk_prefix pre id = Id.of_string (pre ^ Id.to_string id) let mk_rel_id = mk_prefix "R_" @@ -395,7 +395,8 @@ let jmeq_refl () = with e when CErrors.noncritical e -> raise (ToShow e) let h_intros l = - tclMAP (fun x -> Proofview.V82.of_tactic (Tactics.Simple.intro x)) l + Proofview.V82.of_tactic + (Tacticals.New.tclMAP (fun x -> Tactics.Simple.intro x) l) let h_id = Id.of_string "h" let hrec_id = Id.of_string "hrec" @@ -427,15 +428,16 @@ let evaluable_of_global_reference r = | _ -> assert false let list_rewrite (rev : bool) (eqs : (EConstr.constr * bool) list) = - tclREPEAT - (List.fold_right - (fun (eq, b) i -> - tclORELSE - (Proofview.V82.of_tactic - ((if b then Equality.rewriteLR else Equality.rewriteRL) eq)) - i) - (if rev then List.rev eqs else eqs) - (tclFAIL 0 (mt ()))) + let open Tacticals in + (tclREPEAT + (List.fold_right + (fun (eq, b) i -> + tclORELSE + (Proofview.V82.of_tactic + ((if b then Equality.rewriteLR else Equality.rewriteRL) eq)) + i) + (if rev then List.rev eqs else eqs) + (tclFAIL 0 (mt ()))) [@ocaml.warning "-3"]) let decompose_lam_n sigma n = if n < 0 then diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index ffb9a7e69b..9b2d9c4815 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -703,9 +703,16 @@ let terminate_letin (na, b, t, e) expr_info continuation_tac info g = in continuation_tac {info with info = new_e; forbidden_ids = new_forbidden} g -let pf_type c tac gl = - let evars, ty = Typing.type_of (pf_env gl) (project gl) c in - tclTHEN (Refiner.tclEVARS evars) (tac ty) gl +let pf_type c tac = + let open Tacticals.New in + Proofview.Goal.enter (fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let evars, ty = Typing.type_of env sigma c in + tclTHEN (Proofview.Unsafe.tclEVARS evars) (tac ty)) + +let pf_type c tac = + Proofview.V82.of_tactic (pf_type c (fun ty -> Proofview.V82.tactic (tac ty))) let pf_typel l tac = let rec aux tys l = @@ -1483,7 +1490,7 @@ let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name let lemma = build_proof env (Evd.from_env env) start_tac end_tac in Lemmas.save_lemma_proved ~lemma ~opaque:opacity ~idopt:None in - let info = Lemmas.Info.make ~hook:(DeclareDef.Hook.make hook) () in + let info = Lemmas.Info.make ~hook:(Declare.Hook.make hook) () in let lemma = Lemmas.start_lemma ~name:na ~poly:false (* FIXME *) ~info sigma gls_type in @@ -1721,7 +1728,7 @@ let recursive_definition ~interactive_proof ~is_mes function_name rec_impls let tcc_lemma_name = add_suffix function_name "_tcc" in let tcc_lemma_constr = ref Undefined in (* let _ = Pp.msgnl (fun _ _ -> str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *) - let hook {DeclareDef.Hook.S.uctx; _} = + let hook {Declare.Hook.S.uctx; _} = let term_ref = Nametab.locate (qualid_of_ident term_id) in let f_ref = declare_f function_name Decls.(IsProof Lemma) arg_types term_ref @@ -1767,5 +1774,5 @@ let recursive_definition ~interactive_proof ~is_mes function_name rec_impls functional_ref (EConstr.of_constr rec_arg_type) relation rec_arg_num term_id using_lemmas (List.length res_vars) evd - (DeclareDef.Hook.make hook)) + (Declare.Hook.make hook)) () diff --git a/plugins/ltac/evar_tactics.ml b/plugins/ltac/evar_tactics.ml index 17a7121a3f..f867a47c08 100644 --- a/plugins/ltac/evar_tactics.ml +++ b/plugins/ltac/evar_tactics.ml @@ -14,10 +14,7 @@ open Constr open Context open CErrors open Evar_refiner -open Tacmach open Tacexpr -open Refiner -open Evd open Locus open Context.Named.Declaration open Ltac_pretype @@ -26,7 +23,11 @@ module NamedDecl = Context.Named.Declaration (* The instantiate tactic *) -let instantiate_evar evk (ist,rawc) env sigma = +let instantiate_evar evk (ist,rawc) = + let open Proofview.Notations in + Proofview.tclENV >>= fun env -> + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let evi = Evd.find sigma evk in let filtered = Evd.evar_filtered_env env evi in let constrvars = Tacinterp.extract_ltac_constr_values ist filtered in @@ -37,7 +38,8 @@ let instantiate_evar evk (ist,rawc) env sigma = ltac_genargs = ist.Geninterp.lfun; } in let sigma' = w_refine (evk,evi) (lvar ,rawc) env sigma in - tclEVARS sigma' + Proofview.Unsafe.tclEVARS sigma' + end let evar_list sigma c = let rec evrec acc c = @@ -47,14 +49,15 @@ let evar_list sigma c = evrec [] c let instantiate_tac n c ido = - Proofview.V82.tactic begin fun gl -> - let env = Global.env () in - let sigma = gl.sigma in + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env gl in + let concl = Proofview.Goal.concl gl in let evl = match ido with - ConclLocation () -> evar_list sigma (pf_concl gl) + ConclLocation () -> evar_list sigma concl | HypLocation (id,hloc) -> - let decl = Environ.lookup_named id (pf_env gl) in + let decl = Environ.lookup_named id env in match hloc with InHyp -> (match decl with @@ -70,17 +73,16 @@ let instantiate_tac n c ido = user_err Pp.(str "Not enough uninstantiated existential variables."); if n <= 0 then user_err Pp.(str "Incorrect existential variable index."); let evk,_ = List.nth evl (n-1) in - instantiate_evar evk c env sigma gl + instantiate_evar evk c end let instantiate_tac_by_name id c = - Proofview.V82.tactic begin fun gl -> - let env = Global.env () in - let sigma = gl.sigma in + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let evk = try Evd.evar_key id sigma with Not_found -> user_err Pp.(str "Unknown existential variable.") in - instantiate_evar evk c env sigma gl + instantiate_evar evk c end let let_evar name typ = diff --git a/plugins/ltac/extraargs.mlg b/plugins/ltac/extraargs.mlg index c4731e5c34..eb53fd45d0 100644 --- a/plugins/ltac/extraargs.mlg +++ b/plugins/ltac/extraargs.mlg @@ -31,6 +31,8 @@ let create_generic_quotation name e wit = let () = create_generic_quotation "integer" Pcoq.Prim.integer Stdarg.wit_int let () = create_generic_quotation "string" Pcoq.Prim.string Stdarg.wit_string +let () = create_generic_quotation "smart_global" Pcoq.Prim.smart_global Stdarg.wit_smart_global + let () = create_generic_quotation "ident" Pcoq.Prim.ident Stdarg.wit_ident let () = create_generic_quotation "reference" Pcoq.Prim.reference Stdarg.wit_ref let () = create_generic_quotation "uconstr" Pcoq.Constr.lconstr Stdarg.wit_uconstr @@ -342,3 +344,55 @@ 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 + +{ + +(* Work around a limitation of the macro system *) +let strategy_level0 = Pcoq.Prim.strategy_level + +let pr_strategy _ _ _ v = Conv_oracle.pr_level v + +} + +ARGUMENT EXTEND strategy_level PRINTED BY { pr_strategy } +| [ strategy_level0(n) ] -> { n } +END + +{ + +let intern_strategy ist v = match v with +| ArgVar id -> ArgVar (Tacintern.intern_hyp ist id) +| ArgArg v -> ArgArg v + +let subst_strategy _ v = v + +let interp_strategy ist gl = function +| ArgArg n -> gl.Evd.sigma, n +| ArgVar { CAst.v = id; CAst.loc } -> + let v = + try Id.Map.find id ist.lfun + with Not_found -> + CErrors.user_err ?loc + (str "Unbound variable " ++ Id.print id ++ str".") + in + let v = + try Tacinterp.Value.cast (Genarg.topwit wit_strategy_level) v + with CErrors.UserError _ -> Taccoerce.error_ltac_variable ?loc id None v "a strategy_level" + in + gl.Evd.sigma, v + +let pr_loc_strategy _ _ _ v = Pputils.pr_or_var Conv_oracle.pr_level v + +} + +ARGUMENT EXTEND strategy_level_or_var + TYPED AS strategy_level + PRINTED BY { pr_strategy } + INTERPRETED BY { interp_strategy } + GLOBALIZED BY { intern_strategy } + SUBSTITUTED BY { subst_strategy } + RAW_PRINTED BY { pr_loc_strategy } + GLOB_PRINTED BY { pr_loc_strategy } +| [ strategy_level(n) ] -> { ArgArg n } +| [ identref(id) ] -> { ArgVar id } +END diff --git a/plugins/ltac/extraargs.mli b/plugins/ltac/extraargs.mli index fbdb7c0032..e52bf55f71 100644 --- a/plugins/ltac/extraargs.mli +++ b/plugins/ltac/extraargs.mli @@ -78,3 +78,7 @@ val wit_in_clause : (lident Locus.clause_expr, lident Locus.clause_expr, Id.t Locus.clause_expr) Genarg.genarg_type + +val wit_strategy_level : Conv_oracle.level Genarg.uniform_genarg_type + +val wit_strategy_level_or_var : (Conv_oracle.level Locus.or_var, Conv_oracle.level Locus.or_var, Conv_oracle.level) Genarg.genarg_type diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 0bad3cbe5b..ffb597d4cb 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -1119,3 +1119,11 @@ let tclOPTIMIZE_HEAP = TACTIC EXTEND optimize_heap | [ "optimize_heap" ] -> { tclOPTIMIZE_HEAP } END + +(** Tactic analogous to [Strategy] vernacular *) + +TACTIC EXTEND with_strategy +| [ "with_strategy" strategy_level_or_var(v) "[" ne_smart_global_list(q) "]" tactic3(tac) ] -> { + with_set_strategy [(v, q)] (Tacinterp.tactic_of_value ist tac) +} +END diff --git a/plugins/ltac/g_class.mlg b/plugins/ltac/g_class.mlg index 0f0341f123..35c90444b1 100644 --- a/plugins/ltac/g_class.mlg +++ b/plugins/ltac/g_class.mlg @@ -54,16 +54,23 @@ END { +let pr_search_strategy_name _prc _prlc _prt = function + | Dfs -> Pp.str "dfs" + | Bfs -> Pp.str "bfs" + let pr_search_strategy _prc _prlc _prt = function - | Some Dfs -> Pp.str "dfs" - | Some Bfs -> Pp.str "bfs" + | Some s -> pr_search_strategy_name _prc _prlc _prt s | None -> Pp.mt () } +ARGUMENT EXTEND eauto_search_strategy_name PRINTED BY { pr_search_strategy_name } +| [ "bfs" ] -> { Bfs } +| [ "dfs" ] -> { Dfs } +END + ARGUMENT EXTEND eauto_search_strategy PRINTED BY { pr_search_strategy } -| [ "(bfs)" ] -> { Some Bfs } -| [ "(dfs)" ] -> { Some Dfs } +| [ "(" eauto_search_strategy_name(s) ")" ] -> { Some s } | [ ] -> { None } END @@ -135,7 +142,9 @@ let progress_evars t = let sigma = Tacmach.New.project gl' in let newconcl = Proofview.Goal.concl gl' in if eq_constr_mod_evars sigma concl newconcl - then Tacticals.New.tclFAIL 0 (Pp.str"No progress made (modulo evars)") + then + let info = Exninfo.reify () in + Tacticals.New.tclFAIL ~info 0 (Pp.str"No progress made (modulo evars)") else Proofview.tclUNIT () end in t <*> check diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index 5baa23b3e9..0e661543db 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -216,8 +216,8 @@ GRAMMAR EXTEND Gram ; match_key: [ [ "match" -> { Once } - | "lazymatch" -> { Select } - | "multimatch" -> { General } ] ] + | IDENT "lazymatch" -> { Select } + | IDENT "multimatch" -> { General } ] ] ; input_fun: [ [ "_" -> { Name.Anonymous } @@ -342,7 +342,7 @@ GRAMMAR EXTEND Gram hint: [ [ IDENT "Extern"; n = natural; c = OPT Constr.constr_pattern ; "=>"; tac = Pltac.tactic -> - { ComHints.HintsExtern (n,c, in_tac tac) } ] ] + { Vernacexpr.HintsExtern (n,c, in_tac tac) } ] ] ; operconstr: LEVEL "0" [ [ IDENT "ltac"; ":"; "("; tac = Pltac.tactic_expr; ")" -> diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index 6a158bde17..e51b1f051d 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -30,9 +30,6 @@ open Pcoq let all_with delta = Redops.make_red_flag [FBeta;FMatch;FFix;FCofix;FZeta;delta] -let tactic_kw = [ "->"; "<-" ; "by" ] -let _ = List.iter CLexer.add_keyword tactic_kw - let err () = raise Stream.Failure (* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *) diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 09f1fc371a..d74e981c6d 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -1325,6 +1325,8 @@ let () = register_basic_print0 wit_int_or_var (pr_or_var int) (pr_or_var int) int; register_basic_print0 wit_ref pr_qualid (pr_or_var (pr_located pr_global)) pr_global; + register_basic_print0 wit_smart_global + (pr_or_by_notation pr_qualid) (pr_or_var (pr_located pr_global)) pr_global; register_basic_print0 wit_ident pr_id pr_id pr_id; register_basic_print0 wit_var pr_lident pr_lident pr_id; register_print0 wit_intropattern pr_raw_intro_pattern pr_glob_intro_pattern pr_intro_pattern_env [@warning "-3"]; diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 3834b21a14..4bc8d61258 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -478,7 +478,7 @@ let error_no_relation () = user_err Pp.(str "Cannot find a relation to rewrite." let rec decompose_app_rel env evd t = (* Head normalize for compatibility with the old meta mechanism *) - let t = Reductionops.whd_betaiota evd t in + let t = Reductionops.whd_betaiota env evd t in match EConstr.kind evd t with | App (f, [||]) -> assert false | App (f, [|arg|]) -> @@ -711,7 +711,7 @@ let unify_eqn (car, rel, prf, c1, c2, holes, sort) l2r flags env (sigma, cstrs) let sigma = Typeclasses.resolve_typeclasses ~filter:(no_constraints cstrs) ~fail:true env sigma in let evd = solve_remaining_by env sigma holes by in - let nf c = Reductionops.nf_evar evd (Reductionops.nf_meta evd c) in + let nf c = Reductionops.nf_evar evd (Reductionops.nf_meta env evd c) in let c1 = nf c1 and c2 = nf c2 and rew_car = nf car and rel = nf rel and prf = nf prf in @@ -971,7 +971,7 @@ let unfold_match env sigma sk app = | App (f', args) when Constant.equal (fst (destConst sigma f')) sk -> let v = Environ.constant_value_in (Global.env ()) (sk,Univ.Instance.empty)(*FIXME*) in let v = EConstr.of_constr v in - Reductionops.whd_beta sigma (mkApp (v, args)) + Reductionops.whd_beta env sigma (mkApp (v, args)) | _ -> app let is_rew_cast = function RewCast _ -> true | _ -> false @@ -1566,7 +1566,8 @@ let assert_replacing id newt tac = Proofview.tclTHEN prf (Proofview.tclFOCUS 2 2 tac) let newfail n s = - Proofview.tclZERO (Refiner.FailError (n, lazy s)) + let info = Exninfo.reify () in + Proofview.tclZERO ~info (Refiner.FailError (n, lazy s)) let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = let open Proofview.Notations in @@ -1576,8 +1577,10 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = let treat sigma res = match res with | None -> newfail 0 (str "Nothing to rewrite") - | Some None -> if progress then newfail 0 (str"Failed to progress") - else Proofview.tclUNIT () + | Some None -> + if progress + then newfail 0 (str"Failed to progress") + else Proofview.tclUNIT () | Some (Some res) -> let (undef, prf, newt) = res in let fold ev _ accu = if Evd.mem sigma ev then accu else ev :: accu in @@ -1641,7 +1644,9 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = let tactic_init_setoid () = try init_setoid (); Proofview.tclUNIT () - with e when CErrors.noncritical e -> Tacticals.New.tclFAIL 0 (str"Setoid library not loaded") + with e when CErrors.noncritical e -> + let _, info = Exninfo.capture e in + Tacticals.New.tclFAIL ~info 0 (str"Setoid library not loaded") let cl_rewrite_clause_strat progress strat clause = tactic_init_setoid () <*> @@ -1650,10 +1655,11 @@ let cl_rewrite_clause_strat progress strat clause = (cl_rewrite_clause_newtac ~progress strat clause) (fun (e, info) -> match e with | RewriteFailure e -> - tclZEROMSG (str"setoid rewrite failed: " ++ e) + tclZEROMSG ~info (str"setoid rewrite failed: " ++ e) | Refiner.FailError (n, pp) -> - tclFAIL n (str"setoid rewrite failed: " ++ Lazy.force pp) - | e -> Proofview.tclZERO ~info e)) + tclFAIL ~info n (str"setoid rewrite failed: " ++ Lazy.force pp) + | e -> + Proofview.tclZERO ~info e)) (** Setoid rewriting when called with "setoid_rewrite" *) let cl_rewrite_clause l left2right occs clause = @@ -1894,10 +1900,10 @@ let declare_projection name instance_id r = in it_mkProd_or_LetIn ccl ctx in let types = Some (it_mkProd_or_LetIn typ ctx) in - let kind, opaque, scope = Decls.(IsDefinition Definition), false, DeclareDef.Global Declare.ImportDefaultBehavior in + let kind, opaque, scope = Decls.(IsDefinition Definition), false, Declare.Global Declare.ImportDefaultBehavior in let impargs, udecl = [], UState.default_univ_decl in let _r : GlobRef.t = - DeclareDef.declare_definition ~name ~scope ~kind ~opaque ~impargs ~udecl ~poly ~types ~body sigma + Declare.declare_definition ~name ~scope ~kind ~opaque ~impargs ~udecl ~poly ~types ~body sigma in () let build_morphism_signature env sigma m = @@ -1961,10 +1967,10 @@ let add_morphism_as_parameter atts m n : unit = let env = Global.env () in let evd = Evd.from_env env in let poly = atts.polymorphic in - let kind, opaque, scope = Decls.(IsAssumption Logical), false, DeclareDef.Global Declare.ImportDefaultBehavior in + let kind, opaque, scope = Decls.(IsAssumption Logical), false, Declare.Global Declare.ImportDefaultBehavior in let impargs, udecl = [], UState.default_univ_decl in let evd, types = build_morphism_signature env evd m in - let evd, pe = DeclareDef.prepare_parameter ~poly ~udecl ~types evd in + let evd, pe = Declare.prepare_parameter ~poly ~udecl ~types evd in let cst = Declare.declare_constant ~name:instance_id ~kind (Declare.ParameterEntry pe) in let cst = GlobRef.ConstRef cst in Classes.add_instance @@ -1981,7 +1987,7 @@ let add_morphism_interactive atts m n : Lemmas.t = let poly = atts.polymorphic in let kind = Decls.(IsDefinition Instance) in let tac = make_tactic "Coq.Classes.SetoidTactics.add_morphism_tactic" in - let hook { DeclareDef.Hook.S.dref; _ } = dref |> function + let hook { Declare.Hook.S.dref; _ } = dref |> function | GlobRef.ConstRef cst -> Classes.add_instance (Classes.mk_instance (PropGlobal.proper_class env evd) Hints.empty_hint_info @@ -1989,7 +1995,7 @@ let add_morphism_interactive atts m n : Lemmas.t = declare_projection n instance_id (GlobRef.ConstRef cst) | _ -> assert false in - let hook = DeclareDef.Hook.make hook in + let hook = Declare.Hook.make hook in let info = Lemmas.Info.make ~hook ~kind () in Flags.silently (fun () -> @@ -2109,7 +2115,7 @@ let general_s_rewrite cl l2r occs (c,l) ~new_goals = (cl_rewrite_clause_newtac ~progress:true ~abs:(Some abs) ~origsigma strat cl))) (fun (e, info) -> match e with | RewriteFailure e -> - tclFAIL 0 (str"setoid rewrite failed: " ++ e) + tclFAIL ~info 0 (str"setoid rewrite failed: " ++ e) | e -> Proofview.tclZERO ~info e) end @@ -2117,8 +2123,8 @@ let _ = Hook.set Equality.general_setoid_rewrite_clause general_s_rewrite (** [setoid_]{reflexivity,symmetry,transitivity} tactics *) -let not_declared env sigma ty rel = - tclFAIL 0 +let not_declared ~info env sigma ty rel = + tclFAIL ~info 0 (str" The relation " ++ Printer.pr_econstr_env env sigma rel ++ str" is not a declared " ++ str ty ++ str" relation. Maybe you need to require the Coq.Classes.RelationClasses library") @@ -2135,7 +2141,10 @@ let setoid_proof ty fn fallback = let car = snd (List.hd (fst (Reductionops.splay_prod env sigma t))) in (try init_relation_classes () with _ -> raise Not_found); fn env sigma car rel - with e -> Proofview.tclZERO e + with e -> + (* XXX what is the right test here as to whether e can be converted ? *) + let e, info = Exninfo.capture e in + Proofview.tclZERO ~info e end begin function | e -> @@ -2145,9 +2154,10 @@ let setoid_proof ty fn fallback = | Hipattern.NoEquationFound -> begin match e with | (Not_found, _) -> - let rel, _, _ = decompose_app_rel env sigma concl in - not_declared env sigma ty rel - | (e, info) -> Proofview.tclZERO ~info e + let rel, _, _ = decompose_app_rel env sigma concl in + not_declared ~info env sigma ty rel + | (e, info) -> + Proofview.tclZERO ~info e end | e' -> Proofview.tclZERO ~info e' end diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index 04d85ed390..91d26519b8 100644 --- a/plugins/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -293,6 +293,13 @@ let coerce_to_evaluable_ref env sigma v = | VarRef var -> EvalVarRef var | ConstRef c -> EvalConstRef c | IndRef _ | ConstructRef _ -> fail () + else if has_type v (topwit wit_smart_global) then + let open GlobRef in + let r = out_gen (topwit wit_smart_global) v in + match r with + | VarRef var -> EvalVarRef var + | ConstRef c -> EvalConstRef c + | IndRef _ | ConstructRef _ -> fail () else match Value.to_constr v with | Some c when isConst sigma c -> EvalConstRef (fst (destConst sigma c)) diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index 597c3fdaac..53dc518bd3 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -14,7 +14,6 @@ open CAst open Pattern open Genredexpr open Glob_term -open Tacred open Util open Names open Libnames @@ -95,9 +94,16 @@ let intern_string_or_var = intern_or_var (fun (s : string) -> s) let intern_global_reference ist qid = if qualid_is_ident qid && find_var (qualid_basename qid) ist then ArgVar (make ?loc:qid.CAst.loc @@ qualid_basename qid) - else - try ArgArg (qid.CAst.loc,locate_global_with_alias qid) - with Not_found -> Nametab.error_global_not_found qid + else if qualid_is_ident qid && find_hyp (qualid_basename qid) ist then + let id = qualid_basename qid in + ArgArg (qid.CAst.loc, GlobRef.VarRef id) + else match locate_global_with_alias ~head:true qid with + | r -> ArgArg (qid.CAst.loc, r) + | exception Not_found -> + if not !strict_check && qualid_is_ident qid then + let id = qualid_basename qid in + ArgArg (qid.CAst.loc, GlobRef.VarRef id) + else Nametab.error_global_not_found qid let intern_ltac_variable ist qid = if qualid_is_ident qid && find_var (qualid_basename qid) ist then @@ -287,38 +293,42 @@ let intern_destruction_arg ist = function else clear,ElimOnIdent (make ?loc id) -let short_name = function - | {v=AN qid} when qualid_is_ident qid && not !strict_check -> +let short_name qid = + if qualid_is_ident qid && not !strict_check then Some (make ?loc:qid.CAst.loc @@ qualid_basename qid) - | _ -> None - -let intern_evaluable_global_reference ist qid = - try evaluable_of_global_reference ist.genv (locate_global_with_alias ~head:true qid) - with Not_found -> - if qualid_is_ident qid && not !strict_check then EvalVarRef (qualid_basename qid) - else Nametab.error_global_not_found qid + else None + +let evalref_of_globref ?loc ?short = function + | GlobRef.ConstRef cst -> ArgArg (EvalConstRef cst, short) + | GlobRef.VarRef id -> ArgArg (EvalVarRef id, short) + | r -> + let tpe = match r with + | GlobRef.IndRef _ -> "inductive" + | GlobRef.ConstructRef _ -> "constructor" + | (GlobRef.VarRef _ | GlobRef.ConstRef _) -> assert false + in + user_err ?loc (str "Cannot turn" ++ spc () ++ str tpe ++ spc () ++ + Nametab.pr_global_env Id.Set.empty r ++ spc () ++ + str "into an evaluable reference.") + +let intern_evaluable ist = function + | {v=AN qid} -> + begin match intern_global_reference ist qid with + | ArgVar _ as v -> v + | ArgArg (loc, r) -> + let short = short_name qid in + evalref_of_globref ?loc ?short r + end + | {v=ByNotation (ntn,sc);loc} -> + let check = GlobRef.(function ConstRef _ | VarRef _ -> true | _ -> false) in + let r = Notation.interp_notation_as_global_reference ?loc ~head:true check ntn sc in + evalref_of_globref ?loc r -let intern_evaluable_reference_or_by_notation ist = function - | {v=AN r} -> intern_evaluable_global_reference ist r +let intern_smart_global ist = function + | {v=AN r} -> intern_global_reference ist r | {v=ByNotation (ntn,sc);loc} -> - evaluable_of_global_reference ist.genv - (Notation.interp_notation_as_global_reference ?loc - GlobRef.(function ConstRef _ | VarRef _ -> true | _ -> false) ntn sc) - -(* Globalize a reduction expression *) -let intern_evaluable ist r = - let f ist r = - let e = intern_evaluable_reference_or_by_notation ist r in - let na = short_name r in - ArgArg (e,na) - in - match r with - | {v=AN qid} when qualid_is_ident qid && find_var (qualid_basename qid) ist -> - ArgVar (make ?loc:qid.CAst.loc @@ qualid_basename qid) - | {v=AN qid} when qualid_is_ident qid && not !strict_check && find_hyp (qualid_basename qid) ist -> - let id = qualid_basename qid in - ArgArg (EvalVarRef id, Some (make ?loc:qid.CAst.loc id)) - | _ -> f ist r + ArgArg (loc, (Notation.interp_notation_as_global_reference ?loc ~head:true + GlobRef.(function ConstRef _ | VarRef _ -> true | _ -> false) ntn sc)) let intern_unfold ist (l,qid) = (l,intern_evaluable ist qid) @@ -380,10 +390,10 @@ let intern_typed_pattern_or_ref_with_occurrences ist (l,p) = let c = Constrintern.interp_reference sign r in match DAst.get c with | GRef (r,None) -> - Inl (ArgArg (evaluable_of_global_reference ist.genv r,None)) + Inl (evalref_of_globref r) | GVar id -> - let r = evaluable_of_global_reference ist.genv (GlobRef.VarRef id) in - Inl (ArgArg (r,None)) + let r = evalref_of_globref (GlobRef.VarRef id) in + Inl r | _ -> let bound_names = Glob_ops.bound_glob_vars c in Inr (bound_names,(c,None),dummy_pat) in @@ -813,6 +823,7 @@ let intern_ltac ist tac = let () = Genintern.register_intern0 wit_int_or_var (lift intern_int_or_var); + Genintern.register_intern0 wit_smart_global (lift intern_smart_global); Genintern.register_intern0 wit_ref (lift intern_global_reference); Genintern.register_intern0 wit_pre_ident (fun ist c -> (ist,c)); Genintern.register_intern0 wit_ident intern_ident'; diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 6debc7d9b9..5abe18e00c 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -162,17 +162,27 @@ let catching_error call_trace fail (e, info) = fail located_exc end -let catch_error call_trace f x = +let update_loc ?loc (e, info) = + (e, Option.cata (Loc.add_loc info) info loc) + +let catch_error ?loc call_trace f x = try f x with e when CErrors.noncritical e -> let e = Exninfo.capture e in + let e = update_loc ?loc e in catching_error call_trace Exninfo.iraise e -let wrap_error tac k = - if is_traced () then Proofview.tclORELSE tac k else tac +let catch_error_loc ?loc tac = + Proofview.tclOR tac (fun exn -> + let (e, info) = update_loc ?loc exn in + Proofview.tclZERO ~info e) + +let wrap_error ?loc tac k = + if is_traced () then Proofview.tclORELSE tac k + else catch_error_loc ?loc tac -let catch_error_tac call_trace tac = - wrap_error +let catch_error_tac ?loc call_trace tac = + wrap_error ?loc tac (catching_error call_trace (fun (e, info) -> Proofview.tclZERO ~info e)) @@ -535,9 +545,10 @@ let interp_gen kind ist pattern_mode flags env sigma c = ltac_idents = constrvars.idents; ltac_genargs = ist.lfun; } in - let trace = push_trace (loc_of_glob_constr term,LtacConstrInterp (term,vars)) ist in + let loc = loc_of_glob_constr term in + let trace = push_trace (loc,LtacConstrInterp (term,vars)) ist in let (evd,c) = - catch_error trace (understand_ltac flags env sigma vars kind) term + catch_error ?loc trace (understand_ltac flags env sigma vars kind) term in (* spiwack: to avoid unnecessary modifications of tacinterp, as this function already use effect, I call [run] hoping it doesn't mess @@ -763,7 +774,9 @@ let interp_message_token ist = function | MsgIdent {loc;v=id} -> let v = try Some (Id.Map.find id ist.lfun) with Not_found -> None in match v with - | None -> Ftactic.lift (Tacticals.New.tclZEROMSG (Id.print id ++ str" not found.")) + | None -> Ftactic.lift ( + let info = Exninfo.reify () in + Tacticals.New.tclZEROMSG ~info (Id.print id ++ str" not found.")) | Some v -> message_of_value v let interp_message ist l = @@ -1059,7 +1072,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with let call = LtacAtomCall t in let trace = push_trace(loc,call) ist in Profile_ltac.do_profile "eval_tactic:2" trace - (catch_error_tac trace (interp_atomic ist t)) + (catch_error_tac ?loc trace (interp_atomic ist t)) | TacFun _ | TacLetIn _ | TacMatchGoal _ | TacMatch _ -> interp_tactic ist tac | TacId [] -> Proofview.tclLIFT (db_breakpoint (curr_debug ist) []) | TacId s -> @@ -1076,18 +1089,22 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with end | TacFail (g,n,s) -> let msg = interp_message ist s in - let tac l = Tacticals.New.tclFAIL (interp_int_or_var ist n) l in + let tac ~info l = Tacticals.New.tclFAIL ~info (interp_int_or_var ist n) l in let tac = match g with - | TacLocal -> fun l -> Proofview.tclINDEPENDENT (tac l) - | TacGlobal -> tac + | TacLocal -> + let info = Exninfo.reify () in + fun l -> Proofview.tclINDEPENDENT (tac ~info l) + | TacGlobal -> + let info = Exninfo.reify () in + tac ~info in Ftactic.run msg tac | TacProgress tac -> Tacticals.New.tclPROGRESS (interp_tactic ist tac) | TacShowHyps tac -> Proofview.V82.tactic begin tclSHOWHYPS (Proofview.V82.of_tactic (interp_tactic ist tac)) - end + end [@ocaml.warning "-3"] | TacAbstract (t,ido) -> let call = LtacMLCall tac in let trace = push_trace(None,call) ist in @@ -1149,7 +1166,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with ; poly ; extra = TacStore.set ist.extra f_trace trace } in val_interp ist alias.Tacenv.alias_body >>= fun v -> - Ftactic.lift (tactic_of_value ist v) + Ftactic.lift (catch_error_loc ?loc (tactic_of_value ist v)) in let tac = Ftactic.with_env interp_vars >>= fun (env, lr) -> @@ -1163,8 +1180,11 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with let len1 = List.length alias.Tacenv.alias_args in let len2 = List.length l in if len1 = len2 then tac - else Tacticals.New.tclZEROMSG (str "Arguments length mismatch: \ - expected " ++ int len1 ++ str ", found " ++ int len2) + else + let info = Exninfo.reify () in + Tacticals.New.tclZEROMSG ~info + (str "Arguments length mismatch: \ + expected " ++ int len1 ++ str ", found " ++ int len2) in Ftactic.run tac (fun () -> Proofview.tclUNIT ()) @@ -1175,7 +1195,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with let args = Ftactic.List.map_right (fun a -> interp_tacarg ist a) l in let tac args = let name _ _ = Pptactic.pr_extend (fun v -> print_top_val () v) 0 opn args in - Proofview.Trace.name_tactic name (catch_error_tac trace (tac args ist)) + Proofview.Trace.name_tactic name (catch_error_tac ?loc trace (tac args ist)) in Ftactic.run args tac @@ -1256,7 +1276,7 @@ and interp_tacarg ist arg : Val.t Ftactic.t = and interp_app loc ist fv largs : Val.t Ftactic.t = Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (_name, poly) -> let (>>=) = Ftactic.bind in - let fail = Tacticals.New.tclZEROMSG (str "Illegal tactic application.") in + let fail ~info = Tacticals.New.tclZEROMSG ~info (str "Illegal tactic application.") in if has_type fv (topwit wit_tacvalue) then match to_tacvalue fv with (* if var=[] and body has been delayed by val_interp, then body @@ -1278,7 +1298,7 @@ and interp_app loc ist fv largs : Val.t Ftactic.t = ; extra = TacStore.set ist.extra f_trace [] } in Profile_ltac.do_profile "interp_app" trace ~count_call:false - (catch_error_tac trace (val_interp ist body)) >>= fun v -> + (catch_error_tac ?loc trace (val_interp ist body)) >>= fun v -> Ftactic.return (name_vfun (push_appl appl largs) v) end begin fun (e, info) -> @@ -1302,12 +1322,18 @@ and interp_app loc ist fv largs : Val.t Ftactic.t = Ftactic.return (of_tacvalue (VFun(push_appl appl largs,trace,newlfun,lvar,body))) | (VFun(appl,trace,olfun,[],body)) -> let extra_args = List.length largs in - Tacticals.New.tclZEROMSG (str "Illegal tactic application: got " ++ - str (string_of_int extra_args) ++ - str " extra " ++ str (String.plural extra_args "argument") ++ - str ".") - | VRec(_,_) -> fail - else fail + let info = Exninfo.reify () in + Tacticals.New.tclZEROMSG ~info + (str "Illegal tactic application: got " ++ + str (string_of_int extra_args) ++ + str " extra " ++ str (String.plural extra_args "argument") ++ + str ".") + | VRec(_,_) -> + let info = Exninfo.reify () in + fail ~info + else + let info = Exninfo.reify () in + fail ~info (* Gives the tactic corresponding to the tactic value *) and tactic_of_value ist vle = @@ -1335,7 +1361,8 @@ and tactic_of_value ist vle = let givenargs = List.map (fun (arg,_) -> Names.Id.to_string arg) (Names.Id.Map.bindings vmap) in let numgiven = List.length givenargs in - Tacticals.New.tclZEROMSG + let info = Exninfo.reify () in + Tacticals.New.tclZEROMSG ~info (Pp.str tactic_nm ++ Pp.str " was not fully applied:" ++ spc() ++ (match numargs with 0 -> assert false @@ -1353,11 +1380,15 @@ and tactic_of_value ist vle = | _ -> Pp.str "arguments were provided for variables " ++ pr_enum Pp.str givenargs ++ Pp.str ".") - | VRec _ -> Tacticals.New.tclZEROMSG (str "A fully applied tactic is expected.") + | VRec _ -> + let info = Exninfo.reify () in + Tacticals.New.tclZEROMSG ~info (str "A fully applied tactic is expected.") else if has_type vle (topwit wit_tactic) then let tac = out_gen (topwit wit_tactic) vle in tactic_of_value ist tac - else Tacticals.New.tclZEROMSG (str "Expression does not evaluate to a tactic.") + else + let info = Exninfo.reify () in + Tacticals.New.tclZEROMSG ~info (str "Expression does not evaluate to a tactic.") (* Interprets the clauses of a recursive LetIn *) and interp_letrec ist llc u = @@ -1551,10 +1582,12 @@ and interp_ltac_constr ist e : EConstr.t Ftactic.t = pr_econstr_env env sigma cresult) end <*> Ftactic.return cresult - with CannotCoerceTo _ -> + with CannotCoerceTo _ as exn -> + let _, info = Exninfo.capture exn in let env = Proofview.Goal.env gl in - Tacticals.New.tclZEROMSG (str "Must evaluate to a closed term" ++ fnl() ++ - str "offending expression: " ++ fnl() ++ pr_inspect env e result) + Tacticals.New.tclZEROMSG ~info + (str "Must evaluate to a closed term" ++ fnl() ++ + str "offending expression: " ++ fnl() ++ pr_inspect env e result) end @@ -2022,6 +2055,7 @@ let interp_pre_ident ist env sigma s = let () = register_interp0 wit_int_or_var (fun ist n -> Ftactic.return (interp_int_or_var ist n)); + register_interp0 wit_smart_global (lift interp_reference); register_interp0 wit_ref (lift interp_reference); register_interp0 wit_pre_ident (lift interp_pre_ident); register_interp0 wit_ident (lift interp_ident); diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index 600c30b403..ed298b7e66 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -280,6 +280,7 @@ and subst_genarg subst (GenArg (Glbwit wit, x)) = let () = Genintern.register_subst0 wit_int_or_var (fun _ v -> v); Genintern.register_subst0 wit_ref subst_global_reference; + Genintern.register_subst0 wit_smart_global subst_global_reference; Genintern.register_subst0 wit_pre_ident (fun _ v -> v); Genintern.register_subst0 wit_ident (fun _ v -> v); Genintern.register_subst0 wit_var (fun _ v -> v); diff --git a/plugins/ltac/tactic_matching.ml b/plugins/ltac/tactic_matching.ml index 525199735d..2b43b11fe1 100644 --- a/plugins/ltac/tactic_matching.ml +++ b/plugins/ltac/tactic_matching.ml @@ -186,7 +186,9 @@ module PatternMatching (E:StaticEnvironment) = struct { stream = fun k ctx -> m.stream (fun () ctx -> y.stream k ctx) ctx } (** Failure of the pattern-matching monad: no success. *) - let fail (type a) : a m = { stream = fun _ _ -> Proofview.tclZERO matching_error } + let fail (type a) : a m = { stream = fun _ _ -> + let info = Exninfo.reify () in + Proofview.tclZERO ~info matching_error } let run (m : 'a m) = let ctx = { @@ -209,7 +211,11 @@ module PatternMatching (E:StaticEnvironment) = struct (** Declares a substitution, a context substitution and a term substitution. *) let put subst context terms : unit m = let s = { subst ; context ; terms ; lhs = () } in - { stream = fun k ctx -> match merge s ctx with None -> Proofview.tclZERO matching_error | Some s -> k () s } + { stream = fun k ctx -> match merge s ctx with + | None -> + let info = Exninfo.reify () in + Proofview.tclZERO ~info matching_error + | Some s -> k () s } (** Declares a substitution. *) let put_subst subst : unit m = put subst empty_context_subst empty_term_subst diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index ee2c87d19a..0f8d941b41 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -1897,8 +1897,6 @@ type provername = string * int option * The caching mechanism. *) -open Persistent_cache - module MakeCache (T : sig type prover_option type coeff @@ -1922,7 +1920,7 @@ struct Hash.((hash_pair T.hash_prover_option (List.fold_left hash_cstr)) 0) end - include PHashtable (E) + include Persistent_cache.PHashtable (E) let memo_opt use_cache cache_file f = let memof = memo cache_file f in diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 79d6c05e1d..3ba6365783 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -1475,7 +1475,9 @@ let coq_omega = let path = simplify_strong (new_id,new_var_num,display_var) system in if !display_action_flag then display_action display_var path; tclTHEN prelude (replay_history tactic_normalisation path) - with NO_CONTRADICTION -> tclZEROMSG (Pp.str"Omega can't solve this system") + with NO_CONTRADICTION as e -> + let _, info = Exninfo.capture e in + tclZEROMSG ~info (Pp.str"Omega can't solve this system") end end @@ -1890,7 +1892,9 @@ let destructure_goal = end) intro with Undecidable -> Tactics.elim_type (Lazy.force coq_False) - | e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e + | e when Proofview.V82.catchable_exception e -> + let e, info = Exninfo.capture e in + Proofview.tclZERO ~info e in tclTHEN goal_tac destructure_hyps in diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 633cdbd735..e7c75e029e 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -690,15 +690,13 @@ let ring_lookup (f : Value.t) lH rl t = Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in - try (* find_ring_strucure can raise an exception *) - let rl = make_args_list sigma rl t in - let evdref = ref sigma in - let e = find_ring_structure env sigma rl in - let rl = Value.of_constr (make_term_list env evdref (EConstr.of_constr e.ring_carrier) rl) in - let lH = carg (make_hyp_list env evdref lH) in - let ring = ltac_ring_structure e in - Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (Value.apply f (ring@[lH;rl])) - with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e + let rl = make_args_list sigma rl t in + let evdref = ref sigma in + let e = find_ring_structure env sigma rl in + let rl = Value.of_constr (make_term_list env evdref (EConstr.of_constr e.ring_carrier) rl) in + let lH = carg (make_hyp_list env evdref lH) in + let ring = ltac_ring_structure e in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (Value.apply f (ring@[lH;rl])) end (***********************************************************************) @@ -984,13 +982,11 @@ let field_lookup (f : Value.t) lH rl t = Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in - try - let rl = make_args_list sigma rl t in - let evdref = ref sigma in - let e = find_field_structure env sigma rl in - let rl = Value.of_constr (make_term_list env evdref (EConstr.of_constr e.field_carrier) rl) in - let lH = carg (make_hyp_list env evdref lH) in - let field = ltac_field_structure e in - Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (Value.apply f (field@[lH;rl])) - with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e + let rl = make_args_list sigma rl t in + let evdref = ref sigma in + let e = find_field_structure env sigma rl in + let rl = Value.of_constr (make_term_list env evdref (EConstr.of_constr e.field_carrier) rl) in + let lH = carg (make_hyp_list env evdref lH) in + let field = ltac_field_structure e in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (Value.apply f (field@[lH;rl])) end diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index e05c4c26dd..01e8daf82d 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -22,7 +22,7 @@ open Locusops open Ltac_plugin open Tacmach -open Refiner +open Tacticals open Libnames open Ssrmatching_plugin open Ssrmatching @@ -81,6 +81,9 @@ let nohint = false, [] type 'a tac_a = (goal * 'a) sigma -> (goal * 'a) list sigma +let project gl = gl.Evd.sigma +let re_sig it sigma = { Evd.it = it; Evd.sigma = sigma } + let push_ctx a gl = re_sig (sig_it gl, a) (project gl) let push_ctxs a gl = re_sig (List.map (fun x -> x,a) (sig_it gl)) (project gl) @@ -947,7 +950,7 @@ let saturate ?(beta=false) ?(bi_types=false) env sigma c ?(ty=Retyping.get_type_ let open EConstr in if n = 0 then let args = List.rev args in - (if beta then Reductionops.whd_beta sigma else fun x -> x) + (if beta then Reductionops.whd_beta env sigma else fun x -> x) (EConstr.mkApp (c, Array.of_list (List.map snd args))), ty, args, sigma else match kind_of_type sigma ty with | ProdType (_, src, tgt) -> @@ -1062,11 +1065,12 @@ end let introid ?(orig=ref Anonymous) name = let open Proofview.Notations in Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let g = Proofview.Goal.concl gl in match EConstr.kind sigma g with | App (hd, _) when EConstr.isLambda sigma hd -> - convert_concl_no_check (Reductionops.whd_beta sigma g) + convert_concl_no_check (Reductionops.whd_beta env sigma g) | _ -> Tacticals.New.tclIDTAC end <*> (fst_prod false (fun id -> orig := id; Tactics.intro_mustbe_force name)) diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index ab07dd5be9..29a9c65561 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -281,7 +281,7 @@ let unfoldintac occ rdx t (kt,_) = | App (f,a) when EConstr.eq_constr sigma0 f t -> EConstr.mkApp (body env f f,a) | Proj _ when same_proj sigma0 c t -> body env t c | _ -> - let c = Reductionops.whd_betaiotazeta sigma0 c in + let c = Reductionops.whd_betaiotazeta env sigma0 c in match EConstr.kind sigma0 c with | Const _ when EConstr.eq_constr sigma0 c t -> body env t t | App (f,a) when EConstr.eq_constr sigma0 f t -> EConstr.mkApp (body env f f,a) @@ -516,7 +516,7 @@ let rwprocess_rule env dir rule = let rec loop d sigma r t0 rs red = let t = if red = 1 then Tacred.hnf_constr env sigma t0 - else Reductionops.whd_betaiotazeta sigma t0 in + else Reductionops.whd_betaiotazeta env sigma t0 in ppdebug(lazy Pp.(str"rewrule="++pr_econstr_pat env sigma t)); match EConstr.kind sigma t with | Prod (_, xt, at) -> diff --git a/plugins/ssr/ssrview.ml b/plugins/ssr/ssrview.ml index 88a3e85211..ad0a31622c 100644 --- a/plugins/ssr/ssrview.ml +++ b/plugins/ssr/ssrview.ml @@ -194,9 +194,11 @@ let interp_glob ist glob = Goal.enter_one ~__LOC__ begin fun goal -> Pp.(str"interp-out: " ++ Printer.pr_econstr_env env sigma term)); tclUNIT (env,sigma,term) with e -> + (* XXX this is another catch all! *) + let e, info = Exninfo.capture e in Ssrprinters.ppdebug (lazy Pp.(str"interp-err: " ++ Printer.pr_glob_constr_env env glob)); - tclZERO e + tclZERO ~info e end (* Commits the term to the monad *) diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index adaf7c8cc1..e004613ef3 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -405,7 +405,7 @@ let evars_for_FO ~hack env sigma0 (ise0:evar_map) c0 = (* p_origin can be passed to obtain a better error message *) let mk_tpattern ?p_origin ?(hack=false) env sigma0 (ise, t) ok dir p = let k, f, a = - let f, a = Reductionops.whd_betaiota_stack ise (EConstr.of_constr p) in + let f, a = Reductionops.whd_betaiota_stack env ise (EConstr.of_constr p) in let f = EConstr.Unsafe.to_constr f in let a = List.map EConstr.Unsafe.to_constr a in match kind f with diff --git a/pretyping/cases.ml b/pretyping/cases.ml index fc64022ed4..5e3fb9dae3 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -1066,7 +1066,7 @@ let adjust_impossible_cases sigma pb pred tomatch submat = (* with .. end *) (* *) (*****************************************************************************) -let specialize_predicate newtomatchs (names,depna) arsign cs tms ccl = +let specialize_predicate env newtomatchs (names,depna) arsign cs tms ccl = (* Assume some gamma st: gamma |- PI [X,x:I(X)]. PI tms. ccl *) let nrealargs = List.length names in let l = match depna with Anonymous -> 0 | Name _ -> 1 in @@ -1091,7 +1091,7 @@ let specialize_predicate newtomatchs (names,depna) arsign cs tms ccl = (* We need _parallel_ bindings to get gamma, x1...xn |- PI tms. ccl'' *) (* Note: applying the substitution in tms is not important (is it sure?) *) let ccl'' = - whd_betaiota Evd.empty (subst_predicate (realargsi, copti) ccl' tms) in + whd_betaiota env Evd.empty (subst_predicate (realargsi, copti) ccl' tms) in (* We adjust ccl st: gamma, x'1..x'n, x1..xn, tms |- ccl'' *) let ccl''' = liftn_predicate n (n+1) ccl'' tms in (* We finally get gamma,x'1..x'n,x |- [X1;x1:I(X1)]..[Xn;xn:I(Xn)]pred'''*) @@ -1099,7 +1099,7 @@ let specialize_predicate newtomatchs (names,depna) arsign cs tms ccl = let find_predicate loc env sigma p current (IndType (indf,realargs)) dep tms = let pred = abstract_predicate env sigma indf current realargs dep tms p in - (pred, whd_betaiota sigma + (pred, whd_betaiota !!env sigma (applist (pred, realargs@[current]))) (* Take into account that a type has been discovered to be inductive, leading @@ -1255,7 +1255,7 @@ let rec generalize_problem names sigma pb = function | LocalDef ({binder_name=Anonymous},_,_) -> pb', deps | _ -> (* for better rendering *) - let d = RelDecl.map_type (fun c -> whd_betaiota sigma c) d in + let d = RelDecl.map_type (fun c -> whd_betaiota !!(pb.env) sigma c) d in let tomatch = lift_tomatch_stack 1 pb'.tomatch in let tomatch = relocate_index_tomatch sigma (i+1) 1 tomatch in { pb' with @@ -1352,7 +1352,7 @@ let build_branch ~program_mode initial current realargs deps (realnames,curname) (* Do the specialization for the predicate *) let pred = - specialize_predicate typs' (realnames,curname) arsign const_info tomatch pb.pred in + specialize_predicate !!(pb.env) typs' (realnames,curname) arsign const_info tomatch pb.pred in let currents = List.map (fun x -> Pushed (false,x)) typs' in diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 2a844402a8..f931a32bf8 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -108,7 +108,7 @@ let app_opt env sigma f t = | None -> sigma, t | Some f -> f sigma t in - sigma, whd_betaiota sigma t + sigma, whd_betaiota env sigma t let pair_of_array a = (a.(0), a.(1)) @@ -130,7 +130,7 @@ let disc_subset sigma x = exception NoSubtacCoercion let hnf env sigma c = whd_all env sigma c -let hnf_nodelta env sigma c = whd_betaiota sigma c +let hnf_nodelta env sigma c = whd_betaiota env sigma c let lift_args n sign = let rec liftrec k = function @@ -343,7 +343,7 @@ let app_coercion env sigma coercion v = | Some f -> let sigma, v' = f sigma v in let sigma, v' = Typing.solve_evars env sigma v' in - sigma, whd_betaiota sigma v' + sigma, whd_betaiota env sigma v' let coerce_itf ?loc env sigma v t c1 = let sigma, coercion = coerce ?loc env sigma t c1 in diff --git a/pretyping/coercionops.ml b/pretyping/coercionops.ml index 49401a9937..0c3eaa1da9 100644 --- a/pretyping/coercionops.ml +++ b/pretyping/coercionops.ml @@ -164,9 +164,9 @@ let coercion_exists coe = CoeTypMap.mem coe !coercion_tab (* find_class_type : evar_map -> constr -> cl_typ * universe_list * constr list *) -let find_class_type sigma t = +let find_class_type env sigma t = let open EConstr in - let t', args = Reductionops.whd_betaiotazeta_stack sigma t in + let t', args = Reductionops.whd_betaiotazeta_stack env sigma t in match EConstr.kind sigma t' with | Var id -> CL_SECVAR id, EInstance.empty, args | Const (sp,u) -> CL_CONST sp, u, args @@ -178,7 +178,7 @@ let find_class_type sigma t = | _ -> raise Not_found -let subst_cl_typ subst ct = match ct with +let subst_cl_typ env subst ct = match ct with CL_SORT | CL_FUN | CL_SECVAR _ -> ct @@ -190,7 +190,7 @@ let subst_cl_typ subst ct = match ct with if c' == c then ct else (match t with | None -> CL_CONST c' | Some t -> - pi1 (find_class_type Evd.empty (EConstr.of_constr t.Univ.univ_abstracted_value))) + pi1 (find_class_type env Evd.empty (EConstr.of_constr t.Univ.univ_abstracted_value))) | CL_IND i -> let i' = subst_ind subst i in if i' == i then ct else CL_IND i' @@ -204,12 +204,12 @@ let subst_coe_typ subst t = subst_global_reference subst t let class_of env sigma t = let (t, n1, i, u, args) = try - let (cl, u, args) = find_class_type sigma t in + let (cl, u, args) = find_class_type env sigma t in let (i, { cl_param = n1 } ) = class_info cl in (t, n1, i, u, args) with Not_found -> let t = Tacred.hnf_constr env sigma t in - let (cl, u, args) = find_class_type sigma t in + let (cl, u, args) = find_class_type env sigma t in let (i, { cl_param = n1 } ) = class_info cl in (t, n1, i, u, args) in @@ -217,7 +217,7 @@ let class_of env sigma t = let inductive_class_of ind = fst (class_info (CL_IND ind)) -let class_args_of env sigma c = pi3 (find_class_type sigma c) +let class_args_of env sigma c = pi3 (find_class_type env sigma c) let string_of_class = function | CL_FUN -> "Funclass" @@ -249,14 +249,14 @@ let lookup_path_to_sort_from_class s = let apply_on_class_of env sigma t cont = try - let (cl,u,args) = find_class_type sigma t in + let (cl,u,args) = find_class_type env sigma t in let (i, { cl_param = n1 } ) = class_info cl in if not (Int.equal (List.length args) n1) then raise Not_found; t, cont i with Not_found -> (* Is it worth to be more incremental on the delta steps? *) let t = Tacred.hnf_constr env sigma t in - let (cl, u, args) = find_class_type sigma t in + let (cl, u, args) = find_class_type env sigma t in let (i, { cl_param = n1 } ) = class_info cl in if not (Int.equal (List.length args) n1) then raise Not_found; t, cont i @@ -390,9 +390,10 @@ type coercion = { } let subst_coercion subst c = + let env = Global.env () in let coe = subst_coe_typ subst c.coercion_type in - let cls = subst_cl_typ subst c.coercion_source in - let clt = subst_cl_typ subst c.coercion_target in + let cls = subst_cl_typ env subst c.coercion_source in + let clt = subst_cl_typ env subst c.coercion_target in let clp = Option.Smart.map (subst_proj_repr subst) c.coercion_is_proj in if c.coercion_type == coe && c.coercion_source == cls && c.coercion_target == clt && c.coercion_is_proj == clp diff --git a/pretyping/coercionops.mli b/pretyping/coercionops.mli index 247ef4df75..31600dd17f 100644 --- a/pretyping/coercionops.mli +++ b/pretyping/coercionops.mli @@ -26,7 +26,7 @@ type cl_typ = (** Equality over [cl_typ] *) val cl_typ_eq : cl_typ -> cl_typ -> bool -val subst_cl_typ : substitution -> cl_typ -> cl_typ +val subst_cl_typ : env -> substitution -> cl_typ -> cl_typ (** Comparison of [cl_typ] *) val cl_typ_ord : cl_typ -> cl_typ -> int @@ -64,7 +64,7 @@ val class_info_from_index : cl_index -> cl_typ * cl_info_typ (** [find_class_type env sigma c] returns the head reference of [c], its universe instance and its arguments *) -val find_class_type : evar_map -> types -> cl_typ * EInstance.t * constr list +val find_class_type : env -> evar_map -> types -> cl_typ * EInstance.t * constr list (** raises [Not_found] if not convertible to a class *) val class_of : env -> evar_map -> types -> types * cl_index diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index f1506f5f59..36dc01e272 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -136,7 +136,7 @@ let flex_kind_of_term flags env evd c sk = | Cast _ | App _ | Case _ -> assert false let apprec_nohdbeta flags env evd c = - let (t,sk as appr) = Reductionops.whd_nored_state evd (c, []) in + let (t,sk as appr) = Reductionops.whd_nored_state env evd (c, []) in if flags.modulo_betaiota && Stack.not_purely_applicative sk then Stack.zip evd (whd_betaiota_deltazeta_for_iota_state flags.open_ts env evd appr) @@ -496,8 +496,8 @@ let rec evar_conv_x flags env evd pbty term1 term2 = let term2 = apprec_nohdbeta flags env evd term2 in let default () = evar_eqappr_x flags env evd pbty - (whd_nored_state evd (term1,Stack.empty)) - (whd_nored_state evd (term2,Stack.empty)) + (whd_nored_state env evd (term1,Stack.empty)) + (whd_nored_state env evd (term2,Stack.empty)) in begin match EConstr.kind evd term1, EConstr.kind evd term2 with | Evar ev, _ when Evd.is_undefined evd (fst ev) && not (is_frozen flags ev) -> @@ -556,7 +556,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty let env' = push_rel (RelDecl.LocalAssum (na,c)) env in let out1 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env' evd (c'1, Stack.empty) in - let out2, _ = whd_nored_state evd + let out2, _ = whd_nored_state env' evd (lift 1 (Stack.zip evd (term', sk')), Stack.append_app [|EConstr.mkRel 1|] Stack.empty), Cst_stack.empty in if onleft then evar_eqappr_x flags env' evd CONV out1 out2 diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 34684e4a34..348d7c0b2f 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -633,7 +633,7 @@ let solve_pattern_eqn env sigma l c = l c in (* Warning: we may miss some opportunity to eta-reduce more since c' is not in normal form *) - shrink_eta c' + shrink_eta env c' (*****************************************) (* Refining/solving unification problems *) @@ -1632,7 +1632,7 @@ let rec invert_definition unify flags choose imitate_defs map_constr_with_full_binders !evdref (fun d (env,k) -> push_rel d env, k+1) imitate envk t in - let rhs = whd_beta evd rhs (* heuristic *) in + let rhs = whd_beta env evd rhs (* heuristic *) in let fast rhs = let filter_ctxt = evar_filtered_context evi in let names = ref Id.Set.empty in @@ -1758,7 +1758,7 @@ let reconsider_unif_constraints unify flags evd = let solve_simple_eqn unify flags ?(choose=false) ?(imitate_defs=true) env evd (pbty,(evk1,args1 as ev1),t2) = try - let t2 = whd_betaiota evd t2 in (* includes whd_evar *) + let t2 = whd_betaiota env evd t2 in (* includes whd_evar *) let evd = evar_define unify flags ~choose ~imitate_defs env evd pbty ev1 t2 in reconsider_unif_constraints unify flags evd with diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index b5d81f762a..6132365b27 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -283,9 +283,10 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = in (match optionpos with | None -> + let env' = push_rel d env in mkLambda_name env - (n,t,process_constr (push_rel d env) (i+1) - (EConstr.Unsafe.to_constr (whd_beta Evd.empty (EConstr.of_constr (applist (lift 1 f, [(mkRel 1)]))))) + (n,t,process_constr env' (i+1) + (EConstr.Unsafe.to_constr (whd_beta env' Evd.empty (EConstr.of_constr (applist (lift 1 f, [(mkRel 1)]))))) (cprest,rest)) | Some(_,f_0) -> let nF = lift (i+1+decF) f_0 in @@ -293,7 +294,7 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = let arg = process_pos env' nF (lift 1 t) in mkLambda_name env (n,t,process_constr env' (i+1) - (EConstr.Unsafe.to_constr (whd_beta Evd.empty (EConstr.of_constr (applist (lift 1 f, [(mkRel 1); arg]))))) + (EConstr.Unsafe.to_constr (whd_beta env' Evd.empty (EConstr.of_constr (applist (lift 1 f, [(mkRel 1); arg]))))) (cprest,rest))) | (LocalDef (n,c,t) as d)::cprest, rest -> mkLetIn diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index c7110d7a91..e77c5082dd 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -614,7 +614,7 @@ let is_elim_predicate_explicitly_dependent env sigma pred indf = let set_names env sigma n brty = let open EConstr in let (ctxt,cl) = decompose_prod_n_assum sigma n brty in - EConstr.Unsafe.to_constr (Namegen.it_mkProd_or_LetIn_name env sigma cl ctxt) + Namegen.it_mkProd_or_LetIn_name env sigma cl ctxt let set_pattern_names env sigma ind brv = let (mib,mip) = Inductive.lookup_mind_specif env ind in @@ -631,11 +631,12 @@ let type_case_branches_with_names env sigma indspec p c = let nparams = mib.mind_nparams in let (params,realargs) = List.chop nparams args in let lbrty = Inductive.build_branches_type ind specif params p in + let lbrty = Array.map EConstr.of_constr lbrty in (* Build case type *) let conclty = lambda_appvect_assum (mip.mind_nrealdecls+1) p (Array.of_list (realargs@[c])) in (* Adjust names *) if is_elim_predicate_explicitly_dependent env sigma p (ind,params) then - (set_pattern_names env sigma (fst ind) (Array.map EConstr.of_constr lbrty), conclty) + (set_pattern_names env sigma (fst ind) lbrty, conclty) else (lbrty, conclty) (* Type of Case predicates *) diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index ab69629595..2bec86599e 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -194,7 +194,7 @@ val arity_of_case_predicate : env -> inductive_family -> bool -> Sorts.t -> types val type_case_branches_with_names : - env -> evar_map -> pinductive * EConstr.constr list -> constr -> constr -> types array * types + env -> evar_map -> pinductive * EConstr.constr list -> constr -> constr -> EConstr.types array * types (** Annotation for cases *) val make_case_info : env -> inductive -> Sorts.relevance -> case_style -> case_info diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index f7e3d651ff..1b6c17fcf9 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -1025,7 +1025,7 @@ struct | [], [] -> [] | _ -> assert false in aux 1 1 (List.rev nal) cs.cs_args, true in - let fsign = Context.Rel.map (whd_betaiota sigma) fsign in + let fsign = Context.Rel.map (whd_betaiota !!env sigma) fsign in let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in let fsign,env_f = push_rel_context ~hypnaming sigma fsign env in let obj ind rci p v f = @@ -1134,7 +1134,7 @@ struct let pi = lift n pred in (* liftn n 2 pred ? *) let pi = beta_applist sigma (pi, [EConstr.of_constr (build_dependent_constructor cs)]) in let cs_args = List.map (fun d -> map_rel_decl EConstr.of_constr d) cs.cs_args in - let cs_args = Context.Rel.map (whd_betaiota sigma) cs_args in + let cs_args = Context.Rel.map (whd_betaiota !!env sigma) cs_args in let csgn = List.map (set_name Anonymous) cs_args in diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index f7456ef35e..15bf9667b3 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -603,9 +603,7 @@ end (** The type of (machine) states (= lambda-bar-calculus' cuts) *) type state = constr * constr Stack.t -type contextual_reduction_function = env -> evar_map -> constr -> constr -type reduction_function = contextual_reduction_function -type local_reduction_function = evar_map -> constr -> constr +type reduction_function = env -> evar_map -> constr -> constr type e_reduction_function = env -> evar_map -> constr -> evar_map * constr type contextual_stack_reduction_function = @@ -650,16 +648,6 @@ let strong whdfun env sigma t = map_constr_with_full_binders sigma push_rel strongrec env (whdfun env sigma t) in strongrec env t -let local_strong whdfun sigma = - let rec strongrec t = EConstr.map sigma strongrec (whdfun sigma t) in - strongrec - -let rec strong_prodspine redfun sigma c = - let x = redfun sigma c in - match EConstr.kind sigma x with - | Prod (na,a,b) -> mkProd (na,a,strong_prodspine redfun sigma b) - | _ -> x - (*************************************) (*** Reduction using bindingss ***) (*************************************) @@ -1225,7 +1213,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = if tactic_mode then (Stack.best_state sigma s cst_l,Cst_stack.empty) else res (** reduction machine without global env and refold machinery *) -let local_whd_state_gen flags sigma = +let local_whd_state_gen flags _env sigma = let rec whrec (x, stack) = let c0 = EConstr.kind sigma x in let s = (EConstr.of_kind c0, stack) in @@ -1308,7 +1296,7 @@ let raw_whd_state_gen flags env = f let stack_red_of_state_red f = - let f sigma x = EConstr.decompose_app sigma (Stack.zip sigma (f sigma (x, Stack.empty))) in + let f env sigma x = EConstr.decompose_app sigma (Stack.zip sigma (f env sigma (x, Stack.empty))) in f (* Drops the Cst_stack *) @@ -1319,8 +1307,8 @@ let iterate_whd_gen refold flags env sigma s = Stack.zip sigma ~refold (hd,whd_sk) in aux s -let red_of_state_red f sigma x = - Stack.zip sigma (f sigma (x,Stack.empty)) +let red_of_state_red f env sigma x = + Stack.zip sigma (f env sigma (x,Stack.empty)) (* 0. No Reduction Functions *) @@ -1341,15 +1329,12 @@ let whd_betalet = red_of_state_red whd_betalet_state (* 2. Delta Reduction Functions *) let whd_delta_state e = raw_whd_state_gen CClosure.delta e -let whd_delta_stack env = stack_red_of_state_red (whd_delta_state env) -let whd_delta env = red_of_state_red (whd_delta_state env) - -let whd_betadeltazeta_state e = raw_whd_state_gen CClosure.betadeltazeta e -let whd_betadeltazeta_stack env = - stack_red_of_state_red (whd_betadeltazeta_state env) -let whd_betadeltazeta env = - red_of_state_red (whd_betadeltazeta_state env) +let whd_delta_stack = stack_red_of_state_red whd_delta_state +let whd_delta = red_of_state_red whd_delta_state +let whd_betadeltazeta_state = raw_whd_state_gen CClosure.betadeltazeta +let whd_betadeltazeta_stack = stack_red_of_state_red whd_betadeltazeta_state +let whd_betadeltazeta = red_of_state_red whd_betadeltazeta_state (* 3. Iota reduction Functions *) @@ -1361,21 +1346,19 @@ let whd_betaiotazeta_state = local_whd_state_gen CClosure.betaiotazeta let whd_betaiotazeta_stack = stack_red_of_state_red whd_betaiotazeta_state let whd_betaiotazeta = red_of_state_red whd_betaiotazeta_state -let whd_all_state env = raw_whd_state_gen CClosure.all env -let whd_all_stack env = - stack_red_of_state_red (whd_all_state env) -let whd_all env = - red_of_state_red (whd_all_state env) +let whd_all_state = raw_whd_state_gen CClosure.all +let whd_all_stack = stack_red_of_state_red whd_all_state +let whd_all = red_of_state_red whd_all_state -let whd_allnolet_state env = raw_whd_state_gen CClosure.allnolet env -let whd_allnolet_stack env = - stack_red_of_state_red (whd_allnolet_state env) -let whd_allnolet env = - red_of_state_red (whd_allnolet_state env) +let whd_allnolet_state = raw_whd_state_gen CClosure.allnolet +let whd_allnolet_stack = stack_red_of_state_red whd_allnolet_state +let whd_allnolet = red_of_state_red whd_allnolet_state (* 4. Ad-hoc eta reduction, does not substitute evars *) -let shrink_eta c = Stack.zip Evd.empty (local_whd_state_gen eta Evd.empty (c,Stack.empty)) +let shrink_eta env c = + let evd = Evd.from_env env in + Stack.zip evd (local_whd_state_gen eta env evd (c,Stack.empty)) (* 5. Zeta Reduction Functions *) @@ -1627,9 +1610,9 @@ let plain_instance sigma s c = empty map). *) -let instance sigma s c = +let instance env sigma s c = (* if s = [] then c else *) - local_strong whd_betaiota sigma (plain_instance sigma s c) + strong whd_betaiota env sigma (plain_instance sigma s c) (* pseudo-reduction rule: * [hnf_prod_app env s (Prod(_,B)) N --> B[N] @@ -1795,23 +1778,23 @@ let is_arity env sigma c = (*************************************) (* Metas *) -let meta_value evd mv = +let meta_value env evd mv = let rec valrec mv = match meta_opt_fvalue evd mv with | Some (b,_) -> let metas = Metamap.bind valrec b.freemetas in - instance evd metas b.rebus + instance env evd metas b.rebus | None -> mkMeta mv in valrec mv -let meta_instance sigma b = +let meta_instance env sigma b = let fm = b.freemetas in if Metaset.is_empty fm then b.rebus else - let c_sigma = Metamap.bind (fun mv -> meta_value sigma mv) fm in - instance sigma c_sigma b.rebus + let c_sigma = Metamap.bind (fun mv -> meta_value env sigma mv) fm in + instance env sigma c_sigma b.rebus -let nf_meta sigma c = +let nf_meta env sigma c = let cl = mk_freelisted c in - meta_instance sigma { cl with rebus = cl.rebus } + meta_instance env sigma { cl with rebus = cl.rebus } diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 243a2745f0..be91f688e7 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -127,9 +127,7 @@ end type state = constr * constr Stack.t -type contextual_reduction_function = env -> evar_map -> constr -> constr -type reduction_function = contextual_reduction_function -type local_reduction_function = evar_map -> constr -> constr +type reduction_function = env -> evar_map -> constr -> constr type e_reduction_function = env -> evar_map -> constr -> evar_map * constr @@ -151,8 +149,6 @@ 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 (*i val stack_reduction_of_reduction : 'a reduction_function -> 'a state_reduction_function @@ -181,30 +177,30 @@ val nf_evar : evar_map -> constr -> constr (** Lazy strategy, weak head reduction *) val whd_evar : evar_map -> constr -> constr -val whd_nored : local_reduction_function -val whd_beta : local_reduction_function -val whd_betaiota : local_reduction_function -val whd_betaiotazeta : local_reduction_function -val whd_all : contextual_reduction_function -val whd_allnolet : contextual_reduction_function -val whd_betalet : local_reduction_function +val whd_nored : reduction_function +val whd_beta : reduction_function +val whd_betaiota : reduction_function +val whd_betaiotazeta : reduction_function +val whd_all : reduction_function +val whd_allnolet : reduction_function +val whd_betalet : reduction_function (** Removes cast and put into applicative form *) -val whd_nored_stack : local_stack_reduction_function -val whd_beta_stack : local_stack_reduction_function -val whd_betaiota_stack : local_stack_reduction_function -val whd_betaiotazeta_stack : local_stack_reduction_function +val whd_nored_stack : contextual_stack_reduction_function +val whd_beta_stack : contextual_stack_reduction_function +val whd_betaiota_stack : contextual_stack_reduction_function +val whd_betaiotazeta_stack : contextual_stack_reduction_function val whd_all_stack : contextual_stack_reduction_function val whd_allnolet_stack : contextual_stack_reduction_function -val whd_betalet_stack : local_stack_reduction_function +val whd_betalet_stack : contextual_stack_reduction_function -val whd_nored_state : local_state_reduction_function -val whd_beta_state : local_state_reduction_function -val whd_betaiota_state : local_state_reduction_function -val whd_betaiotazeta_state : local_state_reduction_function +val whd_nored_state : state_reduction_function +val whd_beta_state : state_reduction_function +val whd_betaiota_state : state_reduction_function +val whd_betaiotazeta_state : state_reduction_function val whd_all_state : state_reduction_function val whd_allnolet_state : state_reduction_function -val whd_betalet_state : local_state_reduction_function +val whd_betalet_state : state_reduction_function (** {6 Head normal forms } *) @@ -214,11 +210,11 @@ val whd_delta : reduction_function val whd_betadeltazeta_stack : stack_reduction_function val whd_betadeltazeta_state : state_reduction_function val whd_betadeltazeta : reduction_function -val whd_zeta_stack : local_stack_reduction_function -val whd_zeta_state : local_state_reduction_function -val whd_zeta : local_reduction_function +val whd_zeta_stack : stack_reduction_function +val whd_zeta_state : state_reduction_function +val whd_zeta : reduction_function -val shrink_eta : constr -> constr +val shrink_eta : Environ.env -> constr -> constr (** Various reduction functions *) @@ -314,5 +310,5 @@ val whd_betaiota_deltazeta_for_iota_state : TransparentState.t -> Environ.env -> Evd.evar_map -> state -> state (** {6 Meta-related reduction functions } *) -val meta_instance : evar_map -> constr freelisted -> constr -val nf_meta : evar_map -> constr -> constr +val meta_instance : env -> evar_map -> constr freelisted -> constr +val nf_meta : env -> evar_map -> constr -> constr diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 1f091c3df8..5ec5005b3e 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -134,7 +134,7 @@ let retype ?(polyprop=true) sigma = let n = inductive_nrealdecls env (fst (fst (dest_ind_family indf))) in let t = betazetaevar_applist sigma n p realargs in (match EConstr.kind sigma (whd_all env sigma (type_of env t)) with - | Prod _ -> whd_beta sigma (applist (t, [c])) + | Prod _ -> whd_beta env sigma (applist (t, [c])) | _ -> t) | Lambda (name,c1,c2) -> mkProd (name, c1, type_of (push_rel (LocalAssum (name,c1)) env) c2) diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 2c717b8774..5b9bc91b84 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -252,7 +252,7 @@ let invert_name labs l {binder_name=na0} env sigma ref na = | None -> None | Some c -> let labs',ccl = decompose_lam sigma c in - let _, l' = whd_betalet_stack sigma ccl in + let _, l' = whd_betalet_stack env sigma ccl in let labs' = List.map snd labs' in (* ppedrot: there used to be generic equality on terms here *) let eq_constr c1 c2 = EConstr.eq_constr sigma c1 c2 in @@ -288,7 +288,7 @@ let compute_consteval_direct env sigma ref = let compute_consteval_mutual_fix env sigma ref = let rec srec env minarg labs ref c = - let c',l = whd_betalet_stack sigma c in + let c',l = whd_betalet_stack env sigma c in let nargs = List.length l in match EConstr.kind sigma c' with | Lambda (na,t,g) when List.is_empty l -> @@ -424,7 +424,7 @@ let solve_arity_problem env sigma fxminargs c = let evm = ref sigma in let set_fix i = evm := Evd.define i (mkVar vfx) !evm in let rec check strict c = - let c' = whd_betaiotazeta sigma c in + let c' = whd_betaiotazeta env sigma c in let (h,rcargs) = decompose_app_vect sigma c' in match EConstr.kind sigma h with Evar(i,_) when Evar.Map.mem i fxminargs && not (Evd.is_defined !evm i) -> @@ -725,7 +725,7 @@ let rec red_elim_const env sigma ref u largs = if evaluable_reference_eq sigma ref refgoal then (c,args) else - let c', lrest = whd_betalet_stack sigma (applist(c,args)) in + let c', lrest = whd_betalet_stack env sigma (applist(c,args)) in descend (destEvalRefU sigma c') lrest in let (_, midargs as s) = descend (ref,u) largs in let d, lrest = whd_nothing_for_iota env sigma (applist s) in @@ -736,11 +736,11 @@ let rec red_elim_const env sigma ref u largs = | Reduced (c,rest) -> (nf_beta env sigma c, rest), nocase) | NotAnElimination when unfold_nonelim -> let c = reference_value env sigma ref u in - (whd_betaiotazeta sigma (applist (c, largs)), []), nocase + (whd_betaiotazeta env sigma (applist (c, largs)), []), nocase | _ -> raise Redelimination with Redelimination when unfold_anyway -> let c = reference_value env sigma ref u in - (whd_betaiotazeta sigma (applist (c, largs)), []), nocase + (whd_betaiotazeta env sigma (applist (c, largs)), []), nocase and reduce_params env sigma stack l = let len = List.length stack in @@ -849,7 +849,7 @@ and whd_construct_stack env sigma s = let try_red_product env sigma c = let simpfun c = clos_norm_flags betaiotazeta env sigma c in let rec redrec env x = - let x = whd_betaiota sigma x in + let x = whd_betaiota env sigma x in match EConstr.kind sigma x with | App (f,l) -> (match EConstr.kind sigma f with @@ -875,7 +875,7 @@ let try_red_product env sigma c = | _ -> redrec env c in let npars = Projection.npars p in - (match reduce_projection env sigma p ~npars (whd_betaiotazeta_stack sigma c') [] with + (match reduce_projection env sigma p ~npars (whd_betaiotazeta_stack env sigma c') [] with | Reduced s -> simpfun (applist s) | NotReducible -> raise Redelimination) | _ -> diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index afd6c33821..d1b65775bd 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -179,7 +179,7 @@ let build_subclasses ~check env sigma glob { hint_priority = pri } = | None -> [] | Some (rels, ((tc,u), args)) -> let instapp = - Reductionops.whd_beta sigma (EConstr.of_constr (appvectc c (Context.Rel.to_extended_vect mkRel 0 rels))) + Reductionops.whd_beta env sigma (EConstr.of_constr (appvectc c (Context.Rel.to_extended_vect mkRel 0 rels))) in let instapp = EConstr.Unsafe.to_constr instapp in let projargs = Array.of_list (args @ [instapp]) in diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 99a35849e0..f0882d4594 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -29,11 +29,11 @@ open Context.Rel.Declaration module GR = Names.GlobRef -let meta_type evd mv = +let meta_type env evd mv = let ty = try Evd.meta_ftype evd mv with Not_found -> anomaly (str "unknown meta ?" ++ str (Nameops.string_of_meta mv) ++ str ".") in - meta_instance evd ty + meta_instance env evd ty let inductive_type_knowing_parameters env sigma (ind,u) jl = let u = Unsafe.to_instance u in @@ -175,7 +175,7 @@ let type_case_branches env sigma (ind,largs) pj c = let lc = build_branches_type ind specif params (EConstr.to_constr ~abort_on_undefined_evars:false sigma p) in let lc = Array.map EConstr.of_constr lc in let n = (snd specif).Declarations.mind_nrealdecls in - let ty = whd_betaiota sigma (lambda_applist_assum sigma (n+1) p (realargs@[c])) in + let ty = whd_betaiota env sigma (lambda_applist_assum sigma (n+1) p (realargs@[c])) in sigma, (lc, ty, Sorts.relevance_of_sort ps) let judge_of_case env sigma ci pj cj lfj = @@ -335,7 +335,7 @@ let rec execute env sigma cstr = let cstr = whd_evar sigma cstr in match EConstr.kind sigma cstr with | Meta n -> - sigma, { uj_val = cstr; uj_type = meta_type sigma n } + sigma, { uj_val = cstr; uj_type = meta_type env sigma n } | Evar ev -> let ty = EConstr.existential_type sigma ev in diff --git a/pretyping/typing.mli b/pretyping/typing.mli index 96222f7bf6..5916f0e867 100644 --- a/pretyping/typing.mli +++ b/pretyping/typing.mli @@ -35,7 +35,7 @@ val check : env -> evar_map -> constr -> types -> evar_map val type_of_variable : env -> variable -> types (** Returns the instantiated type of a metavariable *) -val meta_type : evar_map -> metavariable -> types +val meta_type : env -> evar_map -> metavariable -> types (** Solve existential variables using typing *) val solve_evars : env -> evar_map -> constr -> evar_map * constr diff --git a/pretyping/unification.ml b/pretyping/unification.ml index f5aaac315a..88eec5ea01 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -708,8 +708,8 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e let stM,stN = extract_instance_status pb in let sigma = if opt.with_types && flags.check_applied_meta_types then - let tyM = Typing.meta_type sigma k1 in - let tyN = Typing.meta_type sigma k2 in + let tyM = Typing.meta_type curenv sigma k1 in + let tyN = Typing.meta_type curenv sigma k2 in let l, r = if k2 < k1 then tyN, tyM else tyM, tyN in check_compatibility curenv CUMUL flags substn l r else sigma @@ -721,7 +721,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e let sigma = if opt.with_types && flags.check_applied_meta_types then (try - let tyM = Typing.meta_type sigma k in + let tyM = Typing.meta_type curenv sigma k in let tyN = get_type_of curenv ~lax:true sigma cN in check_compatibility curenv CUMUL flags substn tyN tyM with RetypeError _ -> @@ -742,7 +742,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e if opt.with_types && flags.check_applied_meta_types then (try let tyM = get_type_of curenv ~lax:true sigma cM in - let tyN = Typing.meta_type sigma k in + let tyN = Typing.meta_type curenv sigma k in check_compatibility curenv CUMUL flags substn tyM tyN with RetypeError _ -> (* Renounce, maybe metas/evars prevents typing *) sigma) @@ -1040,33 +1040,33 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e (match expand_key flags.modulo_delta curenv sigma cf1 with | Some c -> unirec_rec curenvnb pb opt substn - (whd_betaiotazeta sigma (mkApp(c,l1))) cN + (whd_betaiotazeta curenv sigma (mkApp(c,l1))) cN | None -> (match expand_key flags.modulo_delta curenv sigma cf2 with | Some c -> unirec_rec curenvnb pb opt substn cM - (whd_betaiotazeta sigma (mkApp(c,l2))) + (whd_betaiotazeta curenv sigma (mkApp(c,l2))) | None -> error_cannot_unify curenv sigma (cM,cN))) | Some false -> (match expand_key flags.modulo_delta curenv sigma cf2 with | Some c -> unirec_rec curenvnb pb opt substn cM - (whd_betaiotazeta sigma (mkApp(c,l2))) + (whd_betaiotazeta curenv sigma (mkApp(c,l2))) | None -> (match expand_key flags.modulo_delta curenv sigma cf1 with | Some c -> unirec_rec curenvnb pb opt substn - (whd_betaiotazeta sigma (mkApp(c,l1))) cN + (whd_betaiotazeta curenv sigma (mkApp(c,l1))) cN | None -> error_cannot_unify curenv sigma (cM,cN))) and canonical_projections (curenv, _ as curenvnb) pb opt cM cN (sigma,_,_ as substn) = let f1 () = if isApp_or_Proj sigma cM then - let f1l1 = whd_nored_state sigma (cM,Stack.empty) in + let f1l1 = whd_nored_state curenv sigma (cM,Stack.empty) in if is_open_canonical_projection curenv sigma f1l1 then - let f2l2 = whd_nored_state sigma (cN,Stack.empty) in + let f2l2 = whd_nored_state curenv sigma (cN,Stack.empty) in solve_canonical_projection curenvnb pb opt cM f1l1 cN f2l2 substn else error_cannot_unify (fst curenvnb) sigma (cM,cN) else error_cannot_unify (fst curenvnb) sigma (cM,cN) @@ -1080,9 +1080,9 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e else try f1 () with e when precatchable_exception e -> if isApp_or_Proj sigma cN then - let f2l2 = whd_nored_state sigma (cN, Stack.empty) in + let f2l2 = whd_nored_state curenv sigma (cN, Stack.empty) in if is_open_canonical_projection curenv sigma f2l2 then - let f1l1 = whd_nored_state sigma (cM, Stack.empty) in + let f1l1 = whd_nored_state curenv sigma (cM, Stack.empty) in solve_canonical_projection curenvnb pb opt cN f2l2 cM f1l1 substn else error_cannot_unify (fst curenvnb) sigma (cM,cN) else error_cannot_unify (fst curenvnb) sigma (cM,cN) @@ -1306,18 +1306,18 @@ let w_coerce_to_type env evd c cty mvty = let w_coerce env evd mv c = let cty = get_type_of env evd c in - let mvty = Typing.meta_type evd mv in + let mvty = Typing.meta_type env evd mv in w_coerce_to_type env evd c cty mvty let unify_to_type env sigma flags c status u = let sigma, c = refresh_universes (Some false) env sigma c in - let t = get_type_of env sigma (nf_meta sigma c) in - let t = nf_betaiota env sigma (nf_meta sigma t) in + let t = get_type_of env sigma (nf_meta env sigma c) in + let t = nf_betaiota env sigma (nf_meta env sigma t) in unify_0 env sigma CUMUL flags t u let unify_type env sigma flags mv status c = - let mvty = Typing.meta_type sigma mv in - let mvty = nf_meta sigma mvty in + let mvty = Typing.meta_type env sigma mv in + let mvty = nf_meta env sigma mvty in unify_to_type env sigma (set_flags_for_type flags) c status mvty @@ -1476,20 +1476,20 @@ let w_unify_meta_types env ?(flags=default_unify_flags ()) evd = [clenv_typed_unify M N clenv] expects in addition that expected types of metavars are unifiable with the types of their instances *) -let head_app sigma m = - fst (whd_nored_state sigma (m, Stack.empty)) +let head_app env sigma m = + fst (whd_nored_state env sigma (m, Stack.empty)) let isEvar_or_Meta sigma c = match EConstr.kind sigma c with | Evar _ | Meta _ -> true | _ -> false let check_types env flags (sigma,_,_ as subst) m n = - if isEvar_or_Meta sigma (head_app sigma m) then + if isEvar_or_Meta sigma (head_app env sigma m) then unify_0_with_initial_metas subst true env CUMUL flags (get_type_of env sigma n) (get_type_of env sigma m) - else if isEvar_or_Meta sigma (head_app sigma n) then + else if isEvar_or_Meta sigma (head_app env sigma n) then unify_0_with_initial_metas subst true env CUMUL flags (get_type_of env sigma m) @@ -1641,7 +1641,8 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = (fun test -> match test.testing_state with | None -> None | Some (sigma,_,l) -> - let c = applist (local_strong whd_meta sigma c, l) in + let rec strong_whd_meta t = EConstr.map sigma strong_whd_meta (whd_meta sigma t) in + let c = applist (strong_whd_meta c, l) in Some (sigma, c)) let make_eq_test env evd c = @@ -1947,7 +1948,7 @@ let secondOrderAbstraction env evd flags typ (p, oplist) = (* Remove delta when looking for a subterm *) let flags = { flags with core_unify_flags = flags.subterm_unify_flags } in let (evd',cllist) = w_unify_to_subterm_list env evd flags p oplist typ in - let typp = Typing.meta_type evd' p in + let typp = Typing.meta_type env evd' p in let evd',(pred,predtyp) = abstract_list_all env evd' typp typ cllist in match infer_conv ~pb:CUMUL env evd' predtyp typp with | None -> @@ -1958,7 +1959,7 @@ let secondOrderAbstraction env evd flags typ (p, oplist) = (evd',[p,pred,(Conv,TypeProcessed)],[]) let secondOrderDependentAbstraction env evd flags typ (p, oplist) = - let typp = Typing.meta_type evd p in + let typp = Typing.meta_type env evd p in let evd, pred = abstract_list_all_with_dependencies env evd typp typ oplist in w_merge env false flags.merge_unify_flags (evd,[p,pred,(Conv,TypeProcessed)],[]) @@ -1968,8 +1969,8 @@ let secondOrderAbstractionAlgo dep = if dep then secondOrderDependentAbstraction else secondOrderAbstraction let w_unify2 env evd flags dep cv_pb ty1 ty2 = - let c1, oplist1 = whd_nored_stack evd ty1 in - let c2, oplist2 = whd_nored_stack evd ty2 in + let c1, oplist1 = whd_nored_stack env evd ty1 in + let c2, oplist2 = whd_nored_stack env evd ty2 in match EConstr.kind evd c1, EConstr.kind evd c2 with | Meta p1, _ -> (* Find the predicate *) @@ -2000,8 +2001,8 @@ let w_unify2 env evd flags dep cv_pb ty1 ty2 = convertible and first-order otherwise. But if failed if e.g. the type of Meta(1) had meta-variables in it. *) let w_unify env evd cv_pb ?(flags=default_unify_flags ()) ty1 ty2 = - let hd1,l1 = decompose_app_vect evd (whd_nored evd ty1) in - let hd2,l2 = decompose_app_vect evd (whd_nored evd ty2) in + let hd1,l1 = decompose_app_vect evd (whd_nored env evd ty1) in + let hd2,l2 = decompose_app_vect evd (whd_nored env evd ty2) in let is_empty1 = Array.is_empty l1 in let is_empty2 = Array.is_empty l2 in match EConstr.kind evd hd1, not is_empty1, EConstr.kind evd hd2, not is_empty2 with diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 37d54a4eea..87b4255b88 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -41,11 +41,11 @@ type clausenv = { let cl_env ce = ce.env let cl_sigma ce = ce.evd -let clenv_nf_meta clenv c = nf_meta clenv.evd c -let clenv_term clenv c = meta_instance clenv.evd c -let clenv_meta_type clenv mv = Typing.meta_type clenv.evd mv -let clenv_value clenv = meta_instance clenv.evd clenv.templval -let clenv_type clenv = meta_instance clenv.evd clenv.templtyp +let clenv_nf_meta clenv c = nf_meta clenv.env clenv.evd c +let clenv_term clenv c = meta_instance clenv.env clenv.evd c +let clenv_meta_type clenv mv = Typing.meta_type clenv.env clenv.evd mv +let clenv_value clenv = meta_instance clenv.env clenv.evd clenv.templval +let clenv_type clenv = meta_instance clenv.env clenv.evd clenv.templtyp let refresh_undefined_univs clenv = match EConstr.kind clenv.evd clenv.templval.rebus with @@ -212,19 +212,19 @@ let clenv_assign mv rhs clenv = In any case, we respect the order given in A. *) -let clenv_metas_in_type_of_meta evd mv = - (mk_freelisted (meta_instance evd (meta_ftype evd mv))).freemetas +let clenv_metas_in_type_of_meta env evd mv = + (mk_freelisted (meta_instance env evd (meta_ftype evd mv))).freemetas let dependent_in_type_of_metas clenv mvs = List.fold_right - (fun mv -> Metaset.union (clenv_metas_in_type_of_meta clenv.evd mv)) + (fun mv -> Metaset.union (clenv_metas_in_type_of_meta clenv.env clenv.evd mv)) mvs Metaset.empty let dependent_closure clenv mvs = let rec aux mvs acc = Metaset.fold (fun mv deps -> - let metas_of_meta_type = clenv_metas_in_type_of_meta clenv.evd mv in + let metas_of_meta_type = clenv_metas_in_type_of_meta clenv.env clenv.evd mv in aux metas_of_meta_type (Metaset.union deps metas_of_meta_type)) mvs acc in aux mvs mvs @@ -251,7 +251,7 @@ let clenv_dependent ce = clenv_dependent_gen false ce (* Instantiate metas that create beta/iota redexes *) -let meta_reducible_instance evd b = +let meta_reducible_instance env evd b = let fm = b.freemetas in let fold mv accu = let fvalue = try meta_opt_fvalue evd mv with Not_found -> None in @@ -261,7 +261,7 @@ let meta_reducible_instance evd b = in let metas = Metaset.fold fold fm Metamap.empty in let rec irec u = - let u = whd_betaiota Evd.empty u (* FIXME *) in + let u = whd_betaiota env Evd.empty u (* FIXME *) in match EConstr.kind evd u with | Case (ci,p,c,bl) when EConstr.isMeta evd (strip_outer_cast evd c) -> let m = destMeta evd (strip_outer_cast evd c) in @@ -314,16 +314,12 @@ let clenv_unify_meta_types ?(flags=default_unify_flags ()) clenv = { clenv with evd = w_unify_meta_types ~flags:flags clenv.env clenv.evd } let clenv_unique_resolver_gen ?(flags=default_unify_flags ()) clenv concl = - if isMeta clenv.evd (fst (decompose_app_vect clenv.evd (whd_nored clenv.evd clenv.templtyp.rebus))) then + if isMeta clenv.evd (fst (decompose_app_vect clenv.evd (whd_nored clenv.env clenv.evd clenv.templtyp.rebus))) then clenv_unify CUMUL ~flags (clenv_type clenv) concl (clenv_unify_meta_types ~flags clenv) else clenv_unify CUMUL ~flags - (meta_reducible_instance clenv.evd clenv.templtyp) concl clenv - -let old_clenv_unique_resolver ?flags clenv gl = - let concl = Goal.V82.concl clenv.evd (sig_it gl) in - clenv_unique_resolver_gen ?flags clenv concl + (meta_reducible_instance clenv.env clenv.evd clenv.templtyp) concl clenv let clenv_unique_resolver ?flags clenv gl = let concl = Proofview.Goal.concl gl in @@ -535,7 +531,7 @@ let error_already_defined b = (str "Position " ++ int n ++ str" already defined.") let clenv_unify_binding_type clenv c t u = - if isMeta clenv.evd (fst (decompose_app_vect clenv.evd (whd_nored clenv.evd u))) then + if isMeta clenv.evd (fst (decompose_app_vect clenv.evd (whd_nored clenv.env clenv.evd u))) then (* Not enough information to know if some subtyping is needed *) CoerceToType, clenv, c else diff --git a/proofs/clenv.mli b/proofs/clenv.mli index 1adfdb885a..4279ab4768 100644 --- a/proofs/clenv.mli +++ b/proofs/clenv.mli @@ -63,9 +63,6 @@ val clenv_unify : ?flags:unify_flags -> conv_pb -> constr -> constr -> clausenv -> clausenv (** unifies the concl of the goal with the type of the clenv *) -val old_clenv_unique_resolver : - ?flags:unify_flags -> clausenv -> Goal.goal sigma -> clausenv - val clenv_unique_resolver : ?flags:unify_flags -> clausenv -> Proofview.Goal.t -> clausenv diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index 695e103082..007d53f911 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -13,7 +13,6 @@ open Constr open Termops open Evd open EConstr -open Refiner open Logic open Reduction open Clenv @@ -36,7 +35,7 @@ let clenv_cast_meta clenv = match EConstr.kind clenv.evd (strip_outer_cast clenv.evd u) with | Meta mv -> (try - let b = Typing.meta_type clenv.evd mv in + let b = Typing.meta_type clenv.env clenv.evd mv in assert (not (occur_meta clenv.evd b)); if occur_meta clenv.evd b then u else mkCast (mkMeta mv, DEFAULTcast, b) @@ -130,5 +129,7 @@ let unify ?(flags=fail_quick_unif_flags) m = try let evd' = w_unify env evd CONV ~flags m n in Proofview.Unsafe.tclEVARSADVANCE evd' - with e when CErrors.noncritical e -> Proofview.tclZERO e + with e when CErrors.noncritical e -> + let info = Exninfo.reify () in + Proofview.tclZERO ~info e end diff --git a/proofs/logic.ml b/proofs/logic.ml index 406e71aafc..c7a1c32e7c 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -28,16 +28,14 @@ module NamedDecl = Context.Named.Declaration type refiner_error = (* Errors raised by the refiner *) - | BadType of constr * constr * constr + | BadType of constr * constr * EConstr.t | UnresolvedBindings of Name.t list | CannotApply of constr * constr - | NotWellTyped of constr | NonLinearProof of constr | MetaInType of EConstr.constr (* Errors raised by the tactics *) | IntroNeedsProduct - | DoesNotOccurIn of constr * Id.t | NoSuchHyp of Id.t exception RefinerError of Environ.env * Evd.evar_map * refiner_error @@ -73,13 +71,11 @@ let catchable_exception = function let error_no_such_hypothesis env sigma id = raise (RefinerError (env, sigma, NoSuchHyp id)) -(* Tells if the refiner should check that the submitted rules do not - produce invalid subgoals *) -let check = ref false -let with_check = Flags.with_option check +(* The check flag tells if the refiner should check that the submitted rules do + not produce invalid subgoals *) -let check_typability env sigma c = - if !check then fst (type_of env sigma (EConstr.of_constr c)) else sigma +let check_typability ~check env sigma c = + if check then fst (type_of env sigma (EConstr.of_constr c)) else sigma (************************************************************************) (************************************************************************) @@ -316,9 +312,9 @@ let check_meta_variables env sigma c = if not (List.distinct_f Int.compare (collect_meta_variables c)) then raise (RefinerError (env, sigma, NonLinearProof c)) -let check_conv_leq_goal env sigma arg ty conclty = - if !check then - let ans = Reductionops.infer_conv env sigma (EConstr.of_constr ty) (EConstr.of_constr conclty) in +let check_conv_leq_goal ~check env sigma arg ty conclty = + if check then + let ans = Reductionops.infer_conv env sigma (EConstr.of_constr ty) conclty in match ans with | Some evm -> evm | None -> raise (RefinerError (env, sigma, BadType (arg,ty,conclty))) @@ -334,28 +330,27 @@ let meta_free_prefix sigma a = in a with Stop acc -> Array.rev_of_list acc -let goal_type_of env sigma c = - if !check then +let goal_type_of ~check env sigma c = + if check then let (sigma,t) = type_of env sigma (EConstr.of_constr c) in (sigma, EConstr.Unsafe.to_constr t) else (sigma, EConstr.Unsafe.to_constr (Retyping.get_type_of env sigma (EConstr.of_constr c))) -let rec mk_refgoals sigma goal goalacc conclty trm = - let env = Goal.V82.env sigma goal in - let hyps = Goal.V82.hyps sigma goal in +let rec mk_refgoals ~check env sigma goalacc conclty trm = + let hyps = Environ.named_context_val env in let mk_goal hyps concl = Goal.V82.mk_goal sigma hyps concl in - if (not !check) && not (occur_meta sigma (EConstr.of_constr trm)) then + if (not check) && not (occur_meta sigma (EConstr.of_constr trm)) then let t'ty = Retyping.get_type_of env sigma (EConstr.of_constr trm) in let t'ty = EConstr.Unsafe.to_constr t'ty in - let sigma = check_conv_leq_goal env sigma trm t'ty conclty in + let sigma = check_conv_leq_goal ~check env sigma trm t'ty conclty in (goalacc,t'ty,sigma,trm) else match kind trm with | Meta _ -> - let conclty = nf_betaiota env sigma (EConstr.of_constr conclty) in - if !check && occur_meta sigma conclty then + let conclty = nf_betaiota env sigma conclty in + if check && occur_meta sigma conclty then raise (RefinerError (env, sigma, MetaInType conclty)); let (gl,ev,sigma) = mk_goal hyps conclty in let ev = EConstr.Unsafe.to_constr ev in @@ -363,9 +358,9 @@ let rec mk_refgoals sigma goal goalacc conclty trm = gl::goalacc, conclty, sigma, ev | Cast (t,k, ty) -> - let sigma = check_typability env sigma ty in - let sigma = check_conv_leq_goal env sigma trm ty conclty in - let res = mk_refgoals sigma goal goalacc ty t in + let sigma = check_typability ~check env sigma ty in + let sigma = check_conv_leq_goal ~check env sigma trm ty conclty in + let res = mk_refgoals ~check env sigma goalacc (EConstr.of_constr ty) t in (* we keep the casts (in particular VMcast and NATIVEcast) except when they are annotating metas *) if isMeta t then begin @@ -388,24 +383,24 @@ let rec mk_refgoals sigma goal goalacc conclty trm = let ty = EConstr.Unsafe.to_constr ty in goalacc, ty, sigma, f else - mk_hdgoals sigma goal goalacc f + mk_hdgoals ~check env sigma goalacc f in - let ((acc'',conclty',sigma), args) = mk_arggoals sigma goal acc' hdty l in - let sigma = check_conv_leq_goal env sigma trm conclty' conclty in + let ((acc'',conclty',sigma), args) = mk_arggoals ~check env sigma acc' hdty l in + let sigma = check_conv_leq_goal ~check env sigma trm conclty' conclty in let ans = if applicand == f && args == l then trm else mkApp (applicand, args) in (acc'',conclty',sigma, ans) | Proj (p,c) -> - let (acc',cty,sigma,c') = mk_hdgoals sigma goal goalacc c in + let (acc',cty,sigma,c') = mk_hdgoals ~check env sigma goalacc c in let c = mkProj (p, c') in let ty = get_type_of env sigma (EConstr.of_constr c) in let ty = EConstr.Unsafe.to_constr ty in (acc',ty,sigma,c) | Case (ci,p,c,lf) -> - let (acc',lbrty,conclty',sigma,p',c') = mk_casegoals sigma goal goalacc p c in - let sigma = check_conv_leq_goal env sigma trm conclty' conclty in - let (acc'',sigma,rbranches) = treat_case sigma goal ci lbrty lf acc' in + let (acc',lbrty,conclty',sigma,p',c') = mk_casegoals ~check env sigma goalacc p c in + let sigma = check_conv_leq_goal ~check env sigma trm conclty' conclty in + let (acc'',sigma,rbranches) = treat_case ~check env sigma ci lbrty lf acc' in let lf' = Array.rev_of_list rbranches in let ans = if p' == p && c' == c && Array.equal (==) lf' lf then trm @@ -416,28 +411,27 @@ let rec mk_refgoals sigma goal goalacc conclty trm = | _ -> if occur_meta sigma (EConstr.of_constr trm) then anomaly (Pp.str "refiner called with a meta in non app/case subterm."); - let (sigma, t'ty) = goal_type_of env sigma trm in - let sigma = check_conv_leq_goal env sigma trm t'ty conclty in + let (sigma, t'ty) = goal_type_of ~check env sigma trm in + let sigma = check_conv_leq_goal ~check env sigma trm t'ty conclty in (goalacc,t'ty,sigma, trm) (* Same as mkREFGOALS but without knowing the type of the term. Therefore, * Metas should be casted. *) -and mk_hdgoals sigma goal goalacc trm = - let env = Goal.V82.env sigma goal in - let hyps = Goal.V82.hyps sigma goal in +and mk_hdgoals ~check env sigma goalacc trm = + let hyps = Environ.named_context_val env in let mk_goal hyps concl = Goal.V82.mk_goal sigma hyps concl in match kind trm with | Cast (c,_, ty) when isMeta c -> - let sigma = check_typability env sigma ty in + let sigma = check_typability ~check env sigma ty in let (gl,ev,sigma) = mk_goal hyps (nf_betaiota env sigma (EConstr.of_constr ty)) in let ev = EConstr.Unsafe.to_constr ev in gl::goalacc,ty,sigma,ev | Cast (t,_, ty) -> - let sigma = check_typability env sigma ty in - mk_refgoals sigma goal goalacc ty t + let sigma = check_typability ~check env sigma ty in + mk_refgoals ~check env sigma goalacc (EConstr.of_constr ty) t | App (f,l) -> let (acc',hdty,sigma,applicand) = @@ -445,15 +439,15 @@ and mk_hdgoals sigma goal goalacc trm = then let l' = meta_free_prefix sigma l in (goalacc,EConstr.Unsafe.to_constr (type_of_global_reference_knowing_parameters env sigma (EConstr.of_constr f) l'),sigma,f) - else mk_hdgoals sigma goal goalacc f + else mk_hdgoals ~check env sigma goalacc f in - let ((acc'',conclty',sigma), args) = mk_arggoals sigma goal acc' hdty l in + let ((acc'',conclty',sigma), args) = mk_arggoals ~check env sigma acc' hdty l in let ans = if applicand == f && args == l then trm else mkApp (applicand, args) in (acc'',conclty',sigma, ans) | Case (ci,p,c,lf) -> - let (acc',lbrty,conclty',sigma,p',c') = mk_casegoals sigma goal goalacc p c in - let (acc'',sigma,rbranches) = treat_case sigma goal ci lbrty lf acc' in + let (acc',lbrty,conclty',sigma,p',c') = mk_casegoals ~check env sigma goalacc p c in + let (acc'',sigma,rbranches) = treat_case ~check env sigma ci lbrty lf acc' in let lf' = Array.rev_of_list rbranches in let ans = if p' == p && c' == c && Array.equal (==) lf' lf then trm @@ -462,21 +456,21 @@ and mk_hdgoals sigma goal goalacc trm = (acc'',conclty',sigma, ans) | Proj (p,c) -> - let (acc',cty,sigma,c') = mk_hdgoals sigma goal goalacc c in + let (acc',cty,sigma,c') = mk_hdgoals ~check env sigma goalacc c in let c = mkProj (p, c') in let ty = get_type_of env sigma (EConstr.of_constr c) in let ty = EConstr.Unsafe.to_constr ty in (acc',ty,sigma,c) | _ -> - if !check && occur_meta sigma (EConstr.of_constr trm) then + if check && occur_meta sigma (EConstr.of_constr trm) then anomaly (Pp.str "refine called with a dependent meta."); - let (sigma, ty) = goal_type_of env sigma trm in + let (sigma, ty) = goal_type_of env ~check sigma trm in goalacc, ty, sigma, trm -and mk_arggoals sigma goal goalacc funty allargs = +and mk_arggoals ~check env sigma goalacc funty allargs = let foldmap (goalacc, funty, sigma) harg = - let t = whd_all (Goal.V82.env sigma goal) sigma (EConstr.of_constr funty) in + let t = whd_all env sigma (EConstr.of_constr funty) in let t = EConstr.Unsafe.to_constr t in let rec collapse t = match kind t with | LetIn (_, c1, _, b) -> collapse (subst1 c1 b) @@ -485,19 +479,17 @@ and mk_arggoals sigma goal goalacc funty allargs = let t = collapse t in match kind t with | Prod (_, c1, b) -> - let (acc, hargty, sigma, arg) = mk_refgoals sigma goal goalacc c1 harg in + let (acc, hargty, sigma, arg) = mk_refgoals ~check env sigma goalacc (EConstr.of_constr c1) harg in (acc, subst1 harg b, sigma), arg | _ -> - let env = Goal.V82.env sigma goal in raise (RefinerError (env,sigma,CannotApply (t, harg))) in Array.Smart.fold_left_map foldmap (goalacc, funty, sigma) allargs -and mk_casegoals sigma goal goalacc p c = - let env = Goal.V82.env sigma goal in - let (acc',ct,sigma,c') = mk_hdgoals sigma goal goalacc c in +and mk_casegoals ~check env sigma goalacc p c = + let (acc',ct,sigma,c') = mk_hdgoals ~check env sigma goalacc c in let ct = EConstr.of_constr ct in - let (acc'',pt,sigma,p') = mk_hdgoals sigma goal acc' p in + let (acc'',pt,sigma,p') = mk_hdgoals ~check env sigma acc' p in let ((ind, u), spec) = try Tacred.find_hnf_rectype env sigma ct with Not_found -> anomaly (Pp.str "mk_casegoals.") in @@ -505,20 +497,19 @@ and mk_casegoals sigma goal goalacc p c = let (lbrty,conclty) = type_case_branches_with_names env sigma indspec p c in (acc'',lbrty,conclty,sigma,p',c') -and treat_case sigma goal ci lbrty lf acc' = +and treat_case ~check env sigma ci lbrty lf acc' = let rec strip_outer_cast c = match kind c with | Cast (c,_,_) -> strip_outer_cast c | _ -> c in let decompose_app_vect c = match kind c with | App (f,cl) -> (f, cl) | _ -> (c,[||]) in - let env = Goal.V82.env sigma goal in Array.fold_left3 (fun (lacc,sigma,bacc) ty fi l -> if isMeta (strip_outer_cast fi) then (* Support for non-eta-let-expanded Meta as found in *) (* destruct/case with an non eta-let expanded elimination scheme *) - let (r,_,s,fi') = mk_refgoals sigma goal lacc ty fi in + let (r,_,s,fi') = mk_refgoals ~check env sigma lacc ty fi in r,s,(fi'::bacc) else (* Deal with a branch in expanded form of the form @@ -539,14 +530,14 @@ and treat_case sigma goal ci lbrty lf acc' = if isMeta head then begin assert (args = Context.Rel.to_extended_vect mkRel 0 ctx); let head' = lift (-n) head in - let (r,_,s,head'') = mk_refgoals sigma goal lacc ty head' in + let (r,_,s,head'') = mk_refgoals ~check env sigma lacc ty head' in let fi' = it_mkLambda_or_LetIn (mkApp (head'',args)) ctx in (r,s,fi'::bacc) end else (* Supposed to be meta-free *) - let sigma, t'ty = goal_type_of env sigma fi in - let sigma = check_conv_leq_goal env sigma fi t'ty ty in + let sigma, t'ty = goal_type_of ~check env sigma fi in + let sigma = check_conv_leq_goal ~check env sigma fi t'ty ty in (lacc,sigma,fi::bacc)) (acc',sigma,[]) lbrty lf ci.ci_pp_info.cstr_tags @@ -574,18 +565,18 @@ let convert_hyp ~check ~reorder env sigma d = (************************************************************************) (* Primitive tactics are handled here *) -let prim_refiner r sigma goal = - let env = Goal.V82.env sigma goal in - let cl = Goal.V82.concl sigma goal in - let cl = EConstr.Unsafe.to_constr cl in +let refiner ~check r = + let open Proofview.Notations in + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env gl in + let st = Proofview.Goal.state gl in + let cl = Proofview.Goal.concl gl in check_meta_variables env sigma r; - let (sgl,cl',sigma,oterm) = mk_refgoals sigma goal [] cl r in - let sgl = List.rev sgl in - let sigma = Goal.V82.partial_solution env sigma goal (EConstr.of_constr oterm) in - (sgl, sigma) - -let prim_refiner ~check r sigma goal = - if check then - with_check (prim_refiner r sigma) goal - else - prim_refiner r sigma goal + let (sgl,cl',sigma,oterm) = mk_refgoals ~check env sigma [] cl r in + let map gl = Proofview.goal_with_state gl st in + let sgl = List.rev_map map sgl in + let sigma = Goal.V82.partial_solution env sigma (Proofview.Goal.goal gl) (EConstr.of_constr oterm) in + Proofview.Unsafe.tclEVARS sigma <*> + Proofview.Unsafe.tclSETGOALS sgl + end diff --git a/proofs/logic.mli b/proofs/logic.mli index ef8b2731b2..9dc75000a1 100644 --- a/proofs/logic.mli +++ b/proofs/logic.mli @@ -26,23 +26,21 @@ open Evd (** The primitive refiner. *) -val prim_refiner : check:bool -> constr -> evar_map -> Goal.goal -> Goal.goal list * evar_map +val refiner : check:bool -> constr -> unit Proofview.tactic (** {6 Refiner errors. } *) type refiner_error = (*i Errors raised by the refiner i*) - | BadType of constr * constr * constr + | BadType of constr * constr * EConstr.t | UnresolvedBindings of Name.t list | CannotApply of constr * constr - | NotWellTyped of constr | NonLinearProof of constr | MetaInType of EConstr.constr (*i Errors raised by the tactics i*) | IntroNeedsProduct - | DoesNotOccurIn of constr * Id.t | NoSuchHyp of Id.t exception RefinerError of Environ.env * evar_map * refiner_error diff --git a/proofs/proof.ml b/proofs/proof.ml index 75aca7e7ff..175c487958 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -525,7 +525,10 @@ let solve ?with_end_tac gi info_lvl tac pr = | None -> tac | Some _ -> Proofview.Trace.record_info_trace tac in - let nosuchgoal = Proofview.tclZERO (SuggestNoSuchGoals (1,pr)) in + let nosuchgoal = + let info = Exninfo.reify () in + Proofview.tclZERO ~info (SuggestNoSuchGoals (1,pr)) + in let tac = let open Goal_select in match gi with | SelectAlreadyFocused -> let open Proofview.Notations in @@ -537,7 +540,8 @@ let solve ?with_end_tac gi info_lvl tac pr = Pp.(str "Expected a single focused goal but " ++ int n ++ str " goals are focused.")) in - Proofview.tclZERO e + let info = Exninfo.reify () in + Proofview.tclZERO ~info e | SelectNth i -> Proofview.tclFOCUS ~nosuchgoal i i tac | SelectList l -> Proofview.tclFOCUSLIST ~nosuchgoal l tac diff --git a/proofs/refine.ml b/proofs/refine.ml index 0bf0cd7b63..a10bbcbdd4 100644 --- a/proofs/refine.ml +++ b/proofs/refine.ml @@ -132,4 +132,7 @@ let solve_constraints = tclENV >>= fun env -> tclEVARMAP >>= fun sigma -> try let sigma = Evarconv.solve_unif_constraints_with_heuristics env sigma in Unsafe.tclEVARSADVANCE sigma - with e -> tclZERO e + with e -> + (* XXX this is absorbing anomalies? *) + let info = Exninfo.reify () in + tclZERO ~info e diff --git a/proofs/refiner.ml b/proofs/refiner.ml index 29a47c5acd..874bab277d 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -12,7 +12,6 @@ open Pp open CErrors open Util open Evd -open Logic type tactic = Proofview.V82.tac @@ -26,18 +25,7 @@ let project x = x.sigma let pf_env gls = Global.env_of_context (Goal.V82.hyps (project gls) (sig_it gls)) let pf_hyps gls = EConstr.named_context_of_val (Goal.V82.hyps (project gls) (sig_it gls)) -let refiner ~check pr goal_sigma = - let (sgl,sigma') = prim_refiner ~check pr goal_sigma.sigma goal_sigma.it in - { it = sgl; sigma = sigma'; } - -(* Profiling refiner *) -let refiner ~check = - if Flags.profile then - let refiner_key = CProfile.declare_profile "refiner" in - CProfile.profile2 refiner_key (refiner ~check) - else refiner ~check - -let refiner ~check c = Proofview.V82.tactic ~nf_evars:false (refiner ~check c) +let refiner = Logic.refiner (*********************) (* Tacticals *) diff --git a/proofs/refiner.mli b/proofs/refiner.mli index 3471f38e9e..a3cbfb5d5d 100644 --- a/proofs/refiner.mli +++ b/proofs/refiner.mli @@ -28,42 +28,53 @@ val refiner : check:bool -> Constr.t -> unit Proofview.tactic (** [tclIDTAC] is the identity tactic without message printing*) val tclIDTAC : tactic +[@@ocaml.deprecated "Use Tactical.New.tclIDTAC"] val tclIDTAC_MESSAGE : Pp.t -> tactic +[@@ocaml.deprecated] (** [tclEVARS sigma] changes the current evar map *) val tclEVARS : evar_map -> tactic +[@@ocaml.deprecated "Use Proofview.Unsafe.tclEVARS"] (** [tclTHEN tac1 tac2 gls] applies the tactic [tac1] to [gls] and applies [tac2] to every resulting subgoals *) val tclTHEN : tactic -> tactic -> tactic +[@@ocaml.deprecated "Use Tactical.New.tclTHEN"] (** [tclTHENLIST [t1;..;tn]] applies [t1] THEN [t2] ... THEN [tn]. More convenient than [tclTHEN] when [n] is large *) val tclTHENLIST : tactic list -> tactic +[@@ocaml.deprecated "Use Tactical.New.tclTHENLIST"] (** [tclMAP f [x1..xn]] builds [(f x1);(f x2);...(f xn)] *) val tclMAP : ('a -> tactic) -> 'a list -> tactic +[@@ocaml.deprecated "Use Tactical.New.tclMAP"] (** [tclTHEN_i tac1 tac2 gls] applies the tactic [tac1] to [gls] and applies [(tac2 i)] to the [i]{^ th} resulting subgoal (starting from 1) *) val tclTHEN_i : tactic -> (int -> tactic) -> tactic +[@@ocaml.deprecated "Use Tactical.New.tclTHEN_i"] (** [tclTHENLAST tac1 tac2 gls] applies the tactic [tac1] to [gls] and [tac2] to the last resulting subgoal (previously called [tclTHENL]) *) val tclTHENLAST : tactic -> tactic -> tactic +[@@ocaml.deprecated "Use Tactical.New.tclTHENLAST"] (** [tclTHENFIRST tac1 tac2 gls] applies the tactic [tac1] to [gls] and [tac2] to the first resulting subgoal *) val tclTHENFIRST : tactic -> tactic -> tactic +[@@ocaml.deprecated "Use Tactical.New.tclTHENFIRST"] (** [tclTHENS tac1 [|t1 ; ... ; tn|] gls] applies the tactic [tac1] to [gls] and applies [t1],..., [tn] to the [n] resulting subgoals. Raises an error if the number of resulting subgoals is not [n] *) val tclTHENSV : tactic -> tactic array -> tactic +[@@ocaml.deprecated "Use Tactical.New.tclTHENSV"] (** Same with a list of tactics *) val tclTHENS : tactic -> tactic list -> tactic +[@@ocaml.deprecated "Use Tactical.New.tclTHENS"] (** [tclTHENS3PARTS tac1 [|t1 ; ... ; tn|] tac2 [|t'1 ; ... ; t'm|] gls] applies the tactic [tac1] to [gls] then, applies [t1], ..., [tn] to @@ -71,15 +82,18 @@ val tclTHENS : tactic -> tactic list -> tactic subgoals and [tac2] to the rest of the subgoals in the middle. Raises an error if the number of resulting subgoals is strictly less than [n+m] *) val tclTHENS3PARTS : tactic -> tactic array -> tactic -> tactic array -> tactic +[@@ocaml.deprecated "Use Tactical.New.tclTHENS3PARTS"] (** [tclTHENSLASTn tac1 [t1 ; ... ; tn] tac2 gls] applies [t1],...,[tn] on the last [n] resulting subgoals and [tac2] on the remaining first subgoals *) val tclTHENSLASTn : tactic -> tactic -> tactic array -> tactic +[@@ocaml.deprecated "Use Tactical.New.tclTHENSLASTn"] (** [tclTHENSFIRSTn tac1 [t1 ; ... ; tn] tac2 gls] first applies [tac1], then applies [t1],...,[tn] on the first [n] resulting subgoals and [tac2] for the remaining last subgoals (previously called tclTHENST) *) val tclTHENSFIRSTn : tactic -> tactic array -> tactic -> tactic +[@@ocaml.deprecated "Use Tactical.New.tclTHENSFIRSTn"] (** A special exception for levels for the Fail tactic *) exception FailError of int * Pp.t Lazy.t @@ -89,15 +103,28 @@ exception FailError of int * Pp.t Lazy.t val catch_failerror : Exninfo.iexn -> unit val tclORELSE0 : tactic -> tactic -> tactic +[@@ocaml.deprecated "Use Tactical.New.tclORELSE0"] val tclORELSE : tactic -> tactic -> tactic +[@@ocaml.deprecated "Use Tactical.New.tclORELSE"] val tclREPEAT : tactic -> tactic +[@@ocaml.deprecated "Use Tactical.New.tclREPEAT"] val tclFIRST : tactic list -> tactic +[@@ocaml.deprecated "Use Tactical.New.tclFIRST"] val tclTRY : tactic -> tactic +[@@ocaml.deprecated "Use Tactical.New.tclTRY"] val tclTHENTRY : tactic -> tactic -> tactic +[@@ocaml.deprecated "Use Tactical.New.tclTHENTRY"] val tclCOMPLETE : tactic -> tactic +[@@ocaml.deprecated "Use Tactical.New.tclCOMPLETE"] val tclAT_LEAST_ONCE : tactic -> tactic +[@@ocaml.deprecated "Use Tactical.New.tclAT_LEAST_ONCE"] val tclFAIL : int -> Pp.t -> tactic +[@@ocaml.deprecated "Use Tactical.New.tclFAIL"] val tclFAIL_lazy : int -> Pp.t Lazy.t -> tactic +[@@ocaml.deprecated "Use Tactical.New.tclFAIL_lazy"] val tclDO : int -> tactic -> tactic +[@@ocaml.deprecated "Use Tactical.New.tclDO"] val tclPROGRESS : tactic -> tactic +[@@ocaml.deprecated "Use Tactical.New.tclPROGRESS"] val tclSHOWHYPS : tactic -> tactic +[@@ocaml.deprecated "Internal tactic. Do not use."] diff --git a/stm/stm.ml b/stm/stm.ml index 5790bfc07e..b296f8f08f 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -2576,6 +2576,21 @@ end (* }}} *) (******************************************************************************) (** STM initialization options: *) + +type option_command = OptionSet of string option | OptionUnset + +type injection_command = + | OptionInjection of (Goptions.option_name * option_command) + (** Set flags or options before the initial state is ready. *) + | RequireInjection of (string * string option * bool option) + (** Require libraries before the initial state is + ready. Parameters follow [Library], that is to say, + [lib,prefix,import_export] means require library [lib] from + optional [prefix] and [import_export] if [Some false/Some true] + is used. *) + (* -load-vernac-source interleaving is not supported yet *) + (* | LoadInjection of (string * bool) *) + type stm_init_options = { doc_type : stm_doc_type (** The STM does set some internal flags differently depending on @@ -2589,12 +2604,9 @@ type stm_init_options = (** [vo] load paths for the document. Usually extracted from -R options / _CoqProject *) - ; require_libs : (string * string option * bool option) list - (** Require [require_libs] before the initial state is - ready. Parameters follow [Library], that is to say, - [lib,prefix,import_export] means require library [lib] from - optional [prefix] and [import_export] if [Some false/Some true] - is used. *) + ; injections : injection_command list + (** Injects Require and Set/Unset commands before the initial + state is ready *) ; stm_options : AsyncOpts.stm_opt (** Low-level STM options *) @@ -2625,13 +2637,51 @@ let dirpath_of_file f = let ldir = Libnames.add_dirpath_suffix ldir0 id in ldir -let new_doc { doc_type ; ml_load_path; vo_load_path; require_libs; stm_options } = +let new_doc { doc_type ; ml_load_path; vo_load_path; injections; stm_options } = let require_file (dir, from, exp) = let mp = Libnames.qualid_of_string dir in let mfrom = Option.map Libnames.qualid_of_string from in Flags.silently (Vernacentries.vernac_require mfrom exp) [mp] in + let interp_set_option opt v old = + let open Goptions in + let err expect = + let opt = String.concat " " opt in + let got = v in (* avoid colliding with Pp.v *) + CErrors.user_err + Pp.(str "-set: " ++ str opt ++ + str" expects " ++ str expect ++ + str" but got " ++ str got) + in + match old with + | BoolValue _ -> + let v = match String.trim v with + | "true" -> true + | "false" | "" -> false + | _ -> err "a boolean" + in + BoolValue v + | IntValue _ -> + let v = String.trim v in + let v = match int_of_string_opt v with + | Some _ as v -> v + | None -> if v = "" then None else err "an int" + in + IntValue v + | StringValue _ -> StringValue v + | StringOptValue _ -> StringOptValue (Some v) in + + let set_option = let open Goptions in function + | opt, OptionUnset -> unset_option_value_gen ~locality:OptLocal opt + | opt, OptionSet None -> set_bool_option_value_gen ~locality:OptLocal opt true + | opt, OptionSet (Some v) -> set_option_value ~locality:OptLocal (interp_set_option opt) opt v in + + let handle_injection = function + | RequireInjection r -> require_file r + (* | LoadInjection l -> *) + | OptionInjection o -> set_option o in + (* Set the options from the new documents *) AsyncOpts.cur_opt := stm_options; @@ -2670,7 +2720,7 @@ let new_doc { doc_type ; ml_load_path; vo_load_path; require_libs; stm_options } end; (* Import initial libraries. *) - List.iter require_file require_libs; + List.iter handle_injection injections; (* We record the state at this point! *) State.define ~doc ~cache:true ~redefine:true (fun () -> ()) Stateid.initial; diff --git a/stm/stm.mli b/stm/stm.mli index 2c27d63b82..9780c96512 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -52,6 +52,20 @@ type stm_doc_type = | VioDoc of string (* file path *) | Interactive of interactive_top (* module path *) +type option_command = OptionSet of string option | OptionUnset + +type injection_command = + | OptionInjection of (Goptions.option_name * option_command) + (** Set flags or options before the initial state is ready. *) + | RequireInjection of (string * string option * bool option) + (** Require libraries before the initial state is + ready. Parameters follow [Library], that is to say, + [lib,prefix,import_export] means require library [lib] from + optional [prefix] and [import_export] if [Some false/Some true] + is used. *) + (* -load-vernac-source interleaving is not supported yet *) + (* | LoadInjection of (string * bool) *) + (** STM initialization options: *) type stm_init_options = { doc_type : stm_doc_type @@ -66,12 +80,9 @@ type stm_init_options = (** [vo] load paths for the document. Usually extracted from -R options / _CoqProject *) - ; require_libs : (string * string option * bool option) list - (** Require [require_libs] before the initial state is - ready. Parameters follow [Library], that is to say, - [lib,prefix,import_export] means require library [lib] from - optional [prefix] and [import_export] if [Some false/Some true] - is used. *) + ; injections : injection_command list + (** Injects Require and Set/Unset commands before the initial + state is ready *) ; stm_options : AsyncOpts.stm_opt (** Low-level STM options *) diff --git a/tactics/auto.ml b/tactics/auto.ml index 5b06088518..681c4e910f 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -137,8 +137,9 @@ let conclPattern concl pat tac = | Some pat -> try Proofview.tclUNIT (Constr_matching.matches env sigma pat concl) - with Constr_matching.PatternMatchingFailure -> - Tacticals.New.tclZEROMSG (str "pattern-matching failed") + with Constr_matching.PatternMatchingFailure as exn -> + let _, info = Exninfo.capture exn in + Tacticals.New.tclZEROMSG ~info (str "pattern-matching failed") in Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in @@ -383,7 +384,9 @@ and my_find_search_delta sigma db_list local_db secvars hdc concl = and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly;db=dbname})) = let tactic = function | Res_pf (c,cl) -> unify_resolve_gen ~poly flags (c,cl) - | ERes_pf _ -> Proofview.Goal.enter (fun gl -> Tacticals.New.tclZEROMSG (str "eres_pf")) + | ERes_pf _ -> Proofview.Goal.enter (fun gl -> + let info = Exninfo.reify () in + Tacticals.New.tclZEROMSG ~info (str "eres_pf")) | Give_exact (c, cl) -> exact poly (c, cl) | Res_pf_THEN_trivial_fail (c,cl) -> Tacticals.New.tclTHEN @@ -395,7 +398,9 @@ and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly;db= Proofview.Goal.enter begin fun gl -> if exists_evaluable_reference (Tacmach.New.pf_env gl) c then Tacticals.New.tclPROGRESS (reduce (Unfold [AllOccurrences,c]) Locusops.onConcl) - else Tacticals.New.tclFAIL 0 (str"Unbound reference") + else + let info = Exninfo.reify () in + Tacticals.New.tclFAIL ~info 0 (str"Unbound reference") end | Extern tacast -> conclPattern concl p tacast @@ -492,7 +497,10 @@ let search d n mod_delta db_list local_db = (* spiwack: the test of [n] to 0 must be done independently in each goal. Hence the [tclEXTEND] *) Proofview.tclEXTEND [] begin - if Int.equal n 0 then Tacticals.New.tclZEROMSG (str"BOUND 2") else + if Int.equal n 0 then + let info = Exninfo.reify () in + Tacticals.New.tclZEROMSG ~info (str"BOUND 2") + else Tacticals.New.tclORELSE0 (dbg_assumption d) (Tacticals.New.tclORELSE0 (intro_register d (search d n) local_db) ( Proofview.Goal.enter begin fun gl -> diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index ac83acd726..eaefa2947a 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -154,7 +154,8 @@ let gen_auto_multi_rewrite conds tac_main lbas cl = if not (Locusops.is_all_occurrences cl.concl_occs) && cl.concl_occs != NoOccurrences then - Tacticals.New.tclZEROMSG (str"The \"at\" syntax isn't available yet for the autorewrite tactic.") + let info = Exninfo.reify () in + Tacticals.New.tclZEROMSG ~info (str"The \"at\" syntax isn't available yet for the autorewrite tactic.") else let compose_tac t1 t2 = match cl.onhyps with @@ -185,7 +186,9 @@ let auto_multi_rewrite_with ?(conds=Naive) tac_main lbas cl = *) Proofview.V82.wrap_exceptions (fun () -> gen_auto_multi_rewrite conds tac_main lbas cl) | _ -> - Tacticals.New.tclZEROMSG (strbrk "autorewrite .. in .. using can only be used either with a unique hypothesis or on the conclusion.") + let info = Exninfo.reify () in + Tacticals.New.tclZEROMSG ~info + (strbrk "autorewrite .. in .. using can only be used either with a unique hypothesis or on the conclusion.") (* Functions necessary to the library object declaration *) let cache_hintrewrite (_,(rbase,lrl)) = diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index a51fc8b347..80c76bee60 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -166,7 +166,9 @@ let clenv_unique_resolver_tac with_evars ~flags clenv' = Proofview.Goal.enter begin fun gls -> let resolve = try Proofview.tclUNIT (clenv_unique_resolver ~flags clenv' gls) - with e when noncritical e -> Proofview.tclZERO e + with e when noncritical e -> + let _, info = Exninfo.capture e in + Proofview.tclZERO ~info e in resolve >>= fun clenv' -> Clenvtac.clenv_refine ~with_evars ~with_classes:false clenv' end @@ -207,12 +209,14 @@ let unify_resolve_refine poly flags gls ((c, t, ctx),n,clenv) = let unify_resolve_refine poly flags gl clenv = Proofview.tclORELSE (unify_resolve_refine poly flags gl clenv) - (fun ie -> - match fst ie with + (fun (exn,info) -> + match exn with | Evarconv.UnableToUnify _ -> - Tacticals.New.tclZEROMSG (str "Unable to unify") - | e -> - Tacticals.New.tclZEROMSG (str "Unexpected error")) + Tacticals.New.tclZEROMSG ~info (str "Unable to unify") + | e when CErrors.noncritical e -> + Tacticals.New.tclZEROMSG ~info (str "Unexpected error") + | _ -> + Exninfo.iraise (exn,info)) (** Dealing with goals of the form A -> B and hints of the form C -> A -> B. @@ -234,10 +238,13 @@ let with_prods nprods poly (c, clenv) f = if get_typeclasses_limit_intros () then Proofview.Goal.enter begin fun gl -> try match clenv_of_prods poly nprods (c, clenv) gl with - | None -> Tacticals.New.tclZEROMSG (str"Not enough premisses") + | None -> + let info = Exninfo.reify () in + Tacticals.New.tclZEROMSG ~info (str"Not enough premisses") | Some (diff, clenv') -> f gl (c, diff, clenv') with e when CErrors.noncritical e -> - Tacticals.New.tclZEROMSG (CErrors.print e) end + let e, info = Exninfo.capture e in + Tacticals.New.tclZEROMSG ~info (CErrors.print e) end else Proofview.Goal.enter begin fun gl -> if Int.equal nprods 0 then f gl (c, None, clenv) @@ -811,7 +818,9 @@ module Search = struct search_tac hints limit (succ depth) info in fun info -> - if Int.equal depth (succ limit) then Proofview.tclZERO ReachedLimitEx + if Int.equal depth (succ limit) then + let info = Exninfo.reify () in + Proofview.tclZERO ~info ReachedLimitEx else Proofview.tclOR (hints_tac hints info kont) (fun e -> Proofview.tclOR (intro info kont) @@ -860,9 +869,13 @@ module Search = struct let fix_iterative_limit limit t = let open Proofview in let rec aux depth = - if Int.equal depth (succ limit) then tclZERO ReachedLimitEx - else tclOR (t depth) (function (ReachedLimitEx, _) -> aux (succ depth) - | (e,ie) -> Proofview.tclZERO ~info:ie e) + if Int.equal depth (succ limit) + then + let info = Exninfo.reify () in + tclZERO ~info ReachedLimitEx + else tclOR (t depth) (function + | (ReachedLimitEx, _) -> aux (succ depth) + | (e,ie) -> Proofview.tclZERO ~info:ie e) in aux 1 let eauto_tac_stuck mst ?(unique=false) @@ -884,18 +897,18 @@ module Search = struct | None -> fix_iterative search | Some l -> fix_iterative_limit l search in - let error (e, ie) = + let error (e, info) = match e with | ReachedLimitEx -> - Tacticals.New.tclFAIL 0 (str"Proof search reached its limit") + Tacticals.New.tclFAIL ~info 0 (str"Proof search reached its limit") | NoApplicableEx -> - Tacticals.New.tclFAIL 0 (str"Proof search failed" ++ + Tacticals.New.tclFAIL ~info 0 (str"Proof search failed" ++ (if Option.is_empty depth then mt() else str" without reaching its limit")) | Proofview.MoreThanOneSuccess -> - Tacticals.New.tclFAIL 0 (str"Proof search failed: " ++ - str"more than one success found") - | e -> Proofview.tclZERO ~info:ie e + Tacticals.New.tclFAIL ~info 0 (str"Proof search failed: " ++ + str"more than one success found") + | e -> Proofview.tclZERO ~info e in let tac = Proofview.tclOR tac error in let tac = diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index d6be714dd9..8ad3d072ec 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -49,7 +49,9 @@ let absurd c = absurd c (** [f] does not assume its argument to be [nf_evar]-ed. *) let filter_hyp f tac = let rec seek = function - | [] -> Proofview.tclZERO Not_found + | [] -> + let info = Exninfo.reify () in + Proofview.tclZERO ~info Not_found | d::rest when f (NamedDecl.get_type d) -> tac (NamedDecl.get_id d) | _::rest -> seek rest in Proofview.Goal.enter begin fun gl -> @@ -62,7 +64,9 @@ let contradiction_context = let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let rec seek_neg l = match l with - | [] -> Tacticals.New.tclZEROMSG (Pp.str"No such contradiction") + | [] -> + let info = Exninfo.reify () in + Tacticals.New.tclZEROMSG ~info (Pp.str"No such contradiction") | d :: rest -> let id = NamedDecl.get_id d in let typ = nf_evar sigma (NamedDecl.get_type d) in @@ -83,7 +87,8 @@ let contradiction_context = (* Checking on the fly that it type-checks *) simplest_elim (mkApp (mkVar id,[|p|])) | None -> - Tacticals.New.tclZEROMSG (Pp.str"Not a negated unit type.")) + let info = Exninfo.reify () in + Tacticals.New.tclZEROMSG ~info (Pp.str"Not a negated unit type.")) (Proofview.tclORELSE (Proofview.Goal.enter begin fun gl -> let is_conv_leq = Tacmach.New.pf_apply is_conv_leq gl in @@ -123,10 +128,12 @@ let contradiction_term (c,lbind as cl) = filter_hyp (fun c -> is_negation_of env sigma typ c) (fun id -> simplest_elim (mkApp (mkVar id,[|c|]))) else - Proofview.tclZERO Not_found + let info = Exninfo.reify () in + Proofview.tclZERO ~info Not_found end begin function (e, info) -> match e with - | Not_found -> Tacticals.New.tclZEROMSG (Pp.str"Not a contradiction.") + | Not_found -> + Tacticals.New.tclZEROMSG ~info (Pp.str"Not a contradiction.") | e -> Proofview.tclZERO ~info e end end diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 28b5ed5811..710e0a6808 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -485,7 +485,7 @@ let unfold_head env sigma (ids, csts) c = true, EConstr.of_constr (Environ.constant_value_in env (cst, u)) | App (f, args) -> (match aux f with - | true, f' -> true, Reductionops.whd_betaiota sigma (mkApp (f', args)) + | true, f' -> true, Reductionops.whd_betaiota env sigma (mkApp (f', args)) | false, _ -> let done_, args' = Array.fold_left_i (fun i (done_, acc) arg -> @@ -526,5 +526,7 @@ let autounfold_one db cl = match cl with | Some hyp -> change_in_hyp ~check:true None (make_change_arg c') hyp | None -> convert_concl ~check:false c' DEFAULTcast - else Tacticals.New.tclFAIL 0 (str "Nothing to unfold") + else + let info = Exninfo.reify () in + Tacticals.New.tclFAIL ~info 0 (str "Nothing to unfold") end diff --git a/tactics/elim.ml b/tactics/elim.ml index 5d8698916f..415c980c2a 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -160,7 +160,8 @@ let double_ind h1 h2 = let abs = if abs_i < abs_j then Proofview.tclUNIT (abs_i,abs_j) else if abs_i > abs_j then Proofview.tclUNIT (abs_j,abs_i) else - tclZEROMSG (Pp.str "Both hypotheses are the same.") in + let info = Exninfo.reify () in + tclZEROMSG ~info (Pp.str "Both hypotheses are the same.") in abs >>= fun (abs_i,abs_j) -> (tclTHEN (tclDO abs_i intro) (onLastHypId diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index 6fbd29def9..57d793b2a5 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -182,7 +182,9 @@ let match_eqdec env sigma c = let neq = mkApp (noteq,[|mkApp (eq2,[|t;x;y|])|]) in if eqonleft then mkApp (op,[|eq;neq|]) else mkApp (op,[|neq;eq|]) in Proofview.tclUNIT (eqonleft,mk,c1,c2,ty) - with PatternMatchingFailure -> Proofview.tclZERO PatternMatchingFailure + with PatternMatchingFailure as exn -> + let _, info = Exninfo.capture exn in + Proofview.tclZERO ~info PatternMatchingFailure (* /spiwack *) diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index 7c702eab3a..6da2248cc3 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -653,7 +653,7 @@ let fix_r2l_forward_rew_scheme (c, ctx') = (mkLambda_or_LetIn (RelDecl.map_constr (liftn (-1) 1) p) (mkLambda_or_LetIn (RelDecl.map_constr (liftn (-1) 2) hp) (mkLambda_or_LetIn (RelDecl.map_constr (lift 2) ind) - (EConstr.Unsafe.to_constr (Reductionops.whd_beta sigma + (EConstr.Unsafe.to_constr (Reductionops.whd_beta env sigma (EConstr.of_constr (applist (c, Context.Rel.to_extended_list mkRel 3 indargs @ [mkRel 1;mkRel 3;mkRel 2])))))))) in c', ctx' diff --git a/tactics/equality.ml b/tactics/equality.ml index e1d34af13e..79b6dfe920 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -280,8 +280,9 @@ let general_elim_clause with_evars frzevars cls rew elim = end begin function (e, info) -> match e with | PretypeError (env, evd, NoOccurrenceFound (c', _)) -> - Proofview.tclZERO (PretypeError (env, evd, NoOccurrenceFound (c', cls))) - | e -> Proofview.tclZERO ~info e + Proofview.tclZERO ~info (PretypeError (env, evd, NoOccurrenceFound (c', cls))) + | e -> + Proofview.tclZERO ~info e end let general_elim_clause with_evars frzevars tac cls c t l l2r elim = @@ -423,7 +424,8 @@ let type_of_clause cls gl = match cls with let leibniz_rewrite_ebindings_clause cls lft2rgt tac c t l with_evars frzevars dep_proof_ok hdcncl = Proofview.Goal.enter begin fun gl -> let evd = Proofview.Goal.sigma gl in - let isatomic = isProd evd (whd_zeta evd hdcncl) in + let env = Proofview.Goal.env gl in + let isatomic = isProd evd (whd_zeta env evd hdcncl) in let dep_fun = if isatomic then dependent else dependent_no_evar in let type_of_cls = type_of_clause cls gl in let dep = dep_proof_ok && dep_fun evd c type_of_cls in @@ -458,7 +460,7 @@ let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let ctype = get_type_of env sigma c in - let rels, t = decompose_prod_assum sigma (whd_betaiotazeta sigma ctype) in + let rels, t = decompose_prod_assum sigma (whd_betaiotazeta env sigma ctype) in match match_with_equality_type env sigma t with | Some (hdcncl,args) -> (* Fast path: direct leibniz-like rewrite *) let lft2rgt = adjust_rewriting_direction args lft2rgt in @@ -475,7 +477,7 @@ let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac Proofview.tclEVARMAP >>= fun sigma -> let env' = push_rel_context rels env in let rels',t' = splay_prod_assum env' sigma t in (* Search for underlying eq *) - match match_with_equality_type env sigma t' with + match match_with_equality_type env' sigma t' with | Some (hdcncl,args) -> let lft2rgt = adjust_rewriting_direction args lft2rgt in leibniz_rewrite_ebindings_clause cls lft2rgt tac c @@ -1035,7 +1037,9 @@ let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn = Proofview.tclUNIT (build_discriminator e_env sigma true_0 (false_0,false_ty) dirn (mkVar e) cpath) with - UserError _ as ex -> Proofview.tclZERO ex + UserError _ as ex -> + let _, info = Exninfo.capture ex in + Proofview.tclZERO ~info ex in discriminator >>= fun discriminator -> discrimination_pf e (t,t1,t2) discriminator lbeq false_kind >>= fun pf -> @@ -1051,9 +1055,10 @@ let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause = let env = Proofview.Goal.env gl in match find_positions env sigma ~keep_proofs:false ~no_discr:false t1 t2 with | Inr _ -> - tclZEROMSG (str"Not a discriminable equality.") + let info = Exninfo.reify () in + tclZEROMSG ~info (str"Not a discriminable equality.") | Inl (cpath, (_,dirn), _) -> - discr_positions env sigma u eq_clause cpath dirn + discr_positions env sigma u eq_clause cpath dirn end let onEquality with_evars tac (c,lbindc) = @@ -1082,7 +1087,8 @@ let onNegatedEquality with_evars tac = (onLastHypId (fun id -> onEquality with_evars tac (mkVar id,NoBindings))) | _ -> - tclZEROMSG (str "Not a negated primitive equality.") + let info = Exninfo.reify () in + tclZEROMSG ~info (str "Not a negated primitive equality.") end let discrSimpleClause with_evars = function @@ -1214,7 +1220,7 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = with Evarconv.UnableToUnify _ -> user_err Pp.(str "Cannot solve a unification problem.") else - let (a,p_i_minus_1) = match whd_beta_stack sigma p_i with + let (a,p_i_minus_1) = match whd_beta_stack env sigma p_i with | (_sigS,[a;p]) -> (a, p) | _ -> anomaly ~label:"sig_clausal_form" (Pp.str "should be a sigma type.") in let sigma, ev = Evarutil.new_evar env sigma a in @@ -1624,10 +1630,11 @@ let cutSubstInHyp l2r eqn id = let try_rewrite tac = Proofview.tclORELSE tac begin function (e, info) -> match e with | Constr_matching.PatternMatchingFailure -> - tclZEROMSG (str "Not a primitive equality here.") + tclZEROMSG ~info (str "Not a primitive equality here.") | e -> - tclZEROMSG - (strbrk "Cannot find a well-typed generalization of the goal that makes the proof progress.") + (* XXX: absorbing anomalies?? *) + tclZEROMSG ~info + (strbrk "Cannot find a well-typed generalization of the goal that makes the proof progress.") end let cutSubstClause l2r eqn cls = @@ -1707,12 +1714,42 @@ let is_eq_x gl x d = with Constr_matching.PatternMatchingFailure -> () +exception FoundDepInGlobal of Id.t option * GlobRef.t + +let test_non_indirectly_dependent_section_variable gl x = + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let hyps = Proofview.Goal.hyps gl in + let concl = Proofview.Goal.concl gl in + List.iter (fun decl -> + NamedDecl.iter_constr (fun c -> + match occur_var_indirectly env sigma x c with + | Some gr -> raise (FoundDepInGlobal (Some (NamedDecl.get_id decl), gr)) + | None -> ()) decl) hyps; + match occur_var_indirectly env sigma x concl with + | Some gr -> raise (FoundDepInGlobal (None, gr)) + | None -> () + +let check_non_indirectly_dependent_section_variable gl x = + try test_non_indirectly_dependent_section_variable gl x + with FoundDepInGlobal (pos,gr) -> + let where = match pos with + | Some id -> str "hypothesis " ++ Id.print id + | None -> str "the conclusion of the goal" in + user_err ~hdr:"Subst" + (strbrk "Section variable " ++ Id.print x ++ + strbrk " occurs implicitly in global declaration " ++ Printer.pr_global gr ++ + strbrk " present in " ++ where ++ strbrk ".") + +let is_non_indirectly_dependent_section_variable gl z = + try test_non_indirectly_dependent_section_variable gl z; true + with FoundDepInGlobal (pos,gr) -> false + (* Rewrite "hyp:x=rhs" or "hyp:rhs=x" (if dir=false) everywhere and erase hyp and x; proceed by generalizing all dep hyps *) let subst_one dep_proof_ok x (hyp,rhs,dir) = Proofview.Goal.enter begin fun gl -> - let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let hyps = Proofview.Goal.hyps gl in let concl = Proofview.Goal.concl gl in @@ -1721,7 +1758,7 @@ let subst_one dep_proof_ok x (hyp,rhs,dir) = List.rev (pi3 (List.fold_right (fun dcl (dest,deps,allhyps) -> let id = NamedDecl.get_id dcl in if not (Id.equal id hyp) - && List.exists (fun y -> occur_var_in_decl env sigma y dcl) deps + && List.exists (fun y -> local_occur_var_in_decl sigma y dcl) deps then let id_dest = if !regular_subst_tactic then dest else MoveLast in (dest,id::deps,(id_dest,id)::allhyps) @@ -1730,7 +1767,7 @@ let subst_one dep_proof_ok x (hyp,rhs,dir) = hyps (MoveBefore x,[x],[]))) in (* In practice, no dep hyps before x, so MoveBefore x is good enough *) (* Decides if x appears in conclusion *) - let depconcl = occur_var env sigma x concl in + let depconcl = local_occur_var sigma x concl in let need_rewrite = not (List.is_empty dephyps) || depconcl in tclTHENLIST ((if need_rewrite then @@ -1761,6 +1798,8 @@ let subst_one_var dep_proof_ok x = (str "Cannot find any non-recursive equality over " ++ Id.print x ++ str".") with FoundHyp res -> res in + if is_section_variable x then + check_non_indirectly_dependent_section_variable gl x; subst_one dep_proof_ok x res end @@ -1794,53 +1833,37 @@ let subst_all ?(flags=default_subst_tactic_flags) () = if !regular_subst_tactic then - (* First step: find hypotheses to treat in linear time *) - let find_equations gl = - let env = Proofview.Goal.env gl in - let sigma = project gl in - let find_eq_data_decompose = pf_apply find_eq_data_decompose gl in - let select_equation_name decl = + (* Find hypotheses to treat in linear time *) + let process hyp = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let c = pf_get_hyp hyp gl |> NamedDecl.get_type in try - let lbeq,u,(_,x,y) = find_eq_data_decompose (NamedDecl.get_type decl) in + let lbeq,u,(_,x,y) = pf_apply find_eq_data_decompose gl c in let u = EInstance.kind sigma u in let eq = Constr.mkRef (lbeq.eq,u) in if flags.only_leibniz then restrict_to_eq_and_identity eq; match EConstr.kind sigma x, EConstr.kind sigma y with - | Var z, _ when not (is_evaluable env (EvalVarRef z)) -> - Some (NamedDecl.get_id decl) - | _, Var z when not (is_evaluable env (EvalVarRef z)) -> - Some (NamedDecl.get_id decl) + | Var x, Var y when Id.equal x y -> + Proofview.tclUNIT () + | Var x', _ when not (Termops.local_occur_var sigma x' y) && + not (is_evaluable env (EvalVarRef x')) && + is_non_indirectly_dependent_section_variable gl x' -> + subst_one flags.rewrite_dependent_proof x' (hyp,y,true) + | _, Var y' when not (Termops.local_occur_var sigma y' x) && + not (is_evaluable env (EvalVarRef y')) && + is_non_indirectly_dependent_section_variable gl y' -> + subst_one flags.rewrite_dependent_proof y' (hyp,x,false) | _ -> - None - with Constr_matching.PatternMatchingFailure -> None + Proofview.tclUNIT () + with Constr_matching.PatternMatchingFailure -> + Proofview.tclUNIT () + end in - let hyps = Proofview.Goal.hyps gl in - List.rev (List.map_filter select_equation_name hyps) - in - - (* Second step: treat equations *) - let process hyp = Proofview.Goal.enter begin fun gl -> - let sigma = project gl in - let env = Proofview.Goal.env gl in - let find_eq_data_decompose = pf_apply find_eq_data_decompose gl in - let c = pf_get_hyp hyp gl |> NamedDecl.get_type in - let _,_,(_,x,y) = find_eq_data_decompose c in - (* J.F.: added to prevent failure on goal containing x=x as an hyp *) - if EConstr.eq_constr sigma x y then Proofview.tclUNIT () else - match EConstr.kind sigma x, EConstr.kind sigma y with - | Var x', _ when not (Termops.local_occur_var sigma x' y) && not (is_evaluable env (EvalVarRef x')) -> - subst_one flags.rewrite_dependent_proof x' (hyp,y,true) - | _, Var y' when not (Termops.local_occur_var sigma y' x) && not (is_evaluable env (EvalVarRef y')) -> - subst_one flags.rewrite_dependent_proof y' (hyp,x,false) - | _ -> - Proofview.tclUNIT () + tclMAP process (List.rev (List.map NamedDecl.get_id (Proofview.Goal.hyps gl))) end - in - Proofview.Goal.enter begin fun gl -> - let ids = find_equations gl in - tclMAP process ids - end else diff --git a/tactics/hints.ml b/tactics/hints.ml index 5fb519cc4f..a0670ef70d 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -1570,6 +1570,8 @@ let run_hint tac k = match warn_hint () with else Proofview.tclTHEN (log_hint tac) (k tac.obj) | HintStrict -> if is_imported tac then k tac.obj - else Proofview.tclZERO (UserError (None, (str "Tactic failure."))) + else + let info = Exninfo.reify () in + Proofview.tclZERO ~info (UserError (None, (str "Tactic failure."))) let repr_hint h = h.obj diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index 76b1c94759..5338e0eef5 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -88,9 +88,9 @@ let is_lax_conjunction = function let prod_assum sigma t = fst (decompose_prod_assum sigma t) (* whd_beta normalize the types of arguments in a product *) -let rec whd_beta_prod sigma c = match EConstr.kind sigma c with - | Prod (n,t,c) -> mkProd (n,Reductionops.whd_beta sigma t,whd_beta_prod sigma c) - | LetIn (n,d,t,c) -> mkLetIn (n,d,t,whd_beta_prod sigma c) +let rec whd_beta_prod env sigma c = match EConstr.kind sigma c with + | Prod (n,t,c) -> mkProd (n,Reductionops.whd_beta env sigma t,whd_beta_prod env sigma c) + | LetIn (n,d,t,c) -> mkLetIn (n,d,t,whd_beta_prod env sigma c) | _ -> c let match_with_one_constructor env sigma style onlybinary allow_rec t = @@ -119,7 +119,7 @@ let match_with_one_constructor env sigma style onlybinary allow_rec t = else let ctx, cty = mip.mind_nf_lc.(0) in let cty = EConstr.of_constr (Term.it_mkProd_or_LetIn cty ctx) in - let ctyp = whd_beta_prod sigma + let ctyp = whd_beta_prod env sigma (Termops.prod_applist_assum sigma (Context.Rel.length mib.mind_params_ctxt) cty args) in let cargs = List.map RelDecl.get_type (prod_assum sigma ctyp) in if not (is_lax_conjunction style) || has_nodep_prod env sigma ctyp then diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 07f9def2c8..a4d306c497 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -29,6 +29,8 @@ module NamedDecl = Context.Named.Declaration type tactic = Proofview.V82.tac +[@@@ocaml.warning "-3"] + let tclIDTAC = Refiner.tclIDTAC let tclIDTAC_MESSAGE = Refiner.tclIDTAC_MESSAGE let tclORELSE0 = Refiner.tclORELSE0 @@ -264,22 +266,36 @@ module New = struct let tclTHEN t1 t2 = t1 <*> t2 - let tclFAIL lvl msg = - tclZERO (Refiner.FailError (lvl,lazy msg)) - - let tclZEROMSG ?loc msg = - let err = UserError (None, msg) in + let tclFAIL ?info lvl msg = + let info = match info with + (* If the backtrace points here it means the caller didn't save + the backtrace correctly *) + | None -> Exninfo.reify () + | Some info -> info + in + tclZERO ~info (Refiner.FailError (lvl,lazy msg)) + + let tclZEROMSG ?info ?loc msg = + let info = match info with + (* If the backtrace points here it means the caller didn't save + the backtrace correctly *) + | None -> Exninfo.reify () + | Some info -> info + in let info = match loc with - | None -> Exninfo.null - | Some loc -> Loc.add_loc Exninfo.null loc + | None -> info + | Some loc -> Loc.add_loc info loc in + let err = UserError (None, msg) in tclZERO ~info err let catch_failerror e = try Refiner.catch_failerror e; tclUNIT () - with e when CErrors.noncritical e -> tclZERO e + with e when CErrors.noncritical e -> + let _, info = Exninfo.capture e in + tclZERO ~info e (* spiwack: I chose to give the Ltac + the same semantics as [Proofview.tclOR], however, for consistency with the or-else @@ -439,8 +455,10 @@ module New = struct (* Try the first tactic that does not fail in a list of tactics *) let rec tclFIRST = function - | [] -> tclZEROMSG (str"No applicable tactic.") - | t::rest -> tclORELSE0 t (tclFIRST rest) + | [] -> + let info = Exninfo.reify () in + tclZEROMSG ~info (str"No applicable tactic.") + | t::rest -> tclORELSE0 t (tclFIRST rest) let rec tclFIRST_PROGRESS_ON tac = function | [] -> tclFAIL 0 (str "No applicable tactic") @@ -449,7 +467,8 @@ module New = struct let rec tclDO n t = if n < 0 then - tclZEROMSG (str"Wrong argument : Do needs a positive integer.") + let info = Exninfo.reify () in + tclZEROMSG ~info (str"Wrong argument : Do needs a positive integer.") else if n = 0 then tclUNIT () else if n = 1 then t else tclTHEN t (tclDO (n-1) t) @@ -472,7 +491,8 @@ module New = struct let tclCOMPLETE t = t >>= fun res -> (tclINDEPENDENT - (tclZEROMSG (str"Proof is not complete.")) + (let info = Exninfo.reify () in + tclZEROMSG ~info (str"Proof is not complete.")) ) <*> tclUNIT res @@ -531,7 +551,8 @@ module New = struct let () = check_evars env sigma_final sigma sigma_initial in tclUNIT x with e when CErrors.noncritical e -> - tclZERO e + let e, info = Exninfo.capture e in + tclZERO ~info e else tclUNIT x in @@ -550,7 +571,8 @@ module New = struct (Proofview.tclTIMEOUT n t) begin function (e, info) -> match e with | Logic_monad.Tac_Timeout as e -> - Proofview.tclZERO (Refiner.FailError (0,lazy (CErrors.print e))) + let info = Exninfo.reify () in + Proofview.tclZERO ~info (Refiner.FailError (0,lazy (CErrors.print e))) | e -> Proofview.tclZERO ~info e end diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 01565169ca..eebe702259 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -151,9 +151,9 @@ module New : sig (* [tclFAIL n msg] fails with [msg] as an error message at level [n] (meaning that it will jump over [n] error catching tacticals FROM THIS MODULE. *) - val tclFAIL : int -> Pp.t -> 'a tactic + val tclFAIL : ?info:Exninfo.info -> int -> Pp.t -> 'a tactic - val tclZEROMSG : ?loc:Loc.t -> Pp.t -> 'a tactic + val tclZEROMSG : ?info:Exninfo.info -> ?loc:Loc.t -> Pp.t -> 'a tactic (** Fail with a [User_Error] containing the given message. *) val tclOR : unit tactic -> unit tactic -> unit tactic diff --git a/tactics/tactics.ml b/tactics/tactics.ml index e4809332c5..5fe87a94c5 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -182,10 +182,13 @@ let convert_gen pb x y = Proofview.Goal.enter begin fun gl -> match Tacmach.New.pf_apply (Reductionops.infer_conv ~pb) gl x y with | Some sigma -> Proofview.Unsafe.tclEVARS sigma - | None -> Tacticals.New.tclFAIL 0 (str "Not convertible") - | exception _ -> + | None -> + let info = Exninfo.reify () in + Tacticals.New.tclFAIL ~info 0 (str "Not convertible") + | exception e -> + let _, info = Exninfo.capture e in (* FIXME: Sometimes an anomaly is raised from conversion *) - Tacticals.New.tclFAIL 0 (str "Not convertible") + Tacticals.New.tclFAIL ~info 0 (str "Not convertible") end let convert x y = convert_gen Reduction.CONV x y @@ -301,7 +304,9 @@ let rename_hyp repl = let init = Some (Id.Set.empty, Id.Set.empty) in let dom = List.fold_left fold init repl in match dom with - | None -> Tacticals.New.tclZEROMSG (str "Not a one-to-one name mapping") + | None -> + let info = Exninfo.reify () in + Tacticals.New.tclZEROMSG ~info (str "Not a one-to-one name mapping") | Some (src, dst) -> Proofview.Goal.enter begin fun gl -> let hyps = Proofview.Goal.hyps gl in @@ -1023,7 +1028,10 @@ let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = (Proofview.Unsafe.tclEVARS sigma) (intro_then_gen name_flag move_flag force_flag dep_flag tac) | _ -> - begin if not force_flag then Proofview.tclZERO (RefinerError (env, sigma, IntroNeedsProduct)) + begin if not force_flag + then + let info = Exninfo.reify () in + Proofview.tclZERO ~info (RefinerError (env, sigma, IntroNeedsProduct)) (* Note: red_in_concl includes betaiotazeta and this was like *) (* this since at least V6.3 (a pity *) (* that intro do betaiotazeta only when reduction is needed; and *) @@ -1035,7 +1043,7 @@ let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = (intro_then_gen name_flag move_flag false dep_flag tac)) begin function (e, info) -> match e with | RefinerError (env, sigma, IntroNeedsProduct) -> - Tacticals.New.tclZEROMSG (str "No product even after head-reduction.") + Tacticals.New.tclZEROMSG ~info (str "No product even after head-reduction.") | e -> Proofview.tclZERO ~info e end end @@ -1314,12 +1322,13 @@ let cut c = know the relevance *) match Typing.sort_of env sigma c with | exception e when noncritical e -> - Tacticals.New.tclZEROMSG (str "Not a proposition or a type.") + let _, info = Exninfo.capture e in + Tacticals.New.tclZEROMSG ~info (str "Not a proposition or a type.") | sigma, s -> let r = Sorts.relevance_of_sort s in let id = next_name_away_with_default "H" Anonymous (Tacmach.New.pf_ids_set_of_hyps gl) in (* Backward compat: normalize [c]. *) - let c = if normalize_cut then local_strong whd_betaiota sigma c else c in + let c = if normalize_cut then strong whd_betaiota env sigma c else c in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Refine.refine ~typecheck:false begin fun h -> let (h, f) = Evarutil.new_evar ~principal:true env h (mkArrow c r (Vars.lift 1 concl)) in @@ -1607,7 +1616,7 @@ let make_projection env sigma params cstr sign elim i n c u = noccur_between sigma 1 (n-i-1) t (* to avoid surprising unifications, excludes flexible projection types or lambda which will be instantiated by Meta/Evar *) - && not (isEvar sigma (fst (whd_betaiota_stack sigma t))) + && not (isEvar sigma (fst (whd_betaiota_stack env sigma t))) && (accept_universal_lemma_under_conjunctions () || not (isRel sigma t)) then let t = lift (i+1-n) t in @@ -1666,7 +1675,9 @@ let descend_in_conjunctions avoid tac (err, info) c = let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in match make_projection env sigma params cstr sign elim i n c u with - | None -> Tacticals.New.tclFAIL 0 (mt()) + | None -> + let info = Exninfo.reify () in + Tacticals.New.tclFAIL ~info 0 (mt()) | Some (p,pt) -> Tacticals.New.tclTHENS (assert_before_gen false (NamingAvoid avoid) pt) @@ -1718,7 +1729,8 @@ let general_apply ?(respect_opaque=false) with_delta with_destruct with_evars let clause = make_clenv_binding_apply env sigma (Some n) (c,thm_ty) lbind in Clenvtac.res_pf clause ~with_evars ~flags with exn when noncritical exn -> - Proofview.tclZERO exn + let exn, info = Exninfo.capture exn in + Proofview.tclZERO ~info exn in let rec try_red_apply thm_ty (exn0, info) = try @@ -1730,9 +1742,10 @@ let general_apply ?(respect_opaque=false) with_delta with_destruct with_evars | PretypeError _|RefinerError _|UserError _|Failure _ -> Some (try_red_apply red_thm (exn0, info)) | _ -> None) - with Redelimination -> + with Redelimination as exn -> (* Last chance: if the head is a variable, apply may try second order unification *) + let exn, info = Exninfo.capture exn in let info = Option.cata (fun loc -> Loc.add_loc info loc) info loc in let tac = if with_destruct then @@ -1991,7 +2004,9 @@ let assumption = if only_eq then let hyps = Proofview.Goal.hyps gl in arec gl false hyps - else Tacticals.New.tclZEROMSG (str "No such assumption.") + else + let info = Exninfo.reify () in + Tacticals.New.tclZEROMSG ~info (str "No such assumption.") | decl::rest -> let t = NamedDecl.get_type decl in let concl = Proofview.Goal.concl gl in @@ -2087,12 +2102,13 @@ let clear_body ids = else sigma in Proofview.Unsafe.tclEVARS sigma - with DependsOnBody where -> + with DependsOnBody where as exn -> + let _, info = Exninfo.capture exn in let msg = match where with | None -> str "Conclusion" ++ on_the_bodies ids | Some id -> str "Hypothesis " ++ Id.print id ++ on_the_bodies ids in - Tacticals.New.tclZEROMSG msg + Tacticals.New.tclZEROMSG ~info msg in check <*> Refine.refine ~typecheck:false begin fun sigma -> @@ -2306,7 +2322,8 @@ let intro_decomp_eq ?loc l thin tac id = (fun n -> tac ((CAst.make id)::thin) (Some (true,n)) l) (eq,t,eq_args) (c, t) | None -> - Tacticals.New.tclZEROMSG (str "Not a primitive equality here.") + let info = Exninfo.reify () in + Tacticals.New.tclZEROMSG ~info (str "Not a primitive equality here.") end let intro_or_and_pattern ?loc with_evars bracketed ll thin tac id = @@ -3025,7 +3042,7 @@ let specialize (c,lbind) ipat = let flags = { (default_unify_flags ()) with resolve_evars = true } in let clause = clenv_unify_meta_types ~flags clause in let sigma = clause.evd in - let (thd,tstack) = whd_nored_stack sigma (clenv_value clause) in + let (thd,tstack) = whd_nored_stack env sigma (clenv_value clause) in (* The completely applied term is (thd tstack), but tstack may contain unsolved metas, so now we must reabstract them args with there name to have @@ -3992,13 +4009,14 @@ let specialize_eqs id = (internal_cut true id ty') (exact_no_check ((* refresh_universes_strict *) acc')) else - Tacticals.New.tclFAIL 0 (str "Nothing to do in hypothesis " ++ Id.print id) + let info = Exninfo.reify () in + Tacticals.New.tclFAIL ~info 0 (str "Nothing to do in hypothesis " ++ Id.print id) end let specialize_eqs id = Proofview.Goal.enter begin fun gl -> let msg = str "Specialization not allowed on dependent hypotheses" in Proofview.tclOR (clear [id]) - (fun _ -> Tacticals.New.tclZEROMSG msg) >>= fun () -> + (fun (_,info) -> Tacticals.New.tclZEROMSG ~info msg) >>= fun () -> specialize_eqs id end @@ -4414,7 +4432,8 @@ let induction_without_atomization isrec with_evars elim names lid = scheme.nargs + (if scheme.farg_in_concl then 1 else 0) in if not (Int.equal (List.length lid) (scheme.nparams + nargs_indarg_farg)) then - Tacticals.New.tclZEROMSG (msg_not_right_number_induction_arguments scheme) + let info = Exninfo.reify () in + Tacticals.New.tclZEROMSG ~info (msg_not_right_number_induction_arguments scheme) else let indvars,lid_params = List.chop nargs_indarg_farg lid in (* terms to patternify we must patternify indarg or farg if present in concl *) @@ -4528,7 +4547,8 @@ let guard_no_unifiable = Proofview.guard_no_unifiable >>= function | Some l -> Proofview.tclENV >>= function env -> Proofview.tclEVARMAP >>= function sigma -> - Proofview.tclZERO (RefinerError (env, sigma, UnresolvedBindings l)) + let info = Exninfo.reify () in + Proofview.tclZERO ~info (RefinerError (env, sigma, UnresolvedBindings l)) let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim id ((pending,(c0,lbind)),(eqname,names)) t0 inhyps cls tac = @@ -4831,7 +4851,9 @@ let reflexivity_red allowred = let sigma = Tacmach.New.project gl in let concl = maybe_betadeltaiota_concl allowred gl in match match_with_equality_type env sigma concl with - | None -> Proofview.tclZERO NoEquationFound + | None -> + let info = Exninfo.reify () in + Proofview.tclZERO ~info NoEquationFound | Some _ -> one_constructor 1 NoBindings end @@ -4873,8 +4895,9 @@ let match_with_equation c = try let res = match_with_equation env sigma c in Proofview.tclUNIT res - with NoEquationFound -> - Proofview.tclZERO NoEquationFound + with NoEquationFound as exn -> + let _, info = Exninfo.capture exn in + Proofview.tclZERO ~info NoEquationFound let symmetry_red allowred = Proofview.Goal.enter begin fun gl -> @@ -4987,7 +5010,9 @@ let transitivity_red allowred t = | Some t -> Tacticals.New.pf_constr_of_global eq_data.trans >>= fun trans -> apply_list [trans; t]) | None,eq,eq_kind -> match t with - | None -> Tacticals.New.tclZEROMSG (str"etransitivity not supported for this relation.") + | None -> + let info = Exninfo.reify () in + Tacticals.New.tclZEROMSG ~info (str"etransitivity not supported for this relation.") | Some t -> prove_transitivity eq eq_kind t end @@ -5005,8 +5030,8 @@ let transitivity t = transitivity_gen (Some t) let intros_transitivity n = Tacticals.New.tclTHEN intros (transitivity_gen n) let constr_eq ~strict x y = - let fail = Tacticals.New.tclFAIL 0 (str "Not equal") in - let fail_universes = Tacticals.New.tclFAIL 0 (str "Not equal (due to universes)") in + let fail ~info = Tacticals.New.tclFAIL ~info 0 (str "Not equal") in + let fail_universes ~info = Tacticals.New.tclFAIL ~info 0 (str "Not equal (due to universes)") in Proofview.Goal.enter begin fun gl -> let env = Tacmach.New.pf_env gl in let evd = Tacmach.New.project gl in @@ -5015,13 +5040,18 @@ let constr_eq ~strict x y = let csts = UnivProblem.to_constraints ~force_weak:false (Evd.universes evd) csts in if strict then if Evd.check_constraints evd csts then Proofview.tclUNIT () - else fail_universes + else + let info = Exninfo.reify () in + fail_universes ~info else (match Evd.add_constraints evd csts with | evd -> Proofview.Unsafe.tclEVARS evd - | exception Univ.UniverseInconsistency _ -> - fail_universes) - | None -> fail + | exception (Univ.UniverseInconsistency _ as e) -> + let _, info = Exninfo.capture e in + fail_universes ~info) + | None -> + let info = Exninfo.reify () in + fail ~info end let unify ?(state=TransparentState.full) x y = @@ -5042,9 +5072,84 @@ let unify ?(state=TransparentState.full) x y = let sigma = w_unify (Tacmach.New.pf_env gl) sigma Reduction.CONV ~flags x y in Proofview.Unsafe.tclEVARS sigma with e when noncritical e -> - Proofview.tclZERO (PretypeError (env, sigma, CannotUnify (x, y, None))) + let e, info = Exninfo.capture e in + Proofview.tclZERO ~info (PretypeError (env, sigma, CannotUnify (x, y, None))) end +(** [tclWRAPFINALLY before tac finally] runs [before] before each + entry-point of [tac] and passes the result of [before] to + [finally], which is then run at each exit-point of [tac], + regardless of whether it succeeds or fails. Said another way, if + [tac] succeeds, then it behaves as [before >>= fun v -> tac >>= fun + ret -> finally v <*> tclUNIT ret]; otherwise, if [tac] fails with + [e], it behaves as [before >>= fun v -> finally v <*> tclZERO + e]. Note that if [tac] succeeds [n] times before finally failing, + [before] and [finally] are both run [n+1] times (once around each + succuess, and once more around the final failure). *) +(* We should probably export this somewhere, but it's not clear + where. As per + https://github.com/coq/coq/pull/12197#discussion_r418480525 and + https://gitter.im/coq/coq?at=5ead5c35347bd616304e83ef, we don't + export it from Proofview, because it seems somehow not primitive + enough. We don't export it from this file because it is more of a + tactical than a tactic. But we also don't export it from Tacticals + because all of the non-New tacticals there operate on `tactic`, not + `Proofview.tactic`, and all of the `New` tacticals that deal with + multi-success things are focussing, i.e., apply their arguments on + each goal separately (and it even says so in the comment on `New`), + whereas it's important that `tclWRAPFINALLY` doesn't introduce + extra focussing. *) +let rec tclWRAPFINALLY before tac finally = + let open Proofview in + let open Proofview.Notations in + before >>= fun v -> tclCASE tac >>= function + | Fail (e, info) -> finally v >>= fun () -> tclZERO ~info e + | Next (ret, tac') -> tclOR + (finally v >>= fun () -> tclUNIT ret) + (fun e -> tclWRAPFINALLY before (tac' e) finally) + +let with_set_strategy lvl_ql k = + let glob_key r = + match r with + | GlobRef.ConstRef sp -> ConstKey sp + | GlobRef.VarRef id -> VarKey id + | _ -> user_err Pp.(str + "cannot set an inductive type or a constructor as transparent") in + let kl = List.concat (List.map (fun (lvl, ql) -> List.map (fun q -> (lvl, glob_key q)) ql) lvl_ql) in + tclWRAPFINALLY + (Proofview.tclENV >>= fun env -> + let orig_kl = List.map (fun (_lvl, k) -> + (Conv_oracle.get_strategy (Environ.oracle env) k, k)) + kl in + (* Because the global env might be desynchronized from the + proof-local env, we need to update the global env to have this + tactic play nicely with abstract. + TODO: When abstract no longer depends on Global, delete this + let orig_kl_global = ... in *) + let orig_kl_global = List.map (fun (_lvl, k) -> + (Conv_oracle.get_strategy (Environ.oracle (Global.env ())) k, k)) + kl in + let env = List.fold_left (fun env (lvl, k) -> + Environ.set_oracle env + (Conv_oracle.set_strategy (Environ.oracle env) k lvl)) env kl in + Proofview.Unsafe.tclSETENV env <*> + (* TODO: When abstract no longer depends on Global, remove this + [Proofview.tclLIFT] block *) + Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> + List.iter (fun (lvl, k) -> Global.set_strategy k lvl) kl)) <*> + Proofview.tclUNIT (orig_kl, orig_kl_global)) + k + (fun (orig_kl, orig_kl_global) -> + (* TODO: When abstract no longer depends on Global, remove this + [Proofview.tclLIFT] block *) + Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> + List.iter (fun (lvl, k) -> Global.set_strategy k lvl) orig_kl_global)) <*> + Proofview.tclENV >>= fun env -> + let env = List.fold_left (fun env (lvl, k) -> + Environ.set_oracle env + (Conv_oracle.set_strategy (Environ.oracle env) k lvl)) env orig_kl in + Proofview.Unsafe.tclSETENV env) + module Simple = struct (** Simplified version of some of the above tactics *) diff --git a/tactics/tactics.mli b/tactics/tactics.mli index c84ba17f23..b6eb48a3d9 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -435,6 +435,12 @@ val declare_intro_decomp_eq : (types * constr * constr) -> constr * types -> unit Proofview.tactic) -> unit +(** Tactic analogous to the [Strategy] vernacular, but only applied + locally to the tactic argument *) +val with_set_strategy : + (Conv_oracle.level * Names.GlobRef.t list) list -> + 'a Proofview.tactic -> 'a Proofview.tactic + (** {6 Simple form of basic tactics. } *) module Simple : sig diff --git a/test-suite/bugs/closed/bug_10812.v b/test-suite/bugs/closed/bug_10812.v new file mode 100644 index 0000000000..68f3814781 --- /dev/null +++ b/test-suite/bugs/closed/bug_10812.v @@ -0,0 +1,28 @@ +(* subst with indirectly dependent section variables *) + +Section A. + +Variable a:nat. +Definition b := a. + +Goal a=1 -> a+a=1 -> b=1. +intros. +Fail subst a. (* was working; we make it failing *) +rewrite H in H0. +discriminate. +Qed. + +Goal a=1 -> a+a=1 -> b=1. +intros. +subst. (* should not apply to a *) +rewrite H in H0. +discriminate. +Qed. + +Goal forall t, a=t -> b=t. +intros. +subst. +reflexivity. +Qed. + +End A. diff --git a/test-suite/bugs/closed/bug_11727.v b/test-suite/bugs/closed/bug_11727.v new file mode 100644 index 0000000000..d346f05c10 --- /dev/null +++ b/test-suite/bugs/closed/bug_11727.v @@ -0,0 +1,8 @@ +Tactic Notation "myunfold" reference(x) := unfold x. +Notation idnat := (@id nat). +Goal let n := 0 in idnat n = 0. +Proof. + intro n. + myunfold idnat. + myunfold n. +Abort. diff --git a/test-suite/bugs/closed/bug_12234.v b/test-suite/bugs/closed/bug_12234.v new file mode 100644 index 0000000000..b99c5d524e --- /dev/null +++ b/test-suite/bugs/closed/bug_12234.v @@ -0,0 +1,9 @@ +(* Checking a Show Proof bug *) +Section S. +Variable A:Prop. +Theorem thm (a:A) : True. +assert (b:=a). +clear A a b. +Show Proof. +Abort. +End S. diff --git a/test-suite/bugs/closed/bug_2830.v b/test-suite/bugs/closed/bug_2830.v index a321bb324e..16ba02b340 100644 --- a/test-suite/bugs/closed/bug_2830.v +++ b/test-suite/bugs/closed/bug_2830.v @@ -208,7 +208,7 @@ Defined. (* The [list] type constructor is a Functor. *) -Import List. +Require Import List. Definition setList (A:set_cat) := list A. Instance list_functor : Functor set_cat set_cat setList. diff --git a/test-suite/bugs/closed/bug_4151.v b/test-suite/bugs/closed/bug_4151.v index 9ec8c01ac6..df3c9481a6 100644 --- a/test-suite/bugs/closed/bug_4151.v +++ b/test-suite/bugs/closed/bug_4151.v @@ -9,7 +9,7 @@ Qed. Axiom proof_admitted : False. Tactic Notation "admit" := case proof_admitted. Require Import Coq.Lists.SetoidList. -Require Export Coq.Program.Program. +Import ListNotations. Global Set Implicit Arguments. Global Set Asymmetric Patterns. diff --git a/test-suite/bugs/closed/bug_4925.v b/test-suite/bugs/closed/bug_4925.v new file mode 100644 index 0000000000..d4e4b35351 --- /dev/null +++ b/test-suite/bugs/closed/bug_4925.v @@ -0,0 +1,6 @@ +Axiom a: bool. + +Goal a = true. +Proof. +try unfold a. +Abort. diff --git a/test-suite/bugs/closed/bug_5159.v b/test-suite/bugs/closed/bug_5159.v new file mode 100644 index 0000000000..cbc924c2d3 --- /dev/null +++ b/test-suite/bugs/closed/bug_5159.v @@ -0,0 +1,12 @@ +Axiom foo : Type. +Definition bar := 1. +Definition bar' := Eval cbv -[bar] in bar. +Declare Reduction red' := cbv -[bar]. +Opaque bar. +Definition bar'' := Eval red' in bar. +Declare Reduction red'' := cbv -[bar]. (* Error: Cannot coerce bar to an +evaluable reference. *) +Definition bar''' := Eval cbv -[bar] in bar. (* Error: Cannot coerce bar to an +evaluable reference. *) +Definition foo' := Eval cbv -[foo] in foo. (* Error: Cannot coerce foo to an +evaluable reference. *) diff --git a/test-suite/bugs/closed/bug_5764.v b/test-suite/bugs/closed/bug_5764.v new file mode 100644 index 0000000000..0b015d9c7e --- /dev/null +++ b/test-suite/bugs/closed/bug_5764.v @@ -0,0 +1,7 @@ +Module Type A. +Parameter a : nat. +End A. + +Module B (mA : A). +Ltac cbv_a := cbv [mA.a]. +End B. diff --git a/test-suite/bugs/closed/bug_7903.v b/test-suite/bugs/closed/bug_7903.v index 55c7ee99a7..18e1884ca7 100644 --- a/test-suite/bugs/closed/bug_7903.v +++ b/test-suite/bugs/closed/bug_7903.v @@ -1,4 +1,4 @@ (* Slightly improving interpretation of Ltac subterms in notations *) Notation bar x f := (let z := ltac:(exact 1) in (fun x : nat => f)). -Check bar x (x + x). +Check fun x => bar x (x + x). diff --git a/test-suite/bugs/closed/bug_9583.v b/test-suite/bugs/closed/bug_9583.v new file mode 100644 index 0000000000..14232e8578 --- /dev/null +++ b/test-suite/bugs/closed/bug_9583.v @@ -0,0 +1,7 @@ +(* Was causing a stack overflow before #11613 *) +Declare Custom Entry bla. +Notation "[ t ]" := (t) (at level 0, t custom bla at level 0). +Notation "] t [" := (t) (in custom bla at level 0, t custom bla at level 0). +Notation "t" := (t) (in custom bla at level 0, t constr at level 9). +Notation "0" := (0) (in custom bla at level 0). +Check fun x => [ ] x [ ]. diff --git a/test-suite/bugs/closed/bug_9679.v b/test-suite/bugs/closed/bug_9679.v new file mode 100644 index 0000000000..24e69d23f9 --- /dev/null +++ b/test-suite/bugs/closed/bug_9679.v @@ -0,0 +1,6 @@ +(* Was raising an anomaly *) +Notation "'[#' ] f '|' x .. z '=n>' b" := + (fun x => .. (fun z => f b) ..) + (at level 201, x binder, z binder, + format "'[ ' [# ] '[' f | ']' x .. z =n> '[' b ']' ']'" + ). diff --git a/test-suite/ltac2/rebind.v b/test-suite/ltac2/rebind.v index e1c20a2059..7b3a460c8c 100644 --- a/test-suite/ltac2/rebind.v +++ b/test-suite/ltac2/rebind.v @@ -15,6 +15,39 @@ Fail foo (). constructor. Qed. + +(** Bindings are dynamic *) + +Ltac2 Type rec nat := [O | S (nat)]. + +Ltac2 rec nat_eq n m := + match n with + | O => match m with | O => true | S _ => false end + | S n => match m with | O => false | S m => nat_eq n m end + end. + +Ltac2 Type exn ::= [ Assertion_failed ]. + +Ltac2 assert_eq n m := + match nat_eq n m with + | true => () + | false => Control.throw Assertion_failed end. + +Ltac2 mutable x := O. +Ltac2 y := x. +Ltac2 Eval (assert_eq y O). +Ltac2 Set x := (S O). +Ltac2 Eval (assert_eq y (S O)). + +Ltac2 mutable quw := fun (n : nat) => O. +Ltac2 Set quw := fun n => + match n with + | O => O + | S n => S (S (quw n)) + end. + +Ltac2 Eval (quw (S (S O))). + (** Not the right type *) Fail Ltac2 Set foo := 0. @@ -25,10 +58,46 @@ Fail Ltac2 Set bar := fun _ => (). (** Subtype check *) -Ltac2 mutable rec f x := f x. +Ltac2 rec h x := h x. +Ltac2 mutable f x := h x. Fail Ltac2 Set f := fun x => x. Ltac2 mutable g x := x. +Ltac2 Set g := h. + +(** Rebinding with old values *) + + + +Ltac2 mutable qux n := S n. + +Ltac2 Set qux as self := fun n => self (self n). + +Ltac2 Eval assert_eq (qux O) (S (S O)). + +Ltac2 mutable quz := O. + +Ltac2 Set quz as self := S self. + +Ltac2 Eval (assert_eq quz (S O)). + +Ltac2 rec addn n := + match n with + | O => fun m => m + | S n => fun m => S (addn n m) + + end. +Ltac2 mutable rec quy n := + match n with + | O => S O + | S n => S (quy n) + end. -Ltac2 Set g := f. +Ltac2 Set quy as self := fun n => + match n with + | O => O + | S n => addn (self n) (quy n) + end. +Ltac2 Eval (assert_eq (quy (S (S O))) (S (S (S O)))). +Ltac2 Eval (assert_eq (quy (S (S (S O)))) (S (S (S (S (S (S O))))))). diff --git a/test-suite/output/ErrorLocation_12152_1.out b/test-suite/output/ErrorLocation_12152_1.out new file mode 100644 index 0000000000..b7b600d53d --- /dev/null +++ b/test-suite/output/ErrorLocation_12152_1.out @@ -0,0 +1,3 @@ +File "stdin", line 3, characters 0-7: +Error: No product even after head-reduction. + diff --git a/test-suite/output/ErrorLocation_12152_1.v b/test-suite/output/ErrorLocation_12152_1.v new file mode 100644 index 0000000000..e63ab1cd48 --- /dev/null +++ b/test-suite/output/ErrorLocation_12152_1.v @@ -0,0 +1,3 @@ +(* Reported in #12152 *) +Goal True. +intro H; auto. diff --git a/test-suite/output/ErrorLocation_12152_2.out b/test-suite/output/ErrorLocation_12152_2.out new file mode 100644 index 0000000000..bdfd0a050f --- /dev/null +++ b/test-suite/output/ErrorLocation_12152_2.out @@ -0,0 +1,3 @@ +File "stdin", line 3, characters 0-8: +Error: No product even after head-reduction. + diff --git a/test-suite/output/ErrorLocation_12152_2.v b/test-suite/output/ErrorLocation_12152_2.v new file mode 100644 index 0000000000..5df6bec939 --- /dev/null +++ b/test-suite/output/ErrorLocation_12152_2.v @@ -0,0 +1,3 @@ +(* Reported in #12152 *) +Goal True. +intros H; auto. diff --git a/test-suite/output/ErrorLocation_12255.out b/test-suite/output/ErrorLocation_12255.out new file mode 100644 index 0000000000..ed5e183427 --- /dev/null +++ b/test-suite/output/ErrorLocation_12255.out @@ -0,0 +1,4 @@ +File "stdin", line 4, characters 0-16: +Error: Ltac variable x is bound to i > 0 which cannot be coerced to +an evaluable reference. + diff --git a/test-suite/output/ErrorLocation_12255.v b/test-suite/output/ErrorLocation_12255.v new file mode 100644 index 0000000000..347424b2fc --- /dev/null +++ b/test-suite/output/ErrorLocation_12255.v @@ -0,0 +1,4 @@ +Ltac can_unfold x := let b := eval cbv delta [x] in x in idtac. +Definition i := O. +Goal False. +can_unfold (i>0). diff --git a/test-suite/output/Notations4.out b/test-suite/output/Notations4.out index f48eaac4c9..9cb019ca56 100644 --- a/test-suite/output/Notations4.out +++ b/test-suite/output/Notations4.out @@ -111,3 +111,11 @@ Warning: The format modifier is irrelevant for only parsing rules. File "stdin", line 280, characters 0-63: Warning: The only parsing modifier has no effect in Reserved Notation. [irrelevant-reserved-notation-only-parsing,parsing] +fun x : nat => U (S x) + : nat -> nat +V tt + : unit * (unit -> unit) +fun x : nat => V x + : forall x : nat, nat * (?T -> ?T) +where +?T : [x : nat x0 : ?T |- Type] (x0 cannot be used) diff --git a/test-suite/output/Notations4.v b/test-suite/output/Notations4.v index 4d4b37a8b2..b3270d4f92 100644 --- a/test-suite/output/Notations4.v +++ b/test-suite/output/Notations4.v @@ -280,3 +280,13 @@ Notation "###" := 0 (at level 0, only parsing, format "###"). Reserved Notation "##" (at level 0, only parsing, format "##"). End N. + +Module O. + +Notation U t := (match t with 0 => 0 | S t => t | _ => 0 end). +Check fun x => U (S x). +Notation V t := (t,fun t => t). +Check V tt. +Check fun x : nat => V x. + +End O. diff --git a/test-suite/output/interleave_options_bad_order.out b/test-suite/output/interleave_options_bad_order.out new file mode 100644 index 0000000000..68dbaeb7b3 --- /dev/null +++ b/test-suite/output/interleave_options_bad_order.out @@ -0,0 +1,4 @@ +While loading initial state: +Warning: There is no flag or option with this name: "Extraction Optimize". +[unknown-option,option] +Extraction Optimize is on diff --git a/test-suite/output/interleave_options_bad_order.v b/test-suite/output/interleave_options_bad_order.v new file mode 100644 index 0000000000..9a70674b02 --- /dev/null +++ b/test-suite/output/interleave_options_bad_order.v @@ -0,0 +1,3 @@ +(* coq-prog-args: ("-unset" "Extraction Optimize" "-ri" "Extraction") *) + +Test Extraction Optimize. diff --git a/test-suite/output/interleave_options_correct_order.out b/test-suite/output/interleave_options_correct_order.out new file mode 100644 index 0000000000..76bb2016eb --- /dev/null +++ b/test-suite/output/interleave_options_correct_order.out @@ -0,0 +1 @@ +Extraction Optimize is off diff --git a/test-suite/output/interleave_options_correct_order.v b/test-suite/output/interleave_options_correct_order.v new file mode 100644 index 0000000000..7622d6ff52 --- /dev/null +++ b/test-suite/output/interleave_options_correct_order.v @@ -0,0 +1,3 @@ +(* coq-prog-args: ("-ri" "Extraction" "-unset" "Extraction Optimize") *) + +Test Extraction Optimize. diff --git a/test-suite/output/print_ltac.out b/test-suite/output/print_ltac.out index 952761acca..58931c4b82 100644 --- a/test-suite/output/print_ltac.out +++ b/test-suite/output/print_ltac.out @@ -6,3 +6,340 @@ Ltac t3 := idtacstr "my tactic" Ltac t4 x := match x with | ?A => (A, A) end +The command has indeed failed with message: +idnat is bound to a notation that does not denote a reference. +Ltac withstrategy l x := + let idx := smart_global:(id) in + let tl := strategy_level:(transparent) in + with_strategy + 1 + [ + id + id + ] + with_strategy + l + [ + id + id + ] + with_strategy + tl + [ + id + id + ] + with_strategy + transparent + [ + id + id + ] + with_strategy + transparent + [ + id + id + ] + with_strategy + opaque + [ + id + id + ] + with_strategy + expand + [ + id + id + ] + with_strategy + transparent + [ + idx + ] + with_strategy + transparent + [ + id + x + ] + with_strategy + transparent + [ + x + id + ] + with_strategy + transparent + [ + id + ] + with_strategy + transparent + [ + id + x + ] + with_strategy + transparent + [ + id + id + ] + with_strategy + transparent + [ + id + id + x + ] + with_strategy + transparent + [ + id + ] + with_strategy + transparent + [ + id + x + ] + with_strategy + transparent + [ + id + id + ] + with_strategy + transparent + [ + id + id + x + ] + idtac +The command has indeed failed with message: +idnat is bound to a notation that does not denote a reference. +Ltac withstrategy l x := + let idx := smart_global:(id) in + let tl := strategy_level:(transparent) in + with_strategy + 1 + [ + id + id + ] + with_strategy + l + [ + id + id + ] + with_strategy + tl + [ + id + id + ] + with_strategy + transparent + [ + id + id + ] + with_strategy + transparent + [ + id + id + ] + with_strategy + opaque + [ + id + id + ] + with_strategy + expand + [ + id + id + ] + with_strategy + transparent + [ + idx + ] + with_strategy + transparent + [ + id + x + ] + with_strategy + transparent + [ + x + id + ] + with_strategy + transparent + [ + id + ] + with_strategy + transparent + [ + id + x + ] + with_strategy + transparent + [ + id + id + ] + with_strategy + transparent + [ + id + id + x + ] + with_strategy + transparent + [ + id + ] + with_strategy + transparent + [ + id + x + ] + with_strategy + transparent + [ + id + id + ] + with_strategy + transparent + [ + id + id + x + ] + idtac +Ltac FE.withstrategy l x := + let idx := smart_global:(FE.id) in + let tl := strategy_level:(transparent) in + with_strategy + 1 + [ + FE.id + FE.id + ] + with_strategy + l + [ + FE.id + FE.id + ] + with_strategy + tl + [ + FE.id + FE.id + ] + with_strategy + transparent + [ + FE.id + FE.id + ] + with_strategy + transparent + [ + FE.id + FE.id + ] + with_strategy + opaque + [ + FE.id + FE.id + ] + with_strategy + expand + [ + FE.id + FE.id + ] + with_strategy + transparent + [ + idx + ] + with_strategy + transparent + [ + FE.id + x + ] + with_strategy + transparent + [ + x + FE.id + ] + with_strategy + transparent + [ + FE.id + ] + with_strategy + transparent + [ + FE.id + x + ] + with_strategy + transparent + [ + FE.id + FE.id + ] + with_strategy + transparent + [ + FE.id + FE.id + x + ] + with_strategy + transparent + [ + FE.id + ] + with_strategy + transparent + [ + FE.id + x + ] + with_strategy + transparent + [ + FE.id + FE.id + ] + with_strategy + transparent + [ + FE.id + FE.id + x + ] + idtac diff --git a/test-suite/output/print_ltac.v b/test-suite/output/print_ltac.v index a992846791..d0883e32e4 100644 --- a/test-suite/output/print_ltac.v +++ b/test-suite/output/print_ltac.v @@ -10,3 +10,73 @@ Print Ltac t3. (* https://github.com/coq/coq/issues/9716 *) Ltac t4 x := match x with ?A => constr:((A, A)) end. Print Ltac t4. + +Notation idnat := (@id nat). +Notation idn := id. +Notation idan := (@id). +Fail Strategy transparent [idnat]. +Strategy transparent [idn]. +Strategy transparent [idan]. +Ltac withstrategy l x := + let idx := smart_global:(id) in + let tl := strategy_level:(transparent) in + with_strategy 1 [id id] ( + with_strategy l [id id] ( + with_strategy tl [id id] ( + with_strategy 0 [id id] ( + with_strategy transparent [id id] ( + with_strategy opaque [id id] ( + with_strategy expand [id id] ( + with_strategy 0 [idx] ( + with_strategy 0 [id x] ( + with_strategy 0 [x id] ( + with_strategy 0 [idn] ( + with_strategy 0 [idn x] ( + with_strategy 0 [idn id] ( + with_strategy 0 [idn id x] ( + with_strategy 0 [idan] ( + with_strategy 0 [idan x] ( + with_strategy 0 [idan id] ( + with_strategy 0 [idan id x] ( + idtac + )))))))))))))))))). +Print Ltac withstrategy. + +Module Type Empty. End Empty. +Module E. End E. +Module F (E : Empty). + Definition id {T} := @id T. + Notation idnat := (@id nat). + Notation idn := id. + Notation idan := (@id). + Fail Strategy transparent [idnat]. + Strategy transparent [idn]. + Strategy transparent [idan]. + Ltac withstrategy l x := + let idx := smart_global:(id) in + let tl := strategy_level:(transparent) in + with_strategy 1 [id id] ( + with_strategy l [id id] ( + with_strategy tl [id id] ( + with_strategy 0 [id id] ( + with_strategy transparent [id id] ( + with_strategy opaque [id id] ( + with_strategy expand [id id] ( + with_strategy 0 [idx] ( + with_strategy 0 [id x] ( + with_strategy 0 [x id] ( + with_strategy 0 [idn] ( + with_strategy 0 [idn x] ( + with_strategy 0 [idn id] ( + with_strategy 0 [idn id x] ( + with_strategy 0 [idan] ( + with_strategy 0 [idan x] ( + with_strategy 0 [idan id] ( + with_strategy 0 [idan id x] ( + idtac + )))))))))))))))))). + Print Ltac withstrategy. +End F. + +Module FE := F E. +Print Ltac FE.withstrategy. diff --git a/test-suite/success/Record.v b/test-suite/success/Record.v index 18ebcd6384..ce07512a1e 100644 --- a/test-suite/success/Record.v +++ b/test-suite/success/Record.v @@ -3,6 +3,7 @@ Definition CProp := Prop. Record test : CProp := {n : nat ; m : bool ; _ : n <> 0 }. Require Import Program. Require Import List. +Import ListNotations. Record vector {A : Type} {n : nat} := { vec_list : list A ; vec_len : length vec_list = n }. Arguments vector : clear implicits. diff --git a/test-suite/success/shrink_obligations.v b/test-suite/success/shrink_obligations.v index 676b97878f..032fcaac6d 100644 --- a/test-suite/success/shrink_obligations.v +++ b/test-suite/success/shrink_obligations.v @@ -2,8 +2,6 @@ Require Program. Obligation Tactic := idtac. -Set Shrink Obligations. - Program Definition foo (m : nat) (p := S m) (n : nat) (q := S n) : unit := let bar : {r | n < r} := _ in let qux : {r | p < r} := _ in diff --git a/test-suite/success/strategy.v b/test-suite/success/strategy.v new file mode 100644 index 0000000000..926ba54342 --- /dev/null +++ b/test-suite/success/strategy.v @@ -0,0 +1,87 @@ +Notation aid := (@id) (only parsing). +Notation idn := id (only parsing). +Ltac unfold_id := unfold id. + +Fixpoint fact (n : nat) + := match n with + | 0 => 1 + | S n => (S n) * fact n + end. + +Opaque id. +Goal id (fact 100) = fact 100. + Strategy expand [id]. + Time Timeout 5 reflexivity. (* should be instant *) + (* Finished transaction in 0. secs (0.u,0.s) (successful) *) +Time Timeout 5 Defined. +(* Finished transaction in 0.001 secs (0.u,0.s) (successful) *) + +Goal True. + let x := smart_global:(id) in unfold x. + let x := smart_global:(aid) in unfold x. + let x := smart_global:(idn) in unfold x. +Abort. + +Goal id 0 = 0. + Opaque id. + assert_fails unfold_id. + Transparent id. + assert_succeeds unfold_id. + Opaque id. + Strategy 0 [id]. + assert_succeeds unfold_id. + Strategy 1 [id]. + assert_succeeds unfold_id. + Strategy -1 [id]. + assert_succeeds unfold_id. + Strategy opaque [id]. + assert_fails unfold_id. + Strategy transparent [id]. + assert_succeeds unfold_id. + Opaque id. + Strategy expand [id]. + assert_succeeds unfold_id. + reflexivity. +Qed. +Goal id 0 = 0. + Opaque aid. + assert_fails unfold_id. + Transparent aid. + assert_succeeds unfold_id. + Opaque aid. + Strategy 0 [aid]. + assert_succeeds unfold_id. + Strategy 1 [aid]. + assert_succeeds unfold_id. + Strategy -1 [aid]. + assert_succeeds unfold_id. + Strategy opaque [aid]. + assert_fails unfold_id. + Strategy transparent [aid]. + assert_succeeds unfold_id. + Opaque aid. + Strategy expand [aid]. + assert_succeeds unfold_id. + reflexivity. +Qed. +Goal id 0 = 0. + Opaque idn. + assert_fails unfold_id. + Transparent idn. + assert_succeeds unfold_id. + Opaque idn. + Strategy 0 [idn]. + assert_succeeds unfold_id. + Strategy 1 [idn]. + assert_succeeds unfold_id. + Strategy -1 [idn]. + assert_succeeds unfold_id. + Strategy opaque [idn]. + assert_fails unfold_id. + Strategy transparent [idn]. + assert_succeeds unfold_id. + Opaque idn. + Strategy expand [idn]. + assert_succeeds unfold_id. + reflexivity. +Qed. diff --git a/test-suite/success/tac_wit_ref.v b/test-suite/success/tac_wit_ref.v new file mode 100644 index 0000000000..8bde31858e --- /dev/null +++ b/test-suite/success/tac_wit_ref.v @@ -0,0 +1,8 @@ +Tactic Notation "foo" reference(n) := idtac n. + +Goal forall n : nat, n = 0. +Proof. +intros n. +foo nat. +foo n. +Abort. diff --git a/test-suite/success/with_strategy.v b/test-suite/success/with_strategy.v new file mode 100644 index 0000000000..6f0833211e --- /dev/null +++ b/test-suite/success/with_strategy.v @@ -0,0 +1,577 @@ +Notation aid := (@id) (only parsing). +Notation idn := id (only parsing). +Ltac unfold_id := unfold id. + +Fixpoint fact (n : nat) + := match n with + | 0 => 1 + | S n => (S n) * fact n + end. + +Opaque id. +Goal id 0 = 0. + with_strategy + opaque [id] + (with_strategy + opaque [id id] + (assert_fails unfold_id; + with_strategy + transparent [id] + (assert_succeeds unfold_id; + with_strategy + opaque [id] + (with_strategy + 0 [id] + (assert_succeeds unfold_id; + with_strategy + 1 [id] + (assert_succeeds unfold_id; + with_strategy + -1 [id] + (assert_succeeds unfold_id; + with_strategy + opaque [id] + (assert_fails unfold_id; + with_strategy + transparent [id] + (assert_succeeds unfold_id; + with_strategy + opaque [id] + (with_strategy + expand [id] + (assert_succeeds unfold_id; + let l := strategy_level:(expand) in + with_strategy + l [id] + (let idx := smart_global:(id) in + cbv [idx]; + (* This should succeed, but doesn't, basically due to https://github.com/coq/coq/issues/11202 *) + assert_fails + (let idx := smart_global:(id) in + with_strategy + expand [idx] + idtac); + reflexivity)))))))))))). +Qed. +Goal id 0 = 0. + with_strategy + opaque [aid] + (assert_fails unfold_id; + with_strategy + transparent [aid] + (assert_succeeds unfold_id; + with_strategy + opaque [aid] + (with_strategy + 0 [aid] + (assert_succeeds unfold_id; + with_strategy + 1 [aid] + (assert_succeeds unfold_id; + with_strategy + -1 [aid] + (assert_succeeds unfold_id; + with_strategy + opaque [aid] + (assert_fails unfold_id; + with_strategy + transparent [aid] + (assert_succeeds unfold_id; + with_strategy + opaque [aid] + (with_strategy + expand [aid] + (assert_succeeds unfold_id; + reflexivity)))))))))). +Qed. +Goal id 0 = 0. + with_strategy + opaque [idn] + (assert_fails unfold_id; + with_strategy + transparent [idn] + (assert_succeeds unfold_id; + with_strategy + opaque [idn] + (with_strategy + 0 [idn] + (assert_succeeds unfold_id; + with_strategy + 1 [idn] + (assert_succeeds unfold_id; + with_strategy + -1 [idn] + (assert_succeeds unfold_id; + with_strategy + opaque [idn] + (assert_fails unfold_id; + with_strategy + transparent [idn] + (assert_succeeds unfold_id; + with_strategy + opaque [idn] + (with_strategy + expand [idn] + (assert_succeeds unfold_id; + reflexivity)))))))))). +Qed. + +(* test that strategy tactic does not persist after the execution of the tactic *) +Opaque id. +Goal id 0 = 0. + assert_fails unfold_id; + (with_strategy transparent [id] assert_succeeds unfold_id); + assert_fails unfold_id. + assert_fails unfold_id. + with_strategy transparent [id] assert_succeeds unfold_id. + assert_fails unfold_id. + reflexivity. +Qed. + +(* test that the strategy tactic does persist through abstract *) +Opaque id. +Goal id 0 = 0. + Time Timeout 5 + with_strategy + expand [id] + assert (id (fact 100) = fact 100) by abstract reflexivity. + reflexivity. +Time Timeout 5 Defined. + +(* test that it works even with [Qed] *) +Goal id 0 = 0. +Proof using Type. + Time Timeout 5 + abstract + (with_strategy + expand [id] + assert (id (fact 100) = fact 100) by abstract reflexivity; + reflexivity). +Time Timeout 5 Qed. + +(* test that the strategy is correctly reverted after closing the goal completely *) +Goal id 0 = 0. + assert (id 0 = 0) by with_strategy expand [id] reflexivity. + Fail unfold id. + reflexivity. +Qed. + +(* test that the strategy is correctly reverted after failure *) +Goal id 0 = 0. + let id' := id in + (try with_strategy expand [id] fail); assert_fails unfold id'. + Fail unfold id. + (* a more complicated test involving a success and then a failure after backtracking *) + let id' := id in + ((with_strategy expand [id] (unfold id' + fail)) + idtac); + lazymatch goal with |- id 0 = 0 => idtac end; + assert_fails unfold id'. + Fail unfold id. + reflexivity. +Qed. + +(* test multi-success *) +Goal id (fact 100) = fact 100. + Timeout 1 + (with_strategy -1 [id] (((idtac + (abstract reflexivity))); fail)). + Undo. + Timeout 1 + let id' := id in + (with_strategy -1 [id] (((idtac + (unfold id'; reflexivity))); fail)). + Undo. + Timeout 1 + (with_strategy -1 [id] (idtac + (abstract reflexivity))); fail. (* should not time out *) + Undo. + with_strategy -1 [id] abstract reflexivity. +Defined. + +(* check that module substitutions happen correctly *) +Module F. + Definition id {T} := @id T. + Opaque id. + Ltac with_transparent_id tac := with_strategy transparent [id] tac. +End F. +Opaque F.id. + +Goal F.id 0 = F.id 0. + Fail unfold F.id. + F.with_transparent_id ltac:(progress unfold F.id). + Undo. + F.with_transparent_id ltac:(let x := constr:(@F.id) in progress unfold x). +Abort. + +Module Type Empty. End Empty. +Module E. End E. +Module F2F (E : Empty). + Definition id {T} := @id T. + Opaque id. + Ltac with_transparent_id tac := with_strategy transparent [id] tac. +End F2F. +Module F2 := F2F E. +Opaque F2.id. + +Goal F2.id 0 = F2.id 0. + Fail unfold F2.id. + F2.with_transparent_id ltac:(progress unfold F2.id). + Undo. + F2.with_transparent_id ltac:(let x := constr:(@F2.id) in progress unfold x). +Abort. + +(* test the tactic notation entries *) +Tactic Notation "with_strategy0" strategy_level(l) "[" ne_smart_global_list(v) "]" tactic3(tac) := with_strategy l [ v ] tac. +Tactic Notation "with_strategy1" strategy_level_or_var(l) "[" ne_smart_global_list(v) "]" tactic3(tac) := with_strategy l [ v ] tac. +Tactic Notation "with_strategy2" strategy_level(l) "[" constr(v) "]" tactic3(tac) := with_strategy l [ v ] tac. +Tactic Notation "with_strategy3" strategy_level_or_var(l) "[" constr(v) "]" tactic3(tac) := with_strategy l [ v ] tac. + +(* [with_strategy0] should work, but it doesn't, due to a combination of https://github.com/coq/coq/issues/11202 and https://github.com/coq/coq/issues/11209 *) +Opaque id. +Goal id 0 = 0. + Fail (* should work, not Fail *) with_strategy0 opaque [id] idtac. + Fail (* should work, not Fail *) with_strategy0 opaque [id id] idtac. + assert_fails unfold_id. + Fail (* should work, not Fail *) with_strategy0 transparent [id] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + Fail (* should work, not Fail *) with_strategy0 opaque [id] idtac. + Fail (* should work, not Fail *) with_strategy0 0 [id] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + Fail (* should work, not Fail *) with_strategy0 1 [id] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + Fail (* should work, not Fail *) with_strategy0 -1 [id] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + Fail (* should work, not Fail *) with_strategy0 opaque [id] idtac. + assert_fails unfold_id. + Fail (* should work, not Fail *) with_strategy0 transparent [id] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + Fail (* should work, not Fail *) with_strategy0 opaque [id] idtac. + Fail (* should work, not Fail *) with_strategy0 expand [id] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + (* This should succeed, but doesn't, basically due to https://github.com/coq/coq/issues/11202 *) + Fail let idx := smart_global:(id) in + with_strategy0 expand [idx] idtac. + reflexivity. +Qed. +Goal id 0 = 0. + Fail (* should work, not Fail *) with_strategy0 opaque [aid] idtac. + assert_fails unfold_id. + Fail (* should work, not Fail *) with_strategy0 transparent [aid] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + Fail (* should work, not Fail *) with_strategy0 opaque [aid] idtac. + Fail (* should work, not Fail *) with_strategy0 0 [aid] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + Fail (* should work, not Fail *) with_strategy0 1 [aid] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + Fail (* should work, not Fail *) with_strategy0 -1 [aid] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + Fail (* should work, not Fail *) with_strategy0 opaque [aid] idtac. + assert_fails unfold_id. + Fail (* should work, not Fail *) with_strategy0 transparent [aid] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + Fail (* should work, not Fail *) with_strategy0 opaque [aid] idtac. + Fail (* should work, not Fail *) with_strategy0 expand [aid] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + reflexivity. +Qed. +Goal id 0 = 0. + Fail (* should work, not Fail *) with_strategy0 opaque [idn] idtac. + assert_fails unfold_id. + Fail (* should work, not Fail *) with_strategy0 transparent [idn] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + Fail (* should work, not Fail *) with_strategy0 opaque [idn] idtac. + Fail (* should work, not Fail *) with_strategy0 0 [idn] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + Fail (* should work, not Fail *) with_strategy0 1 [idn] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + Fail (* should work, not Fail *) with_strategy0 -1 [idn] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + Fail (* should work, not Fail *) with_strategy0 opaque [idn] idtac. + assert_fails unfold_id. + Fail (* should work, not Fail *) with_strategy0 transparent [idn] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + Fail (* should work, not Fail *) with_strategy0 opaque [idn] idtac. + Fail (* should work, not Fail *) with_strategy0 expand [idn] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + reflexivity. +Qed. + +(* [with_strategy1] should work, but it doesn't, due to a combination of https://github.com/coq/coq/issues/11202 and https://github.com/coq/coq/issues/11209 *) +Opaque id. +Goal id 0 = 0. + Fail (* should work, not Fail *) with_strategy1 opaque [id] idtac. + Fail (* should work, not Fail *) with_strategy1 opaque [id id] idtac. + assert_fails unfold_id. + Fail (* should work, not Fail *) with_strategy1 transparent [id] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + Fail (* should work, not Fail *) with_strategy1 opaque [id] idtac. + Fail (* should work, not Fail *) with_strategy1 0 [id] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + Fail (* should work, not Fail *) with_strategy1 1 [id] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + Fail (* should work, not Fail *) with_strategy1 -1 [id] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + Fail (* should work, not Fail *) with_strategy1 opaque [id] idtac. + assert_fails unfold_id. + Fail (* should work, not Fail *) with_strategy1 transparent [id] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + Fail (* should work, not Fail *) with_strategy1 opaque [id] idtac. + Fail (* should work, not Fail *) with_strategy1 expand [id] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + Fail (* should work, not Fail *) let l := strategy_level:(expand) in + with_strategy1 l [id] idtac. + (* This should succeed, but doesn't, basically due to https://github idtac.com/coq/coq/issues/11202 *) + Fail let idx := smart_global:(id) in + with_strategy1 expand [idx] idtac. + reflexivity. +Qed. +Goal id 0 = 0. + Fail (* should work, not Fail *) with_strategy1 opaque [aid] idtac. + assert_fails unfold_id. + Fail (* should work, not Fail *) with_strategy1 transparent [aid] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + Fail (* should work, not Fail *) with_strategy1 opaque [aid] idtac. + Fail (* should work, not Fail *) with_strategy1 0 [aid] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + Fail (* should work, not Fail *) with_strategy1 1 [aid] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + Fail (* should work, not Fail *) with_strategy1 -1 [aid] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + Fail (* should work, not Fail *) with_strategy1 opaque [aid] idtac. + assert_fails unfold_id. + Fail (* should work, not Fail *) with_strategy1 transparent [aid] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + Fail (* should work, not Fail *) with_strategy1 opaque [aid] idtac. + Fail (* should work, not Fail *) with_strategy1 expand [aid] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + reflexivity. +Qed. +Goal id 0 = 0. + Fail (* should work, not Fail *) with_strategy1 opaque [idn] idtac. + assert_fails unfold_id. + Fail (* should work, not Fail *) with_strategy1 transparent [idn] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + Fail (* should work, not Fail *) with_strategy1 opaque [idn] idtac. + Fail (* should work, not Fail *) with_strategy1 0 [idn] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + Fail (* should work, not Fail *) with_strategy1 1 [idn] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + Fail (* should work, not Fail *) with_strategy1 -1 [idn] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + Fail (* should work, not Fail *) with_strategy1 opaque [idn] idtac. + assert_fails unfold_id. + Fail (* should work, not Fail *) with_strategy1 transparent [idn] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + Fail (* should work, not Fail *) with_strategy1 opaque [idn] idtac. + Fail (* should work, not Fail *) with_strategy1 expand [idn] idtac. + Fail (* should work, not Fail *) assert_succeeds unfold_id idtac. + reflexivity. +Qed. + +Opaque id. +Goal id 0 = 0. + with_strategy2 + opaque [id] + (with_strategy2 + opaque [id] + (assert_fails unfold_id; + with_strategy2 + transparent [id] + (assert_succeeds unfold_id; + with_strategy2 + opaque [id] + (with_strategy2 + 0 [id] + (assert_succeeds unfold_id; + with_strategy2 + 1 [id] + (assert_succeeds unfold_id; + with_strategy2 + -1 [id] + (assert_succeeds unfold_id; + with_strategy2 + opaque [id] + (assert_fails unfold_id; + with_strategy2 + transparent [id] + (assert_succeeds unfold_id; + with_strategy2 + opaque [id] + (with_strategy2 + expand [id] + (assert_succeeds unfold_id))))))))))). + (* This should succeed, but doesn't, basically due to https://github.com/coq/coq/issues/11202 *) + Fail let idx := smart_global:(id) in + with_strategy2 expand [idx] idtac. + reflexivity. +Qed. +Goal id 0 = 0. + with_strategy2 + opaque [aid] + (with_strategy2 + opaque [aid] + (assert_fails unfold_id; + with_strategy2 + transparent [aid] + (assert_succeeds unfold_id; + with_strategy2 + opaque [aid] + (with_strategy2 + 0 [aid] + (assert_succeeds unfold_id; + with_strategy2 + 1 [aid] + (assert_succeeds unfold_id; + with_strategy2 + -1 [aid] + (assert_succeeds unfold_id; + with_strategy2 + opaque [aid] + (assert_fails unfold_id; + with_strategy2 + transparent [aid] + (assert_succeeds unfold_id; + with_strategy2 + opaque [aid] + (with_strategy2 + expand [aid] + (assert_succeeds unfold_id))))))))))). + reflexivity. +Qed. +Goal id 0 = 0. + with_strategy2 + opaque [idn] + (with_strategy2 + opaque [idn] + (assert_fails unfold_id; + with_strategy2 + transparent [idn] + (assert_succeeds unfold_id; + with_strategy2 + opaque [idn] + (with_strategy2 + 0 [idn] + (assert_succeeds unfold_id; + with_strategy2 + 1 [idn] + (assert_succeeds unfold_id; + with_strategy2 + -1 [idn] + (assert_succeeds unfold_id; + with_strategy2 + opaque [idn] + (assert_fails unfold_id; + with_strategy2 + transparent [idn] + (assert_succeeds unfold_id; + with_strategy2 + opaque [idn] + (with_strategy2 + expand [idn] + (assert_succeeds unfold_id))))))))))). + reflexivity. +Qed. + +Opaque id. +Goal id 0 = 0. + with_strategy3 + opaque [id] + (with_strategy3 + opaque [id] + (assert_fails unfold_id; + with_strategy3 + transparent [id] + (assert_succeeds unfold_id; + with_strategy3 + opaque [id] + (with_strategy3 + 0 [id] + (assert_succeeds unfold_id; + with_strategy3 + 1 [id] + (assert_succeeds unfold_id; + with_strategy3 + -1 [id] + (assert_succeeds unfold_id; + with_strategy3 + opaque [id] + (assert_fails unfold_id; + with_strategy3 + transparent [id] + (assert_succeeds unfold_id; + with_strategy3 + opaque [id] + (with_strategy3 + expand [id] + (assert_succeeds unfold_id))))))))))). + (* This should succeed, but doesn't, basically due to https://github.com/coq/coq/issues/11202 *) + Fail let idx := smart_global:(id) in + with_strategy3 expand [idx] idtac. + reflexivity. +Qed. +Goal id 0 = 0. + with_strategy3 + opaque [aid] + (with_strategy3 + opaque [aid] + (assert_fails unfold_id; + with_strategy3 + transparent [aid] + (assert_succeeds unfold_id; + with_strategy3 + opaque [aid] + (with_strategy3 + 0 [aid] + (assert_succeeds unfold_id; + with_strategy3 + 1 [aid] + (assert_succeeds unfold_id; + with_strategy3 + -1 [aid] + (assert_succeeds unfold_id; + with_strategy3 + opaque [aid] + (assert_fails unfold_id; + with_strategy3 + transparent [aid] + (assert_succeeds unfold_id; + with_strategy3 + opaque [aid] + (with_strategy3 + expand [aid] + (assert_succeeds unfold_id))))))))))). + reflexivity. +Qed. +Goal id 0 = 0. + with_strategy3 + opaque [idn] + (with_strategy3 + opaque [idn] + (assert_fails unfold_id; + with_strategy3 + transparent [idn] + (assert_succeeds unfold_id; + with_strategy3 + opaque [idn] + (with_strategy3 + 0 [idn] + (assert_succeeds unfold_id; + with_strategy3 + 1 [idn] + (assert_succeeds unfold_id; + with_strategy3 + -1 [idn] + (assert_succeeds unfold_id; + with_strategy3 + opaque [idn] + (assert_fails unfold_id; + with_strategy3 + transparent [idn] + (assert_succeeds unfold_id; + with_strategy3 + opaque [idn] + (with_strategy3 + expand [idn] + (assert_succeeds unfold_id))))))))))). + reflexivity. +Qed. + +(* Fake out coqchk to work around what is essentially COQBUG(https://github.com/coq/coq/issues/12200) *) +Reset Initial. diff --git a/theories/Bool/Bool.v b/theories/Bool/Bool.v index 57cc8c4e90..d70978fabe 100644 --- a/theories/Bool/Bool.v +++ b/theories/Bool/Bool.v @@ -82,34 +82,39 @@ Qed. (** * Order on booleans *) (************************) -Definition leb (b1 b2:bool) := +#[ local ] Definition le (b1 b2:bool) := match b1 with | true => b2 = true | false => True end. -Hint Unfold leb: bool. +Hint Unfold le: bool. -Lemma leb_implb : forall b1 b2, leb b1 b2 <-> implb b1 b2 = true. +Lemma le_implb : forall b1 b2, le b1 b2 <-> implb b1 b2 = true. Proof. destr_bool; intuition. Qed. -Definition ltb (b1 b2:bool) := +#[deprecated(since="8.12",note="Use Bool.le instead.")] +Notation leb := le (only parsing). +#[deprecated(since="8.12",note="Use Bool.le_implb instead.")] +Notation leb_implb := le_implb (only parsing). + +#[ local ] Definition lt (b1 b2:bool) := match b1 with | true => False | false => b2 = true end. -Hint Unfold ltb: bool. +Hint Unfold lt: bool. -Definition compareb (b1 b2 : bool) := +#[ local ] Definition compare (b1 b2 : bool) := match b1, b2 with | false, true => Lt | true, false => Gt | _, _ => Eq end. -Lemma compareb_spec : forall b1 b2, - CompareSpec (b1 = b2) (ltb b1 b2) (ltb b2 b1) (compareb b1 b2). +Lemma compare_spec : forall b1 b2, + CompareSpec (b1 = b2) (lt b1 b2) (lt b2 b1) (compare b1 b2). Proof. destr_bool; auto. Qed. @@ -935,8 +940,8 @@ Defined. (** Notations *) Module BoolNotations. -Infix "<=" := leb : bool_scope. -Infix "<" := ltb : bool_scope. -Infix "?=" := compareb (at level 70) : bool_scope. +Infix "<=" := le : bool_scope. +Infix "<" := lt : bool_scope. +Infix "?=" := compare (at level 70) : bool_scope. Infix "=?" := eqb (at level 70) : bool_scope. End BoolNotations. diff --git a/theories/Bool/BoolOrder.v b/theories/Bool/BoolOrder.v index 61aab607a9..aaa7321bfc 100644 --- a/theories/Bool/BoolOrder.v +++ b/theories/Bool/BoolOrder.v @@ -14,69 +14,65 @@ Require Export Bool. Require Import Orders. - -Local Notation le := Bool.leb. -Local Notation lt := Bool.ltb. -Local Notation compare := Bool.compareb. -Local Notation compare_spec := Bool.compareb_spec. +Import BoolNotations. (** * Order [le] *) -Lemma le_refl : forall b, le b b. +Lemma le_refl : forall b, b <= b. Proof. destr_bool. Qed. Lemma le_trans : forall b1 b2 b3, - le b1 b2 -> le b2 b3 -> le b1 b3. + b1 <= b2 -> b2 <= b3 -> b1 <= b3. Proof. destr_bool. Qed. -Lemma le_true : forall b, le b true. +Lemma le_true : forall b, b <= true. Proof. destr_bool. Qed. -Lemma false_le : forall b, le false b. +Lemma false_le : forall b, false <= b. Proof. intros; constructor. Qed. -Instance le_compat : Proper (eq ==> eq ==> iff) le. +Instance le_compat : Proper (eq ==> eq ==> iff) Bool.le. Proof. intuition. Qed. (** * Strict order [lt] *) -Lemma lt_irrefl : forall b, ~ lt b b. +Lemma lt_irrefl : forall b, ~ b < b. Proof. destr_bool; auto. Qed. Lemma lt_trans : forall b1 b2 b3, - lt b1 b2 -> lt b2 b3 -> lt b1 b3. + b1 < b2 -> b2 < b3 -> b1 < b3. Proof. destr_bool; auto. Qed. -Instance lt_compat : Proper (eq ==> eq ==> iff) lt. +Instance lt_compat : Proper (eq ==> eq ==> iff) Bool.lt. Proof. intuition. Qed. -Lemma lt_trichotomy : forall b1 b2, { lt b1 b2 } + { b1 = b2 } + { lt b2 b1 }. +Lemma lt_trichotomy : forall b1 b2, { b1 < b2 } + { b1 = b2 } + { b2 < b1 }. Proof. destr_bool; auto. Qed. -Lemma lt_total : forall b1 b2, lt b1 b2 \/ b1 = b2 \/ lt b2 b1. +Lemma lt_total : forall b1 b2, b1 < b2 \/ b1 = b2 \/ b2 < b1. Proof. destr_bool; auto. Qed. -Lemma lt_le_incl : forall b1 b2, lt b1 b2 -> le b1 b2. +Lemma lt_le_incl : forall b1 b2, b1 < b2 -> b1 <= b2. Proof. destr_bool; auto. Qed. -Lemma le_lteq_dec : forall b1 b2, le b1 b2 -> { lt b1 b2 } + { b1 = b2 }. +Lemma le_lteq_dec : forall b1 b2, b1 <= b2 -> { b1 < b2 } + { b1 = b2 }. Proof. destr_bool; auto. Qed. -Lemma le_lteq : forall b1 b2, le b1 b2 <-> lt b1 b2 \/ b1 = b2. +Lemma le_lteq : forall b1 b2, b1 <= b2 <-> b1 < b2 \/ b1 = b2. Proof. destr_bool; intuition. Qed. (** * Order structures *) (* Class structure *) -Instance le_preorder : PreOrder le. +Instance le_preorder : PreOrder Bool.le. Proof. split. - intros b; apply le_refl. - intros b1 b2 b3; apply le_trans. Qed. -Instance lt_strorder : StrictOrder lt. +Instance lt_strorder : StrictOrder Bool.lt. Proof. split. - intros b; apply lt_irrefl. @@ -88,13 +84,13 @@ Module BoolOrd <: UsualDecidableTypeFull <: OrderedTypeFull <: TotalOrder. Definition t := bool. Definition eq := @eq bool. Definition eq_equiv := @eq_equivalence bool. - Definition lt := lt. + Definition lt := Bool.lt. Definition lt_strorder := lt_strorder. Definition lt_compat := lt_compat. - Definition le := le. + Definition le := Bool.le. Definition le_lteq := le_lteq. Definition lt_total := lt_total. - Definition compare := compare. + Definition compare := Bool.compare. Definition compare_spec := compare_spec. Definition eq_dec := bool_dec. Definition eq_refl := @eq_Reflexive bool. diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index f789e966f5..cba90043d5 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -21,6 +21,8 @@ Require Import Logic. Inductive Empty_set : Set :=. +Register Empty_set as core.Empty_set.type. + (** [unit] is a singleton datatype with sole inhabitant [tt] *) Inductive unit : Set := @@ -141,6 +143,9 @@ Inductive BoolSpec (P Q : Prop) : bool -> Prop := | BoolSpecF : Q -> BoolSpec P Q false. Hint Constructors BoolSpec : core. +Register BoolSpec as core.BoolSpec.type. +Register BoolSpecT as core.BoolSpec.BoolSpecT. +Register BoolSpecF as core.BoolSpec.BoolSpecF. (********************************************************************) (** * Peano natural numbers *) @@ -373,6 +378,11 @@ Inductive CompareSpec (Peq Plt Pgt : Prop) : comparison -> Prop := | CompGt : Pgt -> CompareSpec Peq Plt Pgt Gt. Hint Constructors CompareSpec : core. +Register CompareSpec as core.CompareSpec.type. +Register CompEq as core.CompareSpec.CompEq. +Register CompLt as core.CompareSpec.CompLt. +Register CompGt as core.CompareSpec.CompGt. + (** For having clean interfaces after extraction, [CompareSpec] is declared in Prop. For some situations, it is nonetheless useful to have a version in Type. Interestingly, these two versions are equivalent. *) @@ -383,6 +393,11 @@ Inductive CompareSpecT (Peq Plt Pgt : Prop) : comparison -> Type := | CompGtT : Pgt -> CompareSpecT Peq Plt Pgt Gt. Hint Constructors CompareSpecT : core. +Register CompareSpecT as core.CompareSpecT.type. +Register CompEqT as core.CompareSpecT.CompEqT. +Register CompLtT as core.CompareSpecT.CompLtT. +Register CompGtT as core.CompareSpecT.CompGtT. + Lemma CompareSpec2Type : forall Peq Plt Pgt c, CompareSpec Peq Plt Pgt c -> CompareSpecT Peq Plt Pgt c. Proof. diff --git a/theories/Program/Syntax.v b/theories/Program/Syntax.v index 03401aea2b..7a8ddbe71e 100644 --- a/theories/Program/Syntax.v +++ b/theories/Program/Syntax.v @@ -30,7 +30,4 @@ Arguments snd {A B} _. Arguments nil {A}. Arguments cons {A} _ _. -Require List. -Export List.ListNotations. - Require Import Bvector. diff --git a/theories/Reals/Abstract/ConstructiveAbs.v b/theories/Reals/Abstract/ConstructiveAbs.v index d357ad2d54..31397cbddd 100644 --- a/theories/Reals/Abstract/ConstructiveAbs.v +++ b/theories/Reals/Abstract/ConstructiveAbs.v @@ -57,11 +57,11 @@ Proof. - pose proof (CRabs_def R x (CRabs R x)) as [_ H1]. apply H1, CRle_refl. - rewrite <- CRabs_def. split. apply CRle_refl. - apply (CRle_trans _ (CRzero R)). 2: exact H. - apply (CRle_trans _ (CRopp R (CRzero R))). + apply (CRle_trans _ 0). 2: exact H. + apply (CRle_trans _ (CRopp R 0)). intro abs. apply CRopp_lt_cancel in abs. contradiction. - apply (CRplus_le_reg_l (CRzero R)). - apply (CRle_trans _ (CRzero R)). apply CRplus_opp_r. + apply (CRplus_le_reg_l 0). + apply (CRle_trans _ 0). apply CRplus_opp_r. apply CRplus_0_r. Qed. @@ -164,8 +164,7 @@ Lemma CR_of_Q_abs : forall {R : ConstructiveReals} (q : Q), Proof. intros. destruct (Qlt_le_dec 0 q). - apply (CReq_trans _ (CR_of_Q R q)). - apply CRabs_right. apply (CRle_trans _ (CR_of_Q R 0)). - apply CR_of_Q_zero. apply CR_of_Q_le. apply Qlt_le_weak, q0. + apply CRabs_right. apply CR_of_Q_le. apply Qlt_le_weak, q0. apply CR_of_Q_morph. symmetry. apply Qabs_pos, Qlt_le_weak, q0. - apply (CReq_trans _ (CR_of_Q R (-q))). apply (CReq_trans _ (CRabs R (CRopp R (CR_of_Q R q)))). @@ -173,8 +172,7 @@ Proof. 2: apply CR_of_Q_morph; symmetry; apply Qabs_neg, q0. apply (CReq_trans _ (CRopp R (CR_of_Q R q))). 2: apply CReq_sym, CR_of_Q_opp. - apply CRabs_right. apply (CRle_trans _ (CR_of_Q R 0)). - apply CR_of_Q_zero. + apply CRabs_right. apply (CRle_trans _ (CR_of_Q R (-q))). apply CR_of_Q_le. apply (Qplus_le_l _ _ q). ring_simplify. exact q0. apply CR_of_Q_opp. @@ -206,14 +204,14 @@ Proof. destruct (CR_Q_dense R _ _ neg) as [q [H0 H1]]. destruct (Qlt_le_dec 0 q). - destruct (s (CR_of_Q R (-q)) x 0). - rewrite <- CR_of_Q_zero. apply CR_of_Q_lt. + apply CR_of_Q_lt. apply (Qplus_lt_l _ _ q). ring_simplify. exact q0. exfalso. pose proof (CRabs_def R x (CR_of_Q R q)) as [H2 _]. apply H2. clear H2. split. apply CRlt_asym, H0. 2: exact H1. rewrite <- Qopp_involutive, CR_of_Q_opp. apply CRopp_ge_le_contravar, CRlt_asym, c. exact c. - apply (CRlt_le_trans _ _ _ H0). - rewrite <- CR_of_Q_zero. apply CR_of_Q_le. exact q0. + apply CR_of_Q_le. exact q0. Qed. @@ -339,24 +337,23 @@ Proof. left; apply CR_of_Q_pos; reflexivity. rewrite CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CR_of_Q_one, CRmult_1_r. - rewrite (CR_of_Q_plus R 1 1), CR_of_Q_one, CRmult_plus_distr_l, CRmult_1_r. + rewrite CRmult_1_r. + rewrite (CR_of_Q_plus R 1 1), CRmult_plus_distr_l, CRmult_1_r. rewrite CRabs_right. unfold CRminus. rewrite CRopp_plus_distr, CRplus_assoc, <- (CRplus_assoc y). rewrite CRplus_opp_r, CRplus_0_l, CRopp_involutive. reflexivity. apply (CRmult_lt_compat_r (CR_of_Q R 2)) in H. 2: apply CR_of_Q_pos; reflexivity. - rewrite CRmult_assoc, <- CR_of_Q_mult in H. - setoid_replace ((1 # 2) * 2)%Q with 1%Q in H. 2: reflexivity. - rewrite CR_of_Q_one, CRmult_1_r in H. - rewrite CRmult_comm, (CR_of_Q_plus R 1 1), CR_of_Q_one, CRmult_plus_distr_r, - CRmult_1_l in H. - intro abs. rewrite CRabs_left in H. - unfold CRminus in H. - rewrite CRopp_involutive, CRplus_comm in H. - rewrite CRplus_assoc, <- (CRplus_assoc (-x)), CRplus_opp_l in H. - rewrite CRplus_0_l in H. exact (CRlt_asym _ _ H H). - apply CRlt_asym, abs. + intro abs. contradict H. + apply (CRle_trans _ (x + y - CRabs R (y - x))). + rewrite CRabs_left. 2: apply CRlt_asym, abs. + unfold CRminus. rewrite CRopp_involutive, CRplus_comm. + rewrite CRplus_assoc, <- (CRplus_assoc (-x)), CRplus_opp_l. + rewrite CRplus_0_l, (CR_of_Q_plus R 1 1), CRmult_plus_distr_l. + rewrite CRmult_1_r. apply CRle_refl. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CRmult_1_r. apply CRle_refl. Qed. Add Parametric Morphism {R : ConstructiveReals} : CRmin @@ -383,11 +380,11 @@ Lemma CRmin_l : forall {R : ConstructiveReals} (x y : CRcarrier R), Proof. intros. unfold CRmin. apply (CRmult_le_reg_r (CR_of_Q R 2)). - rewrite <- CR_of_Q_zero. apply CR_of_Q_lt; reflexivity. + apply CR_of_Q_lt; reflexivity. rewrite CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CR_of_Q_one, CRmult_1_r. - rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CR_of_Q_one, CRmult_1_r. + rewrite CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CRmult_1_r. unfold CRminus. rewrite CRplus_assoc. apply CRplus_le_compat_l. apply (CRplus_le_reg_r (CRabs _ (y + - x)+ -x)). rewrite CRplus_assoc, <- (CRplus_assoc (-CRabs _ (y + - x))). @@ -401,11 +398,11 @@ Lemma CRmin_r : forall {R : ConstructiveReals} (x y : CRcarrier R), Proof. intros. unfold CRmin. apply (CRmult_le_reg_r (CR_of_Q R 2)). - rewrite <- CR_of_Q_zero. apply CR_of_Q_lt; reflexivity. + apply CR_of_Q_lt; reflexivity. rewrite CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CR_of_Q_one, CRmult_1_r. - rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CR_of_Q_one, CRmult_1_r. + rewrite CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CRmult_1_r. rewrite (CRplus_comm x). unfold CRminus. rewrite CRplus_assoc. apply CRplus_le_compat_l. apply (CRplus_le_reg_l (-x)). @@ -451,15 +448,15 @@ Proof. intros. unfold CRmin. unfold CRminus. setoid_replace (x + z + - (x + y)) with (z-y). apply (CRmult_eq_reg_r (CR_of_Q _ 2)). - left. rewrite <- CR_of_Q_zero. apply CR_of_Q_lt; reflexivity. + left. apply CR_of_Q_lt; reflexivity. rewrite CRmult_plus_distr_r. rewrite CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CR_of_Q_one, CRmult_1_r. + rewrite CRmult_1_r. rewrite CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CR_of_Q_one, CRmult_1_r. - rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CR_of_Q_one, CRmult_1_r. + rewrite CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CRmult_1_r. do 3 rewrite (CRplus_assoc x). apply CRplus_morph. reflexivity. do 2 rewrite <- CRplus_assoc. apply CRplus_morph. 2: reflexivity. rewrite (CRplus_comm x). apply CRplus_assoc. @@ -474,11 +471,11 @@ Lemma CRmin_left : forall {R : ConstructiveReals} (x y : CRcarrier R), Proof. intros. unfold CRmin. apply (CRmult_eq_reg_r (CR_of_Q R 2)). - left. rewrite <- CR_of_Q_zero. apply CR_of_Q_lt; reflexivity. + left. apply CR_of_Q_lt; reflexivity. rewrite CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CR_of_Q_one, CRmult_1_r. - rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CR_of_Q_one, CRmult_1_r. + rewrite CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CRmult_1_r. rewrite CRabs_right. unfold CRminus. rewrite CRopp_plus_distr. rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. apply CRopp_involutive. @@ -491,11 +488,11 @@ Lemma CRmin_right : forall {R : ConstructiveReals} (x y : CRcarrier R), Proof. intros. unfold CRmin. apply (CRmult_eq_reg_r (CR_of_Q R 2)). - left. rewrite <- CR_of_Q_zero. apply CR_of_Q_lt; reflexivity. + left. apply CR_of_Q_lt; reflexivity. rewrite CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CR_of_Q_one, CRmult_1_r. - rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CR_of_Q_one, CRmult_1_r. + rewrite CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CRmult_1_r. rewrite CRabs_left. unfold CRminus. do 2 rewrite CRopp_plus_distr. rewrite (CRplus_comm x y). rewrite CRplus_assoc. apply CRplus_morph. reflexivity. @@ -510,10 +507,10 @@ Lemma CRmin_lt : forall {R : ConstructiveReals} (x y z : CRcarrier R), Proof. intros. unfold CRmin. apply (CRmult_lt_reg_r (CR_of_Q R 2)). - rewrite <- CR_of_Q_zero. apply CR_of_Q_lt; reflexivity. + apply CR_of_Q_lt; reflexivity. rewrite CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CR_of_Q_one, CRmult_1_r. + rewrite CRmult_1_r. apply (CRplus_lt_reg_l _ (CRabs _ (y - x) - (z*CR_of_Q R 2))). unfold CRminus. rewrite CRplus_assoc. rewrite CRplus_opp_l, CRplus_0_r. rewrite (CRplus_comm (CRabs R (y + - x))). @@ -526,7 +523,7 @@ Proof. apply (CRplus_lt_reg_l R (-x)). rewrite CRopp_mult_distr_l. rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. - rewrite (CR_of_Q_plus R 1 1), CR_of_Q_one, CRmult_plus_distr_l. + rewrite (CR_of_Q_plus R 1 1), CRmult_plus_distr_l. rewrite CRmult_1_r. apply CRplus_le_lt_compat. apply CRlt_asym. apply CRopp_gt_lt_contravar, H. @@ -537,7 +534,7 @@ Proof. apply (CRplus_lt_reg_l R (-y)). rewrite CRopp_mult_distr_l. rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. - rewrite (CR_of_Q_plus R 1 1), CR_of_Q_one, CRmult_plus_distr_l. + rewrite (CR_of_Q_plus R 1 1), CRmult_plus_distr_l. rewrite CRmult_1_r. apply CRplus_le_lt_compat. apply CRlt_asym. apply CRopp_gt_lt_contravar, H0. @@ -552,12 +549,12 @@ Proof. rewrite (CRabs_morph _ ((x - y + (CRabs _ (a - y) - CRabs _ (a - x))) * CR_of_Q R (1 # 2))). rewrite CRabs_mult, (CRabs_right (CR_of_Q R (1 # 2))). - 2: rewrite <- CR_of_Q_zero; apply CR_of_Q_le; discriminate. + 2: apply CR_of_Q_le; discriminate. apply (CRle_trans _ ((CRabs _ (x - y) * 1 + CRabs _ (x-y) * 1) * CR_of_Q R (1 # 2))). apply CRmult_le_compat_r. - rewrite <- CR_of_Q_zero. apply CR_of_Q_le. discriminate. + apply CR_of_Q_le. discriminate. apply (CRle_trans _ (CRabs _ (x - y) + CRabs _ (CRabs _ (a - y) - CRabs _ (a - x)))). apply CRabs_triang. rewrite CRmult_1_r. apply CRplus_le_compat_l. @@ -568,11 +565,11 @@ Proof. rewrite CRplus_comm, CRopp_plus_distr, <- CRplus_assoc. rewrite CRplus_opp_r, CRopp_involutive, CRplus_0_l. reflexivity. - rewrite <- CRmult_plus_distr_l, <- CR_of_Q_one. + rewrite <- CRmult_plus_distr_l. rewrite <- (CR_of_Q_plus R 1 1). rewrite CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1 + 1) * (1 # 2))%Q with 1%Q. 2: reflexivity. - rewrite CR_of_Q_one, CRmult_1_r. apply CRle_refl. + rewrite CRmult_1_r. apply CRle_refl. unfold CRminus. apply CRmult_morph. 2: reflexivity. do 4 rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite <- CRplus_assoc. rewrite CRplus_comm, CRopp_plus_distr. @@ -587,10 +584,10 @@ Lemma CRmin_glb : forall {R : ConstructiveReals} (x y z:CRcarrier R), Proof. intros. unfold CRmin. apply (CRmult_le_reg_r (CR_of_Q R 2)). - rewrite <- CR_of_Q_zero. apply CR_of_Q_lt; reflexivity. + apply CR_of_Q_lt; reflexivity. rewrite CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CR_of_Q_one, CRmult_1_r. + rewrite CRmult_1_r. apply (CRplus_le_reg_l (CRabs _ (y-x) - (z*CR_of_Q R 2))). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. rewrite (CRplus_comm (CRabs R (y + - x) + - (z * CR_of_Q R 2))). @@ -601,13 +598,13 @@ Proof. rewrite CRopp_involutive, (CRplus_comm y), CRplus_assoc. apply CRplus_le_compat_l, (CRplus_le_reg_l y). rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. - rewrite (CR_of_Q_plus R 1 1), CR_of_Q_one, CRmult_plus_distr_l. + rewrite (CR_of_Q_plus R 1 1), CRmult_plus_distr_l. rewrite CRmult_1_r. apply CRplus_le_compat; exact H0. - rewrite (CRplus_comm x), CRplus_assoc. apply CRplus_le_compat_l. apply (CRplus_le_reg_l (-x)). rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. rewrite CRopp_mult_distr_l. - rewrite (CR_of_Q_plus R 1 1), CR_of_Q_one, CRmult_plus_distr_l. + rewrite (CR_of_Q_plus R 1 1), CRmult_plus_distr_l. rewrite CRmult_1_r. apply CRplus_le_compat; apply CRopp_ge_le_contravar; exact H. Qed. @@ -673,11 +670,11 @@ Lemma CRmax_lub : forall {R : ConstructiveReals} (x y z:CRcarrier R), x <= z -> y <= z -> CRmax x y <= z. Proof. intros. unfold CRmax. - apply (CRmult_le_reg_r (CR_of_Q _ 2)). rewrite <- CR_of_Q_zero. + apply (CRmult_le_reg_r (CR_of_Q _ 2)). apply CR_of_Q_lt; reflexivity. rewrite CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CR_of_Q_one, CRmult_1_r. + rewrite CRmult_1_r. apply (CRplus_le_reg_l (-x-y)). rewrite <- CRplus_assoc. unfold CRminus. rewrite <- CRopp_plus_distr, CRplus_opp_l, CRplus_0_l. @@ -687,14 +684,14 @@ Proof. rewrite (CRplus_comm x), CRplus_assoc. apply CRplus_le_compat_l. apply (CRplus_le_reg_l (-x)). rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. - rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CR_of_Q_one, CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CRmult_1_r. rewrite CRopp_plus_distr. apply CRplus_le_compat; apply CRopp_ge_le_contravar; assumption. - rewrite (CRplus_comm y), CRopp_plus_distr, CRplus_assoc. apply CRplus_le_compat_l. apply (CRplus_le_reg_l y). rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. - rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CR_of_Q_one, CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CRmult_1_r. apply CRplus_le_compat; assumption. Qed. @@ -702,12 +699,12 @@ Lemma CRmax_l : forall {R : ConstructiveReals} (x y : CRcarrier R), x <= CRmax x y. Proof. intros. unfold CRmax. - apply (CRmult_le_reg_r (CR_of_Q R 2)). rewrite <- CR_of_Q_zero. + apply (CRmult_le_reg_r (CR_of_Q R 2)). apply CR_of_Q_lt; reflexivity. rewrite CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CR_of_Q_one, CRmult_1_r. - setoid_replace 2%Q with (1+1)%Q. rewrite CR_of_Q_plus, CR_of_Q_one. + rewrite CRmult_1_r. + setoid_replace 2%Q with (1+1)%Q. rewrite CR_of_Q_plus. rewrite CRmult_plus_distr_l, CRmult_1_r, CRplus_assoc. apply CRplus_le_compat_l. apply (CRplus_le_reg_l (-y)). @@ -720,12 +717,12 @@ Lemma CRmax_r : forall {R : ConstructiveReals} (x y : CRcarrier R), y <= CRmax x y. Proof. intros. unfold CRmax. - apply (CRmult_le_reg_r (CR_of_Q _ 2)). rewrite <- CR_of_Q_zero. + apply (CRmult_le_reg_r (CR_of_Q _ 2)). apply CR_of_Q_lt; reflexivity. rewrite CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CR_of_Q_one, CRmult_1_r. - rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CR_of_Q_one, CRmult_1_r. + rewrite CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CRmult_1_r. rewrite (CRplus_comm x). rewrite CRplus_assoc. apply CRplus_le_compat_l. apply (CRplus_le_reg_l (-x)). @@ -754,14 +751,14 @@ Proof. intros. unfold CRmax. setoid_replace (x + z - (x + y)) with (z-y). apply (CRmult_eq_reg_r (CR_of_Q _ 2)). - left. rewrite <- CR_of_Q_zero. apply CR_of_Q_lt; reflexivity. + left. apply CR_of_Q_lt; reflexivity. rewrite CRmult_plus_distr_r. rewrite CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CR_of_Q_one, CRmult_1_r. + rewrite CRmult_1_r. rewrite CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CR_of_Q_one, CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CRmult_1_r. rewrite CRmult_1_r. do 3 rewrite (CRplus_assoc x). apply CRplus_morph. reflexivity. do 2 rewrite <- CRplus_assoc. apply CRplus_morph. 2: reflexivity. @@ -777,11 +774,11 @@ Lemma CRmax_left : forall {R : ConstructiveReals} (x y : CRcarrier R), Proof. intros. unfold CRmax. apply (CRmult_eq_reg_r (CR_of_Q R 2)). - left. rewrite <- CR_of_Q_zero. apply CR_of_Q_lt; reflexivity. + left. apply CR_of_Q_lt; reflexivity. rewrite CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CR_of_Q_one, CRmult_1_r. - rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CR_of_Q_one, CRmult_1_r. + rewrite CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CRmult_1_r. rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite CRabs_left. unfold CRminus. rewrite CRopp_plus_distr, CRopp_involutive. rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. reflexivity. @@ -793,11 +790,11 @@ Lemma CRmax_right : forall {R : ConstructiveReals} (x y : CRcarrier R), Proof. intros. unfold CRmax. apply (CRmult_eq_reg_r (CR_of_Q R 2)). - left. rewrite <- CR_of_Q_zero. apply CR_of_Q_lt; reflexivity. + left. apply CR_of_Q_lt; reflexivity. rewrite CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CR_of_Q_one, CRmult_1_r. - rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CR_of_Q_one, CRmult_1_r. + rewrite CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CRmult_1_r. rewrite (CRplus_comm x y). rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite CRabs_right. unfold CRminus. rewrite CRplus_comm. @@ -812,12 +809,12 @@ Proof. rewrite (CRabs_morph _ ((x - y + (CRabs _ (a - x) - CRabs _ (a - y))) * CR_of_Q R (1 # 2))). rewrite CRabs_mult, (CRabs_right (CR_of_Q R (1 # 2))). - 2: rewrite <- CR_of_Q_zero; apply CR_of_Q_le; discriminate. + 2: apply CR_of_Q_le; discriminate. apply (CRle_trans _ ((CRabs _ (x - y) * 1 + CRabs _ (x-y) * 1) * CR_of_Q R (1 # 2))). apply CRmult_le_compat_r. - rewrite <- CR_of_Q_zero. apply CR_of_Q_le. discriminate. + apply CR_of_Q_le. discriminate. apply (CRle_trans _ (CRabs _ (x - y) + CRabs _ (CRabs _ (a - x) - CRabs _ (a - y)))). apply CRabs_triang. rewrite CRmult_1_r. apply CRplus_le_compat_l. @@ -829,11 +826,11 @@ Proof. rewrite CRplus_comm, CRopp_plus_distr, <- CRplus_assoc. rewrite CRplus_opp_r, CRopp_involutive, CRplus_0_l. reflexivity. - rewrite <- CRmult_plus_distr_l, <- CR_of_Q_one. + rewrite <- CRmult_plus_distr_l. rewrite <- (CR_of_Q_plus R 1 1). rewrite CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1 + 1) * (1 # 2))%Q with 1%Q. 2: reflexivity. - rewrite CR_of_Q_one, CRmult_1_r. apply CRle_refl. + rewrite CRmult_1_r. apply CRle_refl. unfold CRminus. rewrite CRopp_mult_distr_l. rewrite <- CRmult_plus_distr_r. apply CRmult_morph. 2: reflexivity. do 4 rewrite CRplus_assoc. apply CRplus_morph. reflexivity. @@ -849,10 +846,10 @@ Lemma CRmax_lub_lt : forall {R : ConstructiveReals} (x y z : CRcarrier R), Proof. intros. unfold CRmax. apply (CRmult_lt_reg_r (CR_of_Q R 2)). - rewrite <- CR_of_Q_zero. apply CR_of_Q_lt; reflexivity. + apply CR_of_Q_lt; reflexivity. rewrite CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CR_of_Q_one, CRmult_1_r. + rewrite CRmult_1_r. apply (CRplus_lt_reg_l _ (-y -x)). unfold CRminus. rewrite CRplus_assoc, <- (CRplus_assoc (-x)), <- (CRplus_assoc (-x)). rewrite CRplus_opp_l, CRplus_0_l, <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. @@ -861,14 +858,14 @@ Proof. apply CRplus_lt_compat_l. apply (CRplus_lt_reg_l _ y). rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. - rewrite (CR_of_Q_plus R 1 1), CR_of_Q_one, CRmult_plus_distr_l. + rewrite (CR_of_Q_plus R 1 1), CRmult_plus_distr_l. rewrite CRmult_1_r. apply CRplus_le_lt_compat. apply CRlt_asym, H0. exact H0. - rewrite CRopp_plus_distr, CRopp_involutive. rewrite CRplus_assoc. apply CRplus_lt_compat_l. apply (CRplus_lt_reg_l _ x). rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. - rewrite (CR_of_Q_plus R 1 1), CR_of_Q_one, CRmult_plus_distr_l. + rewrite (CR_of_Q_plus R 1 1), CRmult_plus_distr_l. rewrite CRmult_1_r. apply CRplus_le_lt_compat. apply CRlt_asym, H. exact H. Qed. diff --git a/theories/Reals/Abstract/ConstructiveLUB.v b/theories/Reals/Abstract/ConstructiveLUB.v index 4ae24de154..1c19c6aa40 100644 --- a/theories/Reals/Abstract/ConstructiveLUB.v +++ b/theories/Reals/Abstract/ConstructiveLUB.v @@ -108,7 +108,7 @@ Proof. rewrite Z.mul_1_l, Z.mul_1_l. apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le. rewrite Nat2Pos.id. apply le_S, H0. discriminate. - rewrite <- CR_of_Q_zero. apply CR_of_Q_le. discriminate. + apply CR_of_Q_le. discriminate. Qed. Lemma is_upper_bound_dec : @@ -272,7 +272,7 @@ Proof. apply CR_of_Q_pos. reflexivity. rewrite CRmult_assoc, <- CR_of_Q_mult, (CR_of_Q_plus R 1 1). setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CR_of_Q_one, CRmult_plus_distr_l, CRmult_1_r, CRmult_1_r. + rewrite CRmult_plus_distr_l, CRmult_1_r, CRmult_1_r. apply CRplus_lt_compat_r. exact H0. } destruct (CR_cv_open_below _ _ l lcv H1) as [p pmaj]. assert (0 < (l-CR_of_Q R r) * CR_of_Q R (1#2)). @@ -280,7 +280,6 @@ Proof. apply CRplus_lt_compat_r. exact H0. apply CR_of_Q_pos. reflexivity. } destruct (CRup_nat (CRinv R _ (inr H2))) as [i imaj]. destruct i. exfalso. simpl in imaj. - rewrite CR_of_Q_zero in imaj. exact (CRlt_asym _ _ imaj (CRinv_0_lt_compat R _ (inr H2) H2)). specialize (pmaj (max (S i) (S p)) (le_trans p (S p) _ (le_S p p (le_refl p)) (Nat.le_max_r (S i) (S p)))). unfold proj1_sig in pmaj. @@ -309,7 +308,7 @@ Proof. CR_of_Q R (1 # Pos.of_nat (S i)))). apply CRlt_asym, imaj. rewrite CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((Z.of_nat (S i) # 1) * (1 # Pos.of_nat (S i)))%Q with 1%Q. - rewrite CR_of_Q_one, CRmult_1_r. + rewrite CRmult_1_r. unfold CRminus. rewrite CRmult_plus_distr_r, (CRplus_comm (-CR_of_Q R r)). rewrite (CRplus_comm (CR_of_Q R r)), CRmult_plus_distr_r. rewrite CRplus_assoc. apply CRplus_le_compat_l. diff --git a/theories/Reals/Abstract/ConstructiveLimits.v b/theories/Reals/Abstract/ConstructiveLimits.v index 4a40cc8cb3..64dcd2e1ec 100644 --- a/theories/Reals/Abstract/ConstructiveLimits.v +++ b/theories/Reals/Abstract/ConstructiveLimits.v @@ -89,7 +89,7 @@ Lemma CR_cv_unique : forall {R : ConstructiveReals} (xn : nat -> CRcarrier R) -> CR_cv R xn b -> a == b. Proof. - intros. assert (CR_cv R (fun _ => CRzero R) (CRminus R b a)). + intros. assert (CR_cv R (fun _ => 0) (CRminus R b a)). { apply (CR_cv_extens (fun n => CRminus R (xn n) (xn n))). intro n. unfold CRminus. apply CRplus_opp_r. apply CR_cv_plus. exact H0. apply CR_cv_opp, H. } @@ -111,8 +111,7 @@ Proof. rewrite Qmult_1_r in pmaj. exact pmaj. unfold Qeq, Qnum, Qden; simpl. do 2 rewrite Pos.mul_1_r. reflexivity. apply (Qplus_lt_l _ _ q). ring_simplify. - apply (lt_CR_of_Q R q 0). apply (CRlt_le_trans _ (CRzero R) _ H). - apply CR_of_Q_zero. + apply (lt_CR_of_Q R q 0). exact H. apply (CRlt_le_trans _ (CRopp R z)). apply (CRle_lt_trans _ (CRopp R (CR_of_Q R q))). apply CR_of_Q_opp. apply CRopp_gt_lt_contravar, H0. @@ -131,8 +130,7 @@ Proof. setoid_replace ((Z.pos p # 1) * (1 # p))%Q with 1%Q in pmaj. rewrite Qmult_1_r in pmaj. exact pmaj. unfold Qeq, Qnum, Qden; simpl. do 2 rewrite Pos.mul_1_r. reflexivity. - apply (lt_CR_of_Q R 0 q). apply (CRle_lt_trans _ (CRzero R)). - 2: exact H0. apply CR_of_Q_zero. + apply (lt_CR_of_Q R 0 q). exact H0. apply (CRlt_le_trans _ _ _ H). apply (CRle_trans _ (CRabs R (CRopp R z))). apply (CRle_trans _ (CRabs R z)). @@ -140,10 +138,7 @@ Proof. apply H1. apply CRle_refl. apply CRabs_opp. apply CRabs_morph. unfold CRminus. symmetry. apply CRplus_0_l. - subst z. apply (CRplus_eq_reg_l (CRopp R a)). - apply (CReq_trans _ (CRzero R)). apply CRplus_opp_l. - destruct (CRisRing R). - apply (CReq_trans _ (CRplus R b (CRopp R a))). apply CReq_sym, H. - apply Radd_comm. + rewrite CRplus_opp_l, CRplus_comm. symmetry. exact H. Qed. Lemma CR_cv_eq : forall {R : ConstructiveReals} @@ -196,7 +191,7 @@ Lemma Un_cv_nat_real : forall {R : ConstructiveReals} Proof. intros. destruct (CR_archimedean R (CRinv R eps (inr H0))) as [k kmaj]. assert (0 < CR_of_Q R (Z.pos k # 1)). - { rewrite <- CR_of_Q_zero. apply CR_of_Q_lt. reflexivity. } + { apply CR_of_Q_lt. reflexivity. } specialize (H k) as [p pmaj]. exists p. intros. apply (CRle_lt_trans _ (CR_of_Q R (1 # k))). @@ -204,7 +199,7 @@ Proof. apply (CRmult_lt_reg_l (CR_of_Q R (Z.pos k # 1))). exact H1. rewrite <- CR_of_Q_mult. apply (CRle_lt_trans _ 1). - rewrite <- CR_of_Q_one. apply CR_of_Q_le. + apply CR_of_Q_le. unfold Qle; simpl. do 2 rewrite Pos.mul_1_r. apply Z.le_refl. apply (CRmult_lt_reg_r (CRinv R eps (inr H0))). apply CRinv_0_lt_compat, H0. rewrite CRmult_1_l, CRmult_assoc. @@ -220,7 +215,7 @@ Lemma Un_cv_real_nat : forall {R : ConstructiveReals} Proof. intros. intros n. specialize (H (CR_of_Q R (1#n))) as [p pmaj]. - rewrite <- CR_of_Q_zero. apply CR_of_Q_lt. reflexivity. + apply CR_of_Q_lt. reflexivity. exists p. intros. apply CRlt_asym. apply pmaj. apply H. Qed. @@ -288,12 +283,12 @@ Proof. setoid_replace (1 # n * x)%Q with ((1 # n) *(1# x))%Q. 2: reflexivity. rewrite <- (CRmult_1_r (CR_of_Q R (1#n))). rewrite CR_of_Q_mult, CRmult_assoc. - apply CRmult_le_compat_l. rewrite <- CR_of_Q_zero. + apply CRmult_le_compat_l. apply CR_of_Q_le. discriminate. intro abs. apply (CRmult_lt_compat_l (CR_of_Q R (Z.pos x #1))) in abs. rewrite CRmult_1_r, <- CRmult_assoc, <- CR_of_Q_mult in abs. rewrite (CR_of_Q_morph R ((Z.pos x # 1) * (1 # x))%Q 1%Q) in abs. - rewrite CR_of_Q_one, CRmult_1_l in abs. + rewrite CRmult_1_l in abs. apply (CRlt_asym _ _ abs), (CRlt_trans _ (1 + CRabs R a)). 2: exact c. rewrite <- CRplus_0_l, <- CRplus_assoc. apply CRplus_lt_compat_r. rewrite CRplus_0_r. apply CRzero_lt_one. @@ -310,7 +305,7 @@ Lemma CR_cv_const : forall {R : ConstructiveReals} (a : CRcarrier R), Proof. intros a p. exists O. intros. unfold CRminus. rewrite CRplus_opp_r. - rewrite CRabs_right. rewrite <- CR_of_Q_zero. + rewrite CRabs_right. apply CR_of_Q_le. discriminate. apply CRle_refl. Qed. @@ -633,7 +628,7 @@ Lemma CR_double : forall {R : ConstructiveReals} (x:CRcarrier R), CR_of_Q R 2 * x == x + x. Proof. intros R x. rewrite (CR_of_Q_morph R 2 (1+1)). - 2: reflexivity. rewrite CR_of_Q_plus, CR_of_Q_one. + 2: reflexivity. rewrite CR_of_Q_plus. rewrite CRmult_plus_distr_r, CRmult_1_l. reflexivity. Qed. @@ -641,7 +636,7 @@ Lemma GeoCvZero : forall {R : ConstructiveReals}, CR_cv R (fun n:nat => CRpow (CR_of_Q R (1#2)) n) 0. Proof. intro R. assert (forall n:nat, INR n < CRpow (CR_of_Q R 2) n). - { induction n. unfold INR; simpl. rewrite CR_of_Q_zero. + { induction n. unfold INR; simpl. apply CRzero_lt_one. unfold INR. fold (1+n)%nat. rewrite Nat2Z.inj_add. rewrite (CR_of_Q_morph R _ ((Z.of_nat 1 # 1) + (Z.of_nat n #1))). @@ -651,29 +646,29 @@ Proof. with (CR_of_Q R 2 * CRpow (CR_of_Q R 2) n). 2: reflexivity. rewrite CR_double. apply CRplus_le_lt_compat. - 2: exact IHn. simpl. rewrite CR_of_Q_one. - apply pow_R1_Rle. rewrite <- CR_of_Q_one. apply CR_of_Q_le. discriminate. } + 2: exact IHn. simpl. + apply pow_R1_Rle. apply CR_of_Q_le. discriminate. } intros p. exists (Pos.to_nat p). intros. unfold CRminus. rewrite CRopp_0. rewrite CRplus_0_r. rewrite CRabs_right. - 2: apply pow_le; rewrite <- CR_of_Q_zero; apply CR_of_Q_le; discriminate. + 2: apply pow_le; apply CR_of_Q_le; discriminate. apply CRlt_asym. apply (CRmult_lt_reg_l (CR_of_Q R (Z.pos p # 1))). - rewrite <- CR_of_Q_zero. apply CR_of_Q_lt. reflexivity. rewrite <- CR_of_Q_mult. + apply CR_of_Q_lt. reflexivity. rewrite <- CR_of_Q_mult. rewrite (CR_of_Q_morph R ((Z.pos p # 1) * (1 # p)) 1). 2: unfold Qmult, Qeq, Qnum, Qden; ring_simplify; reflexivity. apply (CRmult_lt_reg_r (CRpow (CR_of_Q R 2) i)). - apply pow_lt. simpl. rewrite <- CR_of_Q_zero. + apply pow_lt. simpl. apply CR_of_Q_lt. reflexivity. rewrite CRmult_assoc. rewrite pow_mult. rewrite (pow_proper (CR_of_Q R (1 # 2) * CR_of_Q R 2) 1), pow_one. - rewrite CRmult_1_r, CR_of_Q_one, CRmult_1_l. + rewrite CRmult_1_r, CRmult_1_l. apply (CRle_lt_trans _ (INR i)). 2: exact (H i). clear H. apply CR_of_Q_le. unfold Qle,Qnum,Qden. do 2 rewrite Z.mul_1_r. rewrite <- positive_nat_Z. apply Nat2Z.inj_le, H0. rewrite <- CR_of_Q_mult. setoid_replace ((1#2)*2)%Q with 1%Q. - apply CR_of_Q_one. reflexivity. + reflexivity. reflexivity. Qed. Lemma GeoFiniteSum : forall {R : ConstructiveReals} (n:nat), @@ -681,9 +676,9 @@ Lemma GeoFiniteSum : forall {R : ConstructiveReals} (n:nat), Proof. induction n. - unfold CRsum, CRpow. simpl (1%ConstructiveReals). - unfold CRminus. rewrite (CR_of_Q_morph R _ (1+1)). - rewrite CR_of_Q_plus, CR_of_Q_one, CRplus_assoc. - rewrite CRplus_opp_r, CRplus_0_r. reflexivity. reflexivity. + unfold CRminus. rewrite (CR_of_Q_plus R 1 1). + rewrite CRplus_assoc. + rewrite CRplus_opp_r, CRplus_0_r. reflexivity. - setoid_replace (CRsum (CRpow (CR_of_Q R (1 # 2))) (S n)) with (CRsum (CRpow (CR_of_Q R (1 # 2))) n + CRpow (CR_of_Q R (1 # 2)) (S n)). 2: reflexivity. @@ -701,7 +696,7 @@ Proof. 2: reflexivity. rewrite <- CRmult_assoc, <- CR_of_Q_mult. setoid_replace (2 * (1 # 2))%Q with 1%Q. - rewrite CR_of_Q_one. apply CRmult_1_l. reflexivity. + apply CRmult_1_l. reflexivity. Qed. Lemma GeoHalfBelowTwo : forall {R : ConstructiveReals} (n:nat), @@ -710,7 +705,7 @@ Proof. intros. rewrite <- (CRplus_0_r (CR_of_Q R 2)), GeoFiniteSum. apply CRplus_lt_compat_l. rewrite <- CRopp_0. apply CRopp_gt_lt_contravar. - apply pow_lt. rewrite <- CR_of_Q_zero. apply CR_of_Q_lt. reflexivity. + apply pow_lt. apply CR_of_Q_lt. reflexivity. Qed. Lemma GeoHalfTwo : forall {R : ConstructiveReals}, @@ -720,35 +715,35 @@ Proof. apply (CR_cv_eq _ (fun n => CR_of_Q R 2 - CRpow (CR_of_Q R (1 # 2)) n)). - intro n. rewrite GeoFiniteSum. reflexivity. - assert (forall n:nat, INR n < CRpow (CR_of_Q R 2) n). - { induction n. unfold INR; simpl. rewrite CR_of_Q_zero. + { induction n. unfold INR; simpl. apply CRzero_lt_one. apply (CRlt_le_trans _ (CRpow (CR_of_Q R 2) n + 1)). unfold INR. rewrite Nat2Z.inj_succ, <- Z.add_1_l. rewrite (CR_of_Q_morph R _ (1 + (Z.of_nat n #1))). 2: symmetry; apply Qinv_plus_distr. rewrite CR_of_Q_plus. - rewrite CRplus_comm. rewrite CR_of_Q_one. + rewrite CRplus_comm. apply CRplus_lt_compat_r, IHn. setoid_replace (CRpow (CR_of_Q R 2) (S n)) with (CRpow (CR_of_Q R 2) n + CRpow (CR_of_Q R 2) n). apply CRplus_le_compat. apply CRle_refl. - apply pow_R1_Rle. rewrite <- CR_of_Q_one. apply CR_of_Q_le. discriminate. + apply pow_R1_Rle. apply CR_of_Q_le. discriminate. rewrite <- CR_double. reflexivity. } intros n. exists (Pos.to_nat n). intros. setoid_replace (CR_of_Q R 2 - CRpow (CR_of_Q R (1 # 2)) i - CR_of_Q R 2) with (- CRpow (CR_of_Q R (1 # 2)) i). rewrite CRabs_opp. rewrite CRabs_right. assert (0 < CR_of_Q R 2). - { rewrite <- CR_of_Q_zero. apply CR_of_Q_lt. reflexivity. } + { apply CR_of_Q_lt. reflexivity. } rewrite (pow_proper _ (CRinv R (CR_of_Q R 2) (inr H1))). rewrite pow_inv. apply CRlt_asym. apply (CRmult_lt_reg_l (CRpow (CR_of_Q R 2) i)). apply pow_lt, H1. rewrite CRinv_r. apply (CRmult_lt_reg_r (CR_of_Q R (Z.pos n#1))). - rewrite <- CR_of_Q_zero. apply CR_of_Q_lt. reflexivity. + apply CR_of_Q_lt. reflexivity. rewrite CRmult_1_l, CRmult_assoc. rewrite <- CR_of_Q_mult. rewrite (CR_of_Q_morph R ((1 # n) * (Z.pos n # 1)) 1). 2: reflexivity. - rewrite CR_of_Q_one, CRmult_1_r. apply (CRle_lt_trans _ (INR i)). + rewrite CRmult_1_r. apply (CRle_lt_trans _ (INR i)). 2: apply H. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. destruct i. exfalso. inversion H0. pose proof (Pos2Nat.is_pos n). @@ -758,8 +753,8 @@ Proof. apply (CRmult_eq_reg_l (CR_of_Q R 2)). right. exact H1. rewrite CRinv_r. rewrite <- CR_of_Q_mult. setoid_replace (2 * (1 # 2))%Q with 1%Q. - apply CR_of_Q_one. reflexivity. - apply CRlt_asym, pow_lt. rewrite <- CR_of_Q_zero. + reflexivity. reflexivity. + apply CRlt_asym, pow_lt. apply CR_of_Q_lt. reflexivity. unfold CRminus. rewrite CRplus_comm, <- CRplus_assoc. rewrite CRplus_opp_l, CRplus_0_l. reflexivity. @@ -929,5 +924,5 @@ Proof. intros n. exists (Pos.to_nat n). intros. unfold CRminus. simpl. rewrite CRopp_involutive, CRplus_opp_l. rewrite CRabs_right. - rewrite <- CR_of_Q_zero. apply CR_of_Q_le. discriminate. apply CRle_refl. + apply CR_of_Q_le. discriminate. apply CRle_refl. Qed. diff --git a/theories/Reals/Abstract/ConstructiveReals.v b/theories/Reals/Abstract/ConstructiveReals.v index d91fd1183a..019428a5b0 100644 --- a/theories/Reals/Abstract/ConstructiveReals.v +++ b/theories/Reals/Abstract/ConstructiveReals.v @@ -101,9 +101,15 @@ Structure ConstructiveReals : Type := CRltDisjunctEpsilon : forall a b c d : CRcarrier, (CRltProp a b \/ CRltProp c d) -> CRlt a b + CRlt c d; - (* Constants *) - CRzero : CRcarrier; - CRone : CRcarrier; + (* The initial field morphism (in characteristic zero). + The abstract definition by iteration of addition is + probably the slowest. Let each instance implement + a faster (and often simpler) version. *) + CR_of_Q : Q -> CRcarrier; + CR_of_Q_lt : forall q r : Q, + Qlt q r -> CRlt (CR_of_Q q) (CR_of_Q r); + lt_CR_of_Q : forall q r : Q, + CRlt (CR_of_Q q) (CR_of_Q r) -> Qlt q r; (* Addition and multiplication *) CRplus : CRcarrier -> CRcarrier -> CRcarrier; @@ -111,19 +117,22 @@ Structure ConstructiveReals : Type := stronger than Prop-existence of opposite *) CRmult : CRcarrier -> CRcarrier -> CRcarrier; - CRisRing : ring_theory CRzero CRone CRplus CRmult + CR_of_Q_plus : forall q r : Q, CReq (CR_of_Q (q+r)) + (CRplus (CR_of_Q q) (CR_of_Q r)); + CR_of_Q_mult : forall q r : Q, CReq (CR_of_Q (q*r)) + (CRmult (CR_of_Q q) (CR_of_Q r)); + CRisRing : ring_theory (CR_of_Q 0) (CR_of_Q 1) CRplus CRmult (fun x y => CRplus x (CRopp y)) CRopp CReq; CRisRingExt : ring_eq_ext CRplus CRmult CRopp CReq; (* Compatibility with order *) - CRzero_lt_one : CRlt CRzero CRone; (* 0 # 1 would only allow 0 < 1 because - of Fmult_lt_0_compat so request 0 < 1 directly. *) + CRzero_lt_one : CRlt (CR_of_Q 0) (CR_of_Q 1); CRplus_lt_compat_l : forall r r1 r2 : CRcarrier, CRlt r1 r2 -> CRlt (CRplus r r1) (CRplus r r2); CRplus_lt_reg_l : forall r r1 r2 : CRcarrier, CRlt (CRplus r r1) (CRplus r r2) -> CRlt r1 r2; CRmult_lt_0_compat : forall x y : CRcarrier, - CRlt CRzero x -> CRlt CRzero y -> CRlt CRzero (CRmult x y); + CRlt (CR_of_Q 0) x -> CRlt (CR_of_Q 0) y -> CRlt (CR_of_Q 0) (CRmult x y); (* A constructive total inverse function on F would need to be continuous, which is impossible because we cannot connect plus and minus infinities. @@ -132,26 +141,11 @@ Structure ConstructiveReals : Type := To implement Finv by Cauchy sequences we need orderAppart, ~orderEq is not enough. *) - CRinv : forall x : CRcarrier, CRapart x CRzero -> CRcarrier; - CRinv_l : forall (r:CRcarrier) (rnz : CRapart r CRzero), - CReq (CRmult (CRinv r rnz) r) CRone; - CRinv_0_lt_compat : forall (r : CRcarrier) (rnz : CRapart r CRzero), - CRlt CRzero r -> CRlt CRzero (CRinv r rnz); - - (* The initial field morphism (in characteristic zero). - The abstract definition by iteration of addition is - probably the slowest. Let each instance implement - a faster (and often simpler) version. *) - CR_of_Q : Q -> CRcarrier; - CR_of_Q_plus : forall q r : Q, CReq (CR_of_Q (q+r)) - (CRplus (CR_of_Q q) (CR_of_Q r)); - CR_of_Q_mult : forall q r : Q, CReq (CR_of_Q (q*r)) - (CRmult (CR_of_Q q) (CR_of_Q r)); - CR_of_Q_one : CReq (CR_of_Q 1) CRone; - CR_of_Q_lt : forall q r : Q, - Qlt q r -> CRlt (CR_of_Q q) (CR_of_Q r); - lt_CR_of_Q : forall q r : Q, - CRlt (CR_of_Q q) (CR_of_Q r) -> Qlt q r; + CRinv : forall x : CRcarrier, CRapart x (CR_of_Q 0) -> CRcarrier; + CRinv_l : forall (r:CRcarrier) (rnz : CRapart r (CR_of_Q 0)), + CReq (CRmult (CRinv r rnz) r) (CR_of_Q 1); + CRinv_0_lt_compat : forall (r : CRcarrier) (rnz : CRapart r (CR_of_Q 0)), + CRlt (CR_of_Q 0) r -> CRlt (CR_of_Q 0) (CRinv r rnz); (* This function is very fast in both the Cauchy and Dedekind instances, because this rational number q is almost what @@ -213,8 +207,17 @@ Notation "x <= y <= z" := (CRle _ x y /\ CRle _ y z) : ConstructiveReals. Notation "x < y < z" := (prod (CRlt _ x y) (CRlt _ y z)) : ConstructiveReals. Notation "x == y" := (CReq _ x y) : ConstructiveReals. Notation "x ≶ y" := (CRapart _ x y) (at level 70, no associativity) : ConstructiveReals. -Notation "0" := (CRzero _) : ConstructiveReals. -Notation "1" := (CRone _) : ConstructiveReals. +Notation "0" := (CR_of_Q _ 0) : ConstructiveReals. +Notation "1" := (CR_of_Q _ 1) : ConstructiveReals. +Notation "2" := (CR_of_Q _ 2) : ConstructiveReals. +Notation "3" := (CR_of_Q _ 3) : ConstructiveReals. +Notation "4" := (CR_of_Q _ 4) : ConstructiveReals. +Notation "5" := (CR_of_Q _ 5) : ConstructiveReals. +Notation "6" := (CR_of_Q _ 6) : ConstructiveReals. +Notation "7" := (CR_of_Q _ 7) : ConstructiveReals. +Notation "8" := (CR_of_Q _ 8) : ConstructiveReals. +Notation "9" := (CR_of_Q _ 9) : ConstructiveReals. +Notation "10" := (CR_of_Q _ 10) : ConstructiveReals. Notation "x + y" := (CRplus _ x y) : ConstructiveReals. Notation "- x" := (CRopp _ x) : ConstructiveReals. Notation "x - y" := (CRminus _ x y) : ConstructiveReals. @@ -567,7 +570,7 @@ Lemma CRopp_involutive : forall {R : ConstructiveReals} (r : CRcarrier R), - - r == r. Proof. intros. apply (CRplus_eq_reg_l (CRopp R r)). - transitivity (CRzero R). apply CRisRing. + transitivity (CR_of_Q R 0). apply CRisRing. apply CReq_sym. transitivity (r + - r). apply CRisRing. apply CRisRing. Qed. @@ -578,7 +581,7 @@ Lemma CRopp_gt_lt_contravar Proof. intros. apply (CRplus_lt_reg_l R r1). destruct (CRisRing R). - apply (CRle_lt_trans _ (CRzero R)). apply Ropp_def. + apply (CRle_lt_trans _ 0). apply Ropp_def. apply (CRplus_lt_compat_l R (CRopp R r2)) in H. apply (CRle_lt_trans _ (CRplus R (CRopp R r2) r2)). apply (CRle_trans _ (CRplus R r2 (CRopp R r2))). @@ -611,13 +614,13 @@ Lemma CRopp_plus_distr : forall {R : ConstructiveReals} (r1 r2 : CRcarrier R), Proof. intros. destruct (CRisRing R), (CRisRingExt R). apply (CRplus_eq_reg_l (CRplus R r1 r2)). - transitivity (CRzero R). apply Ropp_def. + transitivity (CR_of_Q R 0). apply Ropp_def. transitivity (r2 + r1 + (-r1 + -r2)). transitivity (r2 + (r1 + (-r1 + -r2))). transitivity (r2 + - r2). apply CReq_sym. apply Ropp_def. apply Radd_ext. apply CReq_refl. - transitivity (CRzero R + - r2). + transitivity (0 + - r2). apply CReq_sym, Radd_0_l. transitivity (r1 + - r1 + - r2). apply Radd_ext. 2: apply CReq_refl. apply CReq_sym, Ropp_def. @@ -701,7 +704,7 @@ Lemma CRopp_mult_distr_r : forall {R : ConstructiveReals} (r1 r2 : CRcarrier R), - (r1 * r2) == r1 * (- r2). Proof. intros. apply (CRplus_eq_reg_l (CRmult R r1 r2)). - destruct (CRisRing R). transitivity (CRzero R). apply Ropp_def. + destruct (CRisRing R). transitivity (CR_of_Q R 0). apply Ropp_def. transitivity (r1 * (r2 + - r2)). 2: apply CRmult_plus_distr_l. transitivity (r1 * 0). @@ -725,7 +728,7 @@ Lemma CRmult_lt_compat_r : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R 0 < r -> r1 < r2 -> r1 * r < r2 * r. Proof. intros. apply (CRplus_lt_reg_r (CRopp R (CRmult R r1 r))). - apply (CRle_lt_trans _ (CRzero R)). + apply (CRle_lt_trans _ 0). apply (Ropp_def (CRisRing R)). apply (CRlt_le_trans _ (CRplus R (CRmult R r2 r) (CRmult R (CRopp R r1) r))). apply (CRlt_le_trans _ (CRmult R (CRplus R r2 (CRopp R r1)) r)). @@ -734,7 +737,7 @@ Proof. apply (CRle_lt_trans _ r1). apply (Radd_0_l (CRisRing R)). apply (CRlt_le_trans _ r2 _ H0). apply (CRle_trans _ (CRplus R r2 (CRplus R (CRopp R r1) r1))). - apply (CRle_trans _ (CRplus R r2 (CRzero R))). + apply (CRle_trans _ (CRplus R r2 0)). destruct (CRplus_0_r r2). exact H1. apply CRplus_le_compat_l. destruct (CRplus_opp_l r1). exact H1. destruct (Radd_assoc (CRisRing R) r2 (CRopp R r1) r1). exact H2. @@ -752,7 +755,7 @@ Proof. Qed. Lemma CRinv_r : forall {R : ConstructiveReals} (r:CRcarrier R) - (rnz : r ≶ (CRzero R)), + (rnz : r ≶ 0), r * (/ r) rnz == 1. Proof. intros. transitivity ((/ r) rnz * r). @@ -765,7 +768,7 @@ Proof. intros. apply (CRmult_lt_compat_r ((/ r) (inr H))) in H0. 2: apply CRinv_0_lt_compat, H. apply (CRle_lt_trans _ ((r1 * r) * ((/ r) (inr H)))). - - clear H0. apply (CRle_trans _ (CRmult R r1 (CRone R))). + - clear H0. apply (CRle_trans _ (CRmult R r1 1)). destruct (CRmult_1_r r1). exact H0. apply (CRle_trans _ (CRmult R r1 (CRmult R r ((/ r) (inr H))))). destruct (Rmul_ext (CRisRingExt R) r1 r1 (CReq_refl r1) @@ -779,7 +782,7 @@ Proof. apply (CRle_trans _ (r2 * (r * ((/ r) (inr H))))). destruct (Rmul_assoc (CRisRing R) r2 r ((/ r) (inr H))). exact H0. destruct (Rmul_ext (CRisRingExt R) r2 r2 (CReq_refl r2) - (r * ((/ r) (inr H))) (CRone R)). + (r * ((/ r) (inr H))) 1). apply CRinv_r. exact H1. Qed. @@ -829,7 +832,7 @@ Proof. apply CRmult_lt_compat_r. 2: exact abs. apply (CRplus_lt_reg_r r). apply (CRle_lt_trans _ r). apply (Radd_0_l (CRisRing R)). - apply (CRlt_le_trans _ (CRzero R) _ c). + apply (CRlt_le_trans _ 0 _ c). apply CRplus_opp_l. + intro abs. apply H0. apply CRopp_lt_cancel. apply (CRle_lt_trans _ (CRmult R r2 (CRopp R r))). @@ -839,7 +842,7 @@ Proof. apply CRmult_lt_compat_r. 2: exact abs. apply (CRplus_lt_reg_r r). apply (CRle_lt_trans _ r). apply (Radd_0_l (CRisRing R)). - apply (CRlt_le_trans _ (CRzero R) _ c). + apply (CRlt_le_trans _ 0 _ c). apply CRplus_opp_l. Qed. @@ -920,31 +923,21 @@ Proof. intros R x y H. apply CR_of_Q_morph; assumption. Qed. -Lemma CR_of_Q_zero : forall {R : ConstructiveReals}, - CR_of_Q R 0 == 0. -Proof. - intros. apply CRzero_double. - transitivity (CR_of_Q R (0+0)). apply CR_of_Q_morph. - reflexivity. apply CR_of_Q_plus. -Qed. - Lemma CR_of_Q_opp : forall {R : ConstructiveReals} (q : Q), CR_of_Q R (-q) == - CR_of_Q R q. Proof. intros. apply (CRplus_eq_reg_l (CR_of_Q R q)). - transitivity (CRzero R). + transitivity (CR_of_Q R 0). transitivity (CR_of_Q R (q-q)). apply CReq_sym, CR_of_Q_plus. - transitivity (CR_of_Q R 0). - apply CR_of_Q_morph. ring. apply CR_of_Q_zero. + apply CR_of_Q_morph. ring. apply CReq_sym. apply (CRisRing R). Qed. Lemma CR_of_Q_pos : forall {R : ConstructiveReals} (q:Q), Qlt 0 q -> 0 < CR_of_Q R q. Proof. - intros. apply (CRle_lt_trans _ (CR_of_Q R 0)). - apply CR_of_Q_zero. apply CR_of_Q_lt. exact H. + intros. apply CR_of_Q_lt. exact H. Qed. Lemma CR_of_Q_inv : forall {R : ConstructiveReals} (q : Q) (qPos : Qlt 0 q), @@ -954,7 +947,7 @@ Proof. intros. apply (CRmult_eq_reg_l (CR_of_Q R q)). right. apply CR_of_Q_pos, qPos. - rewrite CRinv_r, <- CR_of_Q_mult, <- CR_of_Q_one. + rewrite CRinv_r, <- CR_of_Q_mult. apply CR_of_Q_morph. field. intro abs. rewrite abs in qPos. exact (Qlt_irrefl 0 qPos). Qed. @@ -969,7 +962,7 @@ Proof. destruct (CR_archimedean R (b * ((/ -(a*b)) (inr epsPos)))) as [n maj]. assert (0 < CR_of_Q R (Z.pos n #1)) as nPos. - { rewrite <- CR_of_Q_zero. apply CR_of_Q_lt. reflexivity. } + { apply CR_of_Q_lt. reflexivity. } assert (b * (/ CR_of_Q R (Z.pos n #1)) (inr nPos) < -(a*b)). { apply (CRmult_lt_reg_r (CR_of_Q R (Z.pos n #1))). apply nPos. rewrite <- (Rmul_assoc (CRisRing R)), CRinv_l, CRmult_1_r. @@ -1082,7 +1075,7 @@ Definition CRfloor {R : ConstructiveReals} (a : CRcarrier R) Proof. destruct (CR_Q_dense R (a - CR_of_Q R (1#2)) a) as [q qmaj]. - apply (CRlt_le_trans _ (a-0)). apply CRplus_lt_compat_l. - apply CRopp_gt_lt_contravar. rewrite <- CR_of_Q_zero. + apply CRopp_gt_lt_contravar. apply CR_of_Q_lt. reflexivity. unfold CRminus. rewrite CRopp_0, CRplus_0_r. apply CRle_refl. - exists (Qfloor q). destruct qmaj. split. diff --git a/theories/Reals/Abstract/ConstructiveRealsMorphisms.v b/theories/Reals/Abstract/ConstructiveRealsMorphisms.v index bc44668e2f..cf302dc847 100644 --- a/theories/Reals/Abstract/ConstructiveRealsMorphisms.v +++ b/theories/Reals/Abstract/ConstructiveRealsMorphisms.v @@ -163,9 +163,8 @@ Lemma CRmorph_zero : forall {R1 R2 : ConstructiveReals} CRmorph f 0 == 0. Proof. intros. apply (CReq_trans _ (CRmorph f (CR_of_Q R1 0))). - apply CRmorph_proper. apply CReq_sym, CR_of_Q_zero. - apply (CReq_trans _ (CR_of_Q R2 0)). - apply CRmorph_rat. apply CR_of_Q_zero. + apply CRmorph_proper. reflexivity. + apply CRmorph_rat. Qed. Lemma CRmorph_one : forall {R1 R2 : ConstructiveReals} @@ -173,9 +172,8 @@ Lemma CRmorph_one : forall {R1 R2 : ConstructiveReals} CRmorph f 1 == 1. Proof. intros. apply (CReq_trans _ (CRmorph f (CR_of_Q R1 1))). - apply CRmorph_proper. apply CReq_sym, CR_of_Q_one. - apply (CReq_trans _ (CR_of_Q R2 1)). - apply CRmorph_rat. apply CR_of_Q_one. + apply CRmorph_proper. reflexivity. + apply CRmorph_rat. Qed. Lemma CRmorph_opp : forall {R1 R2 : ConstructiveReals} @@ -228,9 +226,9 @@ Lemma CRplus_pos_rat_lt : forall {R : ConstructiveReals} (x : CRcarrier R) (q : Qlt 0 q -> CRlt R x (CRplus R x (CR_of_Q R q)). Proof. intros. - apply (CRle_lt_trans _ (CRplus R x (CRzero R))). apply CRplus_0_r. + apply (CRle_lt_trans _ (CRplus R x 0)). apply CRplus_0_r. apply CRplus_lt_compat_l. - apply (CRle_lt_trans _ (CR_of_Q R 0)). apply CR_of_Q_zero. + apply (CRle_lt_trans _ (CR_of_Q R 0)). apply CRle_refl. apply CR_of_Q_lt. exact H. Defined. @@ -238,10 +236,10 @@ Lemma CRplus_neg_rat_lt : forall {R : ConstructiveReals} (x : CRcarrier R) (q : Qlt q 0 -> CRlt R (CRplus R x (CR_of_Q R q)) x. Proof. intros. - apply (CRlt_le_trans _ (CRplus R x (CRzero R))). 2: apply CRplus_0_r. + apply (CRlt_le_trans _ (CRplus R x 0)). 2: apply CRplus_0_r. apply CRplus_lt_compat_l. apply (CRlt_le_trans _ (CR_of_Q R 0)). - apply CR_of_Q_lt. exact H. apply CR_of_Q_zero. + apply CR_of_Q_lt. exact H. apply CRle_refl. Qed. Lemma CRmorph_plus_rat : forall {R1 R2 : ConstructiveReals} @@ -276,7 +274,7 @@ Proof. destruct (CRisRing R1). apply (CRle_trans _ (CRplus R1 x (CRplus R1 (CR_of_Q R1 q) (CRopp R1 (CR_of_Q R1 q))))). - apply (CRle_trans _ (CRplus R1 x (CRzero R1))). + apply (CRle_trans _ (CRplus R1 x 0)). destruct (CRplus_0_r x). exact H. apply CRplus_le_compat_l. destruct (Ropp_def (CR_of_Q R1 q)). exact H. destruct (Radd_assoc x (CR_of_Q R1 q) (CRopp R1 (CR_of_Q R1 q))). @@ -294,7 +292,7 @@ Proof. _ (CRplus R1 x (CRplus R1 (CR_of_Q R1 q) (CRopp R1 (CR_of_Q R1 q))))). destruct (Radd_assoc x (CR_of_Q R1 q) (CRopp R1 (CR_of_Q R1 q))). exact H0. - apply (CRle_trans _ (CRplus R1 x (CRzero R1))). + apply (CRle_trans _ (CRplus R1 x 0)). apply CRplus_le_compat_l. destruct (Ropp_def (CR_of_Q R1 q)). exact H1. destruct (CRplus_0_r x). exact H1. apply (CRlt_le_trans _ (CR_of_Q R1 (r-q))). @@ -379,12 +377,12 @@ Proof. apply CRmorph_proper. destruct (CRisRing R1). apply (CReq_trans _ (CRplus R1 x (CRplus R1 y (CRopp R1 y)))). apply CReq_sym, Radd_assoc. - apply (CReq_trans _ (CRplus R1 x (CRzero R1))). 2: apply CRplus_0_r. + apply (CReq_trans _ (CRplus R1 x 0)). 2: apply CRplus_0_r. destruct (CRisRingExt R1). apply Radd_ext. apply CReq_refl. apply Ropp_def. apply (CRplus_lt_reg_r (CRmorph f y)). apply (CRlt_le_trans _ _ _ abs). clear abs. - apply (CRle_trans _ (CRplus R2 (CRmorph f (CRplus R1 x y)) (CRzero R2))). + apply (CRle_trans _ (CRplus R2 (CRmorph f (CRplus R1 x y)) 0)). destruct (CRplus_0_r (CRmorph f (CRplus R1 x y))). exact H. apply (CRle_trans _ (CRplus R2 (CRmorph f (CRplus R1 x y)) (CRplus R2 (CRmorph f (CRopp R1 y)) (CRmorph f y)))). @@ -407,29 +405,26 @@ Lemma CRmorph_mult_pos : forall {R1 R2 : ConstructiveReals} Proof. induction n. - simpl. destruct (CRisRingExt R1). - apply (CReq_trans _ (CRzero R2)). - + apply (CReq_trans _ (CRmorph f (CRzero R1))). + apply (CReq_trans _ 0). + + apply (CReq_trans _ (CRmorph f 0)). 2: apply CRmorph_zero. apply CRmorph_proper. - apply (CReq_trans _ (CRmult R1 x (CRzero R1))). - 2: apply CRmult_0_r. apply Rmul_ext. apply CReq_refl. apply CR_of_Q_zero. - + apply (CReq_trans _ (CRmult R2 (CRmorph f x) (CRzero R2))). + apply (CReq_trans _ (CRmult R1 x 0)). + 2: apply CRmult_0_r. apply Rmul_ext. apply CReq_refl. reflexivity. + + apply (CReq_trans _ (CRmult R2 (CRmorph f x) 0)). apply CReq_sym, CRmult_0_r. destruct (CRisRingExt R2). - apply Rmul_ext0. apply CReq_refl. apply CReq_sym, CR_of_Q_zero. + apply Rmul_ext0. apply CReq_refl. reflexivity. - destruct (CRisRingExt R1), (CRisRingExt R2). - apply (CReq_trans - _ (CRmorph f (CRplus R1 x (CRmult R1 x (CR_of_Q R1 (Z.of_nat n # 1)))))). + transitivity (CRmorph f (CRplus R1 x (CRmult R1 x (CR_of_Q R1 (Z.of_nat n # 1))))). apply CRmorph_proper. - apply (CReq_trans - _ (CRmult R1 x (CRplus R1 (CRone R1) (CR_of_Q R1 (Z.of_nat n # 1))))). - apply Rmul_ext. apply CReq_refl. - apply (CReq_trans _ (CR_of_Q R1 (1 + (Z.of_nat n # 1)))). + transitivity (CRmult R1 x (CRplus R1 1 (CR_of_Q R1 (Z.of_nat n # 1)))). + apply Rmul_ext. reflexivity. + transitivity (CR_of_Q R1 (1 + (Z.of_nat n # 1))). apply CR_of_Q_morph. rewrite Nat2Z.inj_succ. unfold Z.succ. rewrite Z.add_comm. rewrite Qinv_plus_distr. reflexivity. - apply (CReq_trans _ (CRplus R1 (CR_of_Q R1 1) (CR_of_Q R1 (Z.of_nat n # 1)))). - apply CR_of_Q_plus. apply Radd_ext. apply CR_of_Q_one. apply CReq_refl. - apply (CReq_trans _ (CRplus R1 (CRmult R1 x (CRone R1)) - (CRmult R1 x (CR_of_Q R1 (Z.of_nat n # 1))))). - apply CRmult_plus_distr_l. apply Radd_ext. apply CRmult_1_r. apply CReq_refl. + rewrite CR_of_Q_plus. reflexivity. + transitivity (CRplus R1 (CRmult R1 x 1) + (CRmult R1 x (CR_of_Q R1 (Z.of_nat n # 1)))). + apply CRmult_plus_distr_l. apply Radd_ext. apply CRmult_1_r. reflexivity. apply (CReq_trans _ (CRplus R2 (CRmorph f x) (CRmorph f (CRmult R1 x (CR_of_Q R1 (Z.of_nat n # 1)))))). @@ -439,16 +434,16 @@ Proof. (CRmult R2 (CRmorph f x) (CR_of_Q R2 (Z.of_nat n # 1))))). apply Radd_ext0. apply CReq_refl. exact IHn. apply (CReq_trans - _ (CRmult R2 (CRmorph f x) (CRplus R2 (CRone R2) (CR_of_Q R2 (Z.of_nat n # 1))))). + _ (CRmult R2 (CRmorph f x) (CRplus R2 1 (CR_of_Q R2 (Z.of_nat n # 1))))). apply (CReq_trans - _ (CRplus R2 (CRmult R2 (CRmorph f x) (CRone R2)) + _ (CRplus R2 (CRmult R2 (CRmorph f x) 1) (CRmult R2 (CRmorph f x) (CR_of_Q R2 (Z.of_nat n # 1))))). apply Radd_ext0. 2: apply CReq_refl. apply CReq_sym, CRmult_1_r. apply CReq_sym, CRmult_plus_distr_l. apply Rmul_ext0. apply CReq_refl. apply (CReq_trans _ (CR_of_Q R2 (1 + (Z.of_nat n # 1)))). apply (CReq_trans _ (CRplus R2 (CR_of_Q R2 1) (CR_of_Q R2 (Z.of_nat n # 1)))). - apply Radd_ext0. apply CReq_sym, CR_of_Q_one. apply CReq_refl. + apply Radd_ext0. reflexivity. reflexivity. apply CReq_sym, CR_of_Q_plus. apply CR_of_Q_morph. rewrite Nat2Z.inj_succ. unfold Z.succ. rewrite Z.add_comm. rewrite Qinv_plus_distr. reflexivity. @@ -501,7 +496,7 @@ Lemma CRmorph_mult_inv : forall {R1 R2 : ConstructiveReals} Proof. intros. apply (CRmult_eq_reg_r (CR_of_Q R2 (Z.pos p # 1))). left. apply (CRle_lt_trans _ (CR_of_Q R2 0)). - apply CR_of_Q_zero. apply CR_of_Q_lt. reflexivity. + apply CRle_refl. apply CR_of_Q_lt. reflexivity. apply (CReq_trans _ (CRmorph f x)). - apply (CReq_trans _ (CRmorph f (CRmult R1 (CRmult R1 x (CR_of_Q R1 (1 # p))) @@ -511,22 +506,22 @@ Proof. _ (CRmult R1 x (CRmult R1 (CR_of_Q R1 (1 # p)) (CR_of_Q R1 (Z.pos p # 1))))). destruct (CRisRing R1). apply CReq_sym, Rmul_assoc. - apply (CReq_trans _ (CRmult R1 x (CRone R1))). + apply (CReq_trans _ (CRmult R1 x 1)). apply (Rmul_ext (CRisRingExt R1)). apply CReq_refl. apply (CReq_trans _ (CR_of_Q R1 ((1#p) * (Z.pos p # 1)))). apply CReq_sym, CR_of_Q_mult. apply (CReq_trans _ (CR_of_Q R1 1)). - apply CR_of_Q_morph. reflexivity. apply CR_of_Q_one. + apply CR_of_Q_morph. reflexivity. reflexivity. apply CRmult_1_r. - apply (CReq_trans _ (CRmult R2 (CRmorph f x) (CRmult R2 (CR_of_Q R2 (1 # p)) (CR_of_Q R2 (Z.pos p # 1))))). 2: apply (Rmul_assoc (CRisRing R2)). - apply (CReq_trans _ (CRmult R2 (CRmorph f x) (CRone R2))). + apply (CReq_trans _ (CRmult R2 (CRmorph f x) 1)). apply CReq_sym, CRmult_1_r. apply (Rmul_ext (CRisRingExt R2)). apply CReq_refl. apply (CReq_trans _ (CR_of_Q R2 1)). - apply CReq_sym, CR_of_Q_one. + reflexivity. apply (CReq_trans _ (CR_of_Q R2 ((1#p)*(Z.pos p # 1)))). apply CR_of_Q_morph. reflexivity. apply CR_of_Q_mult. Qed. @@ -571,7 +566,7 @@ Qed. Lemma CRmorph_mult_pos_pos_le : forall {R1 R2 : ConstructiveReals} (f : @ConstructiveRealsMorphism R1 R2) (x y : CRcarrier R1), - CRlt R1 (CRzero R1) y + CRlt R1 0 y -> CRmult R2 (CRmorph f x) (CRmorph f y) <= CRmorph f (CRmult R1 x y). Proof. @@ -590,20 +585,20 @@ Proof. apply Qlt_minus_iff in H1. rewrite H4 in H1. inversion H1. } destruct (CR_Q_dense R1 (CRplus R1 x (CR_of_Q R1 ((q-r) * (1#A)))) x) as [s [H4 H5]]. - - apply (CRlt_le_trans _ (CRplus R1 x (CRzero R1))). + - apply (CRlt_le_trans _ (CRplus R1 x 0)). 2: apply CRplus_0_r. apply CRplus_lt_compat_l. apply (CRplus_lt_reg_l R1 (CR_of_Q R1 ((r-q) * (1#A)))). - apply (CRle_lt_trans _ (CRzero R1)). + apply (CRle_lt_trans _ 0). apply (CRle_trans _ (CR_of_Q R1 ((r-q)*(1#A) + (q-r)*(1#A)))). destruct (CR_of_Q_plus R1 ((r-q)*(1#A)) ((q-r)*(1#A))). exact H0. apply (CRle_trans _ (CR_of_Q R1 0)). - 2: destruct (@CR_of_Q_zero R1); exact H4. + 2: apply CRle_refl. intro H4. apply lt_CR_of_Q in H4. ring_simplify in H4. inversion H4. apply (CRlt_le_trans _ (CR_of_Q R1 ((r - q) * (1 # A)))). 2: apply CRplus_0_r. apply (CRle_lt_trans _ (CR_of_Q R1 0)). - apply CR_of_Q_zero. apply CR_of_Q_lt. + apply CRle_refl. apply CR_of_Q_lt. rewrite <- (Qmult_0_r (r-q)). apply Qmult_lt_l. apply Qlt_minus_iff in H1. exact H1. reflexivity. - apply (CRmorph_increasing f) in H4. @@ -637,7 +632,7 @@ Proof. apply (CRlt_le_trans _ (CRmult R2 (CR_of_Q R2 ((q - r) * (1 # A))) (CRmorph f y))). apply (CRmult_lt_reg_l (CR_of_Q R2 (/((r-q)*(1#A))))). - apply (CRle_lt_trans _ (CR_of_Q R2 0)). apply CR_of_Q_zero. + apply (CRle_lt_trans _ (CR_of_Q R2 0)). apply CRle_refl. apply CR_of_Q_lt, Qinv_lt_0_compat. rewrite <- (Qmult_0_r (r-q)). apply Qmult_lt_l. apply Qlt_minus_iff in H1. exact H1. reflexivity. @@ -655,24 +650,24 @@ Proof. apply (CRlt_le_trans _ (CRmorph f (CR_of_Q R1 (Z.pos A # 1)))). apply CRmorph_increasing. exact Amaj. destruct (CRmorph_rat f (Z.pos A # 1)). exact H4. - apply (CRle_trans _ (CRmult R2 (CRopp R2 (CRone R2)) (CRmorph f y))). - apply (CRle_trans _ (CRopp R2 (CRmult R2 (CRone R2) (CRmorph f y)))). + apply (CRle_trans _ (CRmult R2 (CRopp R2 1) (CRmorph f y))). + apply (CRle_trans _ (CRopp R2 (CRmult R2 1 (CRmorph f y)))). destruct (Ropp_ext (CRisRingExt R2) (CRmorph f y) - (CRmult R2 (CRone R2) (CRmorph f y))). + (CRmult R2 1 (CRmorph f y))). apply CReq_sym, (Rmul_1_l (CRisRing R2)). exact H4. - destruct (CRopp_mult_distr_l (CRone R2) (CRmorph f y)). exact H4. + destruct (CRopp_mult_distr_l 1 (CRmorph f y)). exact H4. apply (CRle_trans _ (CRmult R2 (CRmult R2 (CR_of_Q R2 (/ ((r - q) * (1 # A)))) (CR_of_Q R2 ((q - r) * (1 # A)))) (CRmorph f y))). apply CRmult_le_compat_r_half. - apply (CRle_lt_trans _ (CRmorph f (CRzero R1))). + apply (CRle_lt_trans _ (CRmorph f 0)). apply CRmorph_zero. apply CRmorph_increasing. exact H. apply (CRle_trans _ (CR_of_Q R2 ((/ ((r - q) * (1 # A))) * ((q - r) * (1 # A))))). apply (CRle_trans _ (CR_of_Q R2 (-1))). apply (CRle_trans _ (CRopp R2 (CR_of_Q R2 1))). - destruct (Ropp_ext (CRisRingExt R2) (CRone R2) (CR_of_Q R2 1)). - apply CReq_sym, CR_of_Q_one. exact H4. + destruct (Ropp_ext (CRisRingExt R2) 1 (CR_of_Q R2 1)). + reflexivity. exact H4. destruct (@CR_of_Q_opp R2 1). exact H0. destruct (CR_of_Q_morph R2 (-1) (/ ((r - q) * (1 # A)) * ((q - r) * (1 # A)))). field. split. @@ -685,7 +680,7 @@ Proof. (CRmorph f y)). exact H0. apply CRmult_le_compat_r_half. - apply (CRle_lt_trans _ (CRmorph f (CRzero R1))). + apply (CRle_lt_trans _ (CRmorph f 0)). apply CRmorph_zero. apply CRmorph_increasing. exact H. destruct (CRmorph_rat f ((q - r) * (1 # A))). exact H0. + apply (CRle_trans _ (CRmorph f (CRmult R1 y (CR_of_Q R1 s)))). @@ -696,14 +691,14 @@ Proof. destruct (CRmorph_proper f (CRmult R1 y (CR_of_Q R1 s)) (CRmult R1 (CR_of_Q R1 s) y)). apply (Rmul_comm (CRisRing R1)). exact H4. - + apply (CRle_lt_trans _ (CRmorph f (CRzero R1))). + + apply (CRle_lt_trans _ (CRmorph f 0)). apply CRmorph_zero. apply CRmorph_increasing. exact H. Qed. Lemma CRmorph_mult_pos_pos : forall {R1 R2 : ConstructiveReals} (f : @ConstructiveRealsMorphism R1 R2) (x y : CRcarrier R1), - CRlt R1 (CRzero R1) y + CRlt R1 0 y -> CRmorph f (CRmult R1 x y) == CRmult R2 (CRmorph f x) (CRmorph f y). Proof. @@ -718,10 +713,10 @@ Proof. destruct (CR_archimedean R1 y) as [A Amaj]. destruct (CR_Q_dense R1 x (CRplus R1 x (CR_of_Q R1 ((q-r) * (1#A))))) as [s [H4 H5]]. - - apply (CRle_lt_trans _ (CRplus R1 x (CRzero R1))). + - apply (CRle_lt_trans _ (CRplus R1 x 0)). apply CRplus_0_r. apply CRplus_lt_compat_l. apply (CRle_lt_trans _ (CR_of_Q R1 0)). - apply CR_of_Q_zero. apply CR_of_Q_lt. + apply CRle_refl. apply CR_of_Q_lt. rewrite <- (Qmult_0_r (q-r)). apply Qmult_lt_l. apply Qlt_minus_iff in H3. exact H3. reflexivity. - apply (CRmorph_increasing f) in H5. @@ -763,14 +758,14 @@ Proof. (CRmult R2 (CR_of_Q R2 ((q - r) * (1 # A))) (CRmorph f y)))). apply CRplus_le_compat_l, CRmult_le_compat_r_half. - apply (CRle_lt_trans _ (CRmorph f (CRzero R1))). + apply (CRle_lt_trans _ (CRmorph f 0)). apply CRmorph_zero. apply CRmorph_increasing. exact H. destruct (CRmorph_rat f ((q - r) * (1 # A))). exact H2. apply (CRlt_le_trans _ (CRplus R2 (CR_of_Q R2 r) (CR_of_Q R2 ((q - r))))). apply CRplus_lt_compat_l. * apply (CRmult_lt_reg_l (CR_of_Q R2 (/((q - r) * (1 # A))))). - apply (CRle_lt_trans _ (CR_of_Q R2 0)). apply CR_of_Q_zero. + apply (CRle_lt_trans _ (CR_of_Q R2 0)). apply CRle_refl. apply CR_of_Q_lt, Qinv_lt_0_compat. rewrite <- (Qmult_0_r (q-r)). apply Qmult_lt_l. apply Qlt_minus_iff in H3. exact H3. reflexivity. @@ -781,9 +776,9 @@ Proof. exact (proj2 (Rmul_assoc (CRisRing R2) (CR_of_Q R2 (/ ((q - r) * (1 # A)))) (CR_of_Q R2 ((q - r) * (1 # A))) (CRmorph f y))). - apply (CRle_trans _ (CRmult R2 (CRone R2) (CRmorph f y))). + apply (CRle_trans _ (CRmult R2 1 (CRmorph f y))). apply CRmult_le_compat_r_half. - apply (CRle_lt_trans _ (CRmorph f (CRzero R1))). + apply (CRle_lt_trans _ (CRmorph f 0)). apply CRmorph_zero. apply CRmorph_increasing. exact H. apply (CRle_trans _ (CR_of_Q R2 ((/ ((q - r) * (1 # A))) * ((q - r) * (1 # A))))). @@ -793,7 +788,7 @@ Proof. field_simplify. reflexivity. split. intro H5. inversion H5. intro H5. apply Qlt_minus_iff in H3. rewrite H5 in H3. inversion H3. exact H2. - destruct (CR_of_Q_one R2). exact H2. + apply CRle_refl. destruct (Rmul_1_l (CRisRing R2) (CRmorph f y)). intro H5. contradiction. apply (CRlt_le_trans _ (CR_of_Q R2 (Z.pos A # 1))). @@ -809,7 +804,7 @@ Proof. * apply (CRle_trans _ (CR_of_Q R2 (r + (q-r)))). exact (proj1 (CR_of_Q_plus R2 r (q-r))). destruct (CR_of_Q_morph R2 (r + (q-r)) q). ring. exact H2. - + apply (CRle_lt_trans _ (CRmorph f (CRzero R1))). + + apply (CRle_lt_trans _ (CRmorph f 0)). apply CRmorph_zero. apply CRmorph_increasing. exact H. Qed. @@ -867,10 +862,10 @@ Lemma CRmorph_appart_zero : forall {R1 R2 : ConstructiveReals} CRmorph f x ≶ 0. Proof. intros. destruct app. - - left. apply (CRlt_le_trans _ (CRmorph f (CRzero R1))). + - left. apply (CRlt_le_trans _ (CRmorph f 0)). apply CRmorph_increasing. exact c. exact (proj2 (CRmorph_zero f)). - - right. apply (CRle_lt_trans _ (CRmorph f (CRzero R1))). + - right. apply (CRle_lt_trans _ (CRmorph f 0)). exact (proj1 (CRmorph_zero f)). apply CRmorph_increasing. exact c. Defined. @@ -885,7 +880,7 @@ Lemma CRmorph_inv : forall {R1 R2 : ConstructiveReals} Proof. intros. apply (CRmult_eq_reg_r (CRmorph f x)). destruct fxnz. right. exact c. left. exact c. - apply (CReq_trans _ (CRone R2)). + apply (CReq_trans _ 1). 2: apply CReq_sym, CRinv_l. apply (CReq_trans _ (CRmorph f (CRmult R1 ((/ x) xnz) x))). apply CReq_sym, CRmorph_mult. @@ -915,11 +910,11 @@ Proof. - simpl. unfold INR. rewrite (CRmorph_proper f _ (1 + CR_of_Q R1 (Z.of_nat n # 1))). rewrite CRmorph_plus. unfold INR in IHn. - rewrite IHn. rewrite CRmorph_one, <- CR_of_Q_one, <- CR_of_Q_plus. + rewrite IHn. rewrite CRmorph_one, <- CR_of_Q_plus. apply CR_of_Q_morph. rewrite Qinv_plus_distr. unfold Qeq, Qnum, Qden. do 2 rewrite Z.mul_1_r. rewrite Nat2Z.inj_succ. rewrite <- Z.add_1_l. reflexivity. - rewrite <- CR_of_Q_one, <- CR_of_Q_plus. + rewrite <- CR_of_Q_plus. apply CR_of_Q_morph. rewrite Qinv_plus_distr. unfold Qeq, Qnum, Qden. do 2 rewrite Z.mul_1_r. rewrite Nat2Z.inj_succ. rewrite <- Z.add_1_l. reflexivity. @@ -1047,7 +1042,7 @@ Proof. apply Pos2Z.pos_le_pos, Pos2Nat.inj_le. rewrite Nat2Pos.id. exact H0. destruct i. inversion H0. pose proof (Pos2Nat.is_pos p). rewrite H2 in H1. inversion H1. discriminate. - rewrite <- CR_of_Q_zero. apply CR_of_Q_le. discriminate. + apply CR_of_Q_le. discriminate. rewrite CRplus_0_r. reflexivity. } pose proof (CR_cv_open_above _ _ _ H0 H) as [n nmaj]. apply (CRle_lt_trans _ (CR_of_Q R2 (let (q0, _) := CR_Q_limit x n in diff --git a/theories/Reals/Abstract/ConstructiveSum.v b/theories/Reals/Abstract/ConstructiveSum.v index 11c8e5d8a2..3be03bf615 100644 --- a/theories/Reals/Abstract/ConstructiveSum.v +++ b/theories/Reals/Abstract/ConstructiveSum.v @@ -60,11 +60,11 @@ Lemma sum_const : forall {R : ConstructiveReals} (a : CRcarrier R) (n : nat), CRsum (fun _ => a) n == a * INR (S n). Proof. induction n. - - unfold INR. simpl. rewrite CR_of_Q_one, CRmult_1_r. reflexivity. + - unfold INR. simpl. rewrite CRmult_1_r. reflexivity. - simpl. rewrite IHn. unfold INR. replace (Z.of_nat (S (S n))) with (Z.of_nat (S n) + 1)%Z. rewrite <- Qinv_plus_distr, CR_of_Q_plus, CRmult_plus_distr_l. - apply CRplus_morph. reflexivity. rewrite CR_of_Q_one, CRmult_1_r. reflexivity. + apply CRplus_morph. reflexivity. rewrite CRmult_1_r. reflexivity. replace 1%Z with (Z.of_nat 1). rewrite <- Nat2Z.inj_add. apply f_equal. rewrite Nat.add_comm. reflexivity. reflexivity. Qed. diff --git a/theories/Reals/Cauchy/ConstructiveRcomplete.v b/theories/Reals/Cauchy/ConstructiveRcomplete.v index be844c413a..754f9be5fe 100644 --- a/theories/Reals/Cauchy/ConstructiveRcomplete.v +++ b/theories/Reals/Cauchy/ConstructiveRcomplete.v @@ -309,12 +309,11 @@ Definition CRealConstructive : ConstructiveReals := Build_ConstructiveReals CReal CRealLt CRealLtIsLinear CRealLtProp CRealLtEpsilon CRealLtForget CRealLtDisjunctEpsilon - (inject_Q 0) (inject_Q 1) + inject_Q inject_Q_lt lt_inject_Q CReal_plus CReal_opp CReal_mult + inject_Q_plus inject_Q_mult CReal_isRing CReal_isRingExt CRealLt_0_1 CReal_plus_lt_compat_l CReal_plus_lt_reg_l CReal_mult_lt_0_compat CReal_inv CReal_inv_l CReal_inv_0_lt_compat - inject_Q inject_Q_plus inject_Q_mult - inject_Q_one inject_Q_lt lt_inject_Q CRealQ_dense Rup_pos CReal_abs CRealAbsLUB CRealComplete. diff --git a/theories/Sets/Uniset.v b/theories/Sets/Uniset.v index 31e8cf463e..474b417e8e 100644 --- a/theories/Sets/Uniset.v +++ b/theories/Sets/Uniset.v @@ -44,18 +44,18 @@ Definition In (s:uniset) (a:A) : Prop := charac s a = true. Hint Unfold In : core. (** uniset inclusion *) -Definition incl (s1 s2:uniset) := forall a:A, leb (charac s1 a) (charac s2 a). +Definition incl (s1 s2:uniset) := forall a:A, Bool.le (charac s1 a) (charac s2 a). Hint Unfold incl : core. (** uniset equality *) Definition seq (s1 s2:uniset) := forall a:A, charac s1 a = charac s2 a. Hint Unfold seq : core. -Lemma leb_refl : forall b:bool, leb b b. +Lemma le_refl : forall b, Bool.le b b. Proof. destruct b; simpl; auto. Qed. -Hint Resolve leb_refl : core. +Hint Resolve le_refl : core. Lemma incl_left : forall s1 s2:uniset, seq s1 s2 -> incl s1 s2. Proof. diff --git a/theories/Sorting/Permutation.v b/theories/Sorting/Permutation.v index 1dd9285412..026cf32ceb 100644 --- a/theories/Sorting/Permutation.v +++ b/theories/Sorting/Permutation.v @@ -273,8 +273,8 @@ Proof. exact Permutation_length. Qed. -Instance Permutation_Forall (P : A -> Prop) : - Proper ((@Permutation A) ==> Basics.impl) (Forall P). +Global Instance Permutation_Forall (P : A -> Prop) : + Proper ((@Permutation A) ==> Basics.impl) (Forall P) | 10. Proof. intros l1 l2 HP. induction HP; intro HF; auto. @@ -283,8 +283,8 @@ Proof. inversion_clear HF2; auto. Qed. -Instance Permutation_Exists (P : A -> Prop) : - Proper ((@Permutation A) ==> Basics.impl) (Exists P). +Global Instance Permutation_Exists (P : A -> Prop) : + Proper ((@Permutation A) ==> Basics.impl) (Exists P) | 10. Proof. intros l1 l2 HP. induction HP; intro HF; auto. @@ -581,8 +581,8 @@ Proof. now contradiction (Hf x). Qed. -Instance Permutation_flat_map (g : A -> list B) : - Proper ((@Permutation A) ==> (@Permutation B)) (flat_map g). +Global Instance Permutation_flat_map (g : A -> list B) : + Proper ((@Permutation A) ==> (@Permutation B)) (flat_map g) | 10. Proof. intros l1; induction l1; intros l2 HP. - now apply Permutation_nil in HP; subst. @@ -773,7 +773,7 @@ Qed. End Permutation_alt. -Instance Permutation_list_sum : Proper (@Permutation nat ==> eq) list_sum. +Instance Permutation_list_sum : Proper (@Permutation nat ==> eq) list_sum | 10. Proof. intros l1 l2 HP; induction HP; simpl; intuition. - rewrite 2 (Nat.add_comm x). @@ -781,7 +781,7 @@ Proof. - now transitivity (list_sum l'). Qed. -Instance Permutation_list_max : Proper (@Permutation nat ==> eq) list_max. +Instance Permutation_list_max : Proper (@Permutation nat ==> eq) list_max | 10. Proof. intros l1 l2 HP; induction HP; simpl; intuition. - rewrite 2 (Nat.max_comm x). @@ -806,7 +806,7 @@ Proof. now apply (perm_t_trans IHHP2). Qed. -Instance Permutation_transp_equiv : Equivalence Permutation_transp. +Global Instance Permutation_transp_equiv : Equivalence Permutation_transp | 100. Proof. split. - intros l; apply perm_t_refl. diff --git a/toplevel/ccompile.ml b/toplevel/ccompile.ml index c8b8660b92..524f818523 100644 --- a/toplevel/ccompile.ml +++ b/toplevel/ccompile.ml @@ -92,41 +92,6 @@ let create_empty_file filename = let f = open_out filename in close_out f -let interp_set_option opt v old = - let open Goptions in - let err expect = - let opt = String.concat " " opt in - let got = v in (* avoid colliding with Pp.v *) - CErrors.user_err - Pp.(str "-set: " ++ str opt ++ - str" expects " ++ str expect ++ - str" but got " ++ str got) - in - match old with - | BoolValue _ -> - let v = match String.trim v with - | "true" -> true - | "false" | "" -> false - | _ -> err "a boolean" - in - BoolValue v - | IntValue _ -> - let v = String.trim v in - let v = match int_of_string_opt v with - | Some _ as v -> v - | None -> if v = "" then None else err "an int" - in - IntValue v - | StringValue _ -> StringValue v - | StringOptValue _ -> StringOptValue (Some v) - -let set_option = let open Goptions in function - | opt, OptionUnset -> unset_option_value_gen ~locality:OptLocal opt - | opt, OptionSet None -> set_bool_option_value_gen ~locality:OptLocal opt true - | opt, OptionSet (Some v) -> set_option_value ~locality:OptLocal (interp_set_option opt) opt v - -let set_options = List.iter set_option - (* Compile a vernac file *) let compile opts copts ~echo ~f_in ~f_out = let open Vernac.State in @@ -140,7 +105,7 @@ let compile opts copts ~echo ~f_in ~f_out = ++ str ".") in let ml_load_path, vo_load_path = build_load_path opts in - let require_libs = require_libs opts in + let injections = injection_commands opts in let stm_options = opts.config.stm_flags in let output_native_objects = match opts.config.native_compiler with | NativeOff -> false | NativeOn {ondemand} -> not ondemand @@ -165,11 +130,10 @@ let compile opts copts ~echo ~f_in ~f_out = let doc, sid = Topfmt.(in_phase ~phase:LoadingPrelude) Stm.new_doc Stm.{ doc_type = VoDoc long_f_dot_out; ml_load_path; - vo_load_path; require_libs; stm_options; + vo_load_path; injections; stm_options; } in let state = { doc; sid; proof = None; time = opts.config.time } in let state = load_init_vernaculars opts ~state in - set_options opts.config.set_options; let ldir = Stm.get_ldir ~doc:state.doc in Aux_file.(start_aux_file ~aux_file:(aux_file_name_for long_f_dot_out) @@ -218,12 +182,11 @@ let compile opts copts ~echo ~f_in ~f_out = let doc, sid = Topfmt.(in_phase ~phase:LoadingPrelude) Stm.new_doc Stm.{ doc_type = VioDoc long_f_dot_out; ml_load_path; - vo_load_path; require_libs; stm_options; + vo_load_path; injections; stm_options; } in let state = { doc; sid; proof = None; time = opts.config.time } in let state = load_init_vernaculars opts ~state in - set_options opts.config.set_options; let ldir = Stm.get_ldir ~doc:state.doc in let state = Vernac.load_vernac ~echo ~check:false ~interactive:false ~state long_f_dot_in in let doc = Stm.finish ~doc:state.doc in diff --git a/toplevel/ccompile.mli b/toplevel/ccompile.mli index eb66dbaafc..8c154488d0 100644 --- a/toplevel/ccompile.mli +++ b/toplevel/ccompile.mli @@ -17,5 +17,3 @@ val compile_files : Coqargs.t -> Coqcargs.t -> unit (** [do_vio opts] process [.vio] files in [opts] *) val do_vio : Coqargs.t -> Coqcargs.t -> unit - -val set_options : (Goptions.option_name * Coqargs.option_command) list -> unit diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index 17435c051e..c7ad5edb1f 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -38,8 +38,6 @@ type color = [`ON | `AUTO | `EMACS | `OFF] type native_compiler = NativeOff | NativeOn of { ondemand : bool } -type option_command = OptionSet of string option | OptionUnset - type coqargs_logic_config = { impredicative_set : Declarations.set_predicativity; indices_matter : bool; @@ -59,7 +57,6 @@ type coqargs_config = { debug : bool; time : bool; print_emacs : bool; - set_options : (Goptions.option_name * option_command) list; } type coqargs_pre = { @@ -69,10 +66,9 @@ type coqargs_pre = { ml_includes : string list; vo_includes : Loadpath.vo_path list; - vo_requires : (string * string option * bool option) list; - (* None = No Import; Some false = Import; Some true = Export *) load_vernacular_list : (string * bool) list; + injections : Stm.injection_command list; inputstate : string option; } @@ -124,7 +120,6 @@ let default_config = { debug = false; time = false; print_emacs = false; - set_options = []; (* Quiet / verbosity options should be here *) } @@ -135,8 +130,8 @@ let default_pre = { load_rcfile = true; ml_includes = []; vo_includes = []; - vo_requires = []; load_vernacular_list = []; + injections = []; inputstate = None; } @@ -167,13 +162,13 @@ let add_vo_include opts unix_path coq_path implicit = unix_path; coq_path; has_ml = false; implicit; recursive = true } :: opts.pre.vo_includes }} let add_vo_require opts d p export = - { opts with pre = { opts.pre with vo_requires = (d, p, export) :: opts.pre.vo_requires }} + { opts with pre = { opts.pre with injections = Stm.RequireInjection (d, p, export) :: opts.pre.injections }} let add_load_vernacular opts verb s = - { opts with pre = { opts.pre with load_vernacular_list = (CUnix.make_suffix s ".v",verb) :: opts.pre.load_vernacular_list }} + { opts with pre = { opts.pre with load_vernacular_list = (CUnix.make_suffix s ".v",verb) :: opts.pre.load_vernacular_list }} let add_set_option opts opt_name value = - { opts with config = { opts.config with set_options = (opt_name, value) :: opts.config.set_options }} + { opts with pre = { opts.pre with injections = Stm.OptionInjection (opt_name, value) :: opts.pre.injections }} (** Options for proof general *) let set_emacs opts = @@ -486,10 +481,10 @@ let parse_args ~help ~init arglist : t * string list = | "-set" -> let opt, v = parse_option_set @@ next() in - add_set_option oval opt (OptionSet v) + add_set_option oval opt (Stm.OptionSet v) | "-unset" -> - add_set_option oval (to_opt_key @@ next ()) OptionUnset + add_set_option oval (to_opt_key @@ next ()) Stm.OptionUnset |"-native-output-dir" -> let native_output_dir = next () in @@ -513,18 +508,18 @@ let parse_args ~help ~init arglist : t * string list = |"-config"|"--config" -> set_query oval PrintConfig |"-debug" -> Coqinit.set_debug (); oval |"-diffs" -> - add_set_option oval Proof_diffs.opt_name @@ OptionSet (Some (next ())) + add_set_option oval Proof_diffs.opt_name @@ Stm.OptionSet (Some (next ())) |"-stm-debug" -> Stm.stm_debug := true; oval |"-emacs" -> set_emacs oval |"-impredicative-set" -> set_logic (fun o -> { o with impredicative_set = Declarations.ImpredicativeSet }) oval |"-allow-sprop" -> - add_set_option oval Vernacentries.allow_sprop_opt_name (OptionSet None) + add_set_option oval Vernacentries.allow_sprop_opt_name (Stm.OptionSet None) |"-disallow-sprop" -> - add_set_option oval Vernacentries.allow_sprop_opt_name OptionUnset + add_set_option oval Vernacentries.allow_sprop_opt_name Stm.OptionUnset |"-sprop-cumulative" -> warn_deprecated_sprop_cumul(); - add_set_option oval Vernacentries.cumul_sprop_opt_name (OptionSet None) + add_set_option oval Vernacentries.cumul_sprop_opt_name (Stm.OptionSet None) |"-indices-matter" -> set_logic (fun o -> { o with indices_matter = true }) oval |"-m"|"--memory" -> { oval with post = { oval.post with memory_stat = true }} |"-noinit"|"-nois" -> { oval with pre = { oval.pre with load_init = false }} @@ -564,12 +559,9 @@ let parse_args ~help ~init args = pre = { opts.pre with ml_includes = List.rev opts.pre.ml_includes ; vo_includes = List.rev opts.pre.vo_includes - ; vo_requires = List.rev opts.pre.vo_requires ; load_vernacular_list = List.rev opts.pre.load_vernacular_list + ; injections = List.rev opts.pre.injections } - ; config = { opts.config with - set_options = List.rev opts.config.set_options - } ; } in opts, extra @@ -579,8 +571,8 @@ let parse_args ~help ~init args = (* prelude_data == From Coq Require Import Prelude. *) let prelude_data = "Prelude", Some "Coq", Some false -let require_libs opts = - if opts.pre.load_init then prelude_data :: opts.pre.vo_requires else opts.pre.vo_requires +let injection_commands opts = + if opts.pre.load_init then Stm.RequireInjection prelude_data :: opts.pre.injections else opts.pre.injections let build_load_path opts = let ml_path, vo_path = diff --git a/toplevel/coqargs.mli b/toplevel/coqargs.mli index a51ed6766a..c8634b7847 100644 --- a/toplevel/coqargs.mli +++ b/toplevel/coqargs.mli @@ -14,8 +14,6 @@ val default_toplevel : Names.DirPath.t type native_compiler = NativeOff | NativeOn of { ondemand : bool } -type option_command = OptionSet of string option | OptionUnset - type coqargs_logic_config = { impredicative_set : Declarations.set_predicativity; indices_matter : bool; @@ -35,7 +33,6 @@ type coqargs_config = { debug : bool; time : bool; print_emacs : bool; - set_options : (Goptions.option_name * option_command) list; } type coqargs_pre = { @@ -45,10 +42,10 @@ type coqargs_pre = { ml_includes : CUnix.physical_path list; vo_includes : Loadpath.vo_path list; - vo_requires : (string * string option * bool option) list; - (* None = No Import; Some false = Import; Some true = Export *) load_vernacular_list : (string * bool) list; + injections : Stm.injection_command list; + inputstate : string option; } @@ -79,5 +76,5 @@ val default : t val parse_args : help:Usage.specific_usage -> init:t -> string list -> t * string list val error_wrong_arg : string -> unit -val require_libs : t -> (string * string option * bool option) list +val injection_commands : t -> Stm.injection_command list val build_load_path : t -> CUnix.physical_path list * Loadpath.vo_path list diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 7aad856d0a..2d450d430a 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -243,13 +243,13 @@ let init_document opts = (* Next line allows loading .vos files when in interactive mode *) Flags.load_vos_libraries := true; let ml_load_path, vo_load_path = build_load_path opts in - let require_libs = require_libs opts in + let injections = injection_commands opts in let stm_options = opts.config.stm_flags in let open Vernac.State in let doc, sid = Stm.(new_doc { doc_type = Interactive opts.config.logic.toplevel_name; - ml_load_path; vo_load_path; require_libs; stm_options; + ml_load_path; vo_load_path; injections; stm_options; }) in { doc; sid; proof = None; time = opts.config.time } @@ -273,7 +273,6 @@ type run_mode = Interactive | Batch let init_toploop opts = let state = init_document opts in let state = Ccompile.load_init_vernaculars opts ~state in - Ccompile.set_options opts.config.set_options; state let coqtop_init run_mode ~opts = diff --git a/user-contrib/Ltac2/Notations.v b/user-contrib/Ltac2/Notations.v index 373654e6db..390b39bab1 100644 --- a/user-contrib/Ltac2/Notations.v +++ b/user-contrib/Ltac2/Notations.v @@ -146,7 +146,7 @@ match ev with end. Ltac2 intros0 ev p := - Control.enter (fun () => Std.intros false p). + Control.enter (fun () => Std.intros ev p). Ltac2 Notation "intros" p(intropatterns) := intros0 false p. Ltac2 Notation intros := intros. diff --git a/user-contrib/Ltac2/g_ltac2.mlg b/user-contrib/Ltac2/g_ltac2.mlg index 13c4d667a0..8979170026 100644 --- a/user-contrib/Ltac2/g_ltac2.mlg +++ b/user-contrib/Ltac2/g_ltac2.mlg @@ -289,7 +289,7 @@ GRAMMAR EXTEND Gram ] ] ; tac2def_mut: - [ [ "Set"; qid = Prim.qualid; ":="; e = tac2expr -> { StrMut (qid, e) } ] ] + [ [ "Set"; qid = Prim.qualid; old = OPT [ "as"; id = locident -> { id } ]; ":="; e = tac2expr -> { StrMut (qid, old, e) } ] ] ; tac2typ_knd: [ [ t = tac2type -> { CTydDef (Some t) } diff --git a/user-contrib/Ltac2/tac2entries.ml b/user-contrib/Ltac2/tac2entries.ml index 28e877491e..987cd8c1b8 100644 --- a/user-contrib/Ltac2/tac2entries.ml +++ b/user-contrib/Ltac2/tac2entries.ml @@ -336,7 +336,7 @@ let register_ltac ?(local = false) ?(mut = false) isrec tactics = if isrec then inline_rec_tactic tactics else tactics in let map ({loc;v=id}, e) = - let (e, t) = intern ~strict:true e in + let (e, t) = intern ~strict:true [] e in let () = if not (is_value e) then user_err ?loc (str "Tactic definition must be a syntactical value") @@ -728,19 +728,26 @@ let register_notation ?(local = false) tkn lev body = match tkn, lev with type redefinition = { redef_kn : ltac_constant; redef_body : glb_tacexpr; + redef_old : Id.t option; } let perform_redefinition (_, redef) = let kn = redef.redef_kn in let data = Tac2env.interp_global kn in - let data = { data with Tac2env.gdata_expr = redef.redef_body } in + let body = match redef.redef_old with + | None -> redef.redef_body + | Some id -> + (* Rebind the old value with a let-binding *) + GTacLet (false, [Name id, data.Tac2env.gdata_expr], redef.redef_body) + in + let data = { data with Tac2env.gdata_expr = body } in Tac2env.define_global kn data let subst_redefinition (subst, redef) = let kn = Mod_subst.subst_kn subst redef.redef_kn in let body = Tac2intern.subst_expr subst redef.redef_body in if kn == redef.redef_kn && body == redef.redef_body then redef - else { redef_kn = kn; redef_body = body } + else { redef_kn = kn; redef_body = body; redef_old = redef.redef_old } let classify_redefinition o = Substitute o @@ -751,7 +758,7 @@ let inTac2Redefinition : redefinition -> obj = subst_function = subst_redefinition; classify_function = classify_redefinition } -let register_redefinition ?(local = false) qid e = +let register_redefinition ?(local = false) qid old e = let kn = try Tac2env.locate_ltac qid with Not_found -> user_err ?loc:qid.CAst.loc (str "Unknown tactic " ++ pr_qualid qid) @@ -766,7 +773,11 @@ let register_redefinition ?(local = false) qid e = if not (data.Tac2env.gdata_mutable) then user_err ?loc:qid.CAst.loc (str "The tactic " ++ pr_qualid qid ++ str " is not declared as mutable") in - let (e, t) = intern ~strict:true e in + let ctx = match old with + | None -> [] + | Some { CAst.v = id } -> [id, data.Tac2env.gdata_type] + in + let (e, t) = intern ~strict:true ctx e in let () = if not (is_value e) then user_err ?loc:qid.CAst.loc (str "Tactic definition must be a syntactical value") @@ -777,15 +788,17 @@ let register_redefinition ?(local = false) qid e = user_err ?loc:qid.CAst.loc (str "Type " ++ pr_glbtype name (snd t) ++ str " is not a subtype of " ++ pr_glbtype name (snd data.Tac2env.gdata_type)) in + let old = Option.map (fun { CAst.v = id } -> id) old in let def = { redef_kn = kn; redef_body = e; + redef_old = old; } in Lib.add_anonymous_leaf (inTac2Redefinition def) let perform_eval ~pstate e = let env = Global.env () in - let (e, ty) = Tac2intern.intern ~strict:false e in + let (e, ty) = Tac2intern.intern ~strict:false [] e in let v = Tac2interp.interp Tac2interp.empty_environment e in let selector, proof = match pstate with @@ -818,7 +831,7 @@ let register_struct ?local str = match str with | StrTyp (isrec, t) -> register_type ?local isrec t | StrPrm (id, t, ml) -> register_primitive ?local id t ml | StrSyn (tok, lev, e) -> register_notation ?local tok lev e -| StrMut (qid, e) -> register_redefinition ?local qid e +| StrMut (qid, old, e) -> register_redefinition ?local qid old e (** Toplevel exception *) @@ -913,7 +926,7 @@ let solve ~pstate default tac = let call ~pstate ~default e = let loc = e.loc in - let (e, t) = intern ~strict:false e in + let (e, t) = intern ~strict:false [] e in let () = check_unit ?loc t in let tac = Tac2interp.interp Tac2interp.empty_environment e in solve ~pstate default (Proofview.tclIGNORE tac) diff --git a/user-contrib/Ltac2/tac2expr.mli b/user-contrib/Ltac2/tac2expr.mli index a95d8cc49f..548655f561 100644 --- a/user-contrib/Ltac2/tac2expr.mli +++ b/user-contrib/Ltac2/tac2expr.mli @@ -168,7 +168,7 @@ type strexpr = (** External definition *) | StrSyn of sexpr list * int option * raw_tacexpr (** Syntactic extensions *) -| StrMut of qualid * raw_tacexpr +| StrMut of qualid * Names.lident option * raw_tacexpr (** Redefinition of mutable globals *) (** {5 Dynamic semantics} *) diff --git a/user-contrib/Ltac2/tac2intern.ml b/user-contrib/Ltac2/tac2intern.ml index a4f385d432..797f72702d 100644 --- a/user-contrib/Ltac2/tac2intern.ml +++ b/user-contrib/Ltac2/tac2intern.ml @@ -396,11 +396,13 @@ let is_pure_constructor kn = let rec is_value = function | GTacAtm (AtmInt _) | GTacVar _ | GTacRef _ | GTacFun _ -> true -| GTacAtm (AtmStr _) | GTacApp _ | GTacLet _ -> false +| GTacAtm (AtmStr _) | GTacApp _ | GTacLet (true, _, _) -> false | GTacCst (Tuple _, _, el) -> List.for_all is_value el | GTacCst (_, _, []) -> true | GTacOpn (_, el) -> List.for_all is_value el | GTacCst (Other kn, _, el) -> is_pure_constructor kn && List.for_all is_value el +| GTacLet (false, bnd, e) -> + is_value e && List.for_all (fun (_, e) -> is_value e) bnd | GTacCse _ | GTacPrj _ | GTacSet _ | GTacExt _ | GTacPrm _ | GTacWth _ -> false @@ -458,6 +460,10 @@ let monomorphic (t : UF.elt glb_typexpr) : mix_type_scheme = let subst id = GTypVar (GVar id) in (0, subst_type subst t) +let polymorphic ((n, t) : type_scheme) : mix_type_scheme = + let subst id = GTypVar (LVar id) in + (n, subst_type subst t) + let warn_not_unit = CWarnings.create ~name:"not-unit" ~category:"ltac" (fun () -> strbrk "The following expression should have type unit.") @@ -1138,9 +1144,13 @@ let normalize env (count, vars) (t : UF.elt glb_typexpr) = in subst_type subst t -let intern ~strict e = +type context = (Id.t * type_scheme) list + +let intern ~strict ctx e = let env = empty_env () in let env = if strict then env else { env with env_str = false } in + let fold accu (id, t) = push_name (Name id) (polymorphic t) accu in + let env = List.fold_left fold env ctx in let (e, t) = intern_rec env e in let count = ref 0 in let vars = ref UF.Map.empty in diff --git a/user-contrib/Ltac2/tac2intern.mli b/user-contrib/Ltac2/tac2intern.mli index 8b09ecbcf7..ed251d6201 100644 --- a/user-contrib/Ltac2/tac2intern.mli +++ b/user-contrib/Ltac2/tac2intern.mli @@ -12,7 +12,9 @@ open Names open Mod_subst open Tac2expr -val intern : strict:bool -> raw_tacexpr -> glb_tacexpr * type_scheme +type context = (Id.t * type_scheme) list + +val intern : strict:bool -> context -> raw_tacexpr -> glb_tacexpr * type_scheme val intern_typedef : (KerName.t * int) Id.Map.t -> raw_quant_typedef -> glb_quant_typedef val intern_open_type : raw_typexpr -> type_scheme diff --git a/user-contrib/Ltac2/tac2interp.ml b/user-contrib/Ltac2/tac2interp.ml index 54f2da0621..ed783afce7 100644 --- a/user-contrib/Ltac2/tac2interp.ml +++ b/user-contrib/Ltac2/tac2interp.ml @@ -86,7 +86,7 @@ let rec interp (ist : environment) = function | GTacVar id -> return (get_var ist id) | GTacRef kn -> let data = get_ref ist kn in - return (eval_pure (Some kn) data) + return (eval_pure Id.Map.empty (Some kn) data) | GTacFun (ids, e) -> let cls = { clos_ref = None; clos_env = ist.env_ist; clos_var = ids; clos_exp = e } in let f = interp_app cls in @@ -187,26 +187,41 @@ and interp_set ist e p r = let () = Valexpr.set_field e p r in return (Valexpr.make_int 0) -and eval_pure kn = function +and eval_pure bnd kn = function +| GTacVar id -> Id.Map.get id bnd | GTacAtm (AtmInt n) -> Valexpr.make_int n | GTacRef kn -> let { Tac2env.gdata_expr = e } = try Tac2env.interp_global kn with Not_found -> assert false in - eval_pure (Some kn) e + eval_pure bnd (Some kn) e | GTacFun (na, e) -> - let cls = { clos_ref = kn; clos_env = Id.Map.empty; clos_var = na; clos_exp = e } in + let cls = { clos_ref = kn; clos_env = bnd; clos_var = na; clos_exp = e } in let f = interp_app cls in Tac2ffi.of_closure f | GTacCst (_, n, []) -> Valexpr.make_int n -| GTacCst (_, n, el) -> Valexpr.make_block n (Array.map_of_list eval_unnamed el) -| GTacOpn (kn, el) -> Tac2ffi.of_open (kn, Array.map_of_list eval_unnamed el) -| GTacAtm (AtmStr _) | GTacLet _ | GTacVar _ | GTacSet _ +| GTacCst (_, n, el) -> Valexpr.make_block n (eval_pure_args bnd el) +| GTacOpn (kn, el) -> Tac2ffi.of_open (kn, eval_pure_args bnd el) +| GTacLet (isrec, vals, body) -> + let () = assert (not isrec) in + let fold accu (na, e) = match na with + | Anonymous -> + (* No need to evaluate, we know this is a value *) + accu + | Name id -> + let v = eval_pure bnd None e in + Id.Map.add id v accu + in + let bnd = List.fold_left fold bnd vals in + eval_pure bnd kn body +| GTacAtm (AtmStr _) | GTacSet _ | GTacApp _ | GTacCse _ | GTacPrj _ | GTacPrm _ | GTacExt _ | GTacWth _ -> anomaly (Pp.str "Term is not a syntactical value") -and eval_unnamed e = eval_pure None e +and eval_pure_args bnd args = + let map e = eval_pure bnd None e in + Array.map_of_list map args (** Cross-boundary hacks. *) diff --git a/user-contrib/Ltac2/tac2match.ml b/user-contrib/Ltac2/tac2match.ml index 22f65507c1..86c7b0e3be 100644 --- a/user-contrib/Ltac2/tac2match.ml +++ b/user-contrib/Ltac2/tac2match.ml @@ -131,7 +131,9 @@ module PatternMatching (E:StaticEnvironment) = struct { stream = fun k ctx -> m.stream (fun () ctx -> y.stream k ctx) ctx } (** Failure of the pattern-matching monad: no success. *) - let fail (type a) : a m = { stream = fun _ _ -> Proofview.tclZERO matching_error } + let fail (type a) : a m = { stream = fun _ _ -> + let info = Exninfo.reify () in + Proofview.tclZERO ~info matching_error } let run (m : 'a m) = let ctx = { @@ -150,7 +152,11 @@ module PatternMatching (E:StaticEnvironment) = struct let put_subst subst : unit m = let s = { subst } in - { stream = fun k ctx -> match merge s ctx with None -> Proofview.tclZERO matching_error | Some s -> k () s } + { stream = fun k ctx -> match merge s ctx with + | None -> + let info = Exninfo.reify () in + Proofview.tclZERO ~info matching_error + | Some s -> k () s } (** {6 Pattern-matching} *) diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index 743d1d2026..5323c9f1c6 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -139,7 +139,7 @@ let build_beq_scheme_deps kn = perfomed in a much cleaner way, e.g. using the kernel normal form of constructor types and kernel whd_all for the argument types. *) let rec aux accu c = - let (c,a) = Reductionops.whd_betaiota_stack Evd.empty EConstr.(of_constr c) in + let (c,a) = Reductionops.whd_betaiota_stack env Evd.empty EConstr.(of_constr c) in let (c,a) = EConstr.Unsafe.(to_constr c, List.map to_constr a) in match Constr.kind c with | Cast (x,_,_) -> aux accu (Term.applist (x,a)) @@ -238,7 +238,7 @@ let build_beq_scheme mode kn = let compute_A_equality rel_list nlist eqA ndx t = let lifti = ndx in let rec aux c = - let (c,a) = Reductionops.whd_betaiota_stack Evd.empty EConstr.(of_constr c) in + let (c,a) = Reductionops.whd_betaiota_stack env Evd.empty EConstr.(of_constr c) in let (c,a) = EConstr.Unsafe.(to_constr c, List.map to_constr a) in match Constr.kind c with | Rel x -> mkRel (x-nlist+ndx) diff --git a/vernac/classes.ml b/vernac/classes.ml index eb735b7cdf..55af2e1a7d 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -313,8 +313,8 @@ let instance_hook info global ?hook cst = let declare_instance_constant info global impargs ?hook name udecl poly sigma term termtype = let kind = Decls.(IsDefinition Instance) in - let scope = DeclareDef.Global Declare.ImportDefaultBehavior in - let kn = DeclareDef.declare_definition ~name ~kind ~scope ~impargs + let scope = Declare.Global Declare.ImportDefaultBehavior in + let kn = Declare.declare_definition ~name ~kind ~scope ~impargs ~opaque:false ~poly sigma ~udecl ~types:(Some termtype) ~body:term in instance_hook info global ?hook kn @@ -325,7 +325,7 @@ let do_declare_instance sigma ~global ~poly k u ctx ctx' pri udecl impargs subst in let (_, ty_constr) = instance_constructor (k,u) subst in let termtype = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in - let sigma, entry = DeclareDef.prepare_parameter ~poly sigma ~udecl ~types:termtype in + let sigma, entry = Declare.prepare_parameter ~poly sigma ~udecl ~types:termtype in let cst = Declare.declare_constant ~name ~kind:Decls.(IsAssumption Logical) (Declare.ParameterEntry entry) in DeclareUniv.declare_univ_binders (GlobRef.ConstRef cst) (Evd.universe_binders sigma); @@ -334,7 +334,7 @@ let do_declare_instance sigma ~global ~poly k u ctx ctx' pri udecl impargs subst instance_hook pri global cst let declare_instance_program env sigma ~global ~poly name pri impargs udecl term termtype = - let hook { DeclareDef.Hook.S.scope; dref; _ } = + let hook { Declare.Hook.S.scope; dref; _ } = let cst = match dref with GlobRef.ConstRef kn -> kn | _ -> assert false in let pri = intern_info pri in let env = Global.env () in @@ -342,9 +342,9 @@ let declare_instance_program env sigma ~global ~poly name pri impargs udecl term declare_instance env sigma (Some pri) (not global) (GlobRef.ConstRef cst) in let obls, _, term, typ = RetrieveObl.retrieve_obligations env name sigma 0 term termtype in - let hook = DeclareDef.Hook.make hook in + let hook = Declare.Hook.make hook in let uctx = Evd.evar_universe_context sigma in - let scope, kind = DeclareDef.Global Declare.ImportDefaultBehavior, Decls.Instance in + let scope, kind = Declare.Global Declare.ImportDefaultBehavior, Decls.Instance in let _ : DeclareObl.progress = Obligations.add_definition ~name ~term ~udecl ~scope ~poly ~kind ~hook ~impargs ~uctx typ obls in () @@ -357,7 +357,7 @@ let declare_instance_open sigma ?hook ~tac ~global ~poly id pri impargs udecl id let gls = List.rev (Evd.future_goals sigma) in let sigma = Evd.reset_future_goals sigma in let kind = Decls.(IsDefinition Instance) in - let hook = DeclareDef.Hook.(make (fun { S.dref ; _ } -> instance_hook pri global ?hook dref)) in + let hook = Declare.Hook.(make (fun { S.dref ; _ } -> instance_hook pri global ?hook dref)) in let info = Lemmas.Info.make ~hook ~kind () in (* XXX: We need to normalize the type, otherwise Admitted / Qed will fails! This is due to a bug in proof_global :( *) diff --git a/vernac/classes.mli b/vernac/classes.mli index f410cddfef..1b6deb3b28 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -22,7 +22,7 @@ val declare_instance : ?warn:bool -> env -> Evd.evar_map -> Does nothing — or emit a “not-a-class” warning if the [warn] argument is set — when said type is not a registered type class. *) -val existing_instance : bool -> qualid -> ComHints.hint_info_expr option -> unit +val existing_instance : bool -> qualid -> Vernacexpr.hint_info_expr option -> unit (** globality, reference, optional priority and pattern information *) val new_instance_interactive @@ -34,7 +34,7 @@ val new_instance_interactive -> ?generalize:bool -> ?tac:unit Proofview.tactic -> ?hook:(GlobRef.t -> unit) - -> ComHints.hint_info_expr + -> Vernacexpr.hint_info_expr -> (bool * constr_expr) option -> Id.t * Lemmas.t @@ -47,7 +47,7 @@ val new_instance -> (bool * constr_expr) -> ?generalize:bool -> ?hook:(GlobRef.t -> unit) - -> ComHints.hint_info_expr + -> Vernacexpr.hint_info_expr -> Id.t val new_instance_program @@ -59,7 +59,7 @@ val new_instance_program -> (bool * constr_expr) option -> ?generalize:bool -> ?hook:(GlobRef.t -> unit) - -> ComHints.hint_info_expr + -> Vernacexpr.hint_info_expr -> Id.t val declare_new_instance @@ -69,7 +69,7 @@ val declare_new_instance -> ident_decl -> local_binder_expr list -> constr_expr - -> ComHints.hint_info_expr + -> Vernacexpr.hint_info_expr -> unit (** {6 Low level interface used by Add Morphism, do not use } *) diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index 776ffd6b9f..023d76ce3b 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -87,8 +87,7 @@ let context_set_of_entry = function | Monomorphic_entry uctx -> uctx let declare_assumptions ~poly ~scope ~kind univs nl l = - let open DeclareDef in - let () = match scope with + let () = let open Declare in match scope with | Discharge -> (* declare universes separately for variables *) DeclareUctx.declare_universe_context ~poly (context_set_of_entry (fst univs)) @@ -100,10 +99,10 @@ let declare_assumptions ~poly ~scope ~kind univs nl l = let univs,subst' = List.fold_left_map (fun univs id -> let refu = match scope with - | Discharge -> + | Declare.Discharge -> declare_variable is_coe ~kind typ imps Glob_term.Explicit id; GlobRef.VarRef id.CAst.v, Univ.Instance.empty - | Global local -> + | Declare.Global local -> declare_axiom is_coe ~local ~poly ~kind typ univs imps nl id in next_univs univs, (id.CAst.v, Constr.mkRef refu)) @@ -130,7 +129,7 @@ let process_assumptions_udecls ~scope l = udecl, id | (_, ([], _))::_ | [] -> assert false in - let open DeclareDef in + let open Declare in let () = match scope, udecl with | Discharge, Some _ -> let loc = first_id.CAst.loc in @@ -208,7 +207,7 @@ let context_insection sigma ~poly ctx = let uctx = Evd.evar_universe_context sigma in let kind = Decls.(IsDefinition Definition) in let _ : GlobRef.t = - DeclareDef.declare_entry ~name ~scope:DeclareDef.Discharge + Declare.declare_entry ~name ~scope:Declare.Discharge ~kind ~impargs:[] ~uctx entry in () diff --git a/vernac/comAssumption.mli b/vernac/comAssumption.mli index 4b953c8869..989015a9f3 100644 --- a/vernac/comAssumption.mli +++ b/vernac/comAssumption.mli @@ -17,7 +17,7 @@ open Constrexpr val do_assumptions : program_mode:bool -> poly:bool - -> scope:DeclareDef.locality + -> scope:Declare.locality -> kind:Decls.assumption_object_kind -> Declaremods.inline -> (ident_decl list * constr_expr) with_coercion list diff --git a/vernac/comCoercion.ml b/vernac/comCoercion.ml index 4a8e217fc1..3cc5dd65af 100644 --- a/vernac/comCoercion.ml +++ b/vernac/comCoercion.ml @@ -111,7 +111,7 @@ la liste des variables dont depend la classe source l'indice de la classe source dans la liste lp *) -let get_source lp source = +let get_source env lp source = let open Context.Rel.Declaration in match source with | None -> @@ -120,7 +120,7 @@ let get_source lp source = | [] -> raise Not_found | LocalDef _ :: lt -> aux lt | LocalAssum (_,t1) :: lt -> - let cl1,u1,lv1 = find_class_type Evd.empty (EConstr.of_constr t1) in + let cl1,u1,lv1 = find_class_type env Evd.empty (EConstr.of_constr t1) in cl1,lt,lv1,1 in aux lp | Some cl -> @@ -130,17 +130,17 @@ let get_source lp source = | LocalDef _ as decl :: lt -> aux (decl::acc) lt | LocalAssum (_,t1) as decl :: lt -> try - let cl1,u1,lv1 = find_class_type Evd.empty (EConstr.of_constr t1) in + let cl1,u1,lv1 = find_class_type env Evd.empty (EConstr.of_constr t1) in if cl_typ_eq cl cl1 then cl1,acc,lv1,Context.Rel.nhyps lt+1 else raise Not_found with Not_found -> aux (decl::acc) lt in aux [] (List.rev lp) -let get_target t ind = +let get_target env t ind = if (ind > 1) then CL_FUN else - match pi1 (find_class_type Evd.empty (EConstr.of_constr t)) with + match pi1 (find_class_type env Evd.empty (EConstr.of_constr t)) with | CL_CONST p when Recordops.is_primitive_projection p -> CL_PROJ (Option.get @@ Recordops.find_primitive_projection p) | x -> x @@ -209,7 +209,7 @@ let build_id_coercion idf_opt source poly = match idf_opt with | Some idf -> idf | None -> - let cl,u,_ = find_class_type sigma (EConstr.of_constr t) in + let cl,u,_ = find_class_type env sigma (EConstr.of_constr t) in Id.of_string ("Id_"^(ident_key_of_class source)^"_"^ (ident_key_of_class cl)) in @@ -298,14 +298,15 @@ let warn_uniform_inheritance = let add_new_coercion_core coef stre poly source target isid = check_source source; - let t, _ = Typeops.type_of_global_in_context (Global.env ()) coef in + let env = Global.env () in + let t, _ = Typeops.type_of_global_in_context env coef in if coercion_exists coef then raise (CoercionError AlreadyExists); let lp,tg = decompose_prod_assum t in let llp = List.length lp in if Int.equal llp 0 then raise (CoercionError NotAFunction); let (cls,ctx,lvs,ind) = try - get_source lp source + get_source env lp source with Not_found -> raise (CoercionError (NoSource source)) in @@ -315,7 +316,7 @@ let add_new_coercion_core coef stre poly source target isid = warn_uniform_inheritance coef; let clt = try - get_target tg ind + get_target env tg ind with Not_found -> raise (CoercionError NoTarget) in @@ -352,8 +353,8 @@ let try_add_new_identity_coercion id ~local ~poly ~source ~target = let try_add_new_coercion_with_source ref ~local ~poly ~source = try_add_new_coercion_core ref ~local poly (Some source) None false -let add_coercion_hook poly { DeclareDef.Hook.S.scope; dref; _ } = - let open DeclareDef in +let add_coercion_hook poly { Declare.Hook.S.scope; dref; _ } = + let open Declare in let local = match scope with | Discharge -> assert false (* Local Coercion in section behaves like Local Definition *) | Global ImportNeedQualified -> true @@ -363,10 +364,10 @@ let add_coercion_hook poly { DeclareDef.Hook.S.scope; dref; _ } = let msg = Nametab.pr_global_env Id.Set.empty dref ++ str " is now a coercion" in Flags.if_verbose Feedback.msg_info msg -let add_coercion_hook ~poly = DeclareDef.Hook.make (add_coercion_hook poly) +let add_coercion_hook ~poly = Declare.Hook.make (add_coercion_hook poly) -let add_subclass_hook ~poly { DeclareDef.Hook.S.scope; dref; _ } = - let open DeclareDef in +let add_subclass_hook ~poly { Declare.Hook.S.scope; dref; _ } = + let open Declare in let stre = match scope with | Discharge -> assert false (* Local Subclass in section behaves like Local Definition *) | Global ImportNeedQualified -> true @@ -375,4 +376,4 @@ let add_subclass_hook ~poly { DeclareDef.Hook.S.scope; dref; _ } = let cl = class_of_global dref in try_add_new_coercion_subclass cl ~local:stre ~poly -let add_subclass_hook ~poly = DeclareDef.Hook.make (add_subclass_hook ~poly) +let add_subclass_hook ~poly = Declare.Hook.make (add_subclass_hook ~poly) diff --git a/vernac/comCoercion.mli b/vernac/comCoercion.mli index 3b44bdaf8a..dee693232f 100644 --- a/vernac/comCoercion.mli +++ b/vernac/comCoercion.mli @@ -46,8 +46,8 @@ val try_add_new_identity_coercion -> local:bool -> poly:bool -> source:cl_typ -> target:cl_typ -> unit -val add_coercion_hook : poly:bool -> DeclareDef.Hook.t +val add_coercion_hook : poly:bool -> Declare.Hook.t -val add_subclass_hook : poly:bool -> DeclareDef.Hook.t +val add_subclass_hook : poly:bool -> Declare.Hook.t val class_of_global : GlobRef.t -> cl_typ diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index 66d5a4f7f5..95f3955309 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -117,7 +117,7 @@ let do_definition ?hook ~name ~scope ~poly ~kind udecl bl red_option c ctypopt = in let kind = Decls.IsDefinition kind in let _ : Names.GlobRef.t = - DeclareDef.declare_definition ~name ~scope ~kind ?hook ~impargs + Declare.declare_definition ~name ~scope ~kind ?hook ~impargs ~opaque:false ~poly evd ~udecl ~types ~body in () @@ -126,7 +126,7 @@ let do_definition_program ?hook ~name ~scope ~poly ~kind udecl bl red_option c c let (body, types), evd, udecl, impargs = interp_definition ~program_mode udecl bl ~poly red_option c ctypopt in - let term, ty, uctx, obls = DeclareDef.prepare_obligation ~name ~poly ~body ~types ~udecl evd in + let term, ty, uctx, obls = Declare.prepare_obligation ~name ~poly ~body ~types ~udecl evd in let _ : DeclareObl.progress = Obligations.add_definition ~name ~term ty ~uctx ~udecl ~impargs ~scope ~poly ~kind ?hook obls diff --git a/vernac/comDefinition.mli b/vernac/comDefinition.mli index 337da22018..2e8fe16252 100644 --- a/vernac/comDefinition.mli +++ b/vernac/comDefinition.mli @@ -15,9 +15,9 @@ open Constrexpr (** {6 Definitions/Let} *) val do_definition - : ?hook:DeclareDef.Hook.t + : ?hook:Declare.Hook.t -> name:Id.t - -> scope:DeclareDef.locality + -> scope:Declare.locality -> poly:bool -> kind:Decls.definition_object_kind -> universe_decl_expr option @@ -28,9 +28,9 @@ val do_definition -> unit val do_definition_program - : ?hook:DeclareDef.Hook.t + : ?hook:Declare.Hook.t -> name:Id.t - -> scope:DeclareDef.locality + -> scope:Declare.locality -> poly:bool -> kind:Decls.definition_object_kind -> universe_decl_expr option diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index d3c1d2e767..80ca85e9a6 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -257,7 +257,7 @@ let build_recthms ~indexes fixnames fixtypes fiximps = in let thms = List.map3 (fun name typ (ctx,impargs,_) -> - { DeclareDef.Recthm.name + { Declare.Recthm.name ; typ ; args = List.map Context.Rel.Declaration.get_name ctx ; impargs}) @@ -284,7 +284,7 @@ let declare_fixpoint_generic ?indexes ~scope ~poly ((fixnames,fixrs,fixdefs,fixt let rec_declaration = prepare_recursive_declaration fixnames fixrs fixtypes fixdefs in let fix_kind = Decls.IsDefinition fix_kind in let _ : GlobRef.t list = - DeclareDef.declare_mutually_recursive ~scope ~opaque:false ~kind:fix_kind ~poly ~uctx + Declare.declare_mutually_recursive ~scope ~opaque:false ~kind:fix_kind ~poly ~uctx ~possible_indexes:indexes ~restrict_ucontext:true ~udecl ~ntns ~rec_declaration fixitems in diff --git a/vernac/comFixpoint.mli b/vernac/comFixpoint.mli index dcb61d38d9..62a9d10bae 100644 --- a/vernac/comFixpoint.mli +++ b/vernac/comFixpoint.mli @@ -16,16 +16,16 @@ open Vernacexpr (** Entry points for the vernacular commands Fixpoint and CoFixpoint *) val do_fixpoint_interactive : - scope:DeclareDef.locality -> poly:bool -> fixpoint_expr list -> Lemmas.t + scope:Declare.locality -> poly:bool -> fixpoint_expr list -> Lemmas.t val do_fixpoint : - scope:DeclareDef.locality -> poly:bool -> fixpoint_expr list -> unit + scope:Declare.locality -> poly:bool -> fixpoint_expr list -> unit val do_cofixpoint_interactive : - scope:DeclareDef.locality -> poly:bool -> cofixpoint_expr list -> Lemmas.t + scope:Declare.locality -> poly:bool -> cofixpoint_expr list -> Lemmas.t val do_cofixpoint : - scope:DeclareDef.locality -> poly:bool -> cofixpoint_expr list -> unit + scope:Declare.locality -> poly:bool -> cofixpoint_expr list -> unit (************************************************************************) (** Internal API *) diff --git a/vernac/comHints.ml b/vernac/comHints.ml index 5a48e9c16c..ec37ec7fa8 100644 --- a/vernac/comHints.ml +++ b/vernac/comHints.ml @@ -13,23 +13,6 @@ open Util (** (Partial) implementation of the [Hint] command; some more functionality still lives in tactics/hints.ml *) -type hint_info_expr = Constrexpr.constr_pattern_expr Typeclasses.hint_info_gen - -type reference_or_constr = - | HintsReference of Libnames.qualid - | HintsConstr of Constrexpr.constr_expr - -type hints_expr = - | HintsResolve of (hint_info_expr * bool * reference_or_constr) list - | HintsResolveIFF of bool * Libnames.qualid list * int option - | HintsImmediate of reference_or_constr list - | HintsUnfold of Libnames.qualid list - | HintsTransparency of Libnames.qualid Hints.hints_transparency_target * bool - | HintsMode of Libnames.qualid * Hints.hint_mode list - | HintsConstructors of Libnames.qualid list - | HintsExtern of - int * Constrexpr.constr_expr option * Genarg.raw_generic_argument - let project_hint ~poly pri l2r r = let open EConstr in let open Coqlib in @@ -50,7 +33,7 @@ let project_hint ~poly pri l2r r = let p = if l2r then lib_ref "core.iff.proj1" else lib_ref "core.iff.proj2" in let sigma, p = Evd.fresh_global env sigma p in let c = - Reductionops.whd_beta sigma + Reductionops.whd_beta env sigma (mkApp (c, Context.Rel.to_extended_vect mkRel 0 sign)) in let c = @@ -108,6 +91,7 @@ let interp_hints ~poly h = let fr r = Tacred.evaluable_of_global_reference env (fref r) in let fi c = let open Hints in + let open Vernacexpr in match c with | HintsReference c -> let gr = Smartlocate.global_with_alias c in @@ -126,15 +110,14 @@ let interp_hints ~poly h = in (info, poly, b, path, gr) in - let ft = - let open Hints in - function + let open Hints in + let open Vernacexpr in + let ft = function | HintsVariables -> HintsVariables | HintsConstants -> HintsConstants | HintsReferences lhints -> HintsReferences (List.map fr lhints) in let fp = Constrintern.intern_constr_pattern (Global.env ()) in - let open Hints in match h with | HintsResolve lhints -> HintsResolveEntry (List.map fres lhints) | HintsResolveIFF (l2r, lc, n) -> diff --git a/vernac/comHints.mli b/vernac/comHints.mli index 77fbef5387..20894eecf1 100644 --- a/vernac/comHints.mli +++ b/vernac/comHints.mli @@ -8,22 +8,4 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Typeclasses - -type hint_info_expr = Constrexpr.constr_pattern_expr hint_info_gen - -type reference_or_constr = - | HintsReference of Libnames.qualid - | HintsConstr of Constrexpr.constr_expr - -type hints_expr = - | HintsResolve of (hint_info_expr * bool * reference_or_constr) list - | HintsResolveIFF of bool * Libnames.qualid list * int option - | HintsImmediate of reference_or_constr list - | HintsUnfold of Libnames.qualid list - | HintsTransparency of Libnames.qualid Hints.hints_transparency_target * bool - | HintsMode of Libnames.qualid * Hints.hint_mode list - | HintsConstructors of Libnames.qualid list - | HintsExtern of int * Constrexpr.constr_expr option * Genarg.raw_generic_argument - -val interp_hints : poly:bool -> hints_expr -> Hints.hints_entry +val interp_hints : poly:bool -> Vernacexpr.hints_expr -> Hints.hints_entry diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index cc9b840bed..4242f06844 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -475,7 +475,7 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not let indnames = List.map (fun ind -> ind.ind_name) indl in (* In case of template polymorphism, we need to compute more constraints *) - let env0 = if poly then env0 else Environ.set_universes_lbound env0 Univ.Level.prop in + let env0 = if poly then env0 else Environ.set_universes_lbound env0 UGraph.Bound.Prop in let sigma, env_params, (ctx_params, env_uparams, ctx_uparams, params, userimpls, useruimpls, impls, udecl) = interp_params env0 udecl uparamsl paramsl diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index bf38088f71..4e9e24b119 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -230,7 +230,7 @@ let build_wellfounded (recname,pl,bl,arityc,body) poly r measure notation = let name = add_suffix recname "_func" in (* XXX: Mutating the evar_map in the hook! *) (* XXX: Likely the sigma is out of date when the hook is called .... *) - let hook sigma { DeclareDef.Hook.S.dref; _ } = + let hook sigma { Declare.Hook.S.dref; _ } = let sigma, h_body = Evarutil.new_global sigma dref in let body = it_mkLambda_or_LetIn (mkApp (h_body, [|make|])) binders_rel in let ty = it_mkProd_or_LetIn top_arity binders_rel in @@ -248,13 +248,13 @@ let build_wellfounded (recname,pl,bl,arityc,body) poly r measure notation = hook, name, typ else let typ = it_mkProd_or_LetIn top_arity binders_rel in - let hook sigma { DeclareDef.Hook.S.dref; _ } = + let hook sigma { Declare.Hook.S.dref; _ } = if Impargs.is_implicit_args () || not (List.is_empty impls) then Impargs.declare_manual_implicits false dref impls in hook, recname, typ in (* XXX: Capturing sigma here... bad bad *) - let hook = DeclareDef.Hook.make (hook sigma) in + let hook = Declare.Hook.make (hook sigma) in RetrieveObl.check_evars env sigma; let evars, _, evars_def, evars_typ = RetrieveObl.retrieve_obligations env recname sigma 0 def typ @@ -290,7 +290,7 @@ let do_program_recursive ~scope ~poly fixkind fixl = let evars, _, def, typ = RetrieveObl.retrieve_obligations env name evm (List.length rec_sign) def typ in - ({ DeclareDef.Recthm.name; typ; impargs; args = [] }, def, evars) + ({ Declare.Recthm.name; typ; impargs; args = [] }, def, evars) in let (fixnames,fixrs,fixdefs,fixtypes) = fix in let fiximps = List.map pi2 info in diff --git a/vernac/comProgramFixpoint.mli b/vernac/comProgramFixpoint.mli index 6851c9f69e..8b1fa6c202 100644 --- a/vernac/comProgramFixpoint.mli +++ b/vernac/comProgramFixpoint.mli @@ -14,8 +14,8 @@ open Vernacexpr val do_fixpoint : (* When [false], assume guarded. *) - scope:DeclareDef.locality -> poly:bool -> fixpoint_expr list -> unit + scope:Declare.locality -> poly:bool -> fixpoint_expr list -> unit val do_cofixpoint : (* When [false], assume guarded. *) - scope:DeclareDef.locality -> poly:bool -> cofixpoint_expr list -> unit + scope:Declare.locality -> poly:bool -> cofixpoint_expr list -> unit diff --git a/vernac/declare.ml b/vernac/declare.ml index f4636c5724..c3f95c5297 100644 --- a/vernac/declare.ml +++ b/vernac/declare.ml @@ -16,7 +16,7 @@ open Names open Safe_typing module NamedDecl = Context.Named.Declaration -type opacity_flag = Opaque | Transparent +type opacity_flag = Vernacexpr.opacity_flag = Opaque | Transparent type t = { endline_tactic : Genarg.glob_generic_argument option @@ -120,17 +120,6 @@ let get_open_goals ps = (List.map (fun (l1,l2) -> List.length l1 + List.length l2) stack) + List.length shelf -(* object_kind , id *) -exception AlreadyDeclared of (string option * Id.t) - -let _ = CErrors.register_handler (function - | AlreadyDeclared (kind, id) -> - Some - (seq [ Pp.pr_opt_no_spc (fun s -> str s ++ spc ()) kind - ; Id.print id; str " already exists."]) - | _ -> - None) - type import_status = ImportDefaultBehavior | ImportNeedQualified (** Declaration of constants and parameters *) @@ -267,7 +256,7 @@ type constant_obj = { let load_constant i ((sp,kn), obj) = if Nametab.exists_cci sp then - raise (AlreadyDeclared (None, Libnames.basename sp)); + raise (DeclareUniv.AlreadyDeclared (None, Libnames.basename sp)); let con = Global.constant_of_delta_kn kn in Nametab.push (Nametab.Until i) sp (GlobRef.ConstRef con); Dumpglob.add_constant_kind con obj.cst_kind @@ -287,7 +276,7 @@ let exists_name id = let check_exists id = if exists_name id then - raise (AlreadyDeclared (None, id)) + raise (DeclareUniv.AlreadyDeclared (None, id)) let cache_constant ((sp,kn), obj) = (* Invariant: the constant must exist in the logical environment *) @@ -495,6 +484,17 @@ let declare_constant ?(local = ImportDefaultBehavior) ~name ~kind cd = let () = register_constant kn kind local in kn +let get_cd_fix_exn = function + | DefinitionEntry de -> + Future.fix_exn_of de.proof_entry_body + | _ -> fun x -> x + +let declare_constant ?local ~name ~kind cd = + try declare_constant ?local ~name ~kind cd + with exn -> + let exn = Exninfo.capture exn in + Exninfo.iraise (get_cd_fix_exn cd exn) + let declare_private_constant ?role ?(local = ImportDefaultBehavior) ~name ~kind de = let kn, eff = let de = @@ -537,7 +537,7 @@ let inVariable v = Libobject.Dyn.Easy.inj v objVariable let declare_variable ~name ~kind d = (* Variables are distinguished by only short names *) if Decls.variable_exists name then - raise (AlreadyDeclared (None, name)); + raise (DeclareUniv.AlreadyDeclared (None, name)); let impl,opaque = match d with (* Fails if not well-typed *) | SectionLocalAssum {typ;impl} -> @@ -620,8 +620,6 @@ module Internal = struct let set_opacity ~opaque entry = { entry with proof_entry_opaque = opaque } - let get_fix_exn entry = Future.fix_exn_of entry.proof_entry_body - let rec decompose len c t accu = let open Constr in let open Context.Rel.Declaration in @@ -877,3 +875,181 @@ let _ = Ind_tables.declare_definition_scheme := declare_definition_scheme let _ = Abstract.declare_abstract := declare_abstract let declare_universe_context = DeclareUctx.declare_universe_context + +type locality = Discharge | Global of import_status + +(* Hooks naturally belong here as they apply to both definitions and lemmas *) +module Hook = struct + module S = struct + type t = + { uctx : UState.t + (** [ustate]: universe constraints obtained when the term was closed *) + ; obls : (Names.Id.t * Constr.t) list + (** [(n1,t1),...(nm,tm)]: association list between obligation + name and the corresponding defined term (might be a constant, + but also an arbitrary term in the Expand case of obligations) *) + ; scope : locality + (** [locality]: Locality of the original declaration *) + ; dref : Names.GlobRef.t + (** [ref]: identifier of the original declaration *) + } + end + + type t = (S.t -> unit) CEphemeron.key + + let make hook = CEphemeron.create hook + + let call ?hook x = Option.iter (fun hook -> CEphemeron.get hook x) hook + +end + +(* Locality stuff *) +let declare_entry ~name ~scope ~kind ?hook ?(obls=[]) ~impargs ~uctx entry = + let should_suggest = entry.proof_entry_opaque && + Option.is_empty entry.proof_entry_secctx in + let ubind = UState.universe_binders uctx in + let dref = match scope with + | Discharge -> + let () = declare_variable ~name ~kind (SectionLocalDef entry) in + if should_suggest then Proof_using.suggest_variable (Global.env ()) name; + Names.GlobRef.VarRef name + | Global local -> + let kn = declare_constant ~name ~local ~kind (DefinitionEntry entry) in + let gr = Names.GlobRef.ConstRef kn in + if should_suggest then Proof_using.suggest_constant (Global.env ()) kn; + let () = DeclareUniv.declare_univ_binders gr ubind in + gr + in + let () = Impargs.maybe_declare_manual_implicits false dref impargs in + let () = definition_message name in + Option.iter (fun hook -> Hook.call ~hook { Hook.S.uctx; obls; scope; dref }) hook; + dref + +let mutual_make_bodies ~fixitems ~rec_declaration ~possible_indexes = + match possible_indexes with + | Some possible_indexes -> + let env = Global.env() in + let indexes = Pretyping.search_guard env possible_indexes rec_declaration in + let vars = Vars.universes_of_constr (Constr.mkFix ((indexes,0),rec_declaration)) in + let fixdecls = CList.map_i (fun i _ -> Constr.mkFix ((indexes,i),rec_declaration)) 0 fixitems in + vars, fixdecls, Some indexes + | None -> + let fixdecls = CList.map_i (fun i _ -> Constr.mkCoFix (i,rec_declaration)) 0 fixitems in + let vars = Vars.universes_of_constr (List.hd fixdecls) in + vars, fixdecls, None + +module Recthm = struct + type t = + { name : Names.Id.t + (** Name of theorem *) + ; typ : Constr.t + (** Type of theorem *) + ; args : Names.Name.t list + (** Names to pre-introduce *) + ; impargs : Impargs.manual_implicits + (** Explicitily declared implicit arguments *) + } +end + +let declare_mutually_recursive ~opaque ~scope ~kind ~poly ~uctx ~udecl ~ntns ~rec_declaration ~possible_indexes ?(restrict_ucontext=true) fixitems = + let vars, fixdecls, indexes = + mutual_make_bodies ~fixitems ~rec_declaration ~possible_indexes in + let uctx, univs = + (* XXX: Obligations don't do this, this seems like a bug? *) + if restrict_ucontext + then + let uctx = UState.restrict uctx vars in + let univs = UState.check_univ_decl ~poly uctx udecl in + uctx, univs + else + let univs = UState.univ_entry ~poly uctx in + uctx, univs + in + let csts = CList.map2 + (fun Recthm.{ name; typ; impargs } body -> + let entry = definition_entry ~opaque ~types:typ ~univs body in + declare_entry ~name ~scope ~kind ~impargs ~uctx entry) + fixitems fixdecls + in + let isfix = Option.has_some possible_indexes in + let fixnames = List.map (fun { Recthm.name } -> name) fixitems in + recursive_message isfix indexes fixnames; + List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns; + csts + +let warn_let_as_axiom = + CWarnings.create ~name:"let-as-axiom" ~category:"vernacular" + Pp.(fun id -> strbrk "Let definition" ++ spc () ++ Names.Id.print id ++ + spc () ++ strbrk "declared as an axiom.") + +let declare_assumption ~name ~scope ~hook ~impargs ~uctx pe = + let local = match scope with + | Discharge -> warn_let_as_axiom name; ImportNeedQualified + | Global local -> local + in + let kind = Decls.(IsAssumption Conjectural) in + let decl = ParameterEntry pe in + let kn = declare_constant ~name ~local ~kind decl in + let dref = Names.GlobRef.ConstRef kn in + let () = Impargs.maybe_declare_manual_implicits false dref impargs in + let () = assumption_message name in + let () = DeclareUniv.declare_univ_binders dref (UState.universe_binders uctx) in + let () = Hook.(call ?hook { S.uctx; obls = []; scope; dref}) in + dref + +let declare_assumption ?fix_exn ~name ~scope ~hook ~impargs ~uctx pe = + try declare_assumption ~name ~scope ~hook ~impargs ~uctx pe + with exn -> + let exn = Exninfo.capture exn in + let exn = Option.cata (fun fix -> fix exn) exn fix_exn in + Exninfo.iraise exn + +(* Preparing proof entries *) + +let prepare_definition ?opaque ?inline ?fix_exn ~poly ~udecl ~types ~body sigma = + let env = Global.env () in + Pretyping.check_evars_are_solved ~program_mode:false env sigma; + let sigma, (body, types) = Evarutil.finalize ~abort_on_undefined_evars:true + sigma (fun nf -> nf body, Option.map nf types) + in + let univs = Evd.check_univ_decl ~poly sigma udecl in + let entry = definition_entry ?fix_exn ?opaque ?inline ?types ~univs body in + let uctx = Evd.evar_universe_context sigma in + entry, uctx + +let declare_definition ~name ~scope ~kind ~opaque ~impargs ~udecl ?hook + ?obls ~poly ?inline ~types ~body ?fix_exn sigma = + let entry, uctx = prepare_definition ?fix_exn ~opaque ~poly ~udecl ~types ~body ?inline sigma in + declare_entry ~name ~scope ~kind ~impargs ?obls ?hook ~uctx entry + +let prepare_obligation ?opaque ?inline ~name ~poly ~udecl ~types ~body sigma = + let sigma, (body, types) = Evarutil.finalize ~abort_on_undefined_evars:false + sigma (fun nf -> nf body, Option.map nf types) + in + let univs = Evd.check_univ_decl ~poly sigma udecl in + let ce = definition_entry ?opaque ?inline ?types ~univs body in + let env = Global.env () in + let (c,ctx), sideff = Future.force ce.proof_entry_body in + assert(Safe_typing.is_empty_private_constants sideff.Evd.seff_private); + assert(Univ.ContextSet.is_empty ctx); + RetrieveObl.check_evars env sigma; + let c = EConstr.of_constr c in + let typ = match ce.proof_entry_type with + | Some t -> EConstr.of_constr t + | None -> Retyping.get_type_of env sigma c + in + let obls, _, c, cty = RetrieveObl.retrieve_obligations env name sigma 0 c typ in + let uctx = Evd.evar_universe_context sigma in + c, cty, uctx, obls + +let prepare_parameter ~poly ~udecl ~types sigma = + let env = Global.env () in + Pretyping.check_evars_are_solved ~program_mode:false env sigma; + let sigma, typ = Evarutil.finalize ~abort_on_undefined_evars:true + sigma (fun nf -> nf types) + in + let univs = Evd.check_univ_decl ~poly sigma udecl in + sigma, (None(*proof using*), (typ, univs), None(*inline*)) + +(* Compat: will remove *) +exception AlreadyDeclared = DeclareUniv.AlreadyDeclared diff --git a/vernac/declare.mli b/vernac/declare.mli index a297f25868..340c035d1d 100644 --- a/vernac/declare.mli +++ b/vernac/declare.mli @@ -69,7 +69,7 @@ module Proof : sig end -type opacity_flag = Opaque | Transparent +type opacity_flag = Vernacexpr.opacity_flag = Opaque | Transparent (** [start_proof ~name ~udecl ~poly sigma goals] starts a proof of name [name] with goals [goals] (a list of pairs of environment and @@ -194,14 +194,9 @@ val inline_private_constants val definition_message : Id.t -> unit val assumption_message : Id.t -> unit val fixpoint_message : int array option -> Id.t list -> unit -val recursive_message : bool (** true = fixpoint *) -> - int array option -> Id.t list -> unit val check_exists : Id.t -> unit -(* Used outside this module only in indschemes *) -exception AlreadyDeclared of (string option * Id.t) - (** {6 For legacy support, do not use} *) module Internal : sig @@ -211,10 +206,6 @@ module Internal : sig (* Overriding opacity is indeed really hacky *) val set_opacity : opaque:bool -> 'a proof_entry -> 'a proof_entry - (* TODO: This is only used in DeclareDef to forward the fix to - hooks, should eventually go away *) - val get_fix_exn : 'a proof_entry -> Future.fix_exn - val shrink_entry : EConstr.named_context -> 'a proof_entry -> 'a proof_entry * Constr.constr list type constant_obj @@ -282,3 +273,127 @@ val build_constant_by_tactic : val declare_universe_context : poly:bool -> Univ.ContextSet.t -> unit [@@ocaml.deprecated "Use DeclareUctx.declare_universe_context"] + +type locality = Discharge | Global of import_status + +(** Declaration hooks *) +module Hook : sig + type t + + (** Hooks allow users of the API to perform arbitrary actions at + proof/definition saving time. For example, to register a constant + as a Coercion, perform some cleanup, update the search database, + etc... *) + module S : sig + type t = + { uctx : UState.t + (** [ustate]: universe constraints obtained when the term was closed *) + ; obls : (Id.t * Constr.t) list + (** [(n1,t1),...(nm,tm)]: association list between obligation + name and the corresponding defined term (might be a constant, + but also an arbitrary term in the Expand case of obligations) *) + ; scope : locality + (** [scope]: Locality of the original declaration *) + ; dref : GlobRef.t + (** [dref]: identifier of the original declaration *) + } + end + + val make : (S.t -> unit) -> t + val call : ?hook:t -> S.t -> unit +end + +(** Declare an interactively-defined constant *) +val declare_entry + : name:Id.t + -> scope:locality + -> kind:Decls.logical_kind + -> ?hook:Hook.t + -> ?obls:(Id.t * Constr.t) list + -> impargs:Impargs.manual_implicits + -> uctx:UState.t + -> Evd.side_effects proof_entry + -> GlobRef.t + +(** Declares a non-interactive constant; [body] and [types] will be + normalized w.r.t. the passed [evar_map] [sigma]. Universes should + be handled properly, including minimization and restriction. Note + that [sigma] is checked for unresolved evars, thus you should be + careful not to submit open terms or evar maps with stale, + unresolved existentials *) +val declare_definition + : name:Id.t + -> scope:locality + -> kind:Decls.logical_kind + -> opaque:bool + -> impargs:Impargs.manual_implicits + -> udecl:UState.universe_decl + -> ?hook:Hook.t + -> ?obls:(Id.t * Constr.t) list + -> poly:bool + -> ?inline:bool + -> types:EConstr.t option + -> body:EConstr.t + -> ?fix_exn:(Exninfo.iexn -> Exninfo.iexn) + -> Evd.evar_map + -> GlobRef.t + +val declare_assumption + : ?fix_exn:(Exninfo.iexn -> Exninfo.iexn) + -> name:Id.t + -> scope:locality + -> hook:Hook.t option + -> impargs:Impargs.manual_implicits + -> uctx:UState.t + -> Entries.parameter_entry + -> GlobRef.t + +module Recthm : sig + type t = + { name : Id.t + (** Name of theorem *) + ; typ : Constr.t + (** Type of theorem *) + ; args : Name.t list + (** Names to pre-introduce *) + ; impargs : Impargs.manual_implicits + (** Explicitily declared implicit arguments *) + } +end + +val declare_mutually_recursive + : opaque:bool + -> scope:locality + -> kind:Decls.logical_kind + -> poly:bool + -> uctx:UState.t + -> udecl:UState.universe_decl + -> ntns:Vernacexpr.decl_notation list + -> rec_declaration:Constr.rec_declaration + -> possible_indexes:int list list option + -> ?restrict_ucontext:bool + (** XXX: restrict_ucontext should be always true, this seems like a + bug in obligations, so this parameter should go away *) + -> Recthm.t list + -> Names.GlobRef.t list + +val prepare_obligation + : ?opaque:bool + -> ?inline:bool + -> name:Id.t + -> poly:bool + -> udecl:UState.universe_decl + -> types:EConstr.t option + -> body:EConstr.t + -> Evd.evar_map + -> Constr.constr * Constr.types * UState.t * RetrieveObl.obligation_info + +val prepare_parameter + : poly:bool + -> udecl:UState.universe_decl + -> types:EConstr.types + -> Evd.evar_map + -> Evd.evar_map * Entries.parameter_entry + +(* Compat: will remove *) +exception AlreadyDeclared of (string option * Names.Id.t) diff --git a/vernac/declareDef.ml b/vernac/declareDef.ml index 1809c2bc91..83bb1dae71 100644 --- a/vernac/declareDef.ml +++ b/vernac/declareDef.ml @@ -1,193 +1,9 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -open Declare - -type locality = Discharge | Global of Declare.import_status - -(* Hooks naturally belong here as they apply to both definitions and lemmas *) -module Hook = struct - module S = struct - type t = - { uctx : UState.t - (** [ustate]: universe constraints obtained when the term was closed *) - ; obls : (Names.Id.t * Constr.t) list - (** [(n1,t1),...(nm,tm)]: association list between obligation - name and the corresponding defined term (might be a constant, - but also an arbitrary term in the Expand case of obligations) *) - ; scope : locality - (** [locality]: Locality of the original declaration *) - ; dref : Names.GlobRef.t - (** [ref]: identifier of the original declaration *) - } - end - - type t = (S.t -> unit) CEphemeron.key - - let make hook = CEphemeron.create hook - - let call ?hook x = Option.iter (fun hook -> CEphemeron.get hook x) hook - -end - -(* Locality stuff *) -let declare_entry ~name ~scope ~kind ?hook ?(obls=[]) ~impargs ~uctx entry = - let should_suggest = entry.Declare.proof_entry_opaque && - Option.is_empty entry.Declare.proof_entry_secctx in - let ubind = UState.universe_binders uctx in - let dref = match scope with - | Discharge -> - let () = declare_variable ~name ~kind (SectionLocalDef entry) in - if should_suggest then Proof_using.suggest_variable (Global.env ()) name; - Names.GlobRef.VarRef name - | Global local -> - let kn = declare_constant ~name ~local ~kind (DefinitionEntry entry) in - let gr = Names.GlobRef.ConstRef kn in - if should_suggest then Proof_using.suggest_constant (Global.env ()) kn; - let () = DeclareUniv.declare_univ_binders gr ubind in - gr - in - let () = Impargs.maybe_declare_manual_implicits false dref impargs in - let () = definition_message name in - Option.iter (fun hook -> Hook.call ~hook { Hook.S.uctx; obls; scope; dref }) hook; - dref - -let declare_entry ~name ~scope ~kind ?hook ?obls ~impargs ~uctx entry = - try declare_entry ~name ~scope ~kind ?hook ?obls ~impargs ~uctx entry - with exn -> - let exn = Exninfo.capture exn in - let fix_exn = Declare.Internal.get_fix_exn entry in - Exninfo.iraise (fix_exn exn) - -let mutual_make_bodies ~fixitems ~rec_declaration ~possible_indexes = - match possible_indexes with - | Some possible_indexes -> - let env = Global.env() in - let indexes = Pretyping.search_guard env possible_indexes rec_declaration in - let vars = Vars.universes_of_constr (Constr.mkFix ((indexes,0),rec_declaration)) in - let fixdecls = CList.map_i (fun i _ -> Constr.mkFix ((indexes,i),rec_declaration)) 0 fixitems in - vars, fixdecls, Some indexes - | None -> - let fixdecls = CList.map_i (fun i _ -> Constr.mkCoFix (i,rec_declaration)) 0 fixitems in - let vars = Vars.universes_of_constr (List.hd fixdecls) in - vars, fixdecls, None - -module Recthm = struct - type t = - { name : Names.Id.t - (** Name of theorem *) - ; typ : Constr.t - (** Type of theorem *) - ; args : Names.Name.t list - (** Names to pre-introduce *) - ; impargs : Impargs.manual_implicits - (** Explicitily declared implicit arguments *) - } -end - -let declare_mutually_recursive ~opaque ~scope ~kind ~poly ~uctx ~udecl ~ntns ~rec_declaration ~possible_indexes ?(restrict_ucontext=true) fixitems = - let vars, fixdecls, indexes = - mutual_make_bodies ~fixitems ~rec_declaration ~possible_indexes in - let uctx, univs = - (* XXX: Obligations don't do this, this seems like a bug? *) - if restrict_ucontext - then - let uctx = UState.restrict uctx vars in - let univs = UState.check_univ_decl ~poly uctx udecl in - uctx, univs - else - let univs = UState.univ_entry ~poly uctx in - uctx, univs - in - let csts = CList.map2 - (fun Recthm.{ name; typ; impargs } body -> - let entry = Declare.definition_entry ~opaque ~types:typ ~univs body in - declare_entry ~name ~scope ~kind ~impargs ~uctx entry) - fixitems fixdecls - in - let isfix = Option.has_some possible_indexes in - let fixnames = List.map (fun { Recthm.name } -> name) fixitems in - Declare.recursive_message isfix indexes fixnames; - List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns; - csts - -let warn_let_as_axiom = - CWarnings.create ~name:"let-as-axiom" ~category:"vernacular" - Pp.(fun id -> strbrk "Let definition" ++ spc () ++ Names.Id.print id ++ - spc () ++ strbrk "declared as an axiom.") - -let declare_assumption ~name ~scope ~hook ~impargs ~uctx pe = - let local = match scope with - | Discharge -> warn_let_as_axiom name; Declare.ImportNeedQualified - | Global local -> local - in - let kind = Decls.(IsAssumption Conjectural) in - let decl = Declare.ParameterEntry pe in - let kn = Declare.declare_constant ~name ~local ~kind decl in - let dref = Names.GlobRef.ConstRef kn in - let () = Impargs.maybe_declare_manual_implicits false dref impargs in - let () = Declare.assumption_message name in - let () = DeclareUniv.declare_univ_binders dref (UState.universe_binders uctx) in - let () = Hook.(call ?hook { S.uctx; obls = []; scope; dref}) in - dref - -let declare_assumption ?fix_exn ~name ~scope ~hook ~impargs ~uctx pe = - try declare_assumption ~name ~scope ~hook ~impargs ~uctx pe - with exn -> - let exn = Exninfo.capture exn in - let exn = Option.cata (fun fix -> fix exn) exn fix_exn in - Exninfo.iraise exn - -(* Preparing proof entries *) - -let prepare_definition ?opaque ?inline ?fix_exn ~poly ~udecl ~types ~body sigma = - let env = Global.env () in - Pretyping.check_evars_are_solved ~program_mode:false env sigma; - let sigma, (body, types) = Evarutil.finalize ~abort_on_undefined_evars:true - sigma (fun nf -> nf body, Option.map nf types) - in - let univs = Evd.check_univ_decl ~poly sigma udecl in - let entry = definition_entry ?fix_exn ?opaque ?inline ?types ~univs body in - let uctx = Evd.evar_universe_context sigma in - entry, uctx - -let declare_definition ~name ~scope ~kind ~opaque ~impargs ~udecl ?hook - ?obls ~poly ?inline ~types ~body ?fix_exn sigma = - let entry, uctx = prepare_definition ?fix_exn ~opaque ~poly ~udecl ~types ~body ?inline sigma in - declare_entry ~name ~scope ~kind ~impargs ?obls ?hook ~uctx entry - -let prepare_obligation ?opaque ?inline ~name ~poly ~udecl ~types ~body sigma = - let sigma, (body, types) = Evarutil.finalize ~abort_on_undefined_evars:false - sigma (fun nf -> nf body, Option.map nf types) - in - let univs = Evd.check_univ_decl ~poly sigma udecl in - let ce = definition_entry ?opaque ?inline ?types ~univs body in - let env = Global.env () in - let (c,ctx), sideff = Future.force ce.Declare.proof_entry_body in - assert(Safe_typing.is_empty_private_constants sideff.Evd.seff_private); - assert(Univ.ContextSet.is_empty ctx); - RetrieveObl.check_evars env sigma; - let c = EConstr.of_constr c in - let typ = match ce.Declare.proof_entry_type with - | Some t -> EConstr.of_constr t - | None -> Retyping.get_type_of env sigma c - in - let obls, _, c, cty = RetrieveObl.retrieve_obligations env name sigma 0 c typ in - let uctx = Evd.evar_universe_context sigma in - c, cty, uctx, obls - -let prepare_parameter ~poly ~udecl ~types sigma = - let env = Global.env () in - Pretyping.check_evars_are_solved ~program_mode:false env sigma; - let sigma, typ = Evarutil.finalize ~abort_on_undefined_evars:true - sigma (fun nf -> nf types) - in - let univs = Evd.check_univ_decl ~poly sigma udecl in - sigma, (None(*proof using*), (typ, univs), None(*inline*)) +type locality = Declare.locality = + | Discharge [@ocaml.deprecated "Use [Declare.Discharge]"] + | Global of Declare.import_status [@ocaml.deprecated "Use [Declare.Global]"] +[@@ocaml.deprecated "Use [Declare.locality]"] + +let declare_definition = Declare.declare_definition +[@@ocaml.deprecated "Use [Declare.declare_definition]"] +module Hook = Declare.Hook +[@@ocaml.deprecated "Use [Declare.Hook]"] diff --git a/vernac/declareDef.mli b/vernac/declareDef.mli deleted file mode 100644 index 3bc1e25f19..0000000000 --- a/vernac/declareDef.mli +++ /dev/null @@ -1,132 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -open Names - -type locality = Discharge | Global of Declare.import_status - -(** Declaration hooks *) -module Hook : sig - type t - - (** Hooks allow users of the API to perform arbitrary actions at - proof/definition saving time. For example, to register a constant - as a Coercion, perform some cleanup, update the search database, - etc... *) - module S : sig - type t = - { uctx : UState.t - (** [ustate]: universe constraints obtained when the term was closed *) - ; obls : (Id.t * Constr.t) list - (** [(n1,t1),...(nm,tm)]: association list between obligation - name and the corresponding defined term (might be a constant, - but also an arbitrary term in the Expand case of obligations) *) - ; scope : locality - (** [scope]: Locality of the original declaration *) - ; dref : GlobRef.t - (** [dref]: identifier of the original declaration *) - } - end - - val make : (S.t -> unit) -> t - val call : ?hook:t -> S.t -> unit -end - -(** Declare an interactively-defined constant *) -val declare_entry - : name:Id.t - -> scope:locality - -> kind:Decls.logical_kind - -> ?hook:Hook.t - -> ?obls:(Id.t * Constr.t) list - -> impargs:Impargs.manual_implicits - -> uctx:UState.t - -> Evd.side_effects Declare.proof_entry - -> GlobRef.t - -(** Declares a non-interactive constant; [body] and [types] will be - normalized w.r.t. the passed [evar_map] [sigma]. Universes should - be handled properly, including minimization and restriction. Note - that [sigma] is checked for unresolved evars, thus you should be - careful not to submit open terms or evar maps with stale, - unresolved existentials *) -val declare_definition - : name:Id.t - -> scope:locality - -> kind:Decls.logical_kind - -> opaque:bool - -> impargs:Impargs.manual_implicits - -> udecl:UState.universe_decl - -> ?hook:Hook.t - -> ?obls:(Id.t * Constr.t) list - -> poly:bool - -> ?inline:bool - -> types:EConstr.t option - -> body:EConstr.t - -> ?fix_exn:(Exninfo.iexn -> Exninfo.iexn) - -> Evd.evar_map - -> GlobRef.t - -val declare_assumption - : ?fix_exn:(Exninfo.iexn -> Exninfo.iexn) - -> name:Id.t - -> scope:locality - -> hook:Hook.t option - -> impargs:Impargs.manual_implicits - -> uctx:UState.t - -> Entries.parameter_entry - -> GlobRef.t - -module Recthm : sig - type t = - { name : Id.t - (** Name of theorem *) - ; typ : Constr.t - (** Type of theorem *) - ; args : Name.t list - (** Names to pre-introduce *) - ; impargs : Impargs.manual_implicits - (** Explicitily declared implicit arguments *) - } -end - -val declare_mutually_recursive - : opaque:bool - -> scope:locality - -> kind:Decls.logical_kind - -> poly:bool - -> uctx:UState.t - -> udecl:UState.universe_decl - -> ntns:Vernacexpr.decl_notation list - -> rec_declaration:Constr.rec_declaration - -> possible_indexes:int list list option - -> ?restrict_ucontext:bool - (** XXX: restrict_ucontext should be always true, this seems like a - bug in obligations, so this parameter should go away *) - -> Recthm.t list - -> Names.GlobRef.t list - -val prepare_obligation - : ?opaque:bool - -> ?inline:bool - -> name:Id.t - -> poly:bool - -> udecl:UState.universe_decl - -> types:EConstr.t option - -> body:EConstr.t - -> Evd.evar_map - -> Constr.constr * Constr.types * UState.t * RetrieveObl.obligation_info - -val prepare_parameter - : poly:bool - -> udecl:UState.universe_decl - -> types:EConstr.types - -> Evd.evar_map - -> Evd.evar_map * Entries.parameter_entry diff --git a/vernac/declareObl.ml b/vernac/declareObl.ml index bba3687256..9ea54f5d8f 100644 --- a/vernac/declareObl.ml +++ b/vernac/declareObl.ml @@ -55,10 +55,10 @@ module ProgramDecl = struct ; prg_implicits : Impargs.manual_implicits ; prg_notations : Vernacexpr.decl_notation list ; prg_poly : bool - ; prg_scope : DeclareDef.locality + ; prg_scope : Declare.locality ; prg_kind : Decls.definition_object_kind ; prg_reduce : constr -> constr - ; prg_hook : DeclareDef.Hook.t option + ; prg_hook : Declare.Hook.t option ; prg_opaque : bool } @@ -111,11 +111,6 @@ open ProgramDecl (* Saving an obligation *) -let get_shrink_obligations = - Goptions.declare_bool_option_and_ref ~depr:true (* remove in 8.8 *) - ~key:["Shrink"; "Obligations"] - ~value:true - (* XXX: Is this the right place for this? *) let it_mkLambda_or_LetIn_or_clean t ctx = let open Context.Rel.Declaration in @@ -190,7 +185,7 @@ let add_hint local prg cst = (* true = hide obligations *) let get_hide_obligations = Goptions.declare_bool_option_and_ref - ~depr:false + ~depr:true ~key:["Hide"; "Obligations"] ~value:false @@ -203,7 +198,7 @@ let declare_obligation prg obl body ty uctx = let opaque = (not force) && opaque in let poly = prg.prg_poly in let ctx, body, ty, args = - if get_shrink_obligations () && not poly then shrink_body body ty + if not poly then shrink_body body ty else ([], body, ty, [||]) in let ce = Declare.definition_entry ?types:ty ~opaque ~univs:uctx body in @@ -373,7 +368,7 @@ let declare_definition prg = (* XXX: This is doing normalization twice *) let () = progmap_remove prg in let kn = - DeclareDef.declare_definition ~name ~scope ~kind ~impargs ?hook ~obls + Declare.declare_definition ~name ~scope ~kind ~impargs ?hook ~obls ~fix_exn ~opaque ~poly ~udecl ~types ~body sigma in kn @@ -426,7 +421,7 @@ let declare_mutual_definition l = let fixdefs, fixrs, fixtypes, fixitems = List.fold_right2 (fun (d,r,typ,impargs) name (a1,a2,a3,a4) -> d :: a1, r :: a2, typ :: a3, - DeclareDef.Recthm.{ name; typ; impargs; args = [] } :: a4 + Declare.Recthm.{ name; typ; impargs; args = [] } :: a4 ) defs first.prg_deps ([],[],[],[]) in let fixkind = Option.get first.prg_fixkind in @@ -446,13 +441,13 @@ let declare_mutual_definition l = (* Declare the recursive definitions *) let udecl = UState.default_univ_decl in let kns = - DeclareDef.declare_mutually_recursive ~scope ~opaque ~kind + Declare.declare_mutually_recursive ~scope ~opaque ~kind ~udecl ~ntns ~uctx:first.prg_ctx ~rec_declaration ~possible_indexes ~poly ~restrict_ucontext:false fixitems in (* Only for the first constant *) let dref = List.hd kns in - DeclareDef.Hook.(call ?hook:first.prg_hook { S.uctx = first.prg_ctx; obls; scope; dref }); + Declare.Hook.(call ?hook:first.prg_hook { S.uctx = first.prg_ctx; obls; scope; dref }); List.iter progmap_remove l; dref @@ -556,7 +551,7 @@ let obligation_terminator entries uctx { name; num; auto } = (* Similar to the terminator but for interactive paths, as the terminator is only called in interactive proof mode *) -let obligation_hook prg obl num auto { DeclareDef.Hook.S.uctx = ctx'; dref; _ } = +let obligation_hook prg obl num auto { Declare.Hook.S.uctx = ctx'; dref; _ } = let { obls; remaining=rem } = prg.prg_obligations in let cst = match dref with GlobRef.ConstRef cst -> cst | _ -> assert false in let transparent = evaluable_constant cst (Global.env ()) in diff --git a/vernac/declareObl.mli b/vernac/declareObl.mli index 16c0413caf..03f0a57bcb 100644 --- a/vernac/declareObl.mli +++ b/vernac/declareObl.mli @@ -52,22 +52,22 @@ module ProgramDecl : sig ; prg_implicits : Impargs.manual_implicits ; prg_notations : Vernacexpr.decl_notation list ; prg_poly : bool - ; prg_scope : DeclareDef.locality + ; prg_scope : Declare.locality ; prg_kind : Decls.definition_object_kind ; prg_reduce : constr -> constr - ; prg_hook : DeclareDef.Hook.t option + ; prg_hook : Declare.Hook.t option ; prg_opaque : bool } val make : ?opaque:bool - -> ?hook:DeclareDef.Hook.t + -> ?hook:Declare.Hook.t -> Names.Id.t -> udecl:UState.universe_decl -> uctx:UState.t -> impargs:Impargs.manual_implicits -> poly:bool - -> scope:DeclareDef.locality + -> scope:Declare.locality -> kind:Decls.definition_object_kind -> Constr.constr option -> Constr.types @@ -126,7 +126,7 @@ val obligation_hook -> Obligation.t -> Int.t -> (Names.Id.t option -> Int.Set.t -> 'a option -> 'b) - -> DeclareDef.Hook.S.t + -> Declare.Hook.S.t -> unit (** [obligation_hook] part 2 of saving an obligation, non-interactive mode *) diff --git a/vernac/declareUniv.ml b/vernac/declareUniv.ml index 89f3503f4d..1705915e70 100644 --- a/vernac/declareUniv.ml +++ b/vernac/declareUniv.ml @@ -10,6 +10,17 @@ open Names +(* object_kind , id *) +exception AlreadyDeclared of (string option * Id.t) + +let _ = CErrors.register_handler (function + | AlreadyDeclared (kind, id) -> + Some + Pp.(seq [ Pp.pr_opt_no_spc (fun s -> str s ++ spc ()) kind + ; Id.print id; str " already exists."]) + | _ -> + None) + type universe_source = | BoundUniv (* polymorphic universe, bound in a function (this will go away someday) *) | QualifiedUniv of Id.t (* global universe introduced by some global value *) @@ -19,7 +30,7 @@ type universe_name_decl = universe_source * (Id.t * Univ.Level.UGlobal.t) list let check_exists_universe sp = if Nametab.exists_universe sp then - raise (Declare.AlreadyDeclared (Some "Universe", Libnames.basename sp)) + raise (AlreadyDeclared (Some "Universe", Libnames.basename sp)) else () let qualify_univ i dp src id = diff --git a/vernac/declareUniv.mli b/vernac/declareUniv.mli index 51f3f5e0fb..e4d1d5dc65 100644 --- a/vernac/declareUniv.mli +++ b/vernac/declareUniv.mli @@ -10,6 +10,9 @@ open Names +(* object_kind , id *) +exception AlreadyDeclared of (string option * Id.t) + (** Global universe contexts, names and constraints *) val declare_univ_binders : GlobRef.t -> UnivNames.universe_binders -> unit diff --git a/vernac/g_proofs.mlg b/vernac/g_proofs.mlg index e84fce5504..80a4de472c 100644 --- a/vernac/g_proofs.mlg +++ b/vernac/g_proofs.mlg @@ -14,7 +14,6 @@ open Glob_term open Constrexpr open Vernacexpr open Hints -open ComHints open Pcoq open Pcoq.Prim @@ -98,7 +97,7 @@ GRAMMAR EXTEND Gram | IDENT "Guarded" -> { VernacCheckGuard } (* Hints for Auto and EAuto *) | IDENT "Create"; IDENT "HintDb" ; - id = IDENT ; b = [ "discriminated" -> { true } | -> { false } ] -> + id = IDENT ; b = [ IDENT "discriminated" -> { true } | -> { false } ] -> { VernacCreateHintDb (id, b) } | IDENT "Remove"; IDENT "Hints"; ids = LIST1 global; dbnames = opt_hintbases -> { VernacRemoveHints (dbnames, ids) } diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 3cb10364b5..42259cee10 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -30,9 +30,6 @@ open Pcoq.Module open Pvernac.Vernac_ open Attributes -let vernac_kw = [ ";"; ","; ">->"; ":<"; "<:"; "where"; "at" ] -let _ = List.iter CLexer.add_keyword vernac_kw - (* Rem: do not join the different GEXTEND into one, it breaks native *) (* compilation on PowerPC and Sun architectures *) @@ -790,12 +787,6 @@ GRAMMAR EXTEND Gram { List.map (fun name -> (name.CAst.v, MaxImplicit)) items } ] ]; - strategy_level: - [ [ IDENT "expand" -> { Conv_oracle.Expand } - | IDENT "opaque" -> { Conv_oracle.Opaque } - | n=integer -> { Conv_oracle.Level n } - | IDENT "transparent" -> { Conv_oracle.transparent } ] ] - ; instance_name: [ [ name = ident_decl; bl = binders -> { (CAst.map (fun id -> Name id) (fst name), snd name), bl } diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 41f2ab9c63..9d67ce3757 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -1096,7 +1096,7 @@ let explain_typeclass_error env sigma = function (* Refiner errors *) let explain_refiner_bad_type env sigma arg ty conclty = - let pm, pn = with_diffs (pr_lconstr_env env sigma ty) (pr_lconstr_env env sigma conclty) in + let pm, pn = with_diffs (pr_lconstr_env env sigma ty) (pr_leconstr_env env sigma conclty) in str "Refiner was given an argument" ++ brk(1,1) ++ pr_lconstr_env env sigma arg ++ spc () ++ str "of type" ++ brk(1,1) ++ pm ++ spc () ++ @@ -1112,16 +1112,9 @@ let explain_refiner_cannot_apply env sigma t harg = pr_lconstr_env env sigma t ++ spc () ++ str "could not be applied to" ++ brk(1,1) ++ pr_lconstr_env env sigma harg ++ str "." -let explain_refiner_not_well_typed env sigma c = - str "The term " ++ pr_lconstr_env env sigma c ++ str " is not well-typed." - let explain_intro_needs_product () = str "Introduction tactics needs products." -let explain_does_not_occur_in env sigma c hyp = - str "The term" ++ spc () ++ pr_lconstr_env env sigma c ++ spc () ++ - str "does not occur in" ++ spc () ++ Id.print hyp ++ str "." - let explain_non_linear_proof env sigma c = str "Cannot refine with term" ++ brk(1,1) ++ pr_lconstr_env env sigma c ++ spc () ++ str "because a metavariable has several occurrences." @@ -1137,9 +1130,7 @@ let explain_refiner_error env sigma = function | BadType (arg,ty,conclty) -> explain_refiner_bad_type env sigma arg ty conclty | UnresolvedBindings t -> explain_refiner_unresolved_bindings t | CannotApply (t,harg) -> explain_refiner_cannot_apply env sigma t harg - | NotWellTyped c -> explain_refiner_not_well_typed env sigma c | IntroNeedsProduct -> explain_intro_needs_product () - | DoesNotOccurIn (c,hyp) -> explain_does_not_occur_in env sigma c hyp | NonLinearProof c -> explain_non_linear_proof env sigma c | MetaInType c -> explain_meta_in_type env sigma c | NoSuchHyp id -> explain_no_such_hyp id diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index 6ffa88874b..356ccef06b 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -142,7 +142,7 @@ let try_declare_scheme what f internal names kn = | UndefinedCst s -> alarm what internal (strbrk "Required constant " ++ str s ++ str " undefined.") - | AlreadyDeclared (kind, id) as exn -> + | DeclareUniv.AlreadyDeclared (kind, id) as exn -> let msg = CErrors.print exn in alarm what internal msg | DecidabilityMutualNotSupported -> diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index b13e5bf653..838496c595 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -39,17 +39,17 @@ end module Info = struct type t = - { hook : DeclareDef.Hook.t option + { hook : Declare.Hook.t option ; proof_ending : Proof_ending.t CEphemeron.key (* This could be improved and the CEphemeron removed *) - ; scope : DeclareDef.locality + ; scope : Declare.locality ; kind : Decls.logical_kind (* thms and compute guard are specific only to start_lemma_with_initialization + regular terminator *) - ; thms : DeclareDef.Recthm.t list + ; thms : Declare.Recthm.t list ; compute_guard : lemma_possible_guards } - let make ?hook ?(proof_ending=Proof_ending.Regular) ?(scope=DeclareDef.Global Declare.ImportDefaultBehavior) + let make ?hook ?(proof_ending=Proof_ending.Regular) ?(scope=Declare.Global Declare.ImportDefaultBehavior) ?(kind=Decls.(IsProof Lemma)) () = { hook ; compute_guard = [] @@ -98,7 +98,7 @@ let initialize_named_context_for_proof () = let add_first_thm ~info ~name ~typ ~impargs = let thms = - { DeclareDef.Recthm.name + { Declare.Recthm.name ; impargs ; typ = EConstr.Unsafe.to_constr typ ; args = [] } :: info.Info.thms @@ -128,7 +128,7 @@ let start_dependent_lemma ~name ~poly let rec_tac_initializer finite guard thms snl = if finite then - match List.map (fun { DeclareDef.Recthm.name; typ } -> name, (EConstr.of_constr typ)) thms with + match List.map (fun { Declare.Recthm.name; typ } -> name, (EConstr.of_constr typ)) thms with | (id,_)::l -> Tactics.mutual_cofix id l 0 | _ -> assert false else @@ -136,12 +136,12 @@ let rec_tac_initializer finite guard thms snl = let nl = match snl with | None -> List.map succ (List.map List.last guard) | Some nl -> nl - in match List.map2 (fun { DeclareDef.Recthm.name; typ } n -> (name, n, (EConstr.of_constr typ))) thms nl with + in match List.map2 (fun { Declare.Recthm.name; typ } n -> (name, n, (EConstr.of_constr typ))) thms nl with | (id,n,_)::l -> Tactics.mutual_fix id n l 0 | _ -> assert false let start_lemma_with_initialization ?hook ~poly ~scope ~kind ~udecl sigma recguard thms snl = - let intro_tac { DeclareDef.Recthm.args; _ } = Tactics.auto_intros_tac args in + let intro_tac { Declare.Recthm.args; _ } = Tactics.auto_intros_tac args in let init_tac, compute_guard = match recguard with | Some (finite,guard,init_terms) -> let rec_tac = rec_tac_initializer finite guard thms snl in @@ -161,7 +161,7 @@ let start_lemma_with_initialization ?hook ~poly ~scope ~kind ~udecl sigma recgua intro_tac (List.hd thms), [] in match thms with | [] -> CErrors.anomaly (Pp.str "No proof to start.") - | { DeclareDef.Recthm.name; typ; impargs; _} :: thms -> + | { Declare.Recthm.name; typ; impargs; _} :: thms -> let info = Info.{ hook ; compute_guard @@ -200,7 +200,7 @@ module MutualEntry : sig end = struct - (* XXX: Refactor this with the code in [DeclareDef.declare_mutdef] *) + (* XXX: Refactor this with the code in [Declare.declare_mutdef] *) let guess_decreasing env possible_indexes ((body, ctx), eff) = let open Constr in match Constr.kind body with @@ -220,7 +220,7 @@ end = struct Pp.(str "Not a proof by induction: " ++ Termops.Internal.debug_print_constr (EConstr.of_constr t) ++ str ".") - let declare_mutdef ~uctx ~info pe i DeclareDef.Recthm.{ name; impargs; typ; _} = + let declare_mutdef ~uctx ~info pe i Declare.Recthm.{ name; impargs; typ; _} = let { Info.hook; scope; kind; compute_guard; _ } = info in (* if i = 0 , we don't touch the type; this is for compat but not clear it is the right thing to do. @@ -238,7 +238,7 @@ end = struct Declare.Internal.map_entry_body pe ~f:(fun ((body, ctx), eff) -> (select_body i body, ctx), eff) in - DeclareDef.declare_entry ~name ~scope ~kind ?hook ~impargs ~uctx pe + Declare.declare_entry ~name ~scope ~kind ?hook ~impargs ~uctx pe let declare_mutdef ~info ~uctx const = let pe = match info.Info.compute_guard with @@ -256,8 +256,8 @@ end = struct let declare_variable ~info ~uctx pe = let { Info.scope; hook } = info in List.map_i ( - fun i { DeclareDef.Recthm.name; typ; impargs } -> - DeclareDef.declare_assumption ~name ~scope ~hook ~impargs ~uctx pe + fun i { Declare.Recthm.name; typ; impargs } -> + Declare.declare_assumption ~name ~scope ~hook ~impargs ~uctx pe ) 0 info.Info.thms end @@ -395,8 +395,8 @@ let process_idopt_for_save ~idopt info = (* Save foo was used; we override the info in the first theorem *) let thms = match info.Info.thms, CEphemeron.default info.Info.proof_ending Proof_ending.Regular with - | [ { DeclareDef.Recthm.name; _} as decl ], Proof_ending.Regular -> - [ { decl with DeclareDef.Recthm.name = save_name } ] + | [ { Declare.Recthm.name; _} as decl ], Proof_ending.Regular -> + [ { decl with Declare.Recthm.name = save_name } ] | _ -> err_save_forbidden_in_place_of_qed () in { info with Info.thms } diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index bd2e87ac3a..b1462f1ce5 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -49,11 +49,11 @@ module Info : sig type t val make - : ?hook: DeclareDef.Hook.t + : ?hook: Declare.Hook.t (** Callback to be executed at the end of the proof *) -> ?proof_ending : Proof_ending.t (** Info for special constants *) - -> ?scope : DeclareDef.locality + -> ?scope : Declare.locality (** locality *) -> ?kind:Decls.logical_kind (** Theorem, etc... *) @@ -85,14 +85,14 @@ type lemma_possible_guards = int list list (** Pretty much internal, used by the Lemma / Fixpoint vernaculars *) val start_lemma_with_initialization - : ?hook:DeclareDef.Hook.t + : ?hook:Declare.Hook.t -> poly:bool - -> scope:DeclareDef.locality + -> scope:Declare.locality -> kind:Decls.logical_kind -> udecl:UState.universe_decl -> Evd.evar_map -> (bool * lemma_possible_guards * Constr.t option list option) option - -> DeclareDef.Recthm.t list + -> Declare.Recthm.t list -> int list option -> t diff --git a/vernac/library.ml b/vernac/library.ml index 85db501e84..c30331b221 100644 --- a/vernac/library.ml +++ b/vernac/library.ml @@ -89,6 +89,7 @@ type library_disk = { type summary_disk = { md_name : compilation_unit_name; md_deps : (compilation_unit_name * Safe_typing.vodigest) array; + md_ocaml : string; } (*s Modules loaded in memory contain the following informations. They are @@ -251,6 +252,7 @@ let intern_from_file f = let (univs : seg_univ option), digest_u = ObjFile.marshal_in_segment ch ~segment:"universes" in let ((del_opaque : seg_proofs delayed),_) = in_delayed f ch ~segment:"opaques" in ObjFile.close_in ch; + System.check_caml_version ~caml:lsd.md_ocaml ~file:f; register_library_filename lsd.md_name f; add_opaque_table lsd.md_name (ToFetch del_opaque); let open Safe_typing in @@ -401,6 +403,7 @@ let load_library_todo f = let tasks, _ = ObjFile.marshal_in_segment ch ~segment:"tasks" in let (s4 : seg_proofs), _ = ObjFile.marshal_in_segment ch ~segment:"opaques" in ObjFile.close_in ch; + System.check_caml_version ~caml:s0.md_ocaml ~file:f; if tasks = None then user_err ~hdr:"restart" (str"not a .vio file"); if s2 = None then user_err ~hdr:"restart" (str"not a .vio file"); if snd (Option.get s2) then user_err ~hdr:"restart" (str"not a .vio file"); @@ -486,6 +489,7 @@ let save_library_to todo_proofs ~output_native_objects dir f otab = let sd = { md_name = dir; md_deps = Array.of_list (current_deps ()); + md_ocaml = Coq_config.caml_version; } in let md = { md_compiled = cenv; diff --git a/vernac/locality.ml b/vernac/locality.ml index 9e784c8bb3..f62eed5e41 100644 --- a/vernac/locality.ml +++ b/vernac/locality.ml @@ -34,7 +34,7 @@ let warn_local_declaration = strbrk "available without qualification when imported.") let enforce_locality_exp locality_flag discharge = - let open DeclareDef in + let open Declare in let open Vernacexpr in match locality_flag, discharge with | Some b, NoDischarge -> Global (importability_of_bool b) diff --git a/vernac/locality.mli b/vernac/locality.mli index 26149cb394..bf65579efd 100644 --- a/vernac/locality.mli +++ b/vernac/locality.mli @@ -20,7 +20,7 @@ val make_locality : bool option -> bool val make_non_locality : bool option -> bool -val enforce_locality_exp : bool option -> Vernacexpr.discharge -> DeclareDef.locality +val enforce_locality_exp : bool option -> Vernacexpr.discharge -> Declare.locality val enforce_locality : bool option -> bool (** For commands whose default is to not discharge but to export: diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 3b9c771b93..8435612abd 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -1073,12 +1073,12 @@ let make_internalization_vars recvars mainvars typs = let extratyps = List.map (fun (x,y) -> (y,List.assoc x maintyps)) recvars in maintyps @ extratyps -let make_interpretation_type isrec isonlybinding = function +let make_interpretation_type isrec isonlybinding default_if_binding = function (* Parsed as constr list *) | ETConstr (_,None,_) when isrec -> NtnTypeConstrList - (* Parsed as constr, but interpreted as a binder: default is to parse it as an ident only *) + (* Parsed as constr, but interpreted as a binder *) | ETConstr (_,Some bk,_) -> NtnTypeBinder (NtnBinderParsedAsConstr bk) - | ETConstr (_,None,_) when isonlybinding -> NtnTypeBinder (NtnBinderParsedAsConstr AsIdent) + | ETConstr (_,None,_) when isonlybinding -> NtnTypeBinder (NtnBinderParsedAsConstr default_if_binding) (* Parsed as constr, interpreted as constr *) | ETConstr (_,None,_) -> NtnTypeConstr (* Others *) @@ -1096,7 +1096,9 @@ let subentry_of_constr_prod_entry = function | ETConstr (InConstrEntry,_,_) -> InConstrEntrySomeLevel | _ -> InConstrEntrySomeLevel -let make_interpretation_vars recvars allvars typs = +let make_interpretation_vars + (* For binders, default is to parse only as an ident *) ?(default_if_binding=AsIdent) + recvars allvars typs = let eq_subscope (sc1, l1) (sc2, l2) = Option.equal String.equal sc1 sc2 && List.equal String.equal l1 l2 @@ -1113,7 +1115,7 @@ let make_interpretation_vars recvars allvars typs = Id.Map.mapi (fun x (isonlybinding, sc) -> let typ = Id.List.assoc x typs in ((subentry_of_constr_prod_entry typ,sc), - make_interpretation_type (Id.List.mem_assoc x recvars) isonlybinding typ)) mainvars + make_interpretation_type (Id.List.mem_assoc x recvars) isonlybinding default_if_binding typ)) mainvars let check_rule_productivity l = if List.for_all (function NonTerminal _ | Break _ -> true | _ -> false) l then @@ -1755,7 +1757,8 @@ let cache_scope_command o = 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 env = Global.env () in + let cl' = List.map_filter (subst_scope_class env subst) cl in let cl' = if List.for_all2eq (==) cl cl' then cl else cl' in @@ -1792,8 +1795,8 @@ let try_interp_name_alias = function | _ -> raise Not_found let add_syntactic_definition ~local deprecation env ident (vars,c) { onlyparsing } = - let vars,reversibility,pat = - try [], APrioriReversible, NRef (try_interp_name_alias (vars,c)) + let acvars,pat,reversibility = + try Id.Map.empty, NRef (try_interp_name_alias (vars,c)), APrioriReversible with Not_found -> let fold accu id = Id.Map.add id NtnInternTypeAny accu in let i_vars = List.fold_left fold Id.Map.empty vars in @@ -1801,10 +1804,11 @@ let add_syntactic_definition ~local deprecation env ident (vars,c) { onlyparsing ninterp_var_type = i_vars; ninterp_rec_vars = Id.Map.empty; } in - let nvars, pat, reversibility = interp_notation_constr env nenv c in - let map id = let (_,sc) = Id.Map.find id nvars in (id, sc) in - List.map map vars, reversibility, pat + interp_notation_constr env nenv c in + let in_pat id = (id,ETConstr (Constrexpr.InConstrEntry,None,(NextLevel,0))) in + let interp = make_interpretation_vars ~default_if_binding:AsIdentOrPattern [] acvars (List.map in_pat vars) in + let vars = List.map (fun x -> (x, Id.Map.find x interp)) vars in let onlyparsing = onlyparsing || fst (printability None false reversibility pat) in Syntax_def.declare_syntactic_definition ~local deprecation ident ~onlyparsing (vars,pat) diff --git a/vernac/obligations.ml b/vernac/obligations.ml index bed593234b..5e746afc74 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -162,13 +162,13 @@ let rec solve_obligation prg num tac = ++ str (string_of_list ", " (fun x -> string_of_int (succ x)) remaining)); in let obl = subst_deps_obl obls obl in - let scope = DeclareDef.(Global Declare.ImportNeedQualified) in + let scope = Declare.(Global Declare.ImportNeedQualified) in let kind = kind_of_obligation (snd obl.obl_status) in let evd = Evd.from_ctx prg.prg_ctx in let evd = Evd.update_sigma_env evd (Global.env ()) in let auto n oblset tac = auto_solve_obligations n ~oblset tac in let proof_ending = Lemmas.Proof_ending.End_obligation (DeclareObl.{name = prg.prg_name; num; auto}) in - let hook = DeclareDef.Hook.make (DeclareObl.obligation_hook prg obl num auto) in + let hook = Declare.Hook.make (DeclareObl.obligation_hook prg obl num auto) in let info = Lemmas.Info.make ~hook ~proof_ending ~scope ~kind () in let poly = prg.prg_poly in let lemma = Lemmas.start_lemma ~name:obl.obl_name ~poly ~info evd (EConstr.of_constr obl.obl_type) in @@ -309,7 +309,7 @@ let show_term n = ++ Printer.pr_constr_env env sigma prg.prg_body) let add_definition ~name ?term t ~uctx ?(udecl=UState.default_univ_decl) - ?(impargs=[]) ~poly ?(scope=DeclareDef.Global Declare.ImportDefaultBehavior) ?(kind=Decls.Definition) ?tactic + ?(impargs=[]) ~poly ?(scope=Declare.Global Declare.ImportDefaultBehavior) ?(kind=Decls.Definition) ?tactic ?(reduce=reduce) ?hook ?(opaque = false) obls = let info = Id.print name ++ str " has type-checked" in let prg = ProgramDecl.make ~opaque name ~udecl term t ~uctx [] None [] obls ~impargs ~poly ~scope ~kind reduce ?hook in @@ -328,11 +328,11 @@ let add_definition ~name ?term t ~uctx ?(udecl=UState.default_univ_decl) | _ -> res) let add_mutual_definitions l ~uctx ?(udecl=UState.default_univ_decl) ?tactic - ~poly ?(scope=DeclareDef.Global Declare.ImportDefaultBehavior) ?(kind=Decls.Definition) ?(reduce=reduce) + ~poly ?(scope=Declare.Global Declare.ImportDefaultBehavior) ?(kind=Decls.Definition) ?(reduce=reduce) ?hook ?(opaque = false) notations fixkind = - let deps = List.map (fun ({ DeclareDef.Recthm.name; _ }, _, _) -> name) l in + let deps = List.map (fun ({ Declare.Recthm.name; _ }, _, _) -> name) l in List.iter - (fun ({ DeclareDef.Recthm.name; typ; impargs; _ }, b, obls) -> + (fun ({ Declare.Recthm.name; typ; impargs; _ }, b, obls) -> let prg = ProgramDecl.make ~opaque name ~udecl (Some b) typ ~uctx deps (Some fixkind) notations obls ~impargs ~poly ~scope ~kind reduce ?hook in progmap_add name (CEphemeron.create prg)) l; diff --git a/vernac/obligations.mli b/vernac/obligations.mli index f42d199e18..89ed4c3498 100644 --- a/vernac/obligations.mli +++ b/vernac/obligations.mli @@ -77,11 +77,11 @@ val add_definition : -> ?udecl:UState.universe_decl (** Universe binders and constraints *) -> ?impargs:Impargs.manual_implicits -> poly:bool - -> ?scope:DeclareDef.locality + -> ?scope:Declare.locality -> ?kind:Decls.definition_object_kind -> ?tactic:unit Proofview.tactic -> ?reduce:(constr -> constr) - -> ?hook:DeclareDef.Hook.t + -> ?hook:Declare.Hook.t -> ?opaque:bool -> RetrieveObl.obligation_info -> DeclareObl.progress @@ -91,15 +91,15 @@ val add_definition : (** Start a [Program Fixpoint] declaration, similar to the above, except it takes a list now. *) val add_mutual_definitions : - (DeclareDef.Recthm.t * Constr.t * RetrieveObl.obligation_info) list + (Declare.Recthm.t * Constr.t * RetrieveObl.obligation_info) list -> uctx:UState.t -> ?udecl:UState.universe_decl (** Universe binders and constraints *) -> ?tactic:unit Proofview.tactic -> poly:bool - -> ?scope:DeclareDef.locality + -> ?scope:Declare.locality -> ?kind:Decls.definition_object_kind -> ?reduce:(constr -> constr) - -> ?hook:DeclareDef.Hook.t + -> ?hook:Declare.Hook.t -> ?opaque:bool -> Vernacexpr.decl_notation list -> DeclareObl.fixpoint_kind diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index f1aae239aa..b97cdfa51c 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -185,7 +185,7 @@ open Pputils | [] -> mt() | _ as z -> str":" ++ spc() ++ prlist_with_sep sep str z - let pr_reference_or_constr pr_c = let open ComHints in function + let pr_reference_or_constr pr_c = function | HintsReference r -> pr_qualid r | HintsConstr c -> pr_c c @@ -202,7 +202,6 @@ open Pputils let opth = pr_opt_hintbases db in let pph = let open Hints in - let open ComHints in match h with | HintsResolve l -> keyword "Resolve " ++ prlist_with_sep sep @@ -792,7 +791,6 @@ let string_of_definition_object_kind = let open Decls in function return (keyword "Admitted") | VernacEndProof (Proved (opac,o)) -> return ( - let open Declare in match o with | None -> (match opac with | Transparent -> keyword "Defined" diff --git a/vernac/prettyp.ml b/vernac/prettyp.ml index a7170c8e18..faf53d3fad 100644 --- a/vernac/prettyp.ml +++ b/vernac/prettyp.ml @@ -906,7 +906,7 @@ let print_name env sigma na udecl = match na with | {loc; v=Constrexpr.ByNotation (ntn,sc)} -> print_any_name env sigma - (Term (Notation.interp_notation_as_global_reference ?loc (fun _ -> true) + (Term (Notation.interp_notation_as_global_reference ?loc ~head:false (fun _ -> true) ntn sc)) udecl | {loc; v=Constrexpr.AN ref} -> @@ -960,7 +960,7 @@ let print_about env sigma na udecl = match na with | {loc;v=Constrexpr.ByNotation (ntn,sc)} -> print_about_any ?loc env sigma - (Term (Notation.interp_notation_as_global_reference ?loc (fun _ -> true) + (Term (Notation.interp_notation_as_global_reference ?loc ~head:false (fun _ -> true) ntn sc)) udecl | {loc;v=Constrexpr.AN ref} -> print_about_any ?loc env sigma (locate_any_name ref) udecl diff --git a/vernac/pvernac.mli b/vernac/pvernac.mli index 2b6beaf2e3..1718024edd 100644 --- a/vernac/pvernac.mli +++ b/vernac/pvernac.mli @@ -28,7 +28,7 @@ module Vernac_ : val command_entry : vernac_expr Entry.t val main_entry : vernac_control option Entry.t val red_expr : raw_red_expr Entry.t - val hint_info : ComHints.hint_info_expr Entry.t + val hint_info : hint_info_expr Entry.t end (* To be removed when the parser is made functional wrt the tactic diff --git a/vernac/record.ml b/vernac/record.ml index 9fda98d08e..36254780cd 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -121,7 +121,7 @@ let typecheck_params_and_fields def poly pl ps records = any Set <= i constraint for universes that might actually be instantiated with Prop. *) let is_template = List.exists (fun (_, arity, _, _) -> Option.cata check_anonymous_type true arity) records in - let env0 = if not poly && is_template then Environ.set_universes_lbound env0 Univ.Level.prop else env0 in + let env0 = if not poly && is_template then Environ.set_universes_lbound env0 UGraph.Bound.Prop else env0 in let sigma, decl = Constrexpr_ops.interp_univ_decl_opt env0 pl in let () = let error bk {CAst.loc; v=name} = diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index 6d5d16d94a..618a61f487 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -9,16 +9,15 @@ Himsg Locality Egramml Vernacextend -Declare -ComHints Ppvernac Proof_using Egramcoq Metasyntax DeclareUniv RetrieveObl -DeclareDef +Declare DeclareObl +ComHints Canonical RecLemmas Library @@ -48,3 +47,4 @@ Vernacstate Vernacinterp Proof_global Pfedit +DeclareDef diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index df94f69cf6..09201d727d 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -95,8 +95,14 @@ let show_proof ~pstate = try let pstate = Option.get pstate in let p = Declare.Proof.get_proof pstate in - let sigma, env = Declare.get_current_context pstate in + let sigma, _ = Declare.get_current_context pstate in let pprf = Proof.partial_proof p in + (* In the absence of an environment explicitly attached to the + proof and on top of which side effects of the proof would be pushed, , + we take the global environment which in practise should be a + superset of the initial environment in which the proof was + started *) + let env = Global.env() in Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf (* We print nothing if there are no goals left *) with @@ -460,7 +466,7 @@ let vernac_custom_entry ~module_local s = let check_name_freshness locality {CAst.loc;v=id} : unit = (* We check existence here: it's a bit late at Qed time *) if Nametab.exists_cci (Lib.make_path id) || Termops.is_section_variable id || - locality <> DeclareDef.Discharge && Nametab.exists_cci (Lib.make_path_except_section id) + locality <> Declare.Discharge && Nametab.exists_cci (Lib.make_path_except_section id) then user_err ?loc (Id.print id ++ str " already exists.") @@ -504,7 +510,7 @@ let start_lemma_com ~program_mode ~poly ~scope ~kind ?hook thms = let recguard,thms,snl = RecLemmas.look_for_possibly_mutual_statements evd thms in let evd = Evd.minimize_universes evd in let thms = List.map (fun (name, (typ, (args, impargs))) -> - { DeclareDef.Recthm.name; typ = EConstr.to_constr evd typ; args; impargs} ) thms in + { Declare.Recthm.name; typ = EConstr.to_constr evd typ; args; impargs} ) thms in let () = let open UState in if not (udecl.univdecl_extensible_instance && udecl.univdecl_extensible_constraints) then @@ -521,13 +527,13 @@ let vernac_definition_hook ~canonical_instance ~local ~poly = let open Decls in | Coercion -> Some (ComCoercion.add_coercion_hook ~poly) | CanonicalStructure -> - Some (DeclareDef.Hook.(make (fun { S.dref } -> Canonical.declare_canonical_structure ?local dref))) + Some (Declare.Hook.(make (fun { S.dref } -> Canonical.declare_canonical_structure ?local dref))) | SubClass -> Some (ComCoercion.add_subclass_hook ~poly) | Definition when canonical_instance -> - Some (DeclareDef.Hook.(make (fun { S.dref } -> Canonical.declare_canonical_structure ?local dref))) + Some (Declare.Hook.(make (fun { S.dref } -> Canonical.declare_canonical_structure ?local dref))) | Let when canonical_instance -> - Some (DeclareDef.Hook.(make (fun { S.dref } -> Canonical.declare_canonical_structure dref))) + Some (Declare.Hook.(make (fun { S.dref } -> Canonical.declare_canonical_structure dref))) | _ -> None let default_thm_id = Id.of_string "Unnamed_thm" @@ -542,7 +548,7 @@ let vernac_definition_name lid local = CAst.make ?loc (fresh_name_for_anonymous_theorem ()) | { v = Name.Name n; loc } -> CAst.make ?loc n in let () = - let open DeclareDef in + let open Declare in match local with | Discharge -> Dumpglob.dump_definition lid true "var" | Global _ -> Dumpglob.dump_definition lid false "def" @@ -603,8 +609,8 @@ let vernac_assumption ~atts discharge kind l nl = if Dumpglob.dump () then List.iter (fun (lid, _) -> match scope with - | DeclareDef.Global _ -> Dumpglob.dump_definition lid false "ax" - | DeclareDef.Discharge -> Dumpglob.dump_definition lid true "var") idl) l; + | Declare.Global _ -> Dumpglob.dump_definition lid false "ax" + | Declare.Discharge -> Dumpglob.dump_definition lid true "var") idl) l; ComAssumption.do_assumptions ~poly:atts.polymorphic ~program_mode:atts.program ~scope ~kind nl l let is_polymorphic_inductive_cumulativity = @@ -1779,7 +1785,7 @@ let interp_search_about_item env sigma = try let ref = Notation.interp_notation_as_global_reference - (fun _ -> true) s sc in + ~head:false (fun _ -> true) s sc in GlobSearchSubPattern (Pattern.PRef ref) with UserError _ -> user_err ~hdr:"interp_search_about_item" diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index b65a0da1cc..b622fd9801 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -195,10 +195,12 @@ type syntax_modifier = | SetOnlyPrinting | SetFormat of string * lstring +type opacity_flag = Opaque | Transparent + type proof_end = | Admitted (* name in `Save ident` when closing goal *) - | Proved of Declare.opacity_flag * lident option + | Proved of opacity_flag * lident option type scheme = | InductionScheme of bool * qualid or_by_notation * sort_expr @@ -286,6 +288,22 @@ type extend_name = type discharge = DoDischarge | NoDischarge +type hint_info_expr = Constrexpr.constr_pattern_expr Typeclasses.hint_info_gen + +type reference_or_constr = + | HintsReference of Libnames.qualid + | HintsConstr of Constrexpr.constr_expr + +type hints_expr = + | HintsResolve of (hint_info_expr * bool * reference_or_constr) list + | HintsResolveIFF of bool * Libnames.qualid list * int option + | HintsImmediate of reference_or_constr list + | HintsUnfold of Libnames.qualid list + | HintsTransparency of Libnames.qualid Hints.hints_transparency_target * bool + | HintsMode of Libnames.qualid * Hints.hint_mode list + | HintsConstructors of Libnames.qualid list + | HintsExtern of int * Constrexpr.constr_expr option * Genarg.raw_generic_argument + type nonrec vernac_expr = | VernacLoad of verbose_flag * string @@ -336,18 +354,18 @@ type nonrec vernac_expr = local_binder_expr list * (* binders *) constr_expr * (* type *) (bool * constr_expr) option * (* body (bool=true when using {}) *) - ComHints.hint_info_expr + hint_info_expr | VernacDeclareInstance of ident_decl * (* name *) local_binder_expr list * (* binders *) constr_expr * (* type *) - ComHints.hint_info_expr + hint_info_expr | VernacContext of local_binder_expr list | VernacExistingInstance of - (qualid * ComHints.hint_info_expr) list (* instances names, priorities and patterns *) + (qualid * hint_info_expr) list (* instances names, priorities and patterns *) | VernacExistingClass of qualid (* inductive or definition name *) @@ -387,7 +405,7 @@ type nonrec vernac_expr = (* Commands *) | VernacCreateHintDb of string * bool | VernacRemoveHints of string list * qualid list - | VernacHints of string list * ComHints.hints_expr + | VernacHints of string list * hints_expr | VernacSyntacticDefinition of lident * (Id.t list * constr_expr) * onlyparsing_flag |